(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export per_props.
Require Export subst_per.
Require Export sequents_tacs.
Require Import cequiv_tacs.
Require Import subst_tacs.

(*
Lemma tequality_mkc_erase :
  forall a b,
    tequality (mkc_erase a) (mkc_erase b)
    <=> tequality a b.
Proof.
  introv.
  repeat (rw mkc_erase_eq).
  rw tequality_mkc_ufun; split; sp.
  apply type_mkc_unit.
Qed.
*)

Lemma apply2_erasec_rel {o} :
  forall lib (A x y : @CTerm o),
    cequivc lib (mkc_apply2 (erasec_rel A) x y) A.
Proof.
  introv.
  destruct_cterms.
  unfold cequivc; simpl.
  unfold erase_rel.
  remember (newvars2 [x1]); sp.
  betared.
  apply newvars2_prop2 in Heqp; repnd.
  rw @subst_mk_lam; auto.
  repeat (rw subst_trivial; eauto with isprog).
  betared.
  repeat (rw @subst_trivial; eauto with isprog).
  apply cequiv_refl.
  apply isprog_implies; auto.
Qed.

Lemma forall_apply_erase_rel {o} :
  forall lib (A : @CTerm o),
    (forall x y : CTerm, type lib (mkc_apply2 (erasec_rel A) x y))
    <=> type lib A.
Proof.
  introv; split; intro k; introv.

  generalize (k mkc_axiom mkc_axiom); clear k; intro k.
  generalize (apply2_erasec_rel lib A mkc_axiom mkc_axiom); intro j.
  apply type_respects_cequivc_left in j; auto.
  apply tequality_refl in j; rw @fold_type in j; auto.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply cequivc_sym in j.
  apply type_respects_cequivc_left in j; auto.
  apply tequality_refl in j; auto.
Qed.

Lemma is_per_type_erasec_rel {o} :
  forall lib (A : @CTerm o), is_per_type lib (erasec_rel A).
Proof.
  introv.
  unfold is_per_type; dands.

  unfold sym_type; introv inh.
  generalize (apply2_erasec_rel lib A x y); intro j1.
  generalize (apply2_erasec_rel lib A y x); intro j2.
  apply inhabited_type_cequivc in j1; auto.
  apply inhabited_type_cequivc with (a := A);
    auto; try (apply cequivc_sym; auto).

  unfold trans_type.
  introv inh1 inh2.
  generalize (apply2_erasec_rel lib A x y); intro j1.
  generalize (apply2_erasec_rel lib A y z); intro j2.
  generalize (apply2_erasec_rel lib A x z); intro j3.
  apply inhabited_type_cequivc in j1; auto.
  apply inhabited_type_cequivc in j2; auto.
  apply inhabited_type_cequivc with (a := A);
    auto; try (apply cequivc_sym; auto).
Qed.
Hint Immediate is_per_type_erasec_rel.

Lemma is_per_type_erasec_rel_iff {o} :
  forall lib (A : @CTerm o), is_per_type lib (erasec_rel A) <=> True.
Proof.
  introv; split; sp.
Qed.

Lemma inhabited_type_apply2_erasec_rel {o} :
  forall lib (A x y : @CTerm o),
    inhabited_type lib (mkc_apply2 (erasec_rel A) x y)
    <=> inhabited_type lib A.
Proof.
  introv; split; intro k.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply inhabited_type_cequivc in j; auto.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply inhabited_type_cequivc with (a := A);
    auto; try (apply cequivc_sym; auto).
Qed.

Lemma inhabited_type_apply2_erasec_rel_iff {o} :
  forall lib (A B : @CTerm o),
    (forall x y : CTerm,
       inhabited_type lib (mkc_apply2 (erasec_rel A) x y)
       <=>
       inhabited_type lib (mkc_apply2 (erasec_rel B) x y))
    <=>
    (inhabited_type lib A <=> inhabited_type lib B).
Proof.
  introv.
  split; intro k.

  generalize (k mkc_axiom mkc_axiom).
  repeat (rw @inhabited_type_apply2_erasec_rel); auto.

  introv.
  repeat (rw @inhabited_type_apply2_erasec_rel); auto.
Qed.

Lemma tequality_erase {o} :
  forall lib (A B : @CTerm o),
    tequality lib (erasec A) (erasec B)
    <=> ((inhabited_type lib A <=> inhabited_type lib B)
         # type lib A
         # type lib B).
Proof.
  introv.
  allrw @erasec_eq.
  rw @tequality_mkc_pertype.
  repeat (rw @forall_apply_erase_rel).
  rw @is_per_type_erasec_rel_iff.
  rw @inhabited_type_apply2_erasec_rel_iff.
  split; sp.
Qed.

Lemma type_erase {o} :
  forall lib (A : @CTerm o), type lib (erasec A) <=> type lib A.
Proof.
  introv.
  rw @tequality_erase; split; sp.
Qed.

Lemma inhabited_type_respects_alphaeqc {o} :
  forall lib, respects1 alphaeqc (@inhabited_type o lib).
Proof.
  introv aeq inh.
  apply (alphaeqc_implies_cequivc lib) in aeq.
  apply @inhabited_type_cequivc with (a := a); auto.
Qed.
Hint Resolve inhabited_type_respects_alphaeqc : respects.

Lemma type_respects_cequivc {o} :
  forall lib, respects1 (cequivc lib) (@type o lib).
Proof.
  introv ceq typ.
  apply type_respects_cequivc_left in ceq; auto.
  apply tequality_refl in ceq; auto.
Qed.
Hint Resolve type_respects_cequivc : respects.

Lemma type_respects_alphaeqc {o} :
  forall lib, respects1 alphaeqc (@type o lib).
Proof.
  introv aeq inh.
  apply (alphaeqc_implies_cequivc lib) in aeq.
  apply type_respects_cequivc_left in aeq; auto.
  apply tequality_refl in aeq; auto.
Qed.
Hint Resolve type_respects_alphaeqc : respects.

Lemma type_apply2_erasec_rel {o} :
  forall lib (A x y : @CTerm o),
    type lib (mkc_apply2 (erasec_rel A) x y)
    <=> type lib A.
Proof.
  introv; split; intro k.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply type_respects_cequivc_left in j; auto.
  apply tequality_refl in j; auto.

  generalize (apply2_erasec_rel lib A x y); intro j.
  apply cequivc_sym in j.
  apply type_respects_cequivc_left in j; auto.
  apply tequality_refl in j; auto.
Qed.

Lemma equality_in_erasec {o} :
  forall lib (t1 t2 t : @CTerm o),
    equality lib t1 t2 (erasec t) <=> inhabited_type lib t.
Proof.
  introv; split; intro k; allunfold @inhabited_type; exrepnd;
  allrw @erasec_eq; allrw @equality_in_mkc_pertype; repnd;
  allrw @inhabited_type_apply2_erasec_rel; auto.

  dands; auto.
  exists t0; auto.
  introv.
  apply type_apply2_erasec_rel.
  apply inhabited_implies_tequality in k0; auto.
Qed.

Lemma inhabited_type_erasec {o} :
  forall lib (t : @CTerm o), inhabited_type lib (erasec t) <=> inhabited_type lib t.
Proof.
  introv; split; intro k; allunfold @inhabited_type; exrepnd.

  rw @equality_in_erasec in k0; allunfold @inhabited_type; exrepnd.
  exists t1; auto.

  exists (@mkc_axiom o).
  rw @equality_in_erasec.
  exists t0; auto.
Qed.

Lemma member_in_base_iff {o} :
  forall lib (t : @CTerm o), member lib t mkc_base <=> True.
Proof.
  intros; split; intro; auto; apply member_base.
Qed.

Lemma equality_in_isect2 {o} :
  forall lib (t u : @CTerm o) A v B,
    equality lib t u (mkc_isect A v B)
    <=>
    (type lib A
     # forall a a',
         equality lib a a' A
         -> (equality lib t u (substc a v B) # tequality lib (substc a v B) (substc a' v B))).
Proof.
  sp; rw @equality_in_isect; split; sp; discover; sp.
Qed.

Lemma member_in_isect {o} :
  forall lib (t : @CTerm o) A v B,
    member lib t (mkc_isect A v B)
    <=>
    (type lib A
     # forall a a',
         equality lib a a' A
         -> (member lib t (substc a v B) # tequality lib (substc a v B) (substc a' v B))).
Proof.
  sp; rw @equality_in_isect; split; sp; discover; sp.
Qed.

Lemma is_per_type_sqper_rel_change_subst {o} :
  forall lib v1 v2 R s1 s2 w c1 c2,
    (forall x y : @CTerm o,
       inhabited_type lib (mkc_apply2 (lsubstc (sqper_rel v1 v2 R) w s1 c1) x y)
       <=>
       inhabited_type lib (mkc_apply2 (lsubstc (sqper_rel v1 v2 R) w s2 c2) x y))
    -> is_per_type lib (lsubstc (sqper_rel v1 v2 R) w s1 c1)
    -> is_per_type lib (lsubstc (sqper_rel v1 v2 R) w s2 c2).
Proof.
  introv iff isper.
  allunfold @is_per_type.
  destruct isper as [sym trans].
  allunfold @sqper_rel; lsubst_tac.
  dands.

  - clear trans.
    allunfold @sym_type; introv inh.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec.
    generalize (sym x y); clear sym; intro sym.
    autodimp sym hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec.
    generalize (iff x y); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i1.
    autodimp i2 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (iff y x); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i2.
    autodimp i1 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.

  - clear sym.
    allunfold @trans_type; introv inh1 inh2.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (trans x y z); clear trans; intro trans.

    autodimp trans hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (iff x y); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i1.
    autodimp i2 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.

    autodimp trans hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (iff y z); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i1.
    autodimp i2 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.

    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    generalize (iff x z); clear iff; intro iff.
    destruct iff as [i1 i2]; clear i2.
    autodimp i1 hyp.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
    repeat (betared; repeat substc_lsubstc_vars3; lsubst_tac).
    allrw @inhabited_type_erasec; auto.
Qed.

Lemma tequality_iff_mkc_tequality {o} :
  forall lib (A B : @CTerm o),
    type lib (mkc_tequality A B) <=> tequality lib A B.
Proof.
  introv.
  split; intro k.

  - unfold type, tequality in k; exrepnd.
    inversion k0; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    exists eqa; auto.

  - unfold tequality in k; exrepnd.
    exists (@true_per o).
    apply CL_teq; unfold per_teq.
    fold (@nuprl o).
    exists A B A B eq; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprl_refl in k0; auto.
    apply nuprl_sym in k0; apply nuprl_refl in k0; auto.
Qed.

Lemma tequality_mkc_tequality {o} :
  forall lib (A B C D : @CTerm o),
    tequality lib (mkc_tequality A B) (mkc_tequality C D)
    <=> (tequality lib A C # tequality lib B D # tequality lib A B).
Proof.
  introv.
  split; intro k.

  - unfold tequality in k; exrepnd.
    inversion k0; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    dands; exists eqa; auto.

  - unfold tequality in k; exrepnd.
    exists (@true_per o).
    apply CL_teq; unfold per_teq.
    fold (@nuprl o).

    assert (eq1 <=2=> eq)
      as eqs1
        by (apply nuprl_refl in k1; apply nuprl_refl in k2;
            generalize (nuprl_uniquely_valued lib A eq1 eq); intro k;
            repeat (autodimp k hyp)).

    assert (eq0 <=2=> eq)
      as eqs2
        by (apply nuprl_sym in k2; apply nuprl_refl in k3; apply nuprl_refl in k2;
            generalize (nuprl_uniquely_valued lib B eq0 eq); intro k;
            repeat (autodimp k hyp)).

    exists A B C D eq; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply @nuprl_ext with (eq1 := eq1); auto.
    apply @nuprl_ext with (eq1 := eq0); auto.
Qed.

Lemma mkc_tequality_equality_in_uni {o} :
  forall lib (A B C D : @CTerm o) i,
    tequalityi lib i (mkc_tequality A B) (mkc_tequality C D)
    <=> (tequalityi lib i A C # tequalityi lib i B D # tequalityi lib i A B).
Proof.
  introv.
  split; intro k.

  - unfold tequalityi, equality in k; exrepnd.
    inversion k1; subst; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    inversion h2; subst; try not_univ.
    allunfold_per; computes_to_value_isvalue; allfold (@nuprl o).
    dands; exists eq; sp; allrw; exists eqa0; auto.

  - unfold tequalityi, equality in k; exrepnd.
    generalize (nuprl_uniquely_valued lib (mkc_uni i) eq0 eq k1 k3); intro eqs1.
    generalize (nuprl_uniquely_valued lib (mkc_uni i) eq1 eq k0 k3); intro eqs2.
    clear k0 k1.
    rw eqs1 in k4; clear eqs1.
    rw eqs2 in k5; clear eqs2.
    exists eq; dands; auto.
    inversion k3; try not_univ.
    duniv j h.
    allrw @univi_exists_iff; exrepnd.
    computes_to_value_isvalue; GC.
    discover; exrepnd.
    fold (@nuprli o lib j0) in h2, h3, h4.
    rw h0; exists (@true_per o).
    dup h2 as na1; apply nuprli_refl in na1.
    dup h4 as na2; apply nuprli_refl in na2.
    generalize (nuprli_uniquely_valued lib j0 j0 A A eqa1 eqa na1 na2); clear na1 na2; intro eqs1.
    dup h3 as nb1; apply nuprli_refl in nb1.
    dup h4 as nb2; apply nuprli_sym in nb2; apply nuprli_refl in nb2.
    generalize (nuprli_uniquely_valued lib j0 j0 B B eqa0 eqa nb1 nb2); clear nb1 nb2; intro eqs2.
    apply CL_teq; fold (@nuprli o lib j0).
    exists A B C D eqa; sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprli_ext with (eq1 := eqa1); auto.
    apply nuprli_ext with (eq1 := eqa0); auto.
Qed.

Lemma equality_in_mkc_tequality {o} :
  forall lib (a b A B : @CTerm o),
    equality lib a b (mkc_tequality A B) <=> tequality lib A B.
Proof.
  introv; split; intro k.

  - apply inhabited_implies_tequality in k.
    rw @tequality_iff_mkc_tequality in k; auto.

  - exists (@true_per o); dands; auto; try (complete (unfold true_per; auto)).
    unfold tequality in k; exrepnd.
    apply CL_teq.
    exists A B A B eq; fold (@nuprl o); sp;
    try (complete (spcast; apply computes_to_valc_refl; try (apply iscvalue_mkc_tequality))).
    apply nuprl_refl in k0; auto.
    apply nuprl_sym in k0; apply nuprl_refl in k0; auto.
Qed.


(* Authors: Christian Doczkal and Jan-Oliver Kaiser *)
(* Distributed under the terms of CeCILL-B. *)
From mathcomp Require Import all_ssreflect.
From RegLang Require Import setoid_leq misc languages dfa nfa.

Set Default Proof Using "Type".

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Regular Expressions

This file contains the definition of regular expressions and the proof
that regular expressions have the same expressive power as finite
automata. *)

Section RegExp.
Variable char : eqType.

Inductive regexp :=
 | Void
 | Eps
 | Atom of char
 | Star of regexp
 | Plus of regexp & regexp
 | Conc of regexp & regexp.

Lemma eq_regexp_dec (e1 e2 : regexp) : {e1 = e2} + {e1 <> e2}.
Proof. decide equality; apply: eq_comparable. Qed.

Definition regexp_eqMixin := EqMixin (compareP eq_regexp_dec).
Canonical Structure form_eqType := EqType _ regexp_eqMixin.
End RegExp.

Arguments void : clear implicits.
Arguments eps : clear implicits.
Prenex Implicits Plus.
Arguments plusP {char r s w}.

Notation "'Void'" := (@Void _).
Notation "'Eps'" := (@Eps _).

(** We assign a decidable language to every regular expression *)

Fixpoint re_lang (char: eqType) (e : regexp char) : dlang char :=
  match e with
  | Void => void char
  | Eps => eps char
  | Atom x => atom x
  | Star e1 => star (re_lang e1)
  | Plus e1 e2 => plus (re_lang e1) (re_lang e2)
  | Conc e1 e2 => conc (re_lang e1) (re_lang e2)
  end.

Canonical Structure regexp_predType (char: eqType) := PredType (@re_lang char).

(** We instantiate Ssreflects Canonical Big Operators *)
Notation "\sigma_( i <- r )  F" := (\big[Plus/Void]_(i <- r) F) (at level 50).
Notation "\sigma_( i | P )  F" := (\big[Plus/Void]_(i | P) F) (at level 50).

Lemma big_plus_seqP (T char : eqType) (r : seq T) w (F : T -> regexp char) :
  reflect (exists2 x, x \in r & w \in F x) (w \in \sigma_(i <- r) F i).
Proof.
  elim: r w => [|r rs IHrs] w. rewrite big_nil; by constructor => [[x]].
  rewrite big_cons; apply: (iffP plusP) => [[H|H]|[x]].
  - exists r => //; by rewrite mem_head.
  - case/IHrs : H => x Hx ?. exists x => //. by rewrite in_cons Hx orbT.
  - rewrite in_cons; case/orP => [/eqP -> |]; auto => ? ?.
    right. apply/IHrs. by exists x.
Qed.

Lemma big_plusP (T char: finType) (P:pred T) w (F : T -> regexp char) :
  reflect (exists2 i, P i  & w \in F i) (w \in \sigma_(i | P i) F i).
Proof.
  rewrite -big_filter. apply: (iffP (big_plus_seqP _ _ _)) => [[x]|[x] H1 H2].
  - rewrite mem_filter => /andP [? ?]; by exists x.
  - by exists x; rewrite // mem_filter H1 mem_index_enum.
Qed.

Fixpoint re_size (char: eqType) (e : regexp char) :=
  match e with
  | Star s => (re_size s).+1
  | Plus s t => ((re_size s)+(re_size t)).+1
  | Conc s t => ((re_size s)+(re_size t)).+1
  | _ => 1
  end.

Lemma big_plus_size (T char : eqType) (r : seq T) (F : T -> regexp char) m :
  (forall i, i \in r -> re_size (F i) <= m) -> re_size (\sigma_(i <- r) F i) <= (size r * m.+1).+1.
Proof.
  elim: r => [|e r IH /forall_cons [A B]]; first by rewrite big_nil.
  rewrite big_cons /= ltnS mulSn addSn -addnS leq_add //. exact: IH.
Qed.

(** ** Regular Expressions to Finite Automata *)
Section DFAofRE.
Variable (char : finType).

Fixpoint re_to_nfa (r : regexp char): nfa char :=
  match r with
  | Void => dfa_to_nfa (dfa_void _)
  | Eps => nfa_eps _
  | Atom a => nfa_char a
  | Star s => nfa_star (re_to_nfa s)
  | Plus s t => nfa_plus (re_to_nfa s) (re_to_nfa t)
  | Conc s t => nfa_conc (re_to_nfa s) (re_to_nfa t)
  end.

Lemma re_to_nfa_correct (r : regexp char) : nfa_lang (re_to_nfa r) =i r.
Proof.
  elim: r => [||a|s IHs |s IHs t IHt |s IHs t IHt] w //=.
  - by rewrite -dfa_to_nfa_correct inE /dfa_accept inE.
  - exact: nfa_eps_correct.
  - exact: nfa_char_correct.
  - rewrite nfa_star_correct. exact: star_eq.
  - by rewrite nfa_plus_correct /plus inE IHs IHt.
  - rewrite nfa_conc_correct. exact: conc_eq.
Qed.

Lemma re_to_nfa_size e : #|re_to_nfa e| <= 2 * re_size e.
Proof.
  elim: e; rewrite /= ?card_unit ?card_bool => //.
  - move => e IH. by rewrite card_option (leqRW IH) mulnS add2n.
  - move => e1 IH1 e2 IH2.
    by rewrite card_sum (leqRW IH1) (leqRW IH2) mulnS mulnDr add2n ltnW.
  - move => e1 IH1 e2 IH2.
    by rewrite card_sum (leqRW IH1) (leqRW IH2) mulnS mulnDr add2n ltnW.
Qed.

Definition re_to_dfa := @nfa_to_dfa _ \o re_to_nfa.

Lemma re_to_dfa_correct (r : regexp char) : dfa_lang (re_to_dfa r) =i r.
Proof. move => w. by rewrite -nfa_to_dfa_correct re_to_nfa_correct. Qed.

Lemma re_to_dfa_size e : #|re_to_dfa e| <= 2^(2 * re_size e).
Proof. by rewrite card_set leq_pexp2l // re_to_nfa_size. Qed.

(** Decidability of regular expression equivalence *)

Definition re_equiv r s := dfa_equiv (re_to_dfa r) (re_to_dfa s).

Lemma re_equiv_correct r s : reflect (r =i s) (re_equiv r s).
Proof.
  apply: (iffP (dfa_equiv_correct _ _)) => H w;
    move/(_ w) : H; by rewrite !re_to_dfa_correct.
Qed.

End DFAofRE.

(** ** Finite Automata to Regular Expressions (Kleene Construction) *)

Section KleeneAlgorithm.
  Variable char : finType.
  Variable A : dfa char.

  (** We first define the transition languages between states. The
  trasition languages are defined such that [w \in L^X q p] iff for
  all nonempty strict prefixes [v] of [w], [delta q v \in X]. *)

  Definition L (X : {set A}) (p q : A) x :=
    (delta p x == q) && [forall (i : 'I_(size x) | 0 < i), delta p (take i x) \in X].
  Notation "'L^' X" := (L X) (at level 8,format "'L^' X").

  Lemma dfa_L x y w : w \in L^setT x y = (delta x w == y).
  Proof.
    rewrite unfold_in. case: (_ == _) => //=.
    apply/forall_inP => ? ?. by rewrite inE.
  Qed.

  Lemma LP {X : {set A}} {p q : A} {x} :
    reflect (delta p x = q /\ forall i, (0 < i) -> (i < size x) -> delta p (take i x) \in X)
            (x \in L^X p q).
  Proof.
    apply: (iffP andP); case => /eqP ? H; split => //.
    - move => i I1 I2. exact: (forall_inP H (Ordinal I2)).
    - apply/forall_inP => [[i I1 /= I2]]; auto.
  Qed.

  Lemma L_monotone (X : {set A}) (x y z : A): {subset L^X x y <= L^(z |: X) x y}.
  Proof.
    move => w. rewrite !unfold_in. case: (_ == _) => //. apply: sub_forall => i /=.
    case: (_ < _) => //= H. by rewrite inE H orbT.
  Qed.

  Lemma L_nil X x y : reflect (x = y) ([::] \in L^X x y).
  Proof. apply: (iffP LP) => //=. by case. Qed.

  Lemma L_set0 p q w :
    L^set0 q p w -> p = q /\ w = [::] \/ exists2 a, w = [::a] & p = dfa_trans q a.
  Proof.
    case/LP => <-. case: w => [|a [|b w]] H ; [by left|by right;exists a|].
    move: (H 1). do 2 case/(_ _)/Wrap => //. by rewrite inE.
  Qed.

  Lemma L_split X p q z w : w \in L (z |: X) p q ->
    w \in L^X p q \/
    exists w1 w2, [/\ w = w1 ++ w2, size w2 < size w, w1 \in L^X p z & w2 \in L^(z |: X) z q].
  Proof.
    case/LP => H1 H2.
    case: (find_minn_bound (fun i => (0 < i) && (delta p (take i w) == z)) (size w)).
    - case => i [lt_w /andP [i_gt0 /eqP delta_z] min_i]; right.
      exists (take i w); exists (drop i w).
      have ? : 0 < size w by exact: ltn_trans lt_w.
      rewrite cat_take_drop size_drop -{2}[size w]subn0 ltn_sub2l //; split => //.
      + apply/LP. split => // j J1 J2.
        have lt_i_j : j < i. apply: leq_trans J2 _. by rewrite size_take lt_w.
        have/(H2 _ J1) : j < size w. exact: ltn_trans lt_w.
        case/setU1P => [H|]; last by rewrite take_take 1?ltnW.
        move: (min_i _ lt_i_j). by rewrite negb_and J1 H eqxx.
      + apply/LP. rewrite -H1 -{2}[w](cat_take_drop i) delta_cat delta_z.
        split => // j J1 J2. rewrite -{1}delta_z -delta_cat -takeD.
        apply: H2; first by rewrite addn_gt0 J1 orbT.
        by rewrite -[w](cat_take_drop i) size_cat size_take lt_w ltn_add2l.
    - move => H; left. apply/LP. split => // i I1 I2. apply: contraTT (H2 _ I1 I2) => C.
      rewrite inE negb_or C inE andbT. apply: contraNN (H _ I2) => ->. by rewrite I1.
  Qed.

  Lemma L_cat (X : {set A}) x y z w1 w2 :
    z \in X -> w1 \in L^X x z -> w2 \in L^X z y -> w1++w2 \in L^X x y.
  Proof.
    move => Hz /LP [H11 H12] /LP [H21 H22]. apply/LP.
    split; first by rewrite delta_cat H11 H21.
    move => i i_gt0 H. rewrite take_cat. case: (boolP (i < _)); first exact: H12.
    rewrite delta_cat H11 -leqNgt => le_w1.
    case: (posnP (i - size w1)) => [->|Hi]; first by rewrite take0.
    apply: H22 => //. by rewrite -(ltn_add2l (size w1)) subnKC // -size_cat.
  Qed.

  Lemma L_catL X x y z w1 w2 :
    w1 \in L^X x z -> w2 \in L^(z |: X) z y -> w1++w2 \in L^(z |: X) x y.
  Proof. move/(L_monotone z). apply: L_cat. exact: setU11. Qed.

  Lemma L_catR X x y z w1 w2 :
    w1 \in L^(z |: X) x z -> w2 \in L^X z y -> w1++w2 \in L^(z |: X) x y.
  Proof. move => H /(L_monotone z). apply: L_cat H. exact: setU11. Qed.

  Lemma L_star (X : {set A}) z w : w \in star (L^X z z) -> w \in L^(z |: X) z z.
  Proof.
    move/starP => [vv Hvv ->]. elim: vv Hvv => [_|r vv IHvv]; first exact/L_nil.
    move => /= /andP [/andP [_ H1] H2]. exact: L_catL H1 (IHvv H2).
  Qed.

  (** Main Lemma - L satisfies a recursive equation that can be used
  to construct a regular expression *)

  Lemma L_rec (X : {set A}) x y z :
    L^(z |: X) x y =i plus (conc (L^X x z) (conc (star (L^X z z)) (L^X z y))) (L^X x y).
  Proof.
    move => w. apply/idP/idP.
    - move: w x y. apply: (size_induction (measure := size)) => w IHw x y.
      move/L_split => [|[w1 [w2 [Hw' H1 Hw1 Hw2]]]].
      + rewrite inE => ->. by rewrite orbT.
      + move: (IHw w2 H1 z y Hw2) Hw' => H4 -> {IHw H1}.
        rewrite inE (conc_cat Hw1 _) //.
        case/plusP : H4 => H; last by rewrite -[w2]cat0s conc_cat //.
        move/concP : H => [w21] [w22] [W1 [W2]] /concP [w221] [w222] [W3 [W4 W5]]; subst.
        by rewrite catA conc_cat // star_cat.
    - case/plusP ; last exact: L_monotone.
      move/concP => [w1] [w2] [-> [Hw1]] /concP [w3] [w4] [-> [Hw3 Hw4]].
      by rewrite (L_catL Hw1) // (L_catR _ Hw4) // L_star.
  Qed.

  (** Construction of the regular expression *)

  Definition edges (x y : A) := \big[Plus/Void]_(a | dfa_trans x a == y) Atom a.

  Definition edgesP x y w :
    reflect (exists2 a, w = [::a] & dfa_trans x a = y) (w \in edges x y).
  Proof. apply: (iffP (big_plusP _ _ _)) => [|] [a] /eqP ? /eqP ?; by exists a. Qed.

  Definition R0 x y := Plus (if x == y then Eps else Void) (edges x y).

  Lemma mem_R0 w x y :
    reflect (w = [::] /\ x=y \/ exists2 a, w = [::a] & dfa_trans x a = y)
            (w \in R0 x y).
  Proof.
    apply: (iffP plusP).
    - case => [| /edgesP]; auto. case e : (x == y) => // /eqP.
      by rewrite (eqP e); auto.
    - case => [[-> ->]|/edgesP];auto. by rewrite eqxx; auto.
  Qed.

  Fixpoint R (X : seq A) (x y : A) :=
    if X isn't z :: X' then R0 x y else
      Plus (Conc (R X' x z) (Conc (Star (R X' z z)) (R X' z y))) (R X' x y).

  Notation "'R^' X" := (R X) (at level 8, format "'R^' X").

  Lemma L_R (X : seq A) x y : L^[set z in X] x y =i R^X x y.
  Proof.
    elim: X x y => [|z X' IH] x y w.
    - rewrite (_ : [set z in [::]] = set0) //=.
      apply/idP/mem_R0.
      + move/L_set0 => [[-> ->]|[a -> ->]]; by eauto.
      + move => [[-> ->]|[a -> <-]]; apply/LP => /=; split => // [[|i]] //.
    - rewrite set_cons /= (L_rec _ _) -2!topredE /= /plus /= IH.
      f_equal.
      apply: conc_eq; first exact: IH.
      apply: conc_eq; last exact: IH.
      apply: star_eq. exact: IH.
  Qed.

  Definition dfa_to_re : regexp char := \sigma_(x | x \in dfa_fin A) R^(enum A) (dfa_s A) x.

  Lemma dfa_to_re_correct : dfa_lang A =i dfa_to_re.
  Proof.
    move => w. apply/idP/big_plusP => [H|[x Hx]].
    - exists (delta_s A w) => //. by rewrite -L_R set_enum dfa_L.
    - by rewrite -L_R set_enum dfa_L inE /dfa_accept => /eqP ->.
  Qed.

  (** ** Size Bound for Kleene Theorem *)

  Let c := (2 * #|char|).+3.

  Lemma R0_size x y : re_size (R0 x y) <= c.
  Proof.
    rewrite /= [X in X + _](_ : _ = 1); last by case (_ == _).
    rewrite add1n !ltnS. rewrite /edges -big_filter.
    apply: leq_trans (big_plus_size (m := 1) _) _ => [//|].
    rewrite size_filter ltnS mulnC leq_mul2l /=.
    apply: leq_trans (count_size _ _) _. by rewrite /index_enum -enumT cardE.
  Qed.

  Fixpoint R_size_rec (n : nat) := if n is n'.+1 then 4 * R_size_rec n' + 4 else c.

  Lemma R_size x : re_size (R^(enum A) (dfa_s A) x) <= R_size_rec #|A| .
  Proof.
    rewrite cardE. elim: (enum A) (dfa_s A) x => [|r s IH] p q.
    - exact: R0_size.
    - rewrite /= 6!(addSn,addnS) addn4 !ltnS !(leqRW (IH _ _)).
      by rewrite !mulSn mul0n addn0 !addnA.
  Qed.

  Lemma R_size_low (n : nat) : 3 <= R_size_rec n.
  Proof. elim: n => // n IH. by rewrite (leqRW IH) /= -(leqRW (leq_addr _ _)) leq_pmull. Qed.

  Lemma R_size_high n : R_size_rec n <= c * 4^(2 * n).
  Proof.
    elim: n => //= [|n IH].
    - by rewrite mulnS muln0 addn0.
    - rewrite [in X in _^X]mulnS expnD mulnA [c * _]mulnC -mulnA.
      rewrite -(leqRW IH) -[4^2]/((1+3) * 4) -mulnA mulnDl mul1n leq_add //.
      by rewrite -(leqRW (R_size_low _)).
  Qed.

  Lemma dfa_to_re_size : re_size dfa_to_re <= (#|A| * (c * 4 ^ (2 * #|A|)).+1).+1.
  Proof.
    rewrite /dfa_to_re -big_filter (leqRW (big_plus_size (m := R_size_rec #|A|)_)).
    - rewrite -(leqRW (R_size_high _)) size_filter (leqRW (count_size _ _)).
      by rewrite ltnS /index_enum -enumT cardE.
    - move => q _. exact: R_size.
  Qed.

End KleeneAlgorithm.

Lemma regularP (char : finType) (L : lang char) :
  regular L <-T->  { e : regexp char | forall x, L x <-> x \in e}.
Proof.
  split => [[A HA]|[e He]].
  - exists (dfa_to_re A) => x. by rewrite -dfa_to_re_correct.
  - exists (re_to_dfa e) => x. by rewrite re_to_dfa_correct.
Qed.

(** Closure of Regular Expressions under intersection and complement *)

Definition Inter (char : finType) (r s : regexp char) :=
  dfa_to_re (dfa_op andb (re_to_dfa r) (re_to_dfa s)).

Lemma Inter_correct (char : finType) (r s : regexp char) w :
  w \in Inter r s = (w \in r) && (w \in s).
Proof. by rewrite /Inter -dfa_to_re_correct dfa_op_correct !re_to_dfa_correct. Qed.

Definition Neg (char : finType) (r : regexp char) :=
  dfa_to_re (dfa_compl (re_to_dfa r)).

Lemma Neg_correct (char : finType) (r : regexp char) w :
  w \in Neg r = (w \notin r).
Proof. by rewrite /Neg -dfa_to_re_correct dfa_compl_correct !re_to_dfa_correct. Qed.

(** ** Regular expression for images of homomorphimsms *)

Prenex Implicits Conc.
Definition String (char : finType) (w : word char) :=
  foldr Conc Eps [seq Atom a | a <- w].

Lemma StringE (char : finType) (w : word char) : String w =i pred1 w.
Proof.
  elim: w => [|a v IHv] w //=. rewrite inE /String /=. apply/concP/eqP.
  - move => [w1] [w2] [e []]. set r := foldr _ _ _.
    rewrite -/(re_lang r) inE e => /eqP -> H /=.
    rewrite IHv inE in H. by rewrite (eqP H).
  - move => e. exists [:: a]; exists v; split => //; split.
    by rewrite inE. by rewrite IHv inE eqxx.
Qed.

Section Image.
  Variables (char char' : finType) (h : seq char -> seq char').
  Hypothesis h_hom : homomorphism h.

  Fixpoint re_image (e : regexp char) : regexp char' :=
    match e with
    | Void => Void
    | Eps => Eps
    | Atom a => String (h [:: a])
    | Star e => Star (re_image e)
    | Plus e1 e2 => Plus (re_image e1) (re_image e2)
    | Conc e1 e2 => Conc (re_image e1) (re_image e2)
    end.

  Lemma re_imageP e v : reflect (image h (re_lang e) v) (v \in re_image e).
  Proof using h_hom.
    elim: e v => [||a|e IHe|e1 IHe1 e2 IHe2|e1 IHe1 e2 IHe2] v /=.
    - rewrite inE; constructor. move => [u]. by case.
    - rewrite inE; apply: (iffP eqP) => [-> |[w] [] /eqP -> <-]; last exact: h0.
      exists [::]; by rewrite ?h0.
    - rewrite StringE. apply: (iffP eqP) => [->|[w /=]].
      + exists [::a] => //. by rewrite /atom inE.
      + by rewrite /atom inE => [[]] /eqP -> <-.
    - apply: (iffP idP) => [/starP [vv] /allP Hvv dev_v|].
        have {Hvv IHe} Hvv v' : v' \in vv -> image h (re_lang e) v'.
          by move => /Hvv /= /andP [_ /IHe].
        subst v. elim: vv Hvv => [|v vv IHvv] Hvv /=; first by exists [::]; rewrite ?h0.
        case: (Hvv v (mem_head _ _)) => w [Hw1 Hw2].
        case/forall_cons: Hvv => Hv /IHvv [ww [Hww1 Hww2]].
        exists (w++ww); split; by [exact: star_cat | rewrite h_hom Hw2 Hww2].
      + case => w [] /starP [ww] /allP Hww1 -> <-. rewrite h_flatten //.
        apply: starI => v' /mapP [w' /Hww1 /= /andP [_ Hw' ->]].
        apply/IHe. by exists w'.
    - apply: (iffP orP).
       + case => [/IHe1 | /IHe2] [w] [] H <-.
           exists w => //. by rewrite /plus inE (_ : w \in re_lang e1).
         exists w => //. by rewrite /plus inE (_ : w \in re_lang e2) ?orbT.
       + case => w []. case/orP => H <-; [left; apply/IHe1 |right; apply/IHe2]; by exists w.
    - apply: (iffP idP).
      + case/concP => v1 [v2] [e] [/IHe1 [w [Hw1 Hw2]] /IHe2 [w' [Hw1' Hw2']]].
        exists (w++w'); split; first exact: conc_cat.
        by rewrite h_hom e Hw2 Hw2'.
      + case => w [] /concP [w1] [w2] [-> [H1 H2 <-]]. rewrite h_hom.
        apply: conc_cat; [apply/IHe1|apply/IHe2]. by exists w1. by exists w2.
  Qed.

End Image.

Lemma im_regular (char char' : finType) (h : word char -> word char') L :
  homomorphism h -> regular L -> regular (image h L).
Proof.
  move => hom_h /regularP [e He]. apply/regularP. exists (@re_image _ _ h e) => w.
  transitivity (image h (re_lang e) w); first exact: image_ext.
  exact: rwP (re_imageP _ _ _).
Qed.

(** ** Regular Expression for word reversal *)

Fixpoint Rev (char : finType) (e : regexp char) :=
  match e with
  | Star e => Star (Rev e)
  | Plus e1 e2 => Plus (Rev e1) (Rev e2)
  | Conc e1 e2 => Conc (Rev e2) (Rev e1)
  | _ => e
  end.

Lemma Rev_correct (char : finType) (e : regexp char) w :
  w \in Rev e = (rev w \in e).
Proof.
  elim: e w => [||a|e IH|e1 IH1 e2 IH2|e1 IH1 e2 IH2] w //.
  - rewrite !inE. apply/eqP/idP; first by move->.
    elim/last_ind: w => //= s a _. by rewrite rev_rcons.
  - rewrite !inE. apply/eqP/eqP; first by move->.
    do 2 elim/last_ind: w => //= w ? _. by rewrite !rev_rcons.
  - rewrite /=; apply/idP/idP; case/starP => vv /allP /= H.
    + move->. rewrite rev_flatten. apply: starI => v'.
      rewrite mem_rev => /mapP [v V1 ->]. rewrite -IH. by case/andP: (H _ V1).
    + rewrite -{2}[w]revK => ->. rewrite rev_flatten. apply: starI => v'.
      rewrite mem_rev => /mapP [v V1 ->]. rewrite IH revK. by case/andP: (H _ V1).
  - by rewrite /= !inE -!/(re_lang _) IH1 IH2.
  - rewrite /=. apply/concP/concP => [] [w1] [w2]; rewrite -!/(re_lang _).
    + move => [-> [A B]]. exists (rev w2), (rev w1). by rewrite rev_cat -IH1 -IH2.
    + rewrite -{2}[w]revK. move => [-> [A B]]. exists (rev w2), (rev w1).
      by rewrite rev_cat IH1 IH2 !revK.
Qed.

Lemma regular_rev (char : finType) (L : lang char) :
  regular L -> regular (fun x => L (rev x)).
Proof. case/regularP => e H. apply/regularP. exists (Rev e) => x. by rewrite Rev_correct. Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Limits.Limit Limits.GenProd_GenSum.
Require Import Archetypal.Discr.Discr.
Require Import Basic_Cons.Terminal.

(** In category of types, generalized products are simply dependent prdoducts. *)
Section Type_Cat_GenProd.
  Context (A : Type) (map : A → Type_Cat).

  Local Notation Fm := (Discr_Func Type_Cat map) (only parsing).

  Program Definition Type_Cat_GenProd_Cone : Cone Fm :=
    {|
      cone_apex := {|FO := fun _ => ∀ x : A, (Fm _o x)%object; FA := fun _ _ _ h => h|};
      cone_edge := {|Trans := fun x y => y x |}
    |}.

  Program Definition Type_Cat_GenProd : (Π map)%object :=
    {|
      LRKE := Type_Cat_GenProd_Cone;
      LRKE_morph_ex :=
        fun Cn =>
          {|
            cone_morph :=
              {|Trans :=
                  fun c X x  =>
                    match c as u return ((Cn _o)%object u → map x) with
                    | tt => fun X : (Cn _o)%object tt => Trans Cn x X
                    end X
              |}
          |}
    |}.

  Next Obligation.
  Proof.
    destruct c; destruct c'; destruct h.
    extensionality x; extensionality y.
    apply (equal_f ((@Trans_com _ _ _ _ Cn) y y eq_refl) x).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Type_Cat_GenProd_obligation_1.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    extensionality x; extensionality y; extensionality z.
    destruct x.
    set (hc := (cone_morph_com h')).
    rewrite (cone_morph_com h) in hc.
    set (hc' := (f_equal (fun w :
                  ((Cn ∘ (Functor_To_1_Cat (Discr_Cat A))) –≻ Fm)%nattrans =>
           Trans w z y) hc)); clearbody hc'; clear hc.
    trivial.
  Qed.

End Type_Cat_GenProd.


(* Axiom PropExt : forall (A B : Prop), A <-> B -> A = B. *)
Axiom PI : forall (A : Prop) (x y : A), x = y.
Axiom funext : forall A (B : A -> Type) (f g : forall x, B x), (forall x, f x = g x) -> f = g.

Set Primitive Projections.

Axiom ℙ : Type.
Axiom le₀ : ℙ -> ℙ -> Type.

Definition le p q := forall r, le₀ q r -> le₀ p r.

Definition le_id {p} : le p p := fun r k => k.
Definition le_cmp {p q r} (α : le p q) (β : le q r) : le p r := fun r k => α r (β r k).

Notation "p ≤ q" := (le p q) (at level 70, no associativity).
Notation "'!'" := (@le_id _).
Notation "α ∘ β" := (@le_cmp _ _ _ β α) (at level 35).

Record Psh := mkPsh {
  set : ℙ -> Type;
  mon : forall {p q} (α : q ≤ p), set p -> set q;
  mon_id : forall p (x : set p), mon ! x = x;
  mon_cmp : forall p q (α : le q p) r (β : r ≤ q) (x : set p), mon (α ∘ β) x = mon β (mon α x);
}.

Record Nat (A B : Psh) := mkNat {
  hom : forall p, A.(set) p -> B.(set) p;
  nat : forall p q (α : q ≤ p) x,
    hom q (A.(mon) α x) = B.(mon) α (hom p x);
}.

Arguments hom {_ _}.
Arguments nat {_ _}.

Lemma Nat_eq : forall A B (f g : Nat A B),
  (forall p (x : A.(set) p), f.(hom) p x = g.(hom) p x) -> f = g.
Proof.
intros A B [f fn] [g gn] e.
cbn in *.
assert (e' : f = g).
{ apply funext; intros p; apply funext; intros x; apply e. }
destruct e'.
replace fn with gn by apply PI.
reflexivity.
Qed.

Definition Nid {A} : Nat A A.
Proof.
unshelve refine (mkNat _ _ (fun _ x => x) _).
reflexivity.
Defined.

Definition Ncmp {A B C} (f : Nat A B) (g : Nat B C) : Nat A C.
Proof.
unshelve refine (mkNat _ _ (fun p x => g.(hom) p (f.(hom) p x)) _).
intros; rewrite f.(nat), g.(nat); reflexivity.
Defined.

Record Pfc := mkPfc {
  elt : forall p q (α : q ≤ p), Type;
  rel : forall p, (forall q α, elt p q α) -> Prop;
  prm : forall p q (α : q ≤ p), elt p q α = elt q q !;
}.

Definition cast (A : Pfc) {p q} (α : q ≤ p) : A.(elt) q q ! -> A.(elt) p q α :=
  match A.(prm) p q α with eq_refl => fun x => x end.

Record El p (A : Pfc) := mkEl {
  el₀ : forall q (α : q ≤ p), A.(elt) q q !;
  elε : forall q (α : q ≤ p), A.(rel) q (fun r β => cast A β (el₀ r (α ∘ β)));
}.

Arguments el₀ {_ _}.
Arguments elε {_ _}.

Lemma El_eq : forall p A (x y : El p A),
  x.(el₀) = y.(el₀) -> x = y.
Proof.
intros p A [x₀ xε] [y₀ yε] e; cbn in *.
destruct e.
replace yε with xε by apply PI.
reflexivity.
Qed.

Definition lift (A : Pfc) {p q} (α : q ≤ p) (x : El p A) : El q A.
Proof.
unshelve refine (mkEl _ _ (fun r β => x.(el₀) r (α ∘ β)) _).
refine (fun r β => x.(elε) r (α ∘ β)).
Defined.

Record Fnc (A B : Pfc) := mkFnc {
  fnc : forall p (x : El p A), B.(elt) p p !;
  rlz : forall p (x : El p A), B.(rel) p (fun q (α : q ≤ p) => cast B α (fnc q (lift A α x)));
}.

Arguments fnc {_ _}.
Arguments rlz {_ _}.

Lemma Fnc_eq : forall A B (f g : Fnc A B),
  (forall p (x : El p A), f.(fnc) p x = g.(fnc) p x) -> f = g.
Proof.
intros A B [f fn] [g gn] e.
cbn in *.
assert (e' : f = g).
{ apply funext; intros p; apply funext; intros x; apply e. }
destruct e'.
replace fn with gn by apply PI.
reflexivity.
Qed.

Definition App {A B p} (f : Fnc A B) (x : El p A) : El p B.
Proof.
unshelve refine (mkEl _ _ (fun q α => f.(fnc) q (lift A α x)) _).
intros q α.
apply (f.(rlz) q (lift A α x)).
Defined.

Definition Fid {A} : Fnc A A.
Proof.
unshelve refine (mkFnc _ _ (fun p x => x.(el₀) p !) _).
intros p x.
refine (x.(elε) p !).
Defined.

Definition Fcmp {A B C} (f : Fnc A B) (g : Fnc B C) : Fnc A C.
Proof.
unshelve refine (mkFnc _ _ (fun p x => g.(fnc) p (App f x)) _).
intros p x.
refine (g.(rlz) _ (App f x)).
Defined.

Definition F (A : Psh) : Pfc.
Proof.
unshelve refine (
  mkPfc
    (fun p q α => A.(set) q)
    (fun p x => forall q (α : q ≤ p), x q α = A.(mon) α (x p !))
    (fun p q α => eq_refl)).
Defined.

Definition G (A : Pfc) : Psh.
Proof.
unshelve refine (
  mkPsh
    (fun p => El p A)
    (fun p q α x => lift A α x)
    (fun p x => eq_refl)
    (fun p q α r β x => eq_refl)
).
Defined.

Definition Fφ {A B} (f : Nat A B) : Fnc (F A) (F B).
Proof.
unshelve refine (mkFnc _ _ _ _).
+ refine (fun p x => f.(hom) p (x.(el₀) p !)).
+ cbn; intros p x q α.
  rewrite <- f.(nat).
  assert (xε := x.(elε) p ! q α).
  cbn in *.
  rewrite <- xε.
  reflexivity.
Defined.

Lemma Fφ_id : forall A, Fφ (@Nid A) = Fid.
Proof.
intros A.
apply Fnc_eq; intros p α; reflexivity.
Qed.

Lemma Fφ_cmp : forall A B C (f : Nat A B) (g : Nat B C), Fφ (Ncmp f g) = Fcmp (Fφ f) (Fφ g).
Proof.
intros A B C f g.
apply Fnc_eq; intros p α; reflexivity.
Qed.

Definition Gφ {A B} (f : Fnc A B) : Nat (G A) (G B).
Proof.
unshelve refine (mkNat _ _ _ _).
+ refine (fun p x => App f x).
+ cbn; intros p q α x.
  reflexivity.
Defined.

Lemma Gφ_id : forall A, Gφ (@Fid A) = Nid.
Proof.
intros A.
apply Nat_eq; intros p α; reflexivity.
Qed.

Lemma Gφ_cmp : forall A B C (f : Fnc A B) (g : Fnc B C), Gφ (Fcmp f g) = Ncmp (Gφ f) (Gφ g).
Proof.
intros A B C f g.
apply Nat_eq; intros p α; reflexivity.
Qed.

Definition of_GF {A} : Nat (G (F A)) A.
Proof.
unshelve refine (mkNat _ _ _ _).
+ refine (fun p x => x.(el₀) p !).
+ intros p q α [x₀ xε]; cbn in *.
  specialize (xε p ! q α).
  etransitivity; [|apply xε].
  reflexivity.
Defined.

Lemma of_GF_nat : forall A B (f : Nat A B),
  Ncmp of_GF f = Ncmp (Gφ (Fφ f)) of_GF.
Proof.
intros A B f.
apply Nat_eq; intros p x.
reflexivity.
Qed.

Definition to_GF {A} : Nat A (G (F A)).
Proof.
unshelve refine (mkNat _ _ _ _).
+ unshelve refine (fun p x => mkEl _ _ (fun q α => _) _).
  - refine (A.(mon) α x).
  - refine (fun q α r β => A.(mon_cmp) _ _ _ _ _ _).
+ cbn; intros p q α x.
  apply El_eq; cbn.
  apply funext; intros r; apply funext; intros β.
  symmetry; apply A.(mon_cmp).
Defined.

Lemma to_GF_nat : forall A B (f : Nat A B),
  Ncmp f to_GF = Ncmp to_GF (Gφ (Fφ f)).
Proof.
intros A B f.
apply Nat_eq; intros p x; apply El_eq.
apply funext; intros q; apply funext; intros α.
cbn.
rewrite f.(nat); reflexivity.
Qed.

Lemma of_to_GF_id : forall A, Ncmp of_GF to_GF = @Nid (G (F A)).
Proof.
intros A.
apply Nat_eq; intros p x; cbn in *.
apply El_eq; cbn.
apply funext; intros q; apply funext; intros α.
symmetry.
apply x.(elε).
Qed.

Lemma to_of_GF_id : forall A, Ncmp to_GF of_GF = @Nid A.
Proof.
intros A.
apply Nat_eq; intros p x; cbn in *.
apply A.(mon_id).
Qed.

Definition of_FG {A} : Fnc (F (G A)) A.
Proof.
unshelve refine (mkFnc _ _ _ _).
+ refine (fun p x => (x.(el₀) p !).(el₀) p !).
+ intros p [x₀ xε]; cbn in *.
  assert (e : x₀ = (fun q (α : q ≤ p) => lift A α (x₀ p !))).
  { apply funext; intros q; apply funext; intros α.
    apply (xε p ! q α). }
  rewrite e; cbn; clear e.
  apply (x₀ p !).(elε).
Defined.

Lemma of_FG_nat : forall A B (f : Fnc A B),
  Fcmp of_FG f = Fcmp (Fφ (Gφ f)) of_FG.
Proof.
intros A B f.
apply Fnc_eq; intros p [x₀ xε]; cbn in *.
f_equal; apply El_eq; cbn.
apply funext; intros q; apply funext; intros α.
specialize (xε p ! q α).
change (α ∘ !) with (! ∘ α).
rewrite xε.
reflexivity.
Qed.

Definition to_FG {A} : Fnc A (F (G A)).
Proof.
unshelve refine (mkFnc _ _ _ _).
+ refine (fun p x => x).
+ intros p x; cbn; reflexivity.
Defined.

Lemma to_FG_nat : forall A B (f : Fnc A B),
  Fcmp f to_FG = Fcmp to_FG (Fφ (Gφ f)).
Proof.
intros A B f.
apply Fnc_eq; intros p x.
reflexivity.
Qed.

Lemma of_to_FG_id : forall A, Fcmp of_FG to_FG = @Fid (F (G A)).
Proof.
intros A.
apply Fnc_eq; intros p [x₀ xε]; cbn in *.
apply El_eq; cbn.
apply funext; intros q; apply funext; intros α.
change (el₀ (x₀ q (! ∘ α)) q ! = el₀ (x₀ p !) q α).
rewrite (xε p ! q α).
reflexivity.
Qed.

Lemma to_of_FG_id : forall A, Fcmp to_FG of_FG = @Fid A.
Proof.
intros A.
apply Fnc_eq; intros p x; cbn in *.
reflexivity.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export Rbase.
Require Export QArith_base.

(** Injection of rational numbers into real numbers. *)

Definition Q2R (x : Q) : R := (IZR (Qnum x) * / IZR (QDen x))%R.

Lemma IZR_nz : forall p : positive, IZR (Zpos p) <> 0%R.
Proof.
intros.
now apply not_O_IZR.
Qed.

Hint Resolve IZR_nz Rmult_integral_contrapositive.

Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y.
Proof.
unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
apply eq_IZR.
do 2 rewrite mult_IZR.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
assert ((X2 * X1 * / X2)%R = (X2 * (Y1 * / Y2))%R).
rewrite <- H; field; auto.
rewrite Rinv_r_simpl_m in H0; auto; rewrite H0; field; auto.
Qed.

Lemma Qeq_eqR : forall x y : Q, x==y -> Q2R x = Q2R y.
Proof.
unfold Qeq, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
assert ((X1 * Y2)%R = (Y1 * X2)%R).
 unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
 apply IZR_eq; auto.
clear H.
field_simplify_eq; auto.
rewrite H0; ring.
Qed.

Lemma Rle_Qle : forall x y : Q, (Q2R x <= Q2R y)%R -> x<=y.
Proof.
unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
apply le_IZR.
do 2 rewrite mult_IZR.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
apply Rmult_le_compat_r; auto.
apply Rmult_le_pos.
now apply IZR_le.
now apply IZR_le.
Qed.

Lemma Qle_Rle : forall x y : Q, x<=y -> (Q2R x <= Q2R y)%R.
Proof.
unfold Qle, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
assert (X1 * Y2 <= Y1 * X2)%R.
 unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
 apply IZR_le; auto.
clear H.
replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
apply Rmult_le_compat_r; auto.
apply Rmult_le_pos; apply Rlt_le; apply Rinv_0_lt_compat.
now apply IZR_lt.
now apply IZR_lt.
Qed.

Lemma Rlt_Qlt : forall x y : Q, (Q2R x < Q2R y)%R -> x<y.
Proof.
unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
apply lt_IZR.
do 2 rewrite mult_IZR.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
replace (X1 * Y2)%R with (X1 * / X2 * (X2 * Y2))%R; try (field; auto).
replace (Y1 * X2)%R with (Y1 * / Y2 * (X2 * Y2))%R; try (field; auto).
apply Rmult_lt_compat_r; auto.
apply Rmult_lt_0_compat.
now apply IZR_lt.
now apply IZR_lt.
Qed.

Lemma Qlt_Rlt : forall x y : Q, x<y -> (Q2R x < Q2R y)%R.
Proof.
unfold Qlt, Q2R; intros (x1, x2) (y1, y2); unfold Qnum, Qden;
 intros.
set (X1 := IZR x1) in *; assert (X2nz := IZR_nz x2);
 set (X2 := IZR (Zpos x2)) in *.
set (Y1 := IZR y1) in *; assert (Y2nz := IZR_nz y2);
 set (Y2 := IZR (Zpos y2)) in *.
assert (X1 * Y2 < Y1 * X2)%R.
 unfold X1, X2, Y1, Y2; do 2 rewrite <- mult_IZR.
 apply IZR_lt; auto.
clear H.
replace (X1 * / X2)%R with (X1 * Y2 * (/ X2 * / Y2))%R; try (field; auto).
replace (Y1 * / Y2)%R with (Y1 * X2 * (/ X2 * / Y2))%R; try (field; auto).
apply Rmult_lt_compat_r; auto.
apply Rmult_lt_0_compat; apply Rinv_0_lt_compat.
now apply IZR_lt.
now apply IZR_lt.
Qed.

Lemma Q2R_plus : forall x y : Q, Q2R (x+y) = (Q2R x + Q2R y)%R.
Proof.
unfold Qplus, Qeq, Q2R; intros (x1, x2) (y1, y2);
 unfold Qden, Qnum.
simpl_mult.
rewrite plus_IZR.
do 3 rewrite mult_IZR.
field; auto.
Qed.

Lemma Q2R_mult : forall x y : Q, Q2R (x*y) = (Q2R x * Q2R y)%R.
Proof.
unfold Qmult, Qeq, Q2R; intros (x1, x2) (y1, y2);
 unfold Qden, Qnum.
simpl_mult.
do 2 rewrite mult_IZR.
field; auto.
Qed.

Lemma Q2R_opp : forall x : Q, Q2R (- x) = (- Q2R x)%R.
Proof.
unfold Qopp, Qeq, Q2R; intros (x1, x2); unfold Qden, Qnum.
rewrite Ropp_Ropp_IZR.
field; auto.
Qed.

Lemma Q2R_minus : forall x y : Q, Q2R (x-y) = (Q2R x - Q2R y)%R.
Proof.
unfold Qminus; intros; rewrite Q2R_plus; rewrite Q2R_opp; auto.
Qed.

Lemma Q2R_inv : forall x : Q, ~ x==0 -> Q2R (/x) = (/ Q2R x)%R.
Proof.
unfold Qinv, Q2R, Qeq; intros (x1, x2). case x1; unfold Qnum, Qden.
simpl; intros; elim H; trivial.
intros; field; auto.
intros;
  change (IZR (Zneg x2)) with (- IZR (Zpos x2))%R;
  change (IZR (Zneg p)) with (- IZR (Zpos p))%R;
  simpl; field; (*auto 8 with real.*)
  repeat split; auto; auto with real.
Qed.

Lemma Q2R_div :
 forall x y : Q, ~ y==0 -> Q2R (x/y) = (Q2R x / Q2R y)%R.
Proof.
unfold Qdiv, Rdiv.
intros; rewrite Q2R_mult.
rewrite Q2R_inv; auto.
Qed.

Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl.