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

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

/-!
# Relation chain

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

This file provides basic results about `list.chain` (definition in `data.list.defs`).
A list `[a₂, ..., aₙ]` is a `chain` starting at `a₁` with respect to the relation `r` if `r a₁ a₂`
and `r a₂ a₃` and ... and `r aₙ₋₁ aₙ`. We write it `chain r a₁ [a₂, ..., aₙ]`.
A graph-specialized version is in development and will hopefully be added under `combinatorics.`
sometime soon.
-/

universe u v

open Nat

namespace List

variable {α : Type u} {β : Type v} {R r : α → α → Prop} {l l₁ l₂ : List α} {a b : α}

mk_iff_of_inductive_prop List.Chain List.chain_iff

#print List.rel_of_chain_cons /-
theorem rel_of_chain_cons {a b : α} {l : List α} (p : Chain R a (b :: l)) : R a b :=
  (chain_cons.1 p).1
#align list.rel_of_chain_cons List.rel_of_chain_cons
-/

#print List.chain_of_chain_cons /-
theorem chain_of_chain_cons {a b : α} {l : List α} (p : Chain R a (b :: l)) : Chain R b l :=
  (chain_cons.1 p).2
#align list.chain_of_chain_cons List.chain_of_chain_cons
-/

#print List.Chain.imp' /-
theorem Chain.imp' {S : α → α → Prop} (HRS : ∀ ⦃a b⦄, R a b → S a b) {a b : α}
    (Hab : ∀ ⦃c⦄, R a c → S b c) {l : List α} (p : Chain R a l) : Chain S b l := by
  induction' p with _ a c l r p IH generalizing b <;> constructor <;> [exact Hab r,
    exact IH (@HRS _)]
#align list.chain.imp' List.Chain.imp'
-/

#print List.Chain.imp /-
theorem Chain.imp {S : α → α → Prop} (H : ∀ a b, R a b → S a b) {a : α} {l : List α}
    (p : Chain R a l) : Chain S a l :=
  p.imp' H (H a)
#align list.chain.imp List.Chain.imp
-/

#print List.Chain.iff /-
theorem Chain.iff {S : α → α → Prop} (H : ∀ a b, R a b ↔ S a b) {a : α} {l : List α} :
    Chain R a l ↔ Chain S a l :=
  ⟨Chain.imp fun a b => (H a b).1, Chain.imp fun a b => (H a b).2⟩
#align list.chain.iff List.Chain.iff
-/

#print List.Chain.iff_mem /-
theorem Chain.iff_mem {a : α} {l : List α} :
    Chain R a l ↔ Chain (fun x y => x ∈ a :: l ∧ y ∈ l ∧ R x y) a l :=
  ⟨fun p => by
    induction' p with _ a b l r p IH <;> constructor <;>
      [exact ⟨mem_cons_self _ _, mem_cons_self _ _, r⟩,
      exact IH.imp fun a b ⟨am, bm, h⟩ => ⟨mem_cons_of_mem _ am, mem_cons_of_mem _ bm, h⟩],
    Chain.imp fun a b h => h.2.2⟩
#align list.chain.iff_mem List.Chain.iff_mem
-/

#print List.chain_singleton /-
theorem chain_singleton {a b : α} : Chain R a [b] ↔ R a b := by
  simp only [chain_cons, chain.nil, and_true_iff]
#align list.chain_singleton List.chain_singleton
-/

#print List.chain_split /-
theorem chain_split {a b : α} {l₁ l₂ : List α} :
    Chain R a (l₁ ++ b :: l₂) ↔ Chain R a (l₁ ++ [b]) ∧ Chain R b l₂ := by
  induction' l₁ with x l₁ IH generalizing a <;>
    simp only [*, nil_append, cons_append, chain.nil, chain_cons, and_true_iff, and_assoc']
#align list.chain_split List.chain_split
-/

#print List.chain_append_cons_cons /-
@[simp]
theorem chain_append_cons_cons {a b c : α} {l₁ l₂ : List α} :
    Chain R a (l₁ ++ b :: c :: l₂) ↔ Chain R a (l₁ ++ [b]) ∧ R b c ∧ Chain R c l₂ := by
  rw [chain_split, chain_cons]
#align list.chain_append_cons_cons List.chain_append_cons_cons
-/

#print List.chain_iff_forall₂ /-
theorem chain_iff_forall₂ :
    ∀ {a : α} {l : List α}, Chain R a l ↔ l = [] ∨ Forall₂ R (a :: dropLast l) l
  | a, [] => by simp
  | a, [b] => by simp [init]
  | a, b :: c :: l => by simp [@chain_iff_forall₂ b]
#align list.chain_iff_forall₂ List.chain_iff_forall₂
-/

#print List.chain_append_singleton_iff_forall₂ /-
theorem chain_append_singleton_iff_forall₂ : Chain R a (l ++ [b]) ↔ Forall₂ R (a :: l) (l ++ [b]) :=
  by simp [chain_iff_forall₂, init]
#align list.chain_append_singleton_iff_forall₂ List.chain_append_singleton_iff_forall₂
-/

#print List.chain_map /-
theorem chain_map (f : β → α) {b : β} {l : List β} :
    Chain R (f b) (map f l) ↔ Chain (fun a b : β => R (f a) (f b)) b l := by
  induction l generalizing b <;> simp only [map, chain.nil, chain_cons, *]
#align list.chain_map List.chain_map
-/

#print List.chain_of_chain_map /-
theorem chain_of_chain_map {S : β → β → Prop} (f : α → β) (H : ∀ a b : α, S (f a) (f b) → R a b)
    {a : α} {l : List α} (p : Chain S (f a) (map f l)) : Chain R a l :=
  ((chain_map f).1 p).imp H
#align list.chain_of_chain_map List.chain_of_chain_map
-/

#print List.chain_map_of_chain /-
theorem chain_map_of_chain {S : β → β → Prop} (f : α → β) (H : ∀ a b : α, R a b → S (f a) (f b))
    {a : α} {l : List α} (p : Chain R a l) : Chain S (f a) (map f l) :=
  (chain_map f).2 <| p.imp H
#align list.chain_map_of_chain List.chain_map_of_chain
-/

#print List.chain_pmap_of_chain /-
theorem chain_pmap_of_chain {S : β → β → Prop} {p : α → Prop} {f : ∀ a, p a → β}
    (H : ∀ a b ha hb, R a b → S (f a ha) (f b hb)) {a : α} {l : List α} (hl₁ : Chain R a l)
    (ha : p a) (hl₂ : ∀ a ∈ l, p a) : Chain S (f a ha) (List.pmap f l hl₂) :=
  by
  induction' l with lh lt l_ih generalizing a
  · simp
  · simp [H _ _ _ _ (rel_of_chain_cons hl₁), l_ih _ (chain_of_chain_cons hl₁)]
#align list.chain_pmap_of_chain List.chain_pmap_of_chain
-/

#print List.chain_of_chain_pmap /-
theorem chain_of_chain_pmap {S : β → β → Prop} {p : α → Prop} (f : ∀ a, p a → β) {l : List α}
    (hl₁ : ∀ a ∈ l, p a) {a : α} (ha : p a) (hl₂ : Chain S (f a ha) (List.pmap f l hl₁))
    (H : ∀ a b ha hb, S (f a ha) (f b hb) → R a b) : Chain R a l :=
  by
  induction' l with lh lt l_ih generalizing a
  · simp
  · simp [H _ _ _ _ (rel_of_chain_cons hl₂), l_ih _ _ (chain_of_chain_cons hl₂)]
#align list.chain_of_chain_pmap List.chain_of_chain_pmap
-/

#print List.Pairwise.chain /-
protected theorem Pairwise.chain (p : Pairwise R (a :: l)) : Chain R a l :=
  by
  cases' pairwise_cons.1 p with r p'; clear p
  induction' p' with b l r' p IH generalizing a; · exact chain.nil
  simp only [chain_cons, forall_mem_cons] at r
  exact chain_cons.2 ⟨r.1, IH r'⟩
#align list.pairwise.chain List.Pairwise.chain
-/

#print List.Chain.pairwise /-
protected theorem Chain.pairwise [IsTrans α R] :
    ∀ {a : α} {l : List α}, Chain R a l → Pairwise R (a :: l)
  | a, [], chain.nil => pairwise_singleton _ _
  | a, _, @chain.cons _ _ _ b l h hb =>
    hb.Pairwise.cons
      (by
        simp only [mem_cons_iff, forall_eq_or_imp, h, true_and_iff]
        exact fun c hc => trans h (rel_of_pairwise_cons hb.pairwise hc))
#align list.chain.pairwise List.Chain.pairwise
-/

#print List.chain_iff_pairwise /-
theorem chain_iff_pairwise [IsTrans α R] {a : α} {l : List α} : Chain R a l ↔ Pairwise R (a :: l) :=
  ⟨Chain.pairwise, Pairwise.chain⟩
#align list.chain_iff_pairwise List.chain_iff_pairwise
-/

#print List.Chain.sublist /-
protected theorem Chain.sublist [IsTrans α R] (hl : l₂.Chain R a) (h : l₁ <+ l₂) : l₁.Chain R a :=
  by
  rw [chain_iff_pairwise] at hl⊢
  exact hl.sublist (h.cons_cons a)
#align list.chain.sublist List.Chain.sublist
-/

#print List.Chain.rel /-
protected theorem Chain.rel [IsTrans α R] (hl : l.Chain R a) (hb : b ∈ l) : R a b :=
  by
  rw [chain_iff_pairwise] at hl
  exact rel_of_pairwise_cons hl hb
#align list.chain.rel List.Chain.rel
-/

#print List.chain_iff_nthLe /-
theorem chain_iff_nthLe {R} :
    ∀ {a : α} {l : List α},
      Chain R a l ↔
        (∀ h : 0 < length l, R a (nthLe l 0 h)) ∧
          ∀ (i) (h : i < length l - 1),
            R (nthLe l i (lt_of_lt_pred h)) (nthLe l (i + 1) (lt_pred_iff.mp h))
  | a, [] => by simp
  | a, b :: t => by
    rw [chain_cons, chain_iff_nth_le]
    constructor
    · rintro ⟨R, ⟨h0, h⟩⟩
      constructor
      · intro w
        exact R
      intro i w
      cases i
      · apply h0
      convert h i _ using 1
      simp only [succ_eq_add_one, add_succ_sub_one, add_zero, length, add_lt_add_iff_right] at w
      exact lt_pred_iff.mpr w
    rintro ⟨h0, h⟩; constructor
    · apply h0
      simp
    constructor
    · apply h 0
    intro i w; convert h (i + 1) _ using 1
    exact lt_pred_iff.mp w
#align list.chain_iff_nth_le List.chain_iff_nthLe
-/

#print List.Chain'.imp /-
theorem Chain'.imp {S : α → α → Prop} (H : ∀ a b, R a b → S a b) {l : List α} (p : Chain' R l) :
    Chain' S l := by cases l <;> [trivial, exact p.imp H]
#align list.chain'.imp List.Chain'.imp
-/

#print List.Chain'.iff /-
theorem Chain'.iff {S : α → α → Prop} (H : ∀ a b, R a b ↔ S a b) {l : List α} :
    Chain' R l ↔ Chain' S l :=
  ⟨Chain'.imp fun a b => (H a b).1, Chain'.imp fun a b => (H a b).2⟩
#align list.chain'.iff List.Chain'.iff
-/

#print List.Chain'.iff_mem /-
theorem Chain'.iff_mem : ∀ {l : List α}, Chain' R l ↔ Chain' (fun x y => x ∈ l ∧ y ∈ l ∧ R x y) l
  | [] => Iff.rfl
  | x :: l =>
    ⟨fun h => (Chain.iff_mem.1 h).imp fun a b ⟨h₁, h₂, h₃⟩ => ⟨h₁, Or.inr h₂, h₃⟩,
      Chain'.imp fun a b h => h.2.2⟩
#align list.chain'.iff_mem List.Chain'.iff_mem
-/

#print List.chain'_nil /-
@[simp]
theorem chain'_nil : Chain' R [] :=
  trivial
#align list.chain'_nil List.chain'_nil
-/

#print List.chain'_singleton /-
@[simp]
theorem chain'_singleton (a : α) : Chain' R [a] :=
  Chain.nil
#align list.chain'_singleton List.chain'_singleton
-/

#print List.chain'_cons /-
@[simp]
theorem chain'_cons {x y l} : Chain' R (x :: y :: l) ↔ R x y ∧ Chain' R (y :: l) :=
  chain_cons
#align list.chain'_cons List.chain'_cons
-/

