import data.real.basic
import data.set
import tactic
-- import exercices_espaces_metriques
open push_neg

namespace tactic.interactive
open lean.parser tactic interactive
open interactive (loc.ns)
open interactive.types
open tactic expr
local postfix *:9001 := many -- sinon ne comprends pas ident*

/- décompose en premier caractère, reste  INUTILISE-/
def un_car : string → string × string
| ⟨(x :: xs)⟩  := ( ⟨ [x] ⟩ , ⟨ xs ⟩ )
| _ := ("","")

def deux_car : string → string
| ⟨(x ::  y :: xs)⟩  := ⟨ [x,y] ⟩
| _ := ""

def trois_car : string → string
| ⟨(x ::  y :: z ::xs)⟩  := ⟨ [x,y,z] ⟩
| _ := ""

/- décompose une chaine de caractères selon la première parenthèse ouvrante
Le premier terme ne sert qu'à la récursivité  INUTILISE-/
meta def debut_chaine : string × string → string × string
| (s , t ) := do
    let d := un_car t,
    match d  with
        | ("(",reste) :=  (s,t)
        | ( ⟨(x)⟩, reste) :=  (debut_chaine (s ++ d.1, reste ))
        -- | _ := ("ERREUR", "")
        end

-- set_option trace.eqn_compiler.elim_match true
-- ne fonctionne pas : le "Prop" est ignoré, ou bien tout est Prop ??
-- meta def is_prop : expr →  bool
--     | `(%%e : Prop) := tt
   --  | _             := ff

-- détermine si l'expression est une propriété
-- basé sur le fait (peut-être optimiste) que si on échoue à trouver le type,
-- c'est qu'il y a des variables libres,
-- et donc que c'est une propriété

-- test if expr is semantically an implication or a function
-- (as opposed to a "∀" expression )
meta def is_arrow' : expr → tactic bool
| `(%%P → %%Q) := if has_var_idx Q 0 then return ff else return tt
| _ := return ff

meta def instanciate (e : expr) : tactic expr :=
match e with
| (pi pp_name binder type body) := do
    a ← mk_local' pp_name binder type,
    return $ instantiate_var body a
| (lam pp_name binder type body) := do
    a ← mk_local' pp_name binder type,
    return $ instantiate_var body a
| _ := return e
end

meta def instanciate' (e : expr) : tactic (expr × expr) :=
match e with
| (pi pp_name binder type body) := do
    a ← mk_local' pp_name binder type,
    let inst_body := instantiate_var body a,
    return (a , inst_body)
| (lam pp_name binder type body) := do
    a ← mk_local' pp_name binder type,
    let inst_body := instantiate_var body a,
    return (a , inst_body)
| _ := return (e, e)
end

