Require Import HoTT.Classes.interfaces.abstract_algebra
               HoTT.Classes.interfaces.orders
               HoTT.Classes.theory.rationals
               HoTT.Classes.theory.premetric
               HoTT.Classes.orders.orders
               HoTT.Classes.orders.semirings
               HoTT.Classes.implementations.assume_rationals
               HoTT.HSet HoTT.Basics.Trunc HProp HSet
               Types.Universe
               TruncType Types.Sigma
               HIT.quotient.

Require Import HoTTClasses.sierpinsky partiality dedekind.

Require Export Rlow Opens Functions D_op.

(** * OpenFun : operator which take an open and return
the characteristic function of this open *)

(** such a construction is possible because of the way
we have defined the lower reals as maps from Q to Sier.
We define the OpenFun by induction on the Sierpinski sets
*)

Section S_to_RlP.

(** Map from Sier to RlowPos *)
Definition S_to_RlP : forall s : Sier, RlowPos.
Proof.
apply (partial_rec Unit _ le).
simple refine (Build_Recursors _ _ _ _ _ _ _ _ _ _ _ _);simpl.
+ intros _. exact RlP_1.
+ exact RlP_0.
+ intros f Hn.
  exact (RllubPos f).
+ reflexivity.
+ intros x.
  apply RlowPos_pos.
+ intros s Hp x Hi n.
  assert (Rlle (s n) ((fun (f0 : nat -> RlowPos)
       (_ : forall n : nat, Rlle (f0 n) (f0 (S n))) =>
       RllubPos f0) s Hp)).
  simpl.
  apply RllubPos_lub.
  unfold Rlle in *; red in Hi; auto.
  red; unfold Rllepos, Rlle in *.
  auto.
+ intros s Hi x Hn q Hh.
  assert (Hx : (elt (Rllub s) q)).
  trivial.
  assert (H2 : Rlle (RllubPos s) x).
  apply RllubPos_le. trivial.
  apply Rlow_mon with (Rllub s) q.
  reflexivity.
  trivial.
  trivial.
Defined.

(** Monotonicity of the map from Sier to RlowPos *)
Lemma S_to_RlP_mon : forall s1 s2, SierLe s1 s2
                        -> Rlle (S_to_RlP s1) (S_to_RlP s2).
Proof.
apply (partialLe_ind0 _ _).
+ unfold Rlle; auto.
+ assert (X : S_to_RlP (bot Unit) = RlP_0).
  auto; rewrite X.
  intros. apply RlowPos_pos.
+ intros f x H1 H2 n.
  assert (H : Rlle (S_to_RlP (f n)) (S_to_RlP (sup Unit f))).
  assert (Hr : S_to_RlP (sup Unit f) = RllubPos
                        (fun n => S_to_RlP (f n))).
  auto. rewrite Hr.
  apply (Rllub_lub (fun n => S_to_RlP (f n))); trivial.
  unfold Rlle in *; auto.
+ intros f x H1 H2.
  assert (Hr : S_to_RlP (sup Unit f) = RllubPos
                        (fun n => S_to_RlP (f n))).
  auto. rewrite Hr.
  apply Rllub_le.
  intros n;
  apply H2.
Qed.

(** S_to_RlP preserves meets *)
Lemma meet_pres_S_to_RlP :
          MeetPreserving (fun (s: Sier) => S_to_RlP s).
Proof.
intros x y;
unfold sg_op, meet_is_sg_op, S_to_RlP.
revert x.
apply (partial_ind0 _ (fun a => _)).
+ intros x.
  assert (H1 : SierMeet (eta Unit x) y = y).
  generalize (SierMeet_top y).
  intros Hst;
  destruct x;
  fold SierTop;
  unfold meet in Hst; trivial.
  rewrite H1.
  assert (H2 : forall x:RlowPos, Rlle x RlP_1 ->
                    RlPMeet RlP_1 x = x).
  intros rr Hrr.
  apply (antisymmetry le).
  - intros s Hs.
    simpl in Hs.
    destruct (dec (s < 1)%mc).
    unfold meet in Hs.
    apply top_le_meet in Hs.
    apply (snd Hs).
    apply top_le_meet in Hs.
    apply (snd Hs).
  - intros s Hs.
    simpl.
    apply top_le_meet.
    split.
    unfold semi_decide, Rllt_semi_dec, decidable_semi_decide.
    destruct (dec (s < Qone)%mc).
    apply top_greatest.
    case n.
    red in Hrr;
    unfold Rlle in Hrr.
    specialize (Hrr s Hs).
    simpl in Hrr.
    unfold semi_decide, Rllt_semi_dec, decidable_semi_decide in *.
    destruct (dec (s < Qone)).
    case (n l).
    apply not_bot in Hrr;
    case Hrr.
    trivial.
  - rewrite H2.
    reflexivity.
    assert (H : Rlle (S_to_RlP SierTop) RlP_1).
    unfold Rlle; auto.
    unfold Rlle in *; intros q Hq.
    apply H.
    revert Hq.
    apply S_to_RlP_mon.
    apply top_greatest.
+ assert (HsB : SierMeet (bot Unit) y  = bot Unit).
  apply (antisymmetry le).
  - apply imply_le.
    intros Hz; apply top_le_meet in Hz.
    apply (fst Hz).
  - apply imply_le.
    intros Hz;
    apply not_bot in Hz;
    case Hz.
  - assert (HrB : forall r, RlPMeet RlP_0 r = RlP_0).
    intros r.
    apply (antisymmetry le).
    -- intros s Hs.
       simpl in Hs.
       apply top_le_meet in Hs.
       unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qzero)).
       destruct Hs as (_,Hs).
       simpl.
       unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qzero)).
       apply top_greatest.
       case (n l).
       destruct Hs as (Hs,_).
       apply not_bot in Hs; case Hs.
    -- intros s Hs; simpl in Hs.
       destruct (RlPMeet RlP_0 r) as (rr,Hprr); simpl.
       unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qzero)).
       apply Hprr; trivial.
       apply not_bot in Hs; case Hs.
    -- rewrite HsB.
       transitivity RlP_0.
       reflexivity.
       rewrite HrB.
       reflexivity.
+ intros f Hn.
  apply (antisymmetry le).
  - intros q Hn'.
    assert (H2 : SierMeet (sup Unit f) y =
                 sup _ (SierMeet_seq_l f y)).
    apply SierMeet_sup.
    rewrite H2 in Hn'.
    assert (Hn'2 : elt (Rllub
                  (fun n => S_to_RlP ((SierMeet_seq_l f y) n))) q).
    trivial.
    clear Hn'.
    apply top_le_enumerable_sup in Hn'2.
    revert Hn'2; apply (Trunc_ind _).
    intros (n,Hn'2).
    specialize (Hn n).
    simpl in Hn'2.
    assert (H3 : elt (rl (S_to_RlP y)) q).
    revert Hn'2.
    apply Rlow_mon.
    reflexivity.
    apply S_to_RlP_mon.
    apply SierMeet_is_meet.
    trivial.
    assert (Ho : elt
                     (RlMeet (RllubPos (fun n => S_to_RlP (f n)))
                              (S_to_RlP y)) q).
    unfold RlPMeet.
    simpl.
    apply top_le_meet.
    split.
    -- apply top_le_enumerable_sup.
       apply tr.
       unfold semi_decide.
       exists n.
       revert Hn'2.
       apply Rlow_mon.
       reflexivity.
       apply S_to_RlP_mon.
       apply SierMeet_is_meet.
    -- apply H3.
    -- trivial.
  - intros q Hn'.
    unfold RlPMeet in Hn'.
    apply top_le_meet in Hn'.
    destruct Hn' as (Hna,Hnb).
    assert (Hna2 : elt (Rllub
                   (fun n => S_to_RlP (f n))) q).
    trivial. clear Hna.
    apply top_le_enumerable_sup in Hna2.
    revert Hna2; apply (Trunc_ind _).
    intros (m,Hm).
    assert (H2 : SierMeet (sup Unit f) y =
                 sup _ (SierMeet_seq_l f y)).
    apply SierMeet_sup.
    rewrite H2.
    assert (H3 : elt (Rllub
                 (fun n => S_to_RlP ((SierMeet_seq_l f y) n))) q).
    apply top_le_enumerable_sup.
    apply tr.
    exists m.
    simpl; specialize (Hn m).
    unfold S_to_RlP.
    rewrite Hn.
    unfold RlPMeet.
    simpl.
    apply top_le_meet.
    split; trivial.
    trivial.
Qed.

(** S_to_RlP preserves joins *)
Lemma join_pres_S_to_RlP :
          JoinPreserving (fun (s: Sier) => S_to_RlP s).
Proof.
intros x y;
unfold sg_op, join_is_sg_op, S_to_RlP.
revert x.
apply (partial_ind0 _ (fun a => _)).
+ intros x.
  assert (H1 : SierJoin (eta Unit x) y = eta Unit x).
  generalize (SierJoin_top y).
  intros Hst;
  destruct x;
  trivial.
  rewrite H1.
  assert (H2 : forall x:RlowPos, Rlle x RlP_1 ->
                    RlPJoin RlP_1 x = RlP_1).
  intros rr Hrr.
  apply (antisymmetry le).
  - intros s Hs.
    simpl in Hs.
    unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
    destruct (dec (s < Qone)).
    apply top_le_join in Hs.
    revert Hs; (apply (Trunc_ind _)).
    intros Hs.
    destruct Hs;
    simpl; unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
    destruct (dec (s < Qone)); try trivial.
    case (n l).
    destruct (dec (s < Qone)); try trivial.
    apply top_greatest.
    case (n l).
    apply top_le_join in Hs.
    unfold hor in Hs.
    revert Hs; (apply (Trunc_ind _)).
    intros []. intros i.
    -- apply not_bot in i; case i.
    -- simpl; intros i.
       unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qone)); try trivial.
       apply top_greatest.
       red in Hrr.
       apply Hrr in i.
       simpl in i; unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
       destruct (dec (s < Qone)); try trivial.
       case (n0 l).

  - intros s Hs.
    apply top_le_join.
    apply tr.
    simpl in Hs; simpl.
    unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
    destruct (dec (s < Qone)).
    left; trivial.
    left; trivial.
  - simpl.
    rewrite H2.
    reflexivity.
    clear H1.
    revert y.
    assert (H3 : forall y, Rlle (S_to_RlP y)
                        (S_to_RlP (eta Unit tt))).
    intros y; apply S_to_RlP_mon.
    apply top_greatest.
    trivial.
+ assert (HsB : SierJoin (bot Unit) y  = y).
  reflexivity.
  assert (HrB : forall r, RlPJoin RlP_0 r = r).
  intros r.
  apply (antisymmetry le).
  -- intros s Hs.
     unfold RlPJoin in Hs; simpl in Hs.
     apply top_le_join in Hs.
     unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
     destruct (dec (s < Qzero)).
     * apply rlpos; trivial.
     * revert Hs; apply (Trunc_ind _).
       intros Hs.
       case Hs; intros Ho.
       ** apply not_bot in Ho; case Ho.
       ** trivial.
  -- intros s Hs;
     simpl in Hs.
     simpl.
     unfold semi_decide, Rllt_semi_dec,
              decidable_semi_decide in *.
     destruct (dec (s < Qzero)).
     apply top_le_join.
     unfold hor; apply tr.
     left; apply top_greatest.
     apply top_le_join.
     unfold hor; apply tr.
     right; trivial.
  -- rewrite HrB, HsB.
     reflexivity.
