(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 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/>.

  Websites: http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_tacs.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export lsubst_hyps.
Require Export per_can.
Require Export per_props_atom.
Require Export per_props_nat.
Require Export cequiv_util.

(*
   H |- a = b in Base

     By EqualInBase

     H |- a ~ b
     forall v in (free_vars a), H |- v in Base

 *)

Definition rule_equal_in_base_concl {o} (a b : @NTerm o) H :=
  mk_baresequent H (mk_conclax (mk_equality a b mk_base)).

Definition rule_equal_in_base_hyp1 {o} (a b : @NTerm o) H :=
  mk_baresequent H (mk_conclax (mk_cequiv a b)).

Definition rule_equal_in_base_hyp2 {o} (v : NVar) (H : @bhyps o) :=
  mk_baresequent H (mk_conclax (mk_member (mk_var v) mk_base)).

Definition rule_equal_in_base_rest {o} (a : @NTerm o) (H : @bhyps o) :=
  map (fun v => rule_equal_in_base_hyp2 v H)
      (free_vars a).

Definition rule_equal_in_base {o}
           (H : barehypotheses)
           (a b : @NTerm o)
  :=
    mk_rule
      (rule_equal_in_base_concl a b H)
      (rule_equal_in_base_hyp1 a b H :: rule_equal_in_base_rest a H)
      [].

Lemma rule_equal_in_base_true3 {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true3 lib (rule_equal_in_base H a b).
Proof.
  unfold rule_equal_in_base, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent (rule_equal_in_base_concl a b H)) as wfc by prove_seq.
  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  allrw <- @member_cequiv_iff.
  apply tequality_mkc_cequiv in hyp0.
  applydup hyp0 in hyp1; clear hyp0; spcast.
  spcast.
  apply equality_in_base_iff; spcast.
  eapply cequivc_trans;[|eauto].

  clear dependent b.

  pose proof (lsubstc_csub_filter_free_vars a w1 s1 ca1) as e1; exrepnd; rw e0; clear e0.
  pose proof (lsubstc_csub_filter_free_vars a w1 s2 c1) as e2; exrepnd; rw e0; clear e0.

  apply cequivc_lsubstc; try (apply isprogram_csubst; eauto 3 with slow).
  apply implies_cequiv_csub_if_eq_doms; auto.

  { rw @dom_csub_csub_keep.
    apply implies_no_repeats_lkeep.
    apply similarity_dom in sim; repnd.
    rw sim0.
    eapply vswf_hypotheses_implies_no_repeats; eauto. }

  { allrw @dom_csub_csub_keep.
    apply similarity_dom in sim; repnd.
    rw sim0; rw sim; auto. }

  { introv e1 e2.
    rw @csub_find_csub_keep in e1.
    rw @csub_find_csub_keep in e2.
    boolvar; ginv.
    pose proof (hyps (mk_baresequent H (mk_conclax (mk_member (mk_var v) mk_base)))) as hyp.
    autodimp hyp h.

    { rw in_map_iff; eexists; dands; eauto. }

    destruct hyp as [ws hyp].
    destseq; allsimpl; proof_irr; GC.
    vr_seq_true in hyp.
    pose proof (hyp s1 s2 hf sim) as hyp0; clear hyp; exrepnd.
    lsubst_tac.
    clear hyp0.
    apply tequality_mkc_member_base in hyp1; spcast.
    apply cequiv_stable in hyp1.
    repeat (erewrite lsubstc_mk_var_if_csub_find in hyp1;[|eauto]).
    auto. }
Qed.

Lemma rule_equal_in_base_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true lib (rule_equal_in_base H a b).
Proof.
  introv.
  apply rule_true3_implies_rule_true; auto.
  apply rule_equal_in_base_true3; auto.
Qed.

Lemma rule_equal_in_base_true2 {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true2 lib (rule_equal_in_base H a b).
Proof.
  introv.
  apply rule_true_iff_rule_true2; auto.
  apply rule_equal_in_base_true; auto.
Qed.

Lemma rule_equal_in_base_wf2 {o} :
  forall (H : barehypotheses) (a b : @NTerm o),
    wf_rule2 (rule_equal_in_base H a b).
Proof.
  introv wf i.

  allsimpl; repdors; sp; subst; allunfold @wf_bseq; wfseq; auto;
  unfold rule_equal_in_base_rest in i; rw in_map_iff in i; exrepnd; subst; allsimpl; auto.
  unfold covered; simpl.
  allunfold @covered.
  allrw subvars_eq.
  repeat (rw subset_cons_l); dands; auto.
Qed.

(* same as above but we don't force the subgoals to have given extracts *)

Definition rule_equal_in_base2_hyp1 {o} (a b : @NTerm o) e H :=
  mk_baresequent H (mk_concl (mk_cequiv a b) e).

Definition rule_equal_in_base2_hyp2 {o} (v : NVar) e (H : @bhyps o) :=
  mk_baresequent H (mk_concl (mk_member (mk_var v) mk_base) e).

Definition rule_equal_in_base2_rest {o}
           (a : @NTerm o)
           (F : forall v (i : LIn v (free_vars a)), @NTerm o)
           (H : @bhyps o) :=
  mapin
    (free_vars a)
    (fun v i => rule_equal_in_base2_hyp2 v (F v i) H).

Definition rule_equal_in_base2 {o}
           (H : barehypotheses)
           (a b : @NTerm o)
           (e : NTerm)
           (F : forall v (i : LIn v (free_vars a)), @NTerm o)
  :=
    mk_rule
      (rule_equal_in_base_concl a b H)
      (rule_equal_in_base2_hyp1 a b e H :: rule_equal_in_base2_rest a F H)
      [].

Lemma rule_equal_in_base2_true3 {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o) e F,
    rule_true3 lib (rule_equal_in_base2 H a b e F).
Proof.
  unfold rule_equal_in_base2, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  repnd.
  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent (rule_equal_in_base_concl a b H)) as wfc by prove_seq.
  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  allrw @equality_in_mkc_cequiv; repnd.
  apply tequality_mkc_cequiv in hyp0.
  applydup hyp0 in hyp1; clear hyp0; spcast.
  spcast.
  apply equality_in_base_iff; spcast.
  eapply cequivc_trans;[|eauto].

  clear dependent b.

  pose proof (lsubstc_csub_filter_free_vars a w1 s1 ca1) as e1; exrepnd; rw e0; clear e0.
  pose proof (lsubstc_csub_filter_free_vars a w1 s2 c1) as e2; exrepnd; rw e0; clear e0.

  apply cequivc_lsubstc; try (apply isprogram_csubst; eauto 3 with slow).
  apply implies_cequiv_csub_if_eq_doms; auto.

  { rw @dom_csub_csub_keep.
    apply implies_no_repeats_lkeep.
    apply similarity_dom in sim; repnd.
    rw sim0.
    eapply vswf_hypotheses_implies_no_repeats; eauto. }

  { allrw @dom_csub_csub_keep.
    apply similarity_dom in sim; repnd.
    rw sim0; rw sim; auto. }

  { introv e1 e2.
    rw @csub_find_csub_keep in e1.
    rw @csub_find_csub_keep in e2.
    boolvar; ginv.
    pose proof (hyps (mk_baresequent H (mk_concl (mk_member (mk_var v) mk_base) (F v Heqb)))) as hyp.
    autodimp hyp h.

    { unfold rule_equal_in_base2_rest.
      apply in_mapin.
      eexists; eexists.
      unfold rule_equal_in_base2_hyp2; eauto. }

    destruct hyp as [ws hyp].
    destseq; allsimpl; proof_irr; GC.
    vr_seq_true in hyp.
    pose proof (hyp s1 s2 hf sim) as hyp0; clear hyp; exrepnd.
    lsubst_tac.
    clear hyp0.
    apply tequality_mkc_member_base in hyp1; spcast.
    apply cequiv_stable in hyp1.
    repeat (erewrite lsubstc_mk_var_if_csub_find in hyp1;[|eauto]).
    auto. }
Qed.

Lemma rule_equal_in_base2_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o) e F,
    rule_true lib (rule_equal_in_base2 H a b e F).
Proof.
  introv.
  apply rule_true3_implies_rule_true; auto.
  apply rule_equal_in_base2_true3; auto.
Qed.

Lemma rule_equal_in_base2_true2 {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o) e F,
    rule_true2 lib (rule_equal_in_base2 H a b e F).
Proof.
  introv.
  apply rule_true_iff_rule_true2; auto.
  apply rule_equal_in_base2_true; auto.
Qed.

Lemma rule_equal_in_base2_wf2 {o} :
  forall (H : barehypotheses) (a b : @NTerm o) e F,
    wf_rule2 (rule_equal_in_base2 H a b e F).
Proof.
  introv wf i.

  allsimpl; repdors; sp; subst; allunfold @wf_bseq; wfseq; auto;
  unfold rule_equal_in_base_rest in i; apply in_mapin in i; exrepnd; subst; allsimpl; auto.
  unfold covered; simpl.
  allunfold @covered.
  allrw subvars_eq.
  repeat (rw subset_cons_l); dands; auto.
Qed.

(*
   H |- a = b in Base

     By AtomSubtypeBase

     H |- a = b in Atom

 *)
Definition rule_atom_subtype_base {o}
           (H : barehypotheses)
           (a b : @NTerm o)
  :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_equality a b mk_base)))
      [mk_baresequent H (mk_conclax (mk_equality a b mk_atom))]
      [].

Lemma rule_atom_subtype_base_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true lib (rule_atom_subtype_base H a b).
Proof.
  unfold rule_atom_subtype_base, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  apply equality_commutes in hyp0; auto; clear hyp1.
  apply equality_in_atom_iff in hyp0; exrepnd; spcast.
  apply equality_in_base_iff; spcast.
  eapply cequivc_trans;
    [apply computes_to_valc_implies_cequivc;eauto|].
  eapply cequivc_trans;
    [|apply cequivc_sym;apply computes_to_valc_implies_cequivc;eauto].
  apply cequivc_refl.
Qed.

(*
   H |- a = b in Base

     By UAtomSubtypeBase

     H |- a = b in UAtom

 *)
Definition rule_uatom_subtype_base {o}
           (H : barehypotheses)
           (a b : @NTerm o)
  :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_equality a b mk_base)))
      [mk_baresequent H (mk_conclax (mk_equality a b mk_uatom))]
      [].

Lemma rule_uatom_subtype_base_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true lib (rule_uatom_subtype_base H a b).
Proof.
  unfold rule_uatom_subtype_base, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  apply equality_commutes in hyp0; auto; clear hyp1.
  apply equality_in_uatom_iff in hyp0; exrepnd; spcast.
  apply equality_in_base_iff; spcast.
  eapply cequivc_trans;
    [apply computes_to_valc_implies_cequivc;eauto|].
  eapply cequivc_trans;
    [|apply cequivc_sym;apply computes_to_valc_implies_cequivc;eauto].
  apply cequivc_refl.
Qed.

(*
   H |- a = b in Base

     By IntSubtypeBase

     H |- a = b in Int

 *)
Definition rule_int_subtype_base {o}
           (H : barehypotheses)
           (a b : @NTerm o)
  :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_equality a b mk_base)))
      [mk_baresequent H (mk_conclax (mk_equality a b mk_int))]
      [].

Lemma rule_int_subtype_base_true {o} :
  forall lib (H : barehypotheses)
         (a b : @NTerm o),
    rule_true lib (rule_int_subtype_base H a b).
Proof.
  unfold rule_int_subtype_base, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  clear cargs.

  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  vr_seq_true.
  lsubst_tac.
  allrw <- @member_equality_iff.

  teq_and_eq (@mk_base o) a b s1 s2 H; eauto 3 with slow.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1; exrepnd.
  lsubst_tac.
  allrw <- @member_equality_iff.
  apply equality_commutes in hyp0; auto; clear hyp1.
  apply equality_in_int_implies_cequiv in hyp0.
  apply equality_in_base_iff; spcast; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/" "../terms/" "../computation/" "../cequiv/" "../per/" "../close/")
*** End:
*)


(* ==================================== *)
(* ===== CH07_inv_hmap_inv_poly.v ===== *)
(* ==================================== *)

Require Export CH06_induction.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Lemma map_left_dart_less :
  forall (m:fmap)(mr:fmap)(p:point)(da:dart),
  inv_hmap mr -> inv_poly mr -> well_emb mr ->
  inv_noalign_point mr p -> convex mr ->
  inv_hmap m -> ~ exd m da -> left_dart mr p da ->
  forall (d:dart), exd m d -> ~ left_dart mr p d.
Proof.
intros m mr p da H_1 H_2 H_3 H_4 H_5 Hmap Hexd Hleft db Hdb.
induction m.
 (* Cas 1 : m = V *)
 simpl in *; tauto.
 (* Cas 2 : m = I *)
 simpl in *.
 destruct Hmap as [Hmap [Hmap1 Hmap2]].
 rewritenotorandnot Hexd Hexd1 Hexd2.
 elim Hdb; clear Hdb; intro Hdb; [subst db | idtac].
  elim (left_dart_dec mr p d); [intro H1 | trivial].
   generalize (one_left mr p da d H_1 H_2 H_3 H_4 H_5 Hleft H1).
   intro H3; apply neq_sym in Hexd1; contradiction.
  apply (IHm Hmap Hexd2 Hdb).
 (* Cas 3 : m = L *)
 simpl in *; apply IHm; intuition.
Qed.

Lemma map_right_dart_less :
  forall (m:fmap)(mr:fmap)(p:point)(da:dart),
  inv_hmap mr -> inv_poly mr -> well_emb mr ->
  inv_noalign_point mr p -> convex mr ->
  inv_hmap m -> ~ exd m da -> right_dart mr p da ->
  forall (d:dart), exd m d -> ~ right_dart mr p d.