open tactic
example : true :=
by do e ← to_expr ```(∀ y : ℕ, ∀ x : ℕ, y = x), (es, tgt) ← mk_local_pis e, trace e, trace es, trace tgt

/- Décompose la racine d'une expression (un seul pas)
 LOGICS : ET, OU, SSI, QUELQUESOIT, IMPLIQUE, FONCTION, NON, EXISTE,
SETS: INTER, UNION, INCLUS, APPARTIENT, COMPLEMENTAIRE1,s IMAGE_ENSEMBLE, IMAGE_RECIPROQUE,
EGALITE, ENSEMBLE1, APPLICATION
NUMBERS: -/
private meta def analyse_expr_step  (e : expr) : tactic (string × (list expr)) :=
do  S ←  (tactic.pp e), let e_joli := to_string S,
match e with
| (lam name binder type body)          := return ("lambda[" ++ to_string name ++ "]", [type,body]) -- name → binder_info → expr → expr → expr
------------------------- LOGIQUE -------------------------
| `(%%p ∧ %%q) := return ("PROP_AND", [p,q])
| `(%%p ∨ %%q) := return ("PROP_OR", [p,q])
| `(%%p ↔ %%q) := return ("PROP_IFF", [p,q])
| `(¬ %%p) := return ("PROP_NOT", [p])
| `(%%p → false)  := return ("PROP_NOT", [p])
| (pi name binder type body) := do is_arr ←  (is_arrow' e),
    if is_arr then do is_p ← tactic.is_prop e,
                    if is_p then return ("PROP_IMPLIES", [type,body])
                        else return ("FUNCTION", [type,body])
     else do (var_, inst_body) ← instanciate' e,
               return ("QUANT_∀", [var_, type, inst_body])
| `(Exists %%p) := do match p with          --  améliorer : cas d'une prop, mais attention aux variables !!
    | (lam name binder type body) :=
    -- la suite teste s'il s'agit de l'existence d'un objet ou d'une propriété
        -- d'abord, si `body` contient des variables libres, c'est une propriété
        -- if type.has_var then return ("EXISTE[PROP:" ++ to_string name ++ "]", [type,body])
        -- si ce n'est pas le cas, on peut chercher son type, et voir si c'est Prop
        -- else do type_type ← infer_type type,
            -- if type_type = `(Prop)
            do (var_, inst_body) ← instanciate' p,
                is_p ← is_prop type, if is_p
                then return ("PROP_∃", [var_, type, inst_body])
                else return ("QUANT_∃", [var_, type, inst_body])
    |  _ := return ("ERROR", [])
    end
------------------------- THEORIE DES ENSEMBLES -------------------------
| `(%%A ∩ %%B) := return ("SET_INTER", [A,B])
| `(%%A ∪ %%B) := return ("SET_UNION", [A,B])
| `(set.compl %%A) := return ("SET_COMPLEMENT", [A])
| `(%%A \ %%B) := return ("SET_SYM_DIFF", [A,B])
| `(%%A ⊆ %%B) := return ("PROP_INCLUDED", [A,B])
| `(%%a ∈ %%A) := return ("PROP_BELONGS", [a,A])
| `(@set.univ %%X) := return ("SET_UNIVERSE", [X])
| `(-%%A) := return ("MINUS", [A])
| `(set.Union %%A) := return ("SET_UNION+", [A])
| `(set.Inter %%A) := return ("SET_INTER+", [A])
| `(%%f '' %%A) := return ("SET_IMAGE", [f,A])
| `(%%f  ⁻¹' %%A) := return ("SET_INVERSE", [f,A])
| `(∅) := return ("SET_EMPTY", [])
| `(_root_.set %%X) := return ("SET", [X])
-- polymorphe
| `(%%a = %%b) := return ("PROP_EQUAL", [a,b]) -- faudrait connaitre le type ?
| `(%%a ≠ %%b) := return ("PROP_EQUAL_NOT", [a,b]) -- faudrait connaitre le type ?
----------- TOPOLOGY --------------
-- | `(B(%%x, %%r))

---------------------------- NOMBRES particuliers (cf aussi plus bas)
| `(0:ℝ) := return ("NUMBER[0]",[])               -- OK, mais peut-être faut-il garder l'info 0 : réel
| `(0:ℕ) := return ("NUMBER[0]",[])               -- non testé
| `(0:ℤ) := return ("NUMBER[0]",[])               -- non testé
| `(1:ℝ) := return ("NUMBER[1]",[])
| `(1:ℕ) := return ("NUMBER[1]",[])               -- non testé
| `(1:ℤ) := return ("NUMBER[1]",[])               -- non testé
-- | `(0 < %%b) := return ("POSITIF", [b])
| `(%%a < %%b) := return ("PROP_<", [a,b])
| `(%%a ≤ %%b) := return ("PROP_≤", [a,b])
-- | `(%%a > 0) := return ("POSITIF", [a])
| `(%%a > %%b) := return ("PROP_>", [a,b])
| `(%%a ≥ %%b) := return ("PROP_≥", [a,b])
------------------------------ Meta_applications

| (app fonction argument)   := -- do let Sfonction := to_string(fonction),
    -- pour les nombres, utiliser la pretty printer de Lean
    -- récupérer le type ?
    if is_numeral e
        then return ("NUMBER["++e_joli ++"]",[])
    -- détecter les sous-ensembles
--    else if to_string(fonction) = "set.{0}"
--        then return("SET", [argument])
--        else return("META_APPLICATION[[pp:" ++ e_joli ++"]]",[fonction,argument])
        else return("APPLICATION",[fonction,argument])
| `(ℝ) := return ("TYPE_NUMBER[ℝ]",[])
| `(ℕ) := return ("TYPE_NUMBER[ℕ]",[])
| (const name list_level)   := return ("CONSTANT[name:"++ e_joli ++ "/" ++ to_string name ++"]", []) -- name → list level → expr
| (var nat)       := return ("VAR["++ to_string nat ++ "]", []) --  nat → expr
| (sort level)      := return ("TYPE", [])  -- level → expr
| (mvar name pretty_name type)        := return ("METAVAR[" ++ to_string pretty_name ++ "]", []) -- name → name → expr → expr
| (local_const name pretty_name bi type) := return ("LOCAL_CONSTANT[name:"++ to_string pretty_name++"/identifier:"++ to_string name ++ "]", []) -- name → name → binder_info → expr → expr
| (elet name_var type_var expr body)        := return ("LET["++ to_string name_var ++"]", [type_var,expr,body]) --name → expr → expr → expr → expr
| (macro liste pas_compris)       := return ("MACRO", []) -- macro_def → list expr → expr
end

-- A node will be a leaf of the analysis tree iff it belongs to the following list:
-- leaves = ["NOMBRE", "CONSTANT", "VAR", "TYPE", "METAVAR", "LOCAL_CONSTANT",
--          "LET", "MACRO", "ERREUR"]
-- A leaf is followed by a separateur_virgule or a ")"
-- A node which is not a leaf is followed by a "("

def separateur_virgule := "¿, "
def separateur_egale := " ¿= "
def open_paren := "¿("
def closed_paren := "¿)"
/- Analyse récursivement une expression à l'aide de analyse_expr_step,
renvoie le résultat sous forme de chaine bien parenthésée-/
private meta def analyse_rec : expr →  tactic string
| e :=
do ⟨string, liste_expr⟩ ←  analyse_expr_step(e),
--    bool ← is_prop e,
--    let string := to_string bool ++ "." ++ string,
    match liste_expr with
    -- ATTENTION, cas de plus de trois arguiments non traité
    -- à remplacer par un list.map
    |[e1] :=  do
       string1 ← analyse_rec e1,
       return(string ++ open_paren ++ string1 ++ closed_paren)
    |[e1,e2] :=  do
        string1 ← analyse_rec e1,
        string2 ← analyse_rec e2,
--        if  string = "APPLICATION"
--            then return (string1 ++ open_paren ++ string2 ++ closed_paren) else
        return (string ++ open_paren ++ string1 ++ separateur_virgule ++ string2 ++ closed_paren)
    |[e1,e2,e3] :=  do  -- non utilisé
        string1 ← analyse_rec e1,
        string2 ← analyse_rec e2,
        string3 ← analyse_rec e3,
        return (string ++ open_paren ++ string1 ++ separateur_virgule ++ string2 ++ separateur_virgule ++ string3 ++ closed_paren)
    | _ :=    return(string)
    end
private meta def analyse_expr : expr →  tactic string
| e := do
    expr_t ←  infer_type e,
    bool ← is_prop expr_t,
    -- expr_tt ← infer_type expr_t,
    if bool then do
            -- S ←  (tactic.pp expr_t),
            -- let S1 := to_string S,
            S ←  (tactic.pp expr_t), let et_joli := to_string S,
            S1b ← analyse_rec e,
            S2 ← analyse_rec expr_t,
            let S3 := "PROPERTY[" ++ S1b ++ "/pp_type: " ++ et_joli ++ "]" ++ separateur_egale ++ S2,
            return(S3)
        else  do
            -- let S1 :=  to_string e,
            S1b ← analyse_rec e,
            S2 ← analyse_rec expr_t,
            let S3 := "OBJECT[" ++ S1b ++ separateur_egale ++ S2,
            return(S3)

/- Affiche la liste des objets du contexte, séparés par des retour chariots
format :  "OBJET" ou "PROPRIETE" : affichage Lean : structure -/
meta def analyse_contexte : tactic unit :=
do liste_expr ← local_context,
    trace "context:",
    liste_expr.mmap (λ h, analyse_expr h >>= trace),
    return ()

/- Affiche la liste des buts, même format que analyse_contexte
(excepté qu'il n'y a que des PROPRIETES) -/
meta def analyse_buts : tactic unit :=
do liste_expr ← get_goals,
    trace "goals:",
    liste_expr.mmap (λ h, analyse_expr h >>= trace),
    return ()

---------------------------------------------------------
--------- NON UTILISES (debuggage) ----------------------------------
---------------------------------------------------------

/- Appelle l'analyse récursive sur le but ou sur une hypothèse. Non utilisé par la suite. -/
meta def analyse (names : parse ident*) : tactic unit :=
match names with
    | [] := do goal ← tactic.target,
                trace (analyse_rec goal)
    | [nom] := do expr ← get_local nom,
                expr_t ←  infer_type expr,
                expr_tt ← infer_type expr_t,
                -- la suite différencie selon la sémantique,
                -- ie les objets (éléments, ensembles, fonctions)
                -- vs les propriétés
                if expr_tt = `(Prop) then
                    trace (analyse_rec expr_t)
                else  do S1 ← (analyse_rec expr),
                        S2 ← (analyse_rec expr_t),
                        --let S2 := to_string expr_t,
                        let S3 := S1 ++ " : "++ S2,
                        trace(S3)
    | _ := skip
    end

/- Appelle l'analyse en 1 coup sur le but ou sur une hypothèse. Non utilisé par la suite. -/
meta def analyse1 (names : parse ident*) : tactic unit :=
match names with
    | [] := do goal ← tactic.target,
                trace (analyse_expr_step goal)
    | [nom] := do expr ← get_local nom,
                expr_t ←  infer_type expr,
                trace (analyse_expr_step expr_t)
    | _ := skip
    end

-- non utilisé
private meta def analyse_expr2 : expr →  tactic string
| e := do
    expr_t ←  infer_type e,
    expr_tt ← infer_type expr_t,
    if expr_tt = `(Prop) then do
            S ←  (tactic.pp expr_t),
            let S1 := to_string S,
            S2 ← analyse_rec expr_t,
            let S3 := "PROPRIETE : " ++ S1 ++ " : " ++ S2,
            return(S3)
        else  do let S0 := "OBJET : ",
            let S1 :=  to_string e,
            S2 ← analyse_rec expr_t,
            let S3 := S0 ++ S1 ++ " : "++ S2,
            return(S3)

---------------------------------------------------------
----------------- Essai de rendu LateX, non abouti ------
---------------------------------------------------------

/- transforme une expression lean en expression latex
AMELIORER :
tenir compte de la profondeur de l'arbre pour décider si on met des prenthèses-/
/- ET, OU, SSI, QUELQUESOIT, IMPLIQUE, FONCTION, NON1, EXISTE,
INTER, UNION, INCLUS, APPARTIENT, COMPLEMENTAIRE1, IMAGE_ENSEMBLE, IMAGE_RECIPROQUE,
EGALITE, ENSEMBLE1, APPLICATION-/
meta def latex_expr : expr →  tactic string
| e := do
    ⟨string, liste_expr⟩ ←  analyse_expr_step e,
    if list.length liste_expr =2 then do
        let e1 := list.head liste_expr,
        let e2 := list.head (list.tail liste_expr),
        S1 ← latex_expr e1,
        S2 ← latex_expr e2,
        match string with
            | "ET" := return (S1 ++ " et " ++ S2)
            | "OU" := return (S1 ++ " ou " ++ S2)
            | "SSI" := return ("(" ++ S1 ++ "" ++") \\Leftrightarrow (" ++ S2 ++ ")")

            | "INCLUS" := return (S1 ++ "" ++" \\subset " ++ S2)
            | _ := return "ERREUR"
            end

    else if list.length liste_expr =1 then do
        let e1 := list.head liste_expr,
        S1 ← latex_expr e1,
        match string with
            | "NON" := return ("NON (" ++ S1 ++ ")")
            | "COMPLEMENTAIRE" := return (S1  ++ "^c")
            | _ := return "ERREUR"
            end
    else return (string)

meta def latex_buts : tactic unit :=
do liste_expr ← get_goals,
    trace "Buts :",
    -- liste_buts ← tactic.get_goals,
    -- types ← list.mmap tactic.infer_type liste_buts,
    -- trace types,
    liste_expr.mmap (λ h, latex_expr h >>= trace),
    return ()

meta def latex_but : tactic unit :=
do expr ← target,
    trace "But :",
    -- liste_buts ← tactic.get_goals,
    -- types ← list.mmap tactic.infer_type liste_buts,
    -- trace types,
    trace (latex_expr expr),
    return ()

----------------------------------------------
------------- DEBUGGAGE -------------------
-------------------------------------------

/- debug -/
private meta def analyse_expr_step_brut  (e : expr) : tactic (string × (list expr)) :=
match e with
-- autres
| (pi name binder type body ) := return ("pi (nom : " ++ to_string name ++ ")",[type,body])
| (app fonction argument)   := return ("application", [fonction,argument])
| (const name list_level)   := return ("constante :" ++ to_string name, []) -- name → list level → expr
| (var nat)       := return ("var_"++ to_string nat, []) --  nat → expr
| (sort level)      := return ("sort", [])  -- level → expr
| (mvar name pretty_name type)        := return ("metavar", []) -- name → name → expr → expr
| (local_const name pretty_name bi type) := return ("constante_locale :" ++ to_string pretty_name, []) -- name → name → binder_info → expr → expr
| (lam name binder type body)          := return ("lambda (nom : " ++ to_string name ++ ")", [type,body]) -- name → binder_info → expr → expr → expr
| (elet name_var type_var expr body)        := return ("let", []) --name → expr → expr → expr → expr
| (macro liste pas_compris)       := return ("macro", []) -- macro_def → list expr → expr
end

/-  Debug -/
private meta def analyse_rec_brut : expr →  tactic string
| e :=
do ⟨string, liste_expr⟩ ←  analyse_expr_step_brut e,
    match liste_expr with
    -- ATTENTION, cas de plus de trois arguiments non traité
    -- à remplacer par un list.map
    |[e1] :=  do
       string1 ← analyse_rec_brut e1,
       return(string ++ "(" ++ string1 ++ ")")
    |[e1,e2] :=  do
        string1 ← analyse_rec_brut e1,
        string2 ← analyse_rec_brut e2,
        if  string = "APPLICATION" then do
            { type2 ← infer_type e2,
            let string_type2 := to_string type2, -- trace string_type2,
            if (string_type2 = "Type" ) ∨ (trois_car (to_string(e2)) = "_in" ) -- Type  ou instance
                then return (string1)
                else return (string1 ++ "(" ++ string2 ++")")
            }   <|> return (string1 ++ "(" ++ string2 ++")")
            else return (string ++ "(" ++ string1 ++ "," ++ string2 ++ ")")
    |[e1,e2,e3] :=  do  -- non utilisé
        string1 ← analyse_rec_brut e1,
        string2 ← analyse_rec_brut e2,
        string3 ← analyse_rec_brut e3,
        return (string ++ "(" ++ string1 ++ "," ++ string2 ++ "," ++ string3 ++ ")")
    | _ :=    return(string)
    end

/- Debug -/
meta def analyse_brut (names : parse ident*) : tactic unit :=
match names with
    | [] := do goal ← tactic.target,
                trace (analyse_rec_brut goal)
    | [nom] := do expr ← get_local nom,
                expr_t ←  infer_type expr,
                expr_tt ← infer_type expr_t,
                -- la suite différencie selon la sémantique,
                -- ie les objets (éléments, ensembles, fonctions)
                -- vs les propriétés
                if expr_tt = `(Prop) then
                    trace (analyse_rec_brut expr_t)
                else  do S1 ← (analyse_rec_brut expr),
                        S2 ← (analyse_rec_brut expr_t),
                        --let S2 := to_string expr_t,
                        let S3 := S1 ++ " : "++ S2,
                        trace(S3)
    | _ := skip
    end

-- débug
private meta def analyse_expr_brut : expr →  tactic string
| e := do
    expr_t ←  infer_type e,
    expr_tt ← infer_type expr_t,
    if expr_tt = `(Prop) then do
            S ←  (tactic.pp expr_t),
            let S1 := to_string S,
            S2 ← analyse_rec_brut expr_t,
            let S3 := "PROPRIETE : " ++ S1 ++ " : " ++ S2,
            return(S3)
        else  do let S0 := "OBJET : ",
            let S1 :=  to_string e,
            S2 ← analyse_rec_brut expr_t,
            let S3 := S0 ++ S1 ++ " : "++ S2,
            return(S3)

/- Affiche la liste des objets du contexte, séparés par des retour chariots
format :  "OBJET" ou "PROPRIETE" : affichage Lean : structure -/
meta def analyse_contexte_brut : tactic unit :=
do liste_expr ← local_context,
    trace "Contexte :",
    liste_expr.mmap (λ h, analyse_expr_brut h >>= trace),
    return ()

/- Analyse brute de Lean (dans expr) -/
meta def analyse_raw (names : parse ident*) : tactic unit :=
match names with
    | [] := do goal ← tactic.target,
                trace $ to_raw_fmt goal
    | [nom] := do expr ← get_local nom,
                expr_t ←  infer_type expr,
                trace $ to_raw_fmt expr_t
    | _ := skip
    end

end tactic.interactive


-- author: Ben Sherman

import galois.network.network_monad

universes u v

lemma fin_inhabited_pos {n : ℕ} (x : fin n)
  : 0 < n
:= begin
apply lt_of_le_of_lt, tactic.swap, apply x.is_lt,
apply nat.zero_le,
end

namespace network

def message_t := list byte

@[reducible]
def socket := remote_name

inductive poll_label : Type
| timeout : poll_label
| receive : time → remote_name → message_t → poll_label

instance poll_label_decidable_eq
  : decidable_eq poll_label
  := by tactic.mk_dec_eq_instance

structure agent_label : Type :=
  (plabel : poll_label)
  (messages : list (remote_name × message_t))

instance agent_label_decidable_eq : decidable_eq agent_label
  := by tactic.mk_dec_eq_instance

inductive receives (P : socket → message_t → Prop) : agent_label → Prop
| mk : ∀ (t : time) (rn : remote_name) (mess : message_t) ms,
       P rn mess → receives (agent_label.mk (poll_label.receive t rn mess) ms)

namespace receives
lemma invert {P : socket → message_t → Prop} {plabel} {ms}
  (H : receives P (agent_label.mk plabel ms)) : (match plabel with
  | poll_label.timeout := false
  | poll_label.receive t rn mess := P rn mess
  end : Prop)
:= begin
induction plabel; cases H,
dsimp, assumption,
end
end receives

inductive timeouts : agent_label → Prop
| mk : ∀ ms, timeouts (agent_label.mk poll_label.timeout ms)

instance timeouts_decidable : decidable_pred timeouts
:= begin
intros x, induction x, induction plabel,
{ apply decidable.is_true, constructor, },
{ apply decidable.is_false, intros contra, cases contra, }
end

inductive receives_or_timeout (P : remote_name → message_t → Prop) (l : agent_label) : Prop
| receives : receives P l → receives_or_timeout
| timeouts : timeouts l -> receives_or_timeout

def receives_message (sock : socket) (mess : message_t) : agent_label → Prop :=
  receives (λ s m, s = sock ∧ m = mess)

namespace poll_result
section poll_result_facts
parameters {ports : list port} {sockets : list socket} {timeout : time}
def to_label  : poll_result ports sockets timeout → poll_label
| poll_result.timeout := poll_label.timeout
| (poll_result.message elapsed sock mess _) :=
   poll_label.receive elapsed.val sock.value mess

lemma receives_bound_pos
  (r : poll_result ports sockets timeout)
  {elapsed : fin timeout} {sock : sockets.member} {mess : message_t}
  {elapsed_gt0 : 0 < elapsed.val}
  (Hr : r = poll_result.message elapsed sock mess elapsed_gt0)
  : 0 < timeout
:= begin
induction r; injection Hr, repeat {subst h },
apply fin_inhabited_pos, assumption
end

end poll_result_facts
end poll_result
end network


import category_theory.full_subcategory
import category_theory.limits.creates
import category_theory.reflects_isomorphisms
import category_theory.limits.preserves.shapes.binary_products
import category_theory.adjunction.fully_faithful
import category_theory.adjunction.limits
import category_theory.closed.cartesian
import cartesian_closed
import power

namespace category_theory

open category_theory category_theory.category category_theory.limits
open classifier

universes v u u₂
noncomputable theory
variables (C : Type u) [category.{v} C]

local attribute [instance] has_finite_products_of_has_finite_limits

class topos :=
[lim : has_finite_limits.{v} C]
[sub : has_subobject_classifier.{v} C]
[cc : cartesian_closed.{v} C]

attribute [instance] topos.lim topos.sub topos.cc

variables [topos.{v} C]

variable {C}

lemma prod_iso_pb {B : C} (f : over B) : prod.functor.obj f = star f ⋙ over.forget _ := rfl

def prod_iso_pb' {B : C} (f : over B) : prod.functor.obj f ≅ real_pullback f.hom ⋙ dependent_sum f.hom :=
calc star f ⋙ over.forget _ ≅ star f ⋙ (over.iterated_slice_equiv _).functor ⋙ (over.iterated_slice_equiv f).inverse ⋙ over.forget _ :
            iso_whisker_left (star f) (iso_whisker_right f.iterated_slice_equiv.unit_iso (over.forget _))
     ... ≅ (star f ⋙ (over.iterated_slice_equiv _).functor) ⋙ ((over.iterated_slice_equiv f).inverse ⋙ over.forget _) : iso.refl _
     ... ≅ (star f ⋙ (over.iterated_slice_equiv _).functor) ⋙ dependent_sum f.hom : iso.refl _
     ... ≅ real_pullback f.hom ⋙ dependent_sum f.hom :
      begin
        refine iso_whisker_right _ (dependent_sum f.hom),
        have : f = over.mk f.hom,
          cases f, congr, apply subsingleton.elim,
        convert iso_pb f.hom,
      end

def prod_iso_pb'' {B : C} (f : over B) : prod.functor.obj f ≅ real_pullback f.hom ⋙ over.map f.hom :=
calc star f ⋙ over.forget _ ≅ star f ⋙ (over.iterated_slice_equiv _).functor ⋙ (over.iterated_slice_equiv f).inverse ⋙ over.forget _ :
           iso_whisker_left (star f) (iso_whisker_right f.iterated_slice_equiv.unit_iso (over.forget _))
     ... ≅ (star f ⋙ (over.iterated_slice_equiv _).functor) ⋙ ((over.iterated_slice_equiv f).inverse ⋙ over.forget _) : iso.refl _
     ... ≅ (star f ⋙ (over.iterated_slice_equiv _).functor) ⋙ dependent_sum f.hom : iso.refl _
     ... ≅ real_pullback f.hom ⋙ dependent_sum f.hom :
      begin
        refine iso_whisker_right _ (dependent_sum f.hom),
        have : f = over.mk f.hom,
          cases f, congr, apply subsingleton.elim,
        convert iso_pb f.hom,
      end

def pullback_sum_iso {X Y Z W : C} {f : X ⟶ Y} {g : X ⟶ Z} {h : Y ⟶ W} {k : Z ⟶ W}
  {comm : f ≫ h = g ≫ k} (t : is_limit (pullback_cone.mk f g comm)) :
  real_pullback g ⋙ over.map f ≅ over.map k ⋙ real_pullback h :=
begin
  apply nat_iso.of_components _ _,
  { intro m,
    apply over_iso _ _,
    { refine ⟨_, _, _, _⟩,
      { apply pullback.lift pullback.fst (pullback.snd ≫ f) _,
        change pullback.fst ≫ _ ≫ k = _,
        simp only [pullback.condition_assoc, assoc, comm] },
      { apply pullback.lift pullback.fst _ _,
        refine (pullback_cone.is_limit.lift' t pullback.snd (pullback.fst ≫ m.hom) _).1,
        rw [← pullback.condition, assoc], refl,
        erw (pullback_cone.is_limit.lift' t pullback.snd (pullback.fst ≫ m.hom) _).2.2 },
      { apply pullback.hom_ext,
        { simp },
        { rw [assoc, id_comp, pullback.lift_snd],
          apply pullback_cone.is_limit.hom_ext t,
          { rw [assoc, (pullback_cone.is_limit.lift' t _ _ _).2.1, pullback.lift_snd], refl },
          { rw [assoc, (pullback_cone.is_limit.lift' t _ _ _).2.2, pullback.lift_fst_assoc,
                pullback.condition], refl } } },
      { apply pullback.hom_ext,
        { simp },
        { rw [id_comp, assoc, pullback.lift_snd, pullback.lift_snd_assoc],
          apply (pullback_cone.is_limit.lift' t _ _ _).2.1 } } },
    { apply pullback.lift_snd } },
  { intros,
    ext1,
    change pullback.lift _ _ _ ≫ pullback.lift _ _ _ = pullback.lift _ _ _ ≫ pullback.lift (pullback.fst ≫ f_1.left) _ _,
    ext1;
    simp }
end

def test' {A B : C} (f : over A) (k : B ⟶ A) :
  over.map k ⋙ prod.functor.obj f ≅ prod.functor.obj ((real_pullback k).obj f) ⋙ over.map k :=
calc over.map k ⋙ prod.functor.obj f ≅ over.map k ⋙ real_pullback f.hom ⋙ over.map f.hom :
              iso_whisker_left (over.map k) (prod_iso_pb'' _)
     ... ≅ real_pullback pullback.snd ⋙ over.map pullback.fst ⋙ over.map f.hom :
              iso_whisker_right (pullback_sum_iso (cone_is_pullback _ _)).symm (dependent_sum f.hom)
     ... ≅ real_pullback pullback.snd ⋙ over.map (_ ≫ f.hom) : iso_whisker_left (real_pullback _) (over_map_comp _ _).symm
     ... ≅ real_pullback pullback.snd ⋙ over.map (pullback.snd ≫ k) : iso_whisker_left (real_pullback _) (by rw pullback.condition)
     ... ≅ real_pullback ((real_pullback k).obj f).hom ⋙ over.map pullback.snd ⋙ over.map k : iso_whisker_left (real_pullback _) (over_map_comp _ _)
     ... ≅ prod.functor.obj ((real_pullback k).obj f) ⋙ over.map k : iso_whisker_right (prod_iso_pb' _).symm (over.map k)

def test {A B : C} (f : over A) (k : B ⟶ A) :
  exp f ⋙ real_pullback k ≅ real_pullback k ⋙ exp ((real_pullback k).obj f) :=
begin
  apply adjunction.right_adjoint_uniq,
  apply adjunction.comp _ _ (radj k) (exp.adjunction _),
  apply adjunction.of_nat_iso_left _ (test' f k).symm,
  apply adjunction.comp _ _ (exp.adjunction _) (radj k),
end

/-- Pullback respects exponentials! (Natural in `g`) -/
def pullback_exp {X Y A B : C} (f g : over A) (k : B ⟶ A) :
  (real_pullback k).obj (f ⟹ g) ≅ (real_pullback k).obj f ⟹ (real_pullback k).obj g :=
(test f k).app g

instance subq_cc (A : C) : cartesian_closed (subq A) :=
@cartesian_closed_of_equiv _ _ (id _) _ _ _ (sub_one_over A).symm (top_cc _)

/-- The bottom of the subobject category. -/
def sub_bot (B : C) : sub B := sub.mk' (initial.to B)
@[simp] lemma sub_bot_left {B : C} : (↑(sub_bot B) : over B).left = ⊥_ C := rfl
@[simp] lemma sub_bot_arrow {B : C} : (sub_bot B).arrow = initial.to B := rfl
def subq_bot (B : C) : subq B := ⟦sub_bot B⟧

instance {B : C} : order_bot (subq B) :=
{ bot := subq_bot B,
  bot_le := quotient.ind
  begin
    intro a,
    refine ⟨sub.hom_mk (initial.to _) _⟩,
    dsimp,
    apply subsingleton.elim
  end,
  ..category_theory.subq.partial_order B }

lemma pullback_bot {A B : C} (f : A ⟶ B) : (subq.pullback f).obj ⊥ = ⊥ :=
begin
  apply quotient.sound,
  symmetry,
  refine ⟨sub.iso_mk _ _⟩,
  refine (as_iso pullback.fst).symm,
  dsimp,
  apply subsingleton.elim,
end

-- local attribute [instance] limits.has_coequalizers_of_has_finite_colimits
local attribute [instance] has_finite_coproducts_of_has_finite_colimits

example (A B : C) (f : A ⟶ B) : regular_epi (factor_thru_image f) := by apply_instance

variables {A B : C}

-- def union' : sub' A → sub' A → sub' A := λ f g,
-- sub'.mk' (image.ι (coprod.desc f.arrow.hom g.arrow.hom))

-- lemma left_le_union' (f g : sub' A) : f ≤ union' f g :=
-- begin
--   refine ⟨_, _⟩,
--   apply coprod.inl ≫ factor_thru_image _,
--   dsimp [union'],
--   rw [assoc, image.fac, coprod.inl_desc],
-- end
-- lemma right_le_union' (f g : sub' A) : g ≤ union' f g :=
-- begin
--   refine ⟨_, _⟩,
--   apply coprod.inr ≫ factor_thru_image _,
--   dsimp [union'],
--   rw [assoc, image.fac, coprod.inr_desc],
-- end

-- lemma union'_le (f g h : sub' A) : f ≤ h → g ≤ h → union' f g ≤ h :=
-- begin
--   rintros ⟨hf, hf₁⟩ ⟨hg, hg₁⟩,
--   refine ⟨_, _⟩,
--   refine image.lift ⟨_, h.arrow.hom, coprod.desc hf hg⟩,
--   apply image.lift_fac,
-- end

-- lemma union'_mono {f₁ f₂ g₁ g₂ : sub' A} : f₁ ≤ f₂ → g₁ ≤ g₂ → union' f₁ g₁ ≤ union' f₂ g₂ :=
-- begin
--   intros hf hg,
--   apply union'_le,
--   apply le_trans hf (left_le_union' _ _),
--   apply le_trans hg (right_le_union' _ _),
-- end

-- def union : sub A → sub A → sub A := quotient.map₂ union'
-- begin
--   rintro f₁ f₂ ⟨hf₁, hf₂⟩ g₁ g₂ ⟨hg₁, hg₂⟩,
--   exact ⟨union'_mono hf₁ hg₁, union'_mono hf₂ hg₂⟩,
-- end

def equiv_to_iff {P Q : Prop} (h : P ≃ Q) : P ↔ Q :=
⟨h.to_fun, h.inv_fun⟩

lemma exp_transpose (a b c : subq A) : a ⊓ b ≤ c ↔ b ≤ (a ⟹ c) :=
begin
  rw ← prod_eq_inter,
  apply equiv_to_iff,
  apply equiv.plift.symm.trans (equiv.ulift.symm.trans (((exp.adjunction a).hom_equiv b c).trans (equiv.ulift.trans equiv.plift))),
end

-- def exist' (f : B ⟶ A) (a : sub' B) : sub' A :=
-- sub'.mk' (image.ι (a.arrow.hom ≫ f))

-- def exist'' (f : B ⟶ A) : sub' B ⥤ sub' A :=
-- preorder_functor (exist' f)
-- begin
--   rintros a₁ a₂ ⟨k, hk⟩,
--   refine ⟨_, _⟩,
--   refine image.lift {I := _, m := image.ι _, e := k ≫ factor_thru_image _, fac' := _},
--   rw [assoc, image.fac, reassoc_of hk],
--   apply image.lift_fac,
-- end

-- def exist (f : B ⟶ A) : sub B ⥤ sub A := lower_functor (exist'' f)

-- def pb_adj (f : B ⟶ A) : exist'' f ⊣ pullback_sub' f
  -- equiv.trans equiv.plift.symm $ equiv.trans equiv.ulift.symm $ equiv.trans ((exp.adjunction a).hom_equiv b c) _
-- begin
--   have : ulift (plift _) ≃ ulift (plift _) := (exp.adjunction a).hom_equiv b c,

-- end

instance : bounded_lattice (subq A) :=
{ ..category_theory.subq.semilattice_inf_top,
  ..category_theory.subq.semilattice_sup,
  ..category_theory.subq.order_bot }

lemma coprod_eq_union {A : C} {f₁ f₂ : subq A} : (f₁ ⨿ f₂) = f₁ ⊔ f₂ :=
begin
  apply le_antisymm,
  apply le_of_hom,
  apply coprod.desc,
  apply hom_of_le,
  apply le_sup_left,
  apply hom_of_le,
  apply le_sup_right,
  apply sup_le,
  apply le_of_hom,
  apply coprod.inl,
  apply le_of_hom,
  apply coprod.inr
end

-- (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z
lemma subq.distrib (x y z : subq A) : x ⊓ (y ⊔ z) ≤ (x ⊓ y) ⊔ (x ⊓ z) :=
begin
  rw [exp_transpose],
  apply sup_le,
  rw [← exp_transpose],
  exact le_sup_left,
  rw [← exp_transpose],
  exact le_sup_right,
end

lemma le_sup_inf_of_inf_sup_le {α : Type*} [lattice α]
  (inf_sup_le : ∀ x y z : α, x ⊓ (y ⊔ z) ≤ (x ⊓ y) ⊔ (x ⊓ z)) :
  ∀ x y z : α, (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ (y ⊓ z) :=
begin
  have : ∀ (x y z : α), x ⊓ (y ⊔ z) = (x ⊓ y) ⊔ (x ⊓ z),
    intros x y z,
    apply le_antisymm (inf_sup_le x y z) (sup_le (inf_le_inf_left x le_sup_left) (inf_le_inf_left x le_sup_right)),
  intros,
  rw this,
  change ((x ⊔ y) ⊓ x) ⊔ ((x ⊔ y) ⊓ z) ≤ x ⊔ (y ⊓ z),
  apply sup_le,
    transitivity x,
      simp,
    simp,
  rw inf_comm,
  rw this,
  apply sup_le_sup,
  apply inf_le_right,
  rw inf_comm,
end

def sub.pullback_image_aux {A' : C} (f : A ⟶ B) (g : A' ⟶ B) :
  (sub.pullback f).obj (sub.image.obj (over.mk g)) ≅ sub.image.obj ((real_pullback f).obj (over.mk g)) :=
{ hom := sub.hom_mk (pullback_image _ _).hom (pullback_image_fac _ _),
  inv := sub.hom_mk (pullback_image _ _).inv (pullback_image_inv_fac _ _) }

/-- Image commutes with pullback. -/
def sub.pullback_image (f : A ⟶ B) :
  sub.image ⋙ sub.pullback f ≅ real_pullback f ⋙ sub.image :=
nat_iso.of_components (λ g, sub.pullback_image_aux f _) (by tidy)

/-- Lemma A1.3.3 of the Elephant. -/
def frobenius {A B : C} (f : A ⟶ B) (A' : sub A) (B' : sub B) :
    (sub.intersection.obj ((sub.exists f).obj A')).obj B' ≅
    (sub.exists f).obj ((sub.intersection.obj A').obj ((sub.pullback f).obj B')) :=
begin
  refine sub.iso_mk _ _,
  apply unique_factorise
    ((pullback.snd ≫ A'.arrow) ≫ f)
    (pullback B'.arrow (image.ι (A'.arrow ≫ f))) _ (pullback.fst ≫ B'.arrow) _,
  { apply pullback.lift (pullback.fst ≫ pullback.fst) (pullback.snd ≫ factor_thru_image _) _,
    rw [assoc, pullback.condition, assoc, image.fac],
    apply pullback.condition_assoc },
  { rw pullback.lift_fst_assoc,
    change (pullback.fst ≫ pullback.fst) ≫ B'.arrow = (pullback.snd ≫ A'.arrow) ≫ f,
    erw [assoc, pullback.condition, pullback.condition_assoc, assoc] },
  { apply category_theory.strong_epi_of_regular_epi _,
    apply regular_epi_of_is_pullback_alt _ pullback.snd pullback.snd (factor_thru_image (A'.arrow ≫ f)) _ _,
    apply pullback.lift_snd,
    refine both_pb_to_left_pb _ _ _ _ _ _ _ _ _ (cone_is_pullback _ _) _,
    simp only [pullback.lift_fst],
    have : factor_thru_image (A'.arrow ≫ f) ≫ image.ι (A'.arrow ≫ f) = A'.arrow ≫ f := image.fac _,
    convert left_pb_to_both_pb _ _ _ _ _ _ _ _ _ (cone_is_pullback pullback.snd A'.arrow) (cone_is_pullback B'.arrow f) },
  { erw unique_factorise_hom_comp_image, apply pullback.condition },
end

lemma subq.frobenius {A B : C} (f : A ⟶ B) (A' : subq A) (B' : subq B) :
  (subq.exists f).obj A' ⊓ B' = (subq.exists f).obj (A' ⊓ (subq.pullback f).obj B') :=
quotient.induction_on₂ A' B' $ λ a' b', quotient.sound ⟨frobenius f _ _⟩

instance pb_frob {A B : C} (f : A ⟶ B) (x : subq A) (y : subq B) :
  is_iso (frobenius_map y x (subq.exists_pull_adj f)) :=
{ inv :=
  begin
    refine ⟨⟨_⟩⟩,
    rw [prod_eq_inter, prod_eq_inter, inf_comm, subq.frobenius, inf_comm],
  end }

instance pb_preserves_lim (f : A ⟶ B) : preserves_limits (subq.pullback f) :=
adjunction.right_adjoint_preserves_limits (subq.exists_pull_adj f)

instance pullback_cc (f : A ⟶ B) : cartesian_closed_functor (subq.pullback f) :=
cartesian_closed_of_frobenius_iso (subq.exists_pull_adj f)

lemma subq.pullback_exp (f : A ⟶ B) (x y : subq B) :
  (subq.pullback f).obj (x ⟹ y) = ((subq.pullback f).obj x ⟹ (subq.pullback f).obj y) :=
begin
  apply skel_is_skel,
  have := (category_theory.pullback_cc f).comparison_iso,
  refine @as_iso _ _ _ _ _ (this x y),
end

instance : bounded_distrib_lattice (subq A) :=
{ le_sup_inf := le_sup_inf_of_inf_sup_le subq.distrib,
  ..category_theory.subq.bounded_lattice }

instance : has_compl (subq A) := { compl := λ x, x ⟹ ⊥ }

variables (x y z : subq A)

lemma imp_eq_top_iff_le : (x ⟹ y) = ⊤ ↔ x ≤ y :=
by rw [eq_top_iff, ← exp_transpose, inf_top_eq]

@[simp]
lemma imp_self : (x ⟹ x) = ⊤ :=
by rw [imp_eq_top_iff_le].

lemma classifier_of_pullback {E F A : C} (m : A ⟶ E) (f : F ⟶ E) [mono m] : f ≫ classifier_of m = classifier_of (pullback.snd : pullback m f ⟶ F) :=
begin
  symmetry,
  apply uniquely,
  apply left_right_hpb_to_both_hpb _ has_pullback_top_of_pb (classifies m),
end

lemma class_lift_of_is_iso {A₁ A₂ E : C} {m₁ : A₁ ⟶ E} {m₂ : A₂ ⟶ E} [mono m₁] [mono m₂] (h : A₁ ⟶ A₂) [is_iso h] :
  h ≫ m₂ = m₁ → classifier_of m₁ = classifier_of m₂ :=
begin
  intros k,
  apply uniquely,
  change has_pullback_top _ _ _,
  rw ← id_comp (classifier_of m₂),
  apply left_right_hpb_to_both_hpb m₂,
  apply top_iso_has_pullback_top h,
    simpa,
  apply classifies,
end

lemma class_lift_of_iso {A₁ A₂ E : C} {m₁ : A₁ ⟶ E} {m₂ : A₂ ⟶ E} [mono m₁] [mono m₂] (h : A₁ ≅ A₂) (l : h.hom ≫ m₂ = m₁) :
  classifier_of m₁ = classifier_of m₂ :=
class_lift_of_is_iso h.hom l

lemma class_lift_of_both_factor {A₁ A₂ E : C} {m₁ : A₁ ⟶ E} {m₂ : A₂ ⟶ E} [mono m₁] [mono m₂] (hom : A₁ ⟶ A₂) (inv : A₂ ⟶ A₁) :
  hom ≫ m₂ = m₁ → inv ≫ m₁ = m₂ → classifier_of m₁ = classifier_of m₂ :=
begin
  intros k l,
  apply class_lift_of_iso ⟨hom, inv, _, _⟩ k,
  rw ← cancel_mono m₁, simp [k, l],
  rw ← cancel_mono m₂, simp [k, l],
end

def how_inj_is_classifier {E A₁ A₂ : C} (m₁ : A₁ ⟶ E) (m₂ : A₂ ⟶ E) [mono m₁] [mono m₂]
  (h : classifier_of m₁ = classifier_of m₂) :
A₁ ≅ A₂ :=
{ hom := (pullback_cone.is_limit.lift' (classifies m₂).is_pb (classifies m₁).top m₁ (h ▸ (classifies m₁).comm)).1,
  inv := (pullback_cone.is_limit.lift' (classifies m₁).is_pb (classifies m₂).top m₂ (h.symm ▸ (classifies m₂).comm)).1,
  hom_inv_id' := by erw [← cancel_mono_id m₁, assoc, lift'_right, lift'_right],
  inv_hom_id' := by erw [← cancel_mono_id m₂, assoc, lift'_right, lift'_right] }

lemma c_very_inj {E A₁ A₂ : C} {m₁ : A₁ ⟶ E} {m₂ : A₂ ⟶ E} [mono m₁] [mono m₂] (h : classifier_of m₁ = classifier_of m₂) :
  (how_inj_is_classifier _ _ h).hom ≫ m₂ = m₁ :=
lift'_right _ _ _ _

def get_subobject_obj {B : C} (c : B ⟶ Ω C) : C := pullback (truth C) c
def get_subobject {B : C} (c : B ⟶ Ω C) : get_subobject_obj c ⟶ B := pullback.snd
instance get_subobject_mono {B : C} (c : B ⟶ Ω C) : mono (get_subobject c) := pullback.snd_of_mono

lemma classify_inv {E : C} (c : E ⟶ Ω C) : classifier_of (get_subobject c) = c :=
(uniquely _ _ has_pullback_top_of_pb)

set_option pp.universes false

@[simps]
def classification {B : C} : (B ⟶ Ω C) ≃ subq B :=
{ to_fun := λ k, ⟦sub.mk' (get_subobject k)⟧,
  inv_fun :=
  begin
    refine quotient.lift (λ (k : sub B), _) _,
    exact classifier_of k.arrow,
    rintro a₁ a₂ ⟨⟨k₁, k₂, _, _⟩⟩,
    apply class_lift_of_both_factor _ _ (sub.w k₁) (sub.w k₂),
  end,
  left_inv := λ k, classify_inv k,
  right_inv := quotient.ind
  begin
    intro k,
    apply quotient.sound,
    refine equiv_of_both_ways
      (sub.hom_mk _ ((classifies k.arrow).is_pb.fac _ walking_cospan.right))
      (sub.hom_mk _ (pullback.lift_snd _ _ (classifies k.arrow).comm)),
  end }

abbreviation classify {B : C} : subq B → (B ⟶ Ω C) := classification.symm

lemma classify_eq_iff_eq {B : C} (m n : subq B) : classify m = classify n ↔ m = n :=
classification.right_inv.injective.eq_iff

lemma classify_pullback {B B' : C} (f : B ⟶ B') :
  ∀ m, classify ((subq.pullback f).obj m) = f ≫ classify m :=
quotient.ind $ by { intro m, exact (classifier_of_pullback _ _).symm }

lemma classification_natural_symm {B B' : C} (f : B ⟶ B') (c : B' ⟶ Ω C) :
  classification (f ≫ c) = (subq.pullback f).obj (classification c) :=
begin
  rw [← classification.eq_symm_apply],
  change _ = classify _,
  rw [classify_pullback],
  congr',
  symmetry,
  apply classification.symm_apply_apply c,
end
-- def indicators {B : C} (m : B ⟶ Ω C) (n : B ⟶ Ω C) : B ⟶ Ω C :=
-- classify (classification m ⊓ classification n)

-- def indicators_natural {B B' : C} (f : B' ⟶ B) (m : B ⟶ Ω C) (n : B ⟶ Ω C) :
--   f ≫ indicators m n = indicators (f ≫ m) (f ≫ n) :=
-- begin
--   dunfold indicators,
--   rw [classification_natural_symm, classification_natural_symm, ← intersect_pullback,
--       classification.eq_symm_apply, classification_natural_symm, classification.apply_symm_apply],
-- end

-- variable (C)
-- def and_arrow : Ω C ⨯ Ω C ⟶ Ω C := indicators limits.prod.fst limits.prod.snd
-- variable {C}h

/-- Complement commutes with pullback. -/
lemma compl_natural (m : subq B) (f : A ⟶ B) : (subq.pullback f).obj mᶜ = ((subq.pullback f).obj m)ᶜ :=
by { erw [subq.pullback_exp, pullback_bot], refl }

def neg_arrow_aux (m : B ⟶ Ω C) : B ⟶ Ω C :=
classify (classification m)ᶜ

lemma neg_arrow_aux_natural {B B' : C} (f : B' ⟶ B) (m : B ⟶ Ω C) :
  f ≫ neg_arrow_aux m = neg_arrow_aux (f ≫ m) :=
begin
  rw [neg_arrow_aux, neg_arrow_aux, classification.eq_symm_apply, classification_natural_symm,
      classification_natural_symm, classification.apply_symm_apply, compl_natural],
end

variable (C)
def not : Ω C ⟶ Ω C := neg_arrow_aux (𝟙 _)
variable {C}

lemma not_prop (f : subq B) : classify fᶜ = classify f ≫ not C :=
by rw [not, neg_arrow_aux_natural, comp_id, neg_arrow_aux, classification.apply_symm_apply]

end category_theory


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

The Kleisli construction on the Type category

TODO: generalise this to work with category_theory.monad
-/
import category_theory.category

universes u v

namespace category_theory

def Kleisli (m) [monad.{u v} m] := Type u

def Kleisli.mk (m) [monad.{u v} m] (α : Type u) : Kleisli m := α

instance Kleisli.category_struct {m} [monad m] : category_struct (Kleisli m) :=
{ hom := λ α β, α → m β,
  id := λ α x, (pure x : m α),
  comp := λ X Y Z f g, f >=> g }

instance Kleisli.category {m} [monad m] [is_lawful_monad m] : category (Kleisli m) :=
by refine { hom := λ α β, α → m β,
            id := λ α x, (pure x : m α),
            comp := λ X Y Z f g, f >=> g,
            id_comp' := _, comp_id' := _, assoc' := _ };
   intros; ext; simp only [(>=>)] with functor_norm

@[simp] lemma Kleisli.id_def {m} [monad m] [is_lawful_monad m] (α : Kleisli m) :
  𝟙 α = @pure m _ α := rfl

lemma Kleisli.comp_def {m} [monad m] [is_lawful_monad m] (α β γ : Kleisli m)
  (xs : α ⟶ β) (ys : β ⟶ γ) (a : α) :
  (xs ≫ ys) a = xs a >>= ys := rfl

end category_theory


import ExtParser.AST
namespace Parsing
  open AST
  open Grammar

  inductive PreAST.TrueToGrammar : PreAST n b → GProd n → PEG n → Prop where
    | skip : TrueToGrammar (.skip s e G) Pexp G
    | ε : TrueToGrammar (.ε s e) Pexp .ε
    | any : TrueToGrammar (.any s e x) Pexp .any
    | terminal : TrueToGrammar (.terminal s e a x) Pexp (.terminal a)
    | nonTerminal : TrueToGrammar T Pexp (Pexp.f A) → TrueToGrammar (.nonTerminal s e A T) Pexp (.nonTerminal A)
    | seq : TrueToGrammar T1 Pexp e1 → TrueToGrammar T2 Pexp e2 → TrueToGrammar (.seq s e T1 T2) Pexp (.seq e1 e2)
    | prior : TrueToGrammar T1 Pexp e1 → TrueToGrammar T2 Pexp e2 → TrueToGrammar (.prior s e T1 T2) Pexp (.prior e1 e2)
    | star : TrueToGrammar T0 Pexp e0 → TrueToGrammar TS Pexp (.star e0) → TrueToGrammar (.star s e T0 TS) Pexp (.star e0)
    | notP : TrueToGrammar T Pexp e0 → TrueToGrammar (.notP s e T) Pexp (.notP e0)

  def AST.TrueToGrammar : AST n b → GProd n → PEG n → Prop := fun T => PreAST.TrueToGrammar T.T

  theorem PreAST.unique_grammar : ∀ {T : PreAST n b} {G1 G2 : PEG n} {Pexp : GProd n}, TrueToGrammar T Pexp G1 → TrueToGrammar T Pexp G2 → G1 = G2 := by
    intro T G1 G2 Pexp h1 h2;
    cases T;
    {cases h1; cases h2; rfl}
    {cases h1; cases h2; rfl}
    {cases h1; cases h2; rfl}
    {cases h1; cases h2; rfl}
    {cases h1; cases h2; rfl}
    {
      match h1, h2 with
      | .seq h11 h12, .seq h21 h22 => rw [unique_grammar h11 h21, unique_grammar h12 h22];
    }
    {
      match h1, h2 with
      | .prior h11 h12, .prior h21 h22 => rw [unique_grammar h11 h21, unique_grammar h12 h22];
    }
    {
      match h1, h2 with
      | .star h11 _, .star h21 h22 => rw [unique_grammar h11 h21];
    }
    {
      match h1, h2 with
      | .notP h11, .notP h21 => rw [unique_grammar h11 h21];
    }

  theorem AST.unique_grammar : ∀ {T : AST n b} {G1 G2 : PEG n} {Pexp : GProd n}, TrueToGrammar T Pexp G1 → TrueToGrammar T Pexp G2 → G1 = G2 := by
    intro T;
    exact PreAST.unique_grammar (T := T.T);

  def Input (b : Nat) := Fin b → Char

  inductive PreAST.TrueToInput : PreAST n b → (inp : Input b) → Prop where
    | skip : TrueToInput (.skip s e G) inp
    | ε : TrueToInput (.ε s e) inp
    | any : inp s = x → TrueToInput (.any s e x) inp
    | terminal : inp s = x → TrueToInput (.terminal s e a x) inp
    | nonTerminal : TrueToInput T inp → TrueToInput (.nonTerminal s e A T) inp
    | seq : TrueToInput T1 inp → TrueToInput T2 inp → TrueToInput (.seq s e T1 T2) inp
    | prior : TrueToInput T1 inp → TrueToInput T2 inp → TrueToInput (.prior s e T1 T2) inp
    | star : TrueToInput T0 inp → TrueToInput TS inp → TrueToInput (.star s e T0 TS) inp
    | notP : TrueToInput T inp → TrueToInput (.notP s e T) inp

  def AST.TrueToInput : AST n b → Input b → Prop := fun T => PreAST.TrueToInput T.T

  theorem AST.unique_input : ∀ {T : AST n b} {inp1 inp2 : Input b}, TrueToInput T inp1 → TrueToInput T inp2 → T.start ≤ i → i < T.end → inp1 i = inp2 i := by
    intro (.mk T valid_T wf_T) inp1 inp2 h1 h2 hstart hend;
    match T with
    | .skip _ _ _ => cases wf_T
    | .ε _ _ => match wf_T with
      | .ε (Or.inl (.ε h)) =>
        {
          simp [AST.start, PreAST.start, AST.end, PreAST.end] at hstart hend;
          rw [h] at hstart; have g : i < i := Nat.lt_of_lt_of_le hend hstart;
          apply absurd g (Nat.lt_irrefl i);
        }
    | .any s e x => match h1, h2 with
      | .any heq1, .any heq2 =>
        {
          simp [AST.start, PreAST.start, AST.end, PreAST.end] at hstart hend;
          match wf_T with
          | .any (Or.inl (.any h)) =>
            {
              match Nat.eq_or_lt_of_le hstart with
              | Or.inl g => simp [←Fin.eq_of_val_eq g, heq1, heq2];
              | Or.inr g =>
                {
                  apply absurd (Fin.val_eq_of_eq h);
                  simp [Fin.inbound_succ];
                  apply Nat.ne_of_lt;
                  exact Nat.lt_of_lt_of_le (Nat.succ_lt_succ g) hend;
                }
            }
          | .any (Or.inr (.any h _)) =>
            {
              rw [h] at hstart;
              apply absurd hstart;
              exact Nat.not_le_of_gt hend;
            }

        }
    | .terminal s e a x => match h1, h2 with
      | .terminal (s := s) (e := e) heq1, .terminal heq2 =>
        {
          simp [AST.start, PreAST.start, AST.end, PreAST.end] at hstart hend;
          match wf_T with
          | .terminal (Or.inl (.terminal h _)) =>
            {
              match Nat.eq_or_lt_of_le hstart with
              | Or.inl g => simp [←Fin.eq_of_val_eq g, heq1, heq2];
              | Or.inr g =>
                {
                  apply absurd (Fin.val_eq_of_eq h);
                  simp [Fin.inbound_succ];
                  apply Nat.ne_of_lt;
                  exact Nat.lt_of_lt_of_le (Nat.succ_lt_succ g) hend;
                }
            }
          | .terminal (Or.inr (.terminal_mismatch h _)) =>
            {
              match Nat.eq_or_lt_of_le hstart with
              | Or.inl g => simp [←Fin.eq_of_val_eq g, heq1, heq2];
              | Or.inr g =>
                {
                  apply absurd (Fin.val_eq_of_eq h);
                  simp [Fin.inbound_succ];
                  apply Nat.ne_of_lt;
                  exact Nat.lt_of_lt_of_le (Nat.succ_lt_succ g) hend;
                }
            }
          | .terminal (Or.inr (.terminal_empty h _)) =>
            {
              rw [h] at hstart;
              apply absurd hstart;
              exact Nat.not_le_of_gt hend;
            }
        }
    | .nonTerminal s e A sub_T => match h1, h2 with
      | .nonTerminal (T := sub_T) h1, .nonTerminal h2 =>
        {
          match valid_T, wf_T with
          | .nonTerminal hv _, .nonTerminal hssT heeT hwf =>
            {
              let T' := AST.mk sub_T hv hwf;
              apply unique_input (T := T') h1 h2;
              rw [AST.start, ←hssT]; exact hstart;
              rw [AST.end, ←heeT]; exact hend;
            }
        }
    | .seq s e T1 T2 => match h1, h2 with
      | .seq h11 h12, .seq h21 h22 =>
        {
          simp [AST.start, PreAST.start, AST.end, PreAST.end] at hstart hend;
          match valid_T, wf_T with
          | .seq hv1 _ _, .seq_F hss1 he1s2 hee2 hs2e2 hwf1 _ _ =>
            {
              let T' := AST.mk T1 hv1 hwf1;
              apply unique_input (T := T') h11 h21;
              rw [AST.start, ←hss1]; exact hstart;
              rw [AST.end, he1s2, hs2e2, ←hee2]; exact hend;
            }
          | .seq hv1 hv2 _, .seq_S hss1 he1s2 hee2 hwf1 _ hwf2 =>
            {
              let T1' := AST.mk T1 hv1 hwf1;
              let T2' := AST.mk T2 hv2 hwf2;
              match Nat.lt_or_ge i (T1.end) with
              | Or.inl g =>
                {
                  apply unique_input (T := T1') h11 h21;
                  simp [AST.start, ←hss1]; exact hstart;
                  exact g;
                }
              | Or.inr g =>
                {
                  apply unique_input (T := T2') h12 h22;
                  simp [AST.start, ←he1s2]; exact g;
                  simp [AST.end, ←hee2]; exact hend;
                }
            }
        }
    | .prior s e T1 T2 => match h1, h2 with
      | .prior h11 h12, .prior h21 h22 =>
        {
          simp [AST.start, PreAST.start, AST.end, PreAST.end] at hstart hend;
          match valid_T, wf_T with
          | .prior hv1 _ _, .prior_S hss1 _ _ hee1 hwf1 _ _ =>
            {
              let T' := AST.mk T1 hv1 hwf1;
              apply unique_input (T := T') h11 h21;
              simp [AST.start, ←hss1]; exact hstart;
              simp [AST.end, ←hee1]; exact hend;
            }
          | .prior _ hv2 _, .prior_F _ hss2 hee2 _ _ hwf2 =>
            {
              let T' := AST.mk T2 hv2 hwf2;
              apply unique_input (T := T') h12 h22;
              simp [AST.start, ←hss2]; exact hstart;
              simp [AST.end, ←hee2]; exact hend;
            }
        }
    | .star s e T0 TS => match h1, h2 with
      | .star h10 h1S, .star h20 h2S =>
        {
          simp [AST.start, PreAST.start, AST.end, PreAST.end] at hstart hend;
          match valid_T, wf_T with
          | .star hv1 hv2 _ _, .star_F _ _ _ hse _ _ _ =>
            {
              rw [hse] at hstart;
              have g : e < e := Nat.lt_of_le_of_lt hstart hend;
              apply absurd g (Nat.lt_irrefl e);
            }
          | .star hv0 hvS _ _, .star_S hss0 he0sS heeS hwf0 _ hwfS =>
            {
              let T0' := AST.mk T0 hv0 hwf0;
              let TS' := AST.mk TS hvS hwfS;
              match Nat.lt_or_ge i (T0.end) with
              | Or.inl g =>
                {
                  apply unique_input (T := T0') h10 h20;
                  simp [AST.start, ←hss0]; exact hstart;
                  exact g;
                }
              | Or.inr g =>
                {
                  apply unique_input (T := TS') h1S h2S;
                  simp [AST.start, ←he0sS]; exact g;
                  simp [AST.end, ←heeS]; exact hend;
                }
            }
        }
    | .notP s e T => match h1, h2 with
      | .notP (T := sub_T) h1, .notP h2 =>
        {
          simp [AST.start, PreAST.start, AST.end, PreAST.end] at hstart hend;
          match valid_T, wf_T with
          | .notP hv _, .notP hse _ _ =>
            {
              rw [hse] at hstart;
              have g : e < e := Nat.lt_of_le_of_lt hstart hend;
              apply absurd g (Nat.lt_irrefl e);
            }
        }

  theorem AST.unique_tree : ∀ {T1 T2 : AST n b} {inp : Input b} {G : PEG n} {Pexp : GProd n},
                            AST.TrueToInput T1 inp → AST.TrueToInput T2 inp →
                            AST.TrueToGrammar T1 Pexp G → AST.TrueToGrammar T2 Pexp G →
                            T1.start = T2.start → T1 = T2 := by
    intro (.mk T1 valid_T1 wf_T1) (.mk T2 valid_T2 wf_T2) inp G Pexp hi1 hi2 hg1 hg2 hstart;
    induction T1 generalizing T2 inp G with
    | skip _ _ _ => cases wf_T1;
    | ε s1 e1 => cases T2 with
      | skip _ _ _ => cases wf_T2;
      | ε s2 e2 =>
      {
        simp [AST.start, PreAST.start] at hstart; simp [hstart];
        match wf_T1, wf_T2 with
        | .ε (Or.inl (.ε h1)), .ε (Or.inl (.ε h2)) => rw [←h1, hstart, h2];
      }
      | _ => cases hg1; cases hg2;
    | any s1 e1 x1 => cases T2 with
      | skip _ _ _ => cases wf_T2;
      | any s2 e2 x2 =>
      {
        simp [AST.start, PreAST.start] at hstart; simp [hstart];
        have hx : x1 = x2 := by
          {
            simp [hstart] at hi1;
            cases hi1; cases hi2;
            apply Eq.trans; apply Eq.symm; assumption; assumption;
          }
        simp [hx];
        match wf_T1, wf_T2 with
        | .any (Or.inl (.any h1)), .any (Or.inl (.any h2)) =>
          {
            simp [hstart] at h1;
            exact Eq.trans (Eq.symm h1) h2;
          }
        | .any (Or.inl (.any h1)), .any (Or.inr (.any h2 hb2)) =>
          {
            rw [←h2, ←hstart, Fin.IsMax] at hb2;
            contradiction;
          }
        | .any (Or.inr (.any h1 hb1)), .any (Or.inl (.any h2)) =>
          {
            rw [←h1, hstart, Fin.IsMax] at hb1;
            contradiction;
          }
        | .any (Or.inr (.any h1 _)), .any (Or.inr (.any h2 _)) =>
          {
            rw [←h1, hstart, h2];
          }
      }
      | _ => cases hg1; cases hg2;
    | terminal s1 e1 a1 x1 => cases T2 with
      | skip _ _ _ => cases wf_T2;
      | terminal s2 e2 a2 x2 =>
      {
        simp [AST.start, PreAST.start] at hstart; simp [hstart];
        have hx : x1 = x2 := by
          {
            simp [hstart] at hi1;
            cases hi1; cases hi2;
            apply Eq.trans; apply Eq.symm; assumption; assumption;
          }
        simp [hx];
        cases hg1; cases hg2; simp;
        match wf_T1, wf_T2 with
        | .terminal (Or.inl (.terminal h1 g1)), .terminal (Or.inl (.terminal h2 g2)) =>
          {
            simp [g1, ←g2];
            apply Fin.eq_of_val_eq;
            simp [←Fin.val_eq_of_eq h1, ←Fin.val_eq_of_eq h2, Fin.inbound_succ];
            exact Fin.val_eq_of_eq hstart;
          }
        | .terminal (Or.inl (.terminal h1 g1)), .terminal (Or.inr (.terminal_mismatch h2 g2)) =>
          {
            rw [hx] at g1;
            contradiction;
          }
        | .terminal (Or.inl (.terminal _ _)), .terminal (Or.inr (.terminal_empty h2 hb2)) =>
          {
            simp [←h2, ←hstart, Fin.IsMax] at hb2;
            contradiction;
          }
        | .terminal (Or.inr (.terminal_mismatch h1 g1)), .terminal (Or.inl (.terminal h2 g2)) =>
          {
            rw [hx] at g1; contradiction;
          }
        | .terminal (Or.inr (.terminal_mismatch h1 _)), .terminal (Or.inr (.terminal_mismatch h2 _)) =>
          {
            apply Fin.eq_of_val_eq;
            simp [←Fin.val_eq_of_eq h1, ←Fin.val_eq_of_eq h2, Fin.inbound_succ];
            exact Fin.val_eq_of_eq hstart;
          }
        | .terminal (Or.inr (.terminal_mismatch _ _)), .terminal (Or.inr (.terminal_empty h2 hb2)) =>
          {
            simp [←h2, ←hstart, Fin.IsMax] at hb2;
            contradiction;
          }
        | .terminal (Or.inr (.terminal_empty h1 hb1)), .terminal (Or.inl (.terminal _ _)) =>
          {
            simp [←h1, hstart, Fin.IsMax] at hb1;
            contradiction;
          }
        | .terminal (Or.inr (.terminal_empty h1 hb1)), .terminal (Or.inr (.terminal_mismatch _ _)) =>
          {
            simp [←h1, hstart, Fin.IsMax] at hb1;
            contradiction;
          }
        | .terminal (Or.inr (.terminal_empty h1 _)), .terminal (Or.inr (.terminal_empty h2 _)) =>
          {
            simp [←h1, hstart, h2];
          }
      }
      | _ => cases hg1; cases hg2;
    | nonTerminal s1 e1 A1 T1 ih => cases T2 with
      | skip _ _ _ => cases wf_T2;
      | nonTerminal s2 e2 A2 T2 =>
      {
        simp [AST.start, PreAST.start] at hstart; simp [hstart];
        match wf_T1, wf_T2, valid_T1, valid_T2 with
        | .nonTerminal hss1 hee1 hwfT1, .nonTerminal hss2 hee2 hwfT2, .nonTerminal hvT1 _ , .nonTerminal hvT2 _ =>
        {
          cases hi1; cases hi2; cases hg1; cases hg2;
          have g : AST.mk T1 hvT1 hwfT1 = AST.mk T2 hvT2 hwfT2 := by
          {
            apply ih; assumption; assumption; assumption; assumption;
            simp [AST.start, ←hss1, ←hss2, hstart];
          }
          cases g; simp [hee1, hee2];
        }
      }
      | _ => cases hg1; cases hg2;
    | seq s1 e1 T11 T21 ih1 ih2 => cases T2 with
      | skip _ _ _ => cases wf_T2;
      | seq s2 e2 T12 T22 =>
      {
        simp [AST.start, PreAST.start] at hstart; simp [hstart];
        match wf_T1, wf_T2 with
        | .seq_F hss11 he11s21 hee21 hs21e21 hwf11 hf11 hskip21, .seq_F hss12 he12s22 hee22 hs22e22 hwf12 hf12 hskip22 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .seq hg11 hg21, .seq hg12 hg22, .seq hv11 _ _, .seq hv12 _ _ =>
            {
              have g1 : AST.mk T11 hv11 hwf11 = AST.mk T12 hv12 hwf12 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss11, ←hss12, hstart];
              }
              cases g1; simp;
              cases hskip21; cases hskip22;
              cases hg21; cases hg22;
              simp [PreAST.start, PreAST.end] at hs21e21 hee21 hs22e22 hee22;
              simp [PreAST.start] at he11s21 he12s22;
              simp [hee21, hee22, ←he11s21, ←he12s22, ←hs21e21, ←hs22e22];
            }
          }
        | .seq_F hss11 he11s21 hee21 hs21e21 hwf11 hf11 _, .seq_S hss12 he12s22 hee22 hwf12 hs12 _ =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .seq hg11 _, .seq hg12 _, .seq hv11 _ _, .seq hv12 _ _ =>
            {
              have g1 : AST.mk T11 hv11 hwf11 = AST.mk T12 hv12 hwf12 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss11, ←hss12, hstart];
              }
              cases g1; simp;
              exact absurd hf11 (hs12.ne_failure (by assumption));
            }
          }
        | .seq_S hss11 he11s21 hee21 hwf11 hs11 _, .seq_F hss12 he12s22 hee22 hs22e22 hwf12 hf12 _ =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .seq hg11 _, .seq hg12 _, .seq hv11 _ _, .seq hv12 _ _ =>
            {
              have g1 : AST.mk T11 hv11 hwf11 = AST.mk T12 hv12 hwf12 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss11, ←hss12, hstart];
              }
              cases g1; simp;
              exact absurd hs11 (hf12.ne_success (by assumption));
            }
          }
        | .seq_S hss11 he11s21 hee21 hwf11 hs11 hwf21, .seq_S hss12 he12s22 hee22 hwf12 hs12 hwf22 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .seq hg11 hg21, .seq hg12 hg22, .seq hv11 hv21 _, .seq hv12 hv22 _ =>
            {
              have g1 : AST.mk T11 hv11 hwf11 = AST.mk T12 hv12 hwf12 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss11, ←hss12, hstart];
              }
              cases g1; simp;
              have g2 : AST.mk T21 hv21 hwf21 = AST.mk T22 hv22 hwf22 := by
              {
                apply ih2; assumption; assumption; assumption; assumption;
                simp [AST.start, ←he11s21, ←he12s22];
              }
              cases g2; simp;
              simp [hee21, hee22];
            }
          }
      }
      | _ => cases hg1; cases hg2;
    | prior s1 e1 T11 T21 ih1 ih2 => cases T2 with
      | skip _ _ _ => cases wf_T2;
      | prior s2 e2 T12 T22 =>
      {
        simp [AST.start, PreAST.start] at hstart; simp [hstart];
        match wf_T1, wf_T2 with
        | .prior_F hss11 hss21 hee21 hwf11 hf11 hwf21, .prior_F hss12 hss22 hee22 hwf12 hf12 hwf22 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .prior hg11 hg21, .prior hg12 hg22, .prior hv11 hv21 _, .prior hv12 hv22 _ =>
            {
              have g1 : AST.mk T11 hv11 hwf11 = AST.mk T12 hv12 hwf12 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss11, ←hss12, hstart];
              }
              have g2 : AST.mk T21 hv21 hwf21 = AST.mk T22 hv22 hwf22 := by
              {
                apply ih2; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss21, ←hss22, hstart];
              }
              cases g1; cases g2; simp;
              simp [hee21, hee22];
            }
          }
        | .prior_F hss11 hss21 hee21 hwf11 hf11 hwf21, .prior_S hss12 hss22 hse22 hee12 hwf12 hs12 hskip22 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .prior hg11 _, .prior hg12 _, .prior hv11 _ _, .prior hv12 _ _ =>
            {
              have g1 : AST.mk T11 hv11 hwf11 = AST.mk T12 hv12 hwf12 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss11, ←hss12, hstart];
              }
              cases g1; simp;
              exact absurd hf11 (hs12.ne_failure (by assumption));
            }
          }
        | .prior_S hss11 hss21 hse21 hee11 hwf11 hs11 hskip21, .prior_F hss12 hss22 hee22 hwf12 hf12 hwf22 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .prior hg11 _, .prior hg12 _, .prior hv11 _ _, .prior hv12 _ _ =>
            {
              have g1 : AST.mk T11 hv11 hwf11 = AST.mk T12 hv12 hwf12 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss11, ←hss12, hstart];
              }
              cases g1; simp;
              exact absurd hs11 (hf12.ne_success (by assumption));
            }
          }
        | .prior_S hss11 hss21 hse21 hee11 hwf11 hs11 hskip21, .prior_S hss12 hss22 hse22 hee12 hwf12 hs12 hskip22 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .prior hg11 hg21, .prior hg12 hg22, .prior hv11 hv21 _, .prior hv12 hv22 _ =>
            {
              have g1 : AST.mk T11 hv11 hwf11 = AST.mk T12 hv12 hwf12 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss11, ←hss12, hstart];
              }
              cases g1; simp;
              cases hskip21; cases hskip22;
              cases hg21; cases hg22;
              simp [PreAST.start] at hss21 hss22;
              simp [PreAST.end] at hse21 hse22;
              simp [hee11, hee12, ←hss21, ←hse21, ←hss22, ←hse22, hstart];
            }
          }
      }
      | _ => cases hg1; cases hg2;
    | star s1 e1 T01 TS1 ih1 ih2 => cases T2 with
      | skip _ _ _ => cases wf_T2;
      | star s2 e2 T02 TS2 =>
      {
        simp [AST.start, PreAST.start] at hstart; simp [hstart];
        match wf_T1, wf_T2 with
        | .star_F hss01 he01sS1 hsS1eS1 hse1 hwf01 hf01 hskipS1, .star_F hss02 he02sS2 hsS2eS2 hse2 hwf02 hf02 hskipS2 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .star hg01 hgS1, .star hg02 hgS2, .star hv01 hvS1 _ _, .star hv02 hvS2 _ _ =>
            {
              have g1 : AST.mk T01 hv01 hwf01 = AST.mk T02 hv02 hwf02 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss01, ←hss02, hstart];
              }
              cases g1; simp;
              cases hskipS1; cases hskipS2;
              cases hgS1; cases hgS2;
              simp [PreAST.start, PreAST.end] at hsS1eS1 hsS2eS2;
              simp [PreAST.start] at he01sS1 he02sS2;
              simp [←hse1, ←hse2, ←hsS1eS1, ←hsS2eS2, ←he01sS1, ←he02sS2, hstart];
            }
          }
        | .star_F hss01 he01sS1 hsS1eS1 hse1 hwf01 hf01 hskipS1, .star_S hss02 he02sS2 heeS2 hwf02 hs02 hwfS2 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .star hg01 _, .star hg02 _, .star hv01 _ _ _, .star hv02 _ _ _ =>
            {
              have g1 : AST.mk T01 hv01 hwf01 = AST.mk T02 hv02 hwf02 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss01, ←hss02, hstart];
              }
              cases g1; simp;
              exact absurd hf01 (hs02.ne_failure (by assumption));
            }
          }
        | .star_S hss01 he01sS1 heeS1 hwf01 hs01 hwfS1, .star_F hss02 he02sS2 hsS2eS2 hse2 hwf02 hf02 hskipS2 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .star hg01 _, .star hg02 _, .star hv01 _ _ _, .star hv02 _ _ _ =>
            {
              have g1 : AST.mk T01 hv01 hwf01 = AST.mk T02 hv02 hwf02 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss01, ←hss02, hstart];
              }
              cases g1; simp;
              exact absurd hs01 (hf02.ne_success (by assumption));
            }
          }
        | .star_S hss01 he01sS1 heeS1 hwf01 hs01 hwfS1, .star_S hss02 he02sS2 heeS2 hwf02 hs02 hwfS2 =>
          {
            cases hi1; cases hi2;
            match hg1, hg2, valid_T1, valid_T2 with
            | .star hg01 hgS1, .star hg02 hgS2, .star hv01 hvS1 _ _, .star hv02 hvS2 _ _ =>
            {
              have g1 : AST.mk T01 hv01 hwf01 = AST.mk T02 hv02 hwf02 := by
              {
                apply ih1; assumption; assumption; assumption; assumption;
                simp [AST.start, ←hss01, ←hss02, hstart];
              }
              cases g1; simp;
              have g2 : AST.mk TS1 hvS1 hwfS1 = AST.mk TS2 hvS2 hwfS2 := by
              {
                apply ih2; assumption; assumption; assumption; assumption;
                simp [AST.start, ←he01sS1, ←he02sS2];
              }
              cases g2; simp;
              simp [heeS1, heeS2];
            }
          }
      }
      | _ => cases hg1; cases hg2;
    | notP s1 e1 T1 ih => cases T2 with
      | skip _ _ _ => cases wf_T2;
      | notP s2 e2 T2 =>
      {
        simp [AST.start, PreAST.start] at hstart; simp [hstart];
        match wf_T1, wf_T2, valid_T1, valid_T2 with
        | .notP hse1 hssT1 hwfT1, .notP hse2 hssT2 hwfT2, .notP hv1 _, .notP hv2 _ =>
        {
          have g : AST.mk T1 hv1 hwfT1 = AST.mk T2 hv2 hwfT2 := by
          {
            cases hi1; cases hi2; cases hg1; cases hg2;
            apply ih; assumption; assumption; assumption; assumption;
            simp [AST.start, ←hssT1, ←hssT2, hstart];
          }
          cases g; simp;
          simp [←hse1, ←hse2, hstart];
        }
      }
      | _ => cases hg1; cases hg2;

end Parsing