#print List.chain'_isInfix /-
theorem chain'_isInfix : ∀ l : List α, Chain' (fun x y => [x, y] <:+: l) l
  | [] => chain'_nil
  | [a] => chain'_singleton _
  | a :: b :: l =>
    chain'_cons.2
      ⟨⟨[], l, by simp⟩, (chain'_is_infix (b :: l)).imp fun x y h => h.trans ⟨[a], [], by simp⟩⟩
#align list.chain'_is_infix List.chain'_isInfix
-/

#print List.chain'_split /-
theorem chain'_split {a : α} :
    ∀ {l₁ l₂ : List α}, Chain' R (l₁ ++ a :: l₂) ↔ Chain' R (l₁ ++ [a]) ∧ Chain' R (a :: l₂)
  | [], l₂ => (and_iff_right (chain'_singleton a)).symm
  | b :: l₁, l₂ => chain_split
#align list.chain'_split List.chain'_split
-/

#print List.chain'_append_cons_cons /-
@[simp]
theorem chain'_append_cons_cons {b c : α} {l₁ l₂ : List α} :
    Chain' R (l₁ ++ b :: c :: l₂) ↔ Chain' R (l₁ ++ [b]) ∧ R b c ∧ Chain' R (c :: l₂) := by
  rw [chain'_split, chain'_cons]
#align list.chain'_append_cons_cons List.chain'_append_cons_cons
-/

#print List.chain'_map /-
theorem chain'_map (f : β → α) {l : List β} :
    Chain' R (map f l) ↔ Chain' (fun a b : β => R (f a) (f b)) l := by
  cases l <;> [rfl, exact chain_map _]
#align list.chain'_map List.chain'_map
-/

#print List.chain'_of_chain'_map /-
theorem chain'_of_chain'_map {S : β → β → Prop} (f : α → β) (H : ∀ a b : α, S (f a) (f b) → R a b)
    {l : List α} (p : Chain' S (map f l)) : Chain' R l :=
  ((chain'_map f).1 p).imp H
#align list.chain'_of_chain'_map List.chain'_of_chain'_map
-/

#print List.chain'_map_of_chain' /-
theorem chain'_map_of_chain' {S : β → β → Prop} (f : α → β) (H : ∀ a b : α, R a b → S (f a) (f b))
    {l : List α} (p : Chain' R l) : Chain' S (map f l) :=
  (chain'_map f).2 <| p.imp H
#align list.chain'_map_of_chain' List.chain'_map_of_chain'
-/

#print List.Pairwise.chain' /-
theorem Pairwise.chain' : ∀ {l : List α}, Pairwise R l → Chain' R l
  | [], _ => trivial
  | a :: l, h => Pairwise.chain h
#align list.pairwise.chain' List.Pairwise.chain'
-/

#print List.chain'_iff_pairwise /-
theorem chain'_iff_pairwise [IsTrans α R] : ∀ {l : List α}, Chain' R l ↔ Pairwise R l
  | [] => (iff_true_intro Pairwise.nil).symm
  | a :: l => chain_iff_pairwise
#align list.chain'_iff_pairwise List.chain'_iff_pairwise
-/

#print List.Chain'.sublist /-
protected theorem Chain'.sublist [IsTrans α R] (hl : l₂.Chain' R) (h : l₁ <+ l₂) : l₁.Chain' R :=
  by
  rw [chain'_iff_pairwise] at hl⊢
  exact hl.sublist h
#align list.chain'.sublist List.Chain'.sublist
-/

#print List.Chain'.cons /-
theorem Chain'.cons {x y l} (h₁ : R x y) (h₂ : Chain' R (y :: l)) : Chain' R (x :: y :: l) :=
  chain'_cons.2 ⟨h₁, h₂⟩
#align list.chain'.cons List.Chain'.cons
-/

#print List.Chain'.tail /-
theorem Chain'.tail : ∀ {l} (h : Chain' R l), Chain' R l.tail
  | [], _ => trivial
  | [x], _ => trivial
  | x :: y :: l, h => (chain'_cons.mp h).right
#align list.chain'.tail List.Chain'.tail
-/

#print List.Chain'.rel_head /-
theorem Chain'.rel_head {x y l} (h : Chain' R (x :: y :: l)) : R x y :=
  rel_of_chain_cons h
#align list.chain'.rel_head List.Chain'.rel_head
-/

#print List.Chain'.rel_head? /-
theorem Chain'.rel_head? {x l} (h : Chain' R (x :: l)) ⦃y⦄ (hy : y ∈ head? l) : R x y :=
  by
  rw [← cons_head'_tail hy] at h
  exact h.rel_head
#align list.chain'.rel_head' List.Chain'.rel_head?
-/

#print List.Chain'.cons' /-
theorem Chain'.cons' {x} : ∀ {l : List α}, Chain' R l → (∀ y ∈ l.head?, R x y) → Chain' R (x :: l)
  | [], _, _ => chain'_singleton x
  | a :: l, hl, H => hl.cons <| H _ rfl
#align list.chain'.cons' List.Chain'.cons'
-/

#print List.chain'_cons' /-
theorem chain'_cons' {x l} : Chain' R (x :: l) ↔ (∀ y ∈ head? l, R x y) ∧ Chain' R l :=
  ⟨fun h => ⟨h.rel_head?, h.tail⟩, fun ⟨h₁, h₂⟩ => h₂.cons' h₁⟩
#align list.chain'_cons' List.chain'_cons'
-/

#print List.chain'_append /-
theorem chain'_append :
    ∀ {l₁ l₂ : List α},
      Chain' R (l₁ ++ l₂) ↔ Chain' R l₁ ∧ Chain' R l₂ ∧ ∀ x ∈ l₁.getLast?, ∀ y ∈ l₂.head?, R x y
  | [], l => by simp
  | [a], l => by simp [chain'_cons', and_comm']
  | a :: b :: l₁, l₂ => by
    rw [cons_append, cons_append, chain'_cons, chain'_cons, ← cons_append, chain'_append, last',
      and_assoc]
#align list.chain'_append List.chain'_append
-/

#print List.Chain'.append /-
theorem Chain'.append (h₁ : Chain' R l₁) (h₂ : Chain' R l₂)
    (h : ∀ x ∈ l₁.getLast?, ∀ y ∈ l₂.head?, R x y) : Chain' R (l₁ ++ l₂) :=
  chain'_append.2 ⟨h₁, h₂, h⟩
#align list.chain'.append List.Chain'.append
-/

#print List.Chain'.left_of_append /-
theorem Chain'.left_of_append (h : Chain' R (l₁ ++ l₂)) : Chain' R l₁ :=
  (chain'_append.1 h).1
#align list.chain'.left_of_append List.Chain'.left_of_append
-/

#print List.Chain'.right_of_append /-
theorem Chain'.right_of_append (h : Chain' R (l₁ ++ l₂)) : Chain' R l₂ :=
  (chain'_append.1 h).2.1
#align list.chain'.right_of_append List.Chain'.right_of_append
-/

#print List.Chain'.infix /-
theorem Chain'.infix (h : Chain' R l) (h' : l₁ <:+: l) : Chain' R l₁ :=
  by
  rcases h' with ⟨l₂, l₃, rfl⟩
  exact h.left_of_append.right_of_append
#align list.chain'.infix List.Chain'.infix
-/

#print List.Chain'.suffix /-
theorem Chain'.suffix (h : Chain' R l) (h' : l₁ <:+ l) : Chain' R l₁ :=
  h.infix h'.isInfix
#align list.chain'.suffix List.Chain'.suffix
-/

#print List.Chain'.prefix /-
theorem Chain'.prefix (h : Chain' R l) (h' : l₁ <+: l) : Chain' R l₁ :=
  h.infix h'.isInfix
#align list.chain'.prefix List.Chain'.prefix
-/

#print List.Chain'.drop /-
theorem Chain'.drop (h : Chain' R l) (n : ℕ) : Chain' R (drop n l) :=
  h.suffix (drop_suffix _ _)
#align list.chain'.drop List.Chain'.drop
-/

#print List.Chain'.init /-
theorem Chain'.init (h : Chain' R l) : Chain' R l.dropLast :=
  h.prefix l.dropLast_prefix
#align list.chain'.init List.Chain'.init
-/

#print List.Chain'.take /-
theorem Chain'.take (h : Chain' R l) (n : ℕ) : Chain' R (take n l) :=
  h.prefix (take_prefix _ _)
#align list.chain'.take List.Chain'.take
-/

#print List.chain'_pair /-
theorem chain'_pair {x y} : Chain' R [x, y] ↔ R x y := by
  simp only [chain'_singleton, chain'_cons, and_true_iff]
#align list.chain'_pair List.chain'_pair
-/

#print List.Chain'.imp_head /-
theorem Chain'.imp_head {x y} (h : ∀ {z}, R x z → R y z) {l} (hl : Chain' R (x :: l)) :
    Chain' R (y :: l) :=
  hl.tail.cons' fun z hz => h <| hl.rel_head? hz
#align list.chain'.imp_head List.Chain'.imp_head
-/

#print List.chain'_reverse /-
theorem chain'_reverse : ∀ {l}, Chain' R (reverse l) ↔ Chain' (flip R) l
  | [] => Iff.rfl
  | [a] => by simp only [chain'_singleton, reverse_singleton]
  | a :: b :: l => by
    rw [chain'_cons, reverse_cons, reverse_cons, append_assoc, cons_append, nil_append,
      chain'_split, ← reverse_cons, @chain'_reverse (b :: l), and_comm', chain'_pair, flip]
#align list.chain'_reverse List.chain'_reverse
-/

#print List.chain'_iff_nthLe /-
theorem chain'_iff_nthLe {R} :
    ∀ {l : List α},
      Chain' R l ↔
        ∀ (i) (h : i < length l - 1),
          R (nthLe l i (lt_of_lt_pred h)) (nthLe l (i + 1) (lt_pred_iff.mp h))
  | [] => by simp
  | [a] => by simp
  | a :: b :: t => by
    rw [← and_forall_succ, chain'_cons, chain'_iff_nth_le]
    simp only [length, nth_le, add_tsub_cancel_right, add_lt_add_iff_right, tsub_pos_iff_lt,
      one_lt_succ_succ, true_imp_iff]
    rfl
#align list.chain'_iff_nth_le List.chain'_iff_nthLe
-/

#print List.Chain'.append_overlap /-
/-- If `l₁ l₂` and `l₃` are lists and `l₁ ++ l₂` and `l₂ ++ l₃` both satisfy
  `chain' R`, then so does `l₁ ++ l₂ ++ l₃` provided `l₂ ≠ []` -/
theorem Chain'.append_overlap {l₁ l₂ l₃ : List α} (h₁ : Chain' R (l₁ ++ l₂))
    (h₂ : Chain' R (l₂ ++ l₃)) (hn : l₂ ≠ []) : Chain' R (l₁ ++ l₂ ++ l₃) :=
  h₁.append h₂.right_of_append <| by
    simpa only [last'_append_of_ne_nil _ hn] using (chain'_append.1 h₂).2.2
#align list.chain'.append_overlap List.Chain'.append_overlap
-/

#print List.exists_chain_of_relationReflTransGen /-
/-- If `a` and `b` are related by the reflexive transitive closure of `r`, then there is a `r`-chain
starting from `a` and ending on `b`.
The converse of `relation_refl_trans_gen_of_exists_chain`.
-/
theorem exists_chain_of_relationReflTransGen (h : Relation.ReflTransGen r a b) :
    ∃ l, Chain r a l ∧ getLast (a :: l) (cons_ne_nil _ _) = b :=
  by
  apply Relation.ReflTransGen.head_induction_on h
  · exact ⟨[], chain.nil, rfl⟩
  · intro c d e t ih
    obtain ⟨l, hl₁, hl₂⟩ := ih
    refine' ⟨d :: l, chain.cons e hl₁, _⟩
    rwa [last_cons_cons]
#align list.exists_chain_of_relation_refl_trans_gen List.exists_chain_of_relationReflTransGen
-/

#print List.Chain.induction /-
/-- Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true everywhere in the chain and at `a`.
That is, we can propagate the predicate up the chain.
-/
theorem Chain.induction (p : α → Prop) (l : List α) (h : Chain r a l)
    (hb : getLast (a :: l) (cons_ne_nil _ _) = b) (carries : ∀ ⦃x y : α⦄, r x y → p y → p x)
    (final : p b) : ∀ i ∈ a :: l, p i :=
  by
  induction l generalizing a
  · cases hb
    simp [final]
  · rw [chain_cons] at h
    rintro _ (rfl | _)
    apply carries h.1 (l_ih h.2 hb _ (Or.inl rfl))
    apply l_ih h.2 hb _ H
#align list.chain.induction List.Chain.induction
-/

#print List.Chain.induction_head /-
/-- Given a chain from `a` to `b`, and a predicate true at `b`, if `r x y → p y → p x` then
the predicate is true at `a`.
That is, we can propagate the predicate all the way up the chain.
-/
@[elab_as_elim]
theorem Chain.induction_head (p : α → Prop) (l : List α) (h : Chain r a l)
    (hb : getLast (a :: l) (cons_ne_nil _ _) = b) (carries : ∀ ⦃x y : α⦄, r x y → p y → p x)
    (final : p b) : p a :=
  (Chain.induction p l h hb carries final) _ (mem_cons_self _ _)
#align list.chain.induction_head List.Chain.induction_head
-/

#print List.relationReflTransGen_of_exists_chain /-
/--
If there is an `r`-chain starting from `a` and ending at `b`, then `a` and `b` are related by the
reflexive transitive closure of `r`. The converse of `exists_chain_of_relation_refl_trans_gen`.
-/
theorem relationReflTransGen_of_exists_chain (l) (hl₁ : Chain r a l)
    (hl₂ : getLast (a :: l) (cons_ne_nil _ _) = b) : Relation.ReflTransGen r a b :=
  Chain.induction_head _ l hl₁ hl₂ (fun x y => Relation.ReflTransGen.head)
    Relation.ReflTransGen.refl
#align list.relation_refl_trans_gen_of_exists_chain List.relationReflTransGen_of_exists_chain
-/

end List


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

open list

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

namespace list
namespace func

variables {a : α}
variables {as as1 as2 as3 : list α}

/- Definitions for using lists as finite
   representations of functions with domain ℕ. -/
def neg [has_neg α] (as : list α) := as.map (λ a, -a)

variables [inhabited α] [inhabited β]

@[simp] def set (a : α) : list α → ℕ → list α
| (_::as) 0     := a::as
| []      0     := [a]
| (h::as) (k+1) := h::(set as k)
| []      (k+1) := (default α)::(set ([] : list α) k)

localized "notation as ` {` m ` ↦ ` a `}` := list.func.set a as m" in list.func

@[simp] def get : ℕ → list α → α
| _ []          := default α
| 0 (a::as)     := a
| (n+1) (a::as) := get n as

def equiv (as1 as2 : list α) : Prop :=
∀ (m : nat), get m as1 = get m as2

@[simp] def pointwise (f : α → β → γ) : list α → list β → list γ
| []      []      := []
| []      (b::bs) := map (f $ default α) (b::bs)
| (a::as) []      := map (λ x, f x $ default β) (a::as)
| (a::as) (b::bs) := (f a b)::(pointwise as bs)

def add {α : Type u} [has_zero α] [has_add α] : list α → list α → list α :=
@pointwise α α α ⟨0⟩ ⟨0⟩ (+)

def sub {α : Type u} [has_zero α] [has_sub α] : list α → list α → list α :=
@pointwise α α α ⟨0⟩ ⟨0⟩ (@has_sub.sub α _)

/- set -/

lemma length_set : ∀ {m : ℕ} {as : list α},
  (as {m ↦ a}).length = _root_.max as.length (m+1)
| 0 []          := rfl
| 0 (a::as)     := by {rw max_eq_left, refl, simp [nat.le_add_right]}
| (m+1) []      := by simp only [set, nat.zero_max, length, @length_set m]
| (m+1) (a::as) := by simp only [set, nat.max_succ_succ, length, @length_set m]

@[simp] lemma get_nil {k : ℕ} : get k [] = default α :=
by {cases k; refl}

lemma get_eq_default_of_le :
  ∀ (k : ℕ) {as : list α}, as.length ≤ k → get k as = default α
| 0     []      h1 := rfl
| 0     (a::as) h1 := by cases h1
| (k+1) []      h1 := rfl
| (k+1) (a::as) h1 :=
  begin
    apply get_eq_default_of_le k,
    rw ← nat.succ_le_succ_iff, apply h1,
  end

@[simp] lemma get_set {a : α} :
  ∀ {k : ℕ} {as : list α}, get k (as {k ↦ a}) = a
| 0 as     := by {cases as; refl, }
| (k+1) as := by {cases as; simp [get_set]}

lemma eq_get_of_mem {a : α} :
  ∀ {as : list α}, a ∈ as → ∃ n : nat, ∀ d : α, a = (get n as)
| [] h := by cases h
| (b::as) h :=
  begin
    rw mem_cons_iff at h, cases h,
    { existsi 0, intro d, apply h },
    { cases eq_get_of_mem h with n h2,
      existsi (n+1), apply h2 }
  end

lemma mem_get_of_le :
  ∀ {n : ℕ} {as : list α}, n < as.length → get n as ∈ as
| _ [] h1 := by cases h1
| 0 (a::as) _ := or.inl rfl
| (n+1) (a::as) h1 :=
  begin
    apply or.inr, unfold get,
    apply mem_get_of_le,
    apply nat.lt_of_succ_lt_succ h1,
  end

lemma mem_get_of_ne_zero :
  ∀ {n : ℕ} {as : list α},
  get n as ≠ default α → get n as ∈ as
| _ [] h1 := begin exfalso, apply h1, rw get_nil end
| 0 (a::as) h1 := or.inl rfl
| (n+1) (a::as) h1 :=
  begin
    unfold get,
    apply (or.inr (mem_get_of_ne_zero _)),
    apply h1
  end

lemma get_set_eq_of_ne {a : α} :
  ∀ {as : list α} (k : ℕ) (m : ℕ),
  m ≠ k → get m (as {k ↦ a}) = get m as
| as 0 m h1 :=
  by { cases m, contradiction, cases as;
       simp only [set, get, get_nil] }
| as (k+1) m h1 :=
  begin
    cases as; cases m,
    simp only [set, get],
    { have h3 : get m (nil {k ↦ a}) = default α,
      { rw [get_set_eq_of_ne k m, get_nil],
        intro hc, apply h1, simp [hc] },
      apply h3 },
    simp only [set, get],
    { apply get_set_eq_of_ne k m,
      intro hc, apply h1, simp [hc], }
  end

lemma get_map {f : α → β} : ∀ {n : ℕ} {as : list α}, n < as.length →
  get n (as.map f) = f (get n as)
| _ [] h := by cases h
| 0 (a::as) h := rfl
| (n+1) (a::as) h1 :=
  begin
    have h2 : n < length as,
    { rw [← nat.succ_le_iff, ← nat.lt_succ_iff],
      apply h1 },
    apply get_map h2,
  end

lemma get_map' {f : α → β} {n : ℕ} {as : list α} :
  f (default α) = (default β) →
  get n (as.map f) = f (get n as) :=
begin
  intro h1, by_cases h2 : n < as.length,
  { apply get_map h2, },
  { rw not_lt at h2,
    rw [get_eq_default_of_le _ h2, get_eq_default_of_le, h1],
    rw [length_map], apply h2 }
end

lemma forall_val_of_forall_mem {as : list α} {p : α → Prop} :
  p (default α) → (∀ x ∈ as, p x) → (∀ n, p (get n as)) :=
begin
  intros h1 h2 n,
  by_cases h3 : n < as.length,
  { apply h2 _ (mem_get_of_le h3) },
  { rw not_lt at h3,
    rw get_eq_default_of_le _ h3, apply h1 }
end

/- equiv -/

lemma equiv_refl : equiv as as := λ k, rfl

lemma equiv_symm : equiv as1 as2 → equiv as2 as1 :=
λ h1 k, (h1 k).symm

lemma equiv_trans :
  equiv as1 as2 → equiv as2 as3 → equiv as1 as3 :=
λ h1 h2 k, eq.trans (h1 k) (h2 k)

lemma equiv_of_eq : as1 = as2 → equiv as1 as2 :=
begin intro h1, rw h1, apply equiv_refl end

lemma eq_of_equiv : ∀ {as1 as2 : list α}, as1.length = as2.length →
  equiv as1 as2 → as1 = as2
| []     [] h1 h2 := rfl
| (_::_) [] h1 h2 := by cases h1
| [] (_::_) h1 h2 := by cases h1
| (a1::as1) (a2::as2) h1 h2 :=
  begin
    congr,
    { apply h2 0 },
    have h3 : as1.length = as2.length,
    { simpa [add_left_inj, add_comm, length] using h1 },
    apply eq_of_equiv h3,
    intro m, apply h2 (m+1)
  end

end func
-- We want to drop the `inhabited` instances for a moment,
-- so we close and open the namespace

namespace func

/- neg -/

@[simp] lemma get_neg [add_group α] {k : ℕ} {as : list α} :
  @get α ⟨0⟩ k (neg as) = -(@get α ⟨0⟩ k as) :=
by {unfold neg, rw (@get_map' α α ⟨0⟩), apply neg_zero}

@[simp] lemma length_neg [has_neg α] (as : list α) : (neg as).length = as.length :=
by simp only [neg, length_map]

variables [inhabited α] [inhabited β]

/- pointwise -/

lemma nil_pointwise {f : α → β → γ} : ∀ bs : list β, pointwise f [] bs = bs.map (f $ default α)
| []      := rfl
| (b::bs) :=
  by simp only [nil_pointwise bs, pointwise,
     eq_self_iff_true, and_self, map]

lemma pointwise_nil {f : α → β → γ} :
  ∀ as : list α, pointwise f as [] = as.map (λ a, f a $ default β)
| []      := rfl
| (a::as) :=
  by simp only [pointwise_nil as, pointwise,
     eq_self_iff_true, and_self, list.map]

lemma get_pointwise [inhabited γ] {f : α → β → γ} (h1 : f (default α) (default β) = default γ) :
  ∀ (k : nat) (as : list α) (bs : list β),
  get k (pointwise f as bs) = f (get k as) (get k bs)
| k [] [] := by simp only [h1, get_nil, pointwise, get]
| 0 [] (b::bs) :=
  by simp only [get_pointwise, get_nil,
      pointwise, get, nat.nat_zero_eq_zero, map]
| (k+1) [] (b::bs) :=
  by { have : get k (map (f $ default α) bs) = f (default α) (get k bs),
       { simpa [nil_pointwise, get_nil] using (get_pointwise k [] bs) },
       simpa [get, get_nil, pointwise, map] }
| 0 (a::as) [] :=
  by simp only [get_pointwise, get_nil,
     pointwise, get, nat.nat_zero_eq_zero, map]
| (k+1) (a::as) [] :=
  by simpa [get, get_nil, pointwise, map, pointwise_nil, get_nil]
     using get_pointwise k as []
| 0 (a::as) (b::bs) := by simp only [pointwise, get]
| (k+1) (a::as) (b::bs) :=
  by simp only [pointwise, get, get_pointwise k]

lemma length_pointwise {f : α → β → γ} :
  ∀ {as : list α} {bs : list β},
  (pointwise f as bs).length = _root_.max as.length bs.length
| []      []      := rfl
| []      (b::bs) :=
  by simp only [pointwise, length, length_map,
     max_eq_right (nat.zero_le (length bs + 1))]
| (a::as) []      :=
  by simp only [pointwise, length, length_map,
     max_eq_left (nat.zero_le (length as + 1))]
| (a::as) (b::bs) :=
  by simp only [pointwise, length,
     nat.max_succ_succ, @length_pointwise as bs]

end func

namespace func
/- add -/

@[simp] lemma get_add {α : Type u} [add_monoid α] {k : ℕ} {xs ys : list α} :
  @get α ⟨0⟩ k (add xs ys) = ( @get α ⟨0⟩ k xs + @get α ⟨0⟩ k ys) :=
by {apply get_pointwise, apply zero_add}

@[simp] lemma length_add {α : Type u}
  [has_zero α] [has_add α] {xs ys : list α} :
  (add xs ys).length = _root_.max xs.length ys.length :=
@length_pointwise α α α ⟨0⟩ ⟨0⟩ _ _ _

@[simp]

@[simp] lemma add_nil {α : Type u} [add_monoid α]
  (as : list α) : add as [] = as :=
begin
  rw [add, @pointwise_nil α α α ⟨0⟩ ⟨0⟩],
  apply eq.trans _ (map_id as),
  congr' with x,
  have : @default α ⟨0⟩ = 0 := rfl,
  rw [this, add_zero], refl
end

lemma map_add_map {α : Type u} [add_monoid α] (f g : α → α) {as : list α} :
  add (as.map f) (as.map g) = as.map (λ x, f x + g x) :=
begin
  apply @eq_of_equiv _ (⟨0⟩ : inhabited α),
  { rw [length_map, length_add, max_eq_left, length_map],
    apply le_of_eq,
    rw [length_map, length_map] },
  intros m,
  rw [get_add],
  by_cases h : m < length as,
  { repeat {rw [@get_map α α ⟨0⟩ ⟨0⟩ _ _ _ h]} },
  rw not_lt at h,
  repeat {rw [get_eq_default_of_le m]};
  try {rw length_map, apply h},
  apply zero_add
end

/- sub -/

@[simp] lemma get_sub {α : Type u}
  [add_group α] {k : ℕ} {xs ys : list α} :
  @get α ⟨0⟩ k (sub xs ys) = (@get α ⟨0⟩ k xs - @get α ⟨0⟩ k ys) :=
by {apply get_pointwise, apply sub_zero}

@[simp] lemma length_sub [has_zero α] [has_sub α] {xs ys : list α} :
  (sub xs ys).length = _root_.max xs.length ys.length :=
@length_pointwise α α α ⟨0⟩ ⟨0⟩ _ _ _

@[simp] lemma nil_sub {α : Type} [add_group α]
  (as : list α) : sub [] as = neg as :=
begin
  rw [sub, nil_pointwise],
  congr' with x,
  have : @default α ⟨0⟩ = 0 := rfl,
  rw [this, zero_sub]
end

@[simp] lemma sub_nil {α : Type} [add_group α]
  (as : list α) : sub as [] = as :=
begin
  rw [sub, pointwise_nil],
  apply eq.trans _ (map_id as),
  congr' with x,
  have : @default α ⟨0⟩ = 0 := rfl,
  rw [this, sub_zero], refl
end

end func
end list


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Patrick Stevens
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.choose.basic
import Mathlib.tactic.linarith.default
import Mathlib.tactic.omega.default
import Mathlib.algebra.big_operators.ring
import Mathlib.algebra.big_operators.intervals
import Mathlib.algebra.big_operators.order
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Sums of binomial coefficients

This file includes variants of the binomial theorem and other results on sums of binomial
coefficients. Theorems whose proofs depend on such sums may also go in this file for import
reasons.

-/

/-- A version of the binomial theorem for noncommutative semirings. -/
theorem commute.add_pow {α : Type u_1} [semiring α] {x : α} {y : α} (h : commute x y) (n : ℕ) :
    (x + y) ^ n =
        finset.sum (finset.range (n + 1)) fun (m : ℕ) => x ^ m * y ^ (n - m) * ↑(nat.choose n m) :=
  sorry

/-- The binomial theorem -/
theorem add_pow {α : Type u_1} [comm_semiring α] (x : α) (y : α) (n : ℕ) :
    (x + y) ^ n =
        finset.sum (finset.range (n + 1)) fun (m : ℕ) => x ^ m * y ^ (n - m) * ↑(nat.choose n m) :=
  commute.add_pow (commute.all x y) n

namespace nat

/-- The sum of entries in a row of Pascal's triangle -/
theorem sum_range_choose (n : ℕ) :
    (finset.sum (finset.range (n + 1)) fun (m : ℕ) => choose n m) = bit0 1 ^ n :=
  sorry

theorem sum_range_choose_halfway (m : ℕ) :
    (finset.sum (finset.range (m + 1)) fun (i : ℕ) => choose (bit0 1 * m + 1) i) =
        bit0 (bit0 1) ^ m :=
  sorry

theorem choose_middle_le_pow (n : ℕ) : choose (bit0 1 * n + 1) n ≤ bit0 (bit0 1) ^ n := sorry

end nat

theorem int.alternating_sum_range_choose {n : ℕ} :
    (finset.sum (finset.range (n + 1)) fun (m : ℕ) => (-1) ^ m * ↑(nat.choose n m)) =
        ite (n = 0) 1 0 :=
  sorry

theorem int.alternating_sum_range_choose_of_ne {n : ℕ} (h0 : n ≠ 0) :
    (finset.sum (finset.range (n + 1)) fun (m : ℕ) => (-1) ^ m * ↑(nat.choose n m)) = 0 :=
  sorry

namespace finset

theorem sum_powerset_apply_card {α : Type u_1} {β : Type u_2} [add_comm_monoid α] (f : ℕ → α)
    {x : finset β} :
    (finset.sum (powerset x) fun (m : finset β) => f (card m)) =
        finset.sum (range (card x + 1)) fun (m : ℕ) => nat.choose (card x) m •ℕ f m :=
  sorry

theorem sum_powerset_neg_one_pow_card {α : Type u_1} [DecidableEq α] {x : finset α} :
    (finset.sum (powerset x) fun (m : finset α) => (-1) ^ card m) = ite (x = ∅) 1 0 :=
  sorry

theorem sum_powerset_neg_one_pow_card_of_nonempty {α : Type u_1} {x : finset α}
    (h0 : finset.nonempty x) : (finset.sum (powerset x) fun (m : finset α) => (-1) ^ card m) = 0 :=
  sorry

end Mathlib


import tactic
import data.rel
import data.vector
import data.nat.basic
import ruby.combinators
import ruby.tactics

open rel vector nat

variables {α β γ δ ε φ ψ : Type}

lemma push_π₁ (r : rel α β) (p : rel γ δ) (hr : ∀ c : γ, ∃ d : δ, p c d) : [r, p] ;; π₁ = π₁ ;; r :=
begin
  ext ⟨x,y⟩ z,
  split,
  { rintro ⟨⟨b,d⟩,⟨⟨rxb,pyd⟩,h3⟩⟩,
    simp * at *,
    refine ⟨x,⟨by simp,rxb⟩⟩, },
  { rintro ⟨c,⟨h1,rcz⟩⟩,
    simp * at *,
    obtain ⟨w,pyw⟩ := hr y,
    use ⟨z,w⟩,
    simp * at *,
    exact ⟨rcz,pyw⟩, }
end

lemma push_π₂ (r : rel α β) (p : rel γ δ) (hr : ∀ a : α, ∃ b : β, r a b) : [r, p] ;; π₂ = π₂ ;; p :=
begin
  ext ⟨x,y⟩ z,
  split,
  { rintro ⟨⟨b,d⟩,⟨⟨rxb,pyd⟩,h3⟩⟩,
    simp * at *,
    refine ⟨y,⟨by simp,pyd⟩⟩, },
  { rintro ⟨c,⟨h1,pcz⟩⟩,
    simp * at *,
    obtain ⟨w,rxw⟩ := hr x,
    use ⟨w,z⟩,
    simp * at *,
    exact ⟨rxw,pcz⟩, }
end

def fun_to_exists (f : α → β) : ∀ a : α, ∃ b : β, (to_rel f) a b :=
begin
  intro a,
  use f a,
  simp,
end

lemma apl_proj {n : ℕ} : fst (apl n) ;; π₂ = @π₂ (β × vector β n) α
  := by simpa using push_π₂ (apl n) idd (fun_to_exists (apl_fun n))

lemma push_π₁_nill (r : rel α β) : [r, @nill γ δ] ;; π₁ = π₁ ;; r
  := push_π₁ r nill (begin intro c, use nil, end)

lemma push_rsh (r : rel α β) (s : rel γ δ) (t : rel ε φ) : [r, [s, t]] ;; rsh = rsh ;; [[r, s], t] :=
begin
  ext ⟨a,⟨c,e⟩⟩ ⟨⟨b,d⟩,f⟩,
  split,
  { rintro ⟨⟨b',⟨d',f'⟩⟩,⟨⟨hr,⟨hs,ht⟩⟩,h2⟩⟩,
    use ⟨⟨a,c⟩,e⟩,
    rw rsh_def at h2 ⊢,
    simp [← h2],
    exact ⟨⟨hr,hs⟩,ht⟩, },
  { rintro ⟨⟨⟨a',c'⟩,e'⟩,⟨h1,⟨⟨hr,hs⟩,ht⟩⟩⟩,
    use ⟨b,⟨d,f⟩⟩,
    rw rsh_def at h1 ⊢,
    simp [h1],
    exact ⟨hr,⟨hs,ht⟩⟩, }
end

lemma push_lsh (r : rel α β) (s : rel γ δ) (t : rel ε φ) : [[r, s], t] ;; lsh = lsh ;; [r, [s, t]] :=
begin
  apply from_conv.mp,
  unfold lsh, simp,
  exact (push_rsh (r†) (s†) (t†)).symm,
end

lemma horner_lemma (n : ℕ) (r : rel (α × β) α) (p : rel α α) (q : rel β β) (h : [p,q] ;; r = r ;; p)
  : [p, map' n q] ;; rdl n r = rdl n r ;; p :=
begin
  induction n with n hn,

  simpa using push_π₁_nill p,

  have h : rdl n.succ r;;p = [p,map' n.succ q];;rdl n.succ r,
  { calc rdl n.succ r;;p
      = _ ;; fst r ;; ([p, map' n q] ;; rdl n r) : by simp [rdl_succ, rel_seq_assoc, hn]
  ... = _ ;; (fst r ;; [p, map' n q]) ;; rdl n r : by simp [rel_seq_assoc]
  ... = _ ;; [r ;; p, map' n q] ;; _ : by simp [rel_seq_assoc, ← seq_par_dist]
  ... = _ ;; [[p,q] ;; r, map' n q] ;; _ : by rw h
  ... = _ ;; (rsh ;; [[p,q], map' n q]) ;; fst r ;; _ : by simp [← seq_par_dist, ← rel_seq_assoc]
  ... = snd (apl n)† ;; [p, [q, map' n q]] ;; rsh ;; _ : by simp [push_rsh, ← rel_seq_assoc]
  ... = [p, (apl n)† ;; [q, map' n q] ;; apl n] ;; snd (apl n)† ;; _ : by simp [← rel_seq_assoc, ← seq_par_dist, apl_inv_right]
  ... = [p, map' n.succ q] ;; rdl n.succ r : by simp [map'_succ, rdl_succ, rel_seq_assoc],
  },

  exact h.symm,
end

theorem horner (n : ℕ) (r : rel (α × β) α) (p : rel α α) (q : rel β β) (h : [p,q] ;; r = r ;; p)
  : snd (tri' n q) ;; rdl n (r ;; p) = rdl n r ;; p^n :=
begin
  induction n with n hn,

  simpa using push_π₁_nill idd,

  calc snd (tri' n.succ q) ;; rdl n.succ (r ;; p)
      = snd ((apl n)† ;; snd (tri' n q ;; map' n q) ;; apl n) ;; snd (apl n)† ;; rsh ;; fst (r ;; p) ;; rdl n (r ;; p) : by simp [tri'_succ, rdl_succ, rel_seq_assoc]
  ... = snd ((apl n)† ;; [idd, tri' n q ;; map' n q] ;; apl n) ;; _ : by simp [← rel_seq_assoc]
  ... = snd (apl n)† ;; snd (snd (tri' n q ;; map' n q)) ;; snd (apl n) ;; snd (apl n)† ;; rsh ;; fst (r ;; p) ;; _ : by simp [← seq_par_dist, rel_seq_assoc]
  ... = snd (apl n)† ;; snd (snd (tri' n q ;; map' n q)) ;; rsh ;; _ : by simp [← seq_par_dist, apl_inv_right, ← rel_seq_assoc]
  ... = snd (apl n)† ;; rsh ;; snd (tri' n q ;; map' n q) ;; fst (r ;; p) ;; _ : by simp [← rel_seq_assoc, push_rsh]
  ... = snd (apl n)† ;; rsh ;; [r ;; p, tri' n q ;; map' n q] ;; _ : by simp [← seq_par_dist, ← rel_seq_assoc]
  ... = snd (apl n)† ;; rsh ;; [r, tri' n q] ;; ([p, map' n q] ;; rdl n (r ;; p)) : by simp [← rel_seq_assoc]
  ... = snd (apl n)† ;; rsh ;; fst r ;; (snd (tri' n q) ;; rdl n (r ;; p)) ;; p : _
  ... = snd (apl n)† ;; rsh ;; fst r ;; rdl n r ;; (p^n ;; p) : by {rw hn, simp [rel_seq_assoc]}
  ... = snd (apl n)† ;; rsh ;; fst r ;; rdl n r ;; p^n.succ : by rw rel_pow_succ
  ... = rdl n.succ r ;; p^n.succ : by rw rdl_succ,

  { rw horner_lemma n (r ;; p) p q (begin rw rel_seq_assoc, exact seq_cong_right h, end),
    rw break_par,
    simp [rel_seq_assoc], },
end

theorem horner' (n : ℕ) (r : rel (α × β) α) (p : rel α α) (q : rel β β) (h : [p,q] ;; r = r ;; p)
  : snd (tri' n q) ;; rdl n (r ;; p) = rdl n r ;; p^n :=
begin
  induction n with n hn,

  simpa using push_π₁_nill idd,

  conv_lhs begin
    simp only [tri'_succ, rdl_succ, rel_seq_assoc, inv_snd],
    congr, congr, congr,
    simp [← break_snd, ← rel_seq_assoc, apl_inv_right],
    rw break_snd,
  end, conv_lhs begin
    simp [← rel_seq_assoc],
    congr, skip,
    rw [rel_seq_assoc, rel_seq_assoc], congr,
    simp [push_rsh, ← rel_seq_assoc, ← seq_par_dist],
    rw seq_par_dist,
  end, conv_lhs begin
    congr, skip, rw ← rel_seq_assoc, congr, skip,
    rw ← rel_seq_assoc,
    rw horner_lemma n (r ;; p) p q (begin rw rel_seq_assoc, exact seq_cong_right h, end),
    rw [rel_seq_assoc, break_par, ← rel_seq_assoc, ← rel_seq_assoc],
    congr, skip,
    rw [rel_seq_assoc, hn, ← rel_seq_assoc, ← rel_pow_succ],
  end,
  simp [rdl_succ, rel_seq_assoc],
end

theorem horner'' (n : ℕ) (r : rel (α × β) α) (p : rel α α) (q : rel β β) (h : [p,q] ;; r = r ;; p)
  : snd (tri' n q) ;; rdl n (r ;; p) = rdl n r ;; p^n :=
begin
  induction n with n hn,

  simpa using push_π₁_nill idd,

  simp only [tri'_succ, rdl_succ, rel_seq_assoc, inv_snd],
  conv_lhs { l, l, l, rw break_snd, ar, rw [← break_snd, apl_inv_right, break_snd], }, simp only [idd_snd, seq_id_right],
  conv_lhs { l, l, ar, rw push_rsh, }, simp only [par_id],
  conv_lhs { l, arr, arr, rw [← break_par', seq_par_dist, break_par], },
  conv_lhs { arr, arr, ar,
     rw horner_lemma n (r ;; p) p q (by simpa [← assoc] using seq_cong_right h),
     all, arr, rw hn, },
  conv_lhs { r, r, arr, arr, rw ← rel_pow_succ, },
  repeat {rw assoc},
end

theorem horner2 (n : ℕ) (r : rel (α × β) α) (p : rel α α) (q : rel β β) (h : [p,q] ;; r = r ;; p)
  : snd (tri' n q) ;; rdl' n (r ;; p) = rdl' n r ;; p^n :=
begin
  induction n with n hn,
  simpa using push_π₁_nill idd,

  simp only [tri'_succ, rdl', row_succ, inv_snd, bes] at hn ⊢,
  --conv_lhs { rw [break_snd, break_snd], arr, all, all, all, rw [← break_snd, apl_inv_right] }, simp,
  conv_lhs { rw [break_snd, break_snd], ar, arr,
    conv { r, all, all, all, rw [← break_snd, apl_inv_right], },
    rw [idd_snd], simp [← assoc], rw push_rsh, simp,
    conv { l, l, l, l, l, arr, rw [← fst_snd_swap], }, },

  sorry
end

lemma rel_inv_pow (r : rel α α) (h : r ;; r† = idd) {n : ℕ} : r^n ;; (r†)^n = idd :=
begin
  induction n with n hn,
  simp,
  rw [rel_pow_succ, ← rel_pow_left, rel_seq_assoc],
  nth_rewrite 1 ← rel_seq_assoc,
  simpa [h] using hn,
end

lemma push_delay (r : rel ($α × $β) ($α)) : [D, D] ;; r = r ;; D :=
begin
  ext ⟨x,y⟩ z,
  split,
  { rintro ⟨⟨a,b⟩,⟨⟨dxa,dyb⟩,rabz⟩⟩,
    use D_fun' z,
    refine ⟨_,D_fun_inv_right z⟩,
    unfold D to_rel D_fun at *,
    rw [← dxa, ← dyb] at rabz,
    sorry },
  {sorry}
end

theorem pipeline_reduce (n : ℕ) (r : rel ($α × $β) ($α))
  : snd (tri' n D) ;; rdl n (r ;; D) ;; (D†)^n = rdl n r :=
begin
  rw horner n r D D _,
  rw ← rel_seq_assoc,
  rw rel_inv_pow D D_inv_right,
  simp,
  { sorry },
end


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

import for_mathlib.dold_kan.degeneracies
import for_mathlib.dold_kan.normalized
import tactic.fin_cases

noncomputable theory

namespace category_theory

open limits preadditive

variables {C : Type*} [category C]

lemma subobject.le_iff {X : C} (A B : subobject X) :
  A ≤ B ↔ B.factors A.arrow :=
begin
  split,
  { intro h,
    rw subobject.factors_iff,
    exact ⟨subobject.of_le _ _ h,
      by simp only [subobject.representative_arrow, subobject.of_le_arrow]⟩, },
  { intro h,
    exact subobject.le_of_comm (B.factor_thru _ h) (subobject.factor_thru_arrow _ _ _), }
end

section
variables [abelian C] {I : Type*} [fintype I] {B : C} (P : I → subobject B)
@[simp]
def coproduct_to_finset_univ_sup : ∐ (λ (i : I), (P i : C)) ⟶ ↑(finset.univ.sup P) :=
sigma.desc (λ i, subobject.of_le _ _ (finset.le_sup (finset.mem_univ _)))

lemma subobject.jointly_epi_to_binary_sup {B : C} (P₁ P₂ : subobject B) {Z : C}
  (f₁ f₂ : ↑(P₁ ⊔ P₂) ⟶ Z)
  (hl : subobject.of_le P₁ (P₁ ⊔ P₂) le_sup_left ≫ f₁ =
    subobject.of_le P₁ (P₁ ⊔ P₂) le_sup_left ≫ f₂)
  (hr : subobject.of_le P₂ (P₁ ⊔ P₂) le_sup_right ≫ f₁ =
    subobject.of_le P₂ (P₁ ⊔ P₂) le_sup_right ≫ f₂) : f₁ = f₂ :=
begin
  revert P₁ P₂,
  refine subobject.ind₂ _ _,
  introsI A₁ A₂ f₁ f₂ hf₁ hf₂ g₁ g₂ h₁ h₂,
  rw ← cancel_epi (factor_thru_image_subobject (coprod.desc f₁ f₂)),
  ext,
  { rw ← cancel_epi (subobject.underlying_iso f₁).inv at h₁,
    let α := (subobject.underlying_iso f₁).inv ≫
      (subobject.mk f₁).of_le (subobject.mk f₁ ⊔ subobject.mk f₂) le_sup_left,
    suffices eq₁ : coprod.inl ≫ factor_thru_image_subobject (coprod.desc f₁ f₂) = α,
    { simpa only [reassoc_of eq₁] using h₁, },
    ext,
    change _ = _ ≫ (subobject.mk f₁ ⊔ subobject.mk f₂).arrow,
    simp only [category.assoc, image_subobject_arrow_comp, coprod.inl_desc,
      subobject.of_le_arrow, subobject.underlying_iso_arrow], },
  { rw ← cancel_epi (subobject.underlying_iso f₂).inv at h₂,
    let β := (subobject.underlying_iso f₂).inv ≫
      (subobject.mk f₂).of_le (subobject.mk f₁ ⊔ subobject.mk f₂) le_sup_right,
    suffices eq₂ : coprod.inr ≫ factor_thru_image_subobject (coprod.desc f₁ f₂) = β,
    { simpa only [reassoc_of eq₂] using h₂, },
    ext,
    change _ = _ ≫ (subobject.mk f₁ ⊔ subobject.mk f₂).arrow,
    simp only [category.assoc, image_subobject_arrow_comp, coprod.inr_desc,
      subobject.of_le_arrow, subobject.underlying_iso_arrow], },
end

lemma subobject.jointly_epi_to_sup {I : Type*} (s : finset I) {B : C}
  (P : I → subobject B) {Z : C} (f₁ f₂ : ↑(s.sup P) ⟶ Z)
  (h : ∀ (i : s), subobject.of_le (P i) _ (finset.le_sup i.2)  ≫ f₁ =
    subobject.of_le (P i) _ (finset.le_sup i.2)  ≫ f₂) :
     f₁ = f₂ :=
begin
  revert f₁ f₂ h,
  induction s using finset.cons_induction_on with j s hj hs,
  { intros f₁ f₂ h,
    apply is_initial.hom_ext,
    simpa only [finset.sup_empty] using
      is_initial.of_iso initial_is_initial subobject.bot_coe_iso_initial.symm, },
  { intros f₁ f₂ h,
    let e := subobject.iso_of_eq ((finset.cons j s hj).sup P) (P j ⊔ s.sup P)
      (finset.sup_cons _),
    rw ← cancel_epi e.inv,
    apply subobject.jointly_epi_to_binary_sup,
    { simpa only [subobject.iso_of_eq_inv, subobject.of_le_comp_of_le_assoc]
        using h ⟨j, finset.mem_cons_self j s⟩, },
    { apply hs,
      intro i,
      simpa only [subobject.iso_of_eq_inv, subobject.of_le_comp_of_le_assoc]
        using h ⟨i.1 , finset.mem_cons.2 (or.inr i.2)⟩, }, },
end

lemma subobject.jointly_epi_to_univ_sup {I : Type*} [fintype I] {B : C}
  (P : I → subobject B) {Z : C} (f₁ f₂ : ↑(finset.univ.sup P) ⟶ Z)
  (h : ∀ (i : I), subobject.of_le (P i) _ (finset.le_sup (finset.mem_univ _)) ≫ f₁ =
    subobject.of_le (P i) _ (finset.le_sup (finset.mem_univ _)) ≫ f₂) : f₁ = f₂ :=
subobject.jointly_epi_to_sup _ _ _ _ (λ i, h i.1)

instance : epi (coproduct_to_finset_univ_sup P) :=
⟨λ Z f₁ f₂ h, subobject.jointly_epi_to_univ_sup _ _ _
  (λ i, by simpa only [coproduct_to_finset_univ_sup, colimit.ι_desc_assoc, cofan.mk_ι_app]
    using sigma.ι _ i ≫= h)⟩

lemma ι_comp_coproduct_to_finset_univ_sup_comp_arrow (i : I) :
  sigma.ι _ i ≫ coproduct_to_finset_univ_sup P ≫ (finset.univ.sup P).arrow = (P i).arrow :=
by simp only [coproduct_to_finset_univ_sup, colimit.ι_desc_assoc, cofan.mk_ι_app,
  subobject.of_le_arrow]

end

lemma subobject.factors_sum {X Y : C} [preadditive C] {P : subobject Y} {I : Type*}
  (s : finset I) (f : I → (X ⟶ Y)) (hf : ∀ (i : I) (hi : i ∈ s), P.factors (f i)) :
  P.factors (s.sum f) :=
begin
  rw subobject.factors_iff,
  refine ⟨finset.univ.sum (λ (j : s), P.factor_thru (f j) (hf j.1 j.2)), _⟩,
  simp only [subobject.representative_arrow, sum_comp,
    subobject.factor_thru_arrow, finset.sum_coe_sort],
end

end category_theory

open category_theory category_theory.limits opposite category_theory.preadditive
  category_theory.category algebraic_topology.dold_kan
open_locale simplicial dold_kan

namespace algebraic_topology

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

namespace degenerate_subcomplex

@[simp]
def obj_X (X : simplicial_object C) : Π (n : ℕ), subobject (K[X].X n)
| 0 := ⊥
| (n+1) := finset.univ.sup (λ (i : fin (n+1)), image_subobject (X.σ i))

lemma obj_X_factors_σ (X : simplicial_object C)
  {n : ℕ} (i : fin (n+1)) : (obj_X X (n+1)).factors (X.σ i) :=
subobject.finset_sup_factors ⟨i, finset.mem_univ _, ⟨factor_thru_image (X.σ i), by simp⟩⟩

lemma obj_X_factors_of_not_mono (X : simplicial_object C)
  (n : ℕ) {Δ : simplex_category} (θ : [n] ⟶ Δ) (hθ : ¬mono θ) :
  (obj_X X n).factors (X.map θ.op) :=
begin
  rw simplex_category.mono_iff_injective at hθ,
  cases n,
  { exfalso,
    apply hθ,
    intros x y h,
    fin_cases x,
    fin_cases y, },
  { rcases simplex_category.eq_σ_comp_of_not_injective θ hθ with ⟨i, α, h⟩,
    rw [h, op_comp, X.map_comp],
    apply subobject.factors_of_factors_right,
    apply obj_X_factors_σ, },
end

@[derive epi]
def coproduct_to_obj_X (X : simplicial_object C) (n : ℕ) :
  ∐ (λ (i : fin (n+1)), (image_subobject (X.σ i): C)) ⟶ ↑(obj_X X (n+1)) :=
coproduct_to_finset_univ_sup (λ (i : fin (n + 1)), image_subobject (X.σ i))

@[reassoc]
lemma ι_coproduct_to_obj_X_comp_arrow (X : simplicial_object C) {n : ℕ} (i : fin (n+1)) :
  sigma.ι _ i ≫ coproduct_to_obj_X X n ≫ (obj_X X (n+1)).arrow =
  (image_subobject (X.σ i)).arrow :=
by apply ι_comp_coproduct_to_finset_univ_sup_comp_arrow

@[simp, reassoc]
lemma obj_X_arrow_comp_P_infty (X : simplicial_object C) (n : ℕ) :
  (obj_X X n).arrow ≫ P_infty.f n = 0 :=
begin
  cases n,
  { dsimp [obj_X],
    simp only [subobject.bot_arrow, zero_comp], },
  { rw ← cancel_epi (coproduct_to_obj_X X n),
    ext,
    discrete_cases,
    simp only [ι_coproduct_to_obj_X_comp_arrow_assoc, comp_zero,
      ← cancel_epi (factor_thru_image_subobject (X.σ j)),
      image_subobject_arrow_comp_assoc, σ_comp_P_infty], },
end

@[simp, reassoc]
lemma obj_X_arrow_comp_Q_infty (X : simplicial_object C) (n : ℕ) :
  (obj_X X n).arrow ≫ Q_infty.f n = (obj_X X n).arrow :=
by simp only [Q_infty, homological_complex.sub_f_apply, homological_complex.id_f,
    comp_sub, comp_id, obj_X_arrow_comp_P_infty, sub_zero]

lemma obj_X_factors_Q (X : simplicial_object C) (n : ℕ) :
  (obj_X X n).factors (Q_infty.f n) :=
begin
  rw Q_infty_f,
  cases n,
  { simpa only [Q_f_0_eq, obj_X] using subobject.factors_zero, },
  { rw decomposition_Q n (n+1),
    apply subobject.factors_sum,
    intros i hi,
    apply subobject.factors_of_factors_right,
    apply subobject.factors_of_factors_right,
    apply obj_X_factors_σ, },
end

@[simp]
lemma obj_X_factors_iff_comp_P_infty_eq_zero (X : simplicial_object C) {Y : C} (n : ℕ)
  (f : Y ⟶ X _[n]) :
  (obj_X X n).factors f ↔ f ≫ P_infty.f n = 0 :=
begin
  split,
  { intro h,
    rw [← (obj_X X n).factor_thru_arrow _ h, assoc, obj_X_arrow_comp_P_infty, comp_zero], },
  { intro h,
    have h' : f ≫ Q_infty.f n = f,
    { rw P_infty_f at h,
      rw Q_infty_f,
      dsimp only [Q],
      simpa only [homological_complex.sub_f_apply, homological_complex.id_f, comp_sub,
        h, sub_zero] using comp_id f, },
    rw ← h',
    exact subobject.factors_of_factors_right _ (obj_X_factors_Q _ _), },
end

lemma obj_X_eq_kernel_P_infty (X : simplicial_object C) (n : ℕ) :
  obj_X X n = kernel_subobject (P_infty.f n) :=
begin
  apply le_antisymm; rw subobject.le_iff,
  { rw [kernel_subobject_factors_iff, ← obj_X_factors_iff_comp_P_infty_eq_zero],
    apply subobject.factors_self, },
  { rw [obj_X_factors_iff_comp_P_infty_eq_zero, kernel_subobject_arrow_comp], },
end

lemma d_factors_obj_X (X : simplicial_object C) (i j : ℕ) :
  (obj_X X j).factors ((obj_X X i).arrow ≫ K[X].d i j) :=
by rw [obj_X_factors_iff_comp_P_infty_eq_zero, assoc, ← P_infty.comm i j,
  obj_X_eq_kernel_P_infty, kernel_subobject_arrow_comp_assoc, zero_comp]

@[simps]
def obj (X : simplicial_object C) : chain_complex C ℕ :=
{ X := λ n, obj_X X n,
  d := λ i j, (obj_X X j).factor_thru _ (d_factors_obj_X X i j),
  shape' := λ i j hij, by { ext, rw [subobject.factor_thru_arrow,
    K[X].shape i j hij, zero_comp, comp_zero], },
  d_comp_d' := λ i j k hij hjk, by { ext, simp only [assoc, comp_zero, zero_comp,
    subobject.factor_thru_arrow, subobject.factor_thru_arrow_assoc, K[X].d_comp_d], }, }

lemma map_factors_obj_X {X Y : simplicial_object C} (f : X ⟶ Y) (n : ℕ) :
  (obj_X Y n).factors ((obj_X X n).arrow ≫ ((alternating_face_map_complex C).map f).f n) :=
by simp

@[simps]
def map {X Y : simplicial_object C} (f : X ⟶ Y) : obj X ⟶ obj Y :=
{ f := λ n, (obj_X Y n).factor_thru _ (map_factors_obj_X f n),
  comm' := λ i j hij, begin
    ext,
    simp only [obj_d, assoc, subobject.factor_thru_arrow, subobject.factor_thru_arrow_assoc],
    congr' 1,
    exact ((alternating_face_map_complex C).map f).comm i j,
  end, }

end degenerate_subcomplex

localized "notation `D[`X`]` := algebraic_topology.degenerate_subcomplex.obj X" in dold_kan

variable (C)

@[simps]
def degenerate_subcomplex : simplicial_object C ⥤ chain_complex C ℕ :=
{ obj := degenerate_subcomplex.obj,
  map := λ X Y, degenerate_subcomplex.map, }

variable {C}

@[simps]
def inclusion_of_degenerate_subcomplex_app (X : simplicial_object C) :
  (degenerate_subcomplex C).obj X ⟶ (alternating_face_map_complex C).obj X :=
{ f := λ n, (degenerate_subcomplex.obj_X X n).arrow, }

variable (C)

@[simps]
def inclusion_of_degenerate_subcomplex :
  degenerate_subcomplex C ⟶ alternating_face_map_complex C :=
{ app := inclusion_of_degenerate_subcomplex_app, }

namespace dold_kan

variable {C}

@[simps]
def Q_infty_to_degenerate_subcomplex (X : simplicial_object C) : K[X] ⟶ D[X] :=
{ f := λ n, (degenerate_subcomplex.obj_X X n).factor_thru (Q_infty.f n)
    (by rw [degenerate_subcomplex.obj_X_factors_iff_comp_P_infty_eq_zero,
      Q_infty_f_comp_P_infty_f]),
  comm' := λ i j hij, begin
    ext,
    simp only [degenerate_subcomplex.obj_d, assoc, subobject.factor_thru_arrow,
      subobject.factor_thru_arrow_assoc, homological_complex.hom.comm],
  end, }

instance : has_binary_biproducts (chain_complex C ℕ) := sorry

@[simp, reassoc]
lemma Q_infty_to_degenerate_subcomplex_comp_inclusion_of_degenerate_subcomplex_app
  (X : simplicial_object C) :
  Q_infty_to_degenerate_subcomplex X ≫ inclusion_of_degenerate_subcomplex_app X = Q_infty :=
by tidy

/-- `inclusion_of_degenerate_subcomplex_app X` is a split mono. -/
def split_mono_inclusion_of_degenerate_subcomplex_app (X : simplicial_object C) :
  split_mono (inclusion_of_degenerate_subcomplex_app X) :=
{ retraction := Q_infty_to_degenerate_subcomplex X, }

@[simp, reassoc]
lemma decomposition_KND₁₁ (X : simplicial_object C) :
  inclusion_of_Moore_complex_map X ≫ P_infty_to_normalized_Moore_complex X = 𝟙 N[X] :=
(split_mono_inclusion_of_Moore_complex_map X).id

@[simp, reassoc]
lemma decomposition_KND₂₁ (X : simplicial_object C) :
  inclusion_of_Moore_complex_map X ≫ Q_infty_to_degenerate_subcomplex X = 0 :=
begin
  ext n,
  simpa only [homological_complex.comp_f, Q_infty_to_degenerate_subcomplex_f, assoc,
    subobject.factor_thru_arrow, homological_complex.zero_f_apply, zero_comp]
    using homological_complex.congr_hom (inclusion_of_Moore_complex_map_comp_Q_infty X) n,
end

@[simp, reassoc]
lemma decomposition_KND₁₂ (X : simplicial_object C) :
  inclusion_of_degenerate_subcomplex_app X ≫ P_infty_to_normalized_Moore_complex X = 0 :=
begin
  ext n,
  simp only [homological_complex.comp_f, assoc, P_infty_to_normalized_Moore_complex_f,
    subobject.factor_thru_arrow, homological_complex.zero_f_apply, zero_comp,
    inclusion_of_degenerate_subcomplex_app_f, degenerate_subcomplex.obj_X_arrow_comp_P_infty],
end

@[simp, reassoc]
lemma decomposition_KND₂₂ (X : simplicial_object C) :
  inclusion_of_degenerate_subcomplex_app X ≫ Q_infty_to_degenerate_subcomplex X = 𝟙 D[X] :=
(split_mono_inclusion_of_degenerate_subcomplex_app X).id

def decomposition_K_N_D (X : simplicial_object C) : K[X] ≅ N[X] ⊞ D[X] :=
{ hom := biprod.lift (P_infty_to_normalized_Moore_complex X)
    (Q_infty_to_degenerate_subcomplex X),
  inv := biprod.desc (inclusion_of_Moore_complex_map X)
    (inclusion_of_degenerate_subcomplex_app X),
  hom_inv_id' := by simp only [biprod.lift_desc, P_infty_add_Q_infty,
    P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map,
    Q_infty_to_degenerate_subcomplex_comp_inclusion_of_degenerate_subcomplex_app],
  inv_hom_id' := by { ext1; ext1; simp, }, }

end dold_kan

end algebraic_topology


import galois.data.bounded_list
import galois.list.take_drop_lemmas

universes u v

namespace ksi
namespace merkle

structure combine_result (Link Data : Type) :=
(root : Data)
(left : Link)
(right : Link)

/-- Operations needed to build a Merkle tree.-/
structure merkle_ops (Leaf Link Data : Type) :=
(empty_root : Data)
(leaf_data : Leaf → Data)
(apply_link : Link → Data → Data)
(combine_data : Data -> Data → combine_result Link Data)
(apply_left_correct
: ∀(x y : Data), apply_link (combine_data x y).left x = (combine_data x y).root)
(apply_right_correct
: ∀(x y : Data), apply_link (combine_data x y).right y = (combine_data x y).root)

section types

parameters {Leaf Link Data : Type}
parameter (s : merkle_ops Leaf Link Data)

/-- This stores information about a path from a leaf to a root.

 max_req_level bounds the length of the links.
-/
structure path (max_req_level : ℕ) (root : Data) :=
(leaf  : Leaf)
(links : bounded_list Link max_req_level)
-- Proof theat the
(root_valid : links.val.foldr s.apply_link (s.leaf_data leaf) = root)

/-- This represents-/
structure merkle_result (max_req_level : ℕ) (l : list Leaf) :=
-- what we are aggregating
(root : Data)
-- the paths through the tree to get to this point
(paths : list (path max_req_level root))
-- what we have not yet aggregated
(remaining : list Leaf)
-- Proof we include all the original paths.
(paths_valid : paths.map path.leaf ++ remaining = l)
-- The length of the paths
(remaining_valid : remaining = l.drop (2^max_req_level))

end types

section merkle

-- This contains the types for the leaves of the tree and link elements
parameters {Leaf Link Data : Type}
parameter (ops : merkle_ops Leaf Link Data)

def path.extend_none {n:ℕ} {root : Data} (p : path ops n root)
: path ops n.succ root :=
  { links := p.links.extend 1
  , leaf  := p.leaf
  , root_valid :=
    begin
      cases p,
      cases links,
      exact root_valid,
    end
  }

theorem path_extend_none (n : ℕ) (root : Data)
: path.leaf ∘ @path.extend_none n root = path.leaf :=
begin
  apply funext,
  intro p,
  cases p,
  simp [function.comp, path.extend_none],
end

def gpath.extend_sibling (n : ℕ) {r r' : Data}
    (l : Link)
    (eq : ops.apply_link l r = r')
    (p : path ops n r)
: path ops n.succ r' :=
{ links := p.links.cons l
, leaf  := p.leaf
, root_valid :=
  begin
    cases p,
    cases links,
    simp [bounded_list.cons, root_valid, eq],
  end
}

theorem path_extend_sibling (n : ℕ) (r r' : Data) (l : Link)
  (eq : ops.apply_link l r = r')
: path.leaf ∘ @gpath.extend_sibling n r r' l eq = path.leaf :=
begin
  apply funext,
  intro p,
  cases p,
  simp [function.comp, gpath.extend_sibling],
end

def dcases_on {T : Type u} {C : list T → Sort v}
  (n : list T)
  (base : n = [] → C [])
  (ind : Π (h : T) (r : list T), n = h::r → C (h :: r))
: C n :=
   @list.cases_on T (λl, n = l → C l) n base ind rfl

def merkle_core
     : Π (n : ℕ) (e : Leaf) (rest : list Leaf),
       merkle_result ops n (e::rest)
| 0 e rest :=
{ root := ops.leaf_data e
, paths := [{ leaf := e
            , links := bounded_list.nil
            , root_valid := rfl,
            }]
, remaining := rest
, paths_valid := rfl
, remaining_valid := rfl
}
| (nat.succ n) e rest := do
  let left_result := merkle_core n e rest in
  @dcases_on _ (λr, merkle_result ops n.succ (e::rest)) left_result.remaining
    (λ(eq : left_result.remaining = []),
      { root := left_result.root
      , paths := left_result.paths.map path.extend_none
      , remaining := left_result.remaining
      , paths_valid :=
        begin
          simp [path_extend_none, left_result.paths_valid],
        end
      , remaining_valid :=
        begin
          have h : (2^nat.succ n) = 2^n + 2^n,
          { simp [nat.pow, nat.succ_mul], },
          have g := left_result.remaining_valid,
          rw [h, list.drop_add, ← g, eq, list.drop_nil],
        end
      })
    (λ(e' : Leaf) (rest' : list Leaf) (eq : left_result.remaining = e' :: rest'),
      let right_result := merkle_core n e' rest' in
      let z := ops.combine_data left_result.root right_result.root in
      let l_eq := ops.apply_left_correct left_result.root right_result.root in
      let r_eq := ops.apply_right_correct left_result.root right_result.root in
      { root := z.root
      , paths := left_result.paths.map  (gpath.extend_sibling n z.left  l_eq)
              ++ right_result.paths.map (gpath.extend_sibling n z.right r_eq)
      , remaining := right_result.remaining
      , paths_valid :=
        begin
          simp [path_extend_sibling, right_result.paths_valid],
          rw [← eq],
          exact left_result.paths_valid,
        end
      , remaining_valid :=
        begin
          have h : (2^nat.succ n) = 2^n + 2^n,
          { simp [nat.pow, nat.succ_mul], },
          rw [h, list.drop_add, ← left_result.remaining_valid, eq],
          exact right_result.remaining_valid,
        end
      })

def merkle
     : Π (n : ℕ) (l : list Leaf), merkle_result ops n l
| n [] :=
{ root := ops.empty_root
, paths := []
, remaining := []
, paths_valid := rfl
, remaining_valid := by simp [list.drop_nil],
}
| n (e::r) := merkle_core n e r

end merkle

end merkle
end ksi


universe variables u v

variables {α : Type u} {β : α → Type v}

variables {x y : sigma β}
variables H  : x.1 = y.1
variables H' : x.1 = y.1 → x.2 == y.2

include H H'

lemma sigma.ext : x = y :=
begin
  cases x with x₀ x₁,
  cases y with y₀ y₁,
  have H'' := H' H, clear H',
  unfold sigma.fst at H,
  unfold sigma.snd at H'',
  subst y₀,
  rw eq_of_heq H'',
end


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

import data.int.cast            -- used by clients
import data.int.char_zero
import tactic.norm_cast

/-!
# A tactic to shift `ℕ` goals to `ℤ`

It is often easier to work in `ℤ`, where subtraction is well behaved, than in `ℕ` where it isn't.
`zify` is a tactic that casts goals and hypotheses about natural numbers to ones about integers.
It makes use of `push_cast`, part of the `norm_cast` family, to simplify these goals.

## Implementation notes

`zify` is extensible, using the attribute `@[zify]` to label lemmas used for moving propositions
from `ℕ` to `ℤ`.
`zify` lemmas should have the form `∀ a₁ ... aₙ : ℕ, Pz (a₁ : ℤ) ... (aₙ : ℤ) ↔ Pn a₁ ... aₙ`.
For example, `int.coe_nat_le_coe_nat_iff : ∀ (m n : ℕ), ↑m ≤ ↑n ↔ m ≤ n` is a `zify` lemma.

`zify` is very nearly just `simp only with zify push_cast`. There are a few minor differences:
* `zify` lemmas are used in the opposite order of the standard simp form.
  E.g. we will rewrite with `int.coe_nat_le_coe_nat_iff` from right to left.
* `zify` should fail if no `zify` lemma applies (i.e. it was unable to shift any proposition to ℤ).
  However, once this succeeds, it does not necessarily need to rewrite with any `push_cast` rules.
-/

open tactic

namespace zify

/--
The `zify` attribute is used by the `zify` tactic. It applies to lemmas that shift propositions
between `nat` and `int`.

`zify` lemmas should have the form `∀ a₁ ... aₙ : ℕ, Pz (a₁ : ℤ) ... (aₙ : ℤ) ↔ Pn a₁ ... aₙ`.
For example, `int.coe_nat_le_coe_nat_iff : ∀ (m n : ℕ), ↑m ≤ ↑n ↔ m ≤ n` is a `zify` lemma.
-/
@[user_attribute]
meta def zify_attr : user_attribute simp_lemmas unit :=
{ name := `zify,
  descr := "Used to tag lemmas for use in the `zify` tactic",
  cache_cfg :=
    { mk_cache :=
        λ ns, mmap (λ n, do c ← mk_const n, return (c, tt)) ns >>= simp_lemmas.mk.append_with_symm,
      dependencies := [] } }

/--
Given an expression `e`, `lift_to_z e` looks for subterms of `e` that are propositions "about"
natural numbers and change them to propositions about integers.

Returns an expression `e'` and a proof that `e = e'`.

Includes `ge_iff_le` and `gt_iff_lt` in the simp set. These can't be tagged with `zify` as we
want to use them in the "forward", not "backward", direction.
-/
meta def lift_to_z (e : expr) : tactic (expr × expr) :=
do sl ← zify_attr.get_cache,
   sl ← sl.add_simp `ge_iff_le, sl ← sl.add_simp `gt_iff_lt,
   (e', prf, _) ← simplify sl [] e,
   return (e', prf)

attribute [zify] int.coe_nat_le_coe_nat_iff int.coe_nat_lt_coe_nat_iff int.coe_nat_eq_coe_nat_iff

end zify

@[zify] lemma int.coe_nat_ne_coe_nat_iff (a b : ℕ) : (a : ℤ) ≠ b ↔ a ≠ b :=
by simp

/--
`zify extra_lems e` is used to shift propositions in `e` from `ℕ` to `ℤ`.
This is often useful since `ℤ` has well-behaved subtraction.

The list of extra lemmas is used in the `push_cast` step.

Returns an expression `e'` and a proof that `e = e'`.-/
meta def tactic.zify (extra_lems : list simp_arg_type) : expr → tactic (expr × expr) := λ z,
do (z1, p1) ← zify.lift_to_z z <|> fail "failed to find an applicable zify lemma",
   (z2, p2) ← norm_cast.derive_push_cast extra_lems z1,
   prod.mk z2 <$> mk_eq_trans p1 p2

/--
A variant of `tactic.zify` that takes `h`, a proof of a proposition about natural numbers,
and returns a proof of the zified version of that propositon.
-/
meta def tactic.zify_proof (extra_lems : list simp_arg_type) (h : expr) : tactic expr :=
do (_, pf) ← infer_type h >>= tactic.zify extra_lems,
   mk_eq_mp pf h

section

setup_tactic_parser

/--
The `zify` tactic is used to shift propositions from `ℕ` to `ℤ`.
This is often useful since `ℤ` has well-behaved subtraction.

```lean
example (a b c x y z : ℕ) (h : ¬ x*y*z < 0) : c < a + 3*b :=
begin
  zify,
  zify at h,
  /-
  h : ¬↑x * ↑y * ↑z < 0
  ⊢ ↑c < ↑a + 3 * ↑b
  -/
end
```

`zify` can be given extra lemmas to use in simplification. This is especially useful in the
presence of nat subtraction: passing `≤` arguments will allow `push_cast` to do more work.
```
example (a b c : ℕ) (h : a - b < c) (hab : b ≤ a) : false :=
begin
  zify [hab] at h,
  /- h : ↑a - ↑b < ↑c -/
end
```

`zify` makes use of the `@[zify]` attribute to move propositions,
and the `push_cast` tactic to simplify the `ℤ`-valued expressions.

`zify` is in some sense dual to the `lift` tactic. `lift (z : ℤ) to ℕ` will change the type of an
integer `z` (in the supertype) to `ℕ` (the subtype), given a proof that `z ≥ 0`;
propositions concerning `z` will still be over `ℤ`. `zify` changes propositions about `ℕ` (the
subtype) to propositions about `ℤ` (the supertype), without changing the type of any variable.
-/
meta def tactic.interactive.zify (sl : parse simp_arg_list) (l : parse location) : tactic unit :=
do locs ← l.get_locals,
replace_at (tactic.zify sl) locs l.include_goal >>= guardb

end

add_tactic_doc
{ name := "zify",
  category := doc_category.attr,
  decl_names := [`zify.zify_attr],
  tags := ["coercions", "transport"] }

add_tactic_doc
{ name := "zify",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.zify],
  tags := ["coercions", "transport"] }


import data.rat
import data.polynomial
import data.int.basic
import data.set
import ring_theory.adjoin_root
import ring_theory.polynomial
import data.nat.prime
import algebra.ring
import .normal
import data.finsupp
import linear_algebra.finite_dimensional

noncomputable theory
universes u v

open polynomial
open finsupp
open finite_dimensional

variables {F : Type u} {L : Type v}
variables [field F] [field L] [algebra F L] [finite_dimensional F L]

lemma sub_eq_plus_minus (a : F) : (X - C a) = (X + C (-a)) :=
by { simp, ring }

lemma zero_eq_zero_coe : (0 : with_bot ℕ) = ↑(0 : ℕ) := rfl

lemma one_eq_one_coe : (1 : with_bot ℕ) = ↑(1 : ℕ) := rfl

lemma two_eq_two_coe : (2 : with_bot ℕ) = ↑(2 : ℕ) := rfl

lemma coe_sum_eq_sum_coe (a b : ℕ) : ↑(a + b) = ↑a + (↑b : with_bot ℕ) := rfl

lemma ne_zero_of_degree_eq_n_gt {p : polynomial F} {n : nat}
  (hn : 0 < n) (hp : degree p = n) : (p ≠ 0) :=
begin
have degree_gt_zero : 0 < degree p,
  { simp [hp, zero_eq_zero_coe, ←with_bot.some_eq_coe],
    exact hn,
    },
apply ne_zero_of_degree_gt degree_gt_zero,
end

lemma ne_zero_of_degree_one {p : polynomial F}
  (hp : degree p = 1) : (p ≠ 0) :=
ne_zero_of_degree_eq_n_gt zero_lt_one hp

lemma ne_zero_of_degree_two {p : polynomial F}
  (hp : degree p = 2) : (p ≠ 0) :=
ne_zero_of_degree_eq_n_gt zero_lt_two hp

lemma splits_of_degree_two_root (f : polynomial F)
(f_deg2 : degree f = 2) (a : F) (ha : is_root f a) :
(splits (algebra_map F L) f) :=
begin
intros,
let i := (algebra_map F L),
let f1 := (X - C a),
have f_nz : f ≠ 0,
  from ne_zero_of_degree_two f_deg2,
have sub_eq_plus_minus : (X - C a) = (X + C (-a)),
{ simp, ring },
have d : f1 ∣ f,
  from iff.elim_right dvd_iff_is_root ha,
have f1_deg_1 : degree f1 = 1,
by simp [f1],
have f1_nz : f1 ≠ 0,
  from ne_zero_of_degree_one f1_deg_1,
have f1_monic : monic f1,
{ rw congr_arg monic sub_eq_plus_minus, -- this ought to be able to be done by simp
  apply (monic_X_add_C (-a)) },
let f2 := (f /ₘ f1),
have f2_nz : f2 ≠ 0,
{ simp [div_by_monic_eq_zero_iff f1_monic f1_nz, f_deg2],
  rw [two_eq_two_coe],
  rw [one_eq_one_coe],
  simp [←with_bot.some_eq_coe] },
have f2_deg_1 : degree f2 = 1, -- this section is unwieldly
{ have equation : degree f1 + degree (f /ₘ f1) = degree f,
  { have deg_f1_lt_deg_f : degree f1 ≤ degree f,
    { simp [f1_deg_1, f_deg2],
      rw [two_eq_two_coe],
      rw [one_eq_one_coe],
      simp [←with_bot.some_eq_coe] },
    apply degree_add_div_by_monic f1_monic deg_f1_lt_deg_f },
  have equivalence : degree f1 + degree (f /ₘ f1) = degree f ↔ degree f2 = 1,
  { calc degree f1 + degree (f /ₘ f1) = degree f
       ↔ degree f1 + degree f2 = degree f : by simp [f2]
   ... ↔ 1 + degree f2 = 2 : by rw [f1_deg_1, f_deg2]
   ... ↔ ↑(1) + degree f2 = ↑(2) : by rw [two_eq_two_coe, one_eq_one_coe]
   ... ↔ ↑(1) + ↑(nat_degree f2) = ↑(2) : by rw [degree_eq_nat_degree f2_nz]
   ... ↔ ↑((1 : ℕ) + nat_degree f2) = ↑((2 : ℕ)) : by rw [coe_sum_eq_sum_coe]
   ... ↔ (1 + nat_degree f2) = (2)
           : with_bot.coe_eq_coe
   ... ↔ nat_degree f2 = 1 : by simp [bit0]
   ... ↔ degree f2 = 1 : by simp [←degree_eq_iff_nat_degree_eq f2_nz]},
  rw [←equivalence],
  apply equation },
have s1 : splits i f1,
  by apply splits_of_degree_eq_one i f1_deg_1,
have s2 : splits i f2,
  by apply splits_of_degree_eq_one i f2_deg_1,
have mul_f : f = f1 * f2,
{ simp [f2, f1],
  exact (eq.symm (iff.elim_right mul_div_by_monic_eq_iff_is_root ha)) },
rw congr_arg (splits i) mul_f,
apply splits_mul i s1 s2
end

lemma degree_le_findim (x : L) {hx : is_integral F x} :
degree (minimal_polynomial hx) ≤ findim F L :=
sorry

theorem normal_of_degree_two_extension (h : findim F L = 2) :
normal F L :=
sorry


import condensed.exact
import for_mathlib.split_exact

noncomputable theory

universe u

open opposite category_theory

namespace Condensed

lemma mono_iff_ExtrDisc {A B : Condensed.{u} Ab.{u+1}} (f : A ⟶ B) :
  mono f ↔ ∀ S : ExtrDisc, mono (f.1.app $ ExtrDisc_to_Profinite.op.obj (op S)) :=
begin
  split,
  { intros H S,
    erw (abelian.tfae_mono (A.val.obj (op S.val)) (f.val.app (op S.val))).out 0 2,
    erw (abelian.tfae_mono A f).out 0 2 at H,
    rw Condensed.exact_iff_ExtrDisc at H,
    apply H, },
  { intro H,
    apply exact.mono_of_exact_zero_left, swap, exact A,
    rw Condensed.exact_iff_ExtrDisc,
    intro S, specialize H S,
    show exact 0 _,
    erw (abelian.tfae_mono (A.val.obj (op S.val)) (f.val.app (op S.val))).out 2 0,
    exact H, }
end

lemma short_exact_iff_ExtrDisc {A B C : Condensed.{u} Ab.{u+1}} (f : A ⟶ B) (g : B ⟶ C) :
  short_exact f g ↔ ∀ S : ExtrDisc, short_exact
      (f.1.app $ ExtrDisc_to_Profinite.op.obj (op S))
      (g.1.app $ ExtrDisc_to_Profinite.op.obj (op S)) :=
begin
  split,
  { intros H S,
    apply_with short_exact.mk {instances:=ff},
    { revert S, rw ← mono_iff_ExtrDisc, exact H.mono, },
    { rw AddCommGroup.epi_iff_surjective,
      revert S, erw ← is_epi_iff_forall_surjective, exact H.epi, },
    { revert S, rw ← Condensed.exact_iff_ExtrDisc, exact H.exact } },
  { intro H,
    apply_with short_exact.mk {instances:=ff},
    { rw mono_iff_ExtrDisc, intro S, exact (H S).mono, },
    { simp only [is_epi_iff_forall_surjective, ← AddCommGroup.epi_iff_surjective],
      intro S, exact (H S).epi, },
    { rw Condensed.exact_iff_ExtrDisc, intro S, exact (H S).exact } }
end

end Condensed


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

! This file was ported from Lean 3 source module tactic.tauto
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Hint

namespace Tactic

open Expr

open Tactic.Interactive (casesm constructor_matching)

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      find all assumptions of the shape `¬ (p ∧ q)` or `¬ (p ∨ q)` and
        replace them using de Morgan's law.
      -/
    unsafe
  def
    distrib_not
    : tactic Unit
    :=
      do
        let hs ← local_context
          hs
            fun
              h
                =>
                all_goals'
                  <|
                  iterate_at_most'
                    3
                      do
                        let h ← get_local h
                          let e ← infer_type h
                          match
                            e
                            with
                            | q( ¬ _ = _ ) => replace h ` `( mt Iff.to_eq $ ( h ) )
                              | q( _ ≠ _ ) => replace h ` `( mt Iff.to_eq $ ( h ) )
                              | q( _ = _ ) => replace h ` `( Eq.to_iff $ ( h ) )
                              |
                                q( ¬ ( _ ∧ _ ) )
                                =>
                                replace h ` `( Decidable.not_and' . mp $ ( h ) )
                                  <|>
                                  replace h ` `( Decidable.not_and . mp $ ( h ) )
                              | q( ¬ ( _ ∨ _ ) ) => replace h ` `( not_or . mp $ ( h ) )
                              | q( ¬ _ ≠ _ ) => replace h ` `( Decidable.of_not_not $ ( h ) )
                              | q( ¬ ¬ _ ) => replace h ` `( Decidable.of_not_not $ ( h ) )
                              |
                                q( ¬ ( _ → ( _ : Prop ) ) )
                                =>
                                replace h ` `( Decidable.not_imp . mp $ ( h ) )
                              | q( ¬ ( _ ↔ _ ) ) => replace h ` `( Decidable.not_iff . mp $ ( h ) )
                              |
                                q( _ ↔ _ )
                                =>
                                replace h ` `( Decidable.iff_iff_and_or_not_and_not . mp $ ( h ) )
                                  <|>
                                  replace
                                      h
                                        `
                                          `(
                                            Decidable.iff_iff_and_or_not_and_not . mp $ ( h ) . symm
                                            )
                                    <|>
                                    ( ) <$ tactic.cases h
                              | q( _ → _ ) => replace h ` `( Decidable.not_or_of_imp $ ( h ) )
                              | _ => failed
#align tactic.distrib_not tactic.distrib_not

/-!
  The following definitions maintain a path compression datastructure, i.e. a forest such that:
    - every node is the type of a hypothesis
    - there is a edge between two nodes only if they are provably equivalent
    - every edge is labelled with a proof of equivalence for its vertices
    - edges are added when normalizing propositions.
-/

unsafe def tauto_state :=
  ref <| expr_map (Option (expr × expr))
#align tactic.tauto_state tactic.tauto_state

unsafe def modify_ref {α : Type} (r : ref α) (f : α → α) :=
  read_ref r >>= write_ref r ∘ f
#align tactic.modify_ref tactic.modify_ref

unsafe def add_refl (r : tauto_state) (e : expr) : tactic (expr × expr) := do
  let m ← read_ref r
  let p ← mk_mapp `rfl [none, e]
  write_ref r <| m e none
  return (e, p)
#align tactic.add_refl tactic.add_refl

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      If there exists a symmetry lemma that can be applied to the hypothesis `e`,
        store it.
      -/
    unsafe
  def
    add_symm_proof
    ( r : tauto_state ) ( e : expr ) : tactic ( expr × expr )
    :=
      do
        let env ← get_env
          let rel := e . get_app_fn . const_name
          let some symm ← pure <| environment.symm_for env Rel | add_refl r e
          (
              do
                let e' ← mk_meta_var q( Prop )
                  let iff_t ← to_expr ` `( $ ( e ) = $ ( e' ) )
                  let
                    ( _ , p )
                      ←
                      solve_aux
                        iff_t
                          (
                            andthen
                              ( andthen ( applyc `iff.to_eq ) ( ( ) <$ split ) ) ( applyc symm )
                            )
                  let e' ← instantiate_mvars e'
                  let m ← read_ref r
                  write_ref r <| ( m e ( e' , p ) ) . insert e' none
                  return ( e' , p )
              )
            <|>
            add_refl r e
#align tactic.add_symm_proof tactic.add_symm_proof

unsafe def add_edge (r : tauto_state) (x y p : expr) : tactic Unit :=
  modify_ref r fun m => m.insert x (y, p)
#align tactic.add_edge tactic.add_edge

/-- Retrieve the root of the hypothesis `e` from the proof forest.
  If `e` has not been internalized, add it to the proof forest.
-/
unsafe def root (r : tauto_state) : expr → tactic (expr × expr)
  | e => do
    let m ← read_ref r
    let record_e : tactic (expr × expr) :=
      match e with
      | v@(expr.mvar _ _ _) =>
        (do
            let (e, p) ← get_assignment v >>= root
            add_edge r v e p
            return (e, p)) <|>
          add_refl r e
      | _ => add_refl r e
    let some e' ← pure <| m.find e |
      record_e
    match e' with
      | some (e', p') => do
        let (e'', p'') ← root e'
        let p'' ← mk_app `eq.trans [p', p'']
        add_edge r e e'' p''
        pure (e'', p'')
      | none => Prod.mk e <$> mk_mapp `rfl [none, some e]
#align tactic.root tactic.root

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Given hypotheses `a` and `b`, build a proof that `a` is equivalent to `b`,
        applying congruence and recursing into arguments if `a` and `b`
        are applications of function symbols.
      -/
    unsafe
  def
    symm_eq
    ( r : tauto_state ) : expr → expr → tactic expr
    |
      a , b
      =>
      do
        let m ← read_ref r
          let ( a' , pa ) ← root r a
          let ( b' , pb ) ← root r b
          unify a' b' >> add_refl r a' *> mk_mapp `rfl [ none , a ]
            <|>
            do
              let
                  p
                    ←
                    match
                      ( a' , b' )
                      with
                      |
                          ( q( ¬ $ ( a₀ ) ) , q( ¬ $ ( b₀ ) ) )
                          =>
                          do
                            let p ← symm_eq a₀ b₀
                              let p' ← mk_app `congr_arg [ q( Not ) , p ]
                              add_edge r a' b' p'
                              return p'
                        |
                          ( q( $ ( a₀ ) ∧ $ ( a₁ ) ) , q( $ ( b₀ ) ∧ $ ( b₁ ) ) )
                          =>
                          do
                            let p₀ ← symm_eq a₀ b₀
                              let p₁ ← symm_eq a₁ b₁
                              let p' ← to_expr ` `( congr ( congr_arg And $ ( p₀ ) ) $ ( p₁ ) )
                              add_edge r a' b' p'
                              return p'
                        |
                          ( q( $ ( a₀ ) ∨ $ ( a₁ ) ) , q( $ ( b₀ ) ∨ $ ( b₁ ) ) )
                          =>
                          do
                            let p₀ ← symm_eq a₀ b₀
                              let p₁ ← symm_eq a₁ b₁
                              let p' ← to_expr ` `( congr ( congr_arg Or $ ( p₀ ) ) $ ( p₁ ) )
                              add_edge r a' b' p'
                              return p'
                        |
                          ( q( $ ( a₀ ) ↔ $ ( a₁ ) ) , q( $ ( b₀ ) ↔ $ ( b₁ ) ) )
                          =>
                          (
                              do
                                let p₀ ← symm_eq a₀ b₀
                                  let p₁ ← symm_eq a₁ b₁
                                  let p' ← to_expr ` `( congr ( congr_arg Iff $ ( p₀ ) ) $ ( p₁ ) )
                                  add_edge r a' b' p'
                                  return p'
                              )
                            <|>
                            do
                              let p₀ ← symm_eq a₀ b₁
                                let p₁ ← symm_eq a₁ b₀
                                let
                                  p'
                                    ←
                                    to_expr
                                      `
                                        `(
                                          Eq.trans
                                            ( congr ( congr_arg Iff $ ( p₀ ) ) $ ( p₁ ) )
                                              ( Iff.to_eq Iff.comm )
                                          )
                                add_edge r a' b' p'
                                return p'
                        |
                          ( q( $ ( a₀ ) → $ ( a₁ ) ) , q( $ ( b₀ ) → $ ( b₁ ) ) )
                          =>
                          if
                            ¬ a₁ ∧ ¬ b₁
                            then
                            do
                              let p₀ ← symm_eq a₀ b₀
                                let p₁ ← symm_eq a₁ b₁
                                let p' ← mk_app `congr_arg [ q( Implies ) , p₀ , p₁ ]
                                add_edge r a' b' p'
                                return p'
                            else
                            unify a' b' >> add_refl r a' *> mk_mapp `rfl [ none , a ]
                        |
                          ( _ , _ )
                          =>
                          do
                            guard <| a' ∧ a' = b'
                              let ( a'' , pa' ) ← add_symm_proof r a'
                              guard <| a'' == b'
                              pure pa'
                let p' ← mk_eq_trans pa p
                add_edge r a' b' p'
                mk_eq_symm pb >>= mk_eq_trans p'
#align tactic.symm_eq tactic.symm_eq

unsafe def find_eq_type (r : tauto_state) : expr → List expr → tactic (expr × expr)
  | e, [] => failed
  | e, H :: Hs => do
    let t ← infer_type H
    Prod.mk H <$> symm_eq r e t <|> find_eq_type e Hs
#align tactic.find_eq_type tactic.find_eq_type

-- failed to format: unknown constant 'term.pseudo.antiquot'
private unsafe
  def
    contra_p_not_p
    ( r : tauto_state ) : List expr → List expr → tactic Unit
    | [ ] , Hs => failed
      |
        H1 :: Rs , Hs
        =>
        do
          let t ← extract_opt_auto_param <$> infer_type H1 >>= whnf
            (
                do
                  let a ← match_not t
                    let ( H2 , p ) ← find_eq_type r a Hs
                    let H2 ← to_expr ` `( $ ( p ) . mpr $ ( H2 ) )
                    let tgt ← target
                    let pr ← mk_app `absurd [ tgt , H2 , H1 ]
                    tactic.exact pr
                )
              <|>
              contra_p_not_p Rs Hs
#align tactic.contra_p_not_p tactic.contra_p_not_p

unsafe def contradiction_with (r : tauto_state) : tactic Unit :=
  contradiction <|> do
    tactic.try intro1
    let ctx ← local_context
    contra_p_not_p r ctx ctx
#align tactic.contradiction_with tactic.contradiction_with

unsafe def contradiction_symm :=
  using_new_ref (native.rb_map.mk _ _) contradiction_with
#align tactic.contradiction_symm tactic.contradiction_symm

unsafe def assumption_with (r : tauto_state) : tactic Unit :=
  (do
      let ctx ← local_context
      let t ← target
      let (H, p) ← find_eq_type r t ctx
      mk_eq_mpr p H >>= tactic.exact) <|>
    fail "assumption tactic failed"
#align tactic.assumption_with tactic.assumption_with

unsafe def assumption_symm :=
  using_new_ref (native.rb_map.mk _ _) assumption_with
#align tactic.assumption_symm tactic.assumption_symm

/-- Configuration options for `tauto`.
  If `classical` is `tt`, runs `classical` before the rest of `tauto`.
  `closer` is run on any remaining subgoals left by `tauto_core; basic_tauto_tacs`.
-/
unsafe structure tauto_cfg where
  classical : Bool := false
  closer : tactic Unit := pure ()
#align tactic.tauto_cfg tactic.tauto_cfg

unsafe def tautology (cfg : tauto_cfg := { }) : tactic Unit :=
  focus1 <|
    let basic_tauto_tacs : List (tactic Unit) :=
      [reflexivity, solve_by_elim,
        constructor_matching none [``(_ ∧ _), ``(_ ↔ _), ``(Exists _), ``(True)]]
    let tauto_core (r : tauto_state) : tactic Unit := do
      andthen (andthen (try (contradiction_with r)) (try (assumption_with r)))
          (repeat do
            let gs ← get_goals
            andthen
                (andthen
                  (andthen
                    (andthen
                      (andthen
                        (andthen
                          (andthen (andthen (repeat (() <$ tactic.intro1)) distrib_not)
                            (casesm (some ()) [``(_ ∧ _), ``(_ ∨ _), ``(Exists _), ``(False)]))
                          (try (contradiction_with r)))
                        (try ((target >>= match_or) >> refine ``(or_iff_not_imp_left.mpr _))))
                      (try ((target >>= match_or) >> refine ``(or_iff_not_imp_right.mpr _))))
                    (repeat (() <$ tactic.intro1)))
                  (constructor_matching (some ()) [``(_ ∧ _), ``(_ ↔ _), ``(True)]))
                (try (assumption_with r))
            let gs' ← get_goals
            guard (gs ≠ gs'))
    do
    when cfg (classical tt)
    andthen (andthen (using_new_ref (expr_map.mk _) tauto_core) (repeat (first basic_tauto_tacs)))
        cfg
    done
#align tactic.tautology tactic.tautology

namespace Interactive

-- mathport name: parser.optional
local postfix:1024 "?" => optional

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- `tautology` breaks down assumptions of the form `_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`.
This is a finishing tactic: it either closes the goal or raises an error.
The variant `tautology!` uses the law of excluded middle.

`tautology {closer := tac}` will use `tac` on any subgoals created by `tautology`
that it is unable to solve before failing.
-/
unsafe def tautology (c : parse <| (tk "!")?) (cfg : tactic.tauto_cfg := { }) :=
  tactic.tautology <| { cfg with classical := c.isSome }
#align tactic.interactive.tautology tactic.interactive.tautology

-- Now define a shorter name for the tactic `tautology`.
/-- `tauto` breaks down assumptions of the form `_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`.
This is a finishing tactic: it either closes the goal or raises an error.
The variant `tauto!` uses the law of excluded middle.

`tauto {closer := tac}` will use `tac` on any subgoals created by `tauto`
that it is unable to solve before failing.
-/
unsafe def tauto (c : parse <| (tk "!")?) (cfg : tactic.tauto_cfg := { }) : tactic Unit :=
  tautology c cfg
#align tactic.interactive.tauto tactic.interactive.tauto

add_hint_tactic tauto

/-- This tactic (with shorthand `tauto`) breaks down assumptions of the form
`_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`. This is a finishing tactic: it
either closes the goal or raises an error.

The variants `tautology!` and `tauto!` use the law of excluded middle.

For instance, one can write:
```lean
example (p q r : Prop) [decidable p] [decidable r] : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (r ∨ p ∨ r) := by tauto
```
and the decidability assumptions can be dropped if `tauto!` is used
instead of `tauto`.

`tauto {closer := tac}` will use `tac` on any subgoals created by `tauto`
that it is unable to solve before failing.
-/
add_tactic_doc
  { Name := "tautology"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.tautology, `tactic.interactive.tauto]
    tags := ["logic", "decision procedure"] }

end Interactive

end Tactic


lemma add_left_eq_zero {{a b : mynat}} (H : a + b = 0) : b = 0 :=
begin
cases b with d,
refl,
rw add_succ at H,
exfalso,
apply succ_ne_zero (a + d),
exact H,
end