import data.fin.basic
import data.fintype.basic
import data.list
import ..automata_typeclass

variables {Sigma : Type} [decidable_eq Sigma]

def append_lang (P Q : lang Sigma) : lang Sigma
:= λ w, ∃ u v : word Sigma, P u ∧ Q v ∧ w = u ++ v

def append_ε_nfa {Sigma : Type*} [decidable_eq Sigma] (A : ε_nfa Sigma) (B : ε_nfa Sigma) : ε_nfa Sigma :=
  {
    Q := A.Q ⊕ B.Q,
    finQ := @sum.fintype A.Q B.Q A.finQ B.finQ,
    decQ := @sum.decidable_eq A.Q A.decQ B.Q B.decQ,
    inits := λ q, sum.cases_on q A.inits (λ _, false),
    decI := begin
      assume a,
      cases a;
      simp at *,
      exact A.decI a,
      exact is_false id,
    end,
    final := λ q, sum.cases_on q (λ _, false) B.final,
    decF := begin
      assume a,
      cases a;
      simp at *,
      exact is_false id,
      exact B.decF a,
    end,
    δ := λ a x b, match a, b with
        | (sum.inl a), (sum.inl b) := A.δ a x b
        | (sum.inl a), (sum.inr b) := A.final a ∧ B.inits b ∧ x = none
        | (sum.inr a), (sum.inl b) := false
        | (sum.inr a), (sum.inr b) := B.δ a x b
      end,
    decD := begin
      assume a,
      cases a with ax b, cases ax with a x,
      cases a; cases b; dsimp [sigma.uncurry],
      exact A.decD ⟨⟨a, x⟩, b⟩,
      {
        letI dF := A.decF,
        letI dI := B.decI,
        letI deq := @sum.decidable_eq A.Q A.decQ B.Q B.decQ,
        unfold_aux,
        apply_instance,
      },
      exact is_false id,
      exact B.decD ⟨⟨a, x⟩, b⟩,
    end,
  }

lemma left_append : ∀ A B : ε_nfa Sigma, ∀ w : word Sigma, ∀ q0 q1 : A.Q,
  ε_nfa_δ_star A q0 w q1 → ε_nfa_δ_star (append_ε_nfa A B) (sum.inl q0) w (sum.inl q1) :=
begin
  assume A B w q0 q1 h,
  induction h,
  case ε_nfa_δ_star.empty : q
  {
    constructor,
  },
  case ε_nfa_δ_star.step : q11 q22 q33 x w h1 h2 ih
  {
    fconstructor,
    exact (sum.inl q22),
    exact h1,
    exact ih,
  },
  case ε_nfa_δ_star.epsilon : q11 q22 q33 w h1 h2 ih
  {
    fconstructor,
    exact (sum.inl q22),
    exact h1,
    exact ih,
  }
end

lemma right_append : ∀ A B : ε_nfa Sigma, ∀ w : word Sigma, ∀ q0 q1 : B.Q,
  ε_nfa_δ_star B q0 w q1 → ε_nfa_δ_star (append_ε_nfa A B) (sum.inr q0) w (sum.inr q1) :=
begin
  assume A B w q0 q1 h,
  induction h,
  case ε_nfa_δ_star.empty : q
  {
    constructor,
  },
  case ε_nfa_δ_star.step : q11 q22 q33 x w h1 h2 ih
  {
    fconstructor,
    exact (sum.inr q22),
    exact h1,
    exact ih,
  },
  case ε_nfa_δ_star.epsilon : q11 q22 q33 w h1 h2 ih
  {
    fconstructor,
    exact (sum.inr q22),
    exact h1,
    exact ih,
  }
end

lemma append_lemᵣ : ∀ A B : ε_nfa Sigma, ∀ u v : word Sigma, ∀ q0 : A.Q, ∀ q1 : B.Q,
  (∃ q2 : A.Q, ∃ q3 : B.Q, A.final q2 ∧ B.inits q3
   ∧ ε_nfa_δ_star A q0 u q2 ∧ ε_nfa_δ_star B q3 v q1) →
  ε_nfa_δ_star (append_ε_nfa A B) (sum.inl q0) (u ++ v) (sum.inr q1) :=
begin
  assume A B u v q0 q1 h,
  cases h with q2 h, cases h with q3 h,
  cases h with Afinal h, cases h with Binits h,
  cases h with Astar Bstar,
  have a2b : (append_ε_nfa A B).δ (sum.inl q2) none (sum.inr q3),
  {
    constructor, exact Afinal,
    constructor, exact Binits,
    refl,
  },
  induction Astar,
  case ε_nfa_δ_star.empty : q
  {
    simp,fconstructor,
    exact (sum.inr q3),
    exact a2b, exact right_append A B v q3 q1 Bstar,
  },
  case ε_nfa_δ_star.step : q00 q11 q22 x w h1 h2 ih
  {
    fconstructor,
    exact sum.inl q11,
    exact h1,
    apply ih,
    exact Afinal,
    exact a2b,
  },
  case ε_nfa_δ_star.epsilon : q00 q11 q22 w h1 h2 ih
  {
    fconstructor,
    exact sum.inl q11,
    exact h1,
    apply ih,
    exact Afinal,
    exact a2b,
  }
end

lemma append_lem : ∀ A B : ε_nfa Sigma, ∀ w : word Sigma, ∀ q0 q1 : (append_ε_nfa A B).Q,
  ε_nfa_δ_star (append_ε_nfa A B) q0 w q1 →
  (∃ q0' : A.Q, ∃ q1' : B.Q, q0 = sum.inl q0' ∧ q1 = sum.inr q1'
   ∧ ∃ u v : word Sigma, ∃ q2' : A.Q, ∃ q3' : B.Q, A.final q2' ∧ B.inits q3'
   ∧ ε_nfa_δ_star A q0' u q2' ∧ ε_nfa_δ_star B q3' v q1'
   ∧ u ++ v = w)
  ∨ (∃ q0' q1' : A.Q, q0 = sum.inl q0' ∧ q1 = sum.inl q1'
     ∧ ε_nfa_δ_star A q0' w q1')
  ∨ (∃ q0' q1' : B.Q, q0 = sum.inr q0' ∧ q1 = sum.inr q1'
     ∧ ε_nfa_δ_star B q0' w q1') :=