Proof.
intros m mr p da H_1 H_2 H_3 H_4 H_5 Hmap Hexd Hright db Hdb.
induction m.
 (* Cas 1 : m = V *)
 simpl in *; tauto.
 (* Cas 2 : m = I *)
 simpl in *.
 destruct Hmap as [Hmap [Hmap1 Hmap2]].
 rewritenotorandnot Hexd Hexd1 Hexd2.
 elim Hdb; clear Hdb; intro Hdb; [subst db | idtac].
  elim (right_dart_dec mr p d); [intro H1 | trivial].
   generalize (one_right mr p da d H_1 H_2 H_3 H_4 H_5 Hright H1).
   intro H3; apply neq_sym in Hexd1; contradiction.
  apply (IHm Hmap Hexd2 Hdb).
 (* Cas 3 : m = L *)
 simpl in *; apply IHm; tauto.
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Theorem inv_hmap_CHID :
  forall (m:fmap)(mr:fmap)(x:dart)(tx:tag)(px:point)(max:dart),
  submap m mr -> inv_hmap m ->
  inv_hmap mr -> inv_poly mr -> well_emb mr -> inv_noalign_point mr px -> convex mr ->
  x <> nil -> max <> nil -> x <> max -> ~ exd mr x ->  ~ exd mr max ->
  inv_hmap (CHID m mr x tx px max).
Proof.
intros m mr x tx px max Hsub Hinv1 Hmr1 Hmr2 Hmr3 Hmr4 Hmr5 Hneq1 Hneq2 Hneq0 Hexd1 Hexd2.
induction m.
 (* Cas 1 : m = V *)
 simpl in *; unfold prec_I; simpl; tauto.
 (* Cas 2 : m = I *)
simpl in Hsub, Hinv1.
unfold prec_I in Hinv1.
destruct Hsub as [Hsub [Hsub1 [Hsub2 Hsub3]]].
destruct Hinv1 as [Hinv1 [Hneq3 Hexd3]].
generalize (IHm Hsub Hinv1); clear IHm; intro IHm.
 simpl in *.
 elim blue_dart_dec.
  elim invisible_dec.
   intros H_ccw H_blue.
(* == 1 == *)
simpl; unfold prec_I; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
(* ======= *)
   elim left_dart_dec.
    intros H_left H_ccw H_blue.
(* == 2 == *)
simpl; unfold prec_I, prec_L.
simpl; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
apply and_not_not_or; split.
 apply (exd_not_exd_neq mr d max); assumption.
 apply (max_CHID_3 m mr x tx px max); try assumption.
  apply (submap_not_exd m mr max); try assumption.
  apply (map_left_dart_less m mr px d); try assumption.
