/-
Copyright (c) 2014 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Theorems about functions with multiple arguments
-/
import .init

universes u v w
hott_theory

namespace hott

variables {A : Type _} {U : Type _} {V : Type _} {W : Type _}
          {X : Type _} {Y : Type _} {Z : Type _}
          {B : A → Type _} {C : Πa, B a → Type _} {D : Πa b, C a b → Type _}
          {E : Πa b c, D a b c → Type _} {F : Πa b c d, E a b c d → Type _}
          {G : Πa b c d e, F a b c d e → Type _} {H : Πa b c d e f, G a b c d e f → Type _}
variables {a a' : A} {u u' : U} {v v' : V} {w w' : W} {x x' x'' : X} {y y' : Y} {z z' : Z}
          {b : B a} {b' : B a'}
          {c : C a b} {c' : C a' b'}
          {d : D a b c} {d' : D a' b' c'}
          {e : E a b c d} {e' : E a' b' c' d'}
         {ff : F a b c d e} {f' : F a' b' c' d' e'}
          {g : G a b c d e ff} {g' : G a' b' c' d' e' f'}
          {h : H a b c d e ff g} {h' : H a' b' c' d' e' f' g'}

namespace eq
  /-
    Naming convention:
      The theorem which states how to construct an path between two function applications is
        api₀i₁...iₙ.
      Here i₀, ... iₙ are digits, n is the arity of the function(s),
        and iⱼ specifies the dimension of the path between the jᵗʰ argument
        (i₀ specifies the dimension of the path between the functions).
      A value iⱼ ≡ 0 means that the jᵗʰ arguments are definitionaly equal
      The functions are non-dependent, except when the theorem name contains trailing zeroes
        (where the function is dependent only in the arguments where it doesn't result in any
         transports in the theorem statement).
      For the fully-dependent versions (except that the conclusion doesn't contain a transport)
      we write
        apdi₀i₁...iₙ.

      For versions where only some arguments depend on some other arguments,
      or for versions with transport in the conclusion (like apdt), we don't have a
      consistent naming scheme (yet).

      We don't prove each theorem systematically, but prove only the ones which we actually need.
  -/

  @[hott, reducible] def homotopy2 (f g : Πa b, C a b)         : Type _ :=
  Πa b, f a b = g a b
  @[hott, reducible] def homotopy3 (f g : Πa b c, D a b c)     : Type _ :=
  Πa b c, f a b c = g a b c
  @[hott, reducible] def homotopy4 (f g : Πa b c d, E a b c d) : Type _ :=
  Πa b c d, f a b c d = g a b c d

  infix ` ~2 `:50 := homotopy2
  infix ` ~3 `:50 := homotopy3
  infix ` ~4 `:50 := homotopy4

  @[refl] def homotopy2.refl (f : Π a b, C a b) : f ~2 f := by intros _ _; refl
  @[refl] def homotopy3.refl (f : Π a b c, D a b c) : f ~3 f := by intros _ _ _; refl
  @[refl] def homotopy4.refl (f : Π a b c d, E a b c d) : f ~4 f := by intros _ _ _ _; refl

  @[hott] def ap0111 (f : U → V → W → X) (Hu : u = u') (Hv : v = v') (Hw : w = w')
      : f u v w = f u' v' w' :=
  by induction Hu; hsimp *

  @[hott] def ap01111 (f : U → V → W → X → Y)
    (Hu : u = u') (Hv : v = v') (Hw : w = w') (Hx : x = x')
      : f u v w x = f u' v' w' x' :=
  by induction Hu; hsimp *

  @[hott] def ap011111 (f : U → V → W → X → Y → Z)
    (Hu : u = u') (Hv : v = v') (Hw : w = w') (Hx : x = x') (Hy : y = y')
      : f u v w x y = f u' v' w' x' y' :=
  by induction Hu; hsimp *

  @[hott] def ap0111111 (f : U → V → W → X → Y → Z → A)
    (Hu : u = u') (Hv : v = v') (Hw : w = w') (Hx : x = x') (Hy : y = y') (Hz : z = z')
      : f u v w x y z = f u' v' w' x' y' z' :=
  by induction Hu; hsimp *

  @[hott, elab_simple] def ap010 (f : X → Πa, B a) (Hx : x = x') : f x ~ f x' :=
  λ b, ap (λa, f a b) Hx

  @[hott] def ap0100 (f : X → Πa b, C a b) (Hx : x = x') : f x ~2 f x' :=
  by intros; induction Hx; reflexivity

  @[hott] def ap01000 (f : X → Πa b c, D a b c) (Hx : x = x') : f x ~3 f x' :=
  by intros; induction Hx; reflexivity

  @[hott] def apdt011 (f : Πa, B a → Z) (Ha : a = a') (Hb : transport B Ha b = b')
      : f a b = f a' b' :=
  by induction Ha; induction Hb; reflexivity

  @[hott] def apdt0111 (f : Πa b, C a b → Z) (Ha : a = a') (Hb : transport B Ha b = b')
    (Hc : cast (apdt011 C Ha Hb) c = c')
      : f a b c = f a' b' c' :=
  by induction Ha; induction Hb; induction Hc; reflexivity

  @[hott] def apd011' {R : X → Y → Type _} {r : R x y} {r' : R x' y'} (f : Πx y, R x y → Z)
    (p : x = x') (q : y = y') (s : transport11 R p q r = r') : f x y r = f x' y' r' :=
  by induction p; induction q; induction s; refl

  @[hott] def apdt01111 (f : Πa b c, D a b c → Z) (Ha : a = a') (Hb : transport B Ha b = b')
    (Hc : cast (apdt011 C Ha Hb) c = c') (Hd : cast (apdt0111 D Ha Hb Hc) d = d')
      : f a b c d = f a' b' c' d' :=
  by induction Ha; induction Hb; induction Hc; induction Hd; reflexivity

  @[hott] def apdt011111 (f : Πa b c d, E a b c d → Z) (Ha : a = a') (Hb : transport B Ha b = b')
    (Hc : cast (apdt011 C Ha Hb) c = c') (Hd : cast (apdt0111 D Ha Hb Hc) d = d')
    (He : cast (apdt01111 E Ha Hb Hc Hd) e = e')
    : f a b c d e = f a' b' c' d' e' :=
  by induction Ha; induction Hb; induction Hc; induction Hd; induction He; reflexivity

  @[hott] def apdt0111111 (f : Πa b c d e, F a b c d e → Z) (Ha : a = a') (Hb : transport B Ha b = b')
    (Hc : cast (apdt011 C Ha Hb) c = c') (Hd : cast (apdt0111 D Ha Hb Hc) d = d')
    (He : cast (apdt01111 E Ha Hb Hc Hd) e = e') (Hf : cast (apdt011111 F Ha Hb Hc Hd He) ff = f')
    : f a b c d e ff = f a' b' c' d' e' f' :=
  begin induction Ha, induction Hb, induction Hc, induction Hd, induction He, induction Hf, reflexivity end

  -- @[hott] def apd0111111 (f : Πa b c d e ff, G a b c d e ff → Z) (Ha : a = a') (Hb : transport B Ha b = b')
  --   (Hc : cast (apd011 C Ha Hb) c = c') (Hd : cast (apd0111 D Ha Hb Hc) d = d')
  --   (He : cast (apd01111 E Ha Hb Hc Hd) e = e') (Hf : cast (apd011111 F Ha Hb Hc Hd He) ff = f')
  --   (Hg : cast (apd0111111 G Ha Hb Hc Hd He Hf) g = g')
  --   : f a b c d e ff g = f a' b' c' d' e' f' g' :=
  -- by induction Ha; induction Hb; induction Hc; induction Hd; induction He; induction Hf; induction Hg; reflexivity

  -- @[hott] def apd01111111 (f : Πa b c d e ff g, G a b c d e ff g → Z) (Ha : a = a') (Hb : transport B Ha b = b')
  --   (Hc : cast (apd011 C Ha Hb) c = c') (Hd : cast (apd0111 D Ha Hb Hc) d = d')
  --   (He : cast (apd01111 E Ha Hb Hc Hd) e = e') (Hf : cast (apd011111 F Ha Hb Hc Hd He) ff = f')
  --   (Hg : cast (apd0111111 G Ha Hb Hc Hd He Hf) g = g') (Hh : cast (apd01111111 H Ha Hb Hc Hd He Hf Hg) h = h')
  --   : f a b c d e ff g h = f a' b' c' d' e' f' g' h' :=
  -- by induction Ha; induction Hb; induction Hc; induction Hd; induction He; induction Hf; induction Hg; induction Hh; reflexivity

  @[hott] def apd100 {f g : Πa b, C a b} (p : f = g) : f ~2 g :=
  λa b, apd10 (apd10 p a) b

  @[hott] def apd1000 {f g : Πa b c, D a b c} (p : f = g) : f ~3 g :=
  λa b c, apd100 (apd10 p a) b c

  /- some properties of these variants of ap -/

  -- we only prove what we currently need

  @[hott] def ap010_con (f : X → Πa, B a) (p : x = x') (q : x' = x'') :
    ap010 f (p ⬝ q) a = ap010 f p a ⬝ ap010 f q a :=
  eq.rec_on q (eq.rec_on p idp)

  @[hott] def ap010_ap (f : X → Πa, B a) (g : Y → X) (p : y = y') :
    ap010 f (ap g p) a = (ap010 (f ∘ g) p) a :=
  eq.rec_on p idp

  @[hott] def ap_eq_ap010 {A B C : Type _} (f : A → B → C) {a a' : A} (p : a = a') (b : B) :
    ap (λa, f a b) p = ap010 f p b :=
  idp

  @[hott] def ap011_idp {A B C : Type _} (f : A → B → C) {a a' : A} (p : a = a') (b : B) :
    ap011 f p idp = ap010 f p b :=
  by reflexivity

  @[hott] def ap011_flip {A B C : Type _} (f : A → B → C) {a a' : A} {b b' : B} (p : a = a') (q : b = b') :
    ap011 f p q = (ap011 (λb a, f a b) q) p :=
  by induction q; induction p; reflexivity

  /- the following theorems are function extentionality for functions with multiple arguments -/

  @[hott] def eq_of_homotopy2 {f g : Πa b, C a b} (H : f ~2 g) : f = g :=
  eq_of_homotopy (λa, eq_of_homotopy (H a))

  @[hott] def eq_of_homotopy3 {f g : Πa b c, D a b c} (H : f ~3 g) : f = g :=
  eq_of_homotopy (λa, eq_of_homotopy2 (H a))

  @[hott] def eq_of_homotopy2_id (f : Πa b, C a b)
    : eq_of_homotopy2 (λa b, idpath (f a b)) = idpath f :=
  begin
    transitivity eq_of_homotopy (λ a, idpath (f a)),
      {apply (ap eq_of_homotopy), apply eq_of_homotopy, intro, apply eq_of_homotopy_idp},
      apply eq_of_homotopy_idp
  end

  @[hott] def eq_of_homotopy3_id (f : Πa b c, D a b c)
    : eq_of_homotopy3 (λa b c, idpath (f a b c)) = idpath f :=
  begin
    transitivity _,
      {apply (ap eq_of_homotopy), apply eq_of_homotopy, intro, apply eq_of_homotopy2_id},
      apply eq_of_homotopy_idp
  end

  @[hott] def eq_of_homotopy2_inv {f g : Πa b, C a b} (H : f ~2 g)
    : eq_of_homotopy2 (λa b, (H a b).inverse) = (eq_of_homotopy2 H)⁻¹ :=
  begin
    transitivity,
    {dsimp [eq_of_homotopy2], apply ap, apply eq_of_homotopy, intro, apply eq_of_homotopy_inv},
    {apply eq_of_homotopy_inv}
  end

  @[hott] def eq_of_homotopy3_inv {f g : Πa b c, D a b c} (H : f ~3 g)
    : eq_of_homotopy3 (λa b c, (H a b c).inverse) = (eq_of_homotopy3 H)⁻¹ :=
  begin
    transitivity,
    {dsimp [eq_of_homotopy3], apply ap, apply eq_of_homotopy, intro, apply eq_of_homotopy2_inv},
    {apply eq_of_homotopy_inv}
  end

  @[hott] def eq_of_homotopy2_con {f g h : Πa b, C a b} (H1 : f ~2 g) (H2 : g ~2 h)
    : eq_of_homotopy2 (λa b, H1 a b ⬝ H2 a b) = eq_of_homotopy2 H1 ⬝ eq_of_homotopy2 H2 :=
  begin
    transitivity,
    {dsimp [eq_of_homotopy2], apply ap, apply eq_of_homotopy, intro, apply eq_of_homotopy_con},
    {apply eq_of_homotopy_con}
  end

  @[hott] def eq_of_homotopy3_con {f g h : Πa b c, D a b c} (H1 : f ~3 g) (H2 : g ~3 h)
    : eq_of_homotopy3 (λa b c, H1 a b c ⬝ H2 a b c) = eq_of_homotopy3 H1 ⬝ eq_of_homotopy3 H2 :=
  begin
    transitivity,
    {dsimp [eq_of_homotopy3], apply ap, apply eq_of_homotopy, intro, apply eq_of_homotopy2_con},
    {apply eq_of_homotopy_con}
  end

end eq

open hott.eq hott.equiv hott.is_equiv
namespace funext
  @[hott, instance] def is_equiv_apd100 (f g : Πa b, C a b)
    : is_equiv (@apd100 A B C f g) :=
  adjointify _
             eq_of_homotopy2
             begin
               intro H, dsimp [apd100, eq_of_homotopy2],
               apply eq_of_homotopy, intro a,
               apply concat, apply (ap (λx : Π a, f a = g a, apd10 (x a))), apply (right_inv apd10),
               apply (right_inv apd10)
             end
             begin
               intro p, induction p, apply eq_of_homotopy2_id
             end

  @[hott, instance] def is_equiv_apd1000 (f g : Πa b c, D a b c)
    : is_equiv (@apd1000 A B C D f g) :=
  adjointify _
             eq_of_homotopy3
             begin
               intro H, dsimp,
               apply eq_of_homotopy, intro a,
               transitivity apd100 (eq_of_homotopy2 (H a)),
                 {apply ap (λ x : Π a, f a = g a, apd100 (x a)),
                  apply right_inv apd10},
                 apply right_inv apd100
             end
             begin
               intro p, induction p, apply eq_of_homotopy3_id
             end
end funext

namespace eq
  open funext
  local attribute [instance] funext.is_equiv_apd100
  @[hott] protected def homotopy2.rec_on {f g : Πa b, C a b} {P : (f ~2 g) → Type _}
    (p : f ~2 g) (H : Π(q : f = g), P (apd100 q)) : P p :=
  right_inv apd100 p ▸ H (eq_of_homotopy2 p)

  @[hott] protected def homotopy3.rec_on {f g : Πa b c, D a b c} {P : (f ~3 g) → Type _}
    (p : f ~3 g) (H : Π(q : f = g), P (apd1000 q)) : P p :=
  right_inv apd1000 p ▸ H (eq_of_homotopy3 p)

  @[hott] def eq_equiv_homotopy2 (f g : Πa b, C a b) : (f = g) ≃ (f ~2 g) :=
  equiv.mk apd100 (by apply_instance)

  @[hott] def eq_equiv_homotopy3 (f g : Πa b c, D a b c) : (f = g) ≃ (f ~3 g) :=
  equiv.mk apd1000 (by apply_instance)

  @[hott] def apd10_ap (f : X → Πa, B a) (p : x = x')
    : apd10 (ap f p) = ap010 f p :=
  eq.rec_on p idp

  @[hott] def eq_of_homotopy_ap010 (f : X → Πa, B a) (p : x = x')
    : eq_of_homotopy (ap010 f p) = ap f p :=
  inv_eq_of_eq (apd10_ap _ _)⁻¹

  @[hott] def ap_eq_ap_of_homotopy {f : X → Πa, B a} {p q : x = x'} (H : ap010 f p ~ ap010 f q)
    : ap f p = ap f q :=
  calc
    ap f p = eq_of_homotopy (ap010 f p) : by symmetry; apply eq_of_homotopy_ap010
       ... = eq_of_homotopy (ap010 f q) : by apply ap; apply eq_of_homotopy H
       ... = ap f q                     : by apply eq_of_homotopy_ap010

end eq

end hott


/-
Copyright (c) 2022 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import model_theory.substructures

/-!
# Finitely Generated First-Order Structures
This file defines what it means for a first-order (sub)structure to be finitely or countably
generated, similarly to other finitely-generated objects in the algebra library.

## Main Definitions
* `first_order.language.substructure.fg` indicates that a substructure is finitely generated.
* `first_order.language.Structure.fg` indicates that a structure is finitely generated.
* `first_order.language.substructure.cg` indicates that a substructure is countably generated.
* `first_order.language.Structure.cg` indicates that a structure is countably generated.

## TODO
Develop a more unified definition of finite generation using the theory of closure operators, or use
this definition of finite generation to define the others.

-/

open_locale first_order
open set

namespace first_order
namespace language
open Structure

variables {L : language} {M : Type*} [L.Structure M]

namespace substructure

/-- A substructure of `M` is finitely generated if it is the closure of a finite subset of `M`. -/
def fg (N : L.substructure M) : Prop := ∃ S : finset M, closure L ↑S = N

theorem fg_def {N : L.substructure M} :
  N.fg ↔ ∃ S : set M, S.finite ∧ closure L S = N :=
⟨λ ⟨t, h⟩, ⟨_, finset.finite_to_set t, h⟩, begin
  rintro ⟨t', h, rfl⟩,
  rcases finite.exists_finset_coe h with ⟨t, rfl⟩,
  exact ⟨t, rfl⟩
end⟩

lemma fg_iff_exists_fin_generating_family {N : L.substructure M} :
  N.fg ↔ ∃ (n : ℕ) (s : fin n → M), closure L (range s) = N :=
begin
  rw fg_def,
  split,
  { rintros ⟨S, Sfin, hS⟩,
    obtain ⟨n, f, rfl⟩ := Sfin.fin_embedding,
    exact ⟨n, f, hS⟩, },
  { rintros ⟨n, s, hs⟩,
    refine ⟨range s, finite_range s, hs⟩ },
end

theorem fg_bot : (⊥ : L.substructure M).fg :=
⟨∅, by rw [finset.coe_empty, closure_empty]⟩

theorem fg_closure {s : set M} (hs : s.finite) : fg (closure L s) :=
⟨hs.to_finset, by rw [hs.coe_to_finset]⟩

theorem fg_closure_singleton (x : M) : fg (closure L ({x} : set M)) :=
fg_closure (finite_singleton x)

theorem fg.sup {N₁ N₂ : L.substructure M}
  (hN₁ : N₁.fg) (hN₂ : N₂.fg) : (N₁ ⊔ N₂).fg :=
let ⟨t₁, ht₁⟩ := fg_def.1 hN₁, ⟨t₂, ht₂⟩ := fg_def.1 hN₂ in
fg_def.2 ⟨t₁ ∪ t₂, ht₁.1.union ht₂.1, by rw [closure_union, ht₁.2, ht₂.2]⟩

theorem fg.map {N : Type*} [L.Structure N] (f : M →[L] N) {s : L.substructure M} (hs : s.fg) :
  (s.map f).fg :=
let ⟨t, ht⟩ := fg_def.1 hs in fg_def.2 ⟨f '' t, ht.1.image _, by rw [closure_image, ht.2]⟩

theorem fg.of_map_embedding {N : Type*} [L.Structure N] (f : M ↪[L] N) {s : L.substructure M}
  (hs : (s.map f.to_hom).fg) : s.fg :=
begin
  rcases hs with ⟨t, h⟩,
  rw fg_def,
  refine ⟨f ⁻¹' t, t.finite_to_set.preimage (f.injective.inj_on _), _⟩,
  have hf : function.injective f.to_hom := f.injective,
  refine map_injective_of_injective hf _,
  rw [← h, map_closure, embedding.coe_to_hom, image_preimage_eq_of_subset],
  intros x hx,
  have h' := subset_closure hx,
  rw h at h',
  exact hom.map_le_range h'
end

/-- A substructure of `M` is countably generated if it is the closure of a countable subset of `M`.
-/
def cg (N : L.substructure M) : Prop := ∃ S : set M, S.countable ∧ closure L S = N

theorem fg.cg {N : L.substructure M} (h : N.fg) : N.cg :=
begin
  obtain ⟨s, hf, rfl⟩ := fg_def.1 h,
  refine ⟨s, hf.countable, rfl⟩,
end

lemma cg_iff_empty_or_exists_nat_generating_family {N : L.substructure M} :
  N.cg ↔ (↑N = (∅ : set M)) ∨ ∃ (s : ℕ → M), closure L (range s) = N :=
begin
  rw cg_def,
  split,
  { rintros ⟨S, Scount, hS⟩,
    cases eq_empty_or_nonempty ↑N with h h,
    { exact or.intro_left _ h },
    obtain ⟨f, h'⟩ := (Scount.union (set.countable_singleton h.some)).exists_eq_range
      (singleton_nonempty h.some).inr,
    refine or.intro_right _ ⟨f, _⟩,
    rw [← h', closure_union, hS, sup_eq_left, closure_le],
    exact singleton_subset_iff.2 h.some_mem },
  { intro h,
    cases h with h h,
    { refine ⟨∅, countable_empty, closure_eq_of_le (empty_subset _) _⟩,
      rw [← set_like.coe_subset_coe, h],
      exact empty_subset _ },
    { obtain ⟨f, rfl⟩ := h,
      exact ⟨range f, countable_range _, rfl⟩ } },
end

theorem cg_bot : (⊥ : L.substructure M).cg := fg_bot.cg

theorem cg_closure {s : set M} (hs : s.countable) : cg (closure L s) :=
⟨s, hs, rfl⟩

theorem cg_closure_singleton (x : M) : cg (closure L ({x} : set M)) := (fg_closure_singleton x).cg

theorem cg.sup {N₁ N₂ : L.substructure M}
  (hN₁ : N₁.cg) (hN₂ : N₂.cg) : (N₁ ⊔ N₂).cg :=
let ⟨t₁, ht₁⟩ := cg_def.1 hN₁, ⟨t₂, ht₂⟩ := cg_def.1 hN₂ in
cg_def.2 ⟨t₁ ∪ t₂, ht₁.1.union ht₂.1, by rw [closure_union, ht₁.2, ht₂.2]⟩

theorem cg.map {N : Type*} [L.Structure N] (f : M →[L] N) {s : L.substructure M} (hs : s.cg) :
  (s.map f).cg :=
let ⟨t, ht⟩ := cg_def.1 hs in cg_def.2 ⟨f '' t, ht.1.image _, by rw [closure_image, ht.2]⟩

theorem cg.of_map_embedding {N : Type*} [L.Structure N] (f : M ↪[L] N) {s : L.substructure M}
  (hs : (s.map f.to_hom).cg) : s.cg :=
begin
  rcases hs with ⟨t, h1, h2⟩,
  rw cg_def,
  refine ⟨f ⁻¹' t, h1.preimage f.injective, _⟩,
  have hf : function.injective f.to_hom := f.injective,
  refine map_injective_of_injective hf _,
  rw [← h2, map_closure, embedding.coe_to_hom, image_preimage_eq_of_subset],
  intros x hx,
  have h' := subset_closure hx,
  rw h2 at h',
  exact hom.map_le_range h'
end

theorem cg_iff_countable [countable (Σl, L.functions l)] {s : L.substructure M} :
  s.cg ↔ countable s :=
begin
  refine ⟨_, λ h, ⟨s, h.to_set, s.closure_eq⟩⟩,
  rintro ⟨s, h, rfl⟩,
  exact h.substructure_closure L
end

end substructure

open substructure

namespace Structure

variables (L) (M)

/-- A structure is finitely generated if it is the closure of a finite subset. -/
class fg : Prop := (out : (⊤ : L.substructure M).fg)

/-- A structure is countably generated if it is the closure of a countable subset. -/
class cg : Prop := (out : (⊤ : L.substructure M).cg)

variables {L M}

lemma fg_def : fg L M ↔ (⊤ : L.substructure M).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

/-- An equivalent expression of `Structure.fg` in terms of `set.finite` instead of `finset`. -/
lemma fg_iff : fg L M ↔ ∃ S : set M, S.finite ∧ closure L S = (⊤ : L.substructure M) :=
by rw [fg_def, substructure.fg_def]

lemma fg.range {N : Type*} [L.Structure N] (h : fg L M) (f : M →[L] N) :
  f.range.fg :=
begin
  rw [hom.range_eq_map],
  exact (fg_def.1 h).map f,
end

lemma fg.map_of_surjective {N : Type*} [L.Structure N] (h : fg L M) (f : M →[L] N)
  (hs : function.surjective f) :
  fg L N :=
begin
  rw ← hom.range_eq_top at hs,
  rw [fg_def, ← hs],
  exact h.range f,
end

/-- An equivalent expression of `Structure.cg`. -/
lemma cg_iff : cg L M ↔ ∃ S : set M, S.countable ∧ closure L S = (⊤ : L.substructure M) :=
by rw [cg_def, substructure.cg_def]

lemma cg.range {N : Type*} [L.Structure N] (h : cg L M) (f : M →[L] N) :
  f.range.cg :=
begin
  rw [hom.range_eq_map],
  exact (cg_def.1 h).map f,
end

lemma cg.map_of_surjective {N : Type*} [L.Structure N] (h : cg L M) (f : M →[L] N)
  (hs : function.surjective f) :
  cg L N :=
begin
  rw ← hom.range_eq_top at hs,
  rw [cg_def, ← hs],
  exact h.range f,
end

lemma cg_iff_countable [countable (Σl, L.functions l)] : cg L M ↔ countable M :=
by rw [cg_def, cg_iff_countable, top_equiv.to_equiv.countable_iff]

lemma fg.cg (h : fg L M) : cg L M :=
cg_def.2 (fg_def.1 h).cg

@[priority 100] instance cg_of_fg [h : fg L M] : cg L M := h.cg

end Structure

lemma equiv.fg_iff {N : Type*} [L.Structure N] (f : M ≃[L] N) :
  Structure.fg L M ↔ Structure.fg L N :=
⟨λ h, h.map_of_surjective f.to_hom f.to_equiv.surjective,
  λ h, h.map_of_surjective f.symm.to_hom f.to_equiv.symm.surjective⟩

lemma substructure.fg_iff_Structure_fg (S : L.substructure M) :
  S.fg ↔ Structure.fg L S :=
begin
  rw Structure.fg_def,
  refine ⟨λ h, fg.of_map_embedding S.subtype _, λ h, _⟩,
  { rw [← hom.range_eq_map, range_subtype],
    exact h },
  { have h := h.map S.subtype.to_hom,
    rw [← hom.range_eq_map, range_subtype] at h,
    exact h }
end

lemma equiv.cg_iff {N : Type*} [L.Structure N] (f : M ≃[L] N) :
  Structure.cg L M ↔ Structure.cg L N :=
⟨λ h, h.map_of_surjective f.to_hom f.to_equiv.surjective,
  λ h, h.map_of_surjective f.symm.to_hom f.to_equiv.symm.surjective⟩

lemma substructure.cg_iff_Structure_cg (S : L.substructure M) :
  S.cg ↔ Structure.cg L S :=
begin
  rw Structure.cg_def,
  refine ⟨λ h, cg.of_map_embedding S.subtype _, λ h, _⟩,
  { rw [← hom.range_eq_map, range_subtype],
    exact h },
  { have h := h.map S.subtype.to_hom,
    rw [← hom.range_eq_map, range_subtype] at h,
    exact h }
end

end language
end first_order


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl (CMU)
-/

namespace name

def last_string : name → string
| anonymous        := "[anonymous]"
| (mk_string s _)  := s
| (mk_numeral _ n) := last_string n

end name

namespace expr
open expr

meta def replace_with (e : expr) (s : expr) (s' : expr) : expr :=
e.replace $ λc d, if c = s then some (s'.lift_vars 0 d) else none

meta def local_binder_info : expr → binder_info
| (local_const x n bi t) := bi
| e                      := binder_info.default

meta def to_implicit_binder : expr → expr
| (local_const n₁ n₂ _ d) := local_const n₁ n₂ binder_info.implicit d
| (lam n _ d b) := lam n binder_info.implicit d b
| (pi n _ d b) := pi n binder_info.implicit d b
| e  := e

meta def get_app_fn_args_aux : list expr → expr → expr × list expr
| r (app f a) := get_app_fn_args_aux (a::r) f
| r e         := (e, r)

meta def get_app_fn_args : expr → expr × list expr :=
get_app_fn_args_aux []

end expr

namespace tactic
open level expr tactic

meta def mk_local_pisn : expr → nat → tactic (list expr × expr)
| (pi n bi d b) (c + 1) := do
  p ← mk_local' n bi d,
  (ps, r) ← mk_local_pisn (b.instantiate_var p) c,
  return ((p :: ps), r)
| e 0 := return ([], e)
| _ _ := failed

meta def drop_pis : list expr → expr → tactic expr
| (list.cons v vs) (pi n bi d b) := do
  t ← infer_type v,
  guard (t =ₐ d),
  drop_pis vs (b.instantiate_var v)
| [] e := return e
| _  _ := failed

meta def mk_theorem (n : name) (ls : list name) (t : expr) (e : expr) : declaration :=
declaration.thm n ls t (task.pure e)

meta def add_theorem_by (n : name) (ls : list name) (type : expr) (tac : tactic unit) : tactic expr := do
  ((), body) ← solve_aux type tac,
  body ← instantiate_mvars body,
  add_decl $ mk_theorem n ls type body,
  return $ const n $ ls.map param

meta def mk_exists_lst (args : list expr) (inner : expr) : tactic expr :=
args.mfoldr (λarg i:expr, do
    t ← infer_type arg,
    sort l ← infer_type t,
    return $ if arg.occurs i ∨ l ≠ level.zero
      then (const `Exists [l] : expr) t (i.lambdas [arg])
      else (const `and [] : expr) t i)
  inner

meta def mk_op_lst (op : expr) (empty : expr) : list expr → expr
| []        := empty
| [e]       := e
| (e :: es) := op e $ mk_op_lst es

meta def mk_and_lst : list expr → expr := mk_op_lst `(and) `(true)

meta def mk_or_lst : list expr → expr := mk_op_lst `(or) `(false)

meta def elim_gen_prod : nat → expr → list expr → tactic (list expr × expr)
| 0       e hs := return (hs, e)
| (n + 1) e hs := do
  [(_, [h, h'], _)] ← induction e [],
  elim_gen_prod n h' (hs ++ [h])

private meta def elim_gen_sum_aux : nat → expr → list expr → tactic (list expr × expr)
| 0       e hs := return (hs, e)
| (n + 1) e hs := do
  [(_, [h], _), (_, [h'], _)] ← induction e [],
  swap,
  elim_gen_sum_aux n h' (h::hs)

meta def elim_gen_sum (n : nat) (e : expr) : tactic (list expr) := do
  (hs, h') ← elim_gen_sum_aux n e [],
  gs ← get_goals,
  set_goals $ (gs.take (n+1)).reverse ++ gs.drop (n+1),
  return $ hs.reverse ++ [h']

end tactic

section
universe u

@[user_attribute]
meta def monotonicity : user_attribute := { name := `monotonicity, descr := "Monotonicity rules for predicates" }

lemma monotonicity.pi {α : Sort u} {p q : α → Prop} (h : ∀a, implies (p a) (q a)) :
  implies (Πa, p a) (Πa, q a) :=
assume h' a, h a (h' a)

lemma monotonicity.imp {p p' q q' : Prop} (h₁ : implies p' q') (h₂ : implies q p) :
  implies (p → p') (q → q') :=
assume h, h₁ ∘ h ∘ h₂

@[monotonicity]
lemma monotonicity.const (p : Prop) : implies p p := id

@[monotonicity]
lemma monotonicity.true (p : Prop) : implies p true := assume _, trivial

@[monotonicity]
lemma monotonicity.false (p : Prop) : implies false p := false.elim

@[monotonicity]
lemma monotonicity.exists {α : Sort u} {p q : α → Prop} (h : ∀a, implies (p a) (q a)) :
  implies (∃a, p a) (∃a, q a) :=
exists_imp_exists h

@[monotonicity]
lemma monotonicity.and {p p' q q' : Prop} (hp : implies p p') (hq : implies q q') :
  implies (p ∧ q) (p' ∧ q') :=
and.imp hp hq

@[monotonicity]
lemma monotonicity.or {p p' q q' : Prop} (hp : implies p p') (hq : implies q q') :
  implies (p ∨ q) (p' ∨ q') :=
or.imp hp hq

@[monotonicity]
lemma monotonicity.not {p q : Prop} (h : implies p q) :
  implies (¬ q) (¬ p) :=
mt h

end

namespace tactic
open expr tactic

/- TODO: use backchaining -/
private meta def mono_aux (ns : list name) (hs : list expr) : tactic unit := do
  intros,
  (do
    `(implies %%p %%q) ← target,
    (do is_def_eq p q, eapplyc `monotone.const) <|>
    (do
      (expr.pi pn pbi pd pb) ← whnf p,
      (expr.pi qn qbi qd qb) ← whnf q,
      sort u ← infer_type pd,
      (do is_def_eq pd qd,
        let p' := expr.lam pn pbi pd pb,
        let q' := expr.lam qn qbi qd qb,
        eapply ((const `monotonicity.pi [u] : expr) pd p' q'),
        skip) <|>
      (do guard $ u = level.zero ∧ is_arrow p ∧ is_arrow q,
        let p' := pb.lower_vars 0 1,
        let q' := qb.lower_vars 0 1,
        eapply ((const `monotonicity.imp []: expr) pd p' qd q'),
        skip))) <|>
  first (hs.map $ λh, apply_core h {md := transparency.none, new_goals := new_goals.non_dep_only} >> skip) <|>
  first (ns.map $ λn, do c ← mk_const n, apply_core c {md := transparency.none, new_goals := new_goals.non_dep_only}, skip),
  all_goals mono_aux

meta def mono (e : expr) (hs : list expr) : tactic unit := do
  t ← target,
  t' ← infer_type e,
  ns ← attribute.get_instances `monotonicity,
  ((), p) ← solve_aux `(implies %%t' %%t) (mono_aux ns hs),
  exact (p e)

end tactic

/-
The coinductive predicate `pred`:

  coinductive {u} pred (A) : a → Prop
  | r : ∀A b, pred A p

where
  `u` is a list of universe parameters
  `A` is a list of global parameters
  `pred` is a list predicates to be defined
  `a` are the indices for each `pred`
  `r` is a list of introduction rules for each `pred`
  `b` is a list of parameters for each rule in `r` and `pred`
  `p` is are the instances of `a` using `A` and `b`

`pred` is compiled to the following defintions:

  inductive {u} pred.functional (A) ([pred'] : a → Prop) : a → Prop
  | r : ∀a [f], b[pred/pred'] → pred.functional a [f] p

  lemma {u} pred.functional.mono (A) ([pred₁] [pred₂] : a → Prop) [(h : ∀b, pred₁ b → pred₂ b)] :
    ∀p, pred.functional A pred₁ p → pred.functional A pred₂ p

  def {u} pred_i (A) (a) : Prop :=
  ∃[pred'], (Λi, ∀a, pred_i a → pred_i.functional A [pred] a) ∧ pred'_i a

  lemma {u} pred_i.corec_functional (A) [Λi, C_i : a_i → Prop] [Λi, h : ∀a, C_i a → pred_i.functional A C_i a] :
    ∀a, C_i a → pred_i A a

  lemma {u} pred_i.destruct (A) (a) : pred A a → pred.functional A [pred A] a

  lemma {u} pred_i.construct (A) : ∀a, pred_i.functional A [pred A] a → pred_i A a

  lemma {u} pred_i.cases_on (A) (C : a → Prop) {a} (h : pred_i a) [Λi, ∀a, b → C p] → C a

  lemma {u} pred_i.corec_on (A) [(C : a → Prop)] (a) (h : C_i a)
    [Λi, h_i : ∀a, C_i a → [V j ∃b, a = p]] : pred_i A a

  lemma {u} pred.r (A) (b) : pred_i A p
-/

namespace tactic
open level expr tactic

namespace add_coinductive_predicate

/- private -/ meta structure coind_rule : Type :=
(orig_nm  : name)
(func_nm  : name)
(type     : expr)
(loc_type : expr)
(args     : list expr)
(loc_args : list expr)
(concl    : expr)
(insts    : list expr)

/- private -/ meta structure coind_pred : Type :=
(u_names  : list name)
(params   : list expr)
(pd_name  : name)
(type     : expr)
(intros   : list coind_rule)
(locals   : list expr)
(f₁ f₂    : expr)
(u_f      : level)

namespace coind_pred

meta def u_params (pd : coind_pred) : list level :=
pd.u_names.map param

meta def f₁_l (pd : coind_pred) : expr :=
pd.f₁.app_of_list pd.locals

meta def f₂_l (pd : coind_pred) : expr :=
pd.f₂.app_of_list pd.locals

meta def pred (pd : coind_pred) : expr :=
const pd.pd_name pd.u_params

meta def func (pd : coind_pred) : expr :=
const (pd.pd_name ++ "functional") pd.u_params

meta def func_g (pd : coind_pred) : expr :=
pd.func.app_of_list $ pd.params

meta def pred_g (pd : coind_pred) : expr :=
pd.pred.app_of_list $ pd.params

meta def impl_locals (pd : coind_pred) : list expr :=
pd.locals.map to_implicit_binder

meta def impl_params (pd : coind_pred) : list expr :=
pd.params.map to_implicit_binder

meta def le (pd : coind_pred) (f₁ f₂ : expr) : expr :=
(imp (f₁.app_of_list pd.locals) (f₂.app_of_list pd.locals)).pis pd.impl_locals

meta def corec_functional (pd : coind_pred) : expr :=
const (pd.pd_name ++ "corec_functional") pd.u_params

meta def mono (pd : coind_pred) : expr :=
const (pd.func.const_name ++ "mono") pd.u_params

meta def rec' (pd : coind_pred) : tactic expr :=
do let c := pd.func.const_name ++ "rec",
   env  ← get_env,
   decl ← env.get c,
   let num := decl.univ_params.length,
   return (const c $ if num = pd.u_params.length then pd.u_params else level.zero :: pd.u_params)
  -- ^^ `rec`'s universes are not always `u_params`, e.g. eq, wf, false

meta def construct (pd : coind_pred) : expr :=
const (pd.pd_name ++ "construct") pd.u_params

meta def destruct (pd : coind_pred) : expr :=
const (pd.pd_name ++ "destruct") pd.u_params

meta def add_theorem (pd : coind_pred) (n : name) (type : expr) (tac : tactic unit) : tactic expr :=
add_theorem_by n pd.u_names type tac

end coind_pred

end add_coinductive_predicate

open add_coinductive_predicate

/- compact_relation bs as_ps: Product a relation of the form:
  R := λ as, ∃ bs, Λ_i a_i = p_i[bs]
This relation is user visible, so we compact it by removing each `b_j` where a `p_i = b_j`, and
hence `a_i = b_j`. We need to take care when there are `p_i` and `p_j` with `p_i = p_j = b_k`. -/
private meta def compact_relation :
  list expr → list (expr × expr) → list expr × list (expr × expr)
| [] ps      := ([], ps)
| (list.cons b bs) ps :=
  match ps.span (λap:expr × expr, ¬ ap.2 =ₐ b) with
    | (_, [])           := let (bs, ps) := compact_relation bs ps in (b::bs, ps)
    | (ps₁, list.cons (a, _) ps₂) := let i := a.instantiate_local b.local_uniq_name in
      compact_relation (bs.map i) ((ps₁ ++ ps₂).map (λ⟨a, p⟩, (a, i p)))
  end

meta def add_coinductive_predicate
  (u_names : list name) (params : list expr) (preds : list $ expr × list expr) : command := do
  let params_names := params.map local_pp_name,
  let u_params := u_names.map param,

  pre_info ← preds.mmap (λ⟨c, is⟩, do
    (ls, t) ← mk_local_pis c.local_type,
    (is_def_eq t `(Prop) <|>
      fail (format! "Type of {c.local_pp_name} is not Prop. Currently only " ++
                    "coinductive predicates are supported.")),
    let n := if preds.length = 1 then "" else "_" ++ c.local_pp_name.last_string,
    f₁ ← mk_local_def (mk_simple_name $ "C" ++ n) c.local_type,
    f₂ ← mk_local_def (mk_simple_name $ "C₂" ++ n) c.local_type,
    return (ls, (f₁, f₂))),

  let fs := pre_info.map prod.snd,
  let fs₁ := fs.map prod.fst,
  let fs₂ := fs.map prod.snd,

  pds ← (preds.zip pre_info).mmap (λ⟨⟨c, is⟩, ls, f₁, f₂⟩, do
    sort u_f ← infer_type f₁ >>= infer_type,
    let pred_g := λc:expr, (const c.local_uniq_name u_params : expr).app_of_list params,
    intros ← is.mmap (λi, do
      (args, t') ← mk_local_pis i.local_type,
      (name.mk_string sub p) ← return i.local_uniq_name,
      let loc_args := args.map $ λe, (fs₁.zip preds).foldl (λ(e:expr) ⟨f, c, _⟩,
        e.replace_with (pred_g c) f) e,
      let t' := t'.replace_with (pred_g c) f₂,
      return { tactic.add_coinductive_predicate.coind_rule .
        orig_nm  := i.local_uniq_name,
        func_nm  := (p ++ "functional") ++ sub,
        type     := i.local_type,
        loc_type := t'.pis loc_args,
        concl    := t',
        loc_args := loc_args,
        args     := args,
        insts    := t'.get_app_args }),
    return { tactic.add_coinductive_predicate.coind_pred .
      pd_name := c.local_uniq_name, type := c.local_type, f₁ := f₁, f₂ := f₂, u_f := u_f,
      intros := intros, locals := ls, params := params, u_names := u_names }),

  /- Introduce all functionals -/
  pds.mmap' (λpd:coind_pred, do
    let func_f₁ := pd.func_g.app_of_list $ fs₁,
    let func_f₂ := pd.func_g.app_of_list $ fs₂,

    /- Define functional for `pd` as inductive predicate -/
    func_intros ← pd.intros.mmap (λr:coind_rule, do
      let t := instantiate_local pd.f₂.local_uniq_name (pd.func_g.app_of_list fs₁) r.loc_type,
      return (r.func_nm, r.orig_nm, t.pis $ params ++ fs₁)),
    add_inductive pd.func.const_name u_names
      (params.length + preds.length) (pd.type.pis $ params ++ fs₁) (func_intros.map $ λ⟨t, _, r⟩, (t, r)),

    /- Prove monotonicity rule -/
    mono_params ← pds.mmap (λpd, do
      h ← mk_local_def `h $ pd.le pd.f₁ pd.f₂,
      return [pd.f₁, pd.f₂, h]),
    pd.add_theorem (pd.func.const_name ++ "mono")
      ((pd.le func_f₁ func_f₂).pis $ params ++ mono_params.join)
      (do
      ps ← intro_lst $ params.map expr.local_pp_name,
      fs ← pds.mmap (λpd, do
        [f₁, f₂, h] ← intro_lst [pd.f₁.local_pp_name, pd.f₂.local_pp_name, `h],
        -- the type of h' reduces to h
        let h' := local_const h.local_uniq_name h.local_pp_name h.local_binder_info $
          (((const `implies [] : expr)
            (f₁.app_of_list pd.locals) (f₂.app_of_list pd.locals)).pis pd.locals).instantiate_locals $
          (ps.zip params).map $ λ⟨lv, p⟩, (p.local_uniq_name, lv),
        return (f₂, h')),
      m ← pd.rec',
      eapply $ m.app_of_list ps, -- somehow `induction` / `cases` doesn't work?
      func_intros.mmap' (λ⟨n, pp_n, t⟩, solve1 $ do
        bs ← intros,
        ms ← apply_core ((const n u_params).app_of_list $ ps ++ fs.map prod.fst) {new_goals := new_goals.all},
        params ← (ms.zip bs).enum.mfilter (λ⟨n, m, d⟩, bnot <$> is_assigned m.2),
        params.mmap' (λ⟨n, m, d⟩, mono d (fs.map prod.snd) <|>
          fail format! "failed to prove montonoicity of {n+1}. parameter of intro-rule {pp_n}")))),

  pds.mmap' (λpd, do
    let func_f := λpd:coind_pred, pd.func_g.app_of_list $ pds.map coind_pred.f₁,

    /- define final predicate -/
    pred_body ← mk_exists_lst (pds.map coind_pred.f₁) $
      mk_and_lst $ (pds.map $ λpd, pd.le pd.f₁ (func_f pd)) ++ [pd.f₁.app_of_list pd.locals],
    add_decl $ mk_definition pd.pd_name u_names (pd.type.pis $ params) $
      pred_body.lambdas $ params ++ pd.locals,

    /- prove `corec_functional` rule -/
    hs ← pds.mmap $ λpd:coind_pred, mk_local_def `hc $ pd.le pd.f₁ (func_f pd),
    pd.add_theorem (pd.pred.const_name ++ "corec_functional")
      ((pd.le pd.f₁ pd.pred_g).pis $ params ++ fs₁ ++ hs)
      (do
      intro_lst $ params.map local_pp_name,
      fs ← intro_lst $ fs₁.map local_pp_name,
      hs ← intro_lst $ hs.map local_pp_name,
      ls ← intro_lst $ pd.locals.map local_pp_name,
      h ← intro `h,
      whnf_target,
      fs.mmap' existsi,
      hs.mmap' (λf, econstructor >> exact f),
      exact h)),

  let func_f := λpd : coind_pred, pd.func_g.app_of_list $ pds.map coind_pred.pred_g,

  /- prove `destruct` rules -/
  pds.enum.mmap' (λ⟨n, pd⟩, do
    let destruct := pd.le pd.pred_g (func_f pd),
    pd.add_theorem (pd.pred.const_name ++ "destruct") (destruct.pis params) (do
      ps ← intro_lst $ params.map local_pp_name,
      ls ← intro_lst $ pd.locals.map local_pp_name,
      h ← intro `h,
      (fs, h) ← elim_gen_prod pds.length h [],
      (hs, h) ← elim_gen_prod pds.length h [],
      eapply $ pd.mono.app_of_list ps,
      pds.mmap' (λpd:coind_pred, focus1 $ do
        eapply $ pd.corec_functional,
        focus $ hs.map exact),
      some h' ← return $ hs.nth n,
      eapply h',
      exact h)),

  /- prove `construct` rules -/
  pds.mmap' (λpd,
    pd.add_theorem (pd.pred.const_name ++ "construct")
      ((pd.le (func_f pd) pd.pred_g).pis params) (do
      ps ← intro_lst $ params.map local_pp_name,
      let func_pred_g := λpd:coind_pred,
        pd.func.app_of_list $ ps ++ pds.map (λpd:coind_pred, pd.pred.app_of_list ps),
      eapply $ pd.corec_functional.app_of_list $ ps ++ pds.map func_pred_g,
      pds.mmap' (λpd:coind_pred, solve1 $ do
        eapply $ pd.mono.app_of_list ps,
        pds.mmap' (λpd, solve1 $ eapply (pd.destruct.app_of_list ps) >> skip)))),

  /- prove `cases_on` rules -/
  pds.mmap' (λpd, do
    let C := pd.f₁.to_implicit_binder,
    h ← mk_local_def `h $ pd.pred_g.app_of_list pd.locals,
    rules ← pd.intros.mmap (λr:coind_rule, do
      mk_local_def (mk_simple_name r.orig_nm.last_string) $ (C.app_of_list r.insts).pis r.args),
    cases_on ← pd.add_theorem (pd.pred.const_name ++ "cases_on")
      ((C.app_of_list pd.locals).pis $ params ++ [C] ++ pd.impl_locals ++ [h] ++ rules)
      (do
        ps ← intro_lst $ params.map local_pp_name,
        C  ← intro `C,
        ls ← intro_lst $ pd.locals.map local_pp_name,
        h  ← intro `h,
        rules  ← intro_lst $ rules.map local_pp_name,
        func_rec ← pd.rec',
        eapply $ func_rec.app_of_list $ ps ++ pds.map (λpd, pd.pred.app_of_list ps) ++ [C] ++ rules,
        eapply $ pd.destruct,
        exact h),
    set_basic_attribute `elab_as_eliminator cases_on.const_name),

  /- prove `corec_on` rules -/
  pds.mmap' (λpd, do
    rules ← pds.mmap (λpd, do
      intros ← pd.intros.mmap (λr, do
        let (bs, eqs) := compact_relation r.loc_args $ pd.locals.zip r.insts,
        eqs ← eqs.mmap (λ⟨l, i⟩, do
          sort u ← infer_type l.local_type,
          return $ (const `eq [u] : expr) l.local_type i l),
        match bs, eqs with
        | [], [] := return ((0, 0), mk_true)
        | _, []  := prod.mk (bs.length, 0) <$> mk_exists_lst bs.init bs.ilast.local_type
        | _, _   := prod.mk (bs.length, eqs.length) <$> mk_exists_lst bs (mk_and_lst eqs)
        end),
      let shape  := intros.map prod.fst,
      let intros := intros.map prod.snd,
      prod.mk shape <$>
        mk_local_def (mk_simple_name $ "h_" ++ pd.pd_name.last_string)
          (((pd.f₁.app_of_list pd.locals).imp (mk_or_lst intros)).pis pd.locals)),
    let shape := rules.map prod.fst,
    let rules := rules.map prod.snd,
    h ← mk_local_def `h $ pd.f₁.app_of_list pd.locals,
    pd.add_theorem (pd.pred.const_name ++ "corec_on")
      ((pd.pred_g.app_of_list $ pd.locals).pis $ params ++ fs₁ ++ pd.impl_locals ++ [h] ++ rules)
      (do
        ps ← intro_lst $ params.map local_pp_name,
        fs ← intro_lst $ fs₁.map local_pp_name,
        ls ← intro_lst $ pd.locals.map local_pp_name,
        h  ← intro `h,
        rules  ← intro_lst $ rules.map local_pp_name,
        eapply $ pd.corec_functional.app_of_list $ ps ++ fs,
        (pds.zip $ rules.zip shape).mmap (λ⟨pd, hr, s⟩, solve1 $ do
          ls ← intro_lst $ pd.locals.map local_pp_name,
          h' ← intro `h,
          h' ← note `h' none $ hr.app_of_list ls h',
          match s.length with
          | 0     := induction h' >> skip -- h' : false
          | (n+1) := do
            hs ← elim_gen_sum n h',
            (hs.zip $ pd.intros.zip s).mmap' (λ⟨h, r, n_bs, n_eqs⟩, solve1 $ do
              (as, h) ← elim_gen_prod (n_bs - (if n_eqs = 0 then 1 else 0)) h [],
              if n_eqs > 0 then do
                (eqs, eq') ← elim_gen_prod (n_eqs - 1) h [],
                (eqs ++ [eq']).mmap' subst
              else skip,
              eapply ((const r.func_nm u_params).app_of_list $ ps ++ fs),
              iterate assumption)
          end),
        exact h)),

  /- prove constructors -/
  pds.mmap' (λpd, pd.intros.mmap' (λr,
    pd.add_theorem r.orig_nm (r.type.pis params) $ do
      ps ← intro_lst $ params.map local_pp_name,
      bs ← intros,
      eapply $ pd.construct,
      exact $ (const r.func_nm u_params).app_of_list $ ps ++ pds.map (λpd, pd.pred.app_of_list ps) ++ bs)),

  pds.mmap' (λpd:coind_pred, set_basic_attribute `irreducible pd.pd_name),

  try triv -- we setup a trivial goal for the tactic framework

open lean.parser
open interactive

@[user_command]
meta def coinductive_predicate (meta_info : decl_meta_info) (_ : parse $ tk "coinductive") : lean.parser unit := do
  decl ← inductive_decl.parse meta_info,
  add_coinductive_predicate decl.u_names decl.params $ decl.decls.map $ λ d, (d.sig, d.intros),
  decl.decls.mmap' $ λ d, do {
    get_env >>= λ env, set_env $ env.add_namespace d.name,
    meta_info.attrs.apply d.name,
    d.attrs.apply d.name,
    some doc_string ← pure meta_info.doc_string | skip,
    add_doc_string d.name doc_string
  }

/-- Prepares coinduction proofs. This tactic constructs the coinduction invariant from
the quantifiers in the current goal.

Current version: do not support mutual inductive rules (i.e. only a since C -/
meta def coinduction (rule : expr) : tactic unit := focus1 $
do
  ctxts' ← intros,
  ctxts ← ctxts'.mmap (λv,
    local_const v.local_uniq_name v.local_pp_name v.local_binder_info <$> infer_type v),
  mvars ← apply_core rule {approx := ff, new_goals := new_goals.all},
  -- analyse relation
  g ← list.head <$> get_goals,
  (list.cons _ m_is) ← return $ mvars.drop_while (λv, v.2 ≠ g),
  tgt ← target,
  (is, ty) ← mk_local_pis tgt,

  -- construct coinduction predicate
  (bs, eqs) ← compact_relation ctxts <$>
    ((is.zip m_is).mmap (λ⟨i, m⟩, prod.mk i <$> instantiate_mvars m.2)),

  solve1 (do
    eqs ← mk_and_lst <$> eqs.mmap (λ⟨i, m⟩, mk_app `eq [m, i] >>= instantiate_mvars),
    rel ← mk_exists_lst bs eqs,
    exact (rel.lambdas is)),

  -- prove predicate
  solve1 (do
    target >>= instantiate_mvars >>= change, -- TODO: bug in existsi & constructor when mvars in hyptohesis
    bs.mmap existsi,
    iterate (econstructor >> skip)),

  -- clean up remaining coinduction steps
  all_goals (do
    ctxts'.reverse.mmap clear,
    target >>= instantiate_mvars >>= change, -- TODO: bug in subst when mvars in hyptohesis
    is ← intro_lst $ is.map expr.local_pp_name,
    h ← intro1,
    (_, h) ← elim_gen_prod (bs.length - (if eqs.length = 0 then 1 else 0)) h [],
    (match eqs with
    | [] := clear h
    | (e::eqs) := do
      (hs, h) ← elim_gen_prod eqs.length h [],
      (h::(hs.reverse)).mmap' subst
    end))

namespace interactive
open interactive interactive.types expr lean.parser
local postfix `?`:9001 := optional
local postfix *:9001 := many

meta def coinduction (corec_name : parse ident)
  (revert : parse $ (tk "generalizing" *> ident*)?) : tactic unit := do
  rule ← mk_const corec_name,
  locals ← mmap tactic.get_local $ revert.get_or_else [],
  revert_lst locals,
  tactic.coinduction rule,
  skip

end interactive

end tactic


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.has_limits
import category_theory.thin

/-!
# Wide pullbacks

We define the category `wide_pullback_shape`, (resp. `wide_pushout_shape`) which is the category
obtained from a discrete category of type `J` by adjoining a terminal (resp. initial) element.
Limits of this shape are wide pullbacks (pushouts).
The convenience method `wide_cospan` (`wide_span`) constructs a functor from this category, hitting
the given morphisms.

We use `wide_pullback_shape` to define ordinary pullbacks (pushouts) by using `J := walking_pair`,
which allows easy proofs of some related lemmas.
Furthermore, wide pullbacks are used to show the existence of limits in the slice category.
Namely, if `C` has wide pullbacks then `C/B` has limits for any object `B` in `C`.

Typeclasses `has_wide_pullbacks` and `has_finite_wide_pullbacks` assert the existence of wide
pullbacks and finite wide pullbacks.
-/

universes v u

open category_theory category_theory.limits

namespace category_theory.limits

variable (J : Type v)

/-- A wide pullback shape for any type `J` can be written simply as `option J`. -/
@[derive inhabited]
def wide_pullback_shape := option J

/-- A wide pushout shape for any type `J` can be written simply as `option J`. -/
@[derive inhabited]
def wide_pushout_shape := option J

namespace wide_pullback_shape

variable {J}

/-- The type of arrows for the shape indexing a wide pullback. -/
@[derive decidable_eq]
inductive hom : wide_pullback_shape J → wide_pullback_shape J → Type v
| id : Π X, hom X X
| term : Π (j : J), hom (some j) none

attribute [nolint unused_arguments] hom.decidable_eq

instance struct : category_struct (wide_pullback_shape J) :=
{ hom := hom,
  id := λ j, hom.id j,
  comp := λ j₁ j₂ j₃ f g,
  begin
    cases f,
      exact g,
    cases g,
    apply hom.term _
  end }

instance hom.inhabited : inhabited (hom none none) := ⟨hom.id (none : wide_pullback_shape J)⟩

local attribute [tidy] tactic.case_bash

instance subsingleton_hom (j j' : wide_pullback_shape J) : subsingleton (j ⟶ j') :=
⟨by tidy⟩

instance category : small_category (wide_pullback_shape J) := thin_category

@[simp] lemma hom_id (X : wide_pullback_shape J) : hom.id X = 𝟙 X := rfl

variables {C : Type u} [category.{v} C]

/--
Construct a functor out of the wide pullback shape given a J-indexed collection of arrows to a
fixed object.
-/
@[simps]
def wide_cospan (B : C) (objs : J → C) (arrows : Π (j : J), objs j ⟶ B) :
  wide_pullback_shape J ⥤ C :=
{ obj := λ j, option.cases_on j B objs,
  map := λ X Y f,
  begin
    cases f with _ j,
    { apply (𝟙 _) },
    { exact arrows j }
  end }

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_cospan` -/
def diagram_iso_wide_cospan (F : wide_pullback_shape J ⥤ C) :
  F ≅ wide_cospan (F.obj none) (λ j, F.obj (some j)) (λ j, F.map (hom.term j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by tidy) $ by tidy

/-- Construct a cone over a wide cospan. -/
@[simps]
def mk_cone {F : wide_pullback_shape J ⥤ C} {X : C}
  (f : X ⟶ F.obj none) (π : Π j, X ⟶ F.obj (some j))
  (w : ∀ j, π j ≫ F.map (hom.term j) = f) : cone F :=
{ X := X,
  π :=
  { app := λ j, match j with
    | none := f
    | (some j) := π j
    end,
    naturality' := λ j j' f, by { cases j; cases j'; cases f; unfold_aux; dsimp; simp [w], }, } }

end wide_pullback_shape

namespace wide_pushout_shape

variable {J}

/-- The type of arrows for the shape indexing a wide psuhout. -/
@[derive decidable_eq]
inductive hom : wide_pushout_shape J → wide_pushout_shape J → Type v
| id : Π X, hom X X
| init : Π (j : J), hom none (some j)

attribute [nolint unused_arguments] hom.decidable_eq

instance struct : category_struct (wide_pushout_shape J) :=
{ hom := hom,
  id := λ j, hom.id j,
  comp := λ j₁ j₂ j₃ f g,
  begin
    cases f,
      exact g,
    cases g,
    apply hom.init _
  end }

instance hom.inhabited : inhabited (hom none none) := ⟨hom.id (none : wide_pushout_shape J)⟩

local attribute [tidy] tactic.case_bash

instance subsingleton_hom (j j' : wide_pushout_shape J) : subsingleton (j ⟶ j') :=
⟨by tidy⟩

instance category : small_category (wide_pushout_shape J) := thin_category

@[simp] lemma hom_id (X : wide_pushout_shape J) : hom.id X = 𝟙 X := rfl

variables {C : Type u} [category.{v} C]

/--
Construct a functor out of the wide pushout shape given a J-indexed collection of arrows from a
fixed object.
-/
@[simps]
def wide_span (B : C) (objs : J → C) (arrows : Π (j : J), B ⟶ objs j) : wide_pushout_shape J ⥤ C :=
{ obj := λ j, option.cases_on j B objs,
  map := λ X Y f,
  begin
    cases f with _ j,
    { apply (𝟙 _) },
    { exact arrows j }
  end }

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_span` -/
def diagram_iso_wide_span (F : wide_pushout_shape J ⥤ C) :
  F ≅ wide_span (F.obj none) (λ j, F.obj (some j)) (λ j, F.map (hom.init j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by tidy) $ by tidy

/-- Construct a cocone over a wide span. -/
@[simps]
def mk_cocone {F : wide_pushout_shape J ⥤ C} {X : C}
  (f : F.obj none ⟶ X) (ι : Π j, F.obj (some j) ⟶ X)
  (w : ∀ j, F.map (hom.init j) ≫ ι j = f) : cocone F :=
{ X := X,
  ι :=
  { app := λ j, match j with
    | none := f
    | (some j) := ι j
    end,
    naturality' := λ j j' f, by { cases j; cases j'; cases f; unfold_aux; dsimp; simp [w], }, } }

end wide_pushout_shape

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

/-- `has_wide_pullbacks` represents a choice of wide pullback for every collection of morphisms -/
abbreviation has_wide_pullbacks : Prop :=
Π (J : Type v), has_limits_of_shape (wide_pullback_shape J) C

/-- `has_wide_pushouts` represents a choice of wide pushout for every collection of morphisms -/
abbreviation has_wide_pushouts : Prop :=
Π (J : Type v), has_colimits_of_shape (wide_pushout_shape J) C

end category_theory.limits


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.binary_products
import category_theory.limits.preserves.shapes.pullbacks

/-!
# Relating monomorphisms and epimorphisms to limits and colimits

If `F` preserves (resp. reflects) pullbacks, then it preserves (resp. reflects) monomorphisms.

We also provide the dual version for epimorphisms.

-/

universes v₁ v₂ u₁ u₂

namespace category_theory
open category limits

variables {C : Type u₁} {D : Type u₂} [category.{v₁} C] [category.{v₂} D]
variables (F : C ⥤ D)

/-- If `F` preserves pullbacks, then it preserves monomorphisms. -/
instance preserves_mono {X Y : C} (f : X ⟶ Y) [preserves_limit (cospan f f) F] [mono f] :
  mono (F.map f) :=
begin
  have := is_limit_pullback_cone_map_of_is_limit F _ (pullback_cone.is_limit_mk_id_id f),
  simp_rw [F.map_id] at this,
  apply pullback_cone.mono_of_is_limit_mk_id_id _ this,
end

/-- If `F` reflects pullbacks, then it reflects monomorphisms. -/
lemma reflects_mono {X Y : C} (f : X ⟶ Y) [reflects_limit (cospan f f) F] [mono (F.map f)] :
  mono f :=
begin
  have := pullback_cone.is_limit_mk_id_id (F.map f),
  simp_rw [←F.map_id] at this,
  apply pullback_cone.mono_of_is_limit_mk_id_id _ (is_limit_of_is_limit_pullback_cone_map F _ this),
end

/-- If `F` preserves pushouts, then it preserves epimorphisms. -/
instance preserves_epi {X Y : C} (f : X ⟶ Y) [preserves_colimit (span f f) F] [epi f] :
  epi (F.map f) :=
begin
  have := is_colimit_pushout_cocone_map_of_is_colimit F _ (pushout_cocone.is_colimit_mk_id_id f),
  simp_rw [F.map_id] at this,
  apply pushout_cocone.epi_of_is_colimit_mk_id_id _ this,
end

/-- If `F` reflects pushouts, then it reflects epimorphisms. -/
lemma reflects_epi {X Y : C} (f : X ⟶ Y) [reflects_colimit (span f f) F] [epi (F.map f)] :
  epi f :=
begin
  have := pushout_cocone.is_colimit_mk_id_id (F.map f),
  simp_rw [← F.map_id] at this,
  apply pushout_cocone.epi_of_is_colimit_mk_id_id _
    (is_colimit_of_is_colimit_pushout_cocone_map F _ this)
end

end category_theory


import tactic tactic.induction data.string.basic

namespace exlean
namespace parser

/-
This is a translation into Lean of the `parsing` module described in the first edition of
"Programming in Haskell", by Graham Hutton, Chapter 8:
http://www.cs.nott.ac.uk/~pszgmh/Parsing.lhs
-/

inductive Parser (α : Type)
  | P : (string → option (α × string)) → Parser

open Parser

variables {α β : Type}

def parse : Parser α → string → option (α × string)
  | (P p) inp := p inp

def item : Parser char :=
  P (λ inp, match inp.to_list with
              | [] := none
              | (x::xs) := some (x, ⟨xs⟩)
            end )

instance : monad Parser :=
{ pure := λ α v, P (λ inp, some (v, inp)),
  bind := λ α β p f, P (λ inp,  match (parse p inp) with
                                  | none := none
                                  | some (v, out) := parse (f v) out
                                end ) }

-- `return` is a synonym for `pure`.
example : α → Parser α := return

-- `>>=` is notation for `bind`.
example (f : α → Parser β) (p : Parser α) : Parser β := p >>= f

/-
Some parsers:
-/
example : parse (return 1) "abc" = some (1, "abc") := rfl

example : parse item "" = none := rfl

example : parse item "abc" = some ('a', "bc") := rfl

def failure' : Parser α := P (λ _, none)

def return_first_and_third : Parser (char × char) :=
  do  x ← item,
      item,
      y ← item,
      return (x, y)

example : parse return_first_and_third "ribena" = some ( ('r', 'b'), "ena") := rfl

/-
Alternatives and failure.
-/
instance : alternative Parser :=
{ failure := λ α, P (λ _, none),
  orelse := λ α p q, P (λ inp,  match parse p inp with
                                  | none := parse q inp
                                  | some (v, out) := some (v, out)
                                end) }

-- We need to specifiy the type of `failure` in the example below. I've chosen `Parser unit`
-- for no special reason other than the fact that `failure` should convey no information.
example : parse (failure : Parser unit) "abc" = none := rfl

example : parse (item <|> return 'd') "abc" = some ('a', "bc") := rfl

example : parse (item <|> return 'd') "" = some ('d', "") := rfl

example : parse (failure : Parser unit) "abc" = none := rfl

example : parse ((failure <|> failure) : Parser unit) "abc" = none := rfl

/-
Given a parser `p`, the proposition `consumes p` means that for every input string `inp`, either
`p` fails on `inp` (i.e. that `parse p inp = none`) or that the output string is shorter than
the input string.
-/
def consumes (p : Parser α) : Prop := ∀ (inp : string), (parse p inp = none ∨
  ∃ v out, (parse p inp) = some (v, out) ∧ out.length < inp.length)

def consumes' : Parser α → Prop
| (P p) := ∀ (inp : string), p inp = none ∨ ∃ v out, p inp = some (v, out) ∧ out.length < inp.length

lemma item_consumes' : consumes' item :=
begin
  intro inp, dsimp [item],
  cases h : inp.to_list with x xs,
  { left, refl, },
  { right, existsi x, existsi xs.as_string, split,
    { refl, },
    { rw [←inp.as_string_inv_to_list, h], simp, }, }
end

lemma item_consumes : consumes item :=
begin
  intro inp, dsimp [item, parse],
  cases h : inp.to_list with x xs,
  { left, refl, },
  { right, existsi x, existsi xs.as_string, split,
    { refl, },
    { rw [←inp.as_string_inv_to_list, h], simp, }, }
end

/-
Derived primatives
-/
def sat (p : char → bool) : Parser char :=
  do  x ← item,
      if p x then return x else failure

def digit : Parser char := sat (λ c, to_bool c.is_digit)

def lower : Parser char := sat (λ c, to_bool c.is_lower)

def upper : Parser char := sat (λ c, to_bool c.is_upper)

def letter : Parser char := sat (λ c, to_bool c.is_alpha)

def alphanum : Parser char := sat (λ c, to_bool c.is_alphanum)

def is_space : Parser char := sat (λ c, to_bool c.is_whitespace)

def charp (x : char) : Parser char := sat (λ c, c = x)

example : parse digit "123" = some ('1', "23") := rfl

example : parse digit "abc" = none := rfl

example : parse (charp 'a') "abc" = some ('a', "bc") := rfl

example : parse (charp 'a') "123" = none := rfl

def list_char_parser : list char → Parser string
  | [] := return ""
  | (x::xs) := do charp x,
                  list_char_parser xs,
                  return ⟨x :: xs⟩

def stringp (s : string) : Parser string := list_char_parser (s.to_list)

example : parse (stringp "abc") "abcdef" = some ("abc", "def") := rfl

example : parse (stringp "abc") "ab1234" = none := rfl

/-
Repetition
-/

def once (p : Parser α) : Parser (list α) :=
  P (λ inp, match parse p inp with
              | none := none
              | some (v, out) := some ([v], out)
            end )

def one_or_zero (p : Parser α) : Parser (list α) :=
  P (λ inp, match parse p inp with
              | none := some ([], inp)
              | some (v, out) := some ([v], out)
            end )

example : parse (one_or_zero digit) "a123" = some ([], "a123") := rfl

example : parse (one_or_zero digit) "123" = some (['1'], "23") := rfl

/-
`n_or_less p n` succeeds if `n` or fewer applications of `p` succeed. Else it fails.
-/
def n_or_less (p : Parser α) : ℕ → Parser (list α)
  | 0 := return []
  | (n+1) := do x <- p,
                xs ← n_or_less n,
                return (x :: xs)

example : parse (n_or_less lower 600000) "gihanIIHAN" = none := rfl

example : parse (n_or_less lower 4) "gihanIIHAN" = some (['g', 'i', 'h', 'a'], "nIIHAN") := rfl

/-
`many p` does `p` repeatedly until failure. It always succeeds.
It's a `meta def` as it uses unbounded recursion.
The Lean parser module gets around this by using a natural number to store the position in the string.

Note: Graham Hutton used mutual recursion to define `many` and `many1`. I didn't choose this
approach as Lean 3 has limited support for mutual recursion.
-/
meta def many (p : Parser α) : Parser (list α) :=
  (do x ← p, xs ← many, return (x :: xs)) <|> return []

#eval parse (many digit) "754asdf"

#eval parse (many digit) "abc" -- succeeds and returns the empty list.

/-
`many1 p` is like `many` except that it will fail if `p` doesn't succeed at least once.
-/
meta def many1 (p : Parser α) : Parser (list α) :=
  (do x ← p, xs ← many p, return (x :: xs)) <|> failure

/-
`many_many b` acts as `many` if `b = tt` and as `many1` if `b = ff`.
-/

/- inductive less_than_or_equal (a : ℕ) : ℕ → Prop
| refl : less_than_or_equal a
| step : Π {b}, less_than_or_equal b → less_than_or_equal (succ b) -/

/- inductive opt_rel : option (α × string) → option (α × string) → Prop
| none_lt_some  -/

def opt_rel : option (α × string) → option (α × string) → Prop
  | none (some (_,_)) := true
  | (some (v1, inp1)) (some (v2, inp2)) := inp1.length < inp2.length
  | _ _ := false

lemma not_none_lt_none : @opt_rel α none none = false := rfl

lemma not_some_lt_none (v : α) (inp : string) : @opt_rel α (some (v, inp)) none = false := rfl

lemma some_lt_some {v1 v2 : α} {inp1 inp2 : string} (h : opt_rel (some (v1,inp1)) (some (v2,inp2))) :
  inp1.length < inp2.length := h

lemma not_lt_none (r : option (α × string)) : ¬ (opt_rel r none) :=
begin
  intro h,
  rcases r with _ | ⟨v, inp⟩,
  { cases h, },
  { rw not_some_lt_none v inp at h, exact h, },
end

lemma nat.lt_wf' : well_founded nat.lt := well_founded.intro $
begin
  intro a,
  induction a with n ih,
  { refine acc.intro 0 _,
    intros n h,
    exfalso,
    apply nat.not_lt_zero n, exact h, },
    /-
    case nat.succ
    α : Type,
    n : ℕ,
    ih : ∀ (inp : string) (v : α), inp.length = n → acc opt_rel (some (v, inp)),
    inp : string,
    v : α,
    hl : inp.length = n.succ
    ⊢ acc opt_rel (some (v, inp))
    -/
  { refine acc.intro (n+1) _,
    intros m h,
    cases (nat.eq_or_lt_of_le (nat.le_of_succ_le_succ h)) with e h₂,
    { rw e, exact ih, },
    { exact acc.inv ih h₂, }, }
end

lemma acc_opt_rel_none : acc (@opt_rel α) none :=
begin
  refine acc.intro none _,
  intros n h,
  exfalso,
  exact not_lt_none n h
end

lemma string_succ {s : string} {n : ℕ} (h : s.length = n.succ) : ∃ x xs, s = (x :: xs).as_string :=
begin
  let sl := s.to_list,
  have h₁ : sl.length = n.succ,
  { rw s.length_to_list, exact h, },
  rcases (s.to_list).exists_of_length_succ h₁ with ⟨x, xs, h₂⟩,
  use [x, xs],
  rw [←h₂, s.as_string_inv_to_list],
end

lemma acc_opt_rel_some (n : ℕ) : ∀ (inp : string) (v : α),
  inp.length < n → acc opt_rel (some (v, inp)) :=
begin
  induction n with n ih,
  { intros inp v hl,
    refine acc.intro (some (v, inp)) _,
    intros x h,
    rcases x with _ | ⟨v', inp'⟩,
    { exact acc_opt_rel_none, },
    { have h₂ := some_lt_some h, exfalso, refine nat.not_lt_zero _ hl, }, },
  { intros inp v hl,
    refine acc.intro (some (v, inp)) _,
    intros m h,
    rcases m with _ | ⟨v', inp'⟩,
    { exact acc_opt_rel_none, },
    { cases (nat.eq_or_lt_of_le (nat.le_of_succ_le_succ hl)) with e h₂,
      sorry,
      sorry,
     },
   },
end

/- lemma acc_opt_rel_some (n : ℕ) : ∀ (inp : string) (v : α),
  inp.length = n → acc opt_rel (some (v, inp)) :=
begin
  induction n with n ih,
  { intros inp v hl,
    refine acc.intro (some (v, inp)) _,
    intros x h,
    rcases x with _ | ⟨v', inp'⟩,
    { exact acc_opt_rel_none, },
    { have h₂ := some_lt_some h, rw hl at h₂, exfalso, refine nat.not_lt_zero _ h₂, }, },
  { intros inp v hl,
    refine acc.intro (some (v, inp)) _,
    intros m h,
    rcases m with _ | ⟨v', inp'⟩,
    { exact acc_opt_rel_none, },
    { rcases string_succ hl with ⟨x, xs, h₂⟩,
      have h₃ : (x :: xs).as_string.length = n.succ, { rw [←h₂, hl], },
      have h₄ : xs.as_string.length = n,
      { simp only [nat.succ_eq_add_one, list.length_as_string, add_left_inj, list.length] at h₃ ⊢,
        exact h₃, },
      have h₅ : inp'.length < inp.length := some_lt_some h,
      rw h₂ at h₅, simp only [list.length_as_string, list.length] at h₅,
      cases (nat.eq_or_lt_of_le (nat.le_of_succ_le_succ h₅)) with e h₆,
      { apply ih, rw [e, ←h₄], simp,  },
      sorry,
     },
   },
end -/

example : well_founded (@opt_rel α) := well_founded.intro $
begin
  rintro (_ | ⟨v, inp⟩),
  { exact acc_opt_rel_none, },
  {
    sorry,
   },
end

example : well_founded (@opt_rel α) := well_founded.intro $
begin
  rintro (_ | ⟨v, inp⟩),
  { exact acc_opt_rel_none, },
  { rw ←inp.as_string_inv_to_list,
    induction' p : inp.to_list with x xs ih,
    { refine acc.intro (some (v, [].as_string)) _,
      intros x h, -- maybe use rintro?
      rcases x with _ | ⟨v', inp'⟩,
      { exact acc_opt_rel_none, },
      { cases h, }, },
    { refine acc.intro (some (v, (x :: xs).as_string)) _,
      intros m h,
      rcases m with _ | ⟨v', inp'⟩,
      { exact acc_opt_rel_none, },
      { /- have h₂ : inp'.length < (x :: xs).as_string.length := some_lt_some h,
        simp only [list.length_as_string, list.length] at h₂, -/
        cases (nat.eq_or_lt_of_le (nat.le_of_succ_le_succ h)) with e h₂,
        { specialize ih v' inp', sorry, },
        { sorry, }
       }

      }

   },
end

example : @well_founded (ℕ) (nat.lt) :=
well_founded.intro (λ x, acc.intro x (λ y h, (acc.intro y (λ z p, sorry))))

example : @well_founded (option (α × string)) (@opt_rel α) :=
well_founded.intro (λ x, acc.intro x (λ y h, sorry))

meta def many_many1 : bool → Π (p : Parser α) (h : consumes' p), Parser (list α)
| tt (P p) := λ h, P (λ inp, parse (many_many1 ff (P p) h <|> return []) inp)
| ff (P p) := λ h, P (λ inp, parse  (do v ← (P p),
                                        vs ← many_many1 tt (P p) h,
                                        return (v :: vs)) inp)

#eval parse (many1 digit) "754asdf"

#eval parse (many1 digit) "abc" -- fails

meta def identc : Parser (list char) :=
  do  x ← lower,
      xs ← many alphanum,
      return (x :: xs)

meta def ident : Parser string := do xs ← identc, return ⟨xs⟩

#eval parse ident "abc343[]!!" -- returns "abc343"

#eval parse ident "121abc343[]!!" -- fails

/-
`char_to_nat c` converts the character `c` to a corresponding `ℕ`.
As Lean functions are total, we choose to convert `c` to `0` if `c` is not a digit.
-/
def char_to_nat : char → ℕ
  | '0' := 0
  | '1' := 1
  | '2' := 2
  | '3' := 3
  | '4' := 4
  | '5' := 5
  | '6' := 6
  | '7' := 7
  | '8' := 8
  | '9' := 9
  | _ := 0

-- Converts a list of digits (in 'big-endian' order) into a natural number.
def list_nat_to_nat : list ℕ → ℕ
  | [] := 0
  | (x :: xs) := x + 10 * list_nat_to_nat xs

example : list_nat_to_nat [1,9,4] = 491 := rfl

def list_char_to_nat (xs : list char) : ℕ :=
  list_nat_to_nat (list.map char_to_nat (list.reverse xs))

example : list_char_to_nat ['1','2','3'] = 123 := rfl

-- Recall non-digit chars are converted to `0`:
example : list_char_to_nat ['1','p', '3'] = 103 := rfl

meta def natp : Parser ℕ :=
  do  xs ← many1 digit,
      return (list_char_to_nat xs)

#eval parse natp "4563bob" -- gets `4563` as a natural number

meta def intp : Parser ℤ :=
  (do  charp '-',
      n ← natp,
      return (-n))
  <|> do n ← natp, return n

#eval parse intp "132bob"

#eval parse intp "-123bob"

meta def space : Parser unit := do many is_space, return ()

#eval parse space " ▸  ¬ fish" -- consumes the whitespace, returning `star`.

meta def token (p : Parser α) : Parser α :=
  do  space,
      v ← p,
      space,
      return v

#eval parse (token natp) "    123" -- returns the natural number `123`

meta def identifier : Parser string := token ident

#eval parse identifier "   gill   sdfd"

meta def natural : Parser ℕ := token natp

#eval parse natural "   1232"

meta def symbol (xs : string) : Parser string := token (stringp xs)

#eval parse (symbol "hema") "   hema"

meta def test_parser1 : Parser (list ℕ) :=
  do  symbol "[",
      n ← natural,
      ns ← many (do symbol ",", natural),
      symbol "]",
      return (n :: ns)

#eval parse test_parser1 "  [1,2,  3 ] rubbish" -- returns `[1, 2, 3] : list ℕ`.

end parser
end exlean