(*
  Author(s):
    Dominique Larchey-Wendling (1)
    Andrej Dudenhefner (2)
    Johannes Hostert (2)
  Affiliation(s):
    (1) LORIA -- CNRS
    (2) Saarland University, Saarbrücken, Germany
*)

(** ** H10C_SAT, H10SQC_SAT, and H10UC_SAT are undecidable *)

(*
  Undecidability Result(s):
    Diophantine Constraint Solvability (H10C_SAT)
    Square Diophantine Constraint Solvability (H10SQC_SAT)
    Uniform Diophantine Constraint Solvability (H10UC_SAT)
    Uniform Diophantine Pair Constraint Solvability (H10UPC_SAT)
*)

Require Import Undecidability.Synthetic.Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.
Require Import Undecidability.DiophantineConstraints.H10C.

(* For the reduction chain to complement_HaltL_undec *)
From Undecidability.FRACTRAN  Require Import FRACTRAN Reductions.MM_FRACTRAN.
From Undecidability.MinskyMachines Require Import MM Reductions.BSM_MM.
From Undecidability.StackMachines Require Import BSM Reductions.SBTM_HALT_to_HaltBSM.
Require Import Undecidability.TM.SBTM_undec.

From Undecidability.DiophantineConstraints.Reductions Require
  FRACTRAN_to_H10C_SAT H10C_SAT_to_H10SQC_SAT H10SQC_SAT_to_H10UC_SAT H10UC_SAT_to_H10UPC_SAT.

From Undecidability.FRACTRAN Require Import FRACTRAN FRACTRAN_undec.

(* Undecidability of Diophantine Constraint Solvability *)
Theorem H10C_SAT_undec : undecidable H10C_SAT.
Proof.
  apply (undecidability_from_reducibility FRACTRAN_undec).
  apply (reduces_transitive FRACTRAN_DIO.FRACTRAN_HALTING_DIO_LOGIC_SAT).
  apply (reduces_transitive FRACTRAN_DIO.DIO_LOGIC_ELEM_SAT).
  exact FRACTRAN_to_H10C_SAT.DIO_ELEM_H10C_SAT.
Qed.

(* Undecidability of Square Diophantine Constraint Solvability *)
Theorem H10SQC_SAT_undec : undecidable H10SQC_SAT.
Proof.
  apply (undecidability_from_reducibility H10C_SAT_undec).
  exact H10C_SAT_to_H10SQC_SAT.reduction.
Qed.

(* Undecidability of Uniform Diophantine Constraint Solvability *)
Theorem H10UC_SAT_undec : undecidable H10UC_SAT.
Proof.
  apply (undecidability_from_reducibility H10SQC_SAT_undec).
  exact H10SQC_SAT_to_H10UC_SAT.reduction.
Qed.

Theorem H10UPC_SAT_undec : undecidable H10UPC_SAT.
Proof.
  apply (undecidability_from_reducibility H10UC_SAT_undec).
  exact H10UC_SAT_to_H10UPC_SAT.reduction.
Qed.

Theorem H10UPC_SAT_compl_undec : undecidable (complement H10UPC_SAT).
Proof.
  apply (undecidability_from_reducibility complement_SBTM_HALT_undec).
  apply reduces_complement.
  eapply reduces_transitive; last apply H10UC_SAT_to_H10UPC_SAT.reduction.
  eapply reduces_transitive; last apply H10SQC_SAT_to_H10UC_SAT.reduction.
  eapply reduces_transitive; last apply H10C_SAT_to_H10SQC_SAT.reduction.
  eapply reduces_transitive; last apply FRACTRAN_to_H10C_SAT.DIO_ELEM_H10C_SAT.
  eapply reduces_transitive; last apply FRACTRAN_DIO.DIO_LOGIC_ELEM_SAT.
  eapply reduces_transitive; last apply FRACTRAN_DIO.FRACTRAN_HALTING_DIO_LOGIC_SAT.
  eapply reduces_transitive; last apply FRACTRAN_REG_FRACTRAN_HALTING.
  eapply reduces_transitive; last apply MM_FRACTRAN_REG_HALTING.
  eapply reduces_transitive; last apply BSM_MM_HALTING.
  red. unfold Definitions.reduction. setoid_rewrite BSM_sss.Halt_BSM_iff.
  exact SBTM_HALT_to_HaltBSM.reduction.
Qed.


Goal True /\ True.
split.
- exact I.
- exact I.
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^150 - 3
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 64;
    bitwidth := 64;
    s := 2^150;
    c := [(1, 3)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_other_reduce :
  forall T1 x1 L1 Ts1 T', T1 = (t_rfn_sel x1 L1 Ts1 T') ->
                     forall T2, (T2 <> t_top) ->
                           (forall Ts2, T2 <> (t_rfn_top Ts2)) ->
                           (forall x2 L2 Ts2 T'', T2 <> (t_rfn_sel x2 L2 Ts2 T'')) ->
                           (forall x L T, T2 <> (t_sel_low x L T)) ->
                           (forall x L T, T2 <> (t_sel_equ x L T)) ->
                           (forall L2 T2', T2 <> (t_upp L2 T2')) ->
                           (forall L2 T2', T2 <> (t_equ L2 T2')) ->
                           (forall L2 T2', T2 <> (t_low L2 T2')) ->
                           (forall L2 T2', T2 <> (t_nom L2 T2')) ->
                           (T2 <> t_nil) ->
                           (forall T2' Ts2, T2 <> (t_con T2' Ts2)) ->
                           subtype T1 T2 = subtype T' T2.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

  destruct T2; auto.

  contradiction H0; auto.
  contradiction (H3 v l T2); auto.
  contradiction (H4 v l T2); auto.
  contradiction (H2 v l T2_1 T2_2); auto.
  contradiction (H5 l T2); auto.
  contradiction (H7 l T2); auto.
  contradiction (H6 l T2); auto.
  contradiction (H8 l T2); auto.
  contradiction H9; auto.
  contradiction (H10 T2_1 T2_2); auto.

Qed.


Require Export TcfgqMonotone Precedes TcfgDet.
Require Import Lia.

Definition sub_tag i j := |i| = |j| /\ hd 0 i <= hd 0 j /\ tl i = tl j.

Definition pre_sub_tag i j := exists j', Prefix j' j /\ sub_tag i j'.

Lemma loop_tag_dom_eq `(C : redCFG) (h p : Lab) (i j : Tag) t
      (Hloop : loop_contains h p)
      (Hpath : TPath (root,start_tag) (p,i) t)
      (Htagle : j = take_r (depth h) i)
      (Hdep : |j| = depth h)
  : (h,j) ∈ t.
Proof.
  subst j.
  clear Hdep.
  revert h p i Hloop Hpath.
  induction t;intros.
  + inv Hpath.
  + unfold TPath in Hpath. path_simpl' Hpath. destruct t.
    {
      eapply path_single in Hpath. destruct Hpath.
      inversion H. subst p i. eapply root_no_loop in Hloop. contradiction.
    }
    inv_path Hpath. destruct c as [q j].
    specialize (IHt) with (p:=q) (i:=j).
    eapply tcfg_edge_destruct' in H0.
    destruct H0 as [H0|[H0|[H0|H0]]].
    all: destruct H0 as [Htag Hedge].
    * subst. right.
      eapply IHt. all:cycle 1.
      -- eapply H.
      -- eapply basic_edge_eq_loop in Hedge. rewrite Hedge. assumption.
    * eapply deq_loop_entry_or in Hedge;eauto.
      destruct Hedge.
      -- subst. right.
         rewrite take_r_cons_drop.
         2: {
           eapply loop_contains_deq_loop in H0.
           eapply tag_depth' in H. rewrite H.
           eapply deq_loop_depth;eauto.
         }
         eapply IHt;eauto.
      -- subst p. left. rewrite take_r_geq;eauto.
         eapply tag_depth' in Hpath. lia.
    * destruct j.
      {
        eapply tag_depth' in H. cbn in H. eapply loop_contains_depth_lt in Hloop.
        eapply back_edge_eq_loop in Hedge. rewrite Hedge in H. lia.
      }
      cbn in Htag. subst i.
      decide (h = p).
      -- subst p. left. rewrite take_r_geq;eauto.
         eapply tag_depth' in Hpath. lia.
      -- right. rewrite take_r_cons_replace with (b:=n).
         2: {
           copy Hedge Hedge'.
           eapply back_edge_eq_loop in Hedge.
           copy Hloop Hloop'.
           eapply loop_contains_deq_loop in Hloop.
           eapply eq_loop1 in Hloop;eauto. 2: symmetry;eauto.
           eapply tag_depth' in H.
           enough (depth h < S (| j |)).
           { cbn in H. rewrite H in H0. lia. }
           eapply deq_loop_depth in Hloop.
           eapply le_lt_or_eq in Hloop.
           destruct Hloop.
           ++ cbn in H. lia.
           ++ exfalso. rewrite Hedge in H0.
              eapply loop_contains_deq_loop in Hloop' as Hdeq.
              eapply deq_loop_depth_eq in H0;eauto.
              eapply n0. eapply head_unique;eauto.
              ** eapply loop_contains_ledge;eauto.
              ** split;eauto.
         }
         eapply IHt;eauto.
         eapply back_edge_eq_loop in Hedge. rewrite Hedge. eauto.
    * subst.
      destruct j.
      {
        eapply tag_depth' in H. cbn in H. eapply loop_contains_depth_lt in Hloop.
        destruct Hedge. eapply deq_loop_exited in H0. eapply deq_loop_depth in H0. lia.
      }
      right. rewrite <-take_r_cons_drop with (a:=n).
      all: cbn.
      2: {
        eapply tag_depth' in H. cbn in H.
        enough (depth h < S (|j|)) by lia.
        rewrite H.
        eapply depth_exit in Hedge.
        eapply loop_contains_deq_loop in Hloop. eapply deq_loop_depth in Hloop.
        lia.
      }
      eapply IHt;eauto.
      destruct Hedge. eapply deq_loop_exited in H0. eapply H0. eauto.
Qed.

Lemma loop_tag_dom_same `(C : redCFG) (h : Lab) (i j : Tag) t
      (Hloop : loop_head h)
      (Hpath : TPath (root,start_tag) (h,i) t)
      (Htagle : sub_tag j i)
  : (h,j) ∈ t.