+ intros f Hn.
  apply (antisymmetry le).
  - intros q Hn'.
    assert (H2 : SierJoin (sup Unit f) y =
                 sup _ (SierJoin_seq_l f y)).
    rewrite <- SierJoin_sup.
    reflexivity.
    rewrite H2 in Hn'.
    assert (Hn'2 : elt (Rllub
         (fun n => S_to_RlP ((SierJoin_seq_l f y) n))) q).
    trivial.
    clear Hn'.
    apply top_le_enumerable_sup in Hn'2.
    revert Hn'2; apply (Trunc_ind _).
    intros (n,Hn'2).
    specialize (Hn n).
    simpl in Hn'2.
    unfold join in Hn'2.
    apply top_le_join.
    assert (Hn'3 : elt (rl (RlPJoin
                 (S_to_RlP (f n)) (S_to_RlP y))) q).
    rewrite <- Hn;
    trivial.
    simpl in Hn'3.
    apply top_le_join in Hn'3.
    revert Hn'3;
    apply (Trunc_ind _);
    intros Hn'3.
    apply tr.
    case Hn'3; intros Hh.
    -- left.
       assert (H1 : elt (Rllub
                               (fun n => S_to_RlP (f n))) q).
       apply top_le_enumerable_sup.
       apply tr; exists n; trivial.
       trivial.
    -- right;
       trivial.
  - intros q Hn'.
    unfold RlPJoin in Hn'.
    apply top_le_join in Hn'.
    revert Hn';
    apply (Trunc_ind _);
    intros Hn'.
    assert (H2 : SierJoin (sup Unit f) y =
                     sup _ (SierJoin_seq_l f y)).
    rewrite <- SierJoin_sup.
    reflexivity.
    rewrite H2.
    assert (H3 : elt (Rllub
                     (fun n => S_to_RlP
                     ((SierJoin_seq_l f y) n))) q).
    apply top_le_enumerable_sup.
    case Hn'; intros H;
    unfold semi_decide, semi_decide_sier in H.
    -- assert (H' : elt (Rllub (fun n => S_to_RlP
                                   (f n))) q).
       trivial. clear H.
       apply top_le_enumerable_sup in H'.
       revert H'; apply (Trunc_ind _).
       intros (n,H').
       apply tr.
       exists n.
       simpl.
       revert H'.
       apply Rlow_mon.
       reflexivity.
       apply S_to_RlP_mon,
             SierJoin_is_join.
    -- apply tr.
       exists O.
       simpl.
       revert H.
       apply Rlow_mon.
       reflexivity.
       apply S_to_RlP_mon,
             SierJoin_is_join.
    -- trivial.
Qed.

Coercion S_to_RlP : Sier >-> RlowPos.

End S_to_RlP.

Section OpenFun.

(** Map from Opens to characteristic function *)
Definition OpenFun {A : hSet} : forall (U : A -> Sier),
                                       (A -> RlowPos).
Proof.
intros s z.
exact (let sz := s z in (S_to_RlP sz)).
Defined.

(** OpenFun is definite *)
Lemma OpenFun_def {A} : forall U:OS A, U = OS_empty
                               -> OpenFun U = fun x => RlP_0.
Proof.
intros U HU;
apply path_forall;
intros x; rewrite HU; auto.
Qed.

(** OpenFun is sub-probabilistic*)
Lemma OpenFun_prob {A} : forall U:OS A, U = OS_full
                               -> ffle (OpenFun U) (fun x => RlP_1).
Proof.
intros U HU x;
rewrite HU; unfold Rlle; auto.
Qed.

(** OpenFun is monotonic *)
Lemma OpenFun_mon {A} : forall U V:OS A, Osle U V -> fle (OpenFun U) (OpenFun V).
Proof.
intros U V H1 s;
unfold OpenFun;
apply S_to_RlP_mon; trivial.
Qed.

Lemma Toto : forall p, p = 0%mc -> elt RlP_1 p.
Proof.
intros p Hp.
unfold RlP_1.
simpl.
unfold semi_decide, Rllt_semi_dec,
       decidable_semi_decide in *.
destruct (dec (p < Qone)).
apply top_greatest.
rewrite Hp in n.
assert (X : 0%mc < Qone).
apply lt_0_1.
case (n X).
Qed.

(** 1_U (x) = 1 iff 1_U (x) > 0 *)
Lemma OpenFun_0_1 {A  : hSet}: forall (U : OS A) z,
    OpenFun U z = RlP_1 <-> RlP_0 < OpenFun U z.
Proof.
intros U z.
split; intros H1.
+ rewrite H1.
  red; unfold Rlltpos, Rllt.
  apply tr.
  exists Qzero.
  split.
  - assert (Hh : forall p, p = 0%mc -> elt RlP_1 p).
    intros p Hp; unfold RlP_1.
    simpl.
    unfold semi_decide, Rllt_semi_dec,
       decidable_semi_decide in *.
    destruct (dec (p < Qone)).
    apply top_greatest.
    rewrite Hp in n.
    assert (X : 0%mc < Qone).
    apply lt_0_1.
    case (n X).
    apply Hh.
    reflexivity.
  - intros HF.
    assert (Hh : forall p, p = 0%mc -> ~ elt RlP_0 p).
    intros p Hp H.
    simpl in H.
    unfold semi_decide, Rllt_semi_dec,
       decidable_semi_decide in *.
    destruct (dec (p < Qzero)).
    rewrite Hp in l.
    assert (Hl : ~ 0%mc < Qzero).
    apply le_not_lt_flip.
    reflexivity.
    case (Hl l).
    apply not_bot in H; case H.
    specialize (Hh Qzero).
    assert (Hj : Qzero = 0%mc).
    reflexivity.
    apply Hh in Hj.
    case (Hj HF).
+ revert H1; unfold OpenFun, S_to_RlP.
  generalize (U z).
  apply (partial_ind0 _ (fun a => _ -> _)).
  - intros t H.
    assert (H1 : RlP_0 < RlP_1) by trivial.
    trivial.
  - intros H.
    assert (H1 : RlP_0 < RlP_0).
    trivial.
    apply Rllt_strict_order in H1.
    case H1.
  - intros f Hn' Hsup'.
    assert (Hn : forall n, RlP_0 < S_to_RlP (f n) ->
            S_to_RlP (f n) = RlP_1).
    trivial.
    clear Hn'.
    assert (Hsup : RlP_0 < (RllubPos (fun n =>
                           (S_to_RlP (f n)))));
    trivial; clear Hsup'.
    assert (H : (RllubPos (fun n => (S_to_RlP (f n))))
               = RlP_1).
    apply (antisymmetry le).
    * intros q Hql.
      apply top_le_enumerable_sup in Hql.
      unfold semi_decide, toRlseq in Hql.
      revert Hql; apply (Trunc_ind _).
      intros (x,Hx).
      destruct (Qle_total Qzero q).
      ** assert (H1 : S_to_RlP (f x) = RlP_1).
         apply Hn.
         red; unfold Rlltpos, Rllt;
         apply tr; exists q.
         split; trivial.
         intros Hf; simpl in Hf;
         unfold semi_decide, Rllt_semi_dec,
            decidable_semi_decide in *;
         destruct (dec (q < Qzero)).
         apply orders.lt_not_le_flip in l0.
         case (l0 l).
         apply not_bot in Hf; case Hf.
         rewrite H1 in Hx; trivial.
      ** simpl; unfold semi_decide, Rllt_semi_dec,
                decidable_semi_decide;
         destruct (dec (q < Qone)).
         apply top_greatest.
         assert (n' : q < Qone).
         apply orders.le_lt_trans with Qzero; trivial.
         apply semirings.lt_0_1.
         case (n n').
    * intros q Hq1.
      apply top_le_enumerable_sup.
      unfold semi_decide, toRlseq.
      assert (Hm : hexists
               (fun m => RlP_0 < S_to_RlP (f m))).
      red in Hsup; unfold Rlltpos,
                   Rllt in Hsup.
      revert Hsup; apply (Trunc_ind _);
      intros (r,(Hr1,Hr2)).
      apply top_le_enumerable_sup in Hr1.
      revert Hr1; apply (Trunc_ind _);
      intros (m,Hm);
      unfold semi_decide, toRlseq in *.
      apply tr; exists m.
      red; unfold Rlltpos, Rllt.
      apply tr.
      exists r; split;  trivial.
      revert Hm; apply (Trunc_ind _);
      intros (m,Hm).
      apply Hn in Hm.
      apply tr; exists m.
      rewrite Hm; trivial.
    * trivial.
Qed.

(** 1_U (x) = 1 iff x ∈ U *)
Lemma OpenFun_correct {A : hSet} : forall (x:A) U,
               OpenFun U x = RlP_1 <-> (U x) = SierTop.
Proof.
intros x U.
split; intros Hu.
apply OpenFun_0_1 in Hu.
+ unfold OpenFun, S_to_RlP in *.
  revert Hu.
  generalize (U x).
  apply (partial_ind0 _ (fun a => _->_)).
  - simpl; intros v Hv.
    unfold SierTop.
    destruct v.
    reflexivity.
  - simpl; intros Hv.
    assert (Hf : RlP_0 < RlP_0); trivial.
    red in Hf;
    unfold Rllt in Hf.
    revert Hf; apply (Trunc_ind _).
    intros (q,(E1,E2)).
    case (E2 E1).
  - intros f Hn Hn'.
    assert (Hn'2 : RlP_0 < RllubPos
           (fun n => S_to_RlP (f n))).
    trivial.
    clear Hn'.
    assert (Ha: merely (exists n : nat,
              RlP_0 < S_to_RlP (f n))).
    red in Hn'2;
    unfold Rlltpos, Rllt in Hn'2.
    revert Hn'2; apply (Trunc_ind _).
    intros (p,(Hp1,Hp2)).
    apply top_le_enumerable_sup in Hp1.
    revert Hp1; apply (Trunc_ind _).
    intros (m,Hm).
    apply tr.
    exists m.
    red;unfold Rlltpos, Rllt.
    apply tr.
    exists p.
    split; trivial.
    revert Ha; apply (Trunc_ind _).
    intros (w,Hw).
    specialize (Hn w Hw).
    apply top_le_eq.
    apply top_le_sup.
    apply tr; exists w;
    rewrite Hn;
    apply top_greatest.
+ unfold OpenFun, S_to_RlP;
  rewrite Hu; simpl.
  reflexivity.
Qed.

(** 1_(U /\ V) = (1_U) /\ (1_V) *)
Lemma Meet_pres_openfun {A:hSet}: forall z s,
          MeetPreserving (fun (U: OS A) => elt (OpenFun U z) s).
Proof.
intros z s x y;
unfold OpenFun, sg_op, meet_is_sg_op.
assert (H1 : (x ⋂ y) z = meet (x z) (y z)).
unfold OS_meet, meet.
apply (antisymmetry le);
apply imply_le;
intros Hs;
apply top_le_meet in Hs;
apply top_le_meet; trivial.
rewrite H1.
rewrite meet_pres_S_to_RlP.
reflexivity.
Qed.

(** 1_(U \/ V) = (1_U) \/ (1_V) *)
Lemma Join_pres_openfun {A:hSet}: forall z s,
          JoinPreserving (fun (U: OS A) => elt (OpenFun U z) s).
Proof.
intros z s x y;
unfold OpenFun, sg_op, join_is_sg_op.
assert (H1 : (x ∪ y) z = join (x z) (y z)).
unfold OS_join, join.
apply (antisymmetry le);
apply imply_le; intros Hs;
apply top_le_join in Hs;
apply top_le_join; trivial.
rewrite H1.
rewrite join_pres_S_to_RlP.
reflexivity.
Qed.

(** 1_U + 1_V = 1_(U \/ V) + 1_(U /\ V)*)
Lemma OpenFun_mod {A}: forall (U V : OS A), fplus (OpenFun U) (OpenFun V) =
                                fplus (OpenFun (OS_meet U V))
                                      (OpenFun (OS_join U V)).
Proof.
intros U V.
apply path_forall; intros z.
apply (antisymmetry le).
+ intros q Hs.
  simpl in *.
  apply RlPlus_eq_pr in Hs.
  apply RlPlus_eq_pr.
  revert Hs; apply (Trunc_ind _).
  intros Hs; apply tr.
  destruct Hs as (r,(r',(Hr,(Hr',Hq1)))).
  destruct (Qle_total r r') as [E|E].
  - generalize (SierMeet_is_meet).
    intros Hsm; destruct Hsm.
    exists r, r'.
    repeat split; try trivial.
    -- red.
       rewrite Meet_pres_openfun.
       apply meet_glb.
       * trivial.
       * revert Hr'.
         apply Rlow_mon; trivial.
         intros s Hs; trivial.
    -- apply Rlow_mon with (rl (OpenFun V z)) r'; trivial.
       reflexivity.
       apply OpenFun_mon.
       intros s; apply SierJoin_is_join; apply Hr'.
  - exists r', r.
    repeat split; try trivial.
    -- red.
       rewrite Meet_pres_openfun.
       apply SierMeet_is_meet.
       * revert Hr.
         apply Rlow_mon; trivial.
         intros s Hs;trivial.
       * trivial.
    -- apply Rlow_mon with (rl (OpenFun U z)) r; trivial.
       reflexivity.
       apply OpenFun_mon.
       intros s; apply SierJoin_is_join; apply Hr.
    -- rewrite rings.plus_comm; trivial.
+ intros q Hs. simpl in *.
  apply RlPlus_eq_pr in Hs.
  apply RlPlus_eq_pr.
  revert Hs; apply (Trunc_ind _).
  intros Hs.
  destruct Hs as (r,(r',(Hr,(Hr',Hq1)))).
  destruct (Qle_total r r') as [E|E].
  - rewrite Join_pres_openfun in Hr'.
    apply top_le_join in Hr'.
    unfold hor in Hr'.
    revert Hr'; apply (Trunc_ind _); intros Hr'.
    apply tr.
    destruct Hr'.
    -- exists r', r.
       repeat split; try trivial.
       * rewrite Meet_pres_openfun in Hr.
         revert Hr.
         apply SierLe_imply.
         apply SierMeet_is_meet.
       * rewrite rings.plus_comm; trivial.
    -- exists r, r'.
       repeat split; try trivial.
       * rewrite Meet_pres_openfun in Hr.
         revert Hr.
         apply SierLe_imply.
         apply SierMeet_is_meet.
  - apply tr. exists r', r.
    repeat split; try trivial.
    -- rewrite Meet_pres_openfun in Hr.
       assert (Hr1 : elt (rl (OpenFun U z)) r).
       revert Hr.
       apply SierLe_imply.
       apply SierMeet_is_meet.
       revert Hr1.
       apply Rlow_mon; try trivial.
       intros s Hs; trivial.
    -- revert Hr; apply OpenFun_mon.
       intros s; apply SierMeet_is_meet.
    -- rewrite rings.plus_comm; trivial.
Qed.

(* D_op 0 1_U = U *)
Lemma D_op_OpenFun {A  : hSet}: forall (U : OS A),
           (D_op Qzero (OpenFun U)) = U.
Proof.
intros U.
pose (Hdp := D_op_correct (OpenFun U) Qzero).
apply path_forall.
intros z.
apply (antisymmetry le).
+ apply imply_le.
  intros Hz.
  apply Hdp in Hz.
  apply OpenFun_0_1 in Hz.
  apply OpenFun_correct in Hz.
  rewrite Hz; apply top_greatest.
+ apply imply_le.
  intros Hz.
  apply Hdp.
  apply OpenFun_0_1.
  apply OpenFun_correct.
  apply top_le_eq; trivial.
Qed.

(** 1_U preserves lub *)
Lemma OpenFun_lub {A : hSet} :
    forall (U : IncreasingSequence (OS A)) x,
         OpenFun (Cpo.lub U) x =
                RllubPos (fun n => (OpenFun (U n)) x).
Proof.
intros U x.
unfold OpenFun; simpl.
apply (antisymmetry le).
+ intros s Hs.
  apply top_le_enumerable_sup in Hs.
  unfold semi_decide, toRlseq in Hs.
  revert Hs; apply (Trunc_ind _).
  intros (m,Hm).
  apply top_le_enumerable_sup.
  apply tr; exists m.
  revert Hm; apply S_to_RlP_mon.
  apply imply_le.
  intros Hv.
  apply top_le_joined_seq_n' in Hv.
  revert Hv; apply (Trunc_ind _).
  intros (p,Hp).
  destruct Hp as (Hpm,HUp).
  revert HUp.
  apply SierLe_imply.
  assert (H' : Osle (U p) (U m)).
  apply seq_increasing_le; trivial.
  apply H'.
+ intros s Hs.
  apply top_le_enumerable_sup in Hs.
  unfold semi_decide, toRlseq in Hs.
  revert Hs; apply (Trunc_ind _).
  intros (m,Hm).
  revert Hm; apply S_to_RlP_mon.
  apply imply_le.
  intros H.
  apply top_le_countable_sup.
  apply tr; exists m; trivial.
Qed.

(** fun n => U n ---> fun n => 1_(U n) *)
Definition OpenFun_increasing_sequence {A : hSet} :
   IncreasingSequence (OS A) -> IncreasingSequence (mf A).
Proof.
intros U.
exists (fun n => OpenFun (U n)).
intros n x.
apply OpenFun_mon.
apply U.
Defined.

Definition OpenFun_meet_fun {A : hSet} (U : OS A) (f : mf A) :=
             fun x => RlPMeet (f x) (OpenFun U x).

End OpenFun.


Require Export Crypto.Util.FixCoqMistakes.

Section tower_nd.
  Context (A : Type).
  Section with_B.
    Context (B : Type).
    Fixpoint tower_nd (n : nat)
      := match n with
         | 0 => B
         | S n' => A -> tower_nd n'
         end.
  End with_B.

  Section with_B2.
    Context (B B' : Type) (f : B -> B').
    Fixpoint impl_under_tower_nd (n : nat)
      : tower_nd B n -> tower_nd B' n
      := match n with
         | 0 => f
         | S n' => fun t x => impl_under_tower_nd n' (t x)
         end.
  End with_B2.
End tower_nd.

Definition apply4 {AK BK PA PB ARR}
           (F : forall (A : AK) (B : BK), (PA A -> PB B) -> PB (ARR A B))
           {A0 A1 A2 A3 : AK} {B : BK}
           (f : PA A0 -> PA A1 -> PA A2 -> PA A3 -> PB B)
  : PB (ARR A0 (ARR A1 (ARR A2 (ARR A3 B)))).
Proof.
  repeat (apply F; intro); apply f; assumption.
Defined.

Definition apply4_nd {BK PA PB ARR}
           (F : forall (B : BK), (PA -> PB B) -> PB (ARR B))
           {B : BK}
           (f : tower_nd PA (PB B) 4)
  : PB (ARR (ARR (ARR (ARR B))))
  := @apply4 unit BK (fun _ => PA) PB (fun _ => ARR) (fun _ => F)
             tt tt tt tt B f.

Definition apply9 {AK BK PA PB ARR}
           (F : forall (A : AK) (B : BK), (PA A -> PB B) -> PB (ARR A B))
           {A0 A1 A2 A3 A4 A5 A6 A7 A8 : AK} {B : BK}
           (f : PA A0 -> PA A1 -> PA A2 -> PA A3 -> PA A4 -> PA A5 -> PA A6 -> PA A7 -> PA A8 -> PB B)
  : PB (ARR A0 (ARR A1 (ARR A2 (ARR A3 (ARR A4 (ARR A5 (ARR A6 (ARR A7 (ARR A8 B))))))))).
Proof.
  repeat (apply F; intro); apply f; assumption.
Defined.

Definition apply9_nd {BK PA PB ARR}
           (F : forall (B : BK), (PA -> PB B) -> PB (ARR B))
           {B : BK}
           (f : tower_nd PA (PB B) 9)
  : PB (ARR (ARR (ARR (ARR (ARR (ARR (ARR (ARR (ARR B)))))))))
  := @apply9 unit BK (fun _ => PA) PB (fun _ => ARR) (fun _ => F)
             tt tt tt tt tt tt tt tt tt B f.


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Compare_dec.
Import List.ListNotations.

Require Import Leapfrog.P4automaton.
Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.Relations.
Require Leapfrog.Bisimulations.Semantic.
Module BS := Leapfrog.Bisimulations.Semantic.

Section Upto.
  Variable (a: p4automaton).
  Notation conf := (configuration a).
  Definition bisimulation_upto
             (f: rel conf -> rel conf)
             (R: rel conf)
    :=
      forall c1 c2,
        R c1 c2 ->
        (accepting c1 <-> accepting c2) /\
        forall b, f R (step c1 b) (step c2 b)
  .

  Definition bisimilar_upto
             (f: rel conf -> rel conf)
             (c1 c2: conf)
    :=
      exists R, bisimulation_upto f R /\ R c1 c2
  .

  Definition closure_extends
             (close: rel conf -> rel conf)
    :=
      forall (R: rel conf) c1 c2,
        R c1 c2 -> close R c1 c2
  .

  Definition closure_preserves_accept
             (close: rel conf -> rel conf)
    :=
      forall (R: rel conf),
        (forall c1 c2, R c1 c2 -> accepting c1 <-> accepting c2) ->
        (forall c1 c2, close R c1 c2 -> accepting c1 <-> accepting c2)
  .

  Definition closure_preserves_transition
             (close: rel conf -> rel conf)
    :=
      forall (R: rel conf),
        (forall c1 c2, R c1 c2 ->
                  forall b, close R (step c1 b) (step c2 b)) ->
        (forall c1 c2, close R c1 c2 ->
                  forall b, close R (step c1 b) (step c2 b))
  .

  Definition closure_mono
             (close: rel conf -> rel conf)
    :=
      forall (R R': rel conf),
        (forall c1 c2, R c1 c2 -> R' c1 c2) ->
        (forall c1 c2, close R c1 c2 -> close R' c1 c2)
  .

  Class SoundClosure
        (f: rel conf -> rel conf)
    := {
    closure_sound_extends: closure_extends f;
    closure_sound_preserves_accept: closure_preserves_accept f;
    closure_sound_preserves_transition: closure_preserves_transition f;
    closure_sound_mono: closure_mono f;
      }.
End Upto.


Require Import Crypto.Algebra.Field.
Require Import Crypto.Spec.MontgomeryCurve Crypto.Curves.Montgomery.Affine.
Require Import Crypto.Spec.WeierstrassCurve Crypto.Curves.Weierstrass.Affine.
Require Import Crypto.Curves.Weierstrass.AffineProofs.
Require Import Crypto.Curves.Montgomery.AffineProofs.
Require Import Coq.Classes.RelationClasses.

Module M.
  Section MontgomeryCurve.
    Import BinNat.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:Decidable.DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "- x" := (Fopp x).
    Local Notation "x ^ 2" := (x*x) (at level 30).
    Local Notation "0" := Fzero.
    Local Notation "1" := Fone.
    Local Notation "4" := (1+1+1+1).

    Global Instance MontgomeryWeierstrassIsomorphism
           {a b: F}
           (b_nonzero : b <> 0)
           (discriminant_nonzero: a^2 - 4 <> 0)
           {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 3}
           {char_ge_12:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 12}
           {char_ge_28:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 28} (* XXX: this is a workaround for nsatz assuming arbitrary characteristic *)
      :
      @Group.isomorphic_commutative_groups
        (@W.point F Feq Fadd Fmul _ _)
        W.eq
        (@W.add F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv field _ char_ge_3 _ _)
        W.zero
        (@W.opp F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv _ _ field _)

        (@M.point F Feq Fadd Fmul a b)
        M.eq
        (M.add(char_ge_3:=char_ge_3)(b_nonzero:=b_nonzero))
        M.zero
        (M.opp(b_nonzero:=b_nonzero))

        (M.of_Weierstrass(Haw:=reflexivity _)(Hbw:=reflexivity _)(b_nonzero:=b_nonzero))
        (M.to_Weierstrass(Haw:=reflexivity _)(Hbw:=reflexivity _)(b_nonzero:=b_nonzero)).
    Proof.
      eapply @AffineProofs.M.MontgomeryWeierstrassIsomorphism; try assumption; cbv [id]; fsatz.
    Qed.
  End MontgomeryCurve.
End M.


(* this file is just for experiments, and is not part of the development *)

(*
Goal forall (T:UU) (X : T -> T -> UU) (t t':T) (e:t==t') , X t t'.
  intros.
  destruct (!e).                (* doesn't work *)
  destruct e.                   (* replaces t' by t and eliminates e *)
  rewrite -> e.                 (* replaces t by t' *)
  rewrite    e.                 (* replaces t by t' *)
  rewrite <- e.                 (* replaces t' by t *)
*)

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel2.stnfsets.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.pathnotations. Import PathNotations.
Require Import RezkCompletion.precategories.

Require Import Ktheory.Utilities.
        Import Ktheory.Utilities.Notations.

Module A.

  Module Type TU.
    Variable T:UU.
    Variable U:T->UU.
  End TU.

  Module Rec2 ( Import tu : TU ).
    Record F := newF { t:T; u:U t }.
    Lemma Feq (f f':F) (et : paths (t f) (t f')) (eu : paths (et # u f) (u f')) : paths f f'.
      destruct f as [a b].
      destruct f' as [a' b'].
      unfold t in et.
      unfold u in eu.
      destruct eu.
      destruct et.
      apply idpath.
    Defined.
    (* Check Feq. *)
  End Rec2.

  (* Print Module Rec2. *)

  Module nat_nat : TU.
    Definition T := nat.
    Definition U := (fun t:T => nat).
  End nat_nat.

  Module bool_bool : TU.
    Definition T := bool.
    Definition U := (fun t:T => bool).
  End bool_bool.

  Module prod_nat_nat := Rec2 nat_nat.
  Module prod_bool_bool := Rec2 bool_bool.

End A.

Module B.

  Require Import Foundations.Proof_of_Extensionality.funextfun.

  Add LoadPath "." as Ktheory.
  Require Import Ktheory.Utilities.

  Variable T:UU.
  Variable U:T->UU.
  Variable i:isofhlevel 2 T.
  Variable j:forall t, isofhlevel 2 (U t).

  Record F := newF { t:T; u:U t }.
  Definition G := total2 U.

  Lemma G2: isofhlevel 2 G.
    apply isofhleveltotal2.
    apply i. apply j. Defined.

  Lemma FG: G == F.
   apply univalenceaxiom.
   set (n := (fun g => newF (pr1 g) (pr2 g)) : G -> F).
   set (m := (fun f => tpair U (t f) (u f)) : F -> G).
   exists n.
   apply (gradth n m).
     intro. destruct x. apply idpath.
     intro. destruct y. apply idpath.
   Defined.

  Lemma F2: isofhlevel 2 F.
    destruct FG.  apply G2.
  Qed.

End B.


Require Import List.

Require Import bigstep.
Require Import datatypes.
Require Import smallstep.

(****************** Big -> Small *********************)

Lemma if_bf_then_sf: forall T s p t q,
                     bf T s p t q ->
                     sf T s p t q /\ is_value T t q.
induction 1.

split; auto. apply sf0; assumption.

split.
apply sfI with i (pair (Cons (hd r) l) (tl r)). apply s1R; assumption.
tauto. tauto.

split.
apply sfI with i (pair (tl l) (Cons (hd l) r)). apply s1L; assumption.
tauto. tauto.

split.
apply sfI with i (pair l (Cons a (tl r))). apply s1W; assumption.
tauto. tauto.
Qed.

(****************** Small -> Big *********************)

Lemma s1_to_bf: forall T s p t q u i,
                s1 T s p u i -> bf T u i t q ->
                bf T s p t q.
intros. inversion_clear H in H0.

apply bfR with i; assumption; assumption.
apply bfL with i; assumption; assumption.
apply bfW with i a; assumption; assumption.
Qed.

Lemma if_sf_then_bf: forall T s p t q,
                     sf T s p t q -> is_value T t q ->
                     bf T s p t q.
induction 1; intros.

apply bfH; assumption.

assert (bf T u i t q).
apply IHsf; assumption. clear H0 H1 IHsf.
apply s1_to_bf with u i; assumption; assumption.
Qed.

(****************** Big_oo -> Small_oo *********************)

Lemma if_bi_then_si: forall T s p,
                     bi T s p -> si T s p.
cofix cohp. intros.
inversion_clear H.

apply siC with q (pair (Cons (hd r) l) (tl r)).
apply s1R; assumption.
apply cohp; assumption.

apply siC with q (pair (tl l) (Cons (hd l) r)).
apply s1L; assumption.
apply cohp; assumption.

apply siC with q (pair l (Cons a (tl r))).
apply s1W; assumption.
apply cohp; assumption.
Qed.

(****************** Small_oo -> Big_oo *********************)

Lemma if_si_then_bi: forall T s p,
                     si T s p -> bi T s p.
cofix cohp. intros.
inversion_clear H. inversion_clear H0 in H1.

apply biR with q.
assumption.
apply cohp; assumption.

apply biL with q.
assumption.
apply cohp; assumption.

apply biW with q a.
assumption.
apply cohp; assumption.
Qed.

(****************** Extra tools (for later use) *************)

Lemma sf_to_bf: forall T s p t q u i,
                sf T s p u i -> bf T u i t q ->
                bf T s p t q.
induction 1; intros.

assumption.

assert (bf T u i t q). apply IHsf; assumption.
apply s1_to_bf with u i; assumption; assumption.
Qed.

Lemma sf_trans: forall T s p t q u i,
                sf T s p u i -> sf T u i t q ->
                sf T s p t q.
induction 1; intros.

assumption.

assert (sf T u i t q). apply IHsf; assumption.
apply sfI with i u; assumption; assumption.
Qed.


Require Import stack.
Require Import patterns.

Fixpoint rep_seg lst (tailp p : Z) : MapPattern Z Z :=
 match lst with
    | nil => constraint (p = tailp)
    | x :: xs => constraint (p <> 0) :* existsP p',
        p |-> x :* (p + 1) |-> p' :* rep_seg xs tailp p'
  end%pattern.
Notation rep_list l := (rep_seg l 0).


Inductive light : Set :=
  | Blue   : light
  | Yellow : light
  | Red    : light.

Definition next x :=
  match x with
    | Blue   => Yellow
    | Yellow => Red
    | Red    => Blue
  end.

Check next Yellow.
Eval compute in next Yellow.


From mathcomp
     Require Import ssreflect ssrnat ssrbool ssrfun eqtype seq div fintype
     tuple finfun bigop.
Add LoadPath "../mylib".
Require Export mylib.
Require Export NNet_sub_def.

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

Module Import NNetDef.
(* ***************************** *)
Module neuron1.

   Record class_of (I O C:Type) :=
    Class {
        action : C -> I -> O;
        op : O -> O -> O;
        _ : associative op
      }.

  Section Packing.

    Structure type :=
      Pack {NNetI; NNetO; NNetC; _: class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT return
                           class_of (NNetI cT) (NNetO cT) (NNetC cT) in c.

  End Packing.

  Module Exports.

    Notation neuron1Type := type.
    Definition NNetI := NNetI.
    Definition NNetO := NNetO.
    Definition NNetC := NNetC.
    Definition NNaction S := action (class S).
    Definition NNop S := op (class S).

  End Exports.
End neuron1.
Import neuron1.Exports.

Section neuron1_lemma.

  Variable (S:neuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.

  Lemma NNopA : associative op.
  Proof. rewrite /op. by case : S => NNetI NNetO NNetC []. Qed.

  Definition neuron1 Idim (coeff:C ^ Idim) b : I ^ Idim -> O :=
    fun input => \big[op/b]_(i < Idim) action (coeff i) (input i).

  Definition MP1parameter Idim Odim : Type :=
    ((C ^ Idim) ^ Odim : Type) * O ^ Odim.

  Definition coeff_zero c0 Idim Odim : (C ^ Idim) ^ Odim : Type :=
    [ffun => [ffun => c0]].

  Definition bias_zero o0 Odim : O ^ Odim := [ffun => o0].

  Definition MP1parameter_zero o0 c0 Idim Odim : MP1parameter Idim Odim :=
    (coeff_zero c0 Idim Odim,bias_zero o0 Odim).

  Definition MP1 Idim Odim (p:MP1parameter Idim Odim) :
    I ^ Idim -> O ^ Odim :=
    fun input => [ffun j => neuron1 (p.1 j) (p.2 j) input].

(* ***************************** *)

  Lemma neuron1_Idim0 (coeff:C ^ 0) b input :
    neuron1 coeff b input = b.
  Proof. by rewrite /neuron1 big_ord0. Qed.

  Lemma MP1_Idim0 Odim (p:MP1parameter 0 Odim) input:
    MP1 p input = p.2.
  Proof. apply /ffunP => i. rewrite ffunE. exact : neuron1_Idim0. Qed.

  Lemma neuron1_op_bias Idim (coeff:C ^ Idim) b b' input:
    neuron1 coeff (op b b') input = op (neuron1 coeff b input) b'.
  Proof. by rewrite /neuron1 big_idx_assoc; last exact NNopA. Qed.

  Lemma MP1_op_bias Idim Odim (coeff:(C ^ Idim) ^ Odim: Type)
        (bias bias':O ^ Odim) input:
    MP1 (coeff,[ffun j => op (bias j) (bias' j)]) input
    = [ffun j => op (MP1 (coeff,bias) input j) (bias' j)].
  Proof. apply /ffunP => j. by rewrite !ffunE -/neuron1 neuron1_op_bias. Qed.

  Lemma neuron1_appI Idim Idim' (coeff:C ^ (Idim + Idim')) b input:
    neuron1 coeff b input =
    neuron1 (index_projl coeff)
            (neuron1 (index_projr coeff) b (index_projr input))
            (index_projl input).
  Proof.
    rewrite /neuron1 big_split_ord_nested.
    rewrite (eq_bigr (fun i => action (index_projl coeff i)
                                      (index_projl input i)))=>[|i _];
      last by rewrite !ffunE.
    congr bigop. apply : eq_bigr => i _. by rewrite !ffunE.
  Qed.

  Lemma MP1_appI Idim Idim' Odim (p:MP1parameter (Idim + Idim') Odim) input:
    MP1 p input =
    MP1 ([ffun i => index_projl (p.1 i)],
         MP1 ([ffun i => index_projr (p.1 i)],p.2) (index_projr input))
        (index_projl input).
  Proof. apply /ffunP => j. rewrite !ffunE. exact : neuron1_appI. Qed.

  Lemma MP1_sumO Idim Odim Odim'
        (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim) ^ Odim' : Type) bias bias' input:
    MP1 ((index_app coeff coeff'),(index_app bias bias')) input =
    index_app (MP1 (coeff,bias) input) (MP1 (coeff',bias') input).
  Proof.
    apply /ffunP => j. rewrite !ffunE /=.
    case splitP =>/= j' Heq /=; by rewrite !ffunE.
  Qed.

  Lemma MP1_appO Idim Odim Odim' (p:MP1parameter Idim (Odim + Odim')) input:
    MP1 p input =
    index_app (MP1 (index_projl p.1, index_projl p.2) input)
              (MP1 (index_projr p.1, index_projr p.2) input).
  Proof. by rewrite -MP1_sumO !index_app_proj. Qed.

  Lemma index_projl_MP1 Idim Odim Odim'
        (p:MP1parameter Idim (Odim + Odim')) input:
    index_projl (MP1 p input) = MP1 (index_projl p.1, index_projl p.2) input.
  Proof. by rewrite MP1_appO index_projl_app. Qed.

  Lemma index_projr_MP1 Idim Odim Odim'
        (p:MP1parameter Idim (Odim + Odim')) input:
    index_projr (MP1 p input) = MP1 (index_projr p.1, index_projr p.2) input.
  Proof. by rewrite MP1_appO index_projr_app. Qed.

(* ***************************** *)

  Definition cast_MP1parameter Idim1 Odim1 Idim2 Odim2
             (eqIdim : Idim1 = Idim2) (eqOdim : Odim1 = Odim2)
             (p:MP1parameter Idim1 Odim1) : MP1parameter Idim2 Odim2 :=
    ecast Idim2 _ eqIdim (ecast Odim2 _ eqOdim p).

  Lemma cast_MP1parameter_id Idim Odim eqIdim eqOdim (p:MP1parameter Idim Odim):
    cast_MP1parameter eqIdim eqOdim p = p.
  Proof. by rewrite !eq_axiomK. Qed.

  Lemma cast_MP1parameterK Idim1 Odim1 Idim2 Odim2
        (eqIdim:Idim1 = Idim2) (eqOdim:Odim1 = Odim2):
    cancel (cast_MP1parameter eqIdim eqOdim)
           (cast_MP1parameter (esym eqIdim) (esym eqOdim)).
  Proof. by case : Idim2 / eqIdim; case : Odim2 / eqOdim. Qed.

  Lemma cast_MP1parameterKV Idim1 Odim1 Idim2 Odim2
        (eqIdim:Idim1 = Idim2) (eqOdim:Odim1 = Odim2):
    cancel (cast_MP1parameter (esym eqIdim) (esym eqOdim))
           (cast_MP1parameter eqIdim eqOdim).
  Proof. by case : Idim2 / eqIdim; case : Odim2 / eqOdim. Qed.

  Lemma cast_MP1parameter_trans Idim1 Odim1 Idim2 Odim2 Idim3 Odim3
        eqIdim12 eqIdim23 eqOdim12 eqOdim23 (p:MP1parameter Idim1 Odim1):
    @cast_MP1parameter _ _ Idim3 Odim3 eqIdim23 eqOdim23
                       (@cast_MP1parameter _ _ Idim2 Odim2 eqIdim12 eqOdim12 p)
    = cast_MP1parameter (etrans eqIdim12 eqIdim23) (etrans eqOdim12 eqOdim23) p.
  Proof. by case : Idim3 / eqIdim23; case : Odim3 / eqOdim23. Qed.

  Lemma cast_MP1parameter_inj Idim1 Odim1 Idim2 Odim2
        (eqIdim:Idim1 = Idim2) (eqOdim:Odim1 = Odim2):
    injective (cast_MP1parameter eqIdim eqOdim).
  Proof. exact : can_inj (cast_MP1parameterK _ _). Qed.

  Lemma cast_MP1parameterE Idim1 Odim1 Idim2 Odim2
        (eqIdim : Idim1 = Idim2) (eqOdim : Odim1 = Odim2)
        (p:MP1parameter Idim1 Odim1):
    cast_MP1parameter eqIdim eqOdim p =
    (cast_index eqOdim [ffun i => cast_index eqIdim (p.1 i)],
     cast_index eqOdim p.2).
  Proof.
    case : Idim2 / eqIdim. case : Odim2 /eqOdim.
    rewrite cast_MP1parameter_id !cast_index_id. case : p => p1 p2.
    congr(_,_). apply /ffunP => i. by rewrite ffunE cast_index_id.
  Qed.

  Lemma MP1_cast Idim1 Odim1 Idim2 Odim2
        (eqIdim:Idim1 = Idim2) (eqOdim:Odim1 = Odim2)
        (p:MP1parameter Idim1 Odim1) input:
    MP1 (cast_MP1parameter eqIdim eqOdim p) (cast_index eqIdim input) =
    cast_index eqOdim (MP1 p input).
  Proof.
    apply /ffunP => i. rewrite cast_MP1parameterE ffunE !cast_indexE !ffunE /=.
    rewrite /neuron1 (big_cast_ord _ _ eqIdim).
    apply : eq_bigr => j _. by rewrite !cast_indexE cast_ordK.
  Qed.

End neuron1_lemma.

(* ***************************** *)
Module mononeuron1.

  Record mixin_of (S:neuron1Type) :=
    Mixin {
        id: NNetO S;
        _: left_id id (@NNop S);
        _: right_id id (@NNop S)
      }.

  Section Packing.

    Structure class_of (I O C:Type) :=
      Class {
          neuron1_class : neuron1.class_of I O C;
          mixin : mixin_of (neuron1.Pack neuron1_class)
        }.
    Structure type := Pack {NNetI; NNetO; NNetC; _: class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.

    Definition neuron1 := neuron1.Pack (neuron1_class class).

  End Packing.

  Module Exports.

    Notation mononeuron1Type := type.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion neuron1 : mononeuron1Type >-> neuron1Type.
    Canonical neuron1.
    Definition NNid S := id (mixin (class S)).

  End Exports.
End mononeuron1.
Import mononeuron1.Exports.

(* ***************************** *)
Section mononeuron1_lemma.

  Variable (S:mononeuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.

  Lemma NNop0o : left_id id op.
  Proof. rewrite /op /id. by case : S => NNetI NNetO NNetC [class []]. Qed.

  Lemma NNopo0 : right_id id op.
  Proof. rewrite /op /id. by case : S => NNetI NNetO NNetC [class []]. Qed.

  Canonical NNop_monoid := Monoid.Law (@NNopA S) NNop0o NNopo0.

  Definition bias0 := bias_zero id.

  Lemma neuron1_bias Idim (coeff:C ^ Idim) b input:
    neuron1 coeff b input = op (neuron1 coeff id input) b.
  Proof. by rewrite /op -neuron1_op_bias -/op NNop0o. Qed.

  Lemma MP1_bias Idim Odim (coeff:(C ^ Idim) ^ Odim: Type) bias input:
    MP1 (coeff,bias) input =
    [ffun j => op (MP1 (coeff,bias0 _) input j) (bias j)].
  Proof. apply /ffunP => j. by rewrite !ffunE -/neuron1 neuron1_bias. Qed.

End mononeuron1_lemma.

(* ***************************** *)
Module idCneuron1.

  Record mixin_of (V:mononeuron1Type) :=
    Mixin {
        idC: NNetC V;
        _: forall x, NNaction idC x = @NNid V
      }.

  Section Packing.

    Structure class_of (I O C:Type) :=
      Class {
          mono_class:mononeuron1.class_of I O C;
          mixin:mixin_of (mononeuron1.Pack mono_class)
        }.
    Structure type := Pack {NNetI; NNetO; NNetC; _: class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (mono_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).

  End Packing.

  Module Exports.

    Notation idCneuron1Type := type.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion neuron1 : idCneuron1Type >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : idCneuron1Type >-> mononeuron1Type.
    Canonical mononeuron1.
    Definition NNidC S := idC (class S).

  End Exports.
End idCneuron1.
Export idCneuron1.Exports.

Section idCneuron1_lemma.

  Variable (S:idCneuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.
  Let idC := @NNidC S.
  Let parameter := @MP1parameter S.

  Definition coeff0 := coeff_zero idC.
  Definition MP1parameter0 := MP1parameter_zero id idC.

  Lemma action_idl x: action idC x = id.
  Proof.
    rewrite /action /idC /id. by case : S x => NNetI NNetO NNetC [class []].
  Qed.

  Lemma neuron1_idC Idim (input:I ^ Idim) b:
    neuron1 [ffun _ => idC] b input = b.
  Proof.
    rewrite neuron1_bias /neuron1 big1; first exact : NNop0o.
    move => i _. rewrite ffunE. exact : action_idl.
  Qed.

  Lemma MP1_coeff0 Idim Odim (bias:O ^ Odim) (input:I ^ Idim):
    MP1 (coeff0 _ _,bias) input = bias.
  Proof. by apply /ffunP => j; rewrite !ffunE neuron1_idC. Qed.

  Definition coeff_app Idim Odim Idim' Odim'
             (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim') ^ Odim': Type)
    :=
    index_app
      [ffun j:'I_Odim => (index_app (coeff j) [ffun _ :'I_Idim' => idC])]
      [ffun j:'I_Odim' => (index_app [ffun _ :'I_Idim => idC] (coeff' j))].

  Definition MP1parameter_sum Idim1 Odim1 Idim2 Odim2
             (p1:parameter Idim1 Odim1) (p2:parameter Idim2 Odim2) :
    parameter (Idim1 + Idim2) (Odim1 + Odim2) :=
    (coeff_app p1.1 p2.1,index_app p1.2 p2.2).

  Lemma MP1parameter_sumA Idim1 Odim1 Idim2 Odim2 Idim3 Odim3
        (p1:parameter Idim1 Odim1) (p2:parameter Idim2 Odim2)
        (p3:parameter Idim3 Odim3):
    MP1parameter_sum p1 (MP1parameter_sum p2 p3) =
    cast_MP1parameter (esym (addnA _ _ _)) (esym (addnA _ _ _))
                      (MP1parameter_sum (MP1parameter_sum p1 p2) p3).
  Proof.
    rewrite /MP1parameter_sum cast_MP1parameterE /=.
    congr(_,_); last exact : index_appA. apply /ffunP => i.
    rewrite cast_indexE esymK !ffunE !cast_ord_addnA /=.
    case : splitP => j _/=; last (rewrite !ffunE /=; case : splitP => k _/=);
      rewrite ?split_lshift ?split_rshift /= !ffunE /=
              ?split_lshift ?split_rshift /= ?ffunE -?index_appA =>//.
    - congr index_app. apply /ffunP => k /=. rewrite !ffunE /=.
      by case : splitP => ? _/=; rewrite ffunE.
    - rewrite index_appA. congr cast_index. congr index_app. apply /ffunP => t.
      rewrite !ffunE /=. by case : split => ? /=; rewrite ffunE.
  Qed.

  Lemma MP1parameter_sum0 Idim1 Idim2 Odim1 Odim2:
    MP1parameter_sum (MP1parameter0 Idim1 Odim1) (MP1parameter0 Idim2 Odim2) =
    (MP1parameter0 _ _).
  Proof.
    rewrite /MP1parameter_sum /MP1parameter0.
    by congr(_,_); apply /ffunP => i;
      rewrite !ffunE /=; case : splitP => i' _/=; rewrite !ffunE //;
      apply /ffunP => j; rewrite !ffunE /=; case : splitP => j' /=;
      rewrite !ffunE.
  Qed.

End idCneuron1_lemma.

(* ***************************** *)
Module comoneuron1.

  Record mixin_of (S:mononeuron1Type) :=
    Mixin { _: commutative (@NNop S)}.

  Section Packing.

    Record class_of (I O C:Type) :=
      Class {
          mono_class : mononeuron1.class_of I O C;
          mixin : mixin_of (mononeuron1.Pack mono_class)
        }.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (mono_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).

  End Packing.

  Module Exports.

    Notation comoneuron1Type := type.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion neuron1 : comoneuron1Type >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : comoneuron1Type >-> mononeuron1Type.
    Canonical mononeuron1.

  End Exports.
End comoneuron1.
Export comoneuron1.Exports.

Section comoneuron1_lemma.

  Variable (S:comoneuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.

  Lemma NNopC : commutative op.
  Proof. rewrite /op. by case : S => NNetI NNetO NNetC [class []]. Qed.

  Canonical NNop_comoid := Monoid.ComLaw NNopC.

  Lemma NNopCA : left_commutative op. Proof. exact : Monoid.mulmCA. Qed.
  Lemma NNopAC : right_commutative op. Proof. exact : Monoid.mulmAC. Qed.
  Lemma NNopACA : interchange op op. Proof. exact : Monoid.mulmACA. Qed.

  Lemma neuron1_sumI Idim Idim'
        (coeff:C ^ Idim) (coeff':C ^ Idim') b b' input:
    neuron1 (index_app coeff coeff') (op b b') input
    = op (neuron1 coeff b (index_projl input))
         (neuron1 coeff' b' (index_projr input)).
  Proof.
    rewrite neuron1_bias [_ _ b _]neuron1_bias [_ _ b' _]neuron1_bias.
    rewrite NNopACA /neuron1. congr(op _ _). rewrite big_split_ord.
    congr (op _ _); apply: eq_bigr => i _.
    - congr(action _ _); first exact : index_app_lshift. by rewrite ffunE.
    - congr(action _ _); first exact : index_app_rshift. by rewrite ffunE.
  Qed.

  Lemma MP1_sumI Idim Idim' Odim
      (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim') ^ Odim: Type)
      (bias bias':O ^ Odim) input:
    MP1 ([ffun j => index_app (coeff j) (coeff' j)],
         [ffun j => op (bias j) (bias' j)]) input
    = [ffun j => op (MP1 (coeff,bias) (index_projl input) j)
                    (MP1 (coeff',bias') (index_projr input) j)].
  Proof. apply /ffunP => j. by rewrite !ffunE neuron1_sumI. Qed.

  Lemma neuron1_appl Idim Idim'
        (coeff:C ^ Idim) (coeff':C ^ Idim') b input:
    neuron1 (index_app coeff coeff') b input
    = op (neuron1 coeff b (index_projl input))
         (neuron1 coeff' id (index_projr input)).
  Proof. by rewrite -neuron1_sumI /id /op NNopo0. Qed.

  Lemma neuron1_appr Idim Idim'
        (coeff:C ^ Idim) (coeff':C ^ Idim') b input:
    neuron1 (index_app coeff coeff') b input
    = op (neuron1 coeff id (index_projl input))
         (neuron1 coeff' b (index_projr input)).
  Proof. by rewrite -neuron1_sumI /id /op NNop0o. Qed.

  Lemma MP1_appl Idim Idim' Odim
      (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim') ^ Odim: Type)
      (bias :O ^ Odim) input:
    MP1 ([ffun j => index_app (coeff j) (coeff' j)],bias) input
    = [ffun j => op (MP1 (coeff,bias) (index_projl input) j)
                    (MP1 (coeff',bias0 _ _) (index_projr input) j)].
  Proof. apply /ffunP => j. by rewrite !ffunE neuron1_appl. Qed.

  Lemma MP1_appr Idim Idim' Odim
      (coeff:(C ^ Idim) ^ Odim: Type) (coeff':(C ^ Idim') ^ Odim: Type)
      (bias :O ^ Odim) input:
    MP1 ([ffun j => index_app (coeff j) (coeff' j)],bias) input
    = [ffun j => op (MP1 (coeff,bias0 _ _) (index_projl input) j)
                    (MP1 (coeff',bias) (index_projr input) j)].
  Proof. apply /ffunP => j. by rewrite !ffunE neuron1_appr. Qed.

  Lemma neuron1_linear Idim coeff b (input1 input2:I ^ Idim) k:
    let input1' := [ffun i => if i == k then input2 i else input1 i] in
    let input2' := [ffun i => if i == k then input1 i else input2 i] in
    op (neuron1 coeff b input1) (neuron1 coeff b input2) =
    op (neuron1 coeff b input1') (neuron1 coeff b input2').
  Proof.
    rewrite /= ![_ _ b _]neuron1_bias /op !NNopA -/op. congr op.
    rewrite ![op (_ _ b) _]NNopAC. congr op.
    rewrite /neuron1 !(bigD1 k is_true_true).
    rewrite ![op _ (_ (_ (coeff k) _)_)]NNopACA !ffunE eq_refl.
    congr op; first exact : NNopC.
    by congr op; apply : eq_bigr => i /negbTE; rewrite ffunE =>->.
  Qed.

  Lemma MP1_linear Idim Odim (p:MP1parameter S Idim Odim)
        (input1 input2:I ^ Idim) k:
    let input1' := [ffun i => if i == k then input2 i else input1 i] in
    let input2' := [ffun i => if i == k then input1 i else input2 i] in
    [ffun j => op (MP1 p input1 j) (MP1 p input2 j)]
    = [ffun j => op (MP1 p input1' j) (MP1 p input2' j)].
  Proof. apply /ffunP => j. rewrite !ffunE. exact : neuron1_linear. Qed.

End comoneuron1_lemma.

Module comidCneuron1.

  Record class_of (I O C:Type) :=
    Class {
        mono_class : mononeuron1.class_of I O C;
        como_mixin : comoneuron1.mixin_of (mononeuron1.Pack mono_class);
        idC_mixin : idCneuron1.mixin_of (mononeuron1.Pack mono_class)
      }.

  Definition como_class I O C m := comoneuron1.Class (@como_mixin I O C m).
  Definition idC_class I O C m := idCneuron1.Class (@idC_mixin I O C m).

  Section Packing.

    Record type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (mono_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition comoneuron1 := comoneuron1.Pack (como_class class).
    Definition idCneuron1 := idCneuron1.Pack (idC_class class).

  End Packing.

  Module Exports.

    Notation comidCneuron1Type := type.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion como_mixin : class_of >-> comoneuron1.mixin_of.
    Coercion idC_mixin : class_of >-> idCneuron1.mixin_of.
    Coercion como_class : class_of >-> comoneuron1.class_of.
    Coercion idC_class : class_of >-> idCneuron1.class_of.
    Coercion neuron1 : comidCneuron1Type >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : comidCneuron1Type >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion comoneuron1 : comidCneuron1Type >-> comoneuron1Type.
    Canonical comoneuron1.
    Coercion idCneuron1 : comidCneuron1Type >-> idCneuron1Type.
    Canonical idCneuron1.

  End Exports.
End comidCneuron1.
Export comidCneuron1.Exports.

Section comidCneuron1_lemma.

  Variable (S:comidCneuron1Type).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.
  Let idC := @NNidC S.
  Let parameter := @MP1parameter S.

  Lemma MP1_sum Idim1 Odim1 Idim2 Odim2
        (p1:parameter Idim1 Odim1) (p2:parameter Idim2 Odim2) input:
    MP1 (MP1parameter_sum p1 p2) input =
    index_app (MP1 p1 (index_projl input)) (MP1 p2 (index_projr input)).
  Proof.
    apply /ffunP => i. rewrite !ffunE /=.
    case : splitP => j Heq /=; rewrite !ffunE /=.
    - by rewrite -[p1.2 j]NNopo0 neuron1_sumI neuron1_idC !NNopo0.
    - by rewrite -[p2.2 j]NNop0o neuron1_sumI neuron1_idC !NNop0o.
  Qed.

End comidCneuron1_lemma.

(* ***************************** *)
Module NNet.

  Record mixin_of (S:neuron1Type) :=
    Mixin {activation : NNetO S -> NNetI S}.

  Section Packing.

    Structure class_of (I O C:Type) :=
      Class {
          neuron1_class: neuron1.class_of I O C;
          mixin: mixin_of (neuron1.Pack neuron1_class)
        }.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).

  End Packing.

  Module Exports.

    Notation NNetType := type.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mixin : class_of >-> mixin_of.
    Coercion neuron1 : NNetType >-> neuron1Type.
    Canonical neuron1.
    Definition NNactivation (S:NNetType) := activation (class S).
    Definition NNactf (S:NNetType) dim (f:NNetO S ^ dim)
      := finfun ((@NNactivation S) \o f).

  End Exports.
End NNet.
Export NNet.Exports.

Section NNet_lemma.

  Variable (S:NNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let actf := @NNactf S.
  Let parameter := MP1parameter S.

  Lemma actf_app dim dim' (f:O ^ dim) (f':O ^ dim'):
    NNactf (index_app f f') = index_app (NNactf f) (NNactf f').
  Proof. by rewrite /NNactf index_app_additive. Qed.

  Fixpoint MPparameter Idim l Odim : Type :=
    match l with
    | [::] => parameter Idim Odim
    | Hdim :: l' => parameter Idim Hdim * MPparameter Hdim l' Odim
    end.

  Fixpoint MPparameter_zero o0 c0 {Idim l Odim} : MPparameter Idim l Odim :=
    match l return MPparameter Idim l Odim with
    | [::] => MP1parameter_zero o0 c0 _ _
    | _ :: _ => (MP1parameter_zero o0 c0 _ _, MPparameter_zero o0 c0)
    end.

  Fixpoint MPfunction Idim l Odim :
    MPparameter Idim l Odim -> I ^ Idim -> O ^ Odim :=
    match l return MPparameter Idim l Odim -> I ^ Idim -> O ^ Odim with
    | [::] => fun p => MP1 p
    | Hdim :: l' => fun p => MPfunction p.2 \o @actf _ \o MP1 p.1
    end.

  Definition cast_MPparameter Idim1 l1 Odim1 Idim2 l2 Odim2
             (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2)
             (p:MPparameter Idim1 l1 Odim1) : MPparameter Idim2 l2 Odim2 :=
    ecast Odim2 _ eqOdim (ecast l2 _ eql (ecast Idim2 _ eqIdim p)).

  Lemma cast_MPparameter_id Idim l Odim eqIdim eql eqOdim
        (p:MPparameter Idim l Odim):
    cast_MPparameter eqIdim eql eqOdim p = p.
  Proof. by rewrite !eq_axiomK. Qed.

  Lemma cast_MPparameterK Idim1 l1 Odim1 Idim2 l2 Odim2
        (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2):
    cancel (cast_MPparameter eqIdim eql eqOdim)
           (cast_MPparameter (esym eqIdim) (esym eql) (esym eqOdim)).
  Proof. by case : Idim2 / eqIdim; case : l2 / eql; case : Odim2 / eqOdim. Qed.

  Lemma cast_MPparameterKV Idim1 l1 Odim1 Idim2 l2 Odim2
        (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2):
    cancel (cast_MPparameter (esym eqIdim) (esym eql) (esym eqOdim))
           (cast_MPparameter eqIdim eql eqOdim).
  Proof. by case : Idim2 / eqIdim; case : l2 / eql; case : Odim2 / eqOdim. Qed.

  Lemma cast_MPparameter_trans Idim1 l1 Odim1 Idim2 l2 Odim2 Idim3 l3 Odim3
        eqIdim12 eqIdim23 eql12 eql23 eqOdim12 eqOdim23
        (p:MPparameter Idim1 l1 Odim1):
    @cast_MPparameter _ _ _ Idim3 l3 Odim3 eqIdim23 eql23 eqOdim23
                      (@cast_MPparameter _ _ _ Idim2 l2 Odim2
                                         eqIdim12 eql12 eqOdim12 p)
    = cast_MPparameter (etrans eqIdim12 eqIdim23) (etrans eql12 eql23)
                       (etrans eqOdim12 eqOdim23) p.
  Proof.
      by case : Idim3 / eqIdim23; case : l3 / eql23;case : Odim3 / eqOdim23.
  Qed.

  Lemma cast_MPparameter_inj Idim1 l1 Odim1 Idim2 l2 Odim2
        (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2):
    injective (cast_MPparameter eqIdim eql eqOdim).
  Proof. exact : can_inj (cast_MPparameterK _ _ _). Qed.

  Fixpoint cast_MPparameter_ind Idim1 l1 Odim1 Idim2 l2 Odim2:
    MPparameter Idim1 l1 Odim1 -> MPparameter Idim2 l2 Odim2 -> Prop :=
    match l1,l2 return MPparameter Idim1 l1 Odim1 ->
                       MPparameter Idim2 l2 Odim2 -> Prop with
    | [::],[::] => fun p1 p2 => exists eqIdim eqOdim,
                       cast_MP1parameter eqIdim eqOdim p1 = p2
    | _ :: _,_ :: _ => fun p1 p2 => exists eqIdim eqHdim,
                           cast_MP1parameter eqIdim eqHdim p1.1 = p2.1 /\
                           cast_MPparameter_ind p1.2 p2.2
    | _,_ => fun _ _ => False
    end.

  Lemma cast_MPparameterP Idim1 l1 Odim1 Idim2 l2 Odim2 eqIdim eql eqOdim
        (p1:MPparameter Idim1 l1 Odim1) (p2:MPparameter Idim2 l2 Odim2):
    cast_MPparameter eqIdim eql eqOdim p1 = p2 <-> cast_MPparameter_ind p1 p2.
  Proof.
    split.
    - case : Idim2 / eqIdim p2; case : l2 / eql; case : Odim2 / eqOdim => p2.
      rewrite cast_MPparameter_id =><-{p2}.
      elim : l1 =>[|Hdim1 l1 IHl1] in Idim1 p1 *;
                    by exists (erefl _), (erefl _).
    - case : Idim2 / eqIdim p2; case : l2 / eql; case : Odim2 / eqOdim => p2.
      rewrite cast_MPparameter_id.
      elim : l1 =>[|Hdim1 l1 IHl] in Idim1 p1 p2 *.
      + move =>[eqIdim] [eqOdim] <-. by rewrite cast_MP1parameter_id.
      + move : p1 p2 => [p11 p12] [p21 p22] [eqIdim] [eqHdim] []/=<- /IHl <-.
          by rewrite cast_MP1parameter_id.
  Qed.

  Lemma MPfunction_cast Idim1 l1 Odim1 Idim2 l2 Odim2
        (eqIdim:Idim1 = Idim2) (eql:l1 = l2) (eqOdim:Odim1 = Odim2) p input:
    MPfunction (cast_MPparameter eqIdim eql eqOdim p)
               (cast_index eqIdim input) =
    cast_index eqOdim (MPfunction p input).
  Proof.
    case : Idim2 / eqIdim p; case : l2 / eql; case : Odim2 / eqOdim => p.
    by rewrite cast_MPparameter_id !cast_index_id.
  Qed.

  Fixpoint MPparameter_app Idim l1 Hdim l2 Odim :
    MPparameter Idim l1 Hdim -> MPparameter Hdim l2 Odim ->
    MPparameter Idim (l1 ++ Hdim :: l2) Odim :=
    match l1 return MPparameter Idim l1 Hdim ->
                    MPparameter Hdim l2 Odim ->
                    MPparameter Idim (l1 ++ Hdim :: l2) Odim with
    | [::] => fun p1 p2 => (p1, p2)
    | dim :: l1' => fun p1 p2 => (p1.1, (MPparameter_app p1.2 p2))
    end.

  Lemma MPparameter_appA Idim l1 Hdim1 l2 Hdim2 l3 Odim
        (p1:MPparameter Idim l1 Hdim1)
        (p2:MPparameter Hdim1 l2 Hdim2)
        (p3:MPparameter Hdim2 l3 Odim) :
    MPparameter_app p1 (MPparameter_app p2 p3) =
    cast_MPparameter (erefl _) (esym (catA _ _ _)) (erefl _)
                     (MPparameter_app (MPparameter_app p1 p2) p3).
  Proof.
    symmetry. apply /cast_MPparameterP.
    elim : l1 =>[|dim l1' IHl1]/= in Idim p1 *; exists (erefl _), (erefl _);
    split=>//. exact /cast_MPparameterP.
  Qed.

  Lemma MPfunction_app Idim l1 Hdim l2 Odim
        (p1:MPparameter Idim l1 Hdim) (p2:MPparameter Hdim l2 Odim) :
    MPfunction (MPparameter_app p1 p2)
    =1 MPfunction p2 \o @actf _ \o MPfunction p1.
  Proof.
    elim : l1 =>[|dim l1' IHl1] in Idim p1 *=> input //=. by rewrite IHl1.
  Qed.

  Fixpoint MPparameter_rcons Idim l Hdim Odim :
    MPparameter Idim l Hdim -> parameter Hdim Odim ->
    MPparameter Idim (rcons l Hdim) Odim :=
    match l return MPparameter Idim l Hdim ->
                   parameter Hdim Odim ->
                   MPparameter Idim (rcons l Hdim) Odim with
    | [::] => fun p1 p2 => (p1,p2)
    | x :: l' => fun p1 p2 => (p1.1,MPparameter_rcons p1.2 p2)
    end.

  Fixpoint MPparameter_last Idim l Hdim Odim :
    MPparameter Idim (rcons l Hdim) Odim -> parameter Hdim Odim :=
    match l return MPparameter Idim (rcons l Hdim) Odim ->
                   parameter Hdim Odim with
    | [::] => fun p => p.2
    | a :: l' => fun p => MPparameter_last p.2
    end.

  Fixpoint MPparameter_belast Idim l Hdim Odim :
    MPparameter Idim (rcons l Hdim) Odim -> MPparameter Idim l Hdim :=
    match l return MPparameter Idim (rcons l Hdim) Odim ->
                   MPparameter Idim l Hdim with
    | [::] => fun p => p.1
    | a :: l' => fun p => (p.1,MPparameter_belast p.2)
    end.

  Lemma MPparameter_last_rcons Idim l Hdim Odim
        (p1:MPparameter Idim l Hdim) (p2:parameter Hdim Odim):
    MPparameter_last (MPparameter_rcons p1 p2) = p2.
  Proof. by elim : l =>[|a l IHl] in Idim p1 p2 *=>//=. Qed.

  Lemma MPparameter_belast_rcons Idim l Hdim Odim
        (p1:MPparameter Idim l Hdim) (p2:parameter Hdim Odim):
    MPparameter_belast (MPparameter_rcons p1 p2) = p1.
  Proof.
    elim : l =>[|a l IHl] in Idim p1 p2 *=>//=. rewrite IHl. by case : p1.
  Qed.

  Lemma MPfunction_rcons Idim l Hdim Odim
        (p:MPparameter Idim (rcons l Hdim) Odim) :
    MPfunction p
    =1 MP1 (MPparameter_last p) \o @actf _ \o
       MPfunction (MPparameter_belast p).
  Proof.
    elim : l =>[|l dim IHl] in Idim p *=> input //=. by rewrite IHl /=.
  Qed.

  Lemma MPfunction_in0 Idim l Odim (p:MPparameter Idim l Odim):
    0 \in l -> exists y, MPfunction p =1 (fun => y).
  Proof.
    move => H.
    elim /last_ind : l H Odim p =>[|l Hdim IHl]//=.
    rewrite mem_rcons => /orP [/eqP<-|/IHl H] Odim p.
    - exists (MPparameter_last p).2 => input.
        by rewrite MPfunction_rcons /= MP1_Idim0.
    - case : (H _ (MPparameter_belast p)) => y0 Hy0.
      exists (MP1 (MPparameter_last p) (actf y0)) => input.
        by rewrite MPfunction_rcons /= Hy0.
  Qed.

End NNet_lemma.

(* ***************************** *)
Module monoNNet.

    Record class_of (I O C:Type) : Type :=
      Class {
          neuron1_class : neuron1.class_of I O C;
          mono_mixin : mononeuron1.mixin_of (neuron1.Pack neuron1_class);
          NNet_mixin : NNet.mixin_of (neuron1.Pack neuron1_class)
        }.

    Definition mono_class I O C m := mononeuron1.Class (@mono_mixin I O C m).
    Definition NNet_class I O C m := NNet.Class (@NNet_mixin I O C m).

  Section Packing.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition NNet := NNet.Pack (NNet_class class).

  End Packing.

  Module Exports.

    Notation monoNNetType := type.
    Coercion mono_mixin : class_of >-> mononeuron1.mixin_of.
    Coercion NNet_mixin : class_of >-> NNet.mixin_of.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion NNet_class : class_of >-> NNet.class_of.
    Coercion neuron1 : monoNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : monoNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion NNet : monoNNetType >-> NNetType.
    Canonical NNet.

  End Exports.
End monoNNet.
Export monoNNet.Exports.

Section monoNNet_lemma.

  Variable (S:monoNNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.
  Let parameter := MP1parameter S.
  Let MPparameter := MPparameter S.

End monoNNet_lemma.

(* ***************************** *)
Module idCNNet.

  Record class_of (I O C:Type) :=
    Class {
        neuron1_class : neuron1.class_of I O C;
        mono_mixin : mononeuron1.mixin_of (neuron1.Pack neuron1_class);
        idC_mixin : idCneuron1.mixin_of
                      (mononeuron1.Pack (mononeuron1.Class mono_mixin));
        NNet_mixin : NNet.mixin_of (neuron1.Pack neuron1_class)
      }.

  Definition mono_class I O C m := mononeuron1.Class (@mono_mixin I O C m).
  Definition idC_class I O C m := idCneuron1.Class (@idC_mixin I O C m).
  Definition NNet_class I O C m := NNet.Class (@NNet_mixin I O C m).
  Definition monoNNet_class I O C m :=
    monoNNet.Class (@mono_class I O C m) (NNet_class m).

  Section Packing.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition idCneuron1 := idCneuron1.Pack (idC_class class).
    Definition NNet := NNet.Pack (NNet_class class).
    Definition monoNNet := monoNNet.Pack (monoNNet_class class).

  End Packing.

  Module Exports.

    Notation idCNNetType := type.
    Coercion mono_mixin : class_of >-> mononeuron1.mixin_of.
    Coercion idC_mixin : class_of >-> idCneuron1.mixin_of.
    Coercion NNet_mixin : class_of >-> NNet.mixin_of.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion idC_class : class_of >-> idCneuron1.class_of.
    Coercion NNet_class : class_of >-> NNet.class_of.
    Coercion monoNNet_class : class_of >-> monoNNet.class_of.
    Coercion neuron1 : idCNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : idCNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion idCneuron1 : idCNNetType >-> idCneuron1Type.
    Canonical idCneuron1.
    Coercion NNet : idCNNetType >-> NNetType.
    Canonical NNet.
    Coercion monoNNet : idCNNetType >-> monoNNetType.
    Canonical monoNNet.

  End Exports.
End idCNNet.
Export idCNNet.Exports.

Section idCNNet_lemma.

  Variable (S:idCNNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let action := @NNaction S.
  Let op := @NNop S.
  Let id := @NNid S.
  Let idC := @NNidC S.
  Let parameter := MP1parameter S.
  Let MPparameter := MPparameter S.

  Definition MPparameter0 := @MPparameter_zero S id idC.

  Fixpoint MPparameter_sum Idim1 l1 Odim1 Idim2 l2 Odim2 :
           MPparameter Idim1 l1 Odim1 ->
           MPparameter Idim2 l2 Odim2 ->
           MPparameter (Idim1 + Idim2) (l1 +l l2) (Odim1 + Odim2) :=
    match l1, l2 return
          MPparameter Idim1 l1 Odim1 ->
          MPparameter Idim2 l2 Odim2 ->
          MPparameter (Idim1 + Idim2) (l1 +l l2) (Odim1 + Odim2) with
    | [::],[::] => fun p1 p2 => MP1parameter_sum p1 p2
    | [::],_ => fun p1 _ => MP1parameter_sum p1 (MP1parameter0 _ _ _)
    | _,[::] => fun _ p2 => MP1parameter_sum (MP1parameter0 _ _ _) p2
    | _ :: _,_ :: _ => fun p1 p2 =>
                         (MP1parameter_sum p1.1 p2.1, MPparameter_sum p1.2 p2.2)
    end.

  Lemma MPparameter_sumA Idim1 l1 Odim1 Idim2 l2 Odim2 Idim3 l3 Odim3
        (p1:MPparameter Idim1 l1 Odim1) (p2:MPparameter Idim2 l2 Odim2)
        (p3:MPparameter Idim3 l3 Odim3):
    MPparameter_sum p1 (MPparameter_sum p2 p3) =
    cast_MPparameter (esym (addnA _ _ _))
                     (esym (seqopA addnA _ _ _))
                     (esym (addnA _ _ _))
                     (MPparameter_sum (MPparameter_sum p1 p2) p3).
  Proof.
    elim : l1 =>[|Hdim1 l1 IHl1] in Idim1 p1 Idim2 l2 p2 Idim3 l3 p3 *;
      case : l2 =>[|Hdim2 l2] in Idim2 p2 Idim3 l3 p3 *;
      case : l3 =>[|Hdim3 l3] in Idim3 p3 *;
      symmetry; apply /cast_MPparameterP;
      exists (esym (addnA _ _ _)), (esym (addnA _ _ _))=>/=;
      rewrite -?MP1parameter_sum0 -MP1parameter_sumA =>//.
    split=>//.
    apply /(cast_MPparameterP (esym (addnA _ _ _)) (esym (seqopA addnA _ _ _))
                              (esym (addnA _ _ _))).
    symmetry. exact : IHl1.
  Qed.

End idCNNet_lemma.

Module comoNNet.

  Record class_of (I O C:Type) :=
    Class {
        neuron1_class : neuron1.class_of I O C;
        mono_mixin : mononeuron1.mixin_of (neuron1.Pack neuron1_class);
        como_mixin : comoneuron1.mixin_of
                       (mononeuron1.Pack (mononeuron1.Class mono_mixin));
        NNet_mixin : NNet.mixin_of (neuron1.Pack neuron1_class)
      }.

  Definition mono_class I O C m := mononeuron1.Class (@mono_mixin I O C m).
  Definition como_class I O C m := comoneuron1.Class (@como_mixin I O C m).
  Definition NNet_class I O C m := NNet.Class (@NNet_mixin I O C m).
  Definition monoNNet_class I O C m :=
    monoNNet.Class (@mono_class I O C m) (NNet_class m).

  Section Packing.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition comoneuron1 := comoneuron1.Pack (como_class class).
    Definition NNet := NNet.Pack (NNet_class class).
    Definition monoNNet := monoNNet.Pack (monoNNet_class class).

  End Packing.

  Module Exports.

    Notation comoNNetType := type.
    Coercion mono_mixin : class_of >-> mononeuron1.mixin_of.
    Coercion como_mixin : class_of >-> comoneuron1.mixin_of.
    Coercion NNet_mixin : class_of >-> NNet.mixin_of.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion como_class : class_of >-> comoneuron1.class_of.
    Coercion NNet_class : class_of >-> NNet.class_of.
    Coercion monoNNet_class : class_of >-> monoNNet.class_of.
    Coercion neuron1 : comoNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : comoNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion comoneuron1 : comoNNetType >-> comoneuron1Type.
    Canonical comoneuron1.
    Coercion NNet : comoNNetType >-> NNetType.
    Canonical NNet.
    Coercion monoNNet : comoNNetType >-> monoNNetType.
    Canonical monoNNet.

  End Exports.
End comoNNet.
Export comoNNet.Exports.

Section comoNNet_lemma.
End comoNNet_lemma.

(* ***************************** *)
Module comidCNNet.

  Record class_of (I O C:Type) :=
    Class {
        neuron1_class : neuron1.class_of I O C;
        mono_mixin : mononeuron1.mixin_of (neuron1.Pack neuron1_class);
        como_mixin : comoneuron1.mixin_of
                       (mononeuron1.Pack (mononeuron1.Class mono_mixin));
        idC_mixin : idCneuron1.mixin_of
                      (mononeuron1.Pack (mononeuron1.Class mono_mixin));
        NNet_mixin : NNet.mixin_of (neuron1.Pack neuron1_class)
      }.

  Definition mono_class I O C m := mononeuron1.Class (@mono_mixin I O C m).
  Definition como_class I O C m := comoneuron1.Class (@como_mixin I O C m).
  Definition idC_class I O C m := idCneuron1.Class (@idC_mixin I O C m).
  Definition comidC_class I O C m :=
    comidCneuron1.Class (@como_class I O C m) (idC_class m).
  Definition NNet_class I O C m := NNet.Class (@NNet_mixin I O C m).
  Definition monoNNet_class I O C m :=
    monoNNet.Class (@mono_class I O C m) (NNet_class m).
  Definition comoNNet_class I O C m :=
    comoNNet.Class (@como_class I O C m) (NNet_class m).
  Definition idCNNet_class I O C m :=
    idCNNet.Class  (@idC_class I O C m) (NNet_class m).

  Section Packing.

    Structure type := Pack {NNetI; NNetO; NNetC; _:class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return class_of (NNetI cT) (NNetO cT) (NNetC cT)
      in c.
    Definition neuron1 := neuron1.Pack (neuron1_class class).
    Definition mononeuron1 := mononeuron1.Pack (mono_class class).
    Definition comoneuron1 := comoneuron1.Pack (como_class class).
    Definition idCneuron1 := idCneuron1.Pack (idC_class class).
    Definition comidCneuron1 := comidCneuron1.Pack (comidC_class class).
    Definition NNet := NNet.Pack (NNet_class class).
    Definition monoNNet := monoNNet.Pack (monoNNet_class class).
    Definition comoNNet := comoNNet.Pack (comoNNet_class class).
    Definition idCNNet := idCNNet.Pack (idCNNet_class class).

  End Packing.

  Module Exports.

    Notation comidCNNetType := type.
    Coercion mono_mixin : class_of >-> mononeuron1.mixin_of.
    Coercion como_mixin : class_of >-> comoneuron1.mixin_of.
    Coercion idC_mixin : class_of >-> idCneuron1.mixin_of.
    Coercion NNet_mixin : class_of >-> NNet.mixin_of.
    Coercion neuron1_class : class_of >-> neuron1.class_of.
    Coercion mono_class : class_of >-> mononeuron1.class_of.
    Coercion como_class : class_of >-> comoneuron1.class_of.
    Coercion idC_class : class_of >-> idCneuron1.class_of.
    Coercion comidC_class : class_of >-> comidCneuron1.class_of.
    Coercion NNet_class : class_of >-> NNet.class_of.
    Coercion monoNNet_class : class_of >-> monoNNet.class_of.
    Coercion comoNNet_class : class_of >-> comoNNet.class_of.
    Coercion idCNNet_class : class_of >-> idCNNet.class_of.
    Coercion neuron1 : comidCNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : comidCNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion comoneuron1 : comidCNNetType >-> comoneuron1Type.
    Canonical comoneuron1.
    Coercion idCneuron1 : comidCNNetType >-> idCneuron1Type.
    Canonical idCneuron1.
    Coercion comidCneuron1 : comidCNNetType >-> comidCneuron1Type.
    Canonical comidCneuron1.
    Coercion NNet : comidCNNetType >-> NNetType.
    Canonical NNet.
    Coercion monoNNet : comidCNNetType >-> monoNNetType.
    Canonical monoNNet.
    Coercion comoNNet : comidCNNetType >-> comoNNetType.
    Canonical comoNNet.
    Coercion idCNNet : comidCNNetType >-> idCNNetType.
    Canonical idCNNet.

  End Exports.
End comidCNNet.
Export comidCNNet.Exports.

Section comidCNNet_lemma.

  Variable (S:comidCNNetType).
  Let I := NNetI S.
  Let O := NNetO S.
  Let C := NNetC S.
  Let op := @NNop S.
  Let action := @NNaction S.
  Let id := @NNid S.
  Let idC := @NNidC S.
  Let actf := @NNactf S.
  Let parameter := MP1parameter S.
  Let MPparameter := MPparameter S.

  Lemma MPfunction_sum Idim1 l1 Odim1 Idim2 l2 Odim2
        (p1:MPparameter Idim1 l1 Odim1) (p2:MPparameter Idim2 l2 Odim2) input:
    size l1 = size l2 ->
    MPfunction (MPparameter_sum p1 p2) input =
    index_app (MPfunction p1 (index_projl input))
              (MPfunction p2 (index_projr input)).
  Proof.
    elim : l1 l2 =>[|Hdim1 l1 IHl1][|Hdim2 l2]//= in Idim1 p1 Idim2 p2 input *;
      rewrite MP1_sum =>//[][] /IHl1 =>->.
      by rewrite !actf_app index_projl_app index_projr_app.
  Qed.

End comidCNNet_lemma.

(* ***************************** *)
Module eqneuron1.

  Section Packing.

    Record type := Pack {NNetI:eqType; NNetO; NNetC;
                         neuron1_class : neuron1.class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition neuron1 := neuron1.Pack (neuron1_class cT).

  End Packing.

  Module Exports.

    Notation eqneuron1Type := type.
    Coercion NNetI : eqneuron1Type >-> eqType.
    Coercion neuron1_class : eqneuron1Type >-> neuron1.class_of.
    Coercion neuron1 : eqneuron1Type >-> neuron1Type.
    Canonical neuron1.

  End Exports.
End eqneuron1.
Export eqneuron1.Exports.

Section eqneuron1_lemma.

  Variable (V:eqneuron1Type).
  Let I := NNetI V.
  Let O := NNetO V.
  Let C := NNetC V.
  Let action := @NNaction V.
  Let op := @NNop V.

End eqneuron1_lemma.

(* ***************************** *)
Module eqcomoNNet.

  Section Packing.

    Structure type := Pack {NNetI:eqType; NNetO; NNetC;
                            comNNet_class :comoNNet.class_of NNetI NNetO NNetC}.
    Variable (cT:type).
    Definition class :=
      let: Pack _ _ _ c := cT
                           return comoNNet.class_of
                                    (NNetI cT) (NNetO cT) (NNetC cT) in c.
    Definition neuron1 := neuron1.Pack class.
    Definition mononeuron1 := mononeuron1.Pack class.
    Definition comoneuron1 := comoneuron1.Pack class.
    Definition NNet := NNet.Pack class.
    Definition monoNNet := monoNNet.Pack class.
    Definition comoNNet := comoNNet.Pack class.
    Definition eqneuron1 := eqneuron1.Pack class.

  End Packing.

  Module Exports.

    Notation eqcomoNNetType := type.
    Coercion NNetI : eqcomoNNetType >-> eqType.
    Coercion neuron1 : eqcomoNNetType >-> neuron1Type.
    Canonical neuron1.
    Coercion mononeuron1 : eqcomoNNetType >-> mononeuron1Type.
    Canonical mononeuron1.
    Coercion comoneuron1 : eqcomoNNetType >-> comoneuron1Type.
    Canonical comoneuron1.
    Coercion NNet : eqcomoNNetType >-> NNetType.
    Canonical NNet.
    Coercion monoNNet : eqcomoNNetType >-> monoNNetType.
    Canonical monoNNet.
    Coercion comoNNet : eqcomoNNetType >-> comoNNetType.
    Canonical comoNNet.
    Coercion eqneuron1 : eqcomoNNetType >-> eqneuron1Type.
    Canonical eqneuron1.

  End Exports.
End eqcomoNNet.
Export eqcomoNNet.Exports.

Section eqcomoNNet_lemma.

  Variable (V:eqcomoNNetType).
  Let I := NNetI V.
  Let O := NNetO V.
  Let C := NNetC V.
  Let action := @NNaction V.
  Let op := @NNop V.
  Let id := @NNid V.
  Let actf := @NNactf V.

End eqcomoNNet_lemma.

End NNetDef.

Export neuron1.Exports mononeuron1.Exports comoneuron1.Exports
       idCneuron1.Exports comidCneuron1.Exports NNet.Exports monoNNet.Exports
       comoNNet.Exports idCNNet.Exports comidCNNet.Exports
       eqneuron1.Exports eqcomoNNet.Exports.


From Equations Require Import Equations.
Require Import Coq.Classes.RelationClasses.

Require Import Psatz.

Require Export SystemFR.SizeLemmas.
Require Export SystemFR.NoTypeFVar.

Equations strictly_positive (T: tree) (vars: list nat): Prop
    by wf (type_nodes T) lt :=
  strictly_positive (fvar _ type_var) _ := True;
  strictly_positive (lvar _ _) _ := True;

  strictly_positive T_unit _ := True;
  strictly_positive T_bool _ := True;
  strictly_positive T_nat _ := True;
  strictly_positive T_top _ := True;
  strictly_positive T_bot _ := True;

  strictly_positive (T_equiv _ _) _ := True;

  strictly_positive (T_prod T1 T2) vars := strictly_positive T1 vars /\ strictly_positive T2 vars;
  strictly_positive (T_arrow T1 T2) vars := no_type_fvar T1 vars /\ strictly_positive T2 vars;
  strictly_positive (T_forall T1 T2) vars := no_type_fvar T1 vars /\ strictly_positive T2 vars;
  strictly_positive (T_sum T1 T2) vars := strictly_positive T1 vars /\ strictly_positive T2 vars;
  strictly_positive (T_refine T p) vars := strictly_positive T vars;
  strictly_positive (T_type_refine T1 T2) vars := no_type_fvar T1 vars /\ no_type_fvar T2 vars;
  strictly_positive (T_intersection T1 T2) _ :=
    strictly_positive T1 vars /\ strictly_positive T2 vars;

  (* could be relaxed *)
  strictly_positive (T_union T1 T2) vars :=
    no_type_fvar T1 vars /\ no_type_fvar T2 vars;
  strictly_positive (T_exists T1 T2) vars := no_type_fvar T1 vars /\ no_type_fvar T2 vars;

  strictly_positive (T_abs T) vars := strictly_positive T vars;
  strictly_positive (T_rec n T0 Ts) vars :=
    strictly_positive T0 vars /\ strictly_positive Ts vars /\ (
      (no_type_fvar T0 vars /\ no_type_fvar Ts vars) \/
      exists X,
        ~(X ∈ pfv Ts type_var) /\
        strictly_positive (topen 0 Ts (fvar X type_var)) (X :: nil)
    );

  strictly_positive _ vars := False.

Solve All Obligations with (repeat step || autorewrite with bsize in *; try lia; eauto with lia).

Fail Next Obligation.

(* see https://github.com/coq/coq/issues/3814 *)
#[export]
Instance: subrelation eq Basics.impl.
Proof.
  steps.
Qed.

#[export]
Instance: subrelation eq (Basics.flip Basics.impl).
Proof.
  steps.
Qed.

Ltac simp_spos_hyp :=
  match goal with
  | H: _ |- _ => rewrite_strat topdown hints strictly_positive in H
  end.

Ltac simp_spos_goal := rewrite_strat topdown hints strictly_positive.

Ltac simp_spos := simp_spos_hyp || simp_spos_goal.


Require Import SfLib.
Require Import util.
Require Import STLC_types.
Require Import STLC_terms.

Reserved Notation "t1 '==>' t2" (at level 40).
(* Note: Induction should be fine here. No descent into the list of a literal
   is required. *)
Inductive step : term -> term -> Prop :=
| ST_AppLambda : forall x T t12 v2,
                   value v2 -> (TApp (TLambda x T t12) v2) ==> [x := v2]t12
| ST_App1 : forall t1 t1' t2, t1 ==> t1' -> TApp t1 t2 ==> TApp t1' t2
| ST_App2 : forall v1 t2 t2', value v1 -> t2 ==> t2' -> TApp v1 t2 ==> TApp v1 t2'
| ST_IfTrue : forall t1 t2, TIf TTrue t1 t2 ==> t1
| ST_IfFalse : forall t1 t2, TIf TFalse t1 t2 ==> t2
| ST_If : forall t1 t1' t2 t3, t1 ==> t1' -> TIf t1 t2 t3 ==> TIf t1' t2 t3
| ST_Plus : forall n m, TPlus (TNum n) (TNum m) ==> TNum (n + m)
| ST_PlusL : forall l l' r, l ==> l' -> TPlus l r ==> TPlus l' r
| ST_PlusR : forall l r r', value l -> r ==> r' -> TPlus l r ==> TPlus l r'
| ST_EqNatT : forall n m, beq_nat n m = true ->
                          TEqNat (TNum n) (TNum m) ==> TTrue
| ST_EqNatF : forall n m, beq_nat n m = false ->
                          TEqNat (TNum n) (TNum m) ==> TFalse
| ST_EqNatL : forall l l' r, l ==> l' -> TEqNat l r ==> TEqNat l' r
| ST_EqNatR : forall l r r', value l -> r ==> r' -> TEqNat l r ==> TEqNat l r'
| ST_Literal : forall li lv ri rv i v v', value (TLiteral li lv) ->
                                               length li = length lv ->
                                               v ==> v' ->
                                               TLiteral (li ++ (i :: ri))
                                                        (lv ++ (v :: rv)) ==>
                                                 TLiteral (li ++ (i :: ri))
                                                          (lv ++ (v' :: rv))
| ST_Access : forall li lv i v, value (TLiteral li lv) ->
                                  lookup i li lv = Some v ->
                                  TAccess (TLiteral li lv) i ==> v
| ST_AccessS : forall r r' i, r ==> r' -> TAccess r i ==> TAccess r' i
    where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppLambda" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2"      | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse"   | Case_aux c "ST_If"
  | Case_aux c "ST_Plus"      | Case_aux c "ST_PlusL"
  | Case_aux c "ST_PlusR"     | Case_aux c "ST_EqNatT"
  | Case_aux c "ST_EqNatF"    | Case_aux c "ST_EqNatL"
  | Case_aux c "ST_EqNatR"    | Case_aux c "ST_Literal"
  | Case_aux c "ST_Access"    | Case_aux c "ST_AccessS"].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Lemma values_no_step : forall (t : term), value t -> ((exists t', t ==> t') -> False).
Proof with auto.
  intros t HValue HStep.
  value_cases (induction HValue) Case; try (inversion HStep as [t' HStep']; inversion HStep'; subst)...
  Case "v_literal".
    apply Forall_app in H.
    inversion H. inversion H1; subst.
    apply H7. exists v'...
Qed.

Theorem step_determinism : forall (t t'1 t'2 : term),
  t ==> t'1 -> t ==> t'2 -> t'1 = t'2.
Proof with eauto.
  intros. generalize dependent t'1. generalize dependent t'2.
  term_cases (induction t) Case; intros; try solve by inversion.
  Case "TApp".
    inversion H; inversion H0; subst; try solve by inversion...
    SCase "steps with ST_AppLambda".
      inversion H5; subst...
    SCase "t2 is a value but steps".
      apply values_no_step in H4. inversion H4. exists t2'...
    SCase "t1 steps".
      assert (t1' = t1'0). apply IHt1...
      subst...
    SCase "t1 steps and is a value".
      apply values_no_step in H7. inversion H7. exists t1'...
    SCase "t2 steps and is a value".
      apply values_no_step in H9. inversion H9. exists t2'...
    SCase "t1 is a value but steps".
      apply values_no_step in H3. inversion H3. exists t1'...
    SCase "t2 steps".
      assert (t2' = t2'0). apply IHt2...
      subst...
  Case "TIf".
    inversion H; inversion H0; subst; try solve by inversion...
    assert (t1' = t1'0). apply IHt1...
    subst...
  Case "TPlus".
    inversion H; inversion H0; subst; try solve by inversion...
    SCase "t1 and t2 are numbers".
      inversion H5; inversion H6; subst...
    SCase "t1 steps".
      assert (l' = l'0). apply IHt1...
      subst...
    SCase "t1 steps and is a value".
      apply values_no_step in H7. inversion H7... exists l'...
    SCase "t1 is a value and steps".
      apply values_no_step in H3. inversion H3... exists l'...
    SCase "t2 steps".
      assert (r' = r'0). apply IHt2...
      subst...
  Case "TEqNat".
    inversion H; inversion H0; subst; try solve by inversion...
    SCase "t1 and t2 are numbers; true/false".
      inversion H7; inversion H5; subst.
      rewrite -> H8 in H4.
      inversion H4.
    SCase "t1 and t2 are numbers; false/true".
      inversion H7; inversion H5; subst.
      rewrite -> H8 in H4.
      inversion H4.
    SCase "t1 steps".
      assert (l' = l'0). apply IHt1...
      subst...
    SCase "t1 steps and is a value".
      apply values_no_step in H7. inversion H7. exists l'...
    SCase "t1 is a value and steps".
      apply values_no_step in H3. inversion H3. exists l'...
    SCase "t2 steps".
      assert (r' = r'0). apply IHt2...
      subst...
  Case "TLiteral".
    inversion H0; inversion H1; subst... clear H0 H1.
    inversion H4; inversion H10; subst.
    apply append_length in H8; inversion H8; clear H8; subst...
    inversion H2; subst; clear H2.
    Focus 2.
    apply append_length in H9; inversion H9; subst...
    apply append_length in H8; inversion H8; subst...
    inversion H2; subst.
    assert (v' = v'0). apply Forall_app in H; inversion H.
      inversion H12; subst.
      apply H16...
    subst.
    inversion H3; subst...
inversion H8; subst...
inversion H9. inversion H12; subst...

 clear H9... subst. apply append_length in H8...
    assert (lv1 = lv0).
    admit.
  Case "TAccess".
    inversion H; inversion H0; subst... clear H H0.
    SCase "literal is a value".
      inversion H6; subst.
      rewrite -> H5 in H10.
      inversion H10...
    SCase "literal is a value but steps".
      apply values_no_step in H3. inversion H3. exists r'...
    SCase "literal is a value but steps".
      apply values_no_step in H7. inversion H7. exists r'...
    SCase "literal steps".
      assert (r' = r'0). apply IHt...
      subst...

Admitted.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the dynamic semantics of heap objects, pg. 60.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export DynamicSemanticsHeapObjects.
Require Export Tacticals.

Require Export TestUtilities.

Example test_get_pdot : get vi0 [] vi0.
Proof.
  apply get_pdot; Crunch.
Qed.

Example test_get_l: get (cpair vi0 vi1) [i_pe zero_pe] vi0.
Proof.
  apply get_l;
  eauto 20 with Chapter3.
Qed.

Example test_get_r:
  get (cpair vi0 vi1) [i_pe one_pe] vi1.
Proof.
  apply get_r;
  eauto 20 with Chapter3.
Qed.

Example test_get_pack:
  get (pack
         (cross cint cint)
         (i_e (i_i 0))
         (etype aliases alpha A cint))
      [u_pe]
      (i_e (i_i 0)).
Proof.
  apply get_pack;
  eauto 20 with Chapter3.
Qed.

Example test_set_ip: set vi0 [] vi1 vi1.
Proof.
  apply set_ip;
  eauto 20 with Chapter3.
Qed.

Example test_set_l:
  set (cpair (i_e (i_i 0)) (i_e (i_i 1)))
      ([i_pe zero_pe] ++ [])
      (i_e (i_i 2))
      (cpair (i_e (i_i 2)) (i_e (i_i 1))).
Proof.
  apply set_l;
  eauto 20 with Chapter3.
Qed.

Example test_set_r:
  set (cpair (i_e (i_i 0)) (i_e (i_i 1)))
      ([i_pe one_pe] ++ [])
      (i_e (i_i 2))
      (cpair (i_e (i_i 0)) (i_e (i_i 2))).
Proof.
  apply set_r;
  eauto 20 with Chapter3.
Qed.

Example test_set_pack:
  set (pack tau' v1 (etype q alpha k tau))
      (u_pe :: p0) v (pack tau' v' (etype q alpha k tau)).
Proof.
  apply set_pack;
  eauto 20 with Chapter3.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.

(* Why3 goal *)
Definition div: Z -> Z -> Z.
intros x y.
case (Z_le_dec 0 (Zmod x y)) ; intros H.
exact (Zdiv x y).
exact (Zdiv x y + 1)%Z.
Defined.

(* Why3 goal *)
Definition mod1: Z -> Z -> Z.
intros x y.
exact (x - y * div x y)%Z.
Defined.

(* Why3 goal *)
Lemma Div_mod : forall (x:Z) (y:Z), (~ (y = 0%Z)) -> (x = ((y * (div x
  y))%Z + (mod1 x y))%Z).
intros x y Zy.
unfold mod1, div.
case Z_le_dec ; intros H ; ring.
Qed.

(* Why3 goal *)
Lemma Div_bound : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  ((0%Z <= (div x y))%Z /\ ((div x y) <= x)%Z).
intros x y (Hx,Hy).
unfold div.
case Z_le_dec ; intros H.
split.
apply Z_div_pos with (2 := Hx).
now apply Zlt_gt.
destruct (Z_eq_dec y 1) as [H'|H'].
rewrite H', Zdiv_1_r.
apply Zle_refl.
rewrite <- (Zdiv_1_r x) at 2.
apply Zdiv_le_compat_l with (1 := Hx).
omega.
elim H.
apply Z_mod_lt.
now apply Zlt_gt.
Qed.

(* Why3 goal *)
Lemma Mod_bound : forall (x:Z) (y:Z), (~ (y = 0%Z)) -> ((0%Z <= (mod1 x
  y))%Z /\ ((mod1 x y) < (ZArith.BinInt.Z.abs y))%Z).
intros x y Zy.
zify.
assert (H1 := Z_mod_neg x y).
assert (H2 := Z_mod_lt x y).
unfold mod1, div.
case Z_le_dec ; intros H0.
rewrite Zmult_comm, <- Zmod_eq_full with (1 := Zy).
omega.
replace (x - y * (x / y + 1))%Z with (x - x / y * y - y)%Z by ring.
rewrite <- Zmod_eq_full with (1 := Zy).
omega.
Qed.

(* Why3 goal *)
Lemma Mod_1 : forall (x:Z), ((mod1 x 1%Z) = 0%Z).
intros x.
unfold mod1, div.
rewrite Zmod_1_r, Zdiv_1_r, Zmult_1_l.
apply Zminus_diag.
Qed.

(* Why3 goal *)
Lemma Div_1 : forall (x:Z), ((div x 1%Z) = x).
intros x.
unfold div.
now rewrite Zmod_1_r, Zdiv_1_r.
Qed.

(* Why3 goal *)
Lemma Div_inf : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (x < y)%Z) -> ((div x
  y) = 0%Z).
intros x y Hxy.
unfold div.
case Z_le_dec ; intros H.
now apply Zdiv_small.
elim H.
now rewrite Zmod_small.
Qed.

(* Why3 goal *)
Lemma Div_inf_neg : forall (x:Z) (y:Z), ((0%Z < x)%Z /\ (x <= y)%Z) ->
  ((div (-x)%Z y) = (-1%Z)%Z).
intros x y Hxy.
assert (h: (x < y \/ x = y)%Z) by omega.
destruct h.
(* case 0 < x < y *)
assert (h1: (x mod y = x)%Z).
  rewrite Zmod_small; auto with zarith.
assert (h2: ((-x) mod y = y - x)%Z).
  rewrite Z_mod_nz_opp_full.
  rewrite h1; auto.
rewrite h1; auto with zarith.
unfold div.
case Z_le_dec; auto with zarith.
intros h3.
rewrite Z_div_nz_opp_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.

(* case x = y *)
subst.
assert (h1: (y mod y = 0)%Z).
  rewrite Z_mod_same_full; auto with zarith.
assert (h2: ((-y) mod y = 0)%Z).
  rewrite Z_mod_zero_opp_full; auto with zarith.
unfold div.
case Z_le_dec; rewrite h2; auto with zarith.
intro.
rewrite Z_div_zero_opp_full; auto with zarith.
rewrite Z_div_same_full; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_0 : forall (y:Z), (~ (y = 0%Z)) -> ((mod1 0%Z y) = 0%Z).
intros y Hy.
unfold mod1, div.
rewrite Zmod_0_l.
simpl.
now rewrite Zdiv_0_l, Zmult_0_r.
Qed.

(* Why3 goal *)
Lemma Div_1_left : forall (y:Z), (1%Z < y)%Z -> ((div 1%Z y) = 0%Z).
intros y Hy.
rewrite Div_inf; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Div_minus1_left : forall (y:Z), (1%Z < y)%Z -> ((div (-1%Z)%Z
  y) = (-1%Z)%Z).
intros y Hy.
unfold div.
assert (h1: (1 mod y = 1)%Z).
apply Zmod_1_l; auto.
assert (h2: ((-(1)) mod y = y-1)%Z).
  rewrite Z_mod_nz_opp_full; auto with zarith.
case Z_le_dec; auto with zarith.
intro.
rewrite Z_div_nz_opp_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_1_left : forall (y:Z), (1%Z < y)%Z -> ((mod1 1%Z y) = 1%Z).
intros y Hy.
unfold mod1.
rewrite Div_1_left; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_minus1_left : forall (y:Z), (1%Z < y)%Z -> ((mod1 (-1%Z)%Z
  y) = (y - 1%Z)%Z).
intros y Hy.
unfold mod1.
rewrite Div_minus1_left; auto with zarith.
Qed.

Open Scope Z_scope.

(* Why3 goal *)
Lemma Div_mult : forall (x:Z) (y:Z) (z:Z), (0%Z < x)%Z ->
  ((div ((x * y)%Z + z)%Z x) = (y + (div z x))%Z).
intros x y z h.
unfold div.
destruct (Z_le_dec 0 (z mod x)).
destruct (Z_le_dec 0 ((x*y+z) mod x)).
rewrite Zmult_comm.
rewrite Z_div_plus_full_l; auto with zarith.
generalize (Z_mod_lt (x * y + z) x); auto with zarith.
generalize (Z_mod_lt z x); auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_mult : forall (x:Z) (y:Z) (z:Z), (0%Z < x)%Z ->
  ((mod1 ((x * y)%Z + z)%Z x) = (mod1 z x)).
intros x y z h.
unfold mod1.
rewrite Div_mult.
ring.
auto with zarith.
Qed.


(* File: ML_int.v    (last edited on 25/10/2000  (c) Klaus Weich  *)

(* Axiomisation of the ML type "int" *)

Axiom Int : Set.
Axiom Less : Int -> Int -> Prop.
Axiom Equal : Int -> Int -> Prop.
Axiom int_succ : forall x : Int, {y : Int | Less x y}.
Axiom int_null : Int.

Axiom equal_dec : forall x y : Int, {Equal x y} + {~ Equal x y}.
Axiom less_dec : forall x y : Int, {Less x y} + {~ Less x y}.

Axiom
  notequal_notless_greater :
    forall x y : Int, ~ Equal x y -> ~ Less x y -> Less y x.

Axiom less_trans : forall x y z : Int, Less x y -> Less y z -> Less x z.
Axiom equal_less_less : forall x y z : Int, Equal x y -> Less y z -> Less x z.
Axiom less_equal_less : forall x y z : Int, Less x y -> Equal y z -> Less x z.
Axiom equal_sym : forall x y : Int, Equal x y -> Equal y x.
Axiom equal_trans : forall x y z : Int, Equal x y -> Equal y z -> Equal x z.
Axiom equal_refl : forall x : Int, Equal x x.
Axiom equal_eq : forall x y : Int, Equal x y -> x = y.

Axiom less_irrefl : forall x : Int, Less x x -> False.

Lemma equal_dec_refl :
 forall (i : Int) (A : Set) (a b : A),
 match equal_dec i i with
 | left _ => a
 | right _ => b
 end = a.
intros i A a b.
elim (equal_dec i i).
intros; trivial.
intros notequal; elimtype False; apply notequal.
apply equal_refl.
Qed.

Inductive max_int_spec (i0 i1 : Int) : Set :=
    Max_Int_Intro :
      forall j : Int,
      Less i0 j \/ Equal i0 j ->
      Less i1 j \/ Equal i1 j -> max_int_spec i0 i1.

Lemma max_int : forall i0 i1 : Int, max_int_spec i0 i1.
intros i0 i1.
elim (equal_dec i0 i1).
intros eq_i0_i1.
exists i0.
right.
apply equal_refl.
right.
apply equal_sym; assumption.

intros not_eq_i0_i1.
elim (less_dec i0 i1).
intros less_i0_i1.
exists i1.
left; assumption.
right.
apply equal_refl.

intros ge_i0_i1.
exists i0.
right.
apply equal_refl.
left.
apply notequal_notless_greater; assumption.
Qed.


Require Import FP.Data.Function.
Require Import FP.Structures.FUnit.
Require Import FP.Structures.Proxy.
Require Import FP.Structures.EqvRel.
Require Import FP.Relations.Setoid.

Import ProperNotation.

Class MPipe (m:Type->Type) :=
  { mpipe : forall {A B C}, (A -> m B) -> (B -> m C) -> A -> m C }.

Section MPipe.
  Context {m} {MPipe_:MPipe m}.

  Definition mcompose {A B C} : (B -> m C) -> (A -> m B) -> A -> m C := flip mpipe.
End MPipe.

Module KleisliNotation.
  Infix ">=>" := mpipe (at level 53, right associativity).
  Infix "<=<" := mcompose (at level 53, right associativity).
End KleisliNotation.

Section KleisliWF.
  Variable (m:Type->Type).
  Context {FUnit_:FUnit m} {MPipe_:MPipe m}.
  Variable (EqvEnv_:EqvEnv).
  Context {RPromote:forall {A} {aER:EqvRel A}, EqvRel (m A)}.

  Class KleisliWF :=
    { mpipe_left_unit :
        forall
          {A} {aER:EqvRel A}
          {B} {bER:EqvRel B}
          (f:A -> m B) (f':A -> m B) {fP:(env_R ==> env_R) f f'}
          (a:A) (a':A) {aP:env_R a a'},
            env_R
            (mpipe funit f a)
            (f' a')
    ; mpipe_right_unit :
        forall
          {A} {aER:EqvRel A}
          {B} {bER:EqvRel B}
          (f:A -> m B) (f':A -> m B) {fP:(env_R ==> env_R) f f'}
          (a:A) (a':A) {aP:env_R a a'},
            env_R
            (mpipe f funit a)
            (f' a')
    ; mpipe_associativity :
        forall
          {A} {aER:EqvRel A}
          {B} {bER:EqvRel B}
          {C} {cER:EqvRel C}
          {D} {dER:EqvRel D}
          (f:A -> m B) (f':A -> m B) {fP:(env_R ==> env_R) f f'}
          (g:B -> m C) (g':B -> m C) {gP:(env_R ==> env_R) g g'}
          (h:C -> m D) (h':C -> m D) {hP:(env_R ==> env_R) h h'}
          (a:A) (a':A) {aP:env_R a a'},
            env_R
            (mpipe (mpipe f g) h a)
            (mpipe f (mpipe g h) a)
    }.
End KleisliWF.