begin
  assume A B w q0 q1 h,
  induction h,
  case ε_nfa_δ_star.empty : q
  {
    cases q,
    right, left, existsi [q, q],
    simp, constructor,
    right, right, existsi [q, q],
    simp, constructor,
  },
  case ε_nfa_δ_star.step : q00 q11 q22 x w h1 h2 ih
  {
    cases q00,
    {
      cases q11,
      {
        cases ih,
        {
          left,
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with eq1 ih, cases ih with eq2 ih,
          cases ih with u ih, cases ih with v ih,
          cases ih with q2' ih, cases ih with q3 ih,
          cases ih with Afinal ih, cases ih with Binits ih,
          cases ih with Astar ih, cases ih with Bstar split_eq,
          existsi [q00, q1'], constructor, refl,
          constructor, exact eq2,
          existsi [(x :: u), v],
          existsi [q2', q3],
          constructor, exact Afinal,
          constructor, exact Binits,
          constructor,
          {
            fconstructor,
            exact q11, exact h1,
            injection eq1 with eq1, rw eq1,
            exact Astar,
          },
          constructor,
          {
            exact Bstar,
          },
          {
            rw← split_eq,
            exact list.cons_append x u v,
          }
        },
        {
          cases ih,
          {
            right, left,
            cases ih with q0' ih, cases ih with q1' ih,
            existsi [q00, q1'],
            cases ih with eq1 ih, cases ih with eq2 Astar,
            simp, constructor, exact eq2,
            fconstructor,
            exact q11, exact h1,
            injection eq1 with eq1, rw eq1, exact Astar,
          },
          {
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with f _, cases f,
          }
        }
      },
      {
        cases h1 with _ h1, cases h1 with _ f, cases f,
      }
    },
    {
      cases q11,
      {
        cases h1,
      },
      {
        cases ih,
        {
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with f _, cases f,
        },
        {
          cases ih,
          {
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with f _, cases f,
          },
          {
            right, right,
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with eq1 ih, cases ih with eq2 Bstar,
            existsi [q00, q1'],
            simp, constructor, exact eq2,
            fconstructor,
            exact q11,
            exact h1, injection eq1 with eq1, rw eq1,
            exact Bstar,
          }
        },
      }
    },
  },
  case ε_nfa_δ_star.epsilon : q00 q11 q22 w h1 h2 ih
  {
    cases q00,
    {
      cases q11,
      {
        cases ih,
        {
          left,
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with eq1 ih, cases ih with eq2 ih,
          cases ih with u ih, cases ih with v ih,
          cases ih with q2' ih, cases ih with q3 ih,
          cases ih with Afinal ih, cases ih with Binits ih,
          cases ih with Astar ih, cases ih with Bstar split_eq,
          existsi [q00, q1'], constructor, refl,
          constructor, exact eq2,
          existsi [u, v],
          existsi [q2', q3],
          constructor, exact Afinal,
          constructor, exact Binits,
          constructor,
          {
            fconstructor,
            exact q11, exact h1,
            injection eq1 with eq1, rw eq1,
            exact Astar,
          },
          constructor,
          {
            exact Bstar,
          },
          {
            rw← split_eq,
          }
        },
        {
          cases ih,
          {
            right, left,
            cases ih with q0' ih, cases ih with q1' ih,
            existsi [q00, q1'],
            cases ih with eq1 ih, cases ih with eq2 Astar,
            simp, constructor, exact eq2,
            fconstructor,
            exact q11, exact h1,
            injection eq1 with eq1, rw eq1, exact Astar,
          },
          {
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with f _, cases f,
          }
        }
      },
      {
        left,
        cases ih,
        {
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with f _, cases f,
        },
        cases ih,
        {
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with f _, cases f,
        },
        {
          cases h1 with Afinal h1, cases h1 with Binits _,
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with eq1 ih, cases ih with eq2 Bstar,
          existsi [q00, q1'],
          constructor, refl,
          constructor, exact eq2,
          existsi [[], w, q00, q11],
          constructor, exact Afinal,
          constructor, exact Binits,
          constructor, constructor,
          constructor, injection eq1 with eq1, rw eq1, exact Bstar,
          exact list.nil_append w,
        }
      }
    },
    {
      cases q11,
      {
        cases h1,
      },
      {
        cases ih,
        {
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with f _, cases f,
        },
        {
          cases ih,
          {
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with f _, cases f,
          },
          {
            right, right,
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with eq1 ih, cases ih with eq2 Bstar,
            existsi [q00, q1'],
            simp, constructor, exact eq2,
            fconstructor,
            exact q11,
            exact h1, injection eq1 with eq1, rw eq1,
            exact Bstar,
          }
        },
      }
    },
  },
end

lemma append_ε_nfa_lang : ∀ A B : ε_nfa Sigma, ∀ w : word Sigma,
  ε_nfa_lang (append_ε_nfa A B) w ↔ append_lang (ε_nfa_lang A) (ε_nfa_lang B) w :=
begin
  assume A B w,
  constructor,
  {
    dsimp [ε_nfa_lang, append_lang],
    assume h,
    cases h with q0 h, cases h with q1 h,
    cases h with h1 h, cases h with h2 h3,
    have g := append_lem A B w q0 q1 h2,
    cases g,
    {
      cases g with q0' g, cases g with q1' g,
      cases g with eq1 g, cases g with eq2 g,
      cases g with u g, cases g with v g,
      cases g with q2' g, cases g with q3' g,
      cases g with Afinal g, cases g with Binits ih,
      cases ih with Astar g, cases g with Bstar split_eq,
      existsi [u, v],
      constructor,
      {
        existsi [q0', q2'],
        constructor, finish,
        constructor, exact Astar, exact Afinal,
      },
      constructor,
      {
        existsi [q3', q1'],
        constructor, exact Binits,
        constructor, exact Bstar, finish,
      },
      exact eq.symm split_eq,
    },
    cases g,
    {
      cases g with q0' g, cases g with q1' g,
      cases g with eq1 g, cases g with eq2 Astar,
      existsi [w, []],
      rw eq2 at h3, cases h3,
    },
    {
      cases g with q0' g, cases g with q1' g,
      cases g with eq1 g, cases g with eq2 Astar,
      rw eq1 at h1, cases h1,
    }
  },
  {
    dsimp [ε_nfa_lang, append_lang],
    assume h,
    cases h with u h, cases h with v h,
    cases h with h1 h2, cases h2 with h2 h3,
    cases h1 with q0 h1, cases h1 with q2 h1,
    cases h2 with q3 h2, cases h2 with q1 h2,
    existsi [sum.inl q0, sum.inr q1],
    constructor, exact (and.elim_left h1),
    constructor,
    {
      let h11 : ε_nfa_δ_star A q0 u q2, exact (and.elim_left $ and.elim_right $ h1),
      let h22 : ε_nfa_δ_star B q3 v q1, exact (and.elim_left $ and.elim_right $ h2),
      rw h3,
      apply append_lemᵣ A B u v q0 q1,
      existsi [q2, q3],
      constructor, exact (and.elim_right $ and.elim_right $ h1),
      constructor, exact (and.elim_left h2),
      constructor, exact h11,
      exact h22,
    },
    exact (and.elim_right (and.elim_right h2)),
  }
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.category.default
import Mathlib.PostPort

universes u v l

namespace Mathlib

/-!
# Bundled types

`bundled c` provides a uniform structure for bundling a type equipped with a type class.

We provide `category` instances for these in `category_theory/unbundled_hom.lean`
(for categories with unbundled homs, e.g. topological spaces)
and in `category_theory/bundled_hom.lean` (for categories with bundled homs, e.g. monoids).
-/

namespace category_theory

/-- `bundled` is a type bundled with a type class instance for that type. Only
the type class is exposed as a parameter. -/
structure bundled (c : Type u → Type v) where
  α : Type u
  str :
    autoParam (c α)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
        (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
          "apply_instance")
        [])

namespace bundled

/-- A generic function for lifting a type equipped with an instance to a bundled object. -/
-- Usually explicit instances will provide their own version of this, e.g. `Mon.of` and `Top.of`.

def of {c : Type u → Type v} (α : Type u) [str : c α] : bundled c := mk α

protected instance has_coe_to_sort {c : Type u → Type v} : has_coe_to_sort (bundled c) :=
  has_coe_to_sort.mk (Type u) α

@[simp] theorem coe_mk {c : Type u → Type v} (α : Type u)
    (str :
      autoParam (c α)
        (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
          (Lean.Name.mkStr
            (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
            "apply_instance")
          [])) :
    ↥(mk α) = α :=
  rfl

/-
`bundled.map` is reducible so that, if we define a category

  def Ring : Type (u+1) := induced_category SemiRing (bundled.map @ring.to_semiring)

instance search is able to "see" that a morphism R ⟶ S in Ring is really
a (semi)ring homomorphism from R.α to S.α, and not merely from
`(bundled.map @ring.to_semiring R).α` to `(bundled.map @ring.to_semiring S).α`.
-/

/-- Map over the bundled structure -/
def map {c : Type u → Type v} {d : Type u → Type v} (f : {α : Type u} → c α → d α) (b : bundled c) :
    bundled d :=
  mk ↥b

end Mathlib


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.nat.basic

universes l

namespace Mathlib

def is_valid_char (n : ℕ) :=
  n < bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit1 (bit1 (bit0 (bit1 1)))))))))))))) ∨
    bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit0 (bit1 1)))))))))))))) < n ∧
      n <
        bit0
          (bit0
            (bit0
              (bit0
                (bit0
                  (bit0
                    (bit0
                      (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit1 (bit0 (bit0 (bit0 1)))))))))))))))))))

theorem is_valid_char_range_1 (n : ℕ) (h : n < bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit1 (bit1 (bit0 (bit1 1))))))))))))))) : is_valid_char n :=
  Or.inl h

theorem is_valid_char_range_2 (n : ℕ) (h₁ : bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit1 (bit0 (bit1 1)))))))))))))) < n) (h₂ : n <
  bit0
    (bit0
      (bit0
        (bit0
          (bit0
            (bit0
              (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit1 (bit0 (bit0 (bit0 1)))))))))))))))))))) : is_valid_char n :=
  Or.inr { left := h₁, right := h₂ }

/-- The `char` type represents an unicode scalar value.
    See http://www.unicode.org/glossary/#unicode_scalar_value). -/
structure char
where
  val : ℕ
  valid : is_valid_char val

protected instance char.has_sizeof : SizeOf char :=
  { sizeOf := fun (c : char) => char.val c }

namespace char

protected def lt (a : char) (b : char) :=
  val a < val b

protected def le (a : char) (b : char) :=
  val a ≤ val b

protected instance has_lt : HasLess char :=
  { Less := char.lt }

protected instance has_le : HasLessEq char :=
  { LessEq := char.le }

protected instance decidable_lt (a : char) (b : char) : Decidable (a < b) :=
  nat.decidable_lt (val a) (val b)

protected instance decidable_le (a : char) (b : char) : Decidable (a ≤ b) :=
  nat.decidable_le (val a) (val b)

/-
We cannot use tactics dec_trivial or comp_val here because the tactic framework has not been defined yet.
We also do not use `zero_lt_succ _` as a proof term because this proof may not be trivial to check by
external type checkers. See discussion at: https://github.com/leanprover/tc/issues/8
-/

theorem zero_lt_d800 : 0 < bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit1 (bit1 (bit0 (bit1 1)))))))))))))) := sorry

def of_nat (n : ℕ) : char :=
  dite (is_valid_char n) (fun (h : is_valid_char n) => mk n h) fun (h : ¬is_valid_char n) => mk 0 sorry

def to_nat (c : char) : ℕ :=
  val c

theorem eq_of_veq {c : char} {d : char} : val c = val d → c = d := sorry

theorem veq_of_eq {c : char} {d : char} : c = d → val c = val d := sorry

theorem ne_of_vne {c : char} {d : char} (h : val c ≠ val d) : c ≠ d :=
  fun (h' : c = d) => absurd (veq_of_eq h') h

theorem vne_of_ne {c : char} {d : char} (h : c ≠ d) : val c ≠ val d :=
  fun (h' : val c = val d) => absurd (eq_of_veq h') h

end char

protected instance char.decidable_eq : DecidableEq char :=
  fun (i j : char) => decidable_of_decidable_of_iff (nat.decidable_eq (char.val i) (char.val j)) sorry

protected instance char.inhabited : Inhabited char :=
  { default := char.of_nat (bit1 (bit0 (bit0 (bit0 (bit0 (bit0 1)))))) }


import PnP2023.Lec_01_04.Intro
import PnP2023.Lec_01_04.OddExample
import PnP2023.Lec_01_06.NatEq
import PnP2023.Lec_01_11.NatLe
import PnP2023.Lec_01_13.NatRec
import PnP2023.Lec_01_18.NatSub
import PnP2023.Lec_01_20.NatMin
import PnP2023.Lec_01_20.NatMinus
import PnP2023.Lec_01_25.Answer
import PnP2023.Lec_02_01.Foundations
import PnP2023.Lec_02_03.InductiveTypes
import PnP2023.Lec_02_15.PropsAsTypes
import PnP2023.Lec_03_01.RandomIO
import PnP2023.Lec_03_08.Diaphontine
import PnP2023.Lec_03_10.FormalCalculus
import PnP2023.Lec_03_24.Sampling
/-!
# Proofs and Programs 2023