left; trivial.
right; right; apply (x_CHID_1 m mr x tx px max); try assumption.
unfold succ; simpl; apply (max_CHID_4 m mr x tx px max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply (map_left_dart_less m mr px d); try assumption.
unfold pred; simpl; apply (x_CHID_5 m mr x tx px max); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply (map_left_dart_less m mr px d); try assumption.
elimeqdartdec; apply neq_sym; assumption.
right; left; trivial.
left; trivial.
unfold succ; simpl; apply eq_not_neq; apply not_exd_A_nil; try assumption.
 apply (not_exd_CHID m mr x tx px max d); try assumption.
  apply (exd_not_exd_neq mr d x); assumption.
  apply (exd_not_exd_neq mr d max); assumption.
unfold pred; simpl; apply (max_CHID_5 m mr x tx px max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply (map_left_dart_less m mr px d); try assumption.
elim (eq_dart_dec max d).
 intro Heq; subst d; contradiction.
 elimeqdartdec; intuition.
(* ======= *)
    intros H_left H_ccw H_blue.
(* == 3 == *)
simpl; unfold prec_I; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
(* ======= *)
  elim red_dart_dec.
   elim invisible_dec.
    intros H_ccw H_red H_blue.
(* == 4 == *)
simpl; unfold prec_I; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
(* ======= *)
    elim right_dart_dec.
    intros H_right H_ccw H_red H_blue.
(* == 5 == *)
simpl; unfold prec_I, prec_L.
simpl; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
right; apply (x_CHID_1 m mr x tx px max); try assumption.
left; trivial.
unfold succ; simpl; apply (x_CHID_4 m mr x tx px max); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply (map_right_dart_less m mr px d); try assumption.
unfold pred; simpl; apply eq_not_neq; apply not_exd_A_1_nil; try assumption.
 apply (not_exd_CHID m mr x tx px max d); try assumption.
  apply (exd_not_exd_neq mr d x); assumption.
  apply (exd_not_exd_neq mr d max); assumption.
elim (eq_dart_dec d x); intro Heq.
 subst d; contradiction.
 assert (H0 : cA (CHID m mr x tx px max) zero x = x).
  apply fixpoint_cA; try assumption.
  apply (x_CHID_1 m mr x tx px max); try assumption.
  apply (x_CHID_4 m mr x tx px max); try assumption.
   apply (submap_not_exd m mr x); try assumption.
   apply (map_right_dart_less m mr px d); try assumption.
  apply (x_CHID_3 m mr x tx px max); try assumption.
   apply (submap_not_exd m mr x); try assumption.
 rewrite H0; apply neq_sym; assumption.
(* ======= *)
     intros H_right H_ccw H_red H_blue.
(* == 6 == *)
assumption.
(* ======= *)
   intros Hred Hblue.
(* == 7 == *)
simpl; unfold prec_I; repeat split; try assumption.
apply (not_exd_CHID m mr x tx px max d); try assumption.
 apply (exd_not_exd_neq mr d x); assumption.
 apply (exd_not_exd_neq mr d max); assumption.
(* ======= *)
 (* Cas 3 : m = L *)
simpl in Hsub, Hinv1.
unfold prec_L in Hinv1.
destruct Hsub as [Hsub [Hsub1 Hsub2]].
destruct Hinv1 as [Hinv1 [H1 [H2 [H3 [H4 H5]]]]].
generalize (IHm Hsub Hinv1); clear IHm; intro IHm.
induction d; simpl in *.
  elim ccw_dec.
   intros H_ccw.
(* == 8 == *)
simpl; unfold prec_L; repeat split; try assumption.
apply (blue_dart_CHID_1 m mr x tx px max d0); try assumption.
 apply succ_zero_blue_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
apply (red_dart_CHID_3 m mr x tx px max d1); try assumption.
 apply pred_zero_red_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
 unfold invisible; elim blue_dart_dec; intro Hblue.
  cut (~ blue_dart mr d1); [contradiction|idtac].
  apply red_not_blue; try assumption.
  apply pred_zero_red_dart; try assumption.
  unfold pred; rewrite Hsub2; try assumption.
  apply (exd_not_nil m d0); try assumption.
  left; rewrite Hsub2; assumption.
apply (blue_dart_CHID_5 m mr x tx px max d0); try assumption.
 apply (exd_not_exd_neq m d0 x); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply succ_zero_blue_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 rewrite Hsub1; assumption.
apply (red_dart_CHID_8 m mr x tx px max d1); try assumption.
 apply (exd_not_exd_neq m d1 max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply pred_zero_red_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
 rewrite Hsub2; assumption.
assert (H0 : cA (CHID m mr x tx px max) zero d0 = d0).
 apply fixpoint_cA; try assumption.
 apply (blue_dart_CHID_1 m mr x tx px max d0); try assumption.
  apply succ_zero_blue_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 apply (blue_dart_CHID_5 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 x); try assumption.
  apply (submap_not_exd m mr x); try assumption.
  apply succ_zero_blue_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
  rewrite Hsub1; assumption.
 apply (blue_dart_CHID_3 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 max); try assumption.
  apply (submap_not_exd m mr max); try assumption.
  apply succ_zero_blue_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 rewrite H0; elim (eq_dart_dec d0 d1); [idtac|trivial].
  intro Heq; move Heq after Hsub; subst d0.
  assert (Hblue : blue_dart mr d1).
   apply succ_zero_blue_dart; try assumption.
   unfold succ; rewrite Hsub1; try assumption.
   apply (exd_not_nil m d1); try assumption.
  assert (Hred : red_dart mr d1).
   apply pred_zero_red_dart; try assumption.
   unfold pred; rewrite Hsub2; try assumption.
   apply (exd_not_nil m d1); try assumption.
  apply blue_not_red in Hblue; contradiction.
(* ======= *)
   intros H_ccw.
(* == 9 == *)
assumption.
(* ======= *)
  elim invisible_dec.
   intros H_ccw.
(* == 10 == *)
simpl; unfold prec_L; repeat split; try assumption.
apply (red_dart_CHID_3 m mr x tx px max d0); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
apply (blue_dart_CHID_1 m mr x tx px max d1); try assumption.
 apply pred_one_blue_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
apply (red_dart_CHID_5 m mr x tx px max d0); try assumption.
 apply (exd_not_exd_neq m d0 max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
apply (blue_dart_CHID_20 m mr x tx px max d1); try assumption.
 apply (exd_not_exd_neq m d1 x); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply pred_one_blue_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
assert (H0 : cA (CHID m mr x tx px max) one d0 = d0).
 apply fixpoint_cA; try assumption.
 apply (red_dart_CHID_3 m mr x tx px max d0); try assumption.
  apply succ_one_red_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 apply (red_dart_CHID_5 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 max); try assumption.
  apply (submap_not_exd m mr max); try assumption.
  apply succ_one_red_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 apply (red_dart_CHID_2 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 x); try assumption.
  apply (submap_not_exd m mr x); try assumption.
  apply succ_one_red_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 rewrite H0; elim (eq_dart_dec d0 d1); [idtac|trivial].
  intro Heq; move Heq after Hsub; subst d0.
  assert (Hblue : blue_dart mr d1).
   apply pred_one_blue_dart; try assumption.
   unfold pred; rewrite Hsub2; try assumption.
   apply (exd_not_nil m d1); try assumption.
  assert (Hred : red_dart mr d1).
   apply succ_one_red_dart; try assumption.
   unfold succ; rewrite Hsub1; try assumption.
   apply (exd_not_nil m d1); try assumption.
  apply blue_not_red in Hblue; contradiction.
(* ======== *)
   elim invisible_dec.
    intros H_ccw1 H_ccw2.
(* == 11 == *)
simpl; unfold prec_L; repeat split; try assumption.
apply (red_dart_CHID_11 m mr x tx px max d0); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 apply not_invisible_visible in H_ccw2; assumption.
 rewrite Hsub1; assumption.
apply (blue_dart_CHID_1 m mr x tx px max d1); try assumption.
 apply pred_one_blue_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
apply (red_dart_CHID_13 m mr x tx px max d0); try assumption.
 apply (exd_not_exd_neq m d0 max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 apply not_invisible_visible in H_ccw2; assumption.
 rewrite Hsub1; assumption.
apply (blue_dart_CHID_20 m mr x tx px max d1); try assumption.
 apply (exd_not_exd_neq m d1 x); try assumption.
 apply (submap_not_exd m mr x); try assumption.
 apply pred_one_blue_dart; try assumption.
 unfold pred; rewrite Hsub2; try assumption.
 apply (exd_not_nil m d0); try assumption.
assert (H0 : cA (CHID m mr x tx px max) one d0 = d0).
 apply fixpoint_cA; try assumption.
apply (red_dart_CHID_11 m mr x tx px max d0); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 apply not_invisible_visible in H_ccw2; assumption.
 rewrite Hsub1; assumption.
apply (red_dart_CHID_13 m mr x tx px max d0); try assumption.
 apply (exd_not_exd_neq m d0 max); try assumption.
 apply (submap_not_exd m mr max); try assumption.
 apply succ_one_red_dart; try assumption.
 unfold succ; rewrite Hsub1; try assumption.
 apply (exd_not_nil m d1); try assumption.
 apply not_invisible_visible in H_ccw2; assumption.
 rewrite Hsub1; assumption.
 apply (red_dart_CHID_2 m mr x tx px max d0); try assumption.
  apply (exd_not_exd_neq m d0 x); try assumption.
  apply (submap_not_exd m mr x); try assumption.
  apply succ_one_red_dart; try assumption.
  unfold succ; rewrite Hsub1; try assumption.
  apply (exd_not_nil m d1); try assumption.
 rewrite H0; elim (eq_dart_dec d0 d1); [idtac|trivial].
  intro Heq; move Heq after Hsub; subst d0.
  assert (Hblue : blue_dart mr d1).
   apply pred_one_blue_dart; try assumption.
   unfold pred; rewrite Hsub2; try assumption.
   apply (exd_not_nil m d1); try assumption.
  assert (Hred : red_dart mr d1).
   apply succ_one_red_dart; try assumption.
   unfold succ; rewrite Hsub1; try assumption.
   apply (exd_not_nil m d1); try assumption.
  apply blue_not_red in Hblue; contradiction.
(* ======== *)
    intros H_ccw1 H_ccw2.
(* == 12 == *)
assumption.
(* ======== *)
Qed.

(* ========================== *)
(* ======= ########## ======= *)
(* ========================== *)

Theorem inv_poly_CHID :
  forall (m:fmap)(x:dart)(tx:tag)(px:point)(max:dart),
  inv_hmap m -> inv_poly m -> well_emb m -> inv_noalign_point m px -> convex m ->
  x <> nil -> max <> nil -> x <> max -> ~ exd m x ->  ~ exd m max ->
  inv_poly (CHID m m x tx px max).
Proof.
intros m x tx px max H1 H2 H3 H4 H5 Hneq1 Hneq2 Hneq0 Hexd1 Hexd2.
unfold inv_poly; intros d Hexd0.
assert (Hsub : submap m m).
 apply submap_2_submap; try assumption.
 apply submap_2_refl.
generalize (exd_CHID_exd_m_or_x_or_max m m x tx px max d Hexd0); intro H.
elim H; clear H; intro H.
 generalize (H2 d H); clear H2; intro H2.
 elim H2; clear H2; intro H2.
  left; apply black_dart_CHID; try assumption.
  apply (exd_not_exd_neq m d x); try assumption.
  apply (exd_not_exd_neq m d max); try assumption.
 elim H2; clear H2; intro H2.
  cut (black_dart (CHID m m x tx px max) d \/ blue_dart (CHID m m x tx px max) d).
  intro H0; elim H0; clear H0; intro H0.
  left; assumption.
  right; left; assumption.
  apply blue_dart_CHID; try assumption.
  apply (exd_not_exd_neq m d x); try assumption.
  apply (exd_not_exd_neq m d max); try assumption.
  cut (~ exd (CHID m m x tx px max) d \/ red_dart (CHID m m x tx px max) d).
  intro H0; elim H0; clear H0; intro H0.
  contradiction.
  right; right; assumption.
  apply red_dart_CHID; try assumption.
  apply (exd_not_exd_neq m d x); try assumption.
  apply (exd_not_exd_neq m d max); try assumption.
elim H; clear H; intro H; subst d.
 elim (pred_dec (CHID m m x tx px max) one x); intro Hpred.
  apply (pred_one_x_exd_left_dart) in Hpred; try assumption.
  generalize (exd_left_dart_exd_right_dart m px H1 H2 Hpred); intro Hsucc.
  cut (blue_dart (CHID m m x tx px max) x).
  right; left; assumption.
  apply x_CHID_11; try assumption.
  cut (forall (d:dart), exd m d -> ~ left_dart m px d). intro Hleft.
  cut (forall (d:dart), exd m d -> ~ right_dart m px d). intro Hright.
  cut (black_dart (CHID m m x tx px max) x).
  left; assumption.
  apply x_CHID_6; try assumption.
  intros d Hexd; split.
  apply Hleft; try assumption.
  apply Hright; try assumption.
  apply not_exd_left_dart_not_exd_right_dart; try assumption.
  intros d Hexd.
  apply (not_pred_one_x_not_exd_left_dart m m x tx px max); try assumption.
  cut (~ exd (CHID m m x tx px max) max \/ red_dart (CHID m m x tx px max) max).
  intro H0; elim H0; clear H0; intro H0.
  contradiction.
  right; right; assumption.
  apply max_CHID; try assumption.
  left; apply exd_max_exd_left_dart with x tx max; try assumption.
Qed.


(**
HSS Signature to Signature functor

*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Notations.
(* Require Import UniMath.SubstitutionSystems.FromBindingSigsToMonads_Summary. *)
Require Import UniMath.SubstitutionSystems.BindingSigToMonad.
Require Import UniMath.SubstitutionSystems.Signatures.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.

Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.EpiFacts.
(* Require Import UniMath.CategoryTheory.Chains.All. *)
Require Import UniMath.Combinatorics.Lists.
Require Import UniMath.CategoryTheory.whiskering.

Require Import UniMath.SubstitutionSystems.ModulesFromSignatures.
Require Import UniMath.SubstitutionSystems.SignatureCategory.
Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.LModulesComplements.
Require Import Modules.Signatures.Signature.
Open Scope cat.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.CategoryTheory.PointedFunctors.
Set Automatic Introduction.

Section LiftLModuleMor.

Context {C D : category} (H : Signature C D C)
          (T : Monad C).

Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)).
Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H) ).
Local Notation "'p' T" := (ptd_from_mon  T) (at level 3).

(* Has this been already defined somewhere ?? *)
Definition ptd_mor_from_Monad_mor {M N : Monad C} (f : Monad_Mor M N)
  : ptd_mor _ (p M) (p N).
Proof.
  use tpair.
  - apply f.
  - intro c.
    apply (Monad_Mor_η f).
Defined.

Local Notation liftlmodule := (ModulesFromSignatures.lift_lmodule H T).
(* We should move this part (that turns a signature into a functor)
 into UniMath/ModulesFromSignatures *)
(**
The following diagram must be proved commutative:
<<<

                H f (T X)                θ
  (H M) (T X) ---------> (H N) (T X) --------> H (N T) X
       |                                           |
       |                                           |
       |                                           |
 θ     |                                           |  H (σ_N) X
       |                                           |
       |                                           |
       V                                           V
   H (M T) X ------------> (H M) X ----------->  (H N) X
                H (σ_M) X            (H f) X

>>>

By naturality of θ, the top arrow rewrites
<<<
                θ                      H (f T) X
  (H M) (T X) ---------> (H (M T)) X ----------> H (N T) X
>>>
And the remaining diagram comes from the fact that f is a module morphism

*)

Lemma lift_lmodule_mor_law {M N : LModule T C} (f : LModule_Mor T M N) :
  LModule_Mor_laws T (T := liftlmodule M) (T' := liftlmodule N) (# H (f : _ ⟹ _)).
Proof.
  intro X.
  etrans; [apply assoc|].
  etrans.
  {
    apply cancel_postcomposition.
    apply (θ_nat_1_pw _ _ (f : nat_trans _ _) (p T) X).
  }
  etrans;[|apply assoc].
  etrans;[eapply pathsinv0; apply assoc |].
  apply cancel_precomposition.
  etrans; [apply functor_comp_pw|].
  etrans; [| eapply pathsinv0; apply functor_comp_pw].
  apply functor_cancel_pw.
  apply (nat_trans_eq (homset_property _)).
  intro x.
  cbn. unfold HorizontalComposition.horcomp_data; cbn.
  rewrite functor_id, id_right.
  apply LModule_Mor_σ.
Qed.

Definition lift_lmodule_mor {M N : LModule T C} (f : LModule_Mor T M N) :
  LModule_Mor T (liftlmodule M) (liftlmodule N)
  := # H (f : M ⟹ N),, lift_lmodule_mor_law f.

End LiftLModuleMor.

Section SigWithStrengthToSignature.

Context {C : category}.

Local Notation MONAD := (Monad C).
Local Notation PRE_MONAD := (category_Monad C).

Local Notation hsC := (homset_property C).

Context (H : Signature C C C).
Local Notation liftlmodule := (ModulesFromSignatures.lift_lmodule H ).

Local Notation θ_nat_2_pw := (θ_nat_2_pointwise _ _ _ H (theta H)).
Local Notation θ_nat_1_pw := (θ_nat_1_pointwise _ _ _ H (theta H) ).
(** commutation pullback module/liftlmodule *)
(**
It is almost the same diagram than for liftlmodule_mor, but now we exploit
the naturality in the second component
<<<

                H S (T X)                θ
  (H S) (R X) ---------> (H S) (S X) --------> H (S S) X
       |                                           |
       |                                           |
       |                                           |
 θ     |                                           |  H (μ_S) X
       |                                           |
       |                                           |
       V                                           V
   H (S R) X ------------> (H M) X ----------->  (H S) X
                H (σ_M) X            (H f) X

>>>

By naturality of θ, the top arrow rewrites
<<<
                θ                      H (f T) X
  (H M) (T X) ---------> (H (M T)) X ----------> H (N T) X
>>>
*)
Lemma lift_pb_LModule_eq_mult {R S : Monad C} ( f : Monad_Mor R S) c :
  (ModulesFromSignatures.lift_lm_mult H R (pb_LModule f (tautological_LModule S)) : nat_trans _ _) c =
  (pb_LModule_σ f (liftlmodule S (tautological_LModule S))) c.
Proof.
  apply pathsinv0.
    etrans;[ apply assoc|].
  etrans.
  {
    apply cancel_postcomposition.
    apply (θ_nat_2_pw (S : functor _ _) _ _ (ptd_mor_from_Monad_mor f)).
  }
  apply pathsinv0.
  cbn.
  etrans;[|apply assoc].
  apply cancel_precomposition.
  apply pathsinv0.
  etrans;[apply functor_comp_pw|].
  apply functor_cancel_pw.
  apply nat_trans_eq.
  - apply homset_property.
  - intro x.
    cbn. unfold HorizontalComposition.horcomp_data; cbn.
    rewrite id_left.
    apply idpath.
Qed.

Lemma lift_pb_LModule_iso
  {R S : Monad C}
  (f : Monad_Mor R S) :
    iso (C := precategory_LModule _ _)
    (liftlmodule R (pb_LModule f (tautological_LModule S)))
    (pb_LModule f (liftlmodule S (tautological_LModule S))).
Proof.
  apply LModule_same_func_iso.
  apply lift_pb_LModule_eq_mult.
Defined.

Definition lift_pb_LModule
  {R S : Monad C}
  (f : Monad_Mor R S) :
  LModule_Mor R (liftlmodule R (pb_LModule f (tautological_LModule S)))
              (pb_LModule f (liftlmodule S (tautological_LModule S))) :=
  morphism_from_iso (lift_pb_LModule_iso f).

Definition sigWithStrength_to_sig_data : @signature_data C.
Proof.
  use tpair.
  + intro R.
    apply (ModulesFromSignatures.lift_lmodule H _ (tautological_LModule _ )).
  + cbn.
    intros R S f.
    cbn.
    (* We need a morphism H R ---> H (f* S)
        defined as H R ---> H (f* S) ---> f* (H S)
     *)
    eapply (compose (C := category_LModule R C)).
           (* LModule_composition. *)
    * use lift_lmodule_mor.
      -- apply (pb_LModule f).
         apply (tautological_LModule S).
      -- apply monad_mor_to_lmodule.
    * apply lift_pb_LModule.
Defined.

Lemma sigWithStrength_to_sig_is_signature : is_signature sigWithStrength_to_sig_data.
Proof.
  split.
  - intros R X.
    cbn.
    rewrite id_right.
    assert (h := functor_id H (R : functor _ _)).
    eapply nat_trans_eq_pointwise in h.
    etrans; [|apply h].
    apply functor_cancel_pw.
    apply (nat_trans_eq (homset_property _)).
    intro; apply idpath.
  - intros R S T f g.
    apply LModule_Mor_equiv;[apply homset_property|].
    apply nat_trans_eq;[apply homset_property|].
    intro x.
    cbn.
    rewrite !id_right.
    apply pathsinv0.
    apply functor_comp_pw.
Qed.

Definition sigWithStrength_to_sig : signature C := sigWithStrength_to_sig_data ,, sigWithStrength_to_sig_is_signature.

End SigWithStrengthToSignature.

Section SigWithStrengthToSignatureMor.
  Context {C  : category}.

  Let Sig := Signature_category C C C.
  Local Notation F := sigWithStrength_to_sig.

  Context {A B : Sig}.
  Variable (f : Sig ⟦ A, B⟧).

  (* Let θ_nat_2_pw (H : Signature C (homset_property C) C (homset_property C)) := *)
  (*   (θ_nat_2_pointwise _ _ _ _ H (theta H)). *)
  (* Let θ_nat_1_pw (H : Signature C (homset_property C) C (homset_property C)) := *)
  (*   (θ_nat_1_pointwise _ _ _ _ H (theta H)). *)
  Local Notation "'p' T" := (ptd_from_mon T) (at level 3).

  Lemma sigWithStrength_to_sig_mod_mor_laws (R : Monad C) :
  @LModule_Mor_laws C R C (F A R) (F B R)
    ( (# (SignatureForgetfulFunctor C C C) f : nat_trans _ _) ( R : functor _ _ )).
  Proof.
    (*
<<<
              f_R R
    A(R) R -----------> B(R) R
       |                   |
       |                   |
 θ A   |                   | θ B
       |                   |
       |                   |
       V                   V
    A(R R)              B (R R)
       |                   |
       |                   |
 A(μ)  |                   | B(μ)
       |                   |
       |                   |
       V                   V
      A(R) ----------->  B(R)
             f_R
>>>
And as f is a signature morphism, we have

<<<
              f_X R
    A(X) R ---------->  B(X) R
       |                   |
       |                   |
 θ A   |                   | θ B
       |                   |
       |                   |
       V                   V
    A(X R) ----------->  B(X R)
             f_XR
>>>
*)
    intro c.
    assert (hf := nat_trans_eq_pointwise (pr2 f (R : functor _ _) (p R)) c).
    cbn in hf. unfold HorizontalComposition.horcomp_data in hf; cbn in hf.
    rewrite functor_id,id_right in hf.
    cbn.
    etrans.
    {
      etrans;[apply assoc|].
      apply cancel_postcomposition.
      exact ( !hf).
    }
    do 2 rewrite <- assoc.
    apply cancel_precomposition.
    apply pathsinv0.
    assert (hf' := (nat_trans_ax (pr1 f) _ _ (μ R) )).
    eapply nat_trans_eq_pointwise in hf'.
    apply hf'.
  Qed.

  Definition sigWithStrength_to_sig_mod_mor (R : Monad C) :
    LModule_Mor  R  (F A R) (F B R) :=
    _ ,, sigWithStrength_to_sig_mod_mor_laws R.

  Lemma sigWithStrength_to_sig_is_signature_Mor : is_signature_Mor (F A) (F B) sigWithStrength_to_sig_mod_mor.
  Proof.
    intros R S g.
    change ((#(A : Signature _ _ _ ) (g : nat_trans _ _))· identity _ · (pr11 f (S : functor _ _)) =
            (pr11 f (R : functor _ _)) · (# (B : Signature _ _ _ ) (g : nat_trans _ _) · identity _)).
    do 2 rewrite id_right.
    apply nat_trans_ax.
  Qed.
  Definition sigWithStrength_to_sig_mor   : signature_Mor (F A) (F B) :=
    _ ,, sigWithStrength_to_sig_is_signature_Mor.
End SigWithStrengthToSignatureMor.

Section SigWithStrengthToSignatureFunctor.
  Context {C  : category}.

  Let Sig := Signature_category C C C.
  Local Notation F := sigWithStrength_to_sig.

  Definition sigWithStrength_to_sig_functor_data : functor_data Sig (signature_category (C := C)) :=
    make_functor_data (C' := signature_category) _ (@sigWithStrength_to_sig_mor C).

  Lemma sigWithStrength_to_sig_is_functor : is_functor sigWithStrength_to_sig_functor_data.
  Proof.
    split.
    - intro S.
      apply signature_Mor_eq.
      intro X.
      apply LModule_Mor_equiv;[apply homset_property|].
      apply idpath.
    - intros R S T f g.
      apply signature_Mor_eq.
      intro X.
      apply LModule_Mor_equiv;[apply homset_property|].
      apply idpath.
  Defined.

  Definition sigWithStrength_to_sig_functor : functor Sig (signature_category (C := C)) :=
    make_functor _ sigWithStrength_to_sig_is_functor.
End SigWithStrengthToSignatureFunctor.


Require Import QArith_base Qcanon.
Require Import RAux.
Require Import PolSBase.
Require Import PolAuxList.
Require Import PolAux.

Definition Qc2R_can a :=
  if (Pos.eqb (Qden a) 1) then IZR (Qnum a)
  else if (Z.eqb (Qnum a) 1) then Rinv (IZR (Z.pos (Qden a)))
  else (IZR (Qnum a) / IZR (Z.pos (Qden a)))%R.

Definition Rconvert_back (e : PExpr Qc) (l : list R) : R :=
  convert_back Qc R R0 Rplus Rminus Rmult Ropp Qc2R_can l e.

Definition is_Qc1 := Qc_eq_bool 1.
Definition is_Qc0 := Qc_eq_bool 0.
Definition is_Qcpos x := Qle_bool 0 (this x).
Definition is_Qcdiv (x y : Qc) := true.

Definition Rsimpl_minus (e : PExpr Qc) :=
  simpl_minus
    Qc Qcplus Qcmult Qcopp 0 1 is_Qc1 is_Qc0 is_Qcpos is_Qcdiv Qcdiv e.

Definition Rsimpl (e : PExpr Qc) :=
  simpl
    Qc Qcplus Qcmult Qcopp 0 1 is_Qc1 is_Qc0 is_Qcpos is_Qcdiv Qcdiv e.

Ltac rs term1 term2 :=
  let term := constr:(Rminus term1 term2) in
  let rfv := FV RCst Rplus Rmult Rminus Ropp term (@nil R) in
  let fv := Trev rfv in
  let expr1 := mkPolexpr Qc RCst Rplus Rmult Rminus Ropp term1 fv in
  let expr2 := mkPolexpr Qc RCst Rplus Rmult Rminus Ropp term2 fv in
  let re := (eval vm_compute in (Rsimpl_minus (PEsub expr1 expr2))) in
  let expr3 := match re with (PEsub ?X1 _) => X1 end in
  let expr4 := match re with (PEsub _ ?X1) => X1 end in
  let re1 := constr:(PEsub expr1 expr3) in
  let re1' :=
      (eval
         unfold
         Rconvert_back, convert_back, pos_nth, jump,
       hd, tl, Qc2R_can, Qcanon.this, Q2Qc, Qreduction.Qred,
        inject_Z, Z.eqb, Qden, Qnum, Z2R, P2R,
       Pos.eqb, Z.ggcd, Z.abs, snd, Z.to_pos, Z.sgn,
       Pos.ggcd, Pos.size_nat, Nat.add, Pos.ggcdn
 in (Rconvert_back (PEadd re1 expr3) fv))
  in
  let re1'' := (eval lazy beta in re1') in
  let
    re2' :=
    (eval
       unfold
       Rconvert_back, convert_back, pos_nth, jump,
     hd, tl, Qc2R_can, Qcanon.this, Q2Qc, Qreduction.Qred,
     inject_Z, Z.eqb, Qden, Qnum, Z2R, P2R,
     Pos.eqb, Z.ggcd, Z.abs, snd, Z.to_pos, Z.sgn,
     Pos.ggcd, Pos.size_nat, Nat.add, Pos.ggcdn
     in (Rconvert_back (PEadd re1 expr4) fv))
  in
  let re2'' := (eval lazy beta in re2') in
  replace2_tac term1 term2 re1'' re2''; [idtac| try field | try field].

Ltac rpols :=
  match goal with
  | |- (?X1 = ?X2)%R => rs X1 X2; try apply Rplus_eq_compat_l
  | |- (?X1 <> ?X2)%R => rs X1 X2; apply Rplus_neg_compat_l
  | |- Rlt ?X1 ?X2 => rs X1 X2; apply Rplus_lt_compat_l
  | |- Rgt ?X1 ?X2 => rs X1 X2; apply Rplus_gt_compat_l
  | |- Rle ?X1 ?X2 => rs X1 X2; apply Rplus_le_compat_l
  | |- Rge ?X1 ?X2 => rs X1 X2; apply Rplus_ge_compat_l
  | _ => fail
  end.

Ltac hyp_rpols H :=
  generalize H;
  let tmp := fresh "tmp" in
  match (type of H) with
  | (?X1 = ?X2)%R =>
    rs X1 X2; intros tmp; generalize (Rplus_eq_reg_l _ _ _ tmp); clear H tmp; intro H
  | (?X1 <> ?X2)%nat =>
    rs X1 X2; intros tmp; generalize (Rplus_neg_reg_l _ _ _ tmp); clear H tmp; intro H
  | Rlt ?X1 ?X2 =>
    rs X1 X2; intros tmp; generalize (Rplus_lt_reg_r _ _ _ tmp); clear H tmp; intro H
  | Rgt ?X1 ?X2 =>
    rs X1 X2; intros tmp; generalize (Rplus_gt_reg_l _ _ _ tmp); clear H tmp; intro H
  | Rle ?X1 ?X2 =>
    rs X1 X2; intros tmp; generalize (Rplus_le_reg_l _ _ _ tmp); clear H tmp; intro H
  | Rge ?X1 ?X2 =>
    rs X1 X2; intros tmp; generalize (Rplus_ge_reg_l _ _ _ tmp); clear H tmp; intro H
  | _ => fail
  end.


Require Import IOA.
Require Import CounterSpec.
Require Import Automation.
Require Import Simulation.
Require Import Misc.

Require Import List.
Import ListNotations.

Module CounterRegister.

  Import CounterSpec.Api.

  (* counter built on top of register *)

  Inductive Register_API :=
  | Reg_Set (value : nat)
  | Reg_Set_Done
  | Reg_Get_Request
  | Reg_Get_Response (value : nat).

  Inductive Register_pc := Reg_Ready | Reg_Setting | Reg_Getting.

  Definition Register_state : Set := Register_pc * nat.

  Definition Register_transition (st : Register_state) (act : EmptySet + Register_API) (st' : Register_state) : Prop :=
    match act with
    | inr (Reg_Set n) => (fst st = Reg_Ready /\ st' = (Reg_Setting, n)) \/
                         (fst st <> Reg_Ready /\ st' = st)
    | inr Reg_Set_Done => fst st = Reg_Setting /\ st' = (Reg_Ready, snd st)
    | inr Reg_Get_Request => (fst st = Reg_Ready /\ st' = (Reg_Getting, snd st)) \/
                             (fst st <> Reg_Ready /\ st' = st)
    | inr (Reg_Get_Response n) => st = (Reg_Getting, n) /\ st' = (Reg_Ready, n)
    | inl f => match f with end
    end.

  Definition Register_init value := value = (Reg_Ready, 0).

  Definition Register := mkAutomatonDef
                           Register_API
                           Register_state
                           _
                           Register_init
                           Register_transition.

  Example reg_trace1 : list Register_API :=
    [
      Reg_Get_Request;
        Reg_Get_Response 0;
        Reg_Set 3;
        Reg_Set_Done;
        Reg_Get_Request
    ].

  Example reg_trace1_valid : in_traces Register reg_trace1.
  Proof.
    eexists; eexists; split;
      [ cbv; eauto |
        repeat (eapply Step_External; simpl; eauto); econstructor; eauto ].
  Qed.

  Definition Counter_action_type : Set := Counter_API + Register_API.

  (* pc, cache *)

  Inductive DCounter_pc :=
  | DReady
  | DResetting1
  | DResetting2
  | DResetting3
  | DIncrementing1
  | DIncrementing2
  | DIncrementing3
  | DIncrementing4
  | DIncrementing5
  | DReading1
  | DReading2
  | DReading3.

  Definition Counter_state : Set := DCounter_pc * nat.

  Definition Counter_transition (st : Counter_state) (act : EmptySet + Counter_action_type) (st' : Counter_state) : Prop :=
    match act with
    | inr (inl Reset) => (fst st = DReady /\ st' = (DResetting1, snd st)) \/
                         (fst st <> DReady /\ st' = st)
    | inr (inr (Reg_Set n)) => match (fst st) with
                               | DResetting1 => n = 0 /\ st' = (DResetting2, snd st)
                               | DIncrementing3 => n = snd st /\ st' = (DIncrementing4, snd st)
                               | _ => False
                               end
    | inr (inr Reg_Set_Done) => match (fst st) with
                                | DResetting2 => st' = (DResetting3, snd st)
                                | DIncrementing4 => st' = (DIncrementing5, snd st)
                                | _ => st' = st
                                end
    | inr (inl Reset_Done) => fst st = DResetting3 /\ st' = (DReady, snd st)
    | inr (inl Increment) => (fst st = DReady /\ st' = (DIncrementing1, snd st)) \/
                             (fst st <> DReady /\ st' = st)
    | inr (inr Reg_Get_Request) => match (fst st) with
                                   | DIncrementing1 => st' = (DIncrementing2, snd st)
                                   | DReading1 => st' = (DReading2, snd st)
                                   | _ => False
                                   end
    | inr (inr (Reg_Get_Response n)) => match (fst st) with
                                        | DIncrementing2 => st' = (DIncrementing3, S n)
                                        | DReading2 => st' = (DReading3, n)
                                        | _ => st' = st
                                        end
    | inr (inl Increment_Done) => fst st = DIncrementing5 /\ st' = (DReady, snd st)
    | inr (inl Read_Request) => (fst st = DReady /\ st' = (DReading1, snd st)) \/
                                (fst st <> DReady /\ st' = st)
    | inr (inl (Read_Response n)) => st = (DReading3, n) /\ st' = (DReady, n)
    | inl f => match f with end
    end.

  Definition Counter_init st := st = (DReady, 0).

  Definition Counter : AutomatonDef Counter_action_type :=
    mkAutomatonDef
      _
      Counter_state
      _
      Counter_init
      Counter_transition.

  (* composition *)

  Definition Counter_Register_System : AutomatonDef (Counter_API + Register_API) :=
    compose
      Counter
      Register
      (Counter_API + Register_API)
      (fun act => Some act)
      (fun act => match act with
                  | inr reg_act => Some reg_act
                  | _ => None
                  end).
  Example counter_register_trace1 : list (Counter_API + Register_API) :=
    [
      inl Reset;
        inr (Reg_Set 0);
        inr Reg_Set_Done;
        inl Reset_Done
    ].

  Example counter_register_trace1_valid : in_traces Counter_Register_System counter_register_trace1.
  Proof.
    unfold in_traces; do 2 eexists; ebreak_compstate; split; [cbv; eauto |].
    repeat (estep_ext_break; simpl; eauto).
  Qed.

  Definition Counter_Register_System_external : AutomatonDef Counter_API :=
    rename
      Counter_Register_System
      Counter_API
      (fun act_counter => (inl act_counter))
      Register_API
      (fun act_reg => (inr act_reg)).

  Theorem counter_register_system_correct :
    refines
      Counter_Register_System_external
      Blocking.Spec.
  Proof.
    eapply forward_simulation with
    (f := (
           fun
             (st_impl : StateType Counter_Register_System_external)
             (st_spec : StateType Blocking.Spec) =>
             let ctr_pc := fst (fst st_impl) in
             let reg_pc := fst (snd st_impl) in
             let reg_value := snd (snd st_impl) in
             let ctr_cache := snd (fst st_impl) in
             let spec_pc := fst st_spec in
             let spec_value := snd st_spec in
             match ctr_pc with
             | DReady => reg_pc = Reg_Ready /\
                         spec_pc = Blocking.Ready /\
                         spec_value = reg_value
             | DResetting1 => reg_pc = Reg_Ready /\
                              spec_pc = Blocking.Resetting
             | DResetting2 => reg_pc = Reg_Setting /\
                              spec_pc = Blocking.Resetting /\
                              reg_value = 0
             | DResetting3 => reg_pc = Reg_Ready /\
                              spec_pc = Blocking.Resetting /\
                              reg_value = 0
             | DIncrementing1 => reg_pc = Reg_Ready /\
                                 spec_pc = Blocking.Incrementing /\
                                 spec_value = reg_value
             | DIncrementing2 => reg_pc = Reg_Getting /\
                                 spec_pc = Blocking.Incrementing /\
                                 spec_value = reg_value
             | DIncrementing3 => reg_pc = Reg_Ready /\
                                 spec_pc = Blocking.Incrementing /\
                                 spec_value = reg_value /\
                                 ctr_cache = S reg_value
             | DIncrementing4 => reg_pc = Reg_Setting /\
                                 spec_pc = Blocking.Incrementing /\
                                 S spec_value = reg_value
             | DIncrementing5 => reg_pc = Reg_Ready /\
                                 spec_pc = Blocking.Incrementing /\
                                 S spec_value = reg_value
             | DReading1 => reg_pc = Reg_Ready /\
                            spec_pc = Blocking.Reading /\
                            spec_value = reg_value
             | DReading2 => reg_pc = Reg_Getting /\
                            spec_pc = Blocking.Reading /\
                            spec_value = reg_value
             | DReading3 => reg_pc = Reg_Ready /\
                            spec_pc = Blocking.Reading /\
                            spec_value = reg_value /\
                            ctr_cache = reg_value
             end
         )
    ).
    split.
    - intros s1 Hstart.
      destruct s1 as [[ic_pc ic_v] [ir_pc ir_v]].
      inversion Hstart as [Hc Hr].
      inversion Hc; inversion Hr; subst.
      eexists; cbv; eauto.
    - intros s1' s1 act1 s2' Hstep Hrel.
      simpl in Hstep; unfold Rename_transition in Hstep.
      destruct act1 as [[iact | ract] | cact];
        [destruct iact as [icact | iract]; [destruct icact | destruct iract]
        | destruct ract | destruct cact];
        destruct s1' as [[s1'_cpc s1'_cv] [s1'_rpc s1'_rv]];
        destruct s1 as [[s1_cpc s1_cv] [s1_rpc s1_rv]];
        destruct s1_cpc;
        destruct s1'_cpc;
        subst;
        simpl in *;
        try (repeat break_or);
        shallow;
        abstract (
            destruct s2'; eexists; simpl in *; split; [
              explode; subst; intuition |
              econstructor; eauto; econstructor; intuition; explode
            ];
            subst;
            shallow
          ).
  Qed.

End CounterRegister.