Require Export Util.
Require Export Net.
Require Export List.
Export ListNotations.

Require Import VerdiTactics.
Require Import UpdateLemmas.
Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Fixpoint distinct_pairs_and {A} (R : A -> A -> Prop) (l : list A) : Prop :=
  match l with
    | [] => True
    | x :: xs => (forall y, In y xs -> R x y) /\ distinct_pairs_and R xs
  end.

Class Decomposition (B : BaseParams) (M : MultiParams B) :=
  {
    state_invariant : (name -> data) -> Prop;
    network_invariant : (name -> data) -> packet -> Prop;
    network_network_invariant : packet -> packet -> Prop;

    network_network_invariant_sym :
      forall p1 p2,
        network_network_invariant p1 p2 ->
        network_network_invariant p2 p1 ;

    state_invariant_init : state_invariant init_handlers;

    state_invariant_maintained_input :
      forall h inp sigma st' out ps,
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        state_invariant (update sigma h st');
    state_invariant_maintained_deliver :
      forall p sigma st' out ps,
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        state_invariant (update sigma (pDst p) st');

    network_invariant_maintained_input_old :
      forall h inp sigma st' out ps p,
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        network_invariant (update sigma h st') p;
    network_invariant_maintained_input_new :
      forall h inp sigma st' out ps p,
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        In (pDst p, pBody p) ps ->
        pSrc p = h ->
        network_invariant (update sigma h st') p;

    network_invariant_maintained_deliver_old :
      forall sigma st' out ps p q,
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        network_invariant sigma q ->
        network_network_invariant p q ->
        network_invariant (update sigma (pDst p) st') q;
    network_invariant_maintained_deliver_new :
      forall sigma st' out ps p p',
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        In (pDst p', pBody p') ps ->
        pSrc p' = pDst p ->
        network_invariant (update sigma (pDst p) st') p';

    network_network_invariant_maintained_input_old :
      forall h inp sigma st' out ps p p',
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        In (pDst p', pBody p') ps ->
        pSrc p' = h ->
        network_network_invariant p p';

    network_network_invariant_maintained_input_new :
      forall h inp sigma st' out ps,
        input_handlers h inp (sigma h) = (out, st', ps) ->
        state_invariant sigma ->
        distinct_pairs_and network_network_invariant (map (fun m => mkPacket h (fst m) (snd m)) ps);

    network_network_invariant_maintained_deliver_old :
      forall sigma st' out ps p p' q,
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        network_invariant sigma q ->
        network_network_invariant p q ->
        In (pDst p', pBody p') ps ->
        pSrc p' = pDst p ->
        network_network_invariant p' q;

    network_network_invariant_maintained_deliver_new :
      forall sigma st' out ps p,
        net_handlers (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (out, st', ps) ->
        state_invariant sigma ->
        network_invariant sigma p ->
        distinct_pairs_and network_network_invariant (map (fun m => mkPacket (pDst p) (fst m) (snd m)) ps)
  }.

Section Decomposition.
  Context `{d : Decomposition}.

  (* Fixpoint remove_one {A : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) a l :=
    match l with
      | x :: xs => if A_eq_dec a x then xs else x :: remove_one A_eq_dec a xs
      | [] => []
    end. *)

  Definition packet_eq_dec :
    forall p1 p2 : packet,
      {p1 = p2} + {p1 <> p2}.
  Proof.
    intros. decide equality; eauto using name_eq_dec,msg_eq_dec.
  Defined.

  Definition composed_invariant net :=
    (state_invariant (nwState net)) /\
    (forall p, In p (nwPackets net) -> network_invariant (nwState net) p) /\
    (distinct_pairs_and network_network_invariant (nwPackets net)).

  Lemma post_net_analyze_sent_packet :
    forall h p ms xs ys,
      In p (map (fun m => mkPacket h (fst m) (snd m)) ms ++ xs ++ ys) ->
      (In (pDst p, pBody p) ms /\ h = pSrc p) \/ In p (xs ++ ys).
  Proof.
    intros.
    in_crush. destruct x; simpl in *; eauto.
  Qed.

  Lemma post_input_analyze_sent_packet :
    forall h p ms l,
      In p (map (fun m => mkPacket h (fst m) (snd m)) ms ++ l) ->
      (In (pDst p, pBody p) ms /\ h = pSrc p) \/ In p l.
  Proof.
    intros.
    in_crush; destruct x; simpl in *; eauto.
  Qed.

  (* NB: generalizing this over R makes it useless to [eauto using]
     because the conclusion is too general. *)
  Lemma nw_nw_distinct_pairs_and_elim :
    forall xs a b ys l,
      l = xs ++ a :: ys ->
      In b (xs ++ ys) ->
      distinct_pairs_and network_network_invariant l ->
      network_network_invariant a b.
  Proof.
    induction xs; intros; subst; simpl in *; intuition eauto; subst; eauto.
    apply network_network_invariant_sym. eauto.
  Qed.

  Lemma distinct_pairs_and_app_cons :
    forall A R xs p ys l,
      l = (xs ++ p :: ys) ->
      distinct_pairs_and (A:=A) R l ->
      distinct_pairs_and R (xs ++ ys).
  Proof.
    induction xs; intros; subst; simpl in *; intuition eauto.
  Qed.

  Lemma distinct_pairs_and_app :
    forall A R l1 l2,
      distinct_pairs_and (A := A) R l1 ->
      distinct_pairs_and R l2 ->
      (forall x y,
         In x l1 ->
         In y l2 ->
         R x y) ->
      distinct_pairs_and R (l1 ++ l2).
  Proof.
    induction l1; intros; simpl in *; intuition.
    find_apply_lem_hyp in_app_or.
    intuition eauto.
  Qed.

  Theorem decomposition_invariant :
    inductive_invariant step_m step_m_init composed_invariant.
  Proof.
    unfold inductive_invariant. intuition.
    - unfold composed_invariant. simpl.
      intuition auto using state_invariant_init.
    - unfold inductive, composed_invariant. intros.
      match goal with H : step_m _ _ _ |- _ => invcs H end; intuition; simpl in *.
      + eauto using state_invariant_maintained_deliver.
      + find_apply_lem_hyp post_net_analyze_sent_packet.
        intuition
          eauto 10 using
              network_invariant_maintained_deliver_new,
              network_invariant_maintained_deliver_old,
              nw_nw_distinct_pairs_and_elim,
              network_network_invariant_sym.
      + apply distinct_pairs_and_app;
        eauto using network_network_invariant_maintained_deliver_new, distinct_pairs_and_app_cons.

        intros. do_in_map. subst.
        eapply network_network_invariant_maintained_deliver_old;
          eauto using nw_nw_distinct_pairs_and_elim.
        simpl; now rewrite <- surjective_pairing.
      + eauto using state_invariant_maintained_input.
      + find_apply_lem_hyp post_input_analyze_sent_packet.
        intuition
          eauto using network_invariant_maintained_input_new,
                      network_invariant_maintained_input_old.
      + apply distinct_pairs_and_app;
            eauto using network_network_invariant_maintained_input_new.
        intros.
        do_in_map. subst.
        apply network_network_invariant_sym.
        eapply network_network_invariant_maintained_input_old; eauto.
        simpl. now rewrite <- surjective_pairing.
  Qed.
End Decomposition.


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

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.
Require Import ssrbool TestSuite.ssr_mini_mathcomp.

Axiom P : forall T, seq T -> Prop.

Goal (forall T (s : seq T), P _ s).
move=> T s.
elim: s => [| x /lastP [| s] IH].
Admitted.

Goal forall x : 'I_1, x = 0 :> nat.
move=> /ord1 -> /=; exact: refl_equal.
Qed.

Goal forall x : 'I_1, x = 0 :> nat.
move=> x.
move=> /ord1 -> in x |- *.
exact: refl_equal.
Qed.


From Coq Require Import ZArith .
From Common Require Import Var .
From mQhasm Require Import zDSL zRadix .
From mathcomp Require Import seq .

Open Scope N_scope.
Open Scope zdsl_scope.

Definition fe25519_mul_stage3_2 : program :=

let         wsize :=   64%nat in

let crypto_sign_ed25519_amd64_51_REDMASK51 :=
                       2251799813685247%Z in (* 0x7FFFFFFFFFFFF from consts *)
let crypto_sign_ed25519_amd64_51_REDMASK51_width :=
                       51 in        (* 51 bits *)

let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let          tmp2 := 997 in

let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in

let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in

let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in

let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
[::
zAssign z0 (zVar r0);
zAssign z1 (zVar r1);
zAssign z2 (zVar r2);
zAssign z3 (zVar r3);
zAssign z4 (zVar r4);
      (*  *)
      (*   mult = r0 *)
      (*   (uint64) mult >>= 51 *)
      (*   mult += r1 *)
zAssign mult (zVar r0);
zSplit mult tmp (zVar mult) 51;
zAssign mult (zBinop zAdd (zVar mult) (zVar r1));
      (*   r1 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r0 &= mulredmask *)
      (*   mult += r2 *)
zAssign r1 (zVar mult);
zSplit mult tmp2 (zVar mult) 51;
zAssign r0 (zVar tmp);
zAssign mult (zBinop zAdd (zVar mult) (zVar r2));
      (*   r2 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r1 &= mulredmask *)
      (*   mult += r3 *)
zAssign r2 (zVar mult);
zSplit mult tmp (zVar mult) 51;
zAssign r1 (zVar tmp2);
zAssign mult (zBinop zAdd (zVar mult) (zVar r3));
      (*   r3 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r2 &= mulredmask *)
      (*   mult += r4 *)
zAssign r3 (zVar mult);
zSplit mult tmp2 (zVar mult) 51;
zAssign r2 (zVar tmp);
zAssign mult (zBinop zAdd (zVar mult) (zVar r4));
      (*   r4 = mult *)
      (*   (uint64) mult >>= 51 *)
      (*   r3 &= mulredmask *)
zAssign r4 (zVar mult);
zSplit mult tmp (zVar mult) 51;
zAssign r3 (zVar tmp2);
      (*   mult *= 19 *)
      (*   r0 += mult *)
      (*   r4 &= mulredmask *)
zAssign mult (zBinop zMul (zVar mult) (zConst 19%Z));
zAssign r0 (zBinop zAdd (zVar r0) (zVar mult));
zAssign r4 (zVar tmp)
      (*   #END MACRO mul *)

      (*  *)
      (*   #// var lhs = r0_512 + r1_512 * 2**51 + r2_512 * 2**102 + r3_512 * 2**153 + r4_512 * 2**204 *)
      (*   #//     rhs = r0@u512 + r1@u512 * 2**51 + r2@u512 * 2**102 + r3@u512 * 2**153 + r4@u512 * 2**204 *)
      (*  *)
      (*   #// assert 0 <=u r0 <=u 2**52 && *)
      (*   #//        0 <=u r1 <=u 2**52 && *)
      (*   #//        0 <=u r2 <=u 2**52 && *)
      (*   #//        0 <=u r3 <=u 2**52 && *)
      (*   #//        0 <=u r4 <=u 2**52 && *)
      (*   #//        (lhs - rhs) %u (2**255 - 19) = 0 *)
      (*  *)
] .

Definition fe25519_mul_stage3_2_inputs : VS.t :=
let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let          tmp2 := 997 in
let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in
let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in
let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in
let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
VSLemmas.OP.P.of_list [:: r0; r1; r2; r3; r4].

Definition fe25519_mul_stage3_2_pre : bexp := zTrue.

Definition fe25519_mul_stage3_2_post : bexp :=
let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let          tmp2 := 997 in
let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in
let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in
let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in
let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (radix51 [::zVar z0; zVar z1; zVar z2; zVar z3; zVar z4])
  (radix51 [::zVar r0; zVar r1; zVar r2; zVar r3; zVar r4])
  (zConst n25519).

Definition fe25519_mul_stage3_2_spec :=
  {| spre := fe25519_mul_stage3_2_pre;
     sprog := fe25519_mul_stage3_2;
     spost := fe25519_mul_stage3_2_post |}.

From mathcomp Require Import eqtype ssrbool.
From mQhasm Require Import zVerify.

Lemma valid_fe25519_mul_stage3_2 : valid_zspec (fe25519_mul_stage3_2_inputs, fe25519_mul_stage3_2_spec).
Proof.
  time "valid_fe25519_mul_stage3_2" verify_zspec.
Qed.

Close Scope zdsl_scope.
Close Scope N_scope.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B X Y M Aprime Bprime : Universe, ((wd_ X Y /\ (wd_ A M /\ (wd_ Aprime M /\ (wd_ B M /\ (wd_ Bprime M /\ (wd_ B X /\ (wd_ B Y /\ (wd_ A X /\ (wd_ A Y /\ (wd_ A Aprime /\ (wd_ X Aprime /\ (wd_ Y Aprime /\ (col_ X Y M /\ (col_ B M Bprime /\ (col_ Bprime X Y /\ col_ M A Aprime))))))))))))))) -> col_ M Bprime X)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q Q0 Y B0 : Universe, ((wd_ P Q /\ (wd_ B Q /\ (wd_ A B /\ (wd_ P B /\ (wd_ C B /\ (wd_ P Q0 /\ (wd_ B B0 /\ (wd_ A B0 /\ (wd_ B Q0 /\ (wd_ A Q0 /\ (wd_ A C /\ (col_ B A P /\ (col_ Q P Q0 /\ (col_ B C Y /\ (col_ P Q0 Y /\ col_ B C P))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export VST.veric.bi.
Require Import VST.concurrency.ghosts.

From stdpp Require Export gmap.
From stdpp Require Import mapset finite.
From bst Require Export ccm gmap_more.

Definition keys := nzmap Z nat.

Definition keysComp (k1 k2: keys) : option keys :=
  if decide ((dom (gset Z) k1) ## (dom (gset Z) k2))
  then Some (ccmop k1 k2) else None.

Lemma keys_unitfor: forall t: keys, keysComp ∅ t = Some t.
Proof.
  intros. unfold keysComp.
  assert (@dom keys (gset Z) _ ∅ ## dom (gset Z) t). {
    unfold dom. unfold disjoint. unfold set_disjoint_instance. intros.
    apply nzmap_elem_of_dom_total in H. rewrite nzmap_lookup_empty in H.
    now apply H. }
  destruct (decide (@dom keys (gset Z) _ ∅ ## dom (gset Z) t)).
  rewrite ccm_left_id. auto. exfalso. now apply n.
Qed.

Instance keysJoin: sepalg.Join keys :=
  λ (k1 k2 k3: keys), keysComp k1 k2 = Some k3.

Lemma keysJoin_comm: forall (a b c : keys), keysJoin a b c -> keysJoin b a c.
Proof.
  unfold keysJoin. unfold keysComp. intros.
  destruct (decide (dom (gset Z) a ## dom (gset Z) b)); inversion H. clear H.
  symmetry in d. destruct (decide (dom (gset Z) b ## dom (gset Z) a)). 2: now exfalso.
  now rewrite ccm_comm.
Qed.

Lemma keys_dom: forall (a b: keys),
    dom (gset Z) (a + b)%CCM = dom (gset Z) a ∪ dom (gset Z) b.
Proof.
  intros. set_unfold. intros. unfold ccmop, ccm_op. simpl. unfold lift_op.
  rewrite nzmap_elem_of_dom_total.
  rewrite nzmap_lookup_merge.
  repeat rewrite nzmap_elem_of_dom_total.
  unfold ccmop, ccm_op. simpl. unfold nat_op. unfold ccmunit, nat_unit. lia.
Qed.

Lemma keysJoin_assoc: forall (a b c d e : keys),
    keysJoin a b d -> keysJoin d c e -> {f : keys & keysJoin b c f ∧ keysJoin a f e}.
Proof.
  intros. unfold keysJoin in *. unfold keysComp in *.
  destruct (decide (dom (gset Z) a ## dom (gset Z) b)); inversion H.
  destruct (decide (dom (gset Z) d ## dom (gset Z) c)); inversion H0. clear H H0.
  exists (b + c)%CCM.
  assert (dom (gset Z) a ## dom (gset Z) c ∧ dom (gset Z) b ## dom (gset Z) c). {
    rewrite <- H2 in d1.
    rewrite keys_dom in d1.
    now apply disjoint_union_l in d1. }
  destruct H.
  destruct (decide (dom (gset Z) b ## dom (gset Z) c)). 2: now exfalso. clear d2.
  split; auto.
  assert (dom (gset Z) a ## dom (gset Z) (b + c)%CCM). {
    rewrite keys_dom. rewrite disjoint_union_r. split; auto. }
  destruct (decide (dom (gset Z) a ## dom (gset Z) (b + c)%CCM)). 2: now exfalso.
  f_equal. rewrite <- H2. apply ccm_assoc.
Qed.

Lemma keys_ccm_positive: forall (a b: keys), (a + b)%CCM = 0%CCM -> a = 0%CCM.
Proof.
  intros. unfold ccmop, ccm_op in H. simpl in H. unfold lift_op in H.
  apply nzmap_eq. intros n.
  assert (nzmap_merge ccmop a b ! n = 0%CCM ! n) by now rewrite H.
  rewrite nzmap_lookup_merge in H0. unfold ccmop, ccm_op, nat_op in H0.
  rewrite nzmap_lookup_empty.
  rewrite nzmap_lookup_empty in H0.
  unfold ccmunit, ccm_unit in *. simpl in *.
  unfold nat_unit in *. lia.
Qed.

Program Instance keysGhost : Ghost :=
  { G := keys; valid := fun _ => True; Join_G := keysJoin }.
Next Obligation.
  exists (fun _ => ∅); intros; auto.
  hnf. apply keys_unitfor.
Qed.
Next Obligation.
  constructor; unfold sepalg.join; intros.
  - unfold keysJoin in *. rewrite H in H0. now inversion H0.
  - eapply keysJoin_assoc; eauto.
  - apply keysJoin_comm; auto.
  - unfold keysJoin in *. unfold keysComp in *.
    destruct (decide (dom (gset Z) a ## dom (gset Z) a')); inversion H. clear H.
    destruct (decide (dom (gset Z) b ## dom (gset Z) b')); inversion H0. clear H0.
    rewrite <- H2 in H1. rewrite <- ccm_assoc in H1.
    pose proof (ccm_right_id a). rewrite <- H in H1 at 2.
    apply ccm_cancel in H1. clear H. rewrite <- ccm_assoc.
    rewrite (ccm_comm b' a'). rewrite H1. rewrite ccm_right_id.
    rewrite ccm_comm in H1. apply keys_ccm_positive in H1. rewrite H1.
    now rewrite ccm_right_id.
Qed.
Next Obligation.
  intros. simpl. auto.
Qed.

Lemma bool_decide_nzmap_to1_wf:
  forall (s: gset Z), bool_decide (nzmap_wf (gset_to_gmap 1 s)).
Proof.
  intros. unfold bool_decide. destruct (nzmap_wf_decision Z (gset_to_gmap 1 s)). easy.
  assert (nzmap_wf (gset_to_gmap 1 s)). {
    unfold nzmap_wf. unfold map_Forall. intros. apply lookup_gset_to_gmap_Some in H.
    destruct H. subst x. easy. } now exfalso.
Qed.

Definition gset_to_keys (s: gset Z): keys :=
  NZMap (gset_to_gmap 1 s) (bool_decide_nzmap_to1_wf s).


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                 Xavier Leroy, INRIA Paris                           *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Machine- and ABI-dependent layout information for activation records. *)

Require Import Coqlib.
Require Import AST Memory Separation.
Require Import Bounds.

Local Open Scope sep_scope.

(** The general shape of activation records is as follows,
  from bottom (lowest offsets) to top:
- Space for outgoing arguments to function calls.
- Back link to parent frame
- Return address
- Saved values of callee-save registers used by the function.
- Local stack slots.
- Space for the stack-allocated data declared in Cminor.

The stack pointer is kept 16-aligned.
*)

Definition fe_ofs_arg := 0.

Definition make_env (b: bounds) : frame_env :=
  let w := if Archi.ptr64 then 8 else 4 in
  let olink := align (4 * b.(bound_outgoing)) w in  (* back link *)
  let oretaddr := olink + w in                      (* return address *)
  let ocs := oretaddr + w in                        (* callee-saves *)
  let ol :=  align (size_callee_save_area b ocs) 8 in (* locals *)
  let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *)
  let sz := align (ostkdata + b.(bound_stack_data)) 16 in
  {| fe_size := sz;
     fe_ofs_link := olink;
     fe_ofs_retaddr := oretaddr;
     fe_ofs_local := ol;
     fe_ofs_callee_save := ocs;
     fe_stack_data := ostkdata;
     fe_used_callee_save := b.(used_callee_save) |}.

Lemma frame_env_separated:
  forall b sp m P,
  let fe := make_env b in
  m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
  m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
       ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
       ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr)
       ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr)
       ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
       ** P.
Proof.
Local Opaque Z.add Z.mul sepconj range.
  intros; simpl.
  set (w := if Archi.ptr64 then 8 else 4).
  set (olink := align (4 * b.(bound_outgoing)) w).
  set (oretaddr := olink + w).
  set (ocs := oretaddr + w).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  replace (size_chunk Mptr) with w by (rewrite size_chunk_Mptr; auto).
  assert (0 < w) by (unfold w; destruct Archi.ptr64; lia).
  generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
  assert (0 <= 4 * b.(bound_outgoing)) by lia.
  assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; lia).
  assert (olink + w <= oretaddr) by (unfold oretaddr; lia).
  assert (oretaddr + w <= ocs) by (unfold ocs; lia).
  assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
  assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia).
  assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia).
(* Reorder as:
     outgoing
     back link
     retaddr
     callee-save
     local *)
  rewrite sep_swap12.
  rewrite sep_swap23.
  rewrite sep_swap34.
  rewrite sep_swap45.
(* Apply range_split and range_split2 repeatedly *)
  unfold fe_ofs_arg.
  apply range_split_2. fold olink; lia. lia.
  apply range_split. lia.
  apply range_split. lia.
  apply range_split_2. fold ol. lia. lia.
  apply range_drop_right with ostkdata. lia.
  eapply sep_drop2. eexact H.
Qed.

Lemma frame_env_range:
  forall b,
  let fe := make_env b in
  0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
Proof.
  intros; simpl.
  set (w := if Archi.ptr64 then 8 else 4).
  set (olink := align (4 * b.(bound_outgoing)) w).
  set (oretaddr := olink + w).
  set (ocs := oretaddr + w).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  assert (0 < w) by (unfold w; destruct Archi.ptr64; lia).
  generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
  assert (0 <= 4 * b.(bound_outgoing)) by lia.
  assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; lia).
  assert (olink + w <= oretaddr) by (unfold oretaddr; lia).
  assert (oretaddr + w <= ocs) by (unfold ocs; lia).
  assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
  assert (size_callee_save_area b ocs <= ol) by (apply align_le; lia).
  assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; lia).
  split. lia. apply align_le. lia.
Qed.

Lemma frame_env_aligned:
  forall b,
  let fe := make_env b in
     (8 | fe_ofs_arg)
  /\ (8 | fe_ofs_local fe)
  /\ (8 | fe_stack_data fe)
  /\ (align_chunk Mptr | fe_ofs_link fe)
  /\ (align_chunk Mptr | fe_ofs_retaddr fe).
Proof.
  intros; simpl.
  set (w := if Archi.ptr64 then 8 else 4).
  set (olink := align (4 * b.(bound_outgoing)) w).
  set (oretaddr := olink + w).
  set (ocs := oretaddr + w).
  set (ol :=  align (size_callee_save_area b ocs) 8).
  set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
  assert (0 < w) by (unfold w; destruct Archi.ptr64; lia).
  replace (align_chunk Mptr) with w by (rewrite align_chunk_Mptr; auto).
  split. apply Z.divide_0_r.
  split. apply align_divides; lia.
  split. apply align_divides; lia.
  split. apply align_divides; lia.
  apply Z.divide_add_r. apply align_divides; lia. apply Z.divide_refl.
Qed.


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

(***
Modulus : 2^336 - 17
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 11%nat;
    base := 32;
    bitwidth := 32;
    s := 2^336;
    c := [(1, 17)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

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

    mul_code := None;

    square_code := None;

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

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


From logrel_heaplang_sessions Require Export lty ltyping any arr prod ref basic.
From iris.heap_lang Require Export lifting metatheory.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import notation proofmode.

Section types.
  Context `{heapG Σ}.

  Definition weakrefN := nroot .@ "weakref".

  Definition lty_weakref (A : lty Σ) : lty Σ := Lty (λ w,
    ∃ (l : loc), ⌜w = #l⌝ ∗ inv (weakrefN .@ l) (∃ v : val, l ↦ v ∗ A v))%I.
End types.

Notation "'weakref' A" := (lty_weakref A) (at level 10) : lty_scope.

Section properties.
  Context `{heapG Σ}.

  Global Instance lty_weakref_contractive : Contractive (@lty_weakref Σ _).
  Proof. solve_contractive. Qed.

  Global Instance lty_weakref_ne : NonExpansive2 (@lty_weakref Σ _).
  Proof. solve_proper. Qed.

  Global Instance lty_weakref_unboxed A : LTyUnboxed (weakref A).
  Proof. iIntros (v). by iDestruct 1 as (l ->) "?". Qed.

  (* TODO: Kind of ugly that we have the Skip here, but otherwise I
  had an issue where the thing I wanted in my invariant had two laters
  around it instead of one. *)
  Definition fromstrong : val := λ: "x", Skip;; "x".
  Lemma ltyped_fromstrong A :
    ∅ ⊨ fromstrong : ref A → weakref A.
  Proof.
    iIntros (vs) "HΓ /=".
    wp_apply wp_value.
    iModIntro. iIntros (v) "Hv".
    iDestruct "Hv" as (l w) "[>#Hv [Hl HA]]".
    rewrite /fromstrong.
    wp_lam.
    iMod (inv_alloc (weakrefN .@ l) _ (∃ v : val, l ↦ v ∗ A v)%I with "[Hv Hl HA]") as "Hinv".
    { iModIntro. iExists w. iFrame "Hl HA". }
    wp_pures.
    iExists l.
    iFrame "Hv Hinv".
  Qed.

  Definition fetchandadd : val := λ: "r" "inc", FAA "r" "inc".
  Lemma ltyped_fetchandadd:
    ∅ ⊨ fetchandadd : weakref lty_int → lty_int → lty_int.
  Proof.
    iIntros (vs) "_ /=".
    wp_apply wp_value.
    iModIntro.
    iIntros (r) "#Hr".
    rewrite /fetchandadd. wp_pures.
    iModIntro.
    iIntros (inc) "Hinc".
    wp_pures.
    iDestruct "Hr" as (l ->) "Hr".
    iDestruct "Hinc" as (k) "->".
    iInv (weakrefN .@ l) as (n) "[>Hl >Hn]" "Hclose".
    iDestruct "Hn" as (m) "->".
    wp_faa.
    iMod ("Hclose" with "[Hl]") as "_".
    { iModIntro. iExists #(m + k). iFrame "Hl". by iExists (m + k). }
    iModIntro.
    by iExists m.
  Qed.

  Definition weakrefload : val := λ: "r", !"r".
  Lemma ltyped_weakrefload (A : lty Σ) {copyA : LTyCopy A} :
    ∅ ⊨ weakrefload : weakref A → A.
  Proof.
    iIntros (vs) "_ /=".
    wp_apply wp_value.
    iModIntro. iIntros (r) "#Hr".
    rewrite /weakrefload. wp_pures.
    iDestruct "Hr" as (l ->) "Hr".
    iInv (weakrefN .@ l) as (v) "[>Hl #HA]" "Hclose".
    wp_load. iMod ("Hclose" with "[Hl HA]") as "_".
    { iModIntro. iExists v. iFrame "Hl HA". }
    iModIntro. iFrame "HA".
  Qed.

  Definition weakrefstore : val := λ: "r" "x", "r" <- "x";; #().
  Lemma ltyped_weakrefstore (A : lty Σ) :
    ∅ ⊨ weakrefstore : weakref A → A → ().
  Proof.
    iIntros (vs) "_ /=".
    wp_apply wp_value.
    iModIntro. iIntros (r) "#Hr".
    rewrite /weakrefstore. wp_pures.
    iModIntro. iIntros (x) "HA". wp_pures.
    wp_bind (_ <- _)%E.
    iDestruct "Hr" as (l ->) "Hr".
    iInv (weakrefN .@ l) as (v) "[>Hl _]" "Hclose".
    wp_store. iMod ("Hclose" with "[Hl HA]") as "_".
    { iModIntro. iExists x. iFrame "Hl HA". }
    iModIntro. wp_pures. done.
  Qed.

End properties.


Add LoadPath "~/Schreibtisch/svnba/Elgot/Coq/".
Require Import ElgotMonad.
Require Import Lemmas_ElgotMonad.
Require Import CofreeElgotMonad.
Require Import Lemmas_CofreeElgotMonad.
Require Import Coq_Steroids.
Require Import Setoid.
Open Scope elgot_scope.

Section ContextCofreeElgotMonad.
Context `(C: CofreeElgotMonad).

Parameter a b : Obj.

(* --- *)

Theorem proving_kl1 : forall (x : Obj),
(ηv (x:=x) (a:=a) (b:=b)) § = id.
Proof.
intros.
symmetry.
apply lifting2.
rewrite -> id_l.
rewrite -> out_unitcofree.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> id_l.
rewrite <- f_cpr.
rewrite -> inl_inr_is_id.
rewrite -> id_l.
rewrite -> kl1.
rewrite -> id_r.
reflexivity.
Qed.

Theorem proving_kl2 : forall (x y : Obj) (f: x ~> coext T a b y),
f § ∘ ηv (x:=x) = f.
Proof.
intros.
apply out_cong.
rewrite -> comp_assoc.
rewrite -> lifting1.
rewrite <- comp_assoc.

(* since the introduction of cont, this doesn't work anymore TODO *)
Admitted.
(*
rewrite -> out_unitcofree.
rewrite -> comp_assoc.
rewrite -> kl2.
rewrite -> cpr_inl.
reflexivity.
Qed.
*)

Theorem proving_kl3 : forall (x y z : Obj) (f : y ~> coext T a b z) (g : x ~> coext T a b y),
(f § ∘ g) § = f § ∘ g §.
Proof.
intros.
symmetry.
apply lifting2.
rewrite -> comp_assoc.
rewrite -> lifting1.
rewrite <- comp_assoc.
(* since the introduction of cont, this doesn't work anymore TODO *)
Admitted.
(*
rewrite -> lifting1.
rewrite -> comp_assoc with (h':=out).
rewrite -> lifting1.

rewrite -> comp_assoc with (f':=out).
apply f_equal2; trivial.
rewrite <- kl3.
apply f_equal1.

rewrite -> f_cpr.
rewrite <- comp_assoc with (f':=id ×× lifting_cofree g ^^ id).
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> comp_assoc with (g':=inr).
rewrite -> cpr_inr.
rewrite <- comp_assoc with (f':=id ×× lifting_cofree g ^^ id).
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite -> comp_assoc with (f':=g).
reflexivity.
Qed.
*)

(* additional lemmas based on proving_kl1-3 *)

Lemma mapcofree : forall (x y : Obj) (f:x ~> y),
map_cofree f = (ηv (a:=a) (b:=b) ∘ f) §.
Proof.
intros.
(* TODO *)
Admitted.

Lemma liftingcofree_mapcofree : forall
(x y z : Obj) (f: y ~> coext T a b z) (g: x ~> y),
f § ∘ map_cofree g = (f ∘ g) §.
Proof.
intros.
rewrite -> mapcofree.
rewrite <- proving_kl3.
rewrite -> comp_assoc.
rewrite -> proving_kl2.
reflexivity.
Qed.

(* --- *)

Theorem proving_unfolding : forall x y (f : x ~> (coext T a b (y ⊕ x))),
[ηv , iter_cofree f] § ∘ f = iter_cofree f.
Proof.
intros.
symmetry.

rewrite -> unfolding_triangular1 at 1.
unfold triangular.

rewrite <- comp_assoc with (h':=tuo).
rewrite -> comp_assoc with (g':=tuo).
rewrite -> liftingcofree_tuo.

rewrite -> comp_assoc with (g':=map (inl ⊕⊕ id)).
rewrite <- comp_assoc with (h':=tuo).
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite -> cpr_inl.
rewrite -> id_l.

rewrite <- unfolding.

rewrite <- comp_assoc with (h':=tuo).
rewrite -> comp_assoc with (g':=(([η, ((map ([inl ⊕⊕ id, inl ∘ inr]) ∘ out) ∘ f) †]) *)).
rewrite <- kl3.
rewrite -> f_cpr.
rewrite -> kl2.
(* since the introduction of cont, this doesn't work anymore TODO *)
Admitted.
(*
rewrite <- out_itercofree.

rewrite <- comp_assoc with (g':=out).
rewrite -> comp_assoc with (g':=map ([inl ⊕⊕ id, inl ∘ inr])).
rewrite -> lifting_map.
rewrite -> f_cpr.
rewrite -> cpr_coprodhom.
rewrite -> cpr_inl.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite -> cpr_inr.

rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite <- liftingcofree_tuo.
rewrite <- comp_assoc with (g':=tuo).
rewrite -> tuo_out_is_id.
rewrite -> id_l.
reflexivity.
Qed.
*)

(* --- *)

Lemma proving_naturality_h1 : forall x y z (h: x ~> coext T a b (y ⊕ x)) (g: y ~> coext T a b z),
guarded h ->
  guarded ([map_cofree inl ∘ g, ηv ∘ inr] § ∘ h).
Proof.
intros.
unfold guarded in H.
inversion H as [u' H1].

unfold guarded.

exists ([map (id ⊕⊕ id ×× map_cofree inl ^^ id) ∘ out ∘ g, η ∘ inr ∘ id ×× ([map_cofree inl ∘ g, ηv ∘ inr]) § ^^ id] * ∘ u').
rewrite -> comp_assoc.
rewrite -> lifting1.

rewrite <- comp_assoc.
(* since the introduction of cont, this doesn't work anymore TODO *)
Admitted.
(*
rewrite -> H1.

rewrite -> comp_assoc with (f':=u').
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
rewrite -> id_l.
rewrite -> comp_assoc.
rewrite -> out_mapcofree.

rewrite -> comp_assoc with (f':=u').
apply f_equal2; trivial.
rewrite -> map_lifting.
apply f_equal1.

rewrite -> f_cpr.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
rewrite <- comp_assoc with (h':=η).
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (h':=inl ⊕⊕ id).
rewrite -> coprodhom_inr.
rewrite -> id_l.
reflexivity.
Qed.
*)

Theorem proving_naturality_h2 : forall x y z (f : x ~> (coext T a b (y ⊕ x)))(g : y ~> (coext T a b z)),
▷(([map_cofree inl ∘ g, ηv ∘ inr]) § ∘ f) =
(([map_cofree inl ∘ g, ηv ∘ inr]) § ∘ ▷f).
Proof.
intros.
unfold triangular.
apply out_cong.

rewrite ->3 comp_assoc.
rewrite -> out_tuo_is_id.
rewrite -> id_r.
rewrite <- comp_assoc with (g':=out).
rewrite -> comp_assoc with (h':=out).
rewrite -> lifting1.
rewrite <- comp_assoc with (h':=tuo).
rewrite -> comp_assoc with (g':=tuo).
rewrite <- comp_assoc with (g':=out).
(* since the introduction of cont, this doesn't work anymore TODO *)
Admitted.
(*
rewrite -> out_tuo_is_id.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=map (inl ⊕⊕ id)).
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
rewrite -> id_l.

unfold map at 1.
rewrite ->2 naturality.
apply f_equal1.
rewrite ->5 comp_assoc.
rewrite -> kl2.
apply f_equal2;trivial.
rewrite -> comp_assoc with (f':=out).
apply f_equal2;trivial.

rewrite ->2 lifting_map.
rewrite <- kl3.
apply f_equal1.

case_distinction.

rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
rewrite -> id_l.
rewrite -> f_cpr with (h:=ηv ∘ inr).
rewrite ->2 comp_assoc with (h':=out).
rewrite -> out_mapcofree.
rewrite -> out_unitcofree.
rewrite -> f_cpr with (h:=(η ∘ inl) ∘ inr).
rewrite <-2 comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite <- comp_assoc with (f':=inl ∘ inr).
rewrite ->2 comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite -> comp_assoc with (g':=inl ⊕⊕ id).
rewrite -> cpr_coprodhom.
rewrite -> id_l.
rewrite -> cpr_inr.

rewrite ->2 comp_assoc.
rewrite -> lifting_map.
rewrite <- comp_assoc with (g':=[inl ⊕⊕ id, inl ∘ inr]).
rewrite -> cpr_coprodhom.
rewrite -> coprodhom_inl.

case_distinction.
rewrite -> comp_assoc with (f':=g).
apply f_equal2;trivial.
rewrite -> comp_assoc with (f':=out).
apply f_equal2;trivial.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite <- comp_assoc with (f':=inl).
rewrite -> coprodhom_inl.
rewrite <- comp_assoc with (h':=inl).
rewrite ->2 comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite -> comp_assoc with (g':=inr).
rewrite <- comp_assoc with (g':=inl ⊕⊕ id).
rewrite -> coprodhom_inr.
rewrite -> id_l.
rewrite -> lifting_map.
unfold coprodhom.
rewrite -> f_cpr.
rewrite ->2 comp_assoc.
trivial.

trivial.

rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite <- comp_assoc with (f':=inr).
rewrite -> cpr_inr.
rewrite <-2 comp_assoc with (h':=η).
rewrite ->2 comp_assoc with (g':=η).
rewrite ->2 kl2.
rewrite -> comp_assoc with (g':=inr).
rewrite <- comp_assoc with (f':=inr).
rewrite -> cpr_inr.
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite <-2 comp_assoc with (f':=inr).
rewrite -> coprodhom_inr.
rewrite -> id_l.
rewrite ->2 comp_assoc.
trivial.
Qed.
*)

Theorem proving_naturality : forall x y z (f : x ~> (coext T a b (y ⊕ x)))(g : y ~> (coext T a b z)),
    g § ∘ iter_cofree f = iter_cofree ([(ηv ∘ inl) § ∘ g  , ηv ∘ inr] § ∘ f).
Proof.
intros.
rewrite <- mapcofree.

rewrite -> itercofree_triangular.
symmetry.
rewrite -> itercofree_triangular.

rewrite -> proving_naturality_h2.

symmetry.

apply unfolding_guarded2.

apply proving_naturality_h1.

apply guardedtriangular_def.

rewrite -> comp_assoc.
rewrite <- proving_kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc.
rewrite -> liftingcofree_mapcofree.
rewrite -> cpr_inl.
rewrite -> proving_kl1.
rewrite -> id_r.
rewrite -> comp_assoc.
rewrite -> proving_kl2.
rewrite -> cpr_inr.
rewrite <- proving_unfolding at 1.
rewrite -> comp_assoc.
rewrite <- proving_kl3.
rewrite -> f_cpr.
rewrite -> proving_kl2.
reflexivity.

Qed.

(* --- *)

Theorem proving_dinaturality : forall x y z (g: x ~> (coext T a b (y ⊕ z))) (h : z ~> (coext T a b (y ⊕ x))),
    iter_cofree ([ηv ∘ inl , h] § ∘ g) =
    [ ηv , iter_cofree ([ηv ∘ inl , g] § ∘ h) ] § ∘ g.
Proof.
intros.
set (s:=[ ηv ∘ inl , h ] § ∘ g).
set (t:=[ ηv ∘ inl , g ] § ∘ h).
set (w:=[ ηv, iter_cofree t] § ∘ g).

assert (H0: [ηv, w] § ∘ ▷ s = [ηv, iter_cofree t] § ∘ [ ηv ∘ inl , ▷ t] § ∘ g).
set (p:=(map ((id (a:=y) ⊕⊕ id (a:=a) ×× [ηv ∘ inl, h] § ^^ id (a:=b)) ⊕⊕ id (a:=z)))).
set (q:=(map ((id (a:=y) ⊕⊕ id (a:=a) ×× [ηv ∘ inl, g] § ^^ id (a:=b)) ⊕⊕ id (a:=x)))).

assert (Hp: ((map ([inl ⊕⊕ id, inl ∘ inr])) ∘ out ∘ s) † =
              ([η ∘ inl, (map ([inl ⊕⊕ id, inl ∘ inr])) ∘ out ∘ h] * ∘
              p ∘ (map ([inl ⊕⊕ id, inl ∘ inr])) ∘ out ∘ g) †).
apply f_equal1.
unfold s.
rewrite -> comp_assoc.
apply f_equal2;trivial.
rewrite <- comp_assoc.
rewrite -> lifting1.
rewrite -> comp_assoc.
apply f_equal2;trivial.
rewrite -> map_lifting.
rewrite -> f_cpr.
rewrite -> f_cpr.
rewrite -> comp_assoc with (h':=out).
rewrite -> out_unitcofree.
rewrite -> f_cpr.
rewrite <- comp_assoc with (f':=inl).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite -> coprodhom_inl.
rewrite <- comp_assoc with (g':=inr).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=inr).
rewrite -> cpr_inr.
unfold p.
rewrite <- comp_assoc with (f':=map ([inl ⊕⊕ id, inl ∘ inr])).
rewrite -> map_comp.
rewrite -> f_cpr.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> coprodhom_inl.
rewrite <- comp_assoc with (f':=inr).
rewrite -> coprodhom_inr.
rewrite -> lifting_map.
apply f_equal1.
rewrite -> f_cpr.
rewrite -> cpr_coprodhom.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
reflexivity.

assert (Hq: ((map ([inl ⊕⊕ id, inl ∘ inr])) ∘ out ∘ t) † =
              ([η ∘ inl, (map ([inl ⊕⊕ id, inl ∘ inr])) ∘ out ∘ g] * ∘
              q ∘ (map ([inl ⊕⊕ id, inl ∘ inr])) ∘ out ∘ h) †).
apply f_equal1.
unfold t.
rewrite -> comp_assoc.
apply f_equal2;trivial.
rewrite <- comp_assoc.
rewrite -> lifting1.
rewrite -> comp_assoc.
apply f_equal2;trivial.
rewrite -> map_lifting.
rewrite -> f_cpr.
rewrite -> f_cpr.
rewrite -> comp_assoc with (h':=out).
rewrite -> out_unitcofree.
rewrite -> f_cpr.
rewrite <- comp_assoc with (f':=inl).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite -> coprodhom_inl.
rewrite <- comp_assoc with (g':=inr).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=inr).
rewrite -> cpr_inr.
unfold q.
rewrite <- comp_assoc with (f':=map ([inl ⊕⊕ id, inl ∘ inr])).
rewrite -> map_comp.
rewrite -> f_cpr.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> coprodhom_inl.
rewrite <- comp_assoc with (f':=inr).
rewrite -> coprodhom_inr.
rewrite -> lifting_map.
apply f_equal1.
rewrite -> f_cpr.
rewrite -> cpr_coprodhom.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
reflexivity.

(* left hand side *)
apply out_cong.
rewrite -> comp_assoc.
rewrite -> lifting1 at 1.
unfold triangular at 1.
rewrite <- comp_assoc with (h':=tuo).
rewrite <- comp_assoc with (g':=out).
rewrite -> comp_assoc with (g':=tuo).
(* since the introduction of cont, this doesn't work anymore TODO *)
Admitted.
(*
rewrite -> out_tuo_is_id.
rewrite -> id_r.
rewrite -> comp_assoc.
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
rewrite -> out_unitcofree.
rewrite -> id_l. (* this equals T (id + id ×× ([ηv, w]) § ^^ id), not T (inl + ...) *)

rewrite -> Hp.

rewrite <- comp_assoc with (g':=p).
rewrite <- comp_assoc with (f':=g).
rewrite <- comp_assoc with (f':=out ∘ g).
rewrite -> dinaturality.

unfold p.
rewrite <- comp_assoc with (h':=map ((id ⊕⊕ id ×× ([ηv ∘ inl, h]) § ^^ id) ⊕⊕ id)).
rewrite -> comp_assoc with (g':=map ((id ⊕⊕ id ×× ([ηv ∘ inl, h]) § ^^ id) ⊕⊕ id)).
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite -> id_l.

rewrite -> comp_assoc.
rewrite <- kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> cpr_coprodhom.
rewrite -> id_l.
rewrite <- comp_assoc with (h':=η ∘ inr).
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite <- proving_kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=ηv).
rewrite -> proving_kl2.
rewrite -> cpr_inl. (* how does one get iter_cofree t here ? *)

(* right hand side *)
rewrite -> comp_assoc with (h':=out).
rewrite -> comp_assoc with (h':=out).
rewrite -> lifting1.

rewrite <- comp_assoc with (g':=out).
rewrite <- comp_assoc with (g':=out).
rewrite -> lifting1.

assert (H: (([out ∘ [ηv ∘ inl, ▷t], (η ∘ inr) ∘ id ×× ([ηv ∘ inl, ▷t]) § ^^ id]) *
    ∘ (out ∘ g) = ([η ∘ inl ⊕⊕ id ×× ([ηv ∘ inl, ▷t]) § ^^ id, out ∘ ▷t] *
    ∘ map ([inl ⊕⊕ id, inl ∘ inr])) ∘ (out ∘ g))).
apply f_equal2;trivial.
rewrite -> lifting_map.
rewrite -> f_cpr.
rewrite -> f_cpr.
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inl).
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite <- comp_assoc with (f':=inr).
rewrite -> coprodhom_inr.
rewrite -> comp_assoc with (h':=out).
rewrite -> out_unitcofree.
rewrite -> comp_assoc.
reflexivity.

rewrite <- comp_assoc with (f':=g).
rewrite <- comp_assoc with (f':=g).
rewrite -> H.
clear H.

rewrite <- comp_assoc with (g':=map ([inl ⊕⊕ id, inl ∘ inr])).
rewrite -> comp_assoc with (f':=(map ([inl ⊕⊕ id, inl ∘ inr]) ∘ (out ∘ g))).
rewrite <- kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (h':=η ∘ inr).
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
rewrite -> out_unitcofree. (* again T(id + ..) not T(inl + ..) *)
rewrite <- proving_kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc with (f':=inl).
rewrite -> proving_kl2.
rewrite -> cpr_inl.
rewrite <- unfolding_triangular1.

apply f_equal2;trivial.
apply f_equal1.

assert (H1: ([ηv, w]) § ∘ h = iter_cofree t).
unfold w.
unfold t.
symmetry.
rewrite <- proving_unfolding at 1.
rewrite -> comp_assoc.
apply f_equal2;trivial.
rewrite <- proving_kl3.
apply f_equal1.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=ηv).
rewrite -> proving_kl2.
rewrite -> cpr_inl.
reflexivity.

rewrite -> H1.
apply f_equal2;trivial.

(* left hand side *)
rewrite -> naturality.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite <- comp_assoc with (g':=inr).
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.

rewrite -> comp_assoc.
rewrite <- kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> cpr_inl.

rewrite -> comp_assoc with (g':=map ((id ⊕⊕ id ×× ([ηv ∘ inl, h]) § ^^ id) ⊕⊕ id)).
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite -> cpr_coprodhom.
rewrite -> id_l.
rewrite -> id_l.
rewrite <- comp_assoc with (f':=id ×× ([ηv ∘ inl, h]) § ^^ id).
rewrite <- comp_assoc with (f':=id ×× ([ηv ∘ inl, h]) § ^^ id).
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.

(* page 22 at the top step 2/3, very unclean way to do things, TODO: make it clean *)
assert (H2: (([[(η ∘ inl) ∘ inl, (η ∘ inl) ∘ (inr ∘ id ×× ([ηv, w]) § ^^ id)],
  ([[(η ∘ inl) ∘ inl,
    (η ∘ inl) ∘ (inr ∘ id ×× (([ηv, w]) § ∘ ([ηv ∘ inl, h]) §) ^^ id)],
   η ∘ inr]) * ∘ (map ([inl ⊕⊕ id, inl ∘ inr]) ∘ (out ∘ g))]) *
 ∘ (map ([inl ⊕⊕ id, inl ∘ inr]) ∘ (out ∘ h))) † =
  map (id ⊕⊕ id ×× ([ηv, iter_cofree t]) § ^^ id) ∘
  ([η ∘ inl ∘ id ⊕⊕ id ×× [ηv ∘ inl, g] § ^^ id, map ([inl ⊕⊕ id, inl ∘ inr]) ∘ out ∘ g] * ∘
  map ([inl ⊕⊕ id, inl ∘ inr]) ∘ out ∘ h) †).
symmetry.
unfold map at 1.
rewrite -> naturality.
apply f_equal1.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite <- comp_assoc with (f':=h).
rewrite <- comp_assoc with (f':=out ∘ h).
rewrite -> comp_assoc with (f':=(map ([inl ⊕⊕ id, inl ∘ inr]) ∘ (out ∘ h))).
apply f_equal2;trivial.
rewrite <- kl3.
apply f_equal1.
rewrite -> f_cpr.
rewrite <- comp_assoc with (h':=η).
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite <- comp_assoc with (f':=id ⊕⊕ id ×× ([ηv ∘ inl, g]) § ^^ id).
rewrite <- comp_assoc with (f':=id ⊕⊕ id ×× ([ηv ∘ inl, g]) § ^^ id).
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite <- proving_kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=ηv).
rewrite -> proving_kl2.
rewrite -> cpr_inl.
rewrite <- proving_kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=ηv).
rewrite -> proving_kl2.
rewrite -> cpr_inl.
unfold coprodhom.
rewrite -> id_l.
rewrite -> id_l.
repeat rewrite <- comp_assoc with (h':=η).
repeat rewrite <- f_cpr.

rewrite -> H1.
unfold w.
rewrite <- comp_assoc with (f':=g).
reflexivity.

rewrite -> H2.
clear H2.

(* right hand side *)
unfold triangular.
rewrite <- comp_assoc with (h':=tuo).
rewrite <- comp_assoc with (g':=out).
rewrite -> comp_assoc with (g':=tuo).
rewrite -> out_tuo_is_id.
rewrite -> id_r.

rewrite -> comp_assoc with (g':=map (inl ⊕⊕ id)).
rewrite -> lifting_map.
rewrite -> lifting_map.

rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (g':=[ηv, iter_cofree t]).
rewrite -> cpr_inl.
rewrite -> out_unitcofree.
rewrite -> id_l.

rewrite -> Hq.

rewrite <- comp_assoc with (f':=h).
rewrite <- comp_assoc with (g':=map ([inl ⊕⊕ id, inl ∘ inr])).
apply f_equal2.
unfold coprodhom.
rewrite -> id_l.
unfold map.
rewrite -> f_cpr.
rewrite -> comp_assoc.
reflexivity.

apply f_equal1.
rewrite -> comp_assoc with (f':=out ∘ h).
apply f_equal2;trivial.
unfold q.
rewrite <- comp_assoc with (f':=map ([inl ⊕⊕ id, inl ∘ inr])).
rewrite -> map_comp.
rewrite -> lifting_map.
apply f_equal1.
rewrite -> comp_assoc with (g':=(id ⊕⊕ id ×× ([ηv ∘ inl, g]) § ^^ id) ⊕⊕ id).
rewrite -> cpr_coprodhom.
rewrite -> id_l.
reflexivity.

symmetry.
apply unfolding_triangular2.

rewrite -> H0.

rewrite <- proving_kl3.
rewrite -> f_cpr.
rewrite -> comp_assoc with (f':=inl).
rewrite -> proving_kl2.
rewrite -> cpr_inl.
rewrite <- unfolding_triangular1.
unfold w.
reflexivity.

Qed.
*)

(*
(* --- *)

Theorem proving_codiagonal : forall x y (g: x ~> (coext T a b (y ⊕ (x ⊕ x)))),
    iter_cofree (lifting_cofree (ηv ∘ id ⊕⊕ ∇) ∘ g) = iter_cofree (iter_cofree g).
Admitted.

(* --- *)
*)

Theorem proving_uniformity_guarded : forall x y z (f : x ~> coext T a b (y ⊕ x)) (g: z ~> coext T a b (y ⊕ z)) (h: z ~> x),
    guarded g ->
    f ∘ h = lifting_cofree (ηv ∘ id ⊕⊕ h) ∘ g ->
    iter_cofree f ∘ h = iter_cofree g.
Proof.
intros.
apply unfolding_guarded2.
apply H.
assert (H1: ([ηv, iter_cofree f ∘ h]) § = ([ηv, iter_cofree f]) § ∘ (ηv ∘ id ⊕⊕ h) §).
rewrite <- proving_kl3.
rewrite -> comp_assoc.
rewrite -> proving_kl2.
rewrite -> cpr_coprodhom.
rewrite -> id_l.
reflexivity.
rewrite -> H1.
rewrite <- comp_assoc.
rewrite <- H0.
rewrite -> comp_assoc.
rewrite -> proving_unfolding.
reflexivity.
Qed.

Theorem proving_uniformity : forall x y z (f : x ~> coext T a b (y ⊕ x)) (g: z ~> coext T a b (y ⊕ z)) (h: z ~> x),
    f ∘ h = lifting_cofree (ηv ∘ id ⊕⊕ h) ∘ g ->
    iter_cofree f ∘ h = iter_cofree g.
Proof.
intros.

assert (H1: (map ([inl ⊕⊕ id, inl ∘ inr]) ∘ out ∘ f) † ∘ h =
              map (id ⊕⊕ id ×× map_cofree (id ⊕⊕ h) ^^ id) ∘
              (map ([inl ⊕⊕ id, inl ∘ inr]) ∘ out ∘ g) †).

symmetry.
unfold map at 1.
rewrite -> naturality.
symmetry.
apply uniformity.
rewrite <- comp_assoc.
rewrite -> H.
rewrite <- comp_assoc with (g':=out).
rewrite -> comp_assoc with (h':=out).
rewrite -> lifting1.
rewrite -> comp_assoc with (h':=out).
rewrite -> out_unitcofree.

rewrite <- comp_assoc with (f':=g).
rewrite <- comp_assoc with (f':=g).
rewrite -> comp_assoc with (f':=out ∘ g).
rewrite -> comp_assoc with (f':=out ∘ g).
rewrite -> comp_assoc with (f':=out ∘ g).
apply f_equal2;trivial.

rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> lifting_map.
rewrite <- kl3.
rewrite -> map_lifting.
apply f_equal1.
rewrite -> f_cpr.
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite -> comp_assoc with (g':=inl).
rewrite <- comp_assoc with (h':=η).
rewrite -> cpr_inl.
rewrite <- comp_assoc with (h':=η).
rewrite -> coprodhom_comp.
rewrite -> id_r.
rewrite -> id_l.
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite -> comp_assoc with (g':=inr).
rewrite <- comp_assoc with (h':=η).
rewrite -> cpr_inr.
rewrite -> f_cpr.
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inl).
rewrite -> coprodhom_inl.
rewrite ->2 id_l.
rewrite ->2 comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite <-2 comp_assoc with (f':=inr).
rewrite -> coprodhom_inr.
rewrite -> f_cpr.
rewrite <-3 comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite ->2 comp_assoc with (g':=inl).
rewrite <-2 comp_assoc with (f':=inl).
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> comp_assoc with (g':=inl).
rewrite <- comp_assoc with (g':=id ⊕⊕ h).
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> comp_assoc with (g':=inr).
rewrite <- comp_assoc with (g':=id ⊕⊕ h).
rewrite -> coprodhom_inr.
rewrite -> mapcofree.
unfold coprodhom.
rewrite -> f_cpr.
repeat rewrite -> comp_assoc.
reflexivity.

assert (H2: (▷f) ∘ h = map_cofree (id ⊕⊕ h) ∘ ▷g).
unfold triangular.
rewrite <- comp_assoc.
rewrite -> H1.
rewrite ->2 comp_assoc.
apply f_equal2;trivial.
(* introduce new lemma for this ? see also lemma 22 in the paper *)
apply out_cong.
rewrite -> comp_assoc with (g':=map_cofree (id ⊕⊕ h)).
rewrite -> out_mapcofree.
rewrite ->2 comp_assoc with (h':=out).
rewrite -> out_tuo_is_id.
rewrite -> id_r.
(* since the introduction of cont, this doesn't work anymore TODO *)
Admitted.
(*
rewrite <- comp_assoc with (g':=out).
rewrite -> comp_assoc with (g':=tuo).
rewrite -> out_tuo_is_id.
rewrite -> id_r.
rewrite ->2 map_comp.
rewrite ->2 coprodhom_comp.
rewrite -> id_l.
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite -> id_r.
rewrite -> id_l.
reflexivity.

rewrite -> itercofree_triangular.
symmetry.
rewrite -> itercofree_triangular.
symmetry.
apply proving_uniformity_guarded.
apply guardedtriangular_def.
rewrite <- mapcofree.
apply H2.

Qed.
*)

(* --- *)
Theorem proving_str1 : forall (x y : Obj),
    pr2 = (ηv ∘ pr2) § ∘ τv (x:=x) (y:=y) (a:=a) (b:=b).
Proof.
intros.
rewrite <- mapcofree.
(*
assert (pr2 (a:=x) (b:=coext T a b y) = map_cofree (pr2 (a:=x) (b:=y)) ∘ (map_cofree (pair bang id) ∘ pr2)).
rewrite -> comp_assoc.
rewrite -> mapcofree_comp.
rewrite -> pr2_pair.
rewrite -> mapcofree_id.
rewrite -> id_r.
trivial.

rewrite -> H.
*)
Admitted.

Theorem proving_str2 : forall (x y z : Obj),
    (ηv ∘ prod_assoc1)§ ∘ τv (x:=(x × y)) (y:=(coext T a b (coext T a b z))) (a:=a) (b:=b) =
    τv ∘ id ×× τv ∘ prod_assoc1.
Admitted.

Theorem proving_str3 :forall (x y : Obj),
    τv (x:=x) (y:=y) (a:=a) (b:=b) ∘ id ×× ηv = ηv.
Admitted.

Theorem proving_str4 : forall x y (f: coext T a b x ~> coext T a b (coext T a b y)),
    (τv ∘ id ×× f) § ∘ τv = τv ∘ id (a:=x) ×× f §.
Admitted.

(* --- *)

Definition ηv' (x : Obj) :=
ηv (x:=x) (a:=a) (b:=b).

Definition lifting_cofree' (x y : Obj) (f: x ~> coext T a b y) :=
lifting_cofree (x:=x) (y:=y) (a:=a) (b:=b) f.

Definition iter_cofree' (x y : Obj) (f: x ~> coext T a b (y ⊕ x)) :=
coit ([[η ∘ inl, (map ([inl ⊕⊕ id, inl ∘ inr]) ∘ out ∘ f) †], η ∘ inr]* ∘ out) ∘
ηv ∘ inr.

Definition τv' (x y : Obj) :=
τv (x:=x) (y:=y) (a:=a) (b:=b).

(* Proof that a cofree extension is an ElgotMonad *)
Instance cofree : ElgotMonad Obj Hom (coext T a b) := {
    η := ηv';
    lifting := lifting_cofree';
    iter := iter_cofree';
    τ := τv'
}.

Proof.

intros.
apply dist1.
intros.
apply prod_assoc2.
intros.
apply coprod_assoc1.
intros.
apply coprod_assoc2.

apply comp_assoc.

intros.
apply id_l.
intros.
apply id_r.

apply proving_kl1.

apply proving_kl2.

apply proving_kl3.

apply proving_unfolding.

apply proving_naturality.

apply proving_dinaturality.

(* codiagonal *)

(* uniformity *)

(* str1 *)
(* str2 *)
(* str3 *)
(* str4 *)

(* compcpr *)
(* inlcpr *)
(* inrcpr *)
(* inlinrisid *)

(* comppair *)
(* pr1pair *)
(* pr2pair *)
(* pr1pr2isid *)

(* curryevid *)
(* ev_law *)
(* curry1 *)

(* TODO *)
Admitted.

End ContextCofreeElgotMonad.


Require Export MetaCoq.Template.All.
(* Require Import MetaCoq.Checker.All. *)

Require Import MetaCoq.Template.Checker.

Definition eq_predicate {T: Type} (eq_T: T -> T -> bool) (l r: predicate T) : bool :=
  forallb2 eq_T l.(pparams) r.(pparams) && eq_T l.(preturn) r.(preturn).

Definition eqb_univ (u1 u2 : Universe.t) : bool :=
  match u1, u2 with
  | Universe.lSProp, Universe.lSProp => true
  | Universe.lProp, Universe.lProp => true
  | Universe.lType _, Universe.lType _ => true
  | _, _ => false
  end.

Fixpoint extract_ctor (t: term) : term :=
  match t with
  | tApp f _ =>
    extract_ctor f
  | _ => t
  end.

Fixpoint eq_term (l r: term) : bool :=
  match l with
  | tRel n =>
    match r with
    | tRel n' => PeanoNat.Nat.eqb n n'
    | _ => false
    end
  | tVar id =>
    match r with
    | tVar id' => String.eqb id id'
    | _ => false
    end
  | tEvar ev args =>
    match r with
    | tEvar ev' args' => (Nat.eqb ev ev' && forallb2 eq_term args args')%bool
    | _ => false
    end
  | tSort lu =>
    match r with
    | tSort ru => eqb_univ lu ru
    | _ => false
    end
  | tCast f _ T =>
    match r with
    | tCast f' _ T' => (eq_term f f' && eq_term T T')%bool
    | _ => false
    end
  | tProd _ b t0 =>
    match r with
    | tProd _ b' t' => (eq_term b b' && eq_term t0 t')%bool
    | _ => false
    end
  | tLambda _ b t0 =>
    match r with
    | tLambda _ b' t' => (eq_term b b' && eq_term t0 t')%bool
    | _ => false
    end
  | tLetIn _ b t0 c =>
    match r with
    | tLetIn _ b' t' c' => (eq_term b b' && eq_term t0 t' && eq_term c c')%bool
    | _ => false
    end
  | tApp f args =>
    match r with
    | tApp f' args' => (eq_term f f' && forallb2 eq_term args args')%bool
    | _ => false
    end
  | tConst c _ =>
    match r with
    | tConst c' _ => eq_constant c c'
    | _ => false
    end
  | tInd i _ =>
    match r with
    | tInd i' _ => eq_inductive i i'
    | _ => false
    end
  | tConstruct i k _ =>
    match r with
    | tConstruct i' k' _ => (eq_inductive i i' && PeanoNat.Nat.eqb k k')%bool
    | _ => false
    end
  | tCase c_info p c brs =>
      match r with
      | tCase c_info' p' c' brs' =>
        (eq_inductive c_info.(ci_ind) c_info'.(ci_ind) &&
          eq_predicate eq_term p p' && eq_term c c' &&
          forallb2 (fun l r => eq_term l.(bbody) r.(bbody)) brs brs')%bool
      | _ => false
      end
  | tProj p c =>
    match r with
    | tProj p' c' => (eq_projection p p' && eq_term c c')%bool
    | _ => false
    end
  | tFix mfix idx =>
    match r with
    | tFix mfix' idx' =>
      (forallb2
          (fun x y : def term =>
          eq_term (dtype x) (dtype y) &&
          eq_term (dbody x) (dbody y)) mfix mfix' &&
        PeanoNat.Nat.eqb idx idx')%bool
    | _ => false
    end
  | tCoFix mfix idx =>
    match r with
    | tCoFix mfix' idx' =>
      (forallb2
          (fun x y : def term =>
          eq_term (dtype x) (dtype y) &&
          eq_term (dbody x) (dbody y)) mfix mfix' &&
        PeanoNat.Nat.eqb idx idx')%bool
    | _ => false
    end
  end.

Definition eq_ctor (l r: term) : bool :=
  match l, r with
  | tApp l' _, tApp r' _ => eq_term l' r'
  | tApp l' _, _ => eq_term l' r
  | _, tApp r' _ => eq_term l r'
  | _, _ => false
  end.

Definition eq_prefix (l r: term) : bool :=
  match l, r with
  | tApp l' args_l, tApp r' args_r =>
    eq_term l' r' &&
    let common_pref := List.combine args_l args_r in
    let common_res := List.map (fun '(x, y) => eq_term x y) common_pref in
    List.fold_left andb common_res true
  | tApp l' _, _ => eq_term l' r
  | _, tApp r' _ => eq_term l r'
  | _, _ => eq_term l r
  end.


Inductive R {A} : A -> A -> Type := c : forall x y, R x y.

Goal forall A (x y : A) P (e : R x y) (f : forall x y, P x y (c x y)),
  let g := match e in R x y return P x y e with c x y => f x y end in
  True.
Proof.
intros A x y P e f g.
let t := eval red in g in
match t with
  (match ?E as e in R x y return @?P x y e with c X Y => @?f X Y end) => idtac P f
end.
Abort.