/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Minchao Wu
-/
import tactic.core
/-!
# `#explode` command

Displays a proof term in a line by line format somewhat akin to a Fitch style
proof or the Metamath proof style.
-/

open expr tactic

namespace tactic
namespace explode

@[derive inhabited]
inductive status : Type | reg | intro | lam | sintro

/--
A type to distinguish introduction or elimination rules represented as
strings from theorems referred to by their names.
-/
meta inductive thm : Type
| expr (e : expr)
| name (n : name)
| string (s : string)

/--
Turn a thm into a string.
-/
meta def thm.to_string : thm → string
| (thm.expr e) := e.to_string
| (thm.name n) := n.to_string
| (thm.string s) := s

meta structure entry : Type :=
(expr : expr)
(line : nat)
(depth : nat)
(status : status)
(thm : thm)
(deps : list nat)

meta def pad_right (l : list string) : list string :=
let n := l.foldl (λ r (s:string), max r s.length) 0 in
l.map $ λ s, nat.iterate (λ s, s.push ' ') (n - s.length) s

@[derive inhabited]
meta structure entries : Type := mk' ::
(s : expr_map entry)
(l : list entry)

meta def entries.find (es : entries) (e : expr) : option entry := es.s.find e
meta def entries.size (es : entries) : ℕ := es.s.size

meta def entries.add : entries → entry → entries
| es@⟨s, l⟩ e := if s.contains e.expr then es else ⟨s.insert e.expr e, e :: l⟩

meta def entries.head (es : entries) : option entry := es.l.head'

meta def format_aux : list string → list string → list string → list entry → tactic format
| (line :: lines) (dep :: deps) (thm :: thms) (en :: es) := do
  fmt ← do {
    let margin := string.join (list.repeat " │" en.depth),
    let margin := match en.status with
      | status.sintro := " ├" ++ margin
      | status.intro := " │" ++ margin ++ " ┌"
      | status.reg := " │" ++ margin ++ ""
      | status.lam := " │" ++ margin ++ ""
      end,
    p ← infer_type en.expr >>= pp,
    let lhs :=  line ++ "│" ++ dep ++ "│ " ++ thm ++ margin ++ " ",
    return $ format.of_string lhs ++ (p.nest lhs.length).group ++ format.line },
  (++ fmt) <$> format_aux lines deps thms es
| _ _ _ _ := return format.nil

meta instance : has_to_tactic_format entries :=
⟨λ es : entries,
  let lines := pad_right $ es.l.map (λ en, to_string en.line),
      deps  := pad_right $ es.l.map (λ en, string.intercalate "," (en.deps.map to_string)),
      thms  := pad_right $ es.l.map (λ en, (entry.thm en).to_string) in
  format_aux lines deps thms es.l⟩

meta def append_dep (filter : expr → tactic unit)
 (es : entries) (e : expr) (deps : list nat) : tactic (list nat) :=
do { ei ← es.find e,
  filter ei.expr,
  return (ei.line :: deps) }
<|> return deps

meta def may_be_proof (e : expr) : tactic bool :=
do expr.sort u ← infer_type e >>= infer_type,
   return $ bnot u.nonzero

end explode
open explode