Proof.
  destruct Htagle as [Hlen [Hhd Htl]].
  destruct i,j;cbn in *;[|congruence|congruence|].
  { eapply tag_depth' in Hpath. cbn in Hpath. eapply depth_loop_head in Hloop. lia. }
  subst j. clear Hlen.
  revert t Hpath.
  induction Hhd;intros.
  - eapply path_contains_front;eauto.
  - destruct t;[inv Hpath|].
    unfold TPath in Hpath. path_simpl' Hpath.
    inversion Hpath. subst.
    destruct b as [q j].
    eapply tcfg_edge_destruct' in H3.
    destruct H3 as [H3|[H3|[H3|H3]]].
    all: destruct H3 as [Htag Hedge].
    * eapply basic_edge_no_loop2 in Hedge. contradiction.
    * inv Htag.
    * destruct j;cbn in Htag;[congruence|].
      inv Htag.
      right.
      eapply loop_tag_dom_eq in H0 as Hel2;cycle 1.
      -- eapply loop_contains_ledge;eassumption.
      -- rewrite take_r_geq;eauto. eapply tag_depth' in H0. rewrite H0.
         eapply back_edge_eq_loop in Hedge. rewrite Hedge. eauto.
      -- eapply back_edge_eq_loop in Hedge. rewrite <-Hedge. eapply tag_depth' in H0. eauto.
      -- eapply path_to_elem in Hel2;eauto. destructH.
         eapply prefix_incl;[eauto|].
         eapply IHHhd;eassumption.
    * destruct j;cbn in Htag;[congruence|]. subst j. destruct Hedge.
      eapply no_exit_head in H. contradiction.
Qed.

(* could be generalized with sub_tag _ _  -> sub_tag _ _ \/ Prefix _ _ *)
Lemma loop_tag_dom `(C : redCFG) (h p : Lab) (i j : Tag) t
      (Hloop : loop_contains h p)
      (Hpath : TPath (root,start_tag) (p,i) t)
      (Hstag : sub_tag j (take_r (depth h) i))
      (Hdep : |j| = depth h)
  : (h,j) ∈ t.
Proof.
  assert (depth h <= | i |) as Hdepi.
  {
    eapply tag_depth' in Hpath. rewrite Hpath.
    eapply deq_loop_depth.
    eapply loop_contains_deq_loop;eauto.
  }
  eapply loop_tag_dom_eq in Hpath as Hel2.
  3: reflexivity.
  2: eauto.
  2: rewrite take_r_length_le;eauto.
  eapply path_to_elem in Hel2;eauto.
  destructH.
  eapply prefix_incl;eauto.
  eapply loop_tag_dom_same;eauto.
  eapply loop_contains_loop_head;eauto.
Qed.

Global Instance sub_tag_refl : Reflexive sub_tag.
Proof.
  unfold Reflexive. intros.
  unfold sub_tag. split_conj;eauto.
Qed.

Lemma tcfg_prefix_no_back `(C : redCFG) (h p q : Lab) (i j k : Tag) t
      (Hdeq : deq_loop p q)
      (Hpath : TPath (q,j) (p,i) t)
      (Hstag : Prefix j i)
      (Hdep : |j| = depth q)
      (Hin : (h,k) ∈ (r_tl t))
  : ~ loop_contains h q.
Proof.
  specialize (tcfg_reachability Hdep) as Hreach.
  destructH. intro Hloop.
  eapply loop_contains_deq_loop in Hloop as Hdeqqh.
  assert (| take_r (depth h) j | = depth h) as Hheq.
  { rewrite take_r_length_le;auto. rewrite Hdep. eapply deq_loop_depth. eauto. }
  eapply loop_tag_dom in Hreach as Hdom;eauto. 2:reflexivity.
  destr_r' t;subst. 1: cbn in Hin;contradiction.
  unfold TPath in Hpath. path_simpl' Hpath. rewrite r_tl_rcons in Hin.
  eapply path_from_elem in Hpath as Hϕ. 2: eauto.
  2: eapply In_rcons;right;eauto. destructH.
  eapply tag_depth_unroot in Hdep as Hdepp;eauto.
  eapply tag_depth_unroot2 in Hϕ0 as Hdeph;eauto.
  eapply tagle_monotone in Hϕ0 as Hmon0. 3,5:reflexivity. all:eauto. 2: transitivity q;eauto.
  eapply path_to_elem in Hpath as Hπ. 2: eapply In_rcons;right;eauto. destructH.
  eapply tagle_monotone in Hπ0 as Hmon1;eauto. 2: reflexivity.
  rewrite take_r_geq in Hmon0. 2:lia.
  setoid_rewrite take_r_geq in Hmon1 at 2. 2:lia.
  destruct Hmon1.
  - eapply taglt_tagle_trans in H;eauto.
    clear - H Hstag Hdeph Hdep Hdeqqh.
    eapply taglt_leq with (n:=|j|) in H.
    + eapply prefix_take_r in Hstag. rewrite Hstag in H. rewrite take_r_self in H.
      eapply Taglt_irrefl;eauto.
    + rewrite Hdep. eapply deq_loop_depth;eauto.
    + eapply prefix_len_leq;eauto.
    + reflexivity.
  - subst k. eapply path_from_elem in Hdom;eauto. destructH.
    destruct l;[contradiction|]. cbn in Hpath. path_simpl' Hpath. eapply path_rcons_inv' in Hpath.
    destructH. destruct p0.
    eapply path_to_elem in Hin;eauto. destructH.
    eapply Taglt_irrefl. eapply tcfg_fresh.
    + eapply path_app in Hpath1;eauto.
    + eauto.
    + destruct ϕ1;[inv Hdom0|];destruct ϕ2;[inv Hin0|]. cbn. rewrite app_length. cbn. lia.
Qed.

Lemma tcfg_subtag_deq `(C : redCFG) (x p q : Lab) (i j : Tag) t
      (Hdeq : deq_loop p q)
      (Hpath : TPath (q,j) (p,i) t)
      (Hstag : sub_tag j (take_r (depth q) i))
      (Hdep : |j| = depth q)
      (Hin : x ∈ map fst t)
  : deq_loop x q.
Proof.
  decide (deq_loop x q);[eauto|exfalso].
  do 2 simpl_dec' n. destructH.
  eapply in_fst in Hin. destructH.
  eapply path_from_elem in Hin as Hϕ;eauto. destructH.
  eapply tag_depth_unroot in Hpath as Hdepp;eauto.
  eapply tag_depth_unroot2 in Hϕ0 as Hdepx;eauto.
  assert (depth x0 <= depth p) as Hdep_leq.
  { eapply loop_contains_deq_loop in n0. rewrite n0 in Hdeq. eapply deq_loop_depth in Hdeq;eauto. }
  specialize (@take_take_r _ i (|i| - (depth x0 - 1)) (depth x0 - 1)) as Hi. exploit Hi. 1: lia.
  copy n1 n1'.
  eapply ex_entry in n1. 3:rewrite Hi in Hϕ0;eauto. all:eauto.
  2: { rewrite take_r_length_le;eauto. lia. }
  destr_r' t;subst. 1:contradiction. eapply In_rcons in Hin. destruct Hin.
  - subst x1. unfold TPath in Hpath. eapply path_back in Hpath. inversion Hpath. subst x.
    contradiction.
  - destr_r' ϕ;subst. 1:contradiction. path_simpl' Hϕ0.
    eapply In_rcons in n1. destruct n1.
    + inv H0. eapply n1'. eauto using loop_contains_self, loop_contains_loop_head.
    + specialize (tcfg_reachability Hdep) as Hreach.
      destructH.
      eapply loop_tag_dom with (j0:=0 :: take_r (depth x0 - 1) i) in Hreach as Hdom. 2: eapply n0.
      * unfold TPath in Hpath. path_simpl' Hpath.
        eapply path_app' in Hpath. 2: eapply Hreach. eapply tpath_NoDup in Hpath.
        rewrite <-app_assoc in Hpath.
        eapply NoDup_app in Hpath.
        -- eapply Hpath. destruct t;[contradiction|]. unfold TPath in Hreach. path_simpl' Hreach.
           cbn. eauto.
        -- eapply postfix_incl;eauto using postfix_rcons_rcons.
      * unfold sub_tag. split_conj.
        -- cbn. rewrite take_r_length_le. 2: rewrite Hdepp;lia.
           rewrite take_r_length_le. 2:rewrite Hdep;eauto using deq_loop_depth, loop_contains_deq_loop.
           eapply loop_contains_loop_head in n0. eapply depth_loop_head in n0. lia.
        -- cbn. lia.
        -- cbn. rewrite take_r_tl_eq.
           rewrite take_r_length_le. 2: rewrite Hdep;eauto using deq_loop_depth,loop_contains_deq_loop.
           rewrite take_r_take_r_leq. 2:lia.
           destruct j. 1: { cbn in Hdep. eapply loop_contains_depth_lt in n0. lia. }
           assert (depth x0 > 0 ) as Hx0.
           { cbn in Hdepp. eapply loop_contains_loop_head in n0. eapply depth_loop_head in n0. auto. }
           destruct i. 1:{ cbn in Hdepp. lia. }
           cbn in Hdep, Hdepp.
           assert (depth x0 - 1 <= | j |) as Hx0j.
           { eapply loop_contains_deq_loop in n0. eapply deq_loop_depth in n0. lia. }
           rewrite take_r_cons_drop. 2:lia. rewrite take_r_cons_drop. 2:auto.
           destruct Hstag as [_ [_ Hstag]]. cbn in Hstag.
           rewrite take_r_tl_eq in Hstag.
           eapply deq_loop_depth in Hdeq as Hdepleq.
           rewrite take_r_length_le in Hstag. 2:cbn;lia.
           rewrite take_r_take_r_leq in Hstag. 2:lia.
           rewrite take_r_cons_drop in Hstag. 2:lia. rewrite Hstag.
           rewrite take_r_take_r_leq. 2:lia. reflexivity.
      * cbn. rewrite take_r_length_le. 2:lia. eapply loop_contains_loop_head in n0.
        eapply depth_loop_head in n0. lia.
Qed.

Lemma tcfg_no_back_deq `(C : redCFG) (x p q : Lab) (i j : Tag) t
      (Hdeq : deq_loop p q)
      (Hpath : TPath (q,j) (p,i) t)
      (Hdep : |j| = depth q)
      (Hin : x ∈ map fst t)
      (Hnback : forall x : Lab, x ∈ (map fst (r_tl t)) -> ~ loop_contains x q)
  : deq_loop x q.
Proof.
  decide (deq_loop x q);[eauto|exfalso].
  do 2 simpl_dec' n. destructH.
  eapply in_fst in Hin. destructH.
  eapply path_from_elem in Hin as Hϕ;eauto. destructH.
  eapply tag_depth_unroot in Hpath as Hdepp;eauto.
  eapply tag_depth_unroot2 in Hϕ0 as Hdepx;eauto.
  assert (depth x0 <= depth p) as Hdep_leq.
  { eapply loop_contains_deq_loop in n0. rewrite n0 in Hdeq. eapply deq_loop_depth in Hdeq;eauto. }
  specialize (@take_take_r _ i (|i| - (depth x0 - 1)) (depth x0 - 1)) as Hi. exploit Hi. 1: lia.
  copy n1 n1'.
  eapply ex_entry in n1. 3:rewrite Hi in Hϕ0;eauto. all:eauto.
  2: { rewrite take_r_length_le;eauto. lia. }
  destr_r' t;subst. 1:contradiction. eapply In_rcons in Hin. destruct Hin.
  - subst x1. unfold TPath in Hpath. eapply path_back in Hpath. inversion Hpath. subst x.
    contradiction.
  - destr_r' ϕ;subst. 1:contradiction. path_simpl' Hϕ0.
    eapply In_rcons in n1. destruct n1.
    + inv H0. eapply n1'. eauto using loop_contains_self, loop_contains_loop_head.
    + eapply Hnback;eauto.
      eapply postfix_rcons_rcons in Hϕ1. eapply postfix_incl in H0;eauto.
      rewrite r_tl_rcons. eapply in_map with (f:=fst) in H0. cbn in H0. eauto.
Qed.

Lemma tcfg_prefix_deq `(C : redCFG) (x p q : Lab) (i j : Tag) t
      (Hdeq : deq_loop p q)
      (Hpath : TPath (q,j) (p,i) t)
      (Hstag : Prefix j i)
      (Hdep : |j| = depth q)
      (Hin : x ∈ map fst t)
  : deq_loop x q.
Proof.
  eapply tcfg_no_back_deq;eauto. intros.
  eapply in_fst in H. destructH.
  eapply tcfg_prefix_no_back. 2: eapply Hpath. all:eauto.
Qed.

Lemma loop_tag_dom_prec `(C : redCFG) (h p : Lab) (i j : Tag) t
      (Hloop : loop_contains h p)
      (Hpath : TPath (root,start_tag) (p,i) t)
      (Hstag : Prefix j i)
      (Hdep : |j| = depth h)
  : Precedes fst t (h,j).
Proof.
  eapply loop_tag_dom in Hpath as Hdom;eauto.
  - eapply path_from_elem in Hdom as Hϕ;eauto. destructH.
    destr_r' ϕ;subst. 1: inv Hϕ0.
    path_simpl' Hϕ0.
    eapply postfix_eq in Hϕ1. destructH. subst t.
    eapply loop_contains_deq_loop in Hloop as Hdeq.
    assert (forall k, (h,k) ∉ l).
    { intros. intro N.
      eapply tcfg_prefix_no_back;eauto.
      - rewrite r_tl_rcons. eauto.
      - eauto using loop_contains_self,loop_contains_loop_head.
    }
    clear - H.
    induction l;cbn.
    + econstructor.
    + destruct a.
      econstructor.
      * cbn. intro N. subst. eapply H. left;eauto.
      * eapply IHl;eauto. intros k Hk. eapply H;eauto.
  - eapply prefix_eq in Hstag. destructH. subst i.
    rewrite take_r_app_eq;eauto.
    unfold sub_tag. split_conj;eauto.
Qed.

Lemma tpath_deq_no_haed_tag_eq' `(C : redCFG) p q q0 i j t
      (Hlen : | j | = depth q)
      (Hpath : TPath (q,j) (p,i) t)
      (Hincl : forall x, x ∈ map fst t -> deq_loop x q0)
      (Hnback : forall x : Lab, x ∈ (map fst (r_tl t)) -> ~ loop_contains x q0)
  : take_r (depth q0) i = take_r (depth q0) j.
Proof.
  revert q p i j Hpath Hlen.
  induction t;intros;inv_path Hpath.
  - reflexivity.
  - exploit' IHt.
    { intros. eapply Hincl. cbn. right;eauto. }
    exploit' IHt.
    { intros. eapply Hnback.
      eapply incl_map. 2: eapply H1.
      destr_r' t;subst;cbn;eauto. rewrite app_comm_cons. do 2 rewrite r_tl_rcons. eauto.
    }
    destruct x as [e l].
    eapply tcfg_edge_destruct' in H0.
    destruct H0 as [H0|[H0|[H0|H0]]].
    all: destruct H0 as [Htag Hedge];subst.
    + eapply IHt;eauto.
    + rewrite take_r_cons_drop.
      * eapply IHt;eauto.
      * eapply tag_depth_unroot in H as Hdep;eauto. rewrite Hdep.
        eapply deq_loop_depth. eapply Hincl. cbn. right.
        eapply path_contains_front in H. eapply in_map with (f:=fst) in H. eauto.
    + destruct l;[exfalso|].
      * eapply loop_contains_ledge in Hedge. eapply loop_contains_depth_lt in Hedge.
        eapply tag_depth_unroot in H;eauto. cbn in H. lia.
      * cbn in Hpath. cbn.
        erewrite take_r_cons_replace.
        -- eapply IHt;eauto.
        -- specialize (Hnback p). exploit Hnback.
           {
             destr_r' t;subst. 1: inv H. rewrite app_comm_cons. rewrite r_tl_rcons.
             cbn. left;eauto.
           }
           decide (S (|l|) <= depth q0);[exfalso|lia].
           eapply tag_depth_unroot in H as Hdep;eauto. cbn in Hdep. rewrite Hdep in l0.
           assert (deq_loop e q0) as Hdeq.
           {
             eapply Hincl. cbn. right. eapply path_contains_front in H.
             eapply in_map with (f:=fst) in H. cbn in H. assumption.
           }
           eapply deq_loop_depth_leq in l0;eauto.
           eapply Hnback. eapply deq_loop_head_loop_contains;eauto.
           ++ eapply back_edge_eq_loop in Hedge. rewrite <-Hedge. eauto.
           ++ eexists;eauto.
    + destruct l;[exfalso|].
      * eapply tag_depth_unroot in H;eauto. cbn in H. eapply depth_exit in Hedge. lia.
      * cbn. cbn in Hpath.
        erewrite <-take_r_cons_drop.
        -- eapply IHt;eauto.
        -- eapply tag_depth_unroot in Hpath;eauto. rewrite Hpath.
           eapply deq_loop_depth. eapply Hincl;cbn. eauto.
Qed.

Lemma tpath_deq_no_haed_tag_eq `(C : redCFG) p q q0 i j t
      (Hlen : | j | = depth q)
      (Hpath : TPath (q,j) (p,i) t)
      (Hincl : forall x, x ∈ map fst t -> deq_loop x q0)
      (Hnback : forall x : Lab, x ∈ (map fst t) -> ~ loop_contains x q0)
  : take_r (depth q0) i = take_r (depth q0) j.
Proof.
  eapply tpath_deq_no_haed_tag_eq';eauto.
  intros;eapply Hnback.
  eapply incl_map. 2:eauto.
  destr_r' t;subst;cbn;eauto. rewrite r_tl_rcons. eauto.
Qed.

Lemma tpath_prec_loop_eq `(C : redCFG) h p i j t
      (Hpath : TPath (h,i) (p,j) t)
      (Hprec : Precedes fst t (h,i))
      (Hloop : loop_contains h p)
      (Hdep : |i| = depth h)
  : i = take_r (depth h) j.
Proof.
  assert (forall x : Lab, x ∈ (map fst (r_tl t)) -> ~ loop_contains x h) as Hnback.
  {
    intros. intro N.
    destr_r' t;subst. 1:inv Hpath. unfold TPath in Hpath. path_simpl' Hpath.
    eapply tag_depth_unroot in Hpath as Hdepp;eauto.
    eapply tpath_NoDup_unroot in Hpath as Hnd;eauto.
    rewrite r_tl_rcons in H.
    eapply in_fst in H. destructH. (*
      eapply NoDup_nin_rcons in Hnd. *)
    destruct l. 1:contradiction. cbn in Hpath. path_simpl' Hpath.
    eapply path_rcons_inv in Hpath. destructH.
    eapply path_from_elem in H as Hϕ;eauto. destructH.
    decide (x = h).
    - subst x.
      eapply precedes_rcons in Hprec as Hfneq. 2:eauto. 2:eassumption. cbn in Hfneq. contradiction.
    - assert (~ loop_contains h x).
      { contradict n. eapply eq_loop_same. 2,3: eauto using loop_contains_loop_head.
        split;eauto using loop_contains_deq_loop. }
      eapply loop_contains_deq_loop in Hloop as Hdeq. eapply Hdeq in N.
      eapply deq_loop_depth in Hdeq.
      eapply ex_entry with (k:=take_r (depth h - 1) j) in H0;eauto.
      + eapply precedes_rcons in Hprec as Hfneq. 2:eauto. 2:eapply postfix_incl;eauto.
        cbn in Hfneq. contradiction.
      + eapply tag_depth_unroot2;eauto.
      + eapply take_take_r with (n:=|j| - (depth h - 1)). lia.
      + rewrite take_r_length_le. lia. lia.
  }
  erewrite tpath_deq_no_haed_tag_eq'. 2,3,5:eauto.
  - rewrite take_r_geq;eauto. lia.
  - intros. eapply tcfg_no_back_deq;eauto. eapply loop_contains_deq_loop;eauto.
Qed.

Lemma tpath_prec_innermost_eq `(C : redCFG) h p i j t
      (Hpath : TPath (h,i) (p,j) t)
      (Hprec : Precedes fst t (h,i))
      (Hloop : innermost_loop h p)
      (Hdep : |i| = depth h)
  : i = j.
Proof.
  eapply tag_depth_unroot in Hpath as Hdepp;eauto.
  eapply tpath_prec_loop_eq in Hpath;eauto.
  - eapply innermost_eq_loop in Hloop.
    rewrite take_r_geq in Hpath;eauto. rewrite Hloop. lia.
  - destruct Hloop. eauto.
Qed.


(** * IndistRelations.v: indistinguishability relation for annotated programs *)
(*Require FFun.*)
Require Export DEX_BigStepAnnot.
Require Export Annotated.

Open Scope type_scope.

Import DEX_BigStepAnnot.DEX_BigStepAnnot DEX_BigStep.DEX_BigStep DEX_Dom DEX_Prog.

Inductive Value_in : DEX_value -> DEX_value -> Prop :=
| Value_in_num: forall n,
  Value_in (Num n) (Num n).

Inductive Value_in_opt :
  option DEX_value -> option DEX_value -> Prop :=
| Value_in_opt_some:
  forall v v',
    Value_in v v' ->
    Value_in_opt (Some v) (Some v')
| Value_in_opt_none: Value_in_opt None None.

Inductive Reg_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) (rn:DEX_Reg) : Prop :=
| Reg_high_in : forall k k', MapList.get rt rn = Some k -> MapList.get rt' rn = Some k' ->
    ~(L.leql k observable) -> ~(L.leql k' observable) -> Reg_in observable r r' rt rt' rn
| Reg_nhigh_in : Value_in_opt (DEX_Registers.get r rn) (DEX_Registers.get r' rn) -> Reg_in observable r r' rt rt' rn.

Inductive Regs_in (observable:L.t) (r r': DEX_Registers.t) (rt rt': TypeRegisters) : Prop :=
| Build_Regs_in : eq_set (MapList.dom rt) (MapList.dom rt') ->
  (forall (rn:DEX_Reg), Reg_in observable r r' rt rt' rn) -> Regs_in observable r r' rt rt'.

Inductive st_in (observable:L.t) (rt rt':TypeRegisters) :
  DEX_PC * DEX_Registers.t ->
  DEX_PC * DEX_Registers.t -> Prop :=
| Build_st_in: forall pc pc' r r',
    Regs_in observable r r' rt rt' ->
    st_in observable rt rt' (pc,r) (pc',r').

Inductive indist_return_value (observable:L.t) (s:DEX_sign) :
    DEX_ReturnVal -> DEX_ReturnVal -> Prop :=
| indist_return_val : forall v1 v2 k,
  s.(DEX_resType) = Some k ->
  (L.leql k observable -> Value_in v1 v2) ->
  indist_return_value observable s (Normal (Some v1)) (Normal (Some v2))
| indist_return_void :
  s.(DEX_resType) = None ->
  indist_return_value observable s (Normal None) (Normal None).

Inductive high_result (observable:L.t) (s:DEX_sign) : DEX_ReturnVal -> Prop :=
| high_result_void :
  s.(DEX_resType) = None ->
  high_result observable s (Normal None)
| high_result_value : forall v k,
  s.(DEX_resType) = Some k ->
  ~ L.leql k observable ->
  high_result observable s (Normal (Some v)).

Inductive state : Type :=
  intra : DEX_IntraNormalState -> TypeRegisters -> state
| ret : DEX_ReturnVal -> state.

Inductive indist (observable:L.t) (p:DEX_ExtendedProgram) (m:DEX_Method) (sgn:DEX_sign) : state -> state -> Prop :=
| indist_intra : forall pc pc' r r' rt rt',
  st_in observable rt rt' (pc,r) (pc',r') ->
  indist observable p m sgn (intra (pc,r) rt) (intra (pc',r') rt')
| indist_return : forall v v',
  indist_return_value observable sgn v v'->
  indist observable p m sgn (ret v) (ret v').

 (** Indistinguishability relations *)

Section p.
  Variable kobs : L.t.
  Variable p : DEX_ExtendedProgram.

 (** Basic results on indistinguishability relations *)

  Lemma Value_in_sym : forall v1 v2,
    Value_in v1 v2 ->
    Value_in v2 v1.
  Proof.
    intros.
    inversion_clear H; try constructor.
  Qed.

  Lemma Value_in_opt_sym : forall v1 v2,
    Value_in_opt v1 v2 ->
    Value_in_opt v2 v1.
  Proof.
    intros.
    inversion_clear H; try constructor.
    apply Value_in_sym; auto.
  Qed.

  Lemma Value_in_trans : forall v1 v2 v3,
    Value_in v1 v2 ->
    Value_in v2 v3 ->
    Value_in v1 v3.
  Proof.
    intros.
    inversion H0; inversion H; subst; rewrite H4; constructor.
  Qed.

  Lemma Value_in_opt_trans : forall v1 v2 v3,
    Value_in_opt v1 v2->
    Value_in_opt v2 v3 ->
    Value_in_opt v1 v3.
  Proof.
    intros.
    inversion_clear H in H0; inversion_clear H0; try constructor.
    eapply Value_in_trans; eauto.
  Qed.

  Lemma leql_join1 : forall k1 k2 k3,
    L.leql k2 k3 ->
    L.leql k2 (L.join k1 k3).
  Proof.
    intros.
    apply L.leql_trans with (1:=H).
    apply L.join_right.
  Qed.

  Lemma leql_join2 : forall k1 k2 k3,
    L.leql k2 k1 ->
    L.leql k2 (L.join k1 k3).
  Proof.
    intros.
    apply L.leql_trans with (1:=H).
    apply L.join_left.
  Qed.

  Lemma not_leql_trans : forall k1 k2 k3,
    ~ L.leql k1 k3 ->
    L.leql k1 k2 ->
    ~ L.leql k2 k3.
  Proof.
    red; intros.
    elim H.
    apply L.leql_trans with (1:=H0); auto.
  Qed.

  Lemma not_leql_join1 : forall k1 k2 k3,
    ~ L.leql k1 k3 ->
    ~ L.leql (L.join k1 k2) k3.
  Proof.
    intros; apply not_leql_trans with k1; auto.
    apply L.join_left.
  Qed.

  Lemma not_leql_join2 : forall k1 k2 k3,
    ~ L.leql k2 k3 ->
    ~ L.leql (L.join k1 k2) k3.
  Proof.
    intros; apply not_leql_trans with k2; auto.
    apply L.join_right.
  Qed.

  Lemma leql_join_each: forall k k1 k2, L.leql (L.join k k1) k2 -> L.leql k k2 /\ L.leql k1 k2.
  Proof. intros.
    split. apply L.leql_trans with (l2:=L.join k k1); auto. apply L.join_left.
    apply L.leql_trans with (l2:=L.join k k1); auto. apply L.join_right.
  Qed.

  Lemma Reg_in_sym : forall obs r r' rt rt' rn,
    Reg_in obs r r' rt rt' rn ->
    Reg_in obs r' r rt' rt rn.
  Proof.
    intros.
    inversion H.
      constructor 1 with (k:=k') (k':=k); auto.
      constructor 2; auto.
      apply Value_in_opt_sym; auto.
  Qed.

 Lemma Regs_in_sym : forall r1 r2 rt1 rt2,
    Regs_in kobs r1 r2 rt1 rt2 ->
    Regs_in kobs r2 r1 rt2 rt1.
  Proof.
    induction 1.
    constructor. apply eq_set_sym; auto.
    intros.
    apply Reg_in_sym; auto.
  Qed.

  Lemma st_in_sym : forall rt rt' r r',
    st_in kobs rt rt' r r' ->
    st_in kobs rt' rt r' r.
  Proof.
    intros.
    inversion_clear H; constructor.
    apply Regs_in_sym; auto.
  Qed.
  Implicit Arguments st_in_sym.

  Lemma Value_in_opt_some_aux: forall ov ov' v v',
    Value_in v v' ->
    ov=(Some v)  ->
    ov'= (Some v') ->
    Value_in_opt ov ov'.
  Proof.
    intros;  subst; constructor; auto.
  Qed.

  Lemma ex_comp_Z : forall x y z:Z,
    (x <= y < z \/ ~ x <= y < z)%Z.
  Proof.
    intros.
    destruct (Z_le_dec x y).
    destruct (Z_lt_dec y z); intuition.
    intuition.
  Qed.

  Lemma nth_error_none_length : forall (A:Set) (l:list A) i,
    nth_error l i = None -> (length l <= i)%nat.
  Proof.
    induction l; destruct i; simpl; intros; try omega.
    discriminate.
    generalize (IHl _ H); omega.
  Qed.

  Lemma nth_error_some_length : forall (A:Set) (l:list A) i a,
    nth_error l i = Some a -> (length l > i)%nat.
  Proof.
    induction l; destruct i; simpl; intros; try discriminate; try omega.
    generalize (IHl _ _ H); omega.
  Qed.
End p.

  Hint Resolve
    not_leql_join1 not_leql_join2 not_leql_trans
    L.join_left L.join_right
    L.leql_trans : lattice.


(**********************************************************************************
 * MetricRec.v                                                                    *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(* Categories enriched over bounded complete ultrametric spaces and solving domain
   equations therein
*)

Require Export Categories MetricCore NSetoid.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** printing T0 %\ensuremath{T_0}% *)
(** printing T1 %\ensuremath{T_1}% *)
(** printing T2 %\ensuremath{T_2}% *)
(** printing T3 %\ensuremath{T_3}% *)
(** printing T4 %\ensuremath{T_4}% *)
(** printing T5 %\ensuremath{T_5}% *)
(** printing T6 %\ensuremath{T_6}% *)

Open Scope C_scope.

(*=BaseCat *)
Module BaseCat.

Record mixin_of (C:catType) := Mixin
 { terminal :> CatTerminal.mixin_of C;
   metric : forall (X Y : C),
      Metric.mixin_of (Setoid.Pack (Setoid.class (C X Y)) (C X Y));
   cmetric : forall (X Y : C),
      CMetric.mixin_of (Metric.Pack (Metric.Class (metric X Y)) (C X Y)) ;
   comp: forall (X Y Z : C), (CMetric.Pack (CMetric.Class (cmetric Y Z)) (C Y Z)) *
          (CMetric.Pack (CMetric.Class (cmetric X Y)) (C X Y)) =->
          (CMetric.Pack (CMetric.Class (cmetric X Z)) (C X Z));
   comp_comp : forall X Y Z m m', (comp X Y Z (m,m'):C _ _) =-= m << m' }.
(*=End *)

Section ClassDef.
Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base : Category.class_of M;
          ext: mixin_of (Category.Pack base T) }.
Local Coercion base : class_of >-> Category.class_of.
Local Coercion ext : class_of >-> mixin_of.

Definition base2 (T:Type) (M:T -> T -> setoidType) (c:class_of M) := CatTerminal.Class c.
Local Coercion base2 : class_of >-> CatTerminal.class_of.

Structure cat : Type := Pack {object : Type; morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.
Local Coercion object : cat >-> Sortclass.
Local Coercion morph : cat >-> Funclass.
Definition class cT := let: Pack _ _ c _ := cT return class_of (@morph cT) in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.

Definition terminalCat (cT:cat) : terminalCat := CatTerminal.Pack (class cT) cT.
Definition catType (cT:cat) : catType := Category.Pack (class cT) cT.
Definition metricType (cT:cat) (X Y:cT) : metricType := Metric.Pack (Metric.Class (metric (class cT) X Y)) (cT X Y).
Definition cmetricType (cT:cat) (X Y:cT) : cmetricType := CMetric.Pack (CMetric.Class (cmetric (class cT) X Y)) (cT X Y).
End ClassDef.
Module Import Exports.
Coercion terminalCat : cat >-> CatTerminal.cat.
Coercion base : class_of >-> Category.class_of.
Coercion ext : class_of >-> mixin_of.
Coercion object : cat >-> Sortclass.
Coercion morph : cat >-> Funclass.
Canonical Structure terminalCat.
Canonical Structure catType.
Canonical Structure metricType.
Canonical Structure cmetricType.

Notation cmetricMorph := cmetricType.
Notation cmetricECat := cat.
Notation CmetricECatMixin := Mixin.
Notation CmetricECatType := pack.
End Exports.
End BaseCat.
Export BaseCat.Exports.

Definition ccomp (cT:cmetricECat) (X Y Z : cT) : cmetricMorph Y Z * cmetricMorph X Y =-> cmetricMorph X Z :=
   BaseCat.comp (BaseCat.class cT) X Y Z.

Lemma ccomp_eq (cT:cmetricECat) (X Y Z : cT) (f : cT Y Z) (f' : cT X Y) : ccomp X Y Z (f,f') =-= f << f'.
apply (@BaseCat.comp_comp cT (BaseCat.class cT) X Y Z f f').
Qed.

Section Msolution.
Variable M:cmetricECat.

Open Scope C_scope.
Open Scope S_scope.

(*=BiFunctor *)
Record BiFunctor : Type := mk_functor
{ ob : M -> M -> M ;
  morph : forall (T0 T1 T2 T3 : M),
             (cmetricMorph T1 T0) * (cmetricMorph T2 T3) =->
             (cmetricMorph (ob T0 T2) (ob T1 T3)) ;
  morph_comp: forall T0 T1 T2 T3 T4 T5
             (f:cmetricMorph T4 T1) (g:cmetricMorph T3 T5)
             (h:cmetricMorph T1 T0) (k:cmetricMorph T2 T3),
                (morph T1 T4 T3 T5 (f,g)) <<  morph T0 T1 T2 T3 (h, k)
                 =-= morph _ _ _ _ (h << f, g << k) ;
  morph_id : forall T0 T1, morph T0 _ T1 _ (Id , Id) =-= Id}.

(*=End *)

(*=Tower *)
Definition retract (T0 T1 : M) (f: T0 =-> T1) (g: T1 =-> T0) := g << f =-= Id.

Record Tower : Type := mk_tower
{ tobjects : nat -> M;
  tmorphisms : forall i, tobjects (S i) =-> (tobjects i);
  tmorphismsI : forall i, (tobjects i) =-> (tobjects (S i));
  tretract : forall i, retract (tmorphismsI i) (tmorphisms i);
  tlimitD : forall n i, n <= i ->
    (tmorphismsI i << tmorphisms i : cmetricMorph _ _) = n = Id}.

(*=End *)

(*=Cone *)
Record Cone (To:Tower) : Type := mk_basecone
{ tcone :>  M;
  mcone : forall i, tcone =-> (tobjects To i);
  mconeCom : forall i, tmorphisms To i << mcone (S i) =-= mcone i }.
(*=End *)

Record CoCone (To:Tower) : Type := mk_basecocone
{ tcocone :> M;
  mcocone : forall i, (tobjects To i) =-> tcocone;
  mcoconeCom : forall i, mcocone (S i) << tmorphismsI To i =-= mcocone i }.

(*=Limit *)
Record Limit (To:Tower) : Type := mk_baselimit
{ lcone :> Cone To;
  limitExists : forall (A:Cone To), (tcone A) =-> (tcone lcone);
  limitCom : forall (A:Cone To), forall n, mcone A n =-= mcone lcone n << limitExists A;
  limitUnique : forall (A:Cone To) (h: (tcone A) =-> (tcone lcone))
     (C:forall n, mcone A n =-= mcone lcone n << h), h =-= limitExists A }.
(*=End *)
Record CoLimit (To:Tower) : Type := mk_basecolimit
{ lcocone :> CoCone To;
  colimitExists : forall (A:CoCone To), (tcocone lcocone) =-> (tcocone A) ;
  colimitCom : forall (A:CoCone To), forall n, mcocone A n =-= colimitExists A << mcocone lcocone n;
  colimitUnique : forall (A:CoCone To) (h: (tcocone lcocone) =-> (tcocone A))
     (C:forall n, mcocone A n =-= h << mcocone lcocone n), h =-= colimitExists A }.

Variable L:forall T:Tower, Limit T.

Section RecursiveDomains.

Variable F : BiFunctor.

Add Parametric Morphism C X Y Z W : (fun (x: _ =-> _) (y: _ =-> _) => @morph C X Y Z W (pair x y))
  with signature (@tset_eq _) ==> (@tset_eq _) ==> (@tset_eq _)
  as morph_eq_compat.
move => x x' e y y' e'. apply: (frespect (morph C X Y Z W)). by split.
Qed.

Lemma BiFuncRtoR: forall (T0 T1:M) (f: T0 =-> T1) (g: T1 =-> T0), retract f g ->
          retract (morph F _ _ _ _ (g,f)) (morph F _ _ _ _ (f,g)).
move => A B f g X. unfold retract.
- rewrite -> morph_comp. rewrite -> (morph_eq_compat F X X).
  by rewrite morph_id.
Qed.

Section Tower.

Variable DTower : Tower.

Lemma lt_gt_dec n m : (n < m) + (m = n) + (m < n).
case: (ltngtP m n) => e.
by right.
left. by left.
left. by right.
Qed.

Definition Diter_coercion n m (Eq:n = m) : M (tobjects DTower n) (tobjects DTower m).
rewrite Eq.  by apply: Id.
Defined.

Lemma leqI m n : (m <= n)%N = false -> n <= m.
move => I. have t:=(leq_total m n). rewrite I in t. by apply t.
Qed.

Lemma lt_subK n m : m < n -> n = (n - m + m)%N.
move => l. apply sym_eq. apply subnK. have x:= (leqnSn m). by apply (leq_trans x l).
Qed.

Fixpoint Projection_nm m (n:nat) : (tobjects DTower (n+m)) =-> (tobjects DTower m) :=
match n as n0 return (tobjects DTower (n0+m)) =-> (tobjects DTower m) with
| O => Id
| S n => Projection_nm m n << tmorphisms DTower (n+m)%N
end.

Fixpoint Injection_nm m (n:nat) : (tobjects DTower m) =-> (tobjects DTower (n+m)) :=
match n as n0 return (tobjects DTower m) =-> (tobjects DTower (n0+m)) with
| O => Id
| S n => tmorphismsI DTower (n+m) << Injection_nm m n
end.

Definition t_nm n m : (tobjects DTower n) =-> (tobjects DTower m) :=
match (lt_gt_dec m n) return (tobjects DTower n) =-> (tobjects DTower m) with
| inl (inl ee) => (Projection_nm m (n - m)%N) << (Diter_coercion (lt_subK ee))
| inl (inr ee) => Diter_coercion ee : (tobjects DTower n) =-> (tobjects DTower m)
| inr ee => Diter_coercion (sym_eq (lt_subK ee)) << Injection_nm n (m - n)
end.

Lemma Diter_coercion_simpl: forall n (Eq:n = n), Diter_coercion Eq = Id.
intros n Eq. by rewrite (eq_irrelevance Eq (refl_equal _)).
Qed.

Lemma Proj_left_comp : forall k m, Projection_nm m (S k) =-=
                      tmorphisms DTower m << Projection_nm (S m) k << Diter_coercion (sym_eq (addnS k m)).
elim.
- move => m. simpl.
  rewrite comp_idL. rewrite comp_idR.
  rewrite (Diter_coercion_simpl). by rewrite -> comp_idR.
- move => n IH m. simpl. simpl in IH. rewrite -> IH.
  have P:=(sym_eq (addnS n m)). rewrite (eq_irrelevance (sym_eq (addnS n m)) P).
  have Q:=(sym_eq (addnS n.+1 m)). rewrite (eq_irrelevance (sym_eq (addnS n.+1 m)) Q).
  move: P Q. unfold addn. simpl. fold addn. move => P. generalize P. rewrite P. clear P.
  move => P Q. do 2 rewrite Diter_coercion_simpl.
  do 2 rewrite comp_idR. clear P Q. by rewrite comp_assoc.
Qed.

Lemma Inject_right_comp: forall k m, Injection_nm m (S k) =-=
           Diter_coercion (addnS k m) << Injection_nm (S m) k << tmorphismsI DTower m.
elim.
- move => m. simpl. do 2 rewrite comp_idR. rewrite (Diter_coercion_simpl). by rewrite -> comp_idL.
- move => n IH m. simpl. simpl in IH. rewrite -> IH. clear IH.
  have P:= (addnS n.+1 m). have Q:=(addnS n m). rewrite -> (eq_irrelevance _ P).
  rewrite -> (eq_irrelevance _ Q). move: P Q. unfold addn. simpl. fold addn.
  move => P Q. generalize P Q. rewrite <- Q. clear P Q. move => P Q. do 2 rewrite Diter_coercion_simpl.
  do 2 rewrite comp_idL. by rewrite comp_assoc.
Qed.

Lemma Diter_coercion_comp: forall x y z (Eq1:x = y) (Eq2 : y = z),
     Diter_coercion Eq2 << Diter_coercion Eq1 =-= Diter_coercion (trans_equal Eq1 Eq2).
intros x y z Eq1. generalize Eq1. rewrite Eq1. clear x Eq1.
intros Eq1 Eq2. generalize Eq2. rewrite <- Eq2. clear Eq2. intros Eq2.
repeat (rewrite Diter_coercion_simpl). by rewrite -> comp_idL.
Qed.

Lemma Diter_coercion_eq n m (e e': n = m) : Diter_coercion e =-= Diter_coercion e'.
by rewrite (eq_irrelevance e e').
Qed.

Lemma lt_gt_dec_lt n m : n < m -> exists e, lt_gt_dec n m = inl _ (inl _ e).
move => e. case_eq (lt_gt_dec n m) ; first case.
- move => i _. by exists i.
- move => f. rewrite f in e. by rewrite ltnn in e.
- move => f. have a:=leq_trans (leqnSn _) f. have Fx:=leq_ltn_trans a e. by rewrite ltnn in Fx.
Qed.

Lemma lt_gt_dec_gt n m : m < n -> exists e, lt_gt_dec n m = (inr _ e).
move => e. case_eq (lt_gt_dec n m) ; first case.
- move => i _. have a:=leq_trans (leqnSn _) i. have Fx:=leq_ltn_trans a e. by rewrite ltnn in Fx.
- move => f. rewrite f in e. by rewrite ltnn in e.
- move => i _. by exists i.
Qed.

Lemma lt_gt_dec_eq n m : forall e : m = n, lt_gt_dec n m = (inl _ (inr _ e)).
move => e. generalize e. rewrite e. clear e m. move => e. case_eq (lt_gt_dec n n) ; first case.
- move => i _. have f:=i. by rewrite ltnn in f.
- move => f _. by rewrite (eq_irrelevance e f).
- move => i _. have f:=i. by rewrite ltnn in f.
Qed.

Lemma t_nmProjection: forall n m, t_nm n m =-= tmorphisms DTower m << t_nm n (S m).
move => n m. unfold t_nm. case (lt_gt_dec m n) ; first case.
- case (lt_gt_dec m.+1 n) ; first case.
  + move => l l'. rewrite comp_assoc.
    have X:=Proj_left_comp (n - m.+1) m. have XX:= addnS (n - m.+1) m.
    have Y:=comp_eq_compat X (tset_refl (Diter_coercion XX)).
    repeat (rewrite <- comp_assoc in Y). rewrite -> Diter_coercion_comp in Y.
    rewrite Diter_coercion_simpl in Y. rewrite -> comp_idR in Y. rewrite <- Y.
    rewrite <- comp_assoc. rewrite Diter_coercion_comp.
    have P:=(trans_equal (lt_subK l) XX). have Q:=(lt_subK l').
    rewrite -> (eq_irrelevance _ P). rewrite -> (eq_irrelevance _ Q).
    generalize P.
    have ee:(n - m).-1 = (n - m.+1) by rewrite subnS.
    rewrite <- ee. clear ee P. have e:0 < n - m by rewrite subn_gt0.
    move => P.  have PP:n = ((n - m).-1.+1 + m)%N. rewrite (ltn_predK e). apply Q.
    rewrite (eq_irrelevance P PP). move: PP. rewrite (ltn_predK e). clear. move => PP.
    by rewrite (eq_irrelevance Q PP).
  + move => e. generalize e. rewrite e. clear n e. move => e i. have x:= subSnn m.
    have a:=(lt_subK (n:=m.+1) (m:=m) i). rewrite (eq_irrelevance (lt_subK (n:=m.+1) (m:=m) i) a).
    move: a. rewrite x. clear x. move => a. rewrite (eq_irrelevance e a). simpl. by rewrite comp_idL.
  + move => i j. have Fx:=leq_trans i j. by rewrite ltnn in Fx.
- move => e. generalize e. rewrite e. clear n e. move => e. destruct (lt_gt_dec_gt (leqnn (S m))) as [p A].
  rewrite A. clear A.
  have ee:=subSnn m. have x:=(sym_eq (lt_subK (n:=m.+1) (m:=m) p)).
  rewrite <- (eq_irrelevance x (sym_eq (lt_subK (n:=m.+1) (m:=m) p))). move: x. rewrite ee. simpl.
  move => x. do 2 rewrite (Diter_coercion_simpl). rewrite comp_idL. rewrite comp_idR.
  unfold addn. simpl. by rewrite -> (tretract DTower m).
- move => i. have l:=leq_trans i (leqnSn m). destruct (lt_gt_dec_gt l) as [p A]. rewrite A. clear A l.
  have x:=(sym_eq (lt_subK (n:=m.+1) (m:=n) p)). rewrite (eq_irrelevance (sym_eq (lt_subK (n:=m.+1) (m:=n) p)) x).
  move: x. rewrite subSn ; last by []. simpl. move => x. do 2 rewrite comp_assoc.
  refine (comp_eq_compat _ (tset_refl _)). have y:=(sym_eq (lt_subK (n:=m) (m:=n) i)).
  rewrite (eq_irrelevance (sym_eq (lt_subK (n:=m) (m:=n) i)) y). have a:=(trans_eq (sym_eq (addSn _ _)) x).
  rewrite (eq_irrelevance x a).
  apply tset_trans with (y:=(tmorphisms DTower m << Diter_coercion a) << tmorphismsI DTower (m - n + n)) ; last by [].
  move: a. generalize y. rewrite -> y. clear. move => y a. do 2 rewrite Diter_coercion_simpl.
  rewrite comp_idR. by rewrite (tretract DTower m).
Qed.

Lemma t_nn_ID: forall n, t_nm n n =-= Id.
intros n.
unfold t_nm. rewrite (lt_gt_dec_eq (refl_equal n)). by rewrite Diter_coercion_simpl.
Qed.

Lemma t_nmProjection2 n m : (m <= n) % nat -> t_nm (S n) m =-= (t_nm n m) << tmorphisms DTower n.
move => nm.
assert (exists x, n - m = x) as X by (exists (n - m) ; auto).
destruct X as [x X]. elim: x n m X nm.
- move => n m E EE. have e:=eqn_leq n m. rewrite EE in e. have l:(n <= m)%N. unfold leq. by rewrite E.
  rewrite l in e. have ee:=eqP e. rewrite ee. rewrite t_nn_ID. rewrite comp_idL.
  rewrite -> t_nmProjection. rewrite t_nn_ID. by rewrite comp_idR.
- move => nm IH. case ; first by []. move => n m e l. have ll:n.+1 - m > 0 by rewrite e. rewrite subn_gt0 in ll.
  rewrite subSn in e ; last by []. specialize (IH n m). have ee: n - m = nm by auto.
  rewrite -> (IH ee ll).
  clear IH. have l0:=leq_trans ll (leqnSn _). destruct (lt_gt_dec_lt l0) as [p A].
  unfold t_nm. rewrite A. clear A. case_eq (lt_gt_dec m n) ; first case.
  + move => p' _. have x:=(lt_subK (n:=n.+2) (m:=m) p). rewrite (eq_irrelevance (lt_subK (n:=n.+2) (m:=m) p) x).
    move: x. have x:n.+2 - m = (n-m).+2. rewrite subSn ; last by []. rewrite subSn ; by [].
    rewrite x. clear x. move => x. simpl. do 4 rewrite <- comp_assoc. refine (comp_eq_compat (tset_refl _) _).
    have x':=(lt_subK (n:=n) (m:=m) p'). rewrite (eq_irrelevance (lt_subK (n:=n) (m:=m) p') x').
    have x1:((n - m).+2 + m)%N = ((n - m) + m).+2 by [].
    have x2:=trans_eq x x1.
    apply tset_trans with (y:=tmorphisms DTower (n - m + m) << (tmorphisms DTower (S(n - m + m)) << Diter_coercion x2)) ;
    first by simpl ; rewrite (eq_irrelevance x2 x).
    move: x2. generalize x' ; rewrite <- x'. clear x' x x1 p p'. move => x x'. do 2 rewrite (Diter_coercion_simpl).
    rewrite comp_idR. by rewrite -> comp_idL.
  + move => e'. generalize e'. move: p. rewrite e'. clear e' n l ll e l0 ee. move => p e _.
    rewrite (Diter_coercion_simpl). rewrite comp_idL.
    have x:=(lt_subK (n:=m.+2) (m:=m) p).
    have ee:(m.+2 - m) = (m - m).+2. rewrite subSn ; last by []. rewrite subSn ; by [].
    rewrite (eq_irrelevance (lt_subK (n:=m.+2) (m:=m) p) x). generalize x. rewrite ee. clear ee. rewrite subnn.
    move => xx. clear x e p. simpl. rewrite comp_idL.
    rewrite (Diter_coercion_simpl). by rewrite -> comp_idR.
  + move => f. have lx:=leq_trans f ll. by rewrite ltnn in lx.
Qed.

Lemma t_nmEmbedding: forall n i, t_nm n i =-= (t_nm (S n) i) << tmorphismsI DTower n.
intros n m. unfold t_nm. case (lt_gt_dec m n) ; first case.
- move => i. have l:=leq_trans i (leqnSn _). destruct (lt_gt_dec_lt l) as [p A]. rewrite A. clear A l.
  have x:=((lt_subK p)). rewrite (eq_irrelevance ((lt_subK p)) x).
  move: x. rewrite subSn ; last by []. simpl. move => x. do 2 rewrite <- comp_assoc.
  refine (comp_eq_compat (tset_refl _) _). have y:=((lt_subK i)).
  rewrite (eq_irrelevance ((lt_subK i)) y). have a:=(trans_eq x ((addSn _ _))).
  rewrite (eq_irrelevance x a).
  apply tset_trans with (y:=tmorphisms DTower (n - m + m) << (Diter_coercion a << tmorphismsI DTower n)) ; last by [].
  move: a. generalize y. rewrite <- y. clear. move => y a. do 2 rewrite Diter_coercion_simpl.
  rewrite comp_idL. by rewrite <- (tretract DTower n).
- move => e. generalize e. rewrite e. clear n e. move => e. destruct (lt_gt_dec_lt (leqnn (S m))) as [p A].
  rewrite A. clear A.
  have ee:=subSnn m. have x:=((lt_subK (n:=m.+1) (m:=m) p)).
  rewrite <- (eq_irrelevance x ((lt_subK (n:=m.+1) (m:=m) p))). move: x. rewrite ee. simpl.
  move => x. do 2 rewrite (Diter_coercion_simpl). rewrite comp_idR. rewrite comp_idL.
  by rewrite -> (tretract DTower m).
- case (lt_gt_dec m n.+1) ; first case.
  + move => i j. have Fx:=leq_trans i j. by rewrite ltnn in Fx.
  + move => e. generalize e. rewrite <- e. clear m e. move => e i. have x:= subSnn n.
    have a:=(lt_subK i). rewrite (eq_irrelevance (lt_subK i) a).
    move: a. rewrite x. clear x. move => a. rewrite (eq_irrelevance (sym_eq a) e).
    simpl. by rewrite comp_idR.
  + move => l l'. rewrite <- comp_assoc. have X:=Inject_right_comp (m - n.+1) n. have XX:= sym_eq (addnS (m - n.+1) n).
    have Y:=comp_eq_compat (tset_refl (Diter_coercion XX)) X. rewrite -> comp_assoc in Y.
    rewrite -> (comp_assoc (Injection_nm _ _)) in Y. rewrite -> Diter_coercion_comp in Y.
    rewrite Diter_coercion_simpl in Y. rewrite -> comp_idL in Y. rewrite <- Y.
    rewrite comp_assoc. rewrite Diter_coercion_comp.
    have ee:=(trans_equal XX (sym_eq (lt_subK l))). rewrite -> (eq_irrelevance _ ee).
    clear XX X Y. have e:m - n.+1 = (m - n).-1 by rewrite subnS.
    move: ee. rewrite -> e. have ll:0 < (m - n) by rewrite subn_gt0.
    move => Q.
    have PP:((m - n).-1.+1 + n)%N = m. rewrite -> (ltn_predK ll). by rewrite (sym_eq (lt_subK l')).
    rewrite (eq_irrelevance Q PP). move: PP. have P:=(sym_eq (lt_subK l')). rewrite -> (eq_irrelevance _ P).
    move: P. clear Q. clear e. move => P Q. move: P. rewrite -{1 2 3 4} (ltn_predK ll).
    move => P. by rewrite (eq_irrelevance P Q).
Qed.

Lemma t_nmEmbedding2: forall n m, (n <= m) % nat -> t_nm n (S m) =-= tmorphismsI DTower m << t_nm n m.
move => n m nm.
assert (exists x, m - n = x) as X by (eexists ; apply refl_equal).
destruct X as [x X]. elim: x n m X nm.
- move => n m E EE. have e:=eqn_leq n m. rewrite EE in e. have l:(m <= n)%N. unfold leq. by rewrite E.
  rewrite l in e. have ee:=eqP e. rewrite ee. rewrite -> t_nn_ID. rewrite comp_idR.
  rewrite -> t_nmEmbedding. rewrite t_nn_ID. by rewrite comp_idL.
- move => nm IH. move => n. case ; first by []. move => m e l. have ll:m.+1 - n > 0 by rewrite e. rewrite subn_gt0 in ll.
  rewrite subSn in e ; last by []. specialize (IH n m). have ee:m - n = nm by auto.
  rewrite (IH ee ll). clear IH. have l0:=leq_trans ll (leqnSn _). destruct (lt_gt_dec_gt l0) as [p A].
  unfold t_nm. rewrite A. clear A. case_eq (lt_gt_dec m n) ; first case.
  + move => f. have lx:=leq_trans f ll. by rewrite ltnn in lx.
  + move => e'. generalize e'. move: p. rewrite e'. clear e' n l ll e l0 ee. move => p e _.
    rewrite (Diter_coercion_simpl). rewrite comp_idR. have x:=(lt_subK p).
    have ee:(m.+2 - m) = (m - m).+2. rewrite subSn ; last by []. rewrite subSn ; by [].
    rewrite (eq_irrelevance (lt_subK (n:=m.+2) (m:=m) p) x). generalize x. rewrite ee. clear ee. rewrite subnn.
    move => xx. clear x e p. simpl. rewrite (Diter_coercion_simpl). rewrite -> comp_idL. by rewrite comp_idR.
  + move => p' _. have x:=(lt_subK p). rewrite (eq_irrelevance (lt_subK p) x).
    move: x. have x:m.+2 - n = (m-n).+2. rewrite subSn ; last by []. rewrite subSn ; by [].
    rewrite x. clear x. move => x. simpl. do 4 rewrite -> comp_assoc. refine (comp_eq_compat _ (tset_refl _)).
    have x':=sym_eq(lt_subK p'). rewrite (eq_irrelevance (sym_eq (lt_subK _)) x').
    have x1:((m - n).+2 + n)%N = ((m - n) + n).+2 by [].
    have x2:=sym_eq (trans_eq x x1).
    apply tset_trans with (y:=(Diter_coercion x2 << tmorphismsI DTower (S (m - n + n))) << tmorphismsI DTower ((m - n + n))) ;
    first by simpl ; rewrite (eq_irrelevance x2 (sym_eq x)).
    move: x2. generalize x' ; rewrite x'. clear x' x x1 p p'. move => x x'. do 2 rewrite (Diter_coercion_simpl).
    rewrite -> comp_idR. by rewrite comp_idL.
Qed.

Lemma t_nm_EP i n : (i <= n)%N -> retract (t_nm i n) (t_nm n i).
 have e:exists x, x == n - i by eexists.
case: e => x e. elim: x i n e.
- move => i n e l. have ee:i = n. apply anti_leq. rewrite l. simpl. unfold leq. by rewrite <- (eqP e).
  rewrite -> ee. unfold retract. rewrite -> t_nn_ID. by rewrite comp_idL.
- move => x IH i. case ; first by rewrite sub0n.
  move => n e l. have ll:(i <= n)%N. have aa:0 < n.+1 - i. by rewrite <- (eqP e). rewrite subn_gt0 in aa. by apply aa.
  clear l. specialize (IH i n). rewrite (subSn ll) in e. specialize (IH e ll). unfold retract.
  rewrite (t_nmProjection2 ll). rewrite -> (t_nmEmbedding2 ll). rewrite comp_assoc.
  rewrite <- (comp_assoc (tmorphismsI _ _)). rewrite (tretract DTower n). rewrite comp_idR. by apply (IH).
Qed.

Add Parametric Morphism A B C n : (@Category.comp M A B C)
  with signature (fun x y => @Mrel (cmetricMorph B C) n x y) ==> (fun x y => @Mrel (cmetricMorph A B) n x y) ==>
     (fun x y => @Mrel (cmetricMorph A C) n x y)
  as comp_neq_compat.
move => x y e x' y' e'.
rewrite <- (ccomp_eq x). rewrite <- (proj2 (Mrefl (ccomp _ _ _ (y,y')) _) (ccomp_eq y y') n).
apply: fnonexpansive. by split.
Qed.

Lemma chainPEp (C:CoCone DTower) (C':Cone DTower) : cchainp (fun n : nat => mcocone C n << mcone C' n:cmetricMorph (tcone C') (tcocone C)).
move => n i j l l'. have X:= tlimitD DTower.
have A: forall k, n <= k -> (mcocone C n << mcone C' n:cmetricMorph (tcone C') (tcocone C)) = n = (mcocone C k << mcone C' k).
- elim ; first by move => lx ; rewrite leqn0 in lx ; rewrite (eqP lx).
  move => x IH lx. case_eq (n <= x) => a.
  + specialize (IH a). refine (Mrel_trans IH _).
    have Cx:=comp_eq_compat (mcoconeCom C x) ((mconeCom C' x)).
    simpl in Cx. rewrite <- comp_assoc in Cx. rewrite -> (comp_assoc (mcone C' _)) in Cx.
    refine (Mrel_trans ((proj2 (@Mrefl (cmetricMorph (tcone C') (tcocone C)) _ _) (tset_sym Cx) n)) _). clear Cx. specialize (X _ _ a).
    apply comp_neq_compat ; first by [].
    apply Mrel_trans with (y:=Id << mcone C' x.+1) ; last by apply: (proj2 (Mrefl _ _)) ; apply: comp_idL.
    apply comp_neq_compat ; last by [].
    by apply X.
  + have b:= ltnP x n. rewrite a in b. have c:(x < n) by inversion b. clear b.
    have b:=@anti_leq n (x.+1). rewrite c in b. rewrite lx in b. specialize (b is_true_true).
    by rewrite b.
have B:=A _ l. specialize (A _ l'). by apply (Mrel_trans (Msym B) A).
Qed.

Definition chainPE (C:CoCone DTower) (C':Cone DTower) : cchain (cmetricMorph (tcone C') (tcocone C)) :=
  mk_cchain (@chainPEp C C').

Definition coneN (n:nat) : Cone DTower.
exists (tobjects DTower n) (t_nm n).
move => m. simpl. by rewrite  ->(t_nmProjection n m).
Defined.

Lemma coneCom_l (X:Cone DTower) n i : (i <= n)%nat -> mcone X i =-= t_nm n i << mcone X n.
move => l.
assert (exists x, n - i = x) as E by (eexists ; auto).
destruct E as [x E]. elim: x n i l E.
- move => n i l E. have A:=@anti_leq n i. rewrite l in A.  unfold leq in A. rewrite E in A.
  rewrite andbT in A. specialize (A (eqtype.eq_refl _)). rewrite A. clear l E A n.
  rewrite t_nn_ID. by rewrite comp_idL.
- move => x IH n i l E. rewrite -> (comp_eq_compat (t_nmProjection n i) (tset_refl _)).
  rewrite <- comp_assoc. specialize (IH n i.+1). have l0:i < n by rewrite <- subn_gt0 ; rewrite E.
  have ee:n - i.+1 = x. rewrite subnS. by rewrite E.
  specialize (IH l0 ee). rewrite <- IH.
  by rewrite -> (mconeCom X i).
Qed.

Lemma coconeCom_l (X:CoCone DTower) n i : (n <= i)%nat -> mcocone X n =-= mcocone X i << (t_nm n i).
move => l.
assert (exists x, i - n = x) as E by (eexists ; auto).
destruct E as [x E]. elim: x n i l E.
- move => n i l E. have A:=@anti_leq n i. rewrite l in A. unfold leq in A. rewrite E in A.
  specialize (A is_true_true). rewrite A. rewrite -> t_nn_ID. by rewrite comp_idR.
- move => x IH n i l E. rewrite -> t_nmEmbedding.
  rewrite -> comp_assoc. specialize (IH n.+1 i).
  have ll:n < i by rewrite <- subn_gt0 ; rewrite E.
  have ee:i - n.+1 = x by have Y:= subn_gt0 n i ; rewrite E in Y ;
    rewrite subnS ; rewrite E.
  rewrite <- (IH ll ee). by apply (tset_sym (mcoconeCom X n)).
Qed.

End Tower.

Fixpoint Diter (n:nat) :=
match n return M with
| O => One
| S n => ob F (Diter n) (Diter n)
end.

Variable tmorph_ne : One =-> (ob F One One).

Fixpoint Injection (n:nat) : (Diter n) =-> (Diter (S n)) :=
match n with
| O => tmorph_ne
| S n => morph F (Diter n) (Diter (S n)) (Diter n) (Diter (S n))
           (Projection n, Injection n)
end
with Projection (n:nat) : (Diter (S n)) =-> (Diter n) :=
match n with
| O => terminal_morph _
| S n => morph F (Diter (S n)) (Diter n) (Diter (S n)) (Diter n)
        (Injection n,Projection n)
end.

Lemma retract_IP: forall n, retract (Injection n) (Projection n).
elim ; first by apply: terminal_unique.
move => n IH. unfold retract. simpl. rewrite -> morph_comp.
unfold retract in IH. rewrite -> (morph_eq_compat F IH IH).
by rewrite -> morph_id.
Qed.

Lemma IP_nonexp i j n : i <= j -> (Injection i << Projection i:cmetricMorph _ _) = n = Id -> (Injection j << Projection j : cmetricMorph _ _) = n = Id.
move => l.
have M':exists m, m = j - i by eexists ; apply refl_equal. destruct M' as [m M'].
elim: m i j l M'.
- move => i j l e. have E:= (subn_eq0 j i). rewrite e in E. rewrite eqtype.eq_refl in E.
  have A:= anti_leq. specialize (A i j). rewrite l in A. rewrite <- E in A. specialize (A is_true_true).
  by rewrite A.
- move => m IH i. case ; first by [].
  move=> j l e. specialize (IH i j). have ll: 0 < j.+1 - i. by rewrite <- e.
  rewrite subn_gt0 in ll. specialize (IH ll). clear l. move => X. have I:= (IH _ X). clear IH X.
  simpl. refine (Mrel_trans (proj2 (Mrefl (_ : cmetricMorph _ _) _) (morph_comp F _ _ _ _) n) _).
  apply: (Mrel_trans _ (proj2 (Mrefl (_ : cmetricMorph _ _) _) (morph_id F _ _) n)).
  apply: fnonexpansive. split ; apply I ; rewrite subSn in e ; by auto.
Qed.

Variable morph_contractive : forall (T0 T1 T2 T3:M), contractive (morph F T0 T1 T2 T3).

Lemma IP_cauchy n i : n <= i -> (Injection i << Projection i:cmetricMorph (Diter i.+1) (Diter i.+1)) = n = Id.
- elim:n i ; first by [].
  move => n IH. case ; first by []. move => i l. specialize (IH i l).
  simpl. refine (Mrel_trans (proj2 (Mrefl (_ : cmetricMorph _ _) _) (morph_comp F _ _ _ _) (S n)) _).
  refine (Mrel_trans _ (proj2 (Mrefl (_ : cmetricMorph _ _) _) (morph_id F _ _) (S n))).
  apply morph_contractive. simpl. by split.
Qed.

Definition DTower := mk_tower retract_IP IP_cauchy.

(** printing DInf %\ensuremath{D_\infty}% *)
(*=DInf *)
Definition DInf : M := (L DTower).
(*=End *)
Definition Embeddings n : (tobjects DTower n) =-> DInf := limitExists (L DTower) (coneN DTower n).

Definition Projections n : DInf =-> Diter n := mcone (L DTower) n.

Lemma coCom i : Embeddings i.+1 << Injection i =-= Embeddings i.
unfold Embeddings.
rewrite -> (limitUnique (h:=(Embeddings (S i) << Injection _ :  (tcone (coneN DTower i)) =-> DInf))) ; first by [].
move => m. simpl. unfold Embeddings. rewrite -> comp_assoc. have e:= (limitCom (L DTower) (coneN DTower i.+1) m).
simpl in e. rewrite <- e. by rewrite -> (t_nmEmbedding DTower).
Qed.

Definition DCoCone : CoCone DTower := @mk_basecocone _ DInf Embeddings coCom.

Lemma retract_EP n : Projections n << Embeddings n =-= Id.
unfold Projections. unfold Embeddings.
- rewrite <- (limitCom (L DTower) (coneN DTower n) n). simpl. by rewrite -> t_nn_ID.
Qed.

Lemma emp: forall i j, Projections i << Embeddings j =-= t_nm DTower j i.
intros i j. have A:= leq_total i j. case_eq (i <= j)%N ; move => X ; rewrite X in A.
- unfold Projections. rewrite -> (comp_eq_compat (coneCom_l (L DTower) X) (tset_refl _)).
  rewrite <- comp_assoc. rewrite -> (comp_eq_compat (tset_refl _) (retract_EP j)). by rewrite -> comp_idR.
- simpl in A. have e:= (coconeCom_l DCoCone A). simpl in e. rewrite -> e.
  rewrite -> comp_assoc. rewrite -> (retract_EP i). by rewrite comp_idL.
Qed.

Definition chainPEc (C:CoCone DTower) : cchain (cmetricMorph DInf (tcocone C)) := chainPE C (L DTower).

Lemma EP_id : umet_complete (chainPEc DCoCone) =-= Id.
have Z:forall n : nat, mcone (L DTower) n =-= mcone (L DTower) n << Id by move => n ; rewrite -> comp_idR.
rewrite <- (tset_sym (@limitUnique _ (L DTower) (L DTower) Id Z)).
apply: limitUnique. move => n.
have A:= (nonexp_continuous (exp_fun (ccomp _ _ _) (mcone (L DTower) n)) (chainPEc DCoCone)).
simpl in A. rewrite -> (ccomp_eq (mcone _ n) (umet_complete (chainPEc DCoCone))) in A.
apply: (tset_trans _ (tset_sym A)). clear A. simpl. rewrite -> (cut_complete_eq n). clear Z.
apply tset_trans with (y:=umet_complete (const_cchain (mcone (L DTower) n:cmetricMorph _ _))) ; first by rewrite -> umet_complete_const. refine (@umet_complete_ext (cmetricMorph _ _) _ _ _).
move => i. simpl. rewrite ccomp_eq. rewrite -> comp_assoc.
rewrite -> (emp n (n+i)). by rewrite -> (coneCom_l (L DTower) (leq_addr i n)).
Qed.

Lemma chainPE_simpl X n : chainPEc X n = mcocone X n << Projections n.
by [].
Qed.

Definition DCoLimit : CoLimit DTower.
exists DCoCone (fun C => umet_complete (chainPEc C)).
- move => C n. simpl. have ne:nonexpansive (fun x => x << Embeddings n:cmetricMorph _ _).
    move => t m e e' R. by apply comp_neq_compat. rewrite -> (cut_complete_eq n _).
  apply: (proj1 (Mrefl (_ : cmetricMorph _ _) _)). move => m.
  destruct (cumet_conv (cutn n (chainPEc C)) m) as [m' X]. specialize (X m' (leqnn _)).
  specialize (ne _ _ _ _ X). simpl in ne. refine (Mrel_trans _ ne).
  apply: (proj2 (Mrefl _ _)). rewrite <- comp_assoc. rewrite (emp _ _).
  by apply (coconeCom_l C (leq_addr m' n)).
- move => C h X. rewrite <- (comp_idR h). rewrite <- EP_id.
  have ne:= nonexp_continuous (exp_fun (@ccomp M _ _ _) h) (chainPEc DCoCone).
  simpl in ne. rewrite -> (ccomp_eq h (umet_complete (chainPEc DCoCone))) in ne.
  rewrite -> ne. clear ne. refine (@umet_complete_ext (cmetricMorph _ _) _ _ _) => i. simpl.
  rewrite ccomp_eq. rewrite comp_assoc. by rewrite <- X.
Defined.

Definition ECoCone : CoCone DTower.
exists (ob F DInf DInf) (fun i => morph F _ _ _ _ (Projections i, Embeddings i) << Injection i).
move => i. simpl. rewrite -> morph_comp.
by rewrite -> (morph_eq_compat F (mconeCom (L DTower) i) (mcoconeCom DCoCone i)).
Defined.

Lemma Tcomp_nonexpL (T0 T1 T2:M) (f: T0 =-> T1) : nonexpansive (fun x: T1 =-> T2 => x << f:cmetricMorph _ _).
move => n e e' R. by apply: comp_neq_compat.
Qed.

Lemma Tcomp_nonexpR (T0 T1 T2:M) (f: T2 =-> T0) : nonexpansive (fun x: T1 =-> T2 => f << x:cmetricMorph _ _).
move => n e e' R. by apply: comp_neq_compat.
Qed.

Definition FCone : Cone DTower.
exists (ob F DInf DInf) (fun n => Projection n << morph F _ _ _ _ (Embeddings n, Projections n)).
move => i. refine (comp_eq_compat (tset_refl _) _). unfold Projections.
rewrite <- (morph_eq_compat F (coCom i) (mconeCom (L DTower) i)). simpl.
by rewrite -> morph_comp.
Defined.

Definition chainFPE (C:CoCone DTower) := chainPE C FCone.

Lemma subS_leq j i m : j.+1 - i == m.+1 -> i <= j.
move => X. have a:=subn_gt0 i (j.+1). have x:=ltn0Sn m.
rewrite <- (eqP X) in x. rewrite a in x. by [].
Qed.

Lemma morph_tnm n m : morph F _ _ _ _ (t_nm DTower m n, t_nm DTower n m) =-= t_nm DTower n.+1 m.+1.
have t:= (leq_total n m). case_eq (n <= m)%N ; move => l ; rewrite l in t.
clear t. have M':exists x, m - n == x by eexists ; by []. destruct M' as [x M'].
elim: x m n l M'.
- move => j i l e. rewrite subn_eq0 in e.
  have A:= @anti_leq i j. rewrite l in A. rewrite e in A. specialize (A is_true_true).
  rewrite A. rewrite -> (morph_eq_compat F (t_nn_ID DTower j) (t_nn_ID DTower j)).
  rewrite -> morph_id. by rewrite -> t_nn_ID.
- move => m IH. case.
  + move=> i l e. rewrite leqn0 in l. have ee:=eqP l. rewrite ee.
    rewrite -> (morph_eq_compat F (t_nn_ID DTower O) (t_nn_ID DTower O)).
    rewrite -> morph_id. by rewrite -> t_nn_ID.
  + move => j i e l. specialize (IH j i). have l':=l. have l0:=subS_leq l'. rewrite (subSn l0) in l.
    specialize (IH l0 l). clear l l' e.
    have e:= morph_eq_compat F (t_nmProjection2 DTower l0) (t_nmEmbedding2 DTower l0).
    rewrite <- morph_comp in e. rewrite -> e. rewrite -> IH. clear e.
    have a:= (tset_sym (t_nmEmbedding2 DTower _)).
    specialize (a i.+1 j.+1 l0). by apply a.
simpl in t. clear l.
have M':exists x, n - m == x by eexists ; by []. destruct M' as [x M'].
elim: x m n t M'.
- move => j i l e. rewrite subn_eq0 in e.
  have A:= @anti_leq i j. rewrite l in A. rewrite e in A. specialize (A is_true_true).
  rewrite A. rewrite -> (morph_eq_compat F (t_nn_ID DTower j) (t_nn_ID DTower j)).
  rewrite -> morph_id. by rewrite -> t_nn_ID.
- move => m IH i. case.
  + move=> l e. rewrite leqn0 in l. have ee:=eqP l. rewrite ee.
    rewrite -> (morph_eq_compat F (t_nn_ID DTower O) (t_nn_ID DTower O)).
    rewrite -> morph_id. by rewrite -> t_nn_ID.
  + move => j e l. specialize (IH i j). have l':=l. have l0:=subS_leq l'. rewrite (subSn l0) in l.
    specialize (IH l0 l). clear l l' e.
    have e:= morph_eq_compat F (t_nmEmbedding2 DTower l0) (t_nmProjection2 DTower l0).
    rewrite <-morph_comp in e. rewrite -> e. rewrite -> IH.
    clear e. have a:= (tset_sym (t_nmProjection2 DTower _)).
    specialize (a j.+1 i.+1 l0). by apply a.
Qed.

Lemma ECoLCom : forall (A : CoCone DTower) (n : nat),
   mcocone A n =-= umet_complete (chainFPE A) << mcocone ECoCone n.
move => C n. simpl.
  have ne:=Tcomp_nonexpL (morph F (Diter n) DInf (Diter n) DInf (Projections n, Embeddings n) << Injection n).
  rewrite -> (cut_complete_eq n _).
  apply: (proj1 (Mrefl (_:cmetricMorph _ _) _)). move => m.
  destruct (cumet_conv (cutn n (chainFPE C)) m) as [m' X]. specialize (X m' (leqnn _)).
  specialize (ne _ _ _ _ X). simpl in ne. refine (Mrel_trans _ ne). clear ne.
  apply: (proj2 (Mrefl _ _)).
  do 2 rewrite comp_assoc. rewrite <- (comp_assoc (morph F _ _ _ _ _)). rewrite -> morph_comp.
  rewrite -> (morph_eq_compat F (emp n (n+m')) (emp (n+m') n)). rewrite morph_tnm.
  rewrite <- (comp_assoc (t_nm DTower n.+1 (n+m').+1) (Projection (n + m')) (mcocone C (n + m'))).
  rewrite <- (t_nmProjection DTower). rewrite <- comp_assoc. rewrite <- (t_nmEmbedding DTower).
  apply: (coconeCom_l C _). by apply (leq_addr _ _).
Qed.

Lemma CoLimitUnique : forall (A : CoCone DTower) h,
   (forall n : nat, mcocone A n =-= h << mcocone ECoCone n) ->
   h =-= umet_complete (chainFPE A).
move => C h X. rewrite <- (comp_idR h).
  have a:= morph_eq_compat F EP_id EP_id. rewrite -> morph_id in a. rewrite <- a. clear a.
  have b:= pair_limit (chainPEc DCoCone) (chainPEc DCoCone).
  have c:= (nonexp_continuous (morph F _ _ _ _) _).
  specialize (c _ _ _ _ (cchain_pair (chainPEc DCoCone) (chainPEc DCoCone))).
  have a:=frespect ( (morph F DInf DInf DInf DInf)) b. rewrite -> a in c. clear a b.
  rewrite -> c. clear c.
  have ne:= nonexp_continuous (exp_fun (@ccomp M _ _ _) h) ((liftc (morph F DCoCone DInf DInf DCoCone)
        (cchain_pair (chainPEc DCoCone) (chainPEc DCoCone)))). simpl in ne.
  rewrite -> (@ccomp_eq M _ _ _ h (umet_complete (liftc (morph F DCoCone DInf DInf DCoCone) _))) in ne.
  apply: (tset_trans ne). rewrite -> (cut_complete_eq 1 (chainFPE C)).
  refine (@umet_complete_ext (cmetricMorph _ _) _ _ _) => i. simpl.
  rewrite ccomp_eq. clear ne. rewrite -> morph_comp.
  rewrite <- (morph_comp F (mcone (L DTower) i) (Embeddings i) (Embeddings i) (mcone (L DTower) i)).
  rewrite comp_assoc. apply: comp_eq_compat.
  + specialize (X i.+1). simpl in X. unfold addn. simpl. rewrite -> X. apply: comp_eq_compat ; first by [].
    rewrite -> morph_comp. apply morph_eq_compat.
    * by rewrite -> (mconeCom (L DTower) i).
    * by rewrite -> (@mcoconeCom DTower DCoCone i).
  + apply morph_eq_compat.
    * by rewrite -> (@mcoconeCom DTower DCoCone i).
    * by rewrite -> (mconeCom (L DTower) i).
Qed.

Definition ECoLimit : CoLimit DTower.
exists ECoCone (fun C => umet_complete (chainFPE C)).
by apply ECoLCom.
by apply CoLimitUnique.
Defined.

(*=FoldUnfoldIso *)
Definition Fold : (ob F DInf DInf) =-> DInf := (*CLEAR*) colimitExists ECoLimit DCoCone. (*CLEARED*)
Definition Unfold : DInf =-> (ob F DInf DInf) := (*CLEAR*) colimitExists DCoLimit ECoCone. (*CLEARED*)

Lemma FU_id : Fold << Unfold =-= Id.
(*CLEAR*)
apply tset_trans with (y:=colimitExists DCoLimit DCoLimit).
- refine (@colimitUnique _ DCoLimit DCoLimit _ _). move => i. unfold Fold. unfold Unfold.
  simpl. rewrite <- (ccomp_eq (umet_complete (chainFPE DCoCone)) (umet_complete (chainPEc ECoCone))).
  have a:=frespect ( (ccomp _ _ _)) (pair_limit (chainFPE DCoCone) (chainPEc ECoCone)).
  rewrite -> (nonexp_continuous (ccomp _ _ _)(cchain_pair (chainFPE DCoCone) (chainPEc ECoCone)) ) in a.
  rewrite <- a. clear a.
  have ne:= nonexp_continuous (exp_fun (@ccomp M _ _ _ << <|pi2,pi1|>) (Embeddings i)) (liftc (ccomp DInf FCone DCoCone)
        (cchain_pair (chainFPE DCoCone) (chainPEc ECoCone))).
  simpl in ne.
  rewrite -> (@ccomp_eq M _ _ _ (umet_complete (liftc (ccomp DInf FCone DCoCone)
              (cchain_pair (chainFPE DCoCone) (chainPEc ECoCone)))) (Embeddings i)) in ne.
  rewrite -> ne. clear ne. rewrite -> (cut_complete_eq i _).
  apply (tset_trans (tset_sym (umet_complete_const (Embeddings i:cmetricMorph _ _)))).
  apply umet_complete_ext => j. simpl.
  rewrite ccomp_eq. simpl.
  apply: (tset_trans _ (tset_sym (comp_eq_compat (ccomp_eq _ _) (tset_refl _)))).
  do 3 rewrite comp_assoc. rewrite <- (comp_assoc _ _ (Embeddings (i + j) << Projection (i + j))).
  rewrite -> (morph_comp F (Embeddings (i + j)) (Projections (i + j)) (Projections (i + j)) (Embeddings (i + j))).
  rewrite -> (morph_eq_compat F (emp (i+j) (i+j)) (emp (i+j) (i+j))).
  rewrite -> (morph_eq_compat F (t_nn_ID DTower (i+j)) (t_nn_ID DTower (i+j))).
  rewrite morph_id. rewrite comp_idR. rewrite <- (comp_assoc (Injection (i+j))).
  rewrite retract_IP. rewrite comp_idR. rewrite <- comp_assoc. rewrite -> emp.
  apply: (coconeCom_l DCoCone). by apply leq_addr.
- apply tset_sym. apply: (@colimitUnique _ DCoLimit DCoLimit _ _). move => n. simpl. by rewrite -> comp_idL.
Qed.
(*CLEARED*)
Lemma UF_id : Unfold << Fold =-= Id.
(*CLEAR*)
apply tset_trans with (y:=colimitExists ECoLimit ECoLimit).
- apply (@colimitUnique _ ECoLimit ECoLimit). move => i. unfold Fold. unfold Unfold.
  simpl. rewrite <- (ccomp_eq (umet_complete (chainPEc ECoCone)) (umet_complete (chainFPE DCoCone))).
  have a:=frespect ( (ccomp _ _ _)) (pair_limit (chainPEc ECoCone) (chainFPE DCoCone)).
  rewrite -> (nonexp_continuous (ccomp _ _ _) (cchain_pair (chainPEc ECoCone) (chainFPE DCoCone)) ) in a.
  rewrite <- a. clear a.
  have ne:= nonexp_continuous (exp_fun (@ccomp M _ _ _ << <|pi2,pi1|>) (morph F _ _ _ _ (Projections i,Embeddings i) << Injection i)) (liftc (ccomp _ _ _ )
        (cchain_pair (chainPEc ECoCone) (chainFPE DCoCone))).
  simpl in ne.
  rewrite -> (@ccomp_eq M _ _ _ (umet_complete (liftc (ccomp _ _ _)
              (cchain_pair (chainPEc ECoCone) (chainFPE DCoCone)))) (morph F _ _ _ _ (Projections i,Embeddings i) << Injection i)) in ne.
  rewrite -> ne. clear ne. rewrite -> (cut_complete_eq i _).
  apply (tset_trans (tset_sym (umet_complete_const (morph F _ _ _ _ (Projections i, Embeddings i) << Injection i:cmetricMorph _ _)))).
  apply umet_complete_ext => j. simpl.
  rewrite ccomp_eq. simpl.
  apply: (tset_trans _ (tset_sym (comp_eq_compat (ccomp_eq _ _) (tset_refl _)))).
  do 3 rewrite comp_assoc. rewrite <- (comp_assoc (Embeddings (i+j))). rewrite -> (emp (i+j) (i+j)).
  rewrite t_nn_ID. rewrite comp_idR. rewrite <- (comp_assoc (morph F _ _ _ _ (Projections i, Embeddings i))).
  rewrite -> (morph_comp F (Embeddings (i+j)) (Projections (i+j)) (Projections (i)) (Embeddings (i))).
  rewrite -> (morph_eq_compat F (emp i (i+j)) (emp (i+j) i)). rewrite morph_tnm.
  rewrite <- (comp_assoc (Injection i)). rewrite <- (t_nmEmbedding DTower i (i+j).+1).
  rewrite <- (comp_assoc _ (Projection (i+j))). rewrite <- (t_nmProjection DTower).
  rewrite <- comp_assoc. rewrite <- (@t_nmEmbedding2 DTower _ _ (leq_addr j i)). rewrite -> t_nmEmbedding.
  rewrite comp_assoc. rewrite <- morph_tnm. rewrite -> (morph_comp F (Projections (i + j)) (Embeddings (i + j))
           (t_nm DTower (i + j) i) (t_nm DTower i (i + j))).
  by rewrite <- (morph_eq_compat F (coneCom_l (L DTower) (leq_addr j i)) (coconeCom_l DCoCone (leq_addr j i))).
- apply tset_sym. apply (@colimitUnique _ ECoLimit ECoLimit). move => n. by rewrite -> comp_idL.
Qed.
(*CLEARED*)
(*=End *)

End RecursiveDomains.

End Msolution.


Require Import SCaml.SCaml.
Require Import SCaml.ExtrSCaml.

Inductive action : Set :=
| Increment (i : int)
| Decrement (i : int).

Parameter empty_op : list operation.

Definition main := SCaml.make_contract (fun action storage =>
  match action with
  | Increment i => Some (empty_op : list operation, storage + i)
  | Decrement i => Some (empty_op : list operation, storage - i)
  end).

Extraction Language OCaml.
Extract Inlined Constant empty_op => "([] : SCaml.operation list)".
Extraction "inc_dec.ml" main.