This course will introduce [Lean Theorem Prover 4](https://leanprover.github.io/), which is an _interactive theorem prover_ as well as a programming language and use it for various aspects of _proofs and programs_:

* Using programs (_interactive theorem provers_) to
    * verify proofs of results
    * help in generating proofs
* Proving correctness of programs
* Writing programs to find and/or verify proofs
* _Functional Programming_ in Lean

To study these things in a meaningful way, we will look at _foundations_ of _mathematics_ and of _computation_. We will introduce different foundational systems:

* _Dependent Type Theory_ (DTT): foundations used by Lean that include both proofs and computations in a unified way.
* Classical foundations:
  - _First-order logic:_ the usual foundations of mathematics.
  - _lambda-calculus:_ one of the equivalent formulations of the usual foundations of computation.

## Navigation

To browse the code, expand the `PnP2023` tab on the left.

-/

def hello := "to the course Proofs and Programs"


import Scratch.ExprAppl
import Scratch.ConstDeps
import Scratch.ProdSeq
import Lean.Meta
import Lean.Elab
import Std.Data.HashMap
import Std.Data.HashSet
open Std
open Lean
open Meta
open Elab
open Term
open Lean.Elab.Tactic

def whiteListed (n: Name) : TermElabM Bool := do
  let b ← ConstDeps.isWhiteListed (← getEnv) n
  return b

def contains : Expr → Expr → MetaM Bool
  | e, x =>
    do
    if ← isDefEq e x then return true
    else
    match e with
    | Expr.app f a _ => (← contains f x) || (← contains a x)
    | Expr.lam _ _ b _ => (← contains b x)
    | Expr.forallE _ _ b _ => (← contains b x)
    | _ => return false

-- copied from lean4 source code
def rewriteProof (e: Expr) (heq : Expr) (symm : Bool := false) : MetaM (Option Expr) :=
  do
    let heqType ← instantiateMVars (← inferType heq)
    let (newMVars, binderInfos, heqType) ← forallMetaTelescopeReducing heqType
    let heq := mkAppN heq newMVars
    match heqType.eq? with
    | none => none
    | some (α , lhs, rhs) =>
    let heqType := if symm then ← mkEq rhs lhs else heqType
    let hep := if symm then mkEqSymm heq else heq
    if lhs.getAppFn.isMVar then none
    else
    let e ← instantiateMVars e
    let eAbst ←  kabstract e lhs
    if !eAbst.hasLooseBVars then none
    else
    let eNew := eAbst.instantiate1 rhs
    let eNew ← instantiateMVars eNew
    let eEqE ← mkEq e e
    let eEqEAbst := mkApp eEqE.appFn! eAbst
    let motive := Lean.mkLambda `_a BinderInfo.default α eEqEAbst
    if !(← isTypeCorrect motive) then none
    else
    let eqRefl ← mkEqRefl e
    let eqPrf ← mkEqNDRec motive eqRefl heq
    return some eqPrf

def rwPushOpt(e : Expr) (heq : Expr)
      (symm : Bool := false): MetaM (Option Expr) :=
  do
    let t ← inferType e
    let pfOpt ← rewriteProof t heq symm
    match pfOpt with
    | none => return none
    | some pf =>
      try
        let expr ← mkAppM ``Eq.mp #[pf, e]
        let exprType ← inferType expr
        if (← isTypeCorrect expr) &&  (← isTypeCorrect exprType)
        then return some expr
        else return none
      catch _ =>
        return none

def eqCongrOpt (f: Expr)(eq : Expr) : MetaM (Option Expr) :=
  do
    try
      let expr ← mkAppM ``congrArg #[f, eq]
      let exprType ← inferType expr
      if (← isTypeCorrect expr) &&  (← isTypeCorrect exprType)  then return some expr
      else
        return none
    catch e =>
      return none

def isle (type: Expr)(evolve : Array Expr → TermElabM (Array Expr))(init : List Expr)
       (includePi : Bool := true)(excludeProofs: Bool := false): TermElabM (Array Expr) :=
    withLocalDecl Name.anonymous BinderInfo.default (type)  $ fun x =>
        do
          let l := x :: init
          -- logInfo m!"initial in isle: {l}"
          let evb ← evolve l.toArray
          let evc ← evolve init.toArray
          let mut evl : Array Expr := #[]
          for y in evb do
            unless excludeProofs && ((← inferType (← inferType y)).isProp) do
            unless (evc.contains y) do
              evl := evl.push y
          let evt ← evl.filterM (fun x => liftMetaM (isType x))
          let exported ← evl.mapM (fun e => mkLambdaFVars #[x] e)
          let exportedPi ← evt.mapM (fun e => mkForallFVars #[x] e)
          let res := if includePi then exported ++ exportedPi else exported
          return res

def isleSum (types: List Expr)(evolve : Array Expr → TermElabM (Array Expr))(init : List Expr) :
        TermElabM (Array Expr) :=
        match types with
        | [] => return #[]
        | h :: t =>
          do
            let tail ← isleSum t evolve init
            let head ← isle h evolve init
            return head ++ tail

def Array.join {α : Type}[BEq α](a : Array (Array α)) : Array α := Id.run do
  let mut res : Array α  := #[]
  for x in a do
    for y in x do
      res := if res.contains y then res else res.push y
  return res

def eqIsles (eqs: Array Expr)(evolve : Array Expr → TermElabM (Array Expr))(init : List Expr) :
        TermElabM (Array Expr) :=
        do
        let mut eqGroupMap : HashMap Expr (Array Expr) := HashMap.empty
        for eq in eqs do
          match (← inferType eq).eq? with
          | some (α, lhs, rhs) =>
              let prev := (eqGroupMap.find? α).getD #[]
              eqGroupMap := eqGroupMap.insert α (prev.push eq)
          | none => ()
        let eqGroups := eqGroupMap.toArray
        let res : Array Expr ← eqGroups.concatMapM $ fun (α, eqns) =>
              do
              let fs ← isle α evolve init false true
              -- logInfo m!"fs: {fs.size}"
              let shifted ← eqns.concatMapM $ fun eq =>
                    fs.filterMapM (fun f => eqCongrOpt f eq)
              return shifted
        return res --.join

def List.inTermElab {α : Type}(l : List (TermElabM α)) : TermElabM (List α) :=
  l.foldl (fun ysM xM =>
            do
              return (← xM) :: (← ysM)) (return [])

def Array.inTermElab {α : Type}(l : Array (TermElabM α)) : TermElabM (Array α) :=
  l.foldl (fun ysM xM =>
            do
              return (← ysM).push (← xM)) (return #[])

#check @Array.foldl

def rwAppCongStepTask : Array Expr → Array Name → (TermElabM (Array Expr)):=
    fun l names =>
    let funcs :=  l.filterM $ fun e =>
      let check: TermElabM Bool := do
        let type ← inferType e
        return type.isForall
      check
    let ltml :=
      l.map $ fun arg =>
      Task.spawn $ fun _ =>
      do
        let fns ← funcs
        let apps ← fns.filterMapM (fun f => applyOptM f arg)
        let nameApps ← names.filterMapM (fun name => nameApplyOptM name arg)
        let nameAppPairsRaw ←
          Array.inTermElab (l.map (fun arg2 => names.filterMapM (fun name =>
                  nameApplyPairOptM name arg arg2
                  )))
        let nameAppPairs := nameAppPairsRaw.join
        let type ← inferType arg
        if type.isEq
        then
          let rws ← l.filterMapM (fun f => rwPushOpt  f arg)
          let rwsFlip ← l.filterMapM (fun f => rwPushOpt f arg true)
          let congs ← l.filterMapM (fun f => eqCongrOpt f arg)
          return (rws.append
                    (rwsFlip.append (congs.append (apps)))).append (nameApps) ++ nameAppPairs
        else
          return apps ++ nameApps ++ nameAppPairs
    let lst := ltml.map <| fun t=> t.get
    let ml := (Array.inTermElab lst).map (fun ll => (Array.join ll) ++ l)
    ml

def iterAppRWTask(n: Nat) : Array Expr → Array Name  → TermElabM (Array Expr) :=
   match n with
  | 0 => fun l _ => return l
  | m + 1 => fun l names => do
      let prev ←  iterAppRWTask m   l names
      let rwStepTask := rwAppCongStepTask  prev names
      let isles ← eqIsles prev
        (fun list => (iterAppRWTask m list names)) prev.toList
      -- Elab.logInfo m!"isles: {isles}"
      let rwStep ← rwStepTask
      return rwStep ++ isles

initialize exprArrCache : IO.Ref (HashMap Name (Array Expr)) ← IO.mkRef (HashMap.empty)

initialize exprPackCache : IO.Ref (HashMap Name Expr) ← IO.mkRef (HashMap.empty)

def getArrCached? (name : Name) : IO (Option (Array Expr)) := do
  let cache ← exprArrCache.get
  return (cache.find? name)

def cacheArr (name: Name)(e: Array Expr)  : IO Unit := do
  let cache ← exprArrCache.get
  exprArrCache.set (cache.insert name e)
  return ()

def getPackCached? (name : Name) : IO (Option Expr) := do
  let cache ← exprPackCache.get
  return (cache.find? name)

def cachePack (name: Name)(e: Expr)  : IO Unit := do
  let cache ← exprPackCache.get
  exprPackCache.set (cache.insert name e)
  return ()

def saveExprArr (name: Name)(es: Array Expr) : TermElabM (Unit) := do
  let lctx ← getLCtx
  let fvarIds ← lctx.getFVarIds
  let fvIds ← fvarIds.filterM $ fun fid => whiteListed ((lctx.get! fid).userName)
  let fvars := fvIds.map mkFVar
  Term.synthesizeSyntheticMVarsNoPostponing
  let espair ← es.mapM (fun e => do Term.levelMVarToParam (← instantiateMVars e))
  let es ← espair.mapM fun (e, _) => return e
  let es ← es.mapM (fun e => mkLambdaFVars fvars e)
  let es ← es.mapM (fun e => whnf e)
  logInfo m!"saving relative to: {fvars}"
  cacheArr name es
  let varPack ← ProdSeq.lambdaPack fvars.toList
  cachePack name varPack
  return ()

def loadExprArr (name: Name) : TermElabM (Array Expr) := do
  let lctx ← getLCtx
  let fvarIds ← lctx.getFVarIds
  let fvIds ← fvarIds.filterM $ fun fid => whiteListed ((lctx.get! fid).userName)
  let fvars := fvIds.map mkFVar
  logInfo m!"loading relative to: {fvars}"
  let fvarsCachedPack ← getPackCached? name
  let fvarsCached ← fvarsCachedPack.mapM (fun p => ProdSeq.lambdaUnpack p)
  logInfo m!"fvarsCached: {fvarsCached}"
  let cache ← exprArrCache.get
  match cache.find? name with
  | some es => es.mapM $ fun e => reduce (mkAppN e fvars)
  | none => throwError m!"no cached expr for {name}"

def distinctTypes (exps: Array Expr) : TermElabM (Array Expr) := do
  let mut types : Array Expr := Array.empty
  let mut distinct : Array Expr := Array.empty
  for expr in exps do
    let type ← inferType expr
    unless (types.contains type) do
      types := types.push type
      distinct := distinct.push expr
  return distinct

def propagateEqualities (eqs: Array Expr) : TermElabM (HashMap Expr Expr) :=
  do
    let mut eqsymm : Array Expr := #[]
    let mut eqTypes : HashSet Expr := HashSet.empty
    for eq in eqs do
      let type ← inferType eq
      if type.isEq then
        unless eqTypes.contains type do
          eqsymm := eqsymm.push eq
          eqTypes := eqTypes.insert type
        let seq ← whnf (← mkAppM `Eq.symm #[eq])
        let seqType ← inferType seq
        unless eqTypes.contains seqType do
          eqsymm ← eqsymm.push seq
          eqTypes := eqTypes.insert seqType
    logInfo m!"symmetrize equalities for propagation: {← IO.monoMsNow}"
    logInfo m!"got:{eqsymm.size}"
    let mut withLhs : HashMap Expr (Array (Expr × Expr)) := HashMap.empty
    for eq in eqsymm do
      let type ← inferType eq
      match type.eq? with
      | none => ()
      | some (α , lhs, rhs) =>
        let lhsUp :=
          match withLhs.getOp lhs with
          | some arr => arr.push (eq, rhs)
          | none => #[(eq, rhs)]
        withLhs ← withLhs.insert lhs lhsUp
    logInfo m!"equality map generated: {← IO.monoMsNow}"
    let mut  accum : HashMap Expr Expr := HashMap.empty
    let mut accumSides : HashSet (Expr × Expr) := HashSet.empty
    for eq1 in eqsymm do
      let type ← inferType eq1
      match type.eq? with
      | none => ()
      | some (α , lhs, rhs) =>
        let eqs2 := (withLhs.getOp rhs).getD #[]
        for (eq2, rhs2) in eqs2 do
        unless (rhs2 == lhs) || (accumSides.contains (lhs, rhs2)) do
          let eq3 ←  mkAppM `Eq.trans #[eq1, eq2]
          let type ← mkEq lhs rhs2
          accum ← accum.insert type eq3
          accumSides := accumSides.insert (lhs, rhs2)
    return accum

def typeVariables (e: Expr) : (List Name) × (List Name) :=
  match e with
  | Expr.forallE n d b c =>
      if c.binderInfo.isExplicit then
        let (l1, l2) := typeVariables b
        (n :: l1, l2)
      else
        let (l1, l2) := typeVariables b
        (l1, n :: l2)
  | _ => ([], [])

syntax(name:= goalVariables) "goalVariables" : tactic
@[tactic goalVariables] def goalVariablesImp : Tactic :=
  fun stx =>
  withMainContext do
    let (l1, l2) := typeVariables (← getMainTarget)
    logInfo m!"target: {← getMainTarget}"
    logInfo m!"explicit variables: {l1}"
    logInfo m!"implicit variables: {l2}"
    let lctx ← getLCtx
    let fvarIds ← lctx.getFVarIds
    let fvars := fvarIds.map mkFVar
    logInfo m!"free variables from context: {fvars}"
    logInfo m!"free variable types from context: {← fvars.mapM $ fun x => inferType x}"
    return ()

-- used only in example generation, not in active code
def appStepTask : Array Expr → Task (TermElabM (Array Expr)):=
    fun l =>
    let ltml :=
      l.map $ fun arg =>
      Task.spawn $ fun _ =>
      do
        let apps ← l.filterMapM (fun f => applyOptM f arg)
        return apps
    let tlml := Task.array ltml
    let tml := tlml.map $ fun lst =>
      (Array.inTermElab lst).map (fun ll => (Array.join ll) ++ l)
    tml

def iterAppRWMTask(n: Nat): List Expr → List Name → TermElabM (List Expr) :=
  fun l names => ((iterAppRWTask n l.toArray names.toArray)).map (Array.toList)

def iterAppTask(n: Nat) : Array Expr → TermElabM (Array Expr) :=
   match n with
  | 0 => fun l => return l
  | m + 1 => fun l => do
      let prev ←  iterAppTask m   l
      let stepTask := appStepTask prev
      let step ← stepTask.get
      return step

def iterAppMTask(n: Nat) : List Expr → TermElabM (List Expr) :=
  fun l => ((iterAppTask n  l.toArray)).map (Array.toList)
-- end used only in example generation, not in active code


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

namespace List

open Nat

/-!
# Bootstrapping theorems for lists

These are theorems used in the definitions of `Std.Data.List.Basic`.
New theorems should be added to `Std.Data.List.Lemmas` if they are not needed by the bootstrap.
-/

attribute [simp] get get! get? reverseAux eraseIdx map join dropWhile find? findSome?
  replace elem lookup drop take takeWhile foldl foldr zipWith unzip range.loop enumFrom
  intersperse isPrefixOf isEqv dropLast iota mapM.loop mapA List.forM forA filterAuxM
  filterMapM.loop List.foldlM firstM anyM allM findM? findSomeM? forIn.loop forIn'.loop
  concat_eq_append append_assoc

@[simp] theorem head?_nil : @head? α [] = none := rfl
@[simp] theorem head?_cons : @head? α (a::l) = some a := rfl
@[simp 1100] theorem headD_nil : @headD α [] d = d := rfl
@[simp 1100] theorem headD_cons : @headD α (a::l) d = a := rfl
@[simp] theorem head_cons : @head α (a::l) h = a := rfl
@[simp] theorem tail!_cons : @tail! α (a::l) = l := rfl
@[simp 1100] theorem tailD_nil : @tailD α [] l' = l' := rfl
@[simp 1100] theorem tailD_cons : @tailD α (a::l) l' = l := rfl
@[simp] theorem any_nil : [].any f = false := rfl
@[simp] theorem any_cons : (a::l).any f = (f a || l.any f) := rfl
@[simp] theorem all_nil : [].all f = true := rfl
@[simp] theorem all_cons : (a::l).all f = (f a && l.all f) := rfl
@[simp] theorem or_nil : [].or = false := rfl
@[simp] theorem or_cons : (a::l).or = (a || l.or) := rfl
@[simp] theorem and_nil : [].and = true := rfl
@[simp] theorem and_cons : (a::l).and = (a && l.and) := rfl

/-! ### length -/

theorem eq_nil_of_length_eq_zero (_ : length l = 0) : l = [] := match l with | [] => rfl

theorem ne_nil_of_length_eq_succ (_ : length l = succ n) : l ≠ [] := fun _ => nomatch l

theorem length_eq_zero : length l = 0 ↔ l = [] :=
  ⟨eq_nil_of_length_eq_zero, fun h => h ▸ rfl⟩

/-! ### append -/

@[simp 1100] theorem singleton_append : [x] ++ l = x :: l := rfl

theorem append_inj :
    ∀ {s₁ s₂ t₁ t₂ : List α}, s₁ ++ t₁ = s₂ ++ t₂ → length s₁ = length s₂ → s₁ = s₂ ∧ t₁ = t₂
  | [], [], t₁, t₂, h, _ => ⟨rfl, h⟩
  | a :: s₁, b :: s₂, t₁, t₂, h, hl => by
    simp [append_inj (cons.inj h).2 (Nat.succ.inj hl)] at h ⊢; exact h

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

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

theorem append_inj' (h : s₁ ++ t₁ = s₂ ++ t₂) (hl : length t₁ = length t₂) : s₁ = s₂ ∧ t₁ = t₂ :=
  append_inj h <| @Nat.add_right_cancel _ (length t₁) _ <| by
  let hap := congrArg length h; simp only [length_append, ← hl] at hap; exact hap

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

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

theorem append_right_inj {t₁ t₂ : List α} (s) : s ++ t₁ = s ++ t₂ ↔ t₁ = t₂ :=
  ⟨fun h => append_inj_right h rfl, congrArg _⟩

theorem append_left_inj {s₁ s₂ : List α} (t) : s₁ ++ t = s₂ ++ t ↔ s₁ = s₂ :=
  ⟨fun h => append_inj_left' h rfl, congrArg (· ++ _)⟩

/-! ### map -/

theorem map_nil {f : α → β} : map f [] = [] := rfl

theorem map_cons (f : α → β) a l : map f (a :: l) = f a :: map f l := rfl

@[simp] theorem map_append (f : α → β) : ∀ l₁ l₂, map f (l₁ ++ l₂) = map f l₁ ++ map f l₂ := by
  intro l₁ <;> induction l₁ <;> intros <;> simp_all

@[simp] theorem map_id (l : List α) : map id l = l := by induction l <;> simp_all

@[simp] theorem map_map (g : β → γ) (f : α → β) (l : List α) :
  map g (map f l) = map (g ∘ f) l := by induction l <;> simp_all

/-! ### bind -/

@[simp] theorem nil_bind (f : α → List β) : List.bind [] f = [] := by simp [join, List.bind]

@[simp] theorem cons_bind x xs (f : α → List β) :
  List.bind (x :: xs) f = f x ++ List.bind xs f := by simp [join, List.bind]

@[simp] theorem append_bind xs ys (f : α → List β) :
  List.bind (xs ++ ys) f = List.bind xs f ++ List.bind ys f := by
  induction xs; {rfl}; simp_all [cons_bind, append_assoc]

/-! ### bind -/

@[simp] theorem bind_id (l : List (List α)) : List.bind l id = l.join := by simp [List.bind]

/-! ### reverse -/

theorem reverseAux_eq (as bs : List α) : reverseAux as bs = reverse as ++ bs :=
  reverseAux_eq_append ..

theorem reverse_map (f : α → β) (l : List α) : (l.map f).reverse = l.reverse.map f := by
  induction l <;> simp [*]

/-! ### take and drop -/

@[simp] theorem take_append_drop : ∀ (n : Nat) (l : List α), take n l ++ drop n l = l
  | 0, _ => rfl
  | _+1, [] => rfl
  | n+1, x :: xs => congrArg (cons x) <| take_append_drop n xs

@[simp] theorem length_drop : ∀ (i : Nat) (l : List α), length (drop i l) = length l - i
  | 0, _ => rfl
  | succ i, [] => Eq.symm (Nat.zero_sub (succ i))
  | succ i, x :: l => calc
    length (drop (succ i) (x :: l)) = length l - i := length_drop i l
    _ = succ (length l) - succ i := (Nat.succ_sub_succ_eq_sub (length l) i).symm

theorem drop_length_le {l : List α} (h : l.length ≤ i) : drop i l = [] :=
  length_eq_zero.1 (length_drop .. ▸ Nat.sub_eq_zero_of_le h)

theorem take_length_le {l : List α} (h : l.length ≤ i) : take i l = l := by
  have := take_append_drop i l
  rw [drop_length_le h, append_nil] at this; exact this

@[simp] theorem drop_length (l : List α) : drop l.length l = [] := drop_length_le (Nat.le_refl _)

@[simp] theorem take_length (l : List α) : take l.length l = l := take_length_le (Nat.le_refl _)

theorem take_concat_get (l : List α) (i : Nat) (h : i < l.length) :
    (l.take i).concat l[i] = l.take (i+1) :=
  Eq.symm <| (append_left_inj _).1 <| (take_append_drop (i+1) l).trans <| by
    rw [concat_eq_append, append_assoc, singleton_append, get_drop_eq_drop, take_append_drop]

theorem reverse_concat (l : List α) (a : α) : (l.concat a).reverse = a :: l.reverse := by
  rw [concat_eq_append, reverse_append]; rfl

@[simp] theorem foldlM_reverse [Monad m] (l : List α) (f : β → α → m β) (b) :
    l.reverse.foldlM f b = l.foldrM (fun x y => f y x) b := rfl

@[simp] theorem foldlM_append [Monad m] [LawfulMonad m] (f : β → α → m β) (b) (l l' : List α) :
    (l ++ l').foldlM f b = l.foldlM f b >>= l'.foldlM f := by
  induction l generalizing b <;> simp [*]

@[simp] theorem foldrM_nil [Monad m] (f : α → β → m β) (b) : [].foldrM f b = pure b := rfl

@[simp] theorem foldrM_cons [Monad m] [LawfulMonad m] (a : α) (l) (f : α → β → m β) (b) :
    (a :: l).foldrM f b = l.foldrM f b >>= f a := by
  simp only [foldrM]
  induction l <;> simp_all

@[simp] theorem foldrM_reverse [Monad m] (l : List α) (f : α → β → m β) (b) :
    l.reverse.foldrM f b = l.foldlM (fun x y => f y x) b :=
  (foldlM_reverse ..).symm.trans <| by simp

theorem foldl_eq_foldlM (f : β → α → β) (b) (l : List α) :
    l.foldl f b = l.foldlM (m := Id) f b := by
  induction l generalizing b <;> simp [*, foldl]

theorem foldr_eq_foldrM (f : α → β → β) (b) (l : List α) :
    l.foldr f b = l.foldrM (m := Id) f b := by
  induction l <;> simp [*]

@[simp] theorem foldl_reverse (l : List α) (f : β → α → β) (b) :
    l.reverse.foldl f b = l.foldr (fun x y => f y x) b := by simp [foldl_eq_foldlM, foldr_eq_foldrM]

@[simp] theorem foldr_reverse (l : List α) (f : α → β → β) (b) :
    l.reverse.foldr f b = l.foldl (fun x y => f y x) b :=
  (foldl_reverse ..).symm.trans <| by simp

@[simp] theorem foldrM_append [Monad m] [LawfulMonad m] (f : α → β → m β) (b) (l l' : List α) :
    (l ++ l').foldrM f b = l'.foldrM f b >>= l.foldrM f := by
  induction l <;> simp [*]

@[simp] theorem foldl_append {β : Type _} (f : β → α → β) (b) (l l' : List α) :
    (l ++ l').foldl f b = l'.foldl f (l.foldl f b) := by simp [foldl_eq_foldlM]

@[simp] theorem foldr_append (f : α → β → β) (b) (l l' : List α) :
    (l ++ l').foldr f b = l.foldr f (l'.foldr f b) := by simp [foldr_eq_foldrM]

@[simp] theorem foldr_self_append (l : List α) : l.foldr cons l' = l ++ l' := by
  induction l <;> simp [*]

/-- Alternate (non-tail-recursive) form of mapM for proofs. -/
@[simp] def mapM' [Monad m] (f : α → m β) : List α → m (List β)
  | [] => pure []
  | a :: l => return (← f a) :: (← l.mapM' f)

theorem mapM'_eq_mapM [Monad m] [LawfulMonad m] (f : α → m β) (l : List α) :
    mapM' f l = mapM f l := by simp [go, mapM] where
  go : ∀ l acc, mapM.loop f l acc = return acc.reverse ++ (← mapM' f l)
    | [], acc => by simp
    | a::l, acc => by simp [go l]

@[simp] theorem mapM_nil [Monad m] (f : α → m β) : [].mapM f = pure [] := rfl

@[simp] theorem mapM_cons [Monad m] [LawfulMonad m] (f : α → m β) :
    (a :: l).mapM f = (return (← f a) :: (← l.mapM f)) := by simp [← mapM'_eq_mapM]

@[simp] theorem mapM_append [Monad m] [LawfulMonad m] (f : α → m β) {l₁ l₂ : List α} :
    (l₁ ++ l₂).mapM f = (return (← l₁.mapM f) ++ (← l₂.mapM f)) := by induction l₁ <;> simp [*]


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.list.basic
import Mathlib.Lean3Lib.init.function
import Mathlib.Lean3Lib.init.meta.default
import Mathlib.Lean3Lib.init.data.nat.lemmas
import Mathlib.Lean3Lib.init.meta.interactive
import Mathlib.Lean3Lib.init.meta.smt.rsimp

universes u v w w₂ w₁

namespace Mathlib

namespace list

/- append -/

@[simp] theorem nil_append {α : Type u} (s : List α) : [] ++ s = s := rfl

@[simp] theorem cons_append {α : Type u} (x : α) (s : List α) (t : List α) :
    x :: s ++ t = x :: (s ++ t) :=
  rfl

@[simp] theorem append_nil {α : Type u} (t : List α) : t ++ [] = t := sorry

@[simp] theorem append_assoc {α : Type u} (s : List α) (t : List α) (u : List α) :
    s ++ t ++ u = s ++ (t ++ u) :=
  sorry

/- length -/

theorem length_cons {α : Type u} (a : α) (l : List α) : length (a :: l) = length l + 1 := rfl

@[simp] theorem length_append {α : Type u} (s : List α) (t : List α) :
    length (s ++ t) = length s + length t :=
  sorry

@[simp] theorem length_repeat {α : Type u} (a : α) (n : ℕ) : length (repeat a n) = n := sorry

@[simp] theorem length_tail {α : Type u} (l : List α) : length (tail l) = length l - 1 :=
  list.cases_on l (Eq.refl (length (tail [])))
    fun (l_hd : α) (l_tl : List α) => Eq.refl (length (tail (l_hd :: l_tl)))

-- TODO(Leo): cleanup proof after arith dec proc

@[simp] theorem length_drop {α : Type u} (i : ℕ) (l : List α) : length (drop i l) = length l - i :=
  sorry

/- map -/

theorem map_cons {α : Type u} {β : Type v} (f : α → β) (a : α) (l : List α) :
    map f (a :: l) = f a :: map f l :=
  rfl

@[simp] theorem map_append {α : Type u} {β : Type v} (f : α → β) (l₁ : List α) (l₂ : List α) :
    map f (l₁ ++ l₂) = map f l₁ ++ map f l₂ :=
  sorry

theorem map_singleton {α : Type u} {β : Type v} (f : α → β) (a : α) : map f [a] = [f a] := rfl

@[simp] theorem map_id {α : Type u} (l : List α) : map id l = l := sorry

@[simp] theorem map_map {α : Type u} {β : Type v} {γ : Type w} (g : β → γ) (f : α → β)
    (l : List α) : map g (map f l) = map (g ∘ f) l :=
  sorry

@[simp] theorem length_map {α : Type u} {β : Type v} (f : α → β) (l : List α) :
    length (map f l) = length l :=
  sorry

/- bind -/

@[simp] theorem nil_bind {α : Type u} {β : Type v} (f : α → List β) : list.bind [] f = [] := sorry

@[simp] theorem cons_bind {α : Type u} {β : Type v} (x : α) (xs : List α) (f : α → List β) :
    list.bind (x :: xs) f = f x ++ list.bind xs f :=
  sorry

@[simp] theorem append_bind {α : Type u} {β : Type v} (xs : List α) (ys : List α) (f : α → List β) :
    list.bind (xs ++ ys) f = list.bind xs f ++ list.bind ys f :=
  sorry

/- mem -/

@[simp] theorem mem_nil_iff {α : Type u} (a : α) : a ∈ [] ↔ False := iff.rfl

@[simp] theorem not_mem_nil {α : Type u} (a : α) : ¬a ∈ [] := iff.mp (mem_nil_iff a)

@[simp] theorem mem_cons_self {α : Type u} (a : α) (l : List α) : a ∈ a :: l := Or.inl rfl

@[simp] theorem mem_cons_iff {α : Type u} (a : α) (y : α) (l : List α) :
    a ∈ y :: l ↔ a = y ∨ a ∈ l :=
  iff.rfl

theorem mem_cons_eq {α : Type u} (a : α) (y : α) (l : List α) : a ∈ y :: l = (a = y ∨ a ∈ l) := rfl

theorem mem_cons_of_mem {α : Type u} (y : α) {a : α} {l : List α} : a ∈ l → a ∈ y :: l :=
  fun (H : a ∈ l) => Or.inr H

theorem eq_or_mem_of_mem_cons {α : Type u} {a : α} {y : α} {l : List α} :
    a ∈ y :: l → a = y ∨ a ∈ l :=
  fun (h : a ∈ y :: l) => h

@[simp] theorem mem_append {α : Type u} {a : α} {s : List α} {t : List α} :
    a ∈ s ++ t ↔ a ∈ s ∨ a ∈ t :=
  sorry

theorem mem_append_eq {α : Type u} (a : α) (s : List α) (t : List α) :
    a ∈ s ++ t = (a ∈ s ∨ a ∈ t) :=
  propext mem_append

theorem mem_append_left {α : Type u} {a : α} {l₁ : List α} (l₂ : List α) (h : a ∈ l₁) :
    a ∈ l₁ ++ l₂ :=
  iff.mpr mem_append (Or.inl h)

theorem mem_append_right {α : Type u} {a : α} (l₁ : List α) {l₂ : List α} (h : a ∈ l₂) :
    a ∈ l₁ ++ l₂ :=
  iff.mpr mem_append (Or.inr h)

@[simp] theorem not_bex_nil {α : Type u} (p : α → Prop) : ¬∃ (x : α), ∃ (H : x ∈ []), p x := sorry

@[simp] theorem ball_nil {α : Type u} (p : α → Prop) (x : α) (H : x ∈ []) : p x := false.elim

@[simp] theorem bex_cons {α : Type u} (p : α → Prop) (a : α) (l : List α) :
    (∃ (x : α), ∃ (H : x ∈ a :: l), p x) ↔ p a ∨ ∃ (x : α), ∃ (H : x ∈ l), p x :=
  sorry

@[simp] theorem ball_cons {α : Type u} (p : α → Prop) (a : α) (l : List α) :
    (∀ (x : α), x ∈ a :: l → p x) ↔ p a ∧ ∀ (x : α), x ∈ l → p x :=
  sorry

/- list subset -/

protected def subset {α : Type u} (l₁ : List α) (l₂ : List α) := ∀ {a : α}, a ∈ l₁ → a ∈ l₂

protected instance has_subset {α : Type u} : has_subset (List α) := has_subset.mk list.subset

@[simp] theorem nil_subset {α : Type u} (l : List α) : [] ⊆ l :=
  fun (b : α) (i : b ∈ []) => false.elim (iff.mp (mem_nil_iff b) i)

@[simp] theorem subset.refl {α : Type u} (l : List α) : l ⊆ l := fun (b : α) (i : b ∈ l) => i

theorem subset.trans {α : Type u} {l₁ : List α} {l₂ : List α} {l₃ : List α} (h₁ : l₁ ⊆ l₂)
    (h₂ : l₂ ⊆ l₃) : l₁ ⊆ l₃ :=
  fun (b : α) (i : b ∈ l₁) => h₂ (h₁ i)

@[simp] theorem subset_cons {α : Type u} (a : α) (l : List α) : l ⊆ a :: l :=
  fun (b : α) (i : b ∈ l) => Or.inr i

theorem subset_of_cons_subset {α : Type u} {a : α} {l₁ : List α} {l₂ : List α} :
    a :: l₁ ⊆ l₂ → l₁ ⊆ l₂ :=
  fun (s : a :: l₁ ⊆ l₂) (b : α) (i : b ∈ l₁) => s (mem_cons_of_mem a i)

theorem cons_subset_cons {α : Type u} {l₁ : List α} {l₂ : List α} (a : α) (s : l₁ ⊆ l₂) :
    a :: l₁ ⊆ a :: l₂ :=
  fun (b : α) (hin : b ∈ a :: l₁) =>
    or.elim (eq_or_mem_of_mem_cons hin) (fun (e : b = a) => Or.inl e)
      fun (i : b ∈ l₁) => Or.inr (s i)

@[simp] theorem subset_append_left {α : Type u} (l₁ : List α) (l₂ : List α) : l₁ ⊆ l₁ ++ l₂ :=
  fun (b : α) => mem_append_left l₂

@[simp] theorem subset_append_right {α : Type u} (l₁ : List α) (l₂ : List α) : l₂ ⊆ l₁ ++ l₂ :=
  fun (b : α) => mem_append_right l₁

theorem subset_cons_of_subset {α : Type u} (a : α) {l₁ : List α} {l₂ : List α} :
    l₁ ⊆ l₂ → l₁ ⊆ a :: l₂ :=
  fun (s : l₁ ⊆ l₂) (a_1 : α) (i : a_1 ∈ l₁) => Or.inr (s i)

theorem eq_nil_of_length_eq_zero {α : Type u} {l : List α} : length l = 0 → l = [] := sorry

theorem ne_nil_of_length_eq_succ {α : Type u} {l : List α} {n : ℕ} :
    length l = Nat.succ n → l ≠ [] :=
  sorry

@[simp] theorem length_map₂ {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) (l₁ : List α)
    (l₂ : List β) : length (map₂ f l₁ l₂) = min (length l₁) (length l₂) :=
  sorry

@[simp] theorem length_take {α : Type u} (i : ℕ) (l : List α) :
    length (take i l) = min i (length l) :=
  sorry

theorem length_take_le {α : Type u} (n : ℕ) (l : List α) : length (take n l) ≤ n := sorry

theorem length_remove_nth {α : Type u} (l : List α) (i : ℕ) :
    i < length l → length (remove_nth l i) = length l - 1 :=
  sorry

@[simp] theorem partition_eq_filter_filter {α : Type u} (p : α → Prop) [decidable_pred p]
    (l : List α) : partition p l = (filter p l, filter (Not ∘ p) l) :=
  sorry

/- sublists -/

inductive sublist {α : Type u} : List α → List α → Prop where
| slnil : sublist [] []
| cons : ∀ (l₁ l₂ : List α) (a : α), sublist l₁ l₂ → sublist l₁ (a :: l₂)
| cons2 : ∀ (l₁ l₂ : List α) (a : α), sublist l₁ l₂ → sublist (a :: l₁) (a :: l₂)

infixl:50 " <+ " => Mathlib.list.sublist

theorem length_le_of_sublist {α : Type u} {l₁ : List α} {l₂ : List α} :
    l₁ <+ l₂ → length l₁ ≤ length l₂ :=
  sorry

/- filter -/

@[simp] theorem filter_nil {α : Type u} (p : α → Prop) [h : decidable_pred p] : filter p [] = [] :=
  rfl

@[simp] theorem filter_cons_of_pos {α : Type u} {p : α → Prop} [h : decidable_pred p] {a : α}
    (l : List α) : p a → filter p (a :: l) = a :: filter p l :=
  fun (pa : p a) => if_pos pa

@[simp] theorem filter_cons_of_neg {α : Type u} {p : α → Prop} [h : decidable_pred p] {a : α}
    (l : List α) : ¬p a → filter p (a :: l) = filter p l :=
  fun (pa : ¬p a) => if_neg pa

@[simp] theorem filter_append {α : Type u} {p : α → Prop} [h : decidable_pred p] (l₁ : List α)
    (l₂ : List α) : filter p (l₁ ++ l₂) = filter p l₁ ++ filter p l₂ :=
  sorry

@[simp] theorem filter_sublist {α : Type u} {p : α → Prop} [h : decidable_pred p] (l : List α) :
    filter p l <+ l :=
  sorry

/- map_accumr -/

-- This runs a function over a list returning the intermediate results and a

-- a final result.

def map_accumr {α : Type u} {β : Type v} {σ : Type w₂} (f : α → σ → σ × β) :
    List α → σ → σ × List β :=
  sorry

@[simp] theorem length_map_accumr {α : Type u} {β : Type v} {σ : Type w₂} (f : α → σ → σ × β)
    (x : List α) (s : σ) : length (prod.snd (map_accumr f x s)) = length x :=
  sorry

-- This runs a function over two lists returning the intermediate results and a

-- a final result.

def map_accumr₂ {α : Type u} {β : Type v} {φ : Type w₁} {σ : Type w₂} (f : α → β → σ → σ × φ) :
    List α → List β → σ → σ × List φ :=
  sorry

@[simp] theorem length_map_accumr₂ {α : Type u} {β : Type v} {φ : Type w₁} {σ : Type w₂}
    (f : α → β → σ → σ × φ) (x : List α) (y : List β) (c : σ) :
    length (prod.snd (map_accumr₂ f x y c)) = min (length x) (length y) :=
  sorry

end Mathlib


/-
Copyright (c) 2019 Johan Commelin All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.filter.lift
import Mathlib.topology.opens
import Mathlib.topology.algebra.ring
import Mathlib.PostPort

universes u_1 l u_2

namespace Mathlib

/-- The type of open subgroups of a topological additive group. -/
structure open_add_subgroup (G : Type u_1) [add_group G] [topological_space G]
extends add_subgroup G
where
  is_open' : is_open carrier

/-- The type of open subgroups of a topological group. -/
structure open_subgroup (G : Type u_1) [group G] [topological_space G]
extends subgroup G
where
  is_open' : is_open carrier

/-- Reinterpret an `open_subgroup` as a `subgroup`. -/
/-- Reinterpret an `open_add_subgroup` as an `add_subgroup`. -/
-- Tell Lean that `open_add_subgroup` is a namespace

namespace open_add_subgroup

end open_add_subgroup

namespace open_subgroup

protected instance has_coe_set {G : Type u_1} [group G] [topological_space G] : has_coe_t (open_subgroup G) (set G) :=
  has_coe_t.mk fun (U : open_subgroup G) => carrier U

protected instance has_mem {G : Type u_1} [group G] [topological_space G] : has_mem G (open_subgroup G) :=
  has_mem.mk fun (g : G) (U : open_subgroup G) => g ∈ ↑U

protected instance has_coe_subgroup {G : Type u_1} [group G] [topological_space G] : has_coe_t (open_subgroup G) (subgroup G) :=
  has_coe_t.mk to_subgroup

protected instance has_coe_opens {G : Type u_1} [group G] [topological_space G] : has_coe_t (open_subgroup G) (topological_space.opens G) :=
  has_coe_t.mk fun (U : open_subgroup G) => { val := ↑U, property := is_open' U }

@[simp] theorem mem_coe {G : Type u_1} [group G] [topological_space G] {U : open_subgroup G} {g : G} : g ∈ ↑U ↔ g ∈ U :=
  iff.rfl

@[simp] theorem mem_coe_opens {G : Type u_1} [group G] [topological_space G] {U : open_subgroup G} {g : G} : g ∈ ↑U ↔ g ∈ U :=
  iff.rfl

@[simp] theorem mem_coe_subgroup {G : Type u_1} [group G] [topological_space G] {U : open_subgroup G} {g : G} : g ∈ ↑U ↔ g ∈ U :=
  iff.rfl

theorem coe_injective {G : Type u_1} [group G] [topological_space G] : function.injective coe := sorry

theorem ext {G : Type u_1} [group G] [topological_space G] {U : open_subgroup G} {V : open_subgroup G} (h : ∀ (x : G), x ∈ U ↔ x ∈ V) : U = V :=
  coe_injective (set.ext h)

theorem ext_iff {G : Type u_1} [group G] [topological_space G] {U : open_subgroup G} {V : open_subgroup G} : U = V ↔ ∀ (x : G), x ∈ U ↔ x ∈ V :=
  { mp := fun (h : U = V) (x : G) => h ▸ iff.rfl, mpr := ext }

protected theorem is_open {G : Type u_1} [group G] [topological_space G] (U : open_subgroup G) : is_open ↑U :=
  is_open' U

protected theorem one_mem {G : Type u_1} [group G] [topological_space G] (U : open_subgroup G) : 1 ∈ U :=
  one_mem' U

protected theorem inv_mem {G : Type u_1} [group G] [topological_space G] (U : open_subgroup G) {g : G} (h : g ∈ U) : g⁻¹ ∈ U :=
  inv_mem' U h

protected theorem Mathlib.open_add_subgroup.add_mem {G : Type u_1} [add_group G] [topological_space G] (U : open_add_subgroup G) {g₁ : G} {g₂ : G} (h₁ : g₁ ∈ U) (h₂ : g₂ ∈ U) : g₁ + g₂ ∈ U :=
  open_add_subgroup.add_mem' U h₁ h₂

theorem mem_nhds_one {G : Type u_1} [group G] [topological_space G] (U : open_subgroup G) : ↑U ∈ nhds 1 :=
  mem_nhds_sets (open_subgroup.is_open U) (open_subgroup.one_mem U)

protected instance has_top {G : Type u_1} [group G] [topological_space G] : has_top (open_subgroup G) :=
  has_top.mk (mk (subgroup.carrier ⊤) sorry sorry sorry is_open_univ)

protected instance inhabited {G : Type u_1} [group G] [topological_space G] : Inhabited (open_subgroup G) :=
  { default := ⊤ }

theorem is_closed {G : Type u_1} [group G] [topological_space G] [has_continuous_mul G] (U : open_subgroup G) : is_closed ↑U := sorry

/-- The product of two open subgroups as an open subgroup of the product group. -/
def prod {G : Type u_1} [group G] [topological_space G] {H : Type u_2} [group H] [topological_space H] (U : open_subgroup G) (V : open_subgroup H) : open_subgroup (G × H) :=
  mk (set.prod ↑U ↑V) sorry sorry sorry sorry

protected instance partial_order {G : Type u_1} [group G] [topological_space G] : partial_order (open_subgroup G) :=
  partial_order.mk (fun (U V : open_subgroup G) => ∀ {x : G}, x ∈ U → x ∈ V) partial_order.lt sorry sorry sorry

protected instance semilattice_inf_top {G : Type u_1} [group G] [topological_space G] : semilattice_inf_top (open_subgroup G) :=
  semilattice_inf_top.mk ⊤ partial_order.le partial_order.lt sorry sorry sorry sorry
    (fun (U V : open_subgroup G) => mk (subgroup.carrier (↑U ⊓ ↑V)) sorry sorry sorry sorry) sorry sorry sorry

@[simp] theorem coe_inf {G : Type u_1} [group G] [topological_space G] {U : open_subgroup G} {V : open_subgroup G} : ↑(U ⊓ V) = ↑U ∩ ↑V :=
  rfl

@[simp] theorem coe_subset {G : Type u_1} [group G] [topological_space G] {U : open_subgroup G} {V : open_subgroup G} : ↑U ⊆ ↑V ↔ U ≤ V :=
  iff.rfl

@[simp] theorem coe_subgroup_le {G : Type u_1} [group G] [topological_space G] {U : open_subgroup G} {V : open_subgroup G} : ↑U ≤ ↑V ↔ U ≤ V :=
  iff.rfl

end open_subgroup

namespace subgroup

theorem Mathlib.add_subgroup.is_open_of_mem_nhds {G : Type u_1} [add_group G] [topological_space G] [has_continuous_add G] (H : add_subgroup G) {g : G} (hg : ↑H ∈ nhds g) : is_open ↑H := sorry

theorem is_open_of_open_subgroup {G : Type u_1} [group G] [topological_space G] [has_continuous_mul G] (H : subgroup G) {U : open_subgroup G} (h : open_subgroup.carrier U ≤ ↑H) : is_open ↑H :=
  is_open_of_mem_nhds H (filter.mem_sets_of_superset (open_subgroup.mem_nhds_one U) h)

theorem is_open_mono {G : Type u_1} [group G] [topological_space G] [has_continuous_mul G] {H₁ : subgroup G} {H₂ : subgroup G} (h : H₁ ≤ H₂) (h₁ : is_open ↑H₁) : is_open ↑H₂ :=
  is_open_of_open_subgroup H₂ h

end subgroup

namespace open_subgroup

protected instance semilattice_sup_top {G : Type u_1} [group G] [topological_space G] [has_continuous_mul G] : semilattice_sup_top (open_subgroup G) :=
  semilattice_sup_top.mk semilattice_inf_top.top semilattice_inf_top.le semilattice_inf_top.lt sorry sorry sorry sorry
    (fun (U V : open_subgroup G) => mk (subgroup.carrier (↑U ⊔ ↑V)) sorry sorry sorry sorry) sorry sorry sorry

end open_subgroup

namespace submodule

theorem is_open_mono {R : Type u_1} {M : Type u_2} [comm_ring R] [add_comm_group M] [topological_space M] [topological_add_group M] [module R M] {U : submodule R M} {P : submodule R M} (h : U ≤ P) (hU : is_open ↑U) : is_open ↑P :=
  add_subgroup.is_open_mono h hU

end submodule

namespace ideal

theorem is_open_of_open_subideal {R : Type u_1} [comm_ring R] [topological_space R] [topological_ring R] {U : ideal R} {I : ideal R} (h : U ≤ I) (hU : is_open ↑U) : is_open ↑I :=
  submodule.is_open_mono h hU


structure Lam where
  Repr : Type v → Type v
  Obsv : Type v → Type v

  observe
    {α : Type v}
  : Repr α → Obsv α

  val
    {α : Type v}
  : α → Repr α

  app
    {α β : Type v}
  : Repr (α → β) → Repr α → Repr β

def Lam.example
  (dsl : Lam)
: dsl.Repr Nat :=
  let v1 := dsl.val 7
  let v2 := dsl.val 3
  let f := dsl.val fun l r => l + r
  let tmp := dsl.app f v1
  dsl.app tmp v2

def Lam.eval : Lam where
  Repr := id
  Obsv := id

  observe := id

  val := id
  app f a := f a

#eval Lam.example Lam.eval


import Lean

import Smt.Reconstruction.Certifying.Boolean
import Smt.Reconstruction.Certifying.Util

namespace Smt.Reconstruction.Certifying

open Lean Elab Tactic Meta Expr
open List

theorem modusTollens {A B : Prop} : (A → B) → ¬ B → ¬ A := by
  intros f nb
  exact match Classical.em A with
  | Or.inl ha  => absurd (f ha) nb
  | Or.inr hna => hna

syntax (name := liftOrNToNeg) "liftOrNToNeg" term : tactic

@[tactic liftOrNToNeg] def evalLiftOrNToNeg : Tactic :=
  fun stx => withMainContext do
    let hyp ← elabTerm stx[1] none
    let hypType ← inferType hyp
    let props := map notExpr (collectPropsInOrChain hypType)
    let propsList: Expr := listExpr props $ Expr.sort Level.zero
    let deMorgan: Expr := mkApp (mkConst ``deMorgan₂) propsList
    let modusTollens: Expr ← mkAppM ``modusTollens #[deMorgan]
    let notNotHyp: Expr ← mkAppM ``notNotIntro #[hyp]
    let answer := mkApp modusTollens notNotHyp
    Tactic.closeMainGoal answer

example : ¬ A ∨ ¬ B ∨ ¬ C ∨ ¬ D → ¬ (A ∧ B ∧ C ∧ D) := by
  intro h
  liftOrNToNeg h
--  fun h => modusTollens (@deMorgan₂ [A, B, C, D]) (notNotIntro h)

end Smt.Reconstruction.Certifying


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.sums.basic

/-!
# Associator for binary disjoint union of categories.

The associator functor `((C ⊕ D) ⊕ E) ⥤ (C ⊕ (D ⊕ E))` and its inverse form an equivalence.
-/

universes v u

open category_theory
open sum

namespace category_theory.sum

variables (C : Type u) [category.{v} C]
          (D : Type u) [category.{v} D]
          (E : Type u) [category.{v} E]

/--
The associator functor `(C ⊕ D) ⊕ E ⥤ C ⊕ (D ⊕ E)` for sums of categories.
-/
def associator : (C ⊕ D) ⊕ E ⥤ C ⊕ (D ⊕ E) :=
{ obj := λ X, match X with
  | inl (inl X) := inl X
  | inl (inr X) := inr (inl X)
  | inr X := inr (inr X)
  end,
  map := λ X Y f, match X, Y, f with
  | inl (inl X), inl (inl Y), f := f
  | inl (inr X), inl (inr Y), f := f
  | inr X, inr Y, f := f
  end }

@[simp] lemma associator_obj_inl_inl (X) : (associator C D E).obj (inl (inl X)) = inl X := rfl
@[simp] lemma associator_obj_inl_inr (X) : (associator C D E).obj (inl (inr X)) = inr (inl X) := rfl
@[simp] lemma associator_obj_inr (X) : (associator C D E).obj (inr X) = inr (inr X) := rfl
@[simp] lemma associator_map_inl_inl {X Y : C} (f : inl (inl X) ⟶ inl (inl Y)) :
  (associator C D E).map f = f := rfl
@[simp] lemma associator_map_inl_inr {X Y : D} (f : inl (inr X) ⟶ inl (inr Y)) :
  (associator C D E).map f = f := rfl
@[simp] lemma associator_map_inr {X Y : E} (f : inr X ⟶ inr Y) :
  (associator C D E).map f = f := rfl

/--
The inverse associator functor `C ⊕ (D ⊕ E) ⥤ (C ⊕ D) ⊕ E` for sums of categories.
-/
def inverse_associator : C ⊕ (D ⊕ E) ⥤ (C ⊕ D) ⊕ E :=
{ obj := λ X, match X with
  | inl X := inl (inl X)
  | inr (inl X) := inl (inr X)
  | inr (inr X) := inr X
  end,
  map := λ X Y f, match X, Y, f with
  | inl X, inl Y, f := f
  | inr (inl X), inr (inl Y), f := f
  | inr (inr X), inr (inr Y), f := f
  end }

@[simp] lemma inverse_associator_obj_inl (X) :
  (inverse_associator C D E).obj (inl X) = inl (inl X) := rfl
@[simp] lemma inverse_associator_obj_inr_inl (X) :
  (inverse_associator C D E).obj (inr (inl X)) = inl (inr X) := rfl
@[simp] lemma inverse_associator_obj_inr_inr (X) :
  (inverse_associator C D E).obj (inr (inr X)) = inr X := rfl
@[simp]

/--
The equivalence of categories expressing associativity of sums of categories.
-/
def associativity : (C ⊕ D) ⊕ E ≌ C ⊕ (D ⊕ E) :=
equivalence.mk (associator C D E) (inverse_associator C D E)
  (nat_iso.of_components (λ X, eq_to_iso (by tidy)) (by tidy))
  (nat_iso.of_components (λ X, eq_to_iso (by tidy)) (by tidy))

instance associator_is_equivalence : is_equivalence (associator C D E) :=
(by apply_instance : is_equivalence (associativity C D E).functor)

instance inverse_associator_is_equivalence : is_equivalence (inverse_associator C D E) :=
(by apply_instance : is_equivalence (associativity C D E).inverse)

-- TODO unitors?
-- TODO pentagon natural transformation? ...satisfying?
end category_theory.sum


lemma imp_self (P : Prop) : P → P :=
begin
intro p,
exact p,
end


import new.unordered.chain
import new.ordered.chain_o
-- import algebra.category.Group.abelian
import algebra.homology.homotopy

noncomputable theory

section

open topological_space Top Top.sheaf
open category_theory
open opposite
open AddCommGroup (hiding has_zero_object)

open_locale big_operators

universe u
variables {X : Top.{u}} (𝓕 : sheaf Ab X) (U : X.oc)

namespace computing_homotopy

variables {𝓕 U}

def unordered_to_ordered.to_fun (n : ℕ) :
  C 𝓕 U n → C_o 𝓕 U n :=
λ f σ, f σ.to_fun

def unordered_to_ordered (n : ℕ) :
  C 𝓕 U n ⟶ C_o 𝓕 U n :=
{ to_fun := unordered_to_ordered.to_fun n,
  map_zero' := rfl,
  map_add' := λ _ _, rfl }

def chain_unordered_to_ordered :
  Cech_complex_wrt_cover_unordered 𝓕 U ⟶
  Cech_complex_wrt_cover_ordered   𝓕 U :=
{ f := λ n, unordered_to_ordered (n+1),
  comm' := λ i j (h : _ + 1 = _), begin
    subst h,
    ext f α,
    -- change unordered_to_ordered.to_fun (i + 1) ≫ _ = _,
    rw [comp_apply, comp_apply, unordered_to_ordered, add_monoid_hom.coe_mk,
      unordered_to_ordered, add_monoid_hom.coe_mk, unordered_to_ordered.to_fun,
      unordered_to_ordered.to_fun],
    simp only,
    erw d_o_to_succ,
    erw d_to_succ,
    rw dd_o_aux.d_o_def,
    rw dd_aux.d_def,
    rw finset.sum_congr rfl,
    rintros ⟨k, hk⟩ -,
    split_ifs,
    { rw [id], refl, },
    { refl, },
  end }

def vec2vec_o_of_inj.to_fun {n} {α : fin n → U.ι} (h : function.injective α) : fin n → U.ι :=
let β := finset.order_iso_of_fin (finset.image α finset.univ)
  (show (finset.image α finset.univ).card = n, begin
    rw finset.card_image_eq_iff_inj_on.mpr,
    rw finset.card_univ,
    rw fintype.card_fin,
    apply set.inj_on_of_injective,
    assumption
  end) in
(λ x, x.1 : finset.image α finset.univ → U.ι) ∘ β.to_fun

lemma vec2vec_o_of_inj.to_fun_mem {n} {α : fin n → U.ι} (h : function.injective α) (i : fin n) :
  vec2vec_o_of_inj.to_fun h i ∈ finset.image α finset.univ := finset.mem_image.mpr $
begin
  dunfold vec2vec_o_of_inj.to_fun,
  simp only [finset.mem_univ, subtype.val_eq_coe, order_iso.to_fun_eq_coe,
    function.comp_app, finset.coe_order_iso_of_fin_apply, exists_true_left],
  generalize_proofs card_eq,
  sorry
end

lemma vec2vec_o_of_inj.is_strict_mono {n} {α : fin n → U.ι} (h : function.injective α) :
  strict_mono (vec2vec_o_of_inj.to_fun h) := λ i j ineq,
begin
  rw vec2vec_o_of_inj.to_fun,
  simp only,
  rw function.comp_apply,
  rw function.comp_apply,
  simpa only [order_iso.to_fun_eq_coe, subtype.val_eq_coe, finset.coe_order_iso_of_fin_apply, order_embedding.lt_iff_lt],
end

def vec2vec_o_of_inj {n} {α : fin n → U.ι} (h : function.injective α) : vec_o U n :=
{ to_fun := vec2vec_o_of_inj.to_fun h,
  is_strict_mono := vec2vec_o_of_inj.is_strict_mono h }

lemma vec2vec_o_of_inj.mem_image {n} {α : fin n → U.ι} (h : function.injective α) (i : fin n) :
  vec2vec_o_of_inj h i ∈ finset.image α finset.univ :=
vec2vec_o_of_inj.to_fun_mem h i

lemma face.vec2vec_o_eq {n} {α : fin n → U.ι} (h : function.injective α) :
  face α =
  face_o (vec2vec_o_of_inj h) :=
opens.ext $ set.ext $ λ p,
begin
  erw [opens.mem_coe, opens.mem_coe, opens.fintype_infi, opens.mem_coe, opens.fintype_infi],
  split;
  intros hp i,
  { rcases finset.mem_image.mp (vec2vec_o_of_inj.mem_image h i) with ⟨j, _, hj⟩,
    specialize hp j,
    rw hj at hp,
    exact hp, },
  { sorry },
end

def ordered_to_unordered.to_fun (n : ℕ) :
  C_o 𝓕 U n → C 𝓕 U n := λ f α,
dite (function.injective α)
(λ h, match signature α with
  | sign.zero := 0 -- this will never occur
  | sign.pos := 𝓕.1.map (eq_to_hom (face.vec2vec_o_eq h)).op (f (vec2vec_o_of_inj h))
  | sign.neg := - 𝓕.1.map (eq_to_hom (face.vec2vec_o_eq h)).op (f (vec2vec_o_of_inj h))
  end)
(λ _, 0)

def ordered_to_unordered (n : ℕ) :
  C_o 𝓕 U n ⟶ C 𝓕 U n :=
{ to_fun := ordered_to_unordered.to_fun n,
  map_zero' := sorry,
  map_add' := sorry }

def chain_ordered_to_unordered :
  Cech_complex_wrt_cover_ordered   𝓕 U ⟶
  Cech_complex_wrt_cover_unordered 𝓕 U :=
{ f := λ n, ordered_to_unordered (n + 1),
  comm' := sorry }

end computing_homotopy

def chain_unordered_homotopically_equivalent_ordered :
  homotopy_equiv
    (Cech_complex_wrt_cover_unordered 𝓕 U)
    (Cech_complex_wrt_cover_ordered 𝓕 U)
    :=
{ hom := computing_homotopy.chain_unordered_to_ordered,
  inv := computing_homotopy.chain_ordered_to_unordered,
  homotopy_hom_inv_id := sorry,
  homotopy_inv_hom_id := sorry }

def cohomology_unordered_eq_ordered (n : ℕ) :
  Cech_Cohomology_Group_wrt_cover_unordered_nth 𝓕 U n ≅
  Cech_Cohomology_Group_wrt_cover_ordered_nth 𝓕 U n :=
@homology_obj_iso_of_homotopy_equiv
  ℕ Ab _ _ (complex_shape.up ℕ)
  (Cech_complex_wrt_cover_unordered 𝓕 U)
  (Cech_complex_wrt_cover_ordered 𝓕 U)
  _ _ _ _ (abelian.has_zero_object)
  (chain_unordered_homotopically_equivalent_ordered 𝓕 U)
  n

def example1 :
  Cech_Cohomology_Group_wrt_cover_unordered_nth 𝓕 U 0 ≅
  𝓕.1.obj (op ⊤) :=
cohomology_unordered_eq_ordered 𝓕 U 0 ≪≫ zeroth_Cech_Cohomology 𝓕 U

end