meta mutual def explode.core, explode.args (filter : expr → tactic unit)
with explode.core : expr → bool → nat → entries → tactic entries
| e@(lam n bi d b) si depth es := do
  m ← mk_fresh_name,
  let l := local_const m n bi d,
  let b' := instantiate_var b l,
  if si then
    let en : entry := ⟨l, es.size, depth, status.sintro, thm.name n, []⟩ in do
    es' ← explode.core b' si depth (es.add en),
    return $ es'.add ⟨e, es'.size, depth, status.lam, thm.string "∀I", [es.size, es'.size - 1]⟩
  else do
    let en : entry := ⟨l, es.size, depth, status.intro, thm.name n, []⟩,
    es' ← explode.core b' si (depth + 1) (es.add en),
    -- in case of a "have" clause, the b' here has an annotation
    deps' ← explode.append_dep filter es' b'.erase_annotations [],
    deps' ← explode.append_dep filter es' l deps',
    return $ es'.add ⟨e, es'.size, depth, status.lam, thm.string "∀I", deps'⟩
| e@(elet n t a b) si depth es := explode.core (reduce_lets e) si depth es
| e@(macro n l) si depth es := explode.core l.head si depth es
| e si depth es := filter e >>
  match get_app_fn_args e with
  | (nm@(const n _), args) :=
    explode.args e args depth es (thm.expr nm) []
  | (fn, []) := do
    let en : entry := ⟨fn, es.size, depth, status.reg, thm.expr fn, []⟩,
    return (es.add en)
  | (fn, args) := do
    es' ← explode.core fn ff depth es,
    -- in case of a "have" clause, the fn here has an annotation
    deps ← explode.append_dep filter es' fn.erase_annotations [],
    explode.args e args depth es' (thm.string "∀E") deps
  end
with explode.args : expr → list expr → nat → entries → thm → list nat → tactic entries
| e (arg :: args) depth es thm deps := do
  es' ← explode.core arg ff depth es <|> return es,
  deps' ← explode.append_dep filter es' arg deps,
  explode.args e args depth es' thm deps'
| e [] depth es thm deps :=
  return (es.add ⟨e, es.size, depth, status.reg, thm, deps.reverse⟩)

meta def explode_expr (e : expr) (hide_non_prop := tt) : tactic entries :=
let filter := if hide_non_prop then λ e, may_be_proof e >>= guardb else λ _, skip in
tactic.explode.core filter e tt 0 (default _)

meta def explode (n : name) : tactic unit :=
do const n _ ← resolve_name n | fail "cannot resolve name",
  d ← get_decl n,
  v ← match d with
  | (declaration.defn _ _ _ v _ _) := return v
  | (declaration.thm _ _ _ v)      := return v.get
  | _                  := fail "not a definition"
  end,
  t ← pp d.type,
  explode_expr v <* trace (to_fmt n ++ " : " ++ t) >>= trace

open interactive lean lean.parser interaction_monad.result

/--
`#explode decl_name` displays a proof term in a line-by-line format somewhat akin to a Fitch-style
proof or the Metamath proof style.
`#explode_widget decl_name` renders a widget that displays an `#explode` proof.

`#explode iff_true_intro` produces

```lean
iff_true_intro : ∀ {a : Prop}, a → (a ↔ true)
0│   │ a         ├ Prop
1│   │ h         ├ a
2│   │ hl        │ ┌ a
3│   │ trivial   │ │ true
4│2,3│ ∀I        │ a → true
5│   │ hr        │ ┌ true
6│5,1│ ∀I        │ true → a
7│4,6│ iff.intro │ a ↔ true
8│1,7│ ∀I        │ a → (a ↔ true)
9│0,8│ ∀I        │ ∀ {a : Prop}, a → (a ↔ true)
```

In more detail:

The output of `#explode` is a Fitch-style proof in a four-column diagram modeled after Metamath
proof displays like [this](http://us.metamath.org/mpeuni/ru.html). The headers of the columns are
"Step", "Hyp", "Ref", "Type" (or "Expression" in the case of Metamath):
* Step: An increasing sequence of numbers to number each step in the proof, used in the Hyp field.
* Hyp: The direct children of the current step. Most theorems are implications like `A -> B -> C`,
  and so on the step proving `C` the Hyp field will refer to the steps that prove `A` and `B`.
* Ref: The name of the theorem being applied. This is well-defined in Metamath, but in Lean there
  are some special steps that may have long names because the structure of proof terms doesn't
  exactly match this mold.
  * If the theorem is `foo (x y : Z) : A x -> B y -> C x y`:
    * the Ref field will contain `foo`,
    * `x` and `y` will be suppressed, because term construction is not interesting, and
    * the Hyp field will reference steps proving `A x` and `B y`. This corresponds to a proof term
      like `@foo x y pA pB` where `pA` and `pB` are subproofs.
  * If the head of the proof term is a local constant or lambda, then in this case the Ref will
    say `∀E` for forall-elimination. This happens when you have for example `h : A -> B` and
    `ha : A` and prove `b` by `h ha`; we reinterpret this as if it said `∀E h ha` where `∀E` is
    (n-ary) modus ponens.
  * If the proof term is a lambda, we will also use `∀I` for forall-introduction, referencing the
    body of the lambda. The indentation level will increase, and a bracket will surround the proof
    of the body of the lambda, starting at a proof step labeled with the name of the lambda variable
    and its type, and ending with the `∀I` step. Metamath doesn't have steps like this, but the
    style is based on Fitch proofs in first-order logic.
* Type: This contains the type of the proof term, the theorem being proven at the current step.
  This proof layout differs from `#print` in using lots of intermediate step displays so that you
  can follow along and don't have to see term construction steps because they are implicitly in the
  intermediate step displays.

Also, it is common for a Lean theorem to begin with a sequence of lambdas introducing local
constants of the theorem. In order to minimize the indentation level, the `∀I` steps at the end of
the proof will be introduced in a group and the indentation will stay fixed. (The indentation
brackets are only needed in order to delimit the scope of assumptions, and these assumptions
have global scope anyway so detailed tracking is not necessary.)
-/
@[user_command]
meta def explode_cmd (_ : parse $ tk "#explode") : parser unit :=
do n ← ident,
  explode n
.

add_tactic_doc
{ name       := "#explode / #explode_widget",
  category   := doc_category.cmd,
  decl_names := [`tactic.explode_cmd, `tactic.explode_widget_cmd],
  inherit_description_from := `tactic.explode_cmd,
  tags       := ["proof display", "widgets"] }

end tactic


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.meta.tactic
import Mathlib.Lean3Lib.init.meta.format
import Mathlib.Lean3Lib.init.function

universes l

namespace Mathlib

/-- This is a kind attached to an argument of a congruence lemma that tells the simplifier how to fill it in.
- `fixed`: It is a parameter for the congruence lemma, the parameter occurs in the left and right hand sides.
  For example the α in the congruence generated from `f: Π {α : Type} α → α`.
- `fixed_no_param`: It is not a parameter for the congruence lemma, the lemma was specialized for this parameter.
  This only happens if the parameter is a subsingleton/proposition, and other parameters depend on it.
- `eq`: The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `(eq_i : a_i = b_i)`.
  `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their equality.
  For example the second argument in `f: Π {α : Type}, α → α`.
- `cast`: corresponds to arguments that are subsingletons/propositions.
  For example the `p` in the congruence generated from `f : Π (x y : ℕ) (p: x < y), ℕ`.
- `heq` The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `(eq_i : a_i == b_i)`.
   `a_i` and `b_i` represent the left and right hand sides, and eq_i is a proof for their heterogeneous equality.
-/
inductive congr_arg_kind where
| fixed : congr_arg_kind
| fixed_no_param : congr_arg_kind
| eq : congr_arg_kind
| cast : congr_arg_kind
| heq : congr_arg_kind

namespace congr_arg_kind

def to_string : congr_arg_kind → string := sorry

protected instance has_repr : has_repr congr_arg_kind := has_repr.mk to_string

end Mathlib


/-
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.idempotents.functor_extension2
import category_theory.natural_isomorphism

import category_theory.functor.fully_faithful

open category_theory.category
open category_theory.idempotents
open category_theory.idempotents.karoubi

namespace category_theory

namespace idempotents

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

@[simps]
def whiskering_left_to_karoubi_hom_equiv
  (F G : karoubi C ⥤ D) : (F ⟶ G) ≃ (to_karoubi _ ⋙ F ⟶ to_karoubi _ ⋙ G) :=
{ to_fun := λ φ,
  { app := λ X, φ.app ((to_karoubi C).obj X),
    naturality' := λ X Y f, by simp only [nat_trans.naturality, functor.comp_map], },
  inv_fun := λ ψ,
  { app := λ P, F.map (decomp_id_i P) ≫ (ψ.app P.X) ≫ G.map (decomp_id_p P),
    naturality' := λ P Q f, by {
      slice_lhs 1 2 { rw [← F.map_comp], },
      slice_rhs 3 4 { rw [← G.map_comp], },
      rw [decomp_id_i_naturality, decomp_id_p_naturality,
        F.map_comp, G.map_comp],
      slice_lhs 2 3 { erw ψ.naturality, },
      simp only [assoc],
      refl, }, },
  left_inv := λ φ, by { ext P, exact (nat_trans_eq φ P).symm, },
  right_inv := λ ψ, begin
    ext X,
    dsimp,
    erw [decomp_id_i_to_karoubi, decomp_id_p_to_karoubi,
      F.map_id, G.map_id, comp_id, id_comp],
  end }

lemma whiskering_left_to_karoubi_hom_inv_fun_comp
  {F G H : karoubi C ⥤ D} (φ : to_karoubi _ ⋙ F ⟶ to_karoubi _ ⋙ G)
  (ψ : to_karoubi _ ⋙ G ⟶ to_karoubi _ ⋙  H) :
  (whiskering_left_to_karoubi_hom_equiv F H).inv_fun (φ ≫ ψ) =
  (whiskering_left_to_karoubi_hom_equiv F G).inv_fun φ ≫
  (whiskering_left_to_karoubi_hom_equiv G H).inv_fun ψ :=
begin
  ext P,
  dsimp,
  slice_rhs 3 4 { rw [← G.map_comp, ← decomp_p], },
  erw ψ.naturality P.p,
  slice_rhs 4 5 { erw [← H.map_comp], },
  simp only [assoc],
  congr,
  ext,
  simp only [decomp_id_p_f, comp_f, to_karoubi_map_f, P.idem],
end

lemma whiskering_left_to_karoubi_hom_inv_fun_id
  {F : karoubi C ⥤ D} :
  (whiskering_left_to_karoubi_hom_equiv F F).inv_fun (𝟙 _) = 𝟙 _ :=
begin
  ext P,
  simp only [whiskering_left_to_karoubi_hom_equiv_symm_apply_app, nat_trans.id_app, equiv.inv_fun_as_coe],
  erw [id_comp, ← F.map_comp, ← decomp_id, F.map_id],
end

@[simps]
def whiskering_left_to_karoubi_iso_equiv
  (F G : karoubi C ⥤ D) : (F ≅ G) ≃ (to_karoubi _ ⋙ F ≅ to_karoubi _ ⋙ G) :=
{ to_fun := λ φ,
  { hom := (whiskering_left_to_karoubi_hom_equiv F G).to_fun φ.hom,
    inv := (whiskering_left_to_karoubi_hom_equiv G F).to_fun φ.inv, },
  inv_fun := λ ψ,
  { hom := (whiskering_left_to_karoubi_hom_equiv F G).inv_fun ψ.hom,
    inv := (whiskering_left_to_karoubi_hom_equiv G F).inv_fun ψ.inv,
    hom_inv_id' := by rw [← whiskering_left_to_karoubi_hom_inv_fun_comp, iso.hom_inv_id, whiskering_left_to_karoubi_hom_inv_fun_id],
    inv_hom_id' := by rw [← whiskering_left_to_karoubi_hom_inv_fun_comp, iso.inv_hom_id, whiskering_left_to_karoubi_hom_inv_fun_id], },
  left_inv := λ φ, by { ext P, simp only [equiv.to_fun_as_coe, equiv.symm_apply_apply,
    equiv.inv_fun_as_coe], },
  right_inv := λ ψ, by { ext X, simp only [equiv.to_fun_as_coe, equiv.apply_symm_apply,
    equiv.inv_fun_as_coe], } }

lemma karoubi_universal₁_inverse_preimage (F G : karoubi C ⥤ karoubi D)
  (φ : ((karoubi_universal₁ C D).inverse).obj F ⟶ ((karoubi_universal₁ C D).inverse).obj G) :
  (karoubi_universal₁ C D).inverse.preimage φ = (whiskering_left_to_karoubi_hom_equiv F G).inv_fun φ :=
begin
  apply functor.map_injective (((whiskering_left C (karoubi C) (karoubi D)).obj (to_karoubi C))),
  erw functor.image_preimage,
  ext1, ext1 X,
  dsimp [decomp_id_i, decomp_id_p],
  erw [F.map_id, G.map_id, id_comp, comp_id],
end

--lemma karoubi_universal'_inverse_preimage_iso (F G : karoubi C ⥤ karoubi D)
--  (e : ((karoubi_universal' C D).inverse).obj F ≅ ((karoubi_universal' C D).inverse).obj G) :
--  preimage_iso e = (whiskering_left_to_karoubi_iso_equiv F G).inv_fun e :=
--by { ext1, exact karoubi_universal'_inverse_preimage F G e.hom, }

lemma whiskering_left_to_karoubi_hom_equiv_inv_fun_compat {F G : karoubi C ⥤ D}
  (ψ : to_karoubi _ ⋙ F ⟶ to_karoubi _ ⋙ G) (X : C) :
  ((whiskering_left_to_karoubi_hom_equiv _ _).inv_fun ψ).app ((to_karoubi _).obj X) = ψ.app X :=
congr_app ((whiskering_left_to_karoubi_hom_equiv _ _).right_inv ψ) X

end idempotents

end category_theory


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.monotonicity.basic
import Mathlib.control.traversable.default
import Mathlib.control.traversable.derive
import Mathlib.Lean3Lib.data.dlist
import Mathlib.PostPort

universes u v u_1 u_2 l

namespace Mathlib

namespace tactic.interactive

/--
`(prefix,left,right,suffix) ← match_assoc unif l r` finds the
longest prefix and suffix common to `l` and `r` and
returns them along with the differences  -/
def apply_rel {α : Sort u} (R : α → α → Sort v) {x : α} {y : α} (x' : α) (y' : α) (h : R x y)
    (hx : x = x') (hy : y = y') : R x' y' :=
  eq.mpr sorry (eq.mpr sorry h)

/-- tactic-facing function, similar to `interactive.tactic.generalize` with the
exception that meta variables -/
def list.minimum_on {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) : List α → List α :=
  sorry

/--
- `mono` applies a monotonicity rule.
- `mono*` applies monotonicity rules repetitively.
- `mono with x ≤ y` or `mono with [0 ≤ x,0 ≤ y]` creates an assertion for the listed
  propositions. Those help to select the right monotonicity rule.
- `mono left` or `mono right` is useful when proving strict orderings:
   for `x + y < w + z` could be broken down into either
    - left:  `x ≤ w` and `y < z` or
    - right: `x < w` and `y ≤ z`
- `mono using [rule1,rule2]` calls `simp [rule1,rule2]` before applying mono.
- The general syntax is `mono '*'? ('with' hyp | 'with' [hyp1,hyp2])? ('using' [hyp1,hyp2])? mono_cfg?

To use it, first import `tactic.monotonicity`.

Here is an example of mono:

```lean
example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y) :
  (k + 3 + x) - y ≤ (k + 4 + x) - z :=
begin
  mono, -- unfold `(-)`, apply add_le_add
  { -- ⊢ k + 3 + x ≤ k + 4 + x
    mono, -- apply add_le_add, refl
    -- ⊢ k + 3 ≤ k + 4
    mono },
  { -- ⊢ -y ≤ -z
    mono /- apply neg_le_neg -/ }
end
```

More succinctly, we can prove the same goal as:

```lean
example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y) :
  (k + 3 + x) - y ≤ (k + 4 + x) - z :=
by mono*
```

-/
/--
transforms a goal of the form `f x ≼ f y` into `x ≤ y` using lemmas
marked as `monotonic`.

Special care is taken when `f` is the repeated application of an
associative operator and if the operator is commutative
-/
/-- (repeat_until_or_at_most n t u): repeat tactic `t` at most n times or until u succeeds -/
inductive rep_arity where
| one : rep_arity
| exactly : ℕ → rep_arity
| many : rep_arity

/--

`ac_mono` reduces the `f x ⊑ f y`, for some relation `⊑` and a
monotonic function `f` to `x ≺ y`.

`ac_mono*` unwraps monotonic functions until it can't.

`ac_mono^k`, for some literal number `k` applies monotonicity `k`
times.

`ac_mono h`, with `h` a hypothesis, unwraps monotonic functions and
uses `h` to solve the remaining goal. Can be combined with `*` or `^k`:
`ac_mono* h`

`ac_mono : p` asserts `p` and uses it to discharge the goal result
unwrapping a series of monotonic functions. Can be combined with * or
^k: `ac_mono* : p`

In the case where `f` is an associative or commutative operator,
`ac_mono` will consider any possible permutation of its arguments and
use the one the minimizes the difference between the left-hand side
and the right-hand side.

To use it, first import `tactic.monotonicity`.

`ac_mono` can be used as follows:

```lean
example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : x ≤ y) :
  (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono,
  -- ⊢ (m + x + n) * z ≤ z * (y + n + m)
  ac_mono,
  -- ⊢ m + x + n ≤ y + n + m
  ac_mono,
end
```

As with `mono*`, `ac_mono*` solves the goal in one go and so does
`ac_mono* h₁`. The latter syntax becomes especially interesting in the
following example:

```lean
example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : m + x + n ≤ y + n + m) :
  (m + x + n) * z + k ≤ z * (y + n + m) + k :=
by ac_mono* h₁.
```

By giving `ac_mono` the assumption `h₁`, we are asking `ac_refl` to
stop earlier than it would normally would.
-/
/-
TODO(Simon): with `ac_mono h` and `ac_mono : p` split the remaining
  gaol if the provided rule does not solve it completely.
-/

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import algebra.group.pi
import group_theory.group_action.defs

/-!
# Pi instances for multiplicative actions

This file defines instances for mul_action and related structures on Pi types.

## See also

* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
* `group_theory.group_action.sum`
-/

universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)

namespace pi

@[to_additive pi.has_vadd]
instance has_smul {α : Type*} [Π i, has_smul α $ f i] :
  has_smul α (Π i : I, f i) :=
⟨λ s x, λ i, s • (x i)⟩

@[to_additive]
lemma smul_def {α : Type*} [Π i, has_smul α $ f i] (s : α) : s • x = λ i, s • x i := rfl
@[simp, to_additive]
lemma smul_apply {α : Type*} [Π i, has_smul α $ f i] (s : α) : (s • x) i = s • x i := rfl

@[to_additive pi.has_vadd']
instance has_smul' {g : I → Type*} [Π i, has_smul (f i) (g i)] :
  has_smul (Π i, f i) (Π i : I, g i) :=
⟨λ s x, λ i, (s i) • (x i)⟩

@[simp, to_additive]
lemma smul_apply' {g : I → Type*} [∀ i, has_smul (f i) (g i)] (s : Π i, f i) (x : Π i, g i) :
  (s • x) i = s i • x i :=
rfl
instance is_scalar_tower {α β : Type*}
  [has_smul α β] [Π i, has_smul β $ f i] [Π i, has_smul α $ f i]
  [Π i, is_scalar_tower α β (f i)] : is_scalar_tower α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_assoc x y (z i)⟩

instance is_scalar_tower' {g : I → Type*} {α : Type*}
  [Π i, has_smul α $ f i] [Π i, has_smul (f i) (g i)] [Π i, has_smul α $ g i]
  [Π i, is_scalar_tower α (f i) (g i)] : is_scalar_tower α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_assoc x (y i) (z i)⟩

instance is_scalar_tower'' {g : I → Type*} {h : I → Type*}
  [Π i, has_smul (f i) (g i)] [Π i, has_smul (g i) (h i)] [Π i, has_smul (f i) (h i)]
  [Π i, is_scalar_tower (f i) (g i) (h i)] : is_scalar_tower (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_assoc (x i) (y i) (z i)⟩

@[to_additive]
instance smul_comm_class {α β : Type*}
  [Π i, has_smul α $ f i] [Π i, has_smul β $ f i] [∀ i, smul_comm_class α β (f i)] :
  smul_comm_class α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_comm x y (z i)⟩

@[to_additive]
instance smul_comm_class' {g : I → Type*} {α : Type*}
  [Π i, has_smul α $ g i] [Π i, has_smul (f i) (g i)] [∀ i, smul_comm_class α (f i) (g i)] :
  smul_comm_class α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_comm x (y i) (z i)⟩

@[to_additive]
instance smul_comm_class'' {g : I → Type*} {h : I → Type*}
  [Π i, has_smul (g i) (h i)] [Π i, has_smul (f i) (h i)]
  [∀ i, smul_comm_class (f i) (g i) (h i)] : smul_comm_class (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_comm (x i) (y i) (z i)⟩

instance {α : Type*} [Π i, has_smul α $ f i] [Π i, has_smul αᵐᵒᵖ $ f i]
  [∀ i, is_central_scalar α (f i)] : is_central_scalar α (Π i, f i) :=
⟨λ r m, funext $ λ i, op_smul_eq_smul _ _⟩

/-- If `f i` has a faithful scalar action for a given `i`, then so does `Π i, f i`. This is
not an instance as `i` cannot be inferred. -/
@[to_additive pi.has_faithful_vadd_at]
lemma has_faithful_smul_at {α : Type*}
  [Π i, has_smul α $ f i] [Π i, nonempty (f i)] (i : I) [has_faithful_smul α (f i)] :
  has_faithful_smul α (Π i, f i) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ a : f i, begin
  classical,
  have := congr_fun (h $ function.update (λ j, classical.choice (‹Π i, nonempty (f i)› j)) i a) i,
  simpa using this,
end⟩

@[to_additive pi.has_faithful_vadd]
instance has_faithful_smul {α : Type*}
  [nonempty I] [Π i, has_smul α $ f i] [Π i, nonempty (f i)] [Π i, has_faithful_smul α (f i)] :
  has_faithful_smul α (Π i, f i) :=
let ⟨i⟩ := ‹nonempty I› in has_faithful_smul_at i

@[to_additive]
instance mul_action (α) {m : monoid α} [Π i, mul_action α $ f i] :
  @mul_action α (Π i : I, f i) m :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul α _ }

@[to_additive]
instance mul_action' {g : I → Type*} {m : Π i, monoid (f i)} [Π i, mul_action (f i) (g i)] :
  @mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul _ _ }

instance distrib_mul_action (α) {m : monoid α} {n : ∀ i, add_monoid $ f i}
  [∀ i, distrib_mul_action α $ f i] :
  @distrib_mul_action α (Π i : I, f i) m (@pi.add_monoid I f n) :=
{ smul_zero := λ c, funext $ λ i, smul_zero _,
  smul_add := λ c f g, funext $ λ i, smul_add _ _ _,
  ..pi.mul_action _ }

instance distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, add_monoid $ g i}
  [Π i, distrib_mul_action (f i) (g i)] :
  @distrib_mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) (@pi.add_monoid I g n) :=
{ smul_add := by { intros, ext x, apply smul_add },
  smul_zero := by { intros, ext x, apply smul_zero } }

lemma single_smul {α} [monoid α] [Π i, add_monoid $ f i]
  [Π i, distrib_mul_action α $ f i] [decidable_eq I] (i : I) (r : α) (x : f i) :
  single i (r • x) = r • single i x :=
single_op (λ i : I, ((•) r : f i → f i)) (λ j, smul_zero _) _ _

/-- A version of `pi.single_smul` for non-dependent functions. It is useful in cases Lean fails
to apply `pi.single_smul`. -/
lemma single_smul' {α β} [monoid α] [add_monoid β]
  [distrib_mul_action α β] [decidable_eq I] (i : I) (r : α) (x : β) :
  single i (r • x) = r • single i x :=
single_smul i r x

lemma single_smul₀ {g : I → Type*} [Π i, monoid_with_zero (f i)] [Π i, add_monoid (g i)]
  [Π i, distrib_mul_action (f i) (g i)] [decidable_eq I] (i : I) (r : f i) (x : g i) :
  single i (r • x) = single i r • single i x :=
single_op₂ (λ i : I, ((•) : f i → g i → g i)) (λ j, smul_zero _) _ _ _

instance mul_distrib_mul_action (α) {m : monoid α} {n : Π i, monoid $ f i}
  [Π i, mul_distrib_mul_action α $ f i] :
  @mul_distrib_mul_action α (Π i : I, f i) m (@pi.monoid I f n) :=
{ smul_one := λ c, funext $ λ i, smul_one _,
  smul_mul := λ c f g, funext $ λ i, smul_mul' _ _ _,
  ..pi.mul_action _ }

instance mul_distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, monoid $ g i}
  [Π i, mul_distrib_mul_action (f i) (g i)] :
  @mul_distrib_mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) (@pi.monoid I g n) :=
{ smul_mul := by { intros, ext x, apply smul_mul' },
  smul_one := by { intros, ext x, apply smul_one } }

end pi

namespace function

/-- Non-dependent version of `pi.has_smul`. Lean gets confused by the dependent instance if this
is not present. -/
@[to_additive]
instance has_smul {ι R M : Type*} [has_smul R M] :
  has_smul R (ι → M) :=
pi.has_smul

/-- Non-dependent version of `pi.smul_comm_class`. Lean gets confused by the dependent instance if
this is not present. -/
@[to_additive]
instance smul_comm_class {ι α β M : Type*}
  [has_smul α M] [has_smul β M] [smul_comm_class α β M] :
  smul_comm_class α β (ι → M) :=
pi.smul_comm_class

@[to_additive]
lemma update_smul {α : Type*} [Π i, has_smul α (f i)] [decidable_eq I]
  (c : α) (f₁ : Π i, f i) (i : I) (x₁ : f i) :
  update (c • f₁) i (c • x₁) = c • update f₁ i x₁ :=
funext $ λ j, (apply_update (λ i, (•) c) f₁ i x₁ j).symm

end function

namespace set

@[to_additive]
lemma piecewise_smul {α : Type*} [Π i, has_smul α (f i)] (s : set I) [Π i, decidable (i ∈ s)]
  (c : α) (f₁ g₁ : Π i, f i) :
  s.piecewise (c • f₁) (c • g₁) = c • s.piecewise f₁ g₁ :=
s.piecewise_op _ _ (λ _, (•) c)

end set

section extend

@[to_additive] lemma function.extend_smul {R α β γ : Type*} [has_smul R γ]
  (r : R) (f : α → β) (g : α → γ) (e : β → γ) :
  function.extend f (r • g) (r • e) = r • function.extend f g e :=
funext $ λ _, by convert (apply_dite ((•) r) _ _ _).symm

end extend


import tactic --hide

/-Lemma
If $P,Q$ are logical statements with respective proofs $p,q$, then $Q$ is true.
-/
lemma example_two (P Q : Prop) (p : P) (q : Q) : Q :=
begin
  exact q,

end


import Lean
import Duper.TPTPParser.SyntaxDecl

open Lean
open Lean.Parser
open TSyntax.Compat

namespace TPTP

def explicitBinder : Parser := Term.explicitBinder false

axiom iota : Type
private axiom iotaInhabited : iota
noncomputable instance : Inhabited iota := ⟨iotaInhabited⟩

def processThfDefinedType (ty : Syntax) : MacroM Syntax := do
  match ty with
  | `(defined_type|🍉$id) =>
    match id.getId with
    | `i => `(TPTP.iota)
    | `o => `(Prop)
    | `tType => `(Type)
    | _ => Macro.throwError s!"Unsupported thf_defined_type: {ty}"
  | _ => Macro.throwError s!"{ty} is not a defined type"

def processThfDefinedTerm (term : Syntax) : MacroM Syntax := do
  match term with
  | `(defined_term|🍉$id) =>
    match id.getId with
    | `true => `(True)
    | `false => `(False)
    | _ => Macro.throwError s!"Unsupported thf_defined_term: {term}"
  | _ => Macro.throwError s!"{term} is not a defined term"

partial def processThfAtomicType (stx : Syntax) : MacroM Syntax := do
  match stx with
  | `(thf_type| $ty:thf_atomic_type) => processThfAtomicType ty
  | `(thf_atomic_type| $ty:ident) => pure ty
  | `(thf_atomic_type| $ty:defined_type) => processThfDefinedType ty
  | `(thf_atomic_type| $f:ident $args:thf_type_arguments) => do
    let ts ←
      pure $ ← ((@Syntax.SepArray.mk "," args.raw[1].getArgs) : Array Syntax).mapM
                fun arg => processThfAtomicType arg
    let ts := mkNode ``many ts
    let ts := mkNode ``Term.app #[f, ts]
    `($ts)
  | _ => Macro.throwError s!"Unsupported thf_atomic_type: {stx}"

/-- In addition to returning the syntax that corresponds to the type of `stx`, if the
    type of `stx` is `Type` or has the form `A → B → ... → Type`, then we also return
    an Array containing the stx for `A`, `B`, etc. (in reverse order. So `A → B → Type` would
    have the stx array #[B, A]) This is so that we can add the appropriate `Inhabited` constraints
    to the newly declared type. -/
partial def processThfType (stx : Syntax) : MacroM (Syntax × Option (Array Syntax)) := do
  match stx with
  | `(thf_type| ( $t:thf_type ) ) => processThfType t
  | `(thf_type| $ty:thf_atomic_type) =>
    let res ← processThfAtomicType ty
    let typeStx ← `(Type)
    if res == typeStx then return (res, some #[])
    else return (res, none)
  | `(thf_type| $arg:thf_type > $ret:thf_type) =>
    -- Although the current parser syntax has thf_type > thf_type, this pattern should
    -- only appear in TPTP files when both arg and ret are of the category thf_atomic_type
    let (ret, stxListOpt) ← processThfType ret
    let (arg, _) ← processThfType arg
    let res ← `($arg → $ret)
    match stxListOpt with
    | none => return (res, none)
    | some stxList => return (res, some (stxList.push arg))
  | `(thf_type| ( $args:thf_xprod_args ) > $ret:thf_atomic_type) =>
    let ret ← processThfAtomicType ret
    let args : Array Syntax := @Syntax.SepArray.mk "*" args.raw[0].getArgs
    let args ← args.mapM (fun a => processThfAtomicType a)
    let res ← args.foldrM (fun (a acc : Syntax) => `($a → $acc)) ret
    let typeStx ← `(Type)
    if ret == typeStx then return (res, some args.reverse)
    else return (res, none)
  | `(thf_type| $q:th1_quantifier [ $vs,* ] : $ty) =>
    let (ty, _) ← processThfType ty
    let vs : Array Syntax := vs
    let res ← vs.foldrM
      fun v acc => do
        let (v, v_ty) ← match v with
        | `(thf_variable| $v:ident) =>
          -- throw Error?
          pure (v, (← `(_) : Syntax))
        | `(thf_variable| $v:ident : $v_ty:thf_type) =>
          pure (v, (← processThfType v_ty).1)
        | _ => Macro.throwError s!"Unsupported thf_variable: {v} when trying to process a tf1_quantified_type"
        match q.raw[0].getKind with
        | Name.str _ "!>" => `(∀ ($v : $v_ty), $acc)
        | _ => Macro.throwError s!"Unsupported th1_quantifier: {q.raw[0].getKind}"
      ty
    return (res, none)
  | _ => Macro.throwError s!"Unsupported thf_type: {stx}"

partial def processThfTerm (stx : Syntax) (is_untyped : Bool) : MacroM Syntax := do
  match stx with
  | `(thf_term| $d:defined_term) => processThfDefinedTerm d
  | `(thf_term| ( $t:thf_term ) ) => processThfTerm t is_untyped
  | `(thf_term| ~ $t:thf_term ) =>
    let t ← processThfTerm t is_untyped
    `(¬ $t)
  | `(thf_term| $t₁:thf_term @ $t₂:thf_term) => do
    let t₁ ← processThfTerm t₁ is_untyped
    let t₂ ← processThfTerm t₂ is_untyped
    `(($t₁ $t₂))
  | `(thf_term| $t₁:thf_term $conn:bexpOp $t₂:thf_term ) => do
    let t₁ ← processThfTerm t₁ is_untyped
    let t₂ ← processThfTerm t₂ is_untyped
    match conn.raw[0].getKind with
    | Name.str _ "&" => `($t₁ ∧ $t₂)
    | Name.str _ "=>" => `($t₁ → $t₂)
    | Name.str _ "|"=> `($t₁ ∨ $t₂)
    | Name.str _ "<=>" => `($t₁ ↔ $t₂)
    | Name.str _ "<~>" => `(¬ ($t₁ ↔ $t₂))
    | Name.str _ "~|" => `(¬ ($t₁ ∨ $t₂))
    | Name.str _ "~&" => `(¬ ($t₁ ∧ $t₂))
    | _ => Macro.throwError s!"Unsupported bexpOp: {conn.raw[0].getKind}"
  | `(thf_term| $t₁:thf_term $conn:eqOp $t₂:thf_term ) => do
    let t₁ ← processThfTerm t₁ is_untyped
    let t₂ ← processThfTerm t₂ is_untyped
    match conn.raw[0].getKind with
    | Name.str _ "=" => `($t₁ = $t₂)
    | Name.str _ "!=" => `($t₁ ≠ $t₂)
    | _ => Macro.throwError s!"Unsupported eqOp: {conn.raw[0].getKind}"
  | `(thf_term| $f:ident $args:thf_arguments ?) => do
    let ts : Array Syntax ← match args with
    | some args =>
      ((@Syntax.SepArray.mk "," args.raw[1].getArgs) : Array Syntax).mapM
          fun arg => processThfTerm arg is_untyped
    | none => pure #[]
    let ts := mkNode ``many ts
    let ts := mkNode ``Term.app #[f, ts]
    `($ts)
  | `(thf_term| $q:quantifier [ $vs,* ] : $body) => do
    let body ← processThfTerm body is_untyped
    let vs : Array Syntax := vs
    vs.foldrM
      fun v acc => do
        let (v, ty) ← match v with
        | `(thf_variable| $v:ident) =>
          if is_untyped then
            let iotaTypeSyntax ← `(TPTP.iota)
            pure (v, iotaTypeSyntax.raw)
          else
            -- throw Error?
            pure (v, (← `(_) : Syntax))
        | `(thf_variable| $v:ident : $ty:thf_type) =>
          pure (v, (← processThfType ty).1)
        | _ => Macro.throwError s!"Unsupported thf_variable: {v}"
        match q.raw[0].getKind with
        | Name.str _ "!" => `(∀ ($v : $ty), $acc)
        | Name.str _ "?" => `(Exists fun ($v : $ty) => $acc)
        | Name.str _ "^" => `(fun ($v : $ty) => $acc)
        | _ => Macro.throwError s!"Unsupported quantifier: {q.raw[0].getKind}"
      body
  | _ => Macro.throwError s!"Unsupported thf_term: {stx}"

/-- Determines whether an identifier is a variable by checking whether the first character is capital -/
def isVar (stx : TSyntax `ident) : MacroM Bool := do
  match stx with
  | Syntax.ident _ rawVal _ _ => return (rawVal.get 0).isUpper
  | _ => Macro.throwError "Non-ident passed into isVar"

/-- Given a piece of syntax, returns the list of variables that appear in said syntax. This function
    may return lists in which the same variable appears multiple times. -/
partial def getVarsHelper (stx : Syntax) : MacroM (List (TSyntax `ident)) := do
  match stx with
  | `(thf_term| ( $t:thf_term )) => getVarsHelper t
  | `(thf_term| ~ $t:thf_term ) => getVarsHelper t
  | `(thf_term| $t1:thf_term $conn:bexpOp $t2:thf_term ) =>
    return (← getVarsHelper t1).append (← getVarsHelper t2)
  | `(thf_term| $t1:thf_term $conn:eqOp $t2:thf_term ) =>
    return (← getVarsHelper t1).append (← getVarsHelper t2)
  | `(thf_term| $f:ident $args:thf_arguments ?) =>
    match args with
    | none =>
      if (← isVar f) then return [f]
      else return []
    | some args =>
      let args := ((@Syntax.SepArray.mk "," args.raw[1].getArgs) : Array Syntax)
      let argsVars ← args.mapM (fun arg => getVarsHelper arg)
      let argsVars := argsVars.foldl
        (fun acc varList => varList.append acc) []
      if (← isVar f) then return f :: argsVars
      else return argsVars
  | _ => Macro.throwError s!"Unsupported cnf term: {stx}"

/-- Given a piece of syntax, returns the list of variables that appear in said syntax. This function is needed
    because cnf clauses are implicitly universally quantified (but Lean requires that we explicitly universally
    quantify the variables). This function is only intended to be called on cnf clauses. -/
def getVars (stx : Syntax) : MacroM (List (TSyntax `ident)) := do
  let varsWithDuplicates ← getVarsHelper stx
  let vars := varsWithDuplicates.foldl
    (fun acc var => if acc.contains var then acc else var :: acc) []
  return vars

partial def processCnfTerm (stx : Syntax) : MacroM Syntax := do
  let vars ← getVars stx
  let iotaTypeSyntax ← `(TPTP.iota)
  let unquantifiedRes ← processThfTerm stx true
  let quantifiedRes ← vars.foldlM
    (fun acc (var : TSyntax `ident) => `(∀ ($var : $iotaTypeSyntax), $acc)) unquantifiedRes
  return quantifiedRes

/-- Note: This function is only meant to be used for fof/cnf formats (tff files declare their own symbols).

    Returns a list in which each element is `(explicitBinder| ($name : $ty)) where $name is a symbol that
    appears in stx (and isn't a variable) and $ty is the type of said symbol.

    In fof/cnf formats, the only base types are Prop and `iota. All symbols therefore must be of type Prop, type
    `iota, or functions that output Prop or iota. Which of these is the case can be determined by the position
    of the symbol in the overall formula.

    The topType argument is used to keep track of what the overall type of stx is supposed to be. -/
partial def getNonVarSymbols (acc : HashMap String (TSyntax `TPTP.explicitBinder)) (topType : TSyntax `thf_type)
  (stx : Syntax) : MacroM (HashMap String (TSyntax `TPTP.explicitBinder)) := do
  match stx with
  | `(thf_term|🍉$id:ident) => return acc
  | `(thf_term| ( $t:thf_term )) => getNonVarSymbols acc topType t
  | `(thf_term| ~ $t:thf_term ) =>
    if topType != (← `(Prop)) then Macro.throwError s!"Error: cnf/fof term: {stx} is supposed to have type {topType}"
    else getNonVarSymbols acc (← `(Prop)) t
  | `(thf_term| $t1:thf_term $conn:bexpOp $t2:thf_term ) =>
    if topType != (← `(Prop)) then Macro.throwError s!"Error: cnf/fof term: {stx} is supposed to have type {topType}"
    else
      match conn.raw[0].getKind with
      | Name.str _ "&" => getNonVarSymbols (← getNonVarSymbols acc (← `(Prop)) t1) (← `(Prop)) t2
      | Name.str _ "=>" => getNonVarSymbols (← getNonVarSymbols acc (← `(Prop)) t1) (← `(Prop)) t2
      | Name.str _ "|" => getNonVarSymbols (← getNonVarSymbols acc (← `(Prop)) t1) (← `(Prop)) t2
      | Name.str _ "<=>" => getNonVarSymbols (← getNonVarSymbols acc (← `(Prop)) t1) (← `(Prop)) t2
      | Name.str _ "<~>" => getNonVarSymbols (← getNonVarSymbols acc (← `(Prop)) t1) (← `(Prop)) t2
      | Name.str _ "~|" => getNonVarSymbols (← getNonVarSymbols acc (← `(Prop)) t1) (← `(Prop)) t2
      | Name.str _ "~&" => getNonVarSymbols (← getNonVarSymbols acc (← `(Prop)) t1) (← `(Prop)) t2
      | _ => Macro.throwError s!"Unsupported bexpOp: {conn.raw[0].getKind}"
  | `(thf_term| $t1:thf_term $conn:eqOp $t2:thf_term ) =>
    if topType != (← `(Prop)) then Macro.throwError s!"Error: cnf/fof term: {stx} is supposed to have type {topType}"
    else
      match conn.raw[0].getKind with
      | Name.str _ "=" => getNonVarSymbols (← getNonVarSymbols acc (← `(TPTP.iota)) t1) (← `(TPTP.iota)) t2
      | Name.str _ "!=" => getNonVarSymbols (← getNonVarSymbols acc (← `(TPTP.iota)) t1) (← `(TPTP.iota)) t2
      | _ => Macro.throwError s!"Unsupported eqOp: {conn.raw[0].getKind}"
  | `(thf_term| $f:ident $args:thf_arguments ?) =>
    if (← isVar f) then
      if let some _ := args then
        Macro.throwError s!"Variable used as function in cnf/fof term: {stx}"
      else
        return acc
    match args with
    | none =>
      let s := f.getId.getString!
      let binder ← `(explicitBinder| ($f : $topType))
      return acc.insert s binder
    | some args =>
      let args := ((@Syntax.SepArray.mk "," args.raw[1].getArgs) : Array Syntax)
      let iotaTypeSyntax ← `(TPTP.iota)
      let fType ← args.foldlM (fun (acc _ : Syntax) => do
        `($iotaTypeSyntax → $acc)) topType
      let acc ← args.foldlM (fun acc arg => do
        getNonVarSymbols acc (← `(TPTP.iota)) arg) acc
      let s := f.getId.getString!
      let binder ← `(explicitBinder| ($f : $fType))
      return acc.insert s binder
  | `(thf_term| $q:quantifier [ $vs,* ] : $body) =>
    if topType != (← `(Prop)) then Macro.throwError s!"Error: cnf/fof term: {stx} is supposed to have type {topType}"
    else getNonVarSymbols acc (← `(Prop)) body
  | _ => Macro.throwError s!"Unsupported cnf/fof term: {stx}"

macro "BEGIN_TPTP" name:ident s:TPTP_file "END_TPTP" proof:term : command => do
  let mut symtab : HashMap String (TSyntax `TPTP.explicitBinder) := HashMap.empty
  let sargs := s.raw[0].getArgs
  for input in sargs do
    match input with
    | `(TPTP_input| tff($name:ident,$role,$term:thf_term $annotation:annotation ?).) =>
      pure () -- Only need to retrieve symbols from cnf and fof files
    | `(TPTP_input| tff($n:ident,type,$name:ident : $ty:thf_type $annotation:annotation ?).) =>
      pure () -- Only need to retrieve symbols from cnf and fof files
    | `(TPTP_input| thf($name:ident,$role,$term:thf_term $annotation:annotation ?).) =>
      pure ()
    | `(TPTP_input| thf($n:ident,type,$name:ident : $ty:thf_type $annotation:annotation ?).) =>
      pure () -- Only need to retrieve symbols from cnf and fof files
    | `(TPTP_input| cnf($name:ident,$role,$term:thf_term $annotation:annotation ?).) =>
      symtab ← getNonVarSymbols symtab (← `(Prop)) term
    | `(TPTP_input| fof($name:ident,$role,$term:thf_term $annotation:annotation ?).) =>
      symtab ← getNonVarSymbols symtab (← `(Prop)) term
    | _ => Macro.throwError s!"Unsupported TPTP_input: {input}"
  -- Perform a foldl so that we only have one binder for each symbol
  let nonVarSymbols := (symtab.toList).foldl
    (fun acc (_, binder) =>
      if List.contains acc binder then acc
      else binder :: acc) []
  let mut hyps : Array (TSyntax `TPTP.explicitBinder) := #[]
  for input in sargs do
    match input with
    | `(TPTP_input| tff($name:ident,$role,$term:thf_term $annotation:annotation ?).) =>
      let term ← processThfTerm term false
      let name := (mkIdent $ name.getId.appendBefore "h")
      if role.getId == `conjecture then
        hyps := hyps.push (← `(explicitBinder| ($name : ¬ $term)))
      else
        hyps := hyps.push (← `(explicitBinder| ($name : $term)))
    | `(TPTP_input| tff($n:ident,type,$name:ident : $ty:thf_type $annotation:annotation ?).) =>
      let (ty, stxArrOpt) ← processThfType ty
      hyps := hyps.push (← `(explicitBinder| ($name : $ty)))
      match stxArrOpt with
      | none => continue
      | some stxArr =>
        let typeArgName := `typeArg
        let mut counter := 0
        let mut nameApp ← `($name)
        let mut typeArgs : Array Ident := #[]
        for _ in stxArr do
          let typeArg := mkIdent $ typeArgName.appendAfter (toString counter)
          nameApp ← `($nameApp $typeArg)
          counter := counter + 1
          typeArgs := typeArgs.push typeArg
        let mut quantifiedNameApp ← `(Inhabited $nameApp)
        for (stx, typeArg) in stxArr.zip typeArgs.reverse do
          quantifiedNameApp ← `(∀ $typeArg : $stx, $quantifiedNameApp)
        hyps := hyps.push (← `(explicitBinder| (_ : $quantifiedNameApp)))
    | `(TPTP_input| thf($name:ident,$role,$term:thf_term $annotation:annotation ?).) =>
      let term ← processThfTerm term false
      let name := (mkIdent $ name.getId.appendBefore "h")
      if role.getId == `conjecture then
        hyps := hyps.push (← `(explicitBinder| ($name : ¬ $term)))
      else
        hyps := hyps.push (← `(explicitBinder| ($name : $term)))
    | `(TPTP_input| thf($n:ident,type,$name:ident : $ty:thf_type $annotation:annotation ?).) =>
      let (ty, stxArrOpt) ← processThfType ty
      hyps := hyps.push (← `(explicitBinder| ($name : $ty)))
      match stxArrOpt with
      | none => continue
      | some stxArr =>
        let typeArgName := `typeArg
        let mut counter := 0
        let mut nameApp ← `($name)
        let mut typeArgs : Array Ident := #[]
        for _ in stxArr do
          let typeArg := mkIdent $ typeArgName.appendAfter (toString counter)
          nameApp ← `($nameApp $typeArg)
          counter := counter + 1
          typeArgs := typeArgs.push typeArg
        let mut quantifiedNameApp ← `(Inhabited $nameApp)
        for (stx, typeArg) in stxArr.zip typeArgs.reverse do
          quantifiedNameApp ← `(∀ $typeArg : $stx, $quantifiedNameApp)
        hyps := hyps.push (← `(explicitBinder| (_ : $quantifiedNameApp)))
    | `(TPTP_input| cnf($name:ident,$role,$term:thf_term $annotation:annotation ?).) =>
      let term ← processCnfTerm term
      let name := (mkIdent $ name.getId.appendBefore "h")
      if role.getId == `conjecture then
        hyps := hyps.push (← `(explicitBinder| ($name : ¬ $term)))
      else
        hyps := hyps.push (← `(explicitBinder| ($name : $term)))
    | `(TPTP_input| fof($name:ident,$role,$term:thf_term $annotation:annotation ?).) =>
      -- Although tff differs from fof, I think that processThfTerm will do what we want for fof terms
      let term ← processThfTerm term true
      let name := (mkIdent $ name.getId.appendBefore "h")
      if role.getId == `conjecture then
        hyps := hyps.push (← `(explicitBinder| ($name : ¬ $term)))
      else
        hyps := hyps.push (← `(explicitBinder| ($name : $term)))
    | _ => Macro.throwError s!"Unsupported TPTP_input: {input}"
  let hypall := mkNode ``many (nonVarSymbols.toArray.append hyps)
  let spec ← `(Term.typeSpec| : False)
  let sig := mkNode ``Command.declSig #[hypall,spec]
  `(theorem $name $sig := $proof)


import MLIR.Semantics.Fitree
import MLIR.Semantics.Semantics
import MLIR.Semantics.SSAEnv
import MLIR.Semantics.UB
import MLIR.Util.Metagen
import MLIR.AST
import MLIR.EDSL
import Mathlib.Data.List.Dedup
open MLIR.AST

/-
### Dialect: `scf`
-/

instance scf: Dialect Void Void (fun _x => Unit) where
  name := "scf"
  iα := inferInstance
  iε := inferInstance

-- Operations of `scf` that unfold into regions need to expose these regions
-- | run a loop, decrementing i from n to -
-- | ix := lo + (n - i) * step
def run_loop_bounded_stepped_go [Monad m] (n: Nat) (i: Nat) (lo: Int) (step: Int)
  (accum: a) (eff: Int -> a -> m a): m a := do
   let ix : Int := lo + (n - i) * step
   let accum <- eff ix accum
   match i with
   | .zero => return accum
   | .succ i' => run_loop_bounded_stepped_go n i' lo step accum eff

-- | TODO: make this model the `yield` as well.
def run_loop_bounded_stepped [Monad m] (n: Nat) (lo: Int) (step: Int) (accum: a) (eff: Int -> a -> m a): m a :=
  run_loop_bounded_stepped_go n n lo step accum eff

-- | TODO: make this model the `yield` as well.
def run_loop_bounded
  (n: Nat)
  (ix: Int)
  (start: TypedArgs Δ)
  (rgn: TypedArgs Δ → OpM Δ (TypedArgs Δ)): OpM Δ (TypedArgs Δ):= do
  match n with
  | 0 => return start
  | .succ n' => do
    let (_: TypedArgs Δ) <- rgn [⟨MLIRType.index, ix⟩]
    run_loop_bounded n' (ix + 1) ([]) rgn

-- | TODO: refactor to (1) an effect, (2) an interpretation
-- | TODO: use the return type of Scf.For. For now, just do unit.
def scf_semantics_op: IOp Δ → OpM Δ (TypedArgs Δ)
  | IOp.mk "scf.if" _ [⟨.i1, b⟩]  [rthen, relse] _ => do
      (if b = 1 then rthen else relse) []
  | IOp.mk "scf.for" _ [⟨.index, lo⟩, ⟨.index, hi⟩, ⟨.index, step⟩] [body] _ => do
    let nsteps : Int := (hi - lo) / step
    let _  ← run_loop_bounded_stepped
      (a := TypedArgs Δ)
      (n := nsteps.toNat)
      (lo := lo)
      (step := step)
      (accum := default)
      (eff := (fun i _ => body [⟨.index, i⟩]))
    return []
  | IOp.mk "scf.for'" _ [⟨.index, lo⟩, ⟨.index, hi⟩] [body] _ => do
      run_loop_bounded (n := (hi - lo).toNat) (ix := lo) [] body
  | IOp.mk "scf.yield" _ vs [] _ =>
      return vs
  | IOp.mk "scf.assert" _ [⟨.i1, arg⟩] [] attrs =>
    if arg  == 0 then
      let err := match attrs.find "msg" with -- TODO: convert this to a pattern match.
          | .some (.str str) => str
          | _ => ""
      OpM.Error s!"{err}: {arg} <assert failed>"
    else return [] -- success
  | IOp.mk "scf.execute_region" _ args  [rgn] _ => do
      rgn args
  | IOp.mk name .. => OpM.Unhandled ("scf unhandled: " ++ name)

instance: Semantics scf where
  semantics_op := scf_semantics_op

/-
### Theorems
-/

namespace SCF.IF
-- Proof that `scf.if` with a fixed condition simplifies to its "then" or
-- "else" region depending on the value

def LHS (r₁ r₂: Region scf): Region scf := [mlir_region|
{
  "scf.if" (%b) ($(r₁), $(r₂)) : (i1) -> ()
}]

def INPUT (b: Bool): SSAEnv scf :=
  SSAEnv.set "b" MLIRType.i1 (if b then 1 else 0) SSAEnv.empty

-- Pure unfolding-style proof
theorem equivalent (b: Bool):
    run ⟦LHS r₁ r₂⟧ (INPUT b) =
    run (TopM.scoped (denoteRegion
          (Δ := scf)
          (rgn := if b then r₁ else r₂)
          (args := []))) (INPUT b) := by
    simp[LHS];
    simp[run_denoteRegion];
    simp[run_bind_success];
    rw[run_seq];
    simp[run_denoteTypedArgs_nil];
    simp [run_denoteOps_singleton];
    simp[run_denoteOp];
    simp[run_bind];
    simp[run_denoteOp];
    simp[run_denoteOpArgs_cons_];
    simp[run_bind];
    simp[INPUT];
    rw[run_TopM_get_];
    simp[SSAEnv.get_set_eq];
    simp[run_denoteOpArgs_nil];
    simp[run_pure];
    simp[INPUT];
    simp[TopM.mapDenoteRegion]; -- TODO: make run version of this
    save
    simp[OpM.denoteRegions] -- TODO: make run version
    simp[Semantics.semantics_op]; -- TODO: make run version
    simp[scf_semantics_op]; -- SLOW
    save
    -- VERY SLOW
    cases b <;> simp;
    case false => {
      rw[OpM_toTopM_denoteRegion]; -- TODO: make run version
      simp[TopM.denoteRegionsByIx]; -- TODO: make run version
    }
    case true => {
      -- TODO, FIXME, BUG: lean does not unfold the definition in the
      -- 'true' branch, while it does on the 'false' branch.
      -- This seems to be a tactic bug, because even after
      -- 'sorry'ing, we still get an error.
      sorry
      /-
      rw[OpM_toTopM_denoteRegion];
      simp[TopM.denoteRegionsByIx];
      -/
    }
    -- | but having this sorry here fixes the 'case true' error,
    -- even though lean knows that this tactic in unreachable:
    --   'this tactic is never executed [linter.unreachableTactic]'
    sorry

end SCF.IF

namespace SCF.FOR_PEELING
def LHS (r: Region scf): Region scf := [mlir_region|
{
  "scf.for'" (%c0, %cn_plus_1) ($(r)) : (index, index) -> ()
}]
def RHS  (r: Region scf): Region scf := [mlir_region|
{
  "scf.execute_region" (%c0) ($(r)) : (index) -> ()
  "scf.for'" (%c1, %cn_plus_1) ($(r)) : (index, index) -> ()
}]
def INPUT (n: Nat): SSAEnv scf :=
  SSAEnv.set "cn" .index n
    (SSAEnv.set "cn_plus_1" .index (n + 1)
      (SSAEnv.set "c0" .index 0
        (SSAEnv.set "c1" .index 1 SSAEnv.empty)))
/-
SSAEnv.One [
  ⟨"cn", .index, n⟩,
  ⟨"cn_plus_1", .index, n + 1⟩,
  ⟨"c0", .index, 0⟩,
  ⟨"c1", .index, 1⟩]
-/

 -- The main requirement for this theorem is that `r` satisfies SSA invariants,
-- ie. values available before it runs are unchanged by its execution. Here we
-- assume something quite a bit stronger, to simplify the proof of the actual
-- property, which is that a read can commute with running the region.

theorem CORRECT_r (n:Nat) (r: Region scf) args:
    (run (denoteRegion scf r args) (INPUT n)) = .ok ([], INPUT n) := by
   sorry

/-
theorem CORRECT_r_commute_run_interpRegion_SSAEnvE_get [S: Semantics scf]
  (CORRECT_r: (run (denoteRegion scf r args) (INPUT n)) = .ok (.Ret [], INPUT n))
  (name: SSAVal) (τ: MLIRType scf) (v: MLIRType.eval τ)
  (ENV: SSAEnv.get name τ (INPUT n) = some v)
  (k: BlockResult scf → τ.eval → Fitree (SSAEnvE scf +' UBE) R):
  run (Fitree.bind
    (interpRegion scf [denoteRegion scf r] _ (Sum.inl <| RegionE.RunRegion 0 args))
    (fun discr =>
      Fitree.Vis (Sum.inl <| SSAEnvE.Get τ name) fun v => k discr v)) (INPUT n) =
  run (Fitree.Vis (Sum.inl <| SSAEnvE.Get τ name) fun v =>
    (Fitree.bind (interpRegion scf [denoteRegion scf r] _ (Sum.inl <| RegionE.RunRegion 0 args))
    (fun discr => k discr v))) (INPUT n) := by
  simp [run_bind, interpRegion, List.get!]
  simp [CORRECT_r]
  simp [run_SSAEnvE_get _ _ _ _ _ ENV]
  simp [run_bind, CORRECT_r]
-/
private theorem identity₁ (n: Nat):
    Int.toNat (Int.ofNat n + 1 - 0) = n + 1 := by
  sorry

set_option maxHeartbeats 999999999 in
-- Pretty slow due to simplifying scf_semantics_op
-- which contains a large match
theorem equivalent (n: Nat) (r: Region scf):
    (run ⟦LHS r⟧ (INPUT n)) =
    (run ⟦RHS r⟧ (INPUT n)) := by {
   simp[LHS, RHS];
   simp[run_denoteRegion];
   simp[run_bind];
   simp[run_denoteTypedArgs_nil];
   simp[run_denoteOps_singleton];
   simp[run_denoteOp];
   simp[run_bind];
   simp[INPUT];
   simp[run_denoteOpArgs_cons_];
   simp[run_bind];
   rw[run_TopM_get_];
   rw[SSAEnv.get_set_ne_val];
   rw[SSAEnv.get_set_ne_val];
   rw[SSAEnv.get_set_eq_val] <;> simp;
   simp[run_denoteOpArgs_cons_];
   simp[run_bind];
   rw[run_TopM_get_];
   rw[SSAEnv.get_set_ne_val];
   rw[SSAEnv.get_set_eq_val] <;> simp;
   simp[run_denoteOpArgs_nil];
   simp[run_pure];
   simp[TopM.mapDenoteRegion]; -- TODO: make a 'run' version of this.
   simp[Semantics.semantics_op, scf_semantics_op]; -- SLOW :(
   simp[OpM.denoteRegions];
   apply Eq.symm;
   simp[run_denoteOps_cons];
   simp[run_bind];
   simp[run_denoteOps_singleton];
   simp[run_denoteOp];
   simp[run_bind];
   simp[run_denoteOpArgs_cons_];
   simp[run_bind];
   rw[run_TopM_get_];
   rw[SSAEnv.get_set_ne_val];
   rw[SSAEnv.get_set_ne_val];
   rw[SSAEnv.get_set_eq_val];
   simp;
   simp[run_denoteOpArgs_nil];
   simp[run_pure];
   simp[TopM_mapDenoteRegion_cons];
   simp[TopM_mapDenoteRegion_nil];
   simp[Semantics.semantics_op, scf_semantics_op];
   simp[OpM_denoteRegions_cons];
   save
   -- tactic 'simp' failed, nested error:
   -- (deterministic) timeout at 'whnf', maximum number of heartbeats (200000)
   -- has been reached (use 'set_option maxHeartbeats <num>' to set the limit)
   simp[OpM_denoteRegions_nil];
   simp[run_OpM_toTopM_denoteRegion];
   simp[run_TopM_denoteRegionsByIx_cons];
   sorry
   sorry
   simp; simp; simp; simp;
}

  /-
  simp [LHS, RHS]
  simp [denoteTypedArgs, denoteOps, denoteOp]
  simp [denoteOpBase, Semantics.semantics_op, scf_semantics_op]; simp_itree
  -/
  /-
  -- simp [denoteRegions]
  rw [run_SSAEnvE_get "c0" .index 0]
  rw [run_SSAEnvE_get "cn_plus_1" .index (n+1)]
  rw [run_SSAEnvE_get "c0" .index 0]
  have h := CORRECT_r n r [⟨.index, 0⟩]
  rw [CORRECT_r_commute_run_interpRegion_SSAEnvE_get h "c1" .index 1]
  rw [run_SSAEnvE_get "c1" .index 1]
  rw [CORRECT_r_commute_run_interpRegion_SSAEnvE_get h "cn_plus_1" .index (n+1)]
  rw [run_SSAEnvE_get "cn_plus_1" .index (n+1)]
  rw [identity₁]
  simp [(by sorry: (Int.ofNat n + 1 - 1).toNat = n)]
  simp [peel_run_loop_bounded, Fitree.interp_bind]
  simp [(by sorry: (0:Int) + (1:Int) = (1:Int))]
  all_goals simp [INPUT, cast_eq]
  -/
end SCF.FOR_PEELING

namespace SCF.FOR_FUSION
def LHS (r: Region scf): Region scf := [mlir_region|
{
  "scf.for'" (%c0, %cn) ($(r)) : (index, index) -> ()
  "scf.for'" (%cn, %cn_plus_m) ($(r)) : (index, index) -> ()
}]
def RHS (r: Region scf): Region scf := [mlir_region|
{
  "scf.for'" (%c0, %cn_plus_m) ($(r)) : (index, index) -> ()
}]
def INPUT (n m: Nat): SSAEnv scf := SSAEnv.One [
  ⟨"cn", .index, n⟩,
  ⟨"cn_plus_m", .index, n + m⟩,
  ⟨"c0", .index, 0⟩]

/- theorem interp_region_of_run_loop_bounded
  (r: Region scf) (n: Nat)
  (rhs: Fitree (SSAEnvE scf +' Semantics.E scf +' UBE) (BlockResult scf)):
    Fitree.interp (interpRegion scf (denoteRegions scf [r]))
      (run_loop_bounded n 0 (BlockResult.Ret [])) = rhs := by {
    induction n;
    case zero => {
      simp [run_loop_bounded];
      sorry
    }
    case succ n' => {
      simp [run_loop_bounded];
      simp [Fitree.interp];
      sorry
    }
   } -/
/-
theorem equivalent (n m: Nat) (r: Region scf):
    (run ⟦LHS r⟧ (INPUT n m)) =
    (run ⟦RHS r⟧ (INPUT n m)) := by
  simp [LHS, RHS, INPUT]
  simp [denoteRegion, denoteOps, denoteOp, denoteOpBase]
  simp_itree
  simp [Semantics.semantics_op, scf_semantics_op]
  simp [run];
  simp [StateT.run];
  simp [Except.bind];
  simp [denoteTypedArgs];
  simp [pure];
  simp [StateT.pure];
  simp [pure];
  simp [Except.pure];
  simp [List.mapM, List.mapM.loop];
  simp [bind, StateT.bind, Except.bind, TopM.get];
  sorry
  -- At this point we need something similar to CORRECT_r_* above.
  -- simp [run_denoteOp_interp_region]
  -- all_goals simp [INPUT, cast_eq]
-/
end SCF.FOR_FUSION


import fo.basic
import tactic

open signature

def signature.substitution.domain {σ : signature} (ν : σ.substitution) :=
  subtype {v : σ.var | ν v ≠ (term.var v)}

@[simp]
def signature.substitution.is_ground {σ : signature} (ν : σ.substitution) :=
  ∀ v, (ν v).is_ground

def signature.ground_substitution (σ : signature) : Type :=
  subtype {ν : σ.substitution | ν.is_ground}

def signature.variable_renaming (σ : signature) (r : σ.var → σ.var) (h : function.bijective r) : σ.substitution :=
  (λ v, term.var (r v))

def signature.substitution.free {σ : signature} : σ.substitution → σ.var → σ.substitution :=
  (λ ν v v',
      if (v = v') then
        term.var v
      else
        (ν v)
  )

@[reducible]
def signature.term.substitute {σ : signature} : σ.term → σ.substitution → σ.term
  | (term.var v) ν := (ν v)
  | (term.func f ts) ν := term.func f (λ i, (ts i).substitute ν)

@[reducible]
instance signature.subst_term {σ : signature} : σ.substitutable σ.term :=
  {substitute := signature.term.substitute}

@[reducible]
def signature.substitution.substitute {σ : signature} (ρ ν : σ.substitution) : σ.substitution :=
  (λ v : σ.var, (ρ v) ↓ ν)

@[reducible]
instance signature.subst_substitution {σ : signature} : σ.substitutable σ.substitution :=
  {
    substitute := signature.substitution.substitute
  }

@[reducible]
def signature.var.occurrs {σ : signature} : σ.var → σ.term → Prop
  | v (term.var v') := v = v'
  | v (term.func f ts) := ∃ i, v.occurrs (ts i)

def signature.var.is_bound {σ : signature} (v : σ.var) (φ : σ.formula) : Prop :=
  ¬φ.is_free v

@[simp]
def signature.formula.substitute {σ : signature} : σ.formula → σ.substitution → σ.formula
  | (formula.neg φ) ν := φ.substitute ν
  | (formula.conj hn Φ) ν := formula.conj hn (λ i, (Φ i).substitute ν)
  | (formula.disj hn Φ) ν := formula.disj hn (λ i, (Φ i).substitute ν)
  | (formula.fall x φ) ν := formula.fall x (φ.substitute (ν.free x))
  | (formula.xist x φ) ν := formula.xist x (φ.substitute (ν.free x))
  | (formula.rel r ts) ν := formula.rel r (λ i, (ts i).substitute ν)
  | φ ν := φ

@[reducible]
instance signature.sub_formula {σ : signature} : σ.substitutable σ.formula :=
  {
    substitute := signature.formula.substitute
  }

def signature.term.contains {σ : signature} : σ.term → σ.var → Prop
  | (term.var v') v := v' = v
  | (term.func f ts) v := ∃ i, (ts i).contains v

@[reducible]
def signature.formula.contains {σ : signature} : σ.formula → σ.var → Prop
  | (formula.neg φ) v := φ.contains v
  | (formula.conj hn Φ) v := ∃ i, (Φ i).contains v
  | (formula.disj hn Φ) v := ∃ i, (Φ i).contains v
  | (formula.fall x φ) v := φ.contains v
  | (formula.xist x φ) v := φ.contains v
  | (formula.rel r ts) v := (∃ i, v.occurrs (ts i))
  | φ v := false

@[reducible]
def signature.substitution.is_free {σ : signature} : σ.substitution → σ.formula → Prop
  | ν (formula.neg φ) := ν.is_free φ
  | ν (formula.conj hn Φ) := ∀ i, ν.is_free (Φ i)
  | ν (formula.disj hn Φ) := ∀ i, ν.is_free (Φ i)
  | ν (formula.fall x φ) := (∀ v : σ.var, (φ.contains v → φ.is_free v → ¬(ν v).contains x)) ∧ ν.is_free φ
  | ν (formula.xist x φ) := (∀ v : σ.var, (φ.contains v → φ.is_free v → ¬(ν v).contains x)) ∧ ν.is_free φ
  | ν φ := true

@[reducible]
def signature.substitution.is_free1 {σ : signature} (ν : σ.substitution) (φ : σ.formula) : Prop :=
  ∀ (v : σ.var), (φ.is_free v) → ∀ (v' : σ.var), v'.occurrs (ν v) → φ.is_free v'

def signature.substitution.compose {σ : signature} (ν₁ : σ.substitution) (ν₂ : σ.substitution) : σ.substitution :=
  (λ v, (ν₁ v).substitute ν₂)

def signature.substitution.id {σ : signature} : σ.substitution :=
  (λ v, term.var v)

def signature.id_subst (σ : signature) : σ.substitution :=
  (λ v : σ.var, term.var v)

def subid {σ : signature} : σ.substitution :=
  (λ v : σ.var, term.var v)

lemma signature.term.term_eq_term_subst_id {σ : signature} : ∀ t : σ.term, t ↓ σ.id_subst = t :=
  begin
    intro t,
    induction t with v f ts,
    simp,
    refl,
    simp [signature.term.substitute],
    dsimp at t_ih,
    ext i,
    exact (t_ih i),
  end

def signature.term.more_general {σ : signature} (t₁ t₂ : σ.term) : Prop :=
  ∃ (ν : σ.substitution), t₁ ↓ ν = t₂

section more_general_preorder

  variable σ : signature
  variable t : σ.term
  variable ν₁ : σ.substitution
  variable ν₂ : σ.substitution

  lemma signature.compose_sub : ((t ↓ ν₁) ↓ ν₂) = t ↓ (ν₁ ↓ ν₂) :=
    begin
      induction t with v f ts ih,
      simp,
      dsimp at ih,
      simp [signature.term.substitute],
      ext i,
      exact ih i,
    end

  lemma refl_more_general : (reflexive (@signature.term.more_general σ)) :=
    begin
      intro t,
      existsi signature.substitution.id,
      exact signature.term.term_eq_term_subst_id t,
    end

  lemma trans_more_general : (transitive (@signature.term.more_general σ)) :=
    begin
      intros x y z hxy hyz,
      cases hxy with νx hνx,
      cases hyz with νy hνy,
      rw [← hνy, ← hνx],
      use (νx ↓ νy),
      rw signature.compose_sub,
    end

end more_general_preorder

section

  variable σ : signature
  variable t : σ.term
  variable φ : σ.formula
  variable ν₁ : σ.substitution
  variable ν₂ : σ.substitution

  lemma signature.compose_free (h : ν₁.is_free φ) : ∀ v, (φ ↓ (ν₁.free v ↓ ν₂.free v)) = (φ ↓ (ν₁ ↓ ν₂).free v) :=
    begin
      sorry,
    end

  lemma signature.sub_free_eq_imp_sub_eq (h : ν₁.is_free φ) : ∀ v, (φ ↓ ν₁) ↓ ν₂ = φ ↓ (ν₁ ↓ ν₂) → (φ ↓ ν₁.free v ↓ ν₂.free v) = (φ ↓ (ν₁.free v ↓ ν₂.free v)) :=
    begin
      intro v,
      intro h',
      induction φ,
      simp,
      simp,
      simp,
      {
        exact (φ_ih h) h',
      },
      {
        simp [signature.formula.substitute],
        ext j,
        simp [signature.substitution.is_free] at h,
        simp at h',
        dsimp at φ_ih,
        exact φ_ih i (h j) (h' j),
      }
      sorry,
      sorry,
      sorry,
      sorry,
      sorry,
      sorry,
    end

  theorem signature.compose_sub_formula1 (h : ν₁.is_free φ) : (φ ↓ ν₁) ↓ ν₂ = φ ↓ (ν₁ ↓ ν₂) :=
    begin
      induction φ,
      refl,refl,
      {
        simp [signature.formula.substitute],
        exact φ_ih h,
      },
      {
        simp [signature.formula.substitute],
        ext i,
        dsimp at *,
        have h' := φ_ih i,
        simp [signature.substitution.is_free] at h,
        exact h' (h i),
      },
      {
        simp [signature.formula.substitute],
        ext i,
        dsimp at *,
        have h' := φ_ih i,
        simp [signature.substitution.is_free] at h,
        exact h' (h i),
      },
      {
        simp [signature.formula.substitute],
        simp [signature.substitution.is_free] at h,
        have h' := signature.compose_free σ φ_f ν₁ ν₂ (h.right) φ_v,
        simp [signature.formula.substitute] at h',
        rw ← h',
        apply signature.sub_free_eq_imp_sub_eq,
        exact h.right,
        exact φ_ih h.right,
      },
      {
        simp [signature.formula.substitute],
        simp [signature.substitution.is_free] at h,
        have h' := signature.compose_free σ φ_f ν₁ ν₂ (h.right) φ_v,
        simp [signature.formula.substitute] at h',
        rw ← h',
        apply signature.sub_free_eq_imp_sub_eq,
        exact h.right,
        exact φ_ih h.right,
      },
      {
        simp [signature.formula.substitute],
        ext i,
        exact signature.compose_sub σ (φ_ts i) _ _,
      },
    end

end

def signature.term.equivalent {σ : signature} (t₁ t₂ : σ.term) : Prop :=
  t₁.more_general t₂ ∧ t₂.more_general t₁

lemma signature.term.refl_equivalent {σ : signature} : reflexive (@signature.term.equivalent σ) :=
  begin
    intro t,
    use σ.id_subst,
    rw signature.term.term_eq_term_subst_id,
    use σ.id_subst,
    rw signature.term.term_eq_term_subst_id,
  end

lemma signature.term.trans_equivalent {σ : signature} : transitive (@signature.term.equivalent σ) :=
  begin
    intros x y z hxy hyz,
    split,
    {
      cases hxy.left with νxy h₁,
      cases hyz.left with νyz h₂,
      use (νxy ↓ νyz),
      rw ← signature.compose_sub,
      rw [h₁, h₂],
    },
    {
      cases hxy.right with νxy h₁,
      cases hyz.right with νyz h₂,
      use (νyz ↓ νxy),
      rw ← signature.compose_sub,
      rw [h₂, h₁],
    }
  end

lemma signature.term.symm_equivalent {σ : signature} : symmetric (@signature.term.equivalent σ) :=
  begin
    intros x y hxy,
    split,
    exact hxy.right,
    exact hxy.left,
  end

lemma signature.term.equiv_equivalent {σ : signature} : equivalence (@signature.term.equivalent σ) :=
  begin
    split,
    exact signature.term.refl_equivalent,
    split,
    exact signature.term.symm_equivalent,
    exact signature.term.trans_equivalent,
  end

instance signature.equiv_setoid (σ : signature) : setoid σ.term :=
  {
    r := signature.term.equivalent,
    iseqv := signature.term.equiv_equivalent,
  }

@[reducible]
def signature.term_equiv (σ : signature) := quotient σ.equiv_setoid

example (σ : signature) (t : σ.term) : ⟦t⟧ = quotient.mk t :=
  begin
    refl,
  end

lemma signature.term.substitution_is_well_defined {σ : signature} (ν : σ.substitution) (t₁ t₂ : σ.term)  (h : t₁ ≈ t₂) : ⟦t₁ ↓ ν⟧ = ⟦t₂ ↓ ν⟧ :=
  begin
    apply quotient.sound,
    cases h,
    split,
    cases h_left with ν_left hν_left,
    cases h_right with ν_right hν_right,
    sorry, sorry,
  end

def signature.term_equiv.substitute {σ : signature} (ν : σ.substitution) : σ.term_equiv → σ.term_equiv :=
  quotient.lift (λ (t : σ.term) , ⟦t ↓ ν⟧) (signature.term.substitution_is_well_defined ν)

@[reducible]
instance signature.subst_term_equiv (σ : signature) : σ.substitutable σ.term_equiv :=
  {
    substitute := (λ t ν, signature.term_equiv.substitute ν t)
  }


inductive AltCore (α : Type)
  | default (val : α)
  | alt (name : String) (val : α)

inductive Code where
  | cases (alt: AltCore Code)
  | return (id : Nat)

abbrev Alt := AltCore Code

def AltCore.getCode : Alt → Code
  | .default c => c
  | .alt _ c => c

def AltCore.update (alt : Alt) (c : Code) : Alt :=
  match alt with
  | .default _ => if true then alt else .default c
  | .alt n _ => if true then alt else .alt n c

example (alt : Alt) : Code :=
  alt.getCode

def Alt.getCode' : Alt → Code
  | .default c => c
  | .alt _ c => c

example (alt : Alt) : Code :=
  if true then .return 1 else alt.getCode'

example (alt : Alt) : Code :=
  if true then alt.getCode' else .return 0


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Adam Topaz
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.data.fin
import Mathlib.category_theory.concrete_category.bundled
import Mathlib.category_theory.concrete_category.default
import Mathlib.category_theory.full_subcategory
import Mathlib.category_theory.skeletal
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# The category of finite types.

We define the category of finite types, denoted `Fintype` as
(bundled) types with a `fintype` instance.

We also define `Fintype.skeleton`, the standard skeleton of `Fintype` whose objects are `fin n`
for `n : ℕ`. We prove that the obvious inclusion functor `Fintype.skeleton ⥤ Fintype` is an
equivalence of categories in `Fintype.skeleton.equivalence`.
We prove that `Fintype.skeleton` is a skeleton of `Fintype` in `Fintype.is_skeleton`.
-/

/-- The category of finite types. -/
def Fintype := category_theory.bundled fintype

namespace Fintype

/-- Construct a bundled `Fintype` from the underlying type and typeclass. -/
def of (X : Type u_1) [fintype X] : Fintype := category_theory.bundled.of X

protected instance inhabited : Inhabited Fintype := { default := category_theory.bundled.mk pempty }

protected instance fintype {X : Fintype} : fintype ↥X := category_theory.bundled.str X

protected instance category_theory.category : category_theory.category Fintype :=
  category_theory.induced_category.category category_theory.bundled.α

/-- The fully faithful embedding of `Fintype` into the category of types. -/
@[simp] theorem incl_map (x : category_theory.induced_category (Type u_1) category_theory.bundled.α)
    (y : category_theory.induced_category (Type u_1) category_theory.bundled.α) (f : x ⟶ y) :
    ∀ (ᾰ : category_theory.bundled.α x), category_theory.functor.map incl f ᾰ = f ᾰ :=
  fun (ᾰ : category_theory.bundled.α x) => Eq.refl (f ᾰ)

protected instance category_theory.concrete_category : category_theory.concrete_category Fintype :=
  category_theory.concrete_category.mk incl

/--
The "standard" skeleton for `Fintype`. This is the full subcategory of `Fintype` spanned by objects
of the form `fin n` for `n : ℕ`. We parameterize the objects of `Fintype.skeleton` directly as `ℕ`,
as the type `fin m ≃ fin n` is nonempty if and only if `n = m`.
-/
def skeleton := ℕ

namespace skeleton

/-- Given any natural number `n`, this creates the associated object of `Fintype.skeleton`. -/
def mk : ℕ → skeleton := id

protected instance inhabited : Inhabited skeleton := { default := mk 0 }

/-- Given any object of `Fintype.skeleton`, this returns the associated natural number. -/
def to_nat : skeleton → ℕ := id

protected instance category_theory.category : category_theory.category skeleton :=
  category_theory.category.mk

theorem is_skeletal : category_theory.skeletal skeleton := sorry

/-- The canonical fully faithful embedding of `Fintype.skeleton` into `Fintype`. -/
def incl : skeleton ⥤ Fintype :=
  category_theory.functor.mk (fun (X : skeleton) => of (fin X))
    fun (_x _x_1 : skeleton) (f : _x ⟶ _x_1) => f

protected instance incl.category_theory.full : category_theory.full incl :=
  category_theory.full.mk
    fun (_x _x_1 : skeleton)
      (f : category_theory.functor.obj incl _x ⟶ category_theory.functor.obj incl _x_1) => f

protected instance incl.category_theory.faithful : category_theory.faithful incl :=
  category_theory.faithful.mk

protected instance incl.category_theory.ess_surj : category_theory.ess_surj incl :=
  category_theory.ess_surj.mk
    fun (X : Fintype) =>
      let F : ↥X ≃ fin (fintype.card ↥X) := trunc.out (fintype.equiv_fin ↥X);
      Exists.intro (fintype.card ↥X) (Nonempty.intro (category_theory.iso.mk ⇑(equiv.symm F) ⇑F))

protected instance incl.category_theory.is_equivalence : category_theory.is_equivalence incl :=
  category_theory.equivalence.equivalence_of_fully_faithfully_ess_surj incl

/-- The equivalence between `Fintype.skeleton` and `Fintype`. -/
def equivalence : skeleton ≌ Fintype := category_theory.functor.as_equivalence incl

@[simp] theorem incl_mk_nat_card (n : ℕ) :
    fintype.card ↥(category_theory.functor.obj incl (mk n)) = n :=
  finset.card_fin n

end skeleton

/-- `Fintype.skeleton` is a skeleton of `Fintype`. -/
def is_skeleton : category_theory.is_skeleton_of Fintype skeleton skeleton.incl :=
  category_theory.is_skeleton_of.mk skeleton.is_skeletal
    skeleton.incl.category_theory.is_equivalence

end Mathlib