Require Import LogicMain.
Import ListNotations.

Obligation Tactic := congruence.

Context `{EqDec (nat -> nat) eq} (Hfil: `{EqDec (nat -> bool) eq}).

Inductive ports := A | B | C | D | E | F | G.

Program Instance portsEq : EqDec ports eq :=
	{equiv_dec x y :=
		match x, y with
		| A,A => in_left
		| B,B => in_left
		| C,C => in_left
		| D,D => in_left
		| E,E => in_left
		| F,F => in_left
		| G,G => in_left
		| A,B => in_right
		| A,C => in_right
		| A,D => in_right
		| A,E => in_right
		| A,F => in_right
		| A,G => in_right
		| B,A => in_right
		| B,C => in_right
		| B,D => in_right
		| B,E => in_right
		| B,F => in_right
		| B,G => in_right
		| C,A => in_right
		| C,B => in_right
		| C,D => in_right
		| C,E => in_right
		| C,F => in_right
		| C,G => in_right
		| D,A => in_right
		| D,B => in_right
		| D,C => in_right
		| D,E => in_right
		| D,F => in_right
		| D,G => in_right
		| E,A => in_right
		| E,B => in_right
		| E,C => in_right
		| E,D => in_right
		| E,F => in_right
		| E,G => in_right
		| F,A => in_right
		| F,B => in_right
		| F,C => in_right
		| F,D => in_right
		| F,E => in_right
		| F,G => in_right
		| G,A => in_right
		| G,B => in_right
		| G,C => in_right
		| G,D => in_right
		| G,E => in_right
		| G,F => in_right
		end
	}.

Inductive statesLossyFifo := D_A | D_B | D_C | D_BFIFOC.

Program Instance statesLossyFifoEqDec : EqDec statesLossyFifo eq :=
	{equiv_dec x y :=
		match x, y with
		| D_A,D_A => in_left
		| D_B,D_B => in_left
		| D_C,D_C => in_left
		| D_BFIFOC,D_BFIFOC => in_left
    | D_A,D_B => in_right
		| D_A,D_C => in_right
		| D_A,D_BFIFOC => in_right
    | D_B,D_A => in_right
		| D_B,D_C => in_right
		| D_B,D_BFIFOC => in_right
    | D_C,D_A => in_right
		| D_C,D_B => in_right
    | D_C, D_BFIFOC => in_right
		| D_BFIFOC,D_A => in_right
    | D_BFIFOC,D_B => in_right
		| D_BFIFOC,D_C => in_right

		end
	}.

Inductive statesSequencer := DA | DB | DC | DD | DE | DF | DG | D_DFIFOE | D_EFIFOF | D_FFIFOG.

Program Instance statesEqDec : EqDec statesSequencer eq :=
	{equiv_dec x y :=
		match x, y with
		| DA,DA => in_left
		| DB,DB => in_left
    | DD,DD => in_left
		| DC,DC => in_left
		| DE,DE => in_left
		| DF,DF => in_left
		| DG,DG => in_left
		| D_DFIFOE,D_DFIFOE => in_left
		| D_EFIFOF,D_EFIFOF => in_left
		| D_FFIFOG,D_FFIFOG => in_left
		| DA,DB => in_right
		| DA,DC => in_right
    | DA,DD => in_right
		| DA,DE => in_right
		| DA,DF => in_right
		| DA,DG => in_right
		| DA,D_DFIFOE => in_right
		| DA,D_EFIFOF => in_right
		| DA,D_FFIFOG => in_right
		| DB,DA => in_right
		| DB,DC => in_right
    | DB,DD => in_right
		| DB,DE => in_right
		| DB,DF => in_right
		| DB,DG => in_right
		| DB,D_DFIFOE => in_right
		| DB,D_EFIFOF => in_right
		| DB,D_FFIFOG => in_right
		| DC,DA => in_right
		| DC,DB => in_right
    | DC,DD => in_right
		| DC,DE => in_right
		| DC,DF => in_right
		| DC,DG => in_right
		| DC,D_DFIFOE => in_right
		| DC,D_EFIFOF => in_right
		| DC,D_FFIFOG => in_right
		| DE,DA => in_right
		| DE,DB => in_right
    | DE,DD => in_right
		| DE,DC => in_right
		| DE,DF => in_right
		| DE,DG => in_right
		| DE,D_DFIFOE => in_right
		| DE,D_EFIFOF => in_right
		| DE,D_FFIFOG => in_right
		| DF,DA => in_right
		| DF,DB => in_right
    | DF,DD => in_right
		| DF,DC => in_right
		| DF,DE => in_right
		| DF,DG => in_right
		| DF,D_DFIFOE => in_right
		| DF,D_EFIFOF => in_right
		| DF,D_FFIFOG => in_right
		| DG,DA => in_right
		| DG,DB => in_right
		| DG,DC => in_right
    | DG,DD => in_right
		| DG,DE => in_right
		| DG,DF => in_right
		| DG,D_DFIFOE => in_right
		| DG,D_EFIFOF => in_right
		| DG,D_FFIFOG => in_right
		| D_DFIFOE,DA => in_right
		| D_DFIFOE,DB => in_right
		| D_DFIFOE,DC => in_right
		| D_DFIFOE,DD => in_right
		| D_DFIFOE,DE => in_right
		| D_DFIFOE,DF => in_right
		| D_DFIFOE,DG => in_right
		| D_DFIFOE,D_EFIFOF => in_right
		| D_DFIFOE,D_FFIFOG => in_right
		| D_EFIFOF,DA => in_right
		| D_EFIFOF,DB => in_right
		| D_EFIFOF,DC => in_right
		| D_EFIFOF,DD => in_right
		| D_EFIFOF,DE => in_right
		| D_EFIFOF,DF => in_right
		| D_EFIFOF,DG => in_right
		| D_EFIFOF,D_DFIFOE => in_right
		| D_EFIFOF,D_FFIFOG => in_right
		| D_FFIFOG,DA => in_right
		| D_FFIFOG,DB => in_right
		| D_FFIFOG,DC => in_right
		| D_FFIFOG,DD => in_right
		| D_FFIFOG,DE => in_right
		| D_FFIFOG,DF => in_right
		| D_FFIFOG,DG => in_right
		| D_FFIFOG,D_DFIFOE => in_right
		| D_FFIFOG,D_EFIFOF => in_right
    | DD,DA => in_right
    | DD,DB => in_right
		| DD,DC => in_right
		| DD,DE => in_right
		| DD,DF => in_right
		| DD,DG => in_right
		| DD,D_DFIFOE => in_right
		| DD,D_EFIFOF => in_right
		| DD,D_FFIFOG => in_right
		end
	}.

Close Scope Q_scope.

Check formula_eqDec.

Check dataProp_eqdec.

Definition lossyFifoProgram := [flowLossySync nat A B;flowFifo nat B C].

Definition t' := [dataPorts A 0].

Definition pi' := sProgram (reoProg lossyFifoProgram []).

Definition piStar := star (reoProg lossyFifoProgram []).

Definition formula1 := formula2Tableau
  (box t' pi'
    (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)))).

Definition formula2 := {|
         proofTree :=
           leaf
             (0,
             (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)),
             true));
         statesTree := []
       |}.

Eval compute in formula1.

Eval compute in formula2.

 Program Instance dataProp_eqdec : EqDec (dataProp ports nat) eq :=
   {
    equiv_dec x y (* := fix rec x y *) :=
      match x, y with
        | dataInPorts a x, dataInPorts b y => if a == b then if x == y then in_left else in_right else in_right
        | dataInFifo a x b, dataInFifo c y d => if a == c then if b == d then if x == y then in_left else in_right else in_right else in_right
        | dataBothPorts _ a b, dataBothPorts _ c d => if a == c then if b == d then in_left else in_right else in_right
 (*        | quiFormulaBox x phi, quiFormulaBox y phi' => if x == y then if rec phi phi' then in_left else in_right else in_right
        | quiFormulaDia  x phi, quiFormulaDia y phi' => if x == y then if rec phi phi' then in_left else in_right else in_right *)
        | dataInPorts a x , dataInFifo b y c => in_right
        | dataInPorts a x , dataBothPorts _ b y => in_right
(*         | dataInPorts a x , quiFormulaBox y phi' => in_right
        | dataInPorts a x , quiFormulaDia y phi' => in_right *)
        | dataInFifo a x b , dataInPorts c y => in_right
        | dataInFifo a x b , dataBothPorts _ c y => in_right
(*         | dataInFifo a x b , quiFormulaBox y phi' => in_right
        | dataInFifo a x b , quiFormulaDia y phi' => in_right *)
        | dataBothPorts _ a b , dataInPorts c y => in_right
        | dataBothPorts _ a b , dataInFifo c y d  => in_right
(*         | dataBothPorts _ a b , quiFormulaBox x phi  => in_right
        | dataBothPorts _ a b , quiFormulaDia x phi  => in_right *)
(*         | quiFormulaBox x phi , dataInPorts c y => in_right
        | quiFormulaBox x phi , dataInFifo c y d  => in_right
        | quiFormulaBox x phi , dataBothPorts _ a b => in_right
        | quiFormulaBox x phi, quiFormulaDia y phi' => in_right
        | quiFormulaDia x phi , dataInPorts c y => in_right
        | quiFormulaDia x phi , dataInFifo c y d  => in_right
        | quiFormulaDia x phi, dataBothPorts _ a b => in_right
        | quiFormulaDia x phi , quiFormulaBox y phi' => in_right *)
      end
  }.

(*To employ the tableau, one needs to supply the equality relation defined, the proof tree and
  the specificnode content (i.e, the state, the formulae and its value in the state to apply the
  corresponding rule to the corresponding node *)

Definition formulaApp1 := applyRule (formula_eqDec Hfil portsEq nat_eqDec) (formula1)
    (0,
             (box [dataPorts A 0]
                (sProgram
                   (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                (or (proposition (dataInPorts A 1))
                   (proposition (dataInPorts B 1))), false)) 1 0 0 0

(0,
             (box [dataPorts A 0]
                (sProgram
                   (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                (or (proposition (dataInPorts A 1))
                   (proposition (dataInPorts B 1))), false)).

Definition formulaApp2 := tableauRules (formula_eqDec Hfil portsEq nat_eqDec)
  (proofTree(formula2)).

Eval compute in formulaApp1.

Definition formulaCompApp1 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
            (formulaApp1)
               (1,
                (or (proposition (dataInPorts A 1))
                   (proposition (dataInPorts B 1)), false)) 1 0 0 0
               (1,
                (or (proposition (dataInPorts A 1))
                   (proposition (dataInPorts B 1)), false)).

Eval compute in formulaCompApp1.

Definition test2 := formula2Tableau (or (proposition (dataInPorts A 1))
                   (proposition (dataInPorts B 1))).

Eval compute in test2.

Eval compute in applyRule (formula_eqDec Hfil portsEq nat_eqDec) (test2)
(0,
             (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)),
             false)) 0 0 0 0 (0,
             (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)),
             false)).

Definition testNoBox := formula2Tableau (imp
    (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)))
        (proposition (dataInPorts B 1))).

Eval compute in testNoBox.

Definition testNoBoxAppRule := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
    ((testNoBox))
(0,
             (imp
                (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)))
                (proposition (dataInPorts B 1)), false)) 0 0 0 0
(0,
             (imp
                (or (proposition (dataInPorts A 1))
                   (proposition (dataInPorts B 1)))
                (proposition (dataInPorts B 1)), false)).

Eval compute in testNoBoxAppRule.

Definition testNoBoxAppRule2 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
testNoBoxAppRule
(0,
                (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)),
                true)) 0 0 0 0

(0, (proposition (dataInPorts B 1), false)).

Eval compute in testNoBoxAppRule.

Eval compute in testNoBoxAppRule2.

(*box tests*)
Definition formula1Star := formula2Tableau
  (diamond t' piStar
    (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)))).

Eval compute in formula1Star.

Eval compute in applyRule (formula_eqDec Hfil portsEq nat_eqDec)
formula1Star
(0,
             (diamond [dataPorts A 0]
                (star (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1))),
             false)) 0 0 0 0

(0,
             (diamond [dataPorts A 0]
                (star
                   (reoProg [flowLossySync nat A B; flowFifo nat B C]
                      []))
                (or (proposition (dataInPorts A 1))
                   (proposition (dataInPorts B 1))), false)).

Definition formula2Star := formula2Tableau
  (imp (diamond t' piStar
    (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1))))
(diamond t' piStar
    (or (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1))))).

Eval compute in formula2Star.

Definition formula2StarAppRule := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
formula2Star (0,
             (imp
                (diamond [dataPorts A 0]
                   (star (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                   (or (proposition (dataInPorts A 1))
                      (proposition (dataInPorts B 1))))
                (diamond [dataPorts A 0]
                   (star (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                   (or (proposition (dataInPorts A 1))
                      (proposition (dataInPorts B 1)))), false)) 0 0 0 0
(0,
             (imp
                (diamond [dataPorts A 0]
                   (star (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                   (or (proposition (dataInPorts A 1))
                      (proposition (dataInPorts B 1))))
                (diamond [dataPorts A 0]
                   (star (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                   (or (proposition (dataInPorts A 1))
                      (proposition (dataInPorts B 1)))), false)).

Eval compute in formula2StarAppRule.

Definition formula2StarAppRule2 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
formula2StarAppRule (0,
                (diamond [dataPorts A 0]
                   (star (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                   (or (proposition (dataInPorts A 1))
                      (proposition (dataInPorts B 1))), true)) 0 0 0 0
 (0,
                   (diamond [dataPorts A 0]
                      (star (reoProg [flowLossySync nat A B; flowFifo nat B C] []))
                      (or (proposition (dataInPorts A 1))
                         (proposition (dataInPorts B 1))), false)).

Eval compute in formula2StarAppRule2.

Variable varphi psi : formula ports nat.

Check t'.

Variable t : set (dataConnector ports nat).

(*Tableau axiom proofs*)

(**Axiom K**)
Definition axiomKTableau :=

(imp ((box [] (sProgram (reoProg [flowLossySync nat A B] []))
              (imp (proposition (dataInPorts A 1))
                   (proposition (dataInPorts B 1)))))

     (imp ((box [] (sProgram (reoProg [flowLossySync nat A B] [])))
          (proposition (dataInPorts A 1)))
          ((box [] (sProgram (reoProg [flowLossySync nat A B] [])))
          (proposition (dataInPorts B 1))))).

Definition formula2TableauK := formula2Tableau axiomKTableau.

Eval compute in formula2TableauK.

(*Rule application 1*)
Definition formula2TableauKApp1 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
  formula2TableauK
 (0,
             (imp
                (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                   (imp (proposition (dataInPorts A 1))
                      (proposition (dataInPorts B 1))))
                (imp
                   (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                      (proposition (dataInPorts A 1)))
                   (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                      (proposition (dataInPorts B 1)))), false)) 0 0 0 0

(0,
             (imp
                (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                   (imp (proposition (dataInPorts A 1))
                      (proposition (dataInPorts B 1))))
                (imp
                   (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                      (proposition (dataInPorts A 1)))
                   (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                      (proposition (dataInPorts B 1)))), false)).

Eval compute in formula2TableauKApp1.
(*Rule Application 2*)

Definition formula2TableauKApp2 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
  formula2TableauKApp1
  (0,
                   (imp
                      (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                         (proposition (dataInPorts A 1)))
                      (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                         (proposition (dataInPorts B 1))), false)) 0 0 0 0
(0,
                   (imp
                      (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                         (proposition (dataInPorts A 1)))
                      (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                         (proposition (dataInPorts B 1))), false)).

Eval compute in formula2TableauKApp2.

(*Rule application 3*)

Definition formula2TableauKApp3 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
  formula2TableauKApp2
  (0,
                         (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                            (proposition (dataInPorts B 1)), false)) 1 0 0 0
  (0,
                         (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                            (proposition (dataInPorts B 1)), false)).

Eval compute in formula2TableauKApp3.

(*Rule appliaction 4*)

Definition formula2TableauKApp4 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
  formula2TableauKApp3
  (0,
                (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                   (imp (proposition (dataInPorts A 1))
                      (proposition (dataInPorts B 1))), true)) 1 1 0 0

  (1, (proposition (dataInPorts B 1), false)).

Eval compute in formula2TableauKApp4.

(*Rule application 5*)

Definition formula2TableauKApp5 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
  formula2TableauKApp4
  (1,
                               (imp (proposition (dataInPorts A 1))
                                  (proposition (dataInPorts B 1)), true)) 1 1 0 0

  (1,
                               (imp (proposition (dataInPorts A 1))
                                  (proposition (dataInPorts B 1)), true)).

Eval compute in formula2TableauKApp5.

Definition formula2TableauKApp6 := applyRule (formula_eqDec Hfil portsEq nat_eqDec)
  formula2TableauKApp5
  (0,
                      (box [] (sProgram (reoProg [flowLossySync nat A B] []))
                         (proposition (dataInPorts A 1)), true)) 1 1 0 0

  (1, (proposition (dataInPorts A 1), false)).

Eval compute in formula2TableauKApp6.

(*Check whether the tableau is closed *)

Eval compute in isTableauClosed (formula_eqDec Hfil portsEq nat_eqDec)
  (proofTree(formula2TableauKApp6)).


(* Compatibility with rationals from the standard library *)

From mathcomp Require Import ssreflect seq ssrfun ssrbool ssrnat eqtype.
Require Import reals all_metrics all_metric_spaces standard.
From mf Require Import all_mf.
Require Import Qreals Reals Psatz ClassicalChoice FunctionalExtensionality.

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

Import QArith.
Local Open Scope R_scope.
Local Open Scope metric_scope.

Section rationals_as_reals.
  Coercion IZR: Z >-> R.
  Fixpoint Pos_size p :=
    match p with
    | xH => 1%nat
    | xI p' => S (Pos_size p')
    | xO p' => S (Pos_size p')
    end.

  Lemma Pos_size_gt0 p: (0 < Pos_size p)%nat.
  Proof. by elim p. Qed.

  Definition Z_size z:=
    match z with
    | Z0 => 0%nat
    | Z.pos p => Pos_size p
    | Z.neg p => Pos_size p
    end.

  Lemma Z_size_eq0 z: Z_size z = 0%nat <-> z = 0%Z.
  Proof.
    split => [ | ->]//.
    case: z => // p/=; have := Pos_size_gt0 p => /leP ineq eq; rewrite eq in ineq; lia.
  Qed.

  Lemma Z_size_lt z: IZR z < 2 ^ (Z_size z).
  Proof.
    rewrite pow_IZR; apply IZR_lt; rewrite -two_power_nat_equiv.
    elim: z => // p; elim: p => // p /= ih.
    rewrite !Pos2Z.inj_xI two_power_nat_S.
    have ineq: (Z.pos p + 1 <= two_power_nat (Pos_size p))%Z by lia.
    by apply/ Z.lt_le_trans; last apply Zmult_le_compat_l; [ | apply ineq | ]; lia.
  Qed.

  Lemma Qnum_gt:
	forall eps: Q, (0 < eps)%Q -> (0 < Qnum eps)%Z.
  Proof.
    move => eps epsg0.
    rewrite Zlt_Qlt/inject_Z.
    have eq: eps == Qnum eps # Qden eps by trivial.
    have lt: (0 * (Z.pos (Qden eps)#1) < eps * ((Z.pos (Qden eps))#1))%Q by apply Qmult_lt_compat_r.
    apply Rlt_Qlt.
    have:= (Qlt_Rlt (0 * (Z.pos (Qden eps) # 1)) (eps * (Z.pos (Qden eps) # 1)) (lt)).
    rewrite Q2R_mult /Q2R/= mult_IZR Pos.mul_1_r !Rmult_assoc Rinv_r; last exact: IZR_nz.
    by rewrite Rinv_1.
  Qed.

  Lemma size_Qden eps: 0 < Q2R eps -> /2^(Pos_size (Qden eps)) <= Q2R eps.
  Proof.
    move => ineq; rewrite /Q2R/Rdiv /Qdiv -[/_]Rmult_1_l.
    apply Rmult_le_compat; [ | apply Rlt_le; apply Rinv_0_lt_compat; apply pow_lt | | ]; try lra.
    - apply IZR_le; suff: (0 < Qnum eps)%Z by lia.
      by apply Qnum_gt; apply Rlt_Qlt; rewrite {1}/Q2R/=; try lra.
    apply Rinv_le_contravar; first exact /IZR_lt/Pos2Z.is_pos.
    by have /=:= Z_size_lt (Z.pos (Qden eps)); lra.
  Qed.

  Lemma accf_Q2R_0: acc_f_zero_plus Q2R.
  Proof.
    move=> r rPos.
    have ir_Pos : 0 < /r by apply: Rinv_0_lt_compat.
    pose z := up (/ r).
    have irLz : / r < IZR z by rewrite /z; have := archimed (/ r); lra.
    have zPos : 0 < IZR z by lra.
    pose p := Z.to_pos z.
    have pE : (Z.pos p)%Z = z by rewrite Z2Pos.id //; apply: lt_0_IZR.
    exists (1 # p).
    rewrite /Q2R /= pE Rmult_1_l; try lra.
    split; first by apply Rinv_0_lt_compat.
    rewrite -(Rinv_involutive r); try lra.
    by apply: Rinv_lt_contravar; try nra.
  Qed.

  Lemma Z_tech a b : (0 < b -> a / b * b > a  - b)%Z.
  Proof.
    move=> Pb; rewrite {2}(Z_div_mod_eq a b); try lia.
    suffices : (0 <= a mod b < b)%Z by lia.
    by apply: Z_mod_lt; lia.
  Qed.

  Definition Int_partQ eps := ((Qnum eps) / (Z.pos (Qden eps)))%Z.

  Lemma base_Int_partQ eps:
    Int_partQ eps <= Q2R eps /\ Q2R eps < Int_partQ eps + 1.
  Proof.
    have ineq: (Z.pos (Qden eps) > 0)%Z.
    - suffices: (0 < Z.pos (Qden eps))%Z by lia.
      apply lt_IZR; have <-: IPR (Qden eps) = Z.pos (Qden eps) by trivial.
      by rewrite -INR_IPR; apply/pos_INR_nat_of_P.
    split.
    - rewrite -(Rmult_1_r (Qnum eps / Z.pos (Qden eps))%Z).
      rewrite -(Rinv_r (Z.pos (Qden eps))); last exact: IZR_nz.
      rewrite -Rmult_assoc; apply/Rmult_le_compat_r.
      - by apply/Rlt_le/Rinv_0_lt_compat/IZR_lt; lia.
      by rewrite Rmult_comm -mult_IZR; apply/IZR_le/Z_mult_div_ge; lia.
    rewrite /Q2R/Int_partQ.
    have ineq': ((Qnum eps / Z.pos (Qden eps)) * (Z.pos (Qden eps)) > Qnum eps - Z.pos (Qden eps))%Z.
    - by apply/(@Z_tech (Qnum eps) (Z.pos (Qden eps))); lia.
    apply Rlt_gt.
    suffices ineq'': (Qnum eps - Z.pos (Qden eps)) < (Qnum eps / Z.pos (Qden eps))%Z * Z.pos (Qden eps).
    suffices:(Qnum eps * / Z.pos (Qden eps) - 1 < (Qnum eps / Z.pos (Qden eps))%Z) by lra.
    have ->: (Qnum eps * / Z.pos (Qden eps) - 1) = ((Qnum eps  - Z.pos (Qden eps))/ Z.pos (Qden eps)) by field.
    have ->: (IZR(Qnum eps / Z.pos (Qden eps))%Z) =
	((Qnum eps / Z.pos (Qden eps))%Z * Z.pos (Qden eps)/ Z.pos (Qden eps)) by field => //.
    by apply Rmult_lt_compat_r; first by apply/Rinv_0_lt_compat/IZR_lt; lia.
    by rewrite -mult_IZR -minus_IZR; apply IZR_lt; lia.
  Qed.

  Definition upQ eps:= (Int_partQ eps + 1)%Z.
  Lemma archimedQ r:
    IZR (upQ r) > Q2R r /\ IZR (upQ r) - Q2R r <= 1.
  Proof.
    have []:= base_Int_partQ r; rewrite plus_IZR; lra.
  Qed.

  Lemma Q_dense:
    (codom (F2MF Q2R)) \dense_subset.
  Proof.
    move => x eps eg0.
    have [q [qg0 qle]]:= accf_Q2R_0 eg0.
    have ieps_pos : 0 < /(Q2R q) by apply: Rinv_0_lt_compat.
    pose aprx:= (inject_Z (Int_part (x / Q2R q)) * q)%Q.
    exists (Q2R aprx); split; first by exists aprx.
    rewrite /distance/=/R_dist/=; have []:= base_Int_part (x / Q2R q); intros.
    have ->: x - Q2R aprx = (x / Q2R q - Int_part (x/Q2R q)) * Q2R q.
    - by rewrite /aprx Q2R_mult {1}/Q2R/=; field; lra.
    rewrite Rabs_mult !Rabs_pos_eq; last rewrite /Rdiv; try lra.
    by rewrite /Rdiv -(Rmult_1_l eps); apply/Rmult_le_compat; lra.
  Qed.

  Lemma Q_sur_dns (qn: sequence_in Q):
    qn \is_surjective -> (Q2R \o_f qn) \is_dense_sequence.
  Proof.
    move => sur; rewrite dseq_dns.
    suff ->: codom (F2MF (Q2R \o_f qn)) === codom (F2MF Q2R) by apply/Q_dense.
    rewrite -F2MF_comp_F2MF comp_rcmp; last exact/F2MF_tot.
    move => x; split => [[n [q []]] | [q <-]]; first by exists q.
    by have [n eq]:= sur q; exists n; exists q.
  Qed.
End rationals_as_reals.

Section rationals_and_metric_spaces.
  Context (M: MetricSpace).
  Implicit Types (x y: M).
  Notation subset := mf_set.subset.
  Lemma dense_Q (A: subset M): A \dense_subset <->
    forall x eps, 0 < Q2R eps -> exists y, y \from A /\ d(x, y) <= Q2R eps.
  Proof.
    split => dns x eps eg0; first exact/dns.
    have [q ineq]:= accf_Q2R_0 eg0.
    have [y []]:= dns x q ineq.1.
    exists y; split => //.
    exact/Rlt_le/Rle_lt_trans/ineq.2.
  Qed.

  Lemma cond_eq_Q x y:
    (forall q, d(x, y) <= Q2R q) -> x = y.
  Proof.
    move => prp; apply/dst0_eq/cond_eq_f; first exact/accf_Q2R_0.
    intros; rewrite/R_dist Rabs_pos_eq Rminus_0_r; first exact/prp.
    exact/dst_pos.
  Qed.

  Lemma limQ xn x: limit xn x <->
    forall eps, 0 < Q2R eps -> exists N, forall m, (N <= m)%nat -> d(x, xn m) <= Q2R eps.
  Proof.
    split => lim eps eg0; first exact/lim.
    have [q ineq]:= accf_Q2R_0 eg0.
    have [N prp]:= lim q ineq.1.
    exists N => m Nlm.
    exact/Rlt_le/Rle_lt_trans/ineq.2/prp.
  Qed.
End rationals_and_metric_spaces.


From SegmentQueue.lib.blocking_pool
     Require Export outer_storage_interfaces.
From iris.program_logic Require Import atomic.
From iris.heap_lang Require Export proofmode notation lang.

Definition option_to_value (v: option val): val :=
  match v with
    None => NONEV
  | Some v => SOMEV v
  end.

Theorem option_to_value_inj:
  FinFun.Injective option_to_value.
Proof.
  intros a b. rewrite /option_to_value.
  case: a; case: b=> //=.
  move=> a b. case. by intros ->.
Qed.

Inductive outerStorageState :=
  OuterStorageState {
      failuresInStorage: nat;
      valuesInStorage: gmultiset val
    }.

Definition insertionAddsValue (state: outerStorageState) (v: val) :=
  match state with
    OuterStorageState fs vs => OuterStorageState fs ({[v]} ⊎ vs)
  end.

Definition insertionRemovesFailure (state: outerStorageState) :=
  match state with
    OuterStorageState fs vs => match fs with
                                0 => None
                              | S fs => Some (OuterStorageState fs vs)
                              end
  end.

Definition retrievalAddsFailure (state: outerStorageState) :=
  match state with
    OuterStorageState fs vs => OuterStorageState (S fs) vs
  end.

Locate multiplicity.

Definition retrievalRemovesValue (state: outerStorageState) (value: val) :=
  match state with
    OuterStorageState fs vs =>
    match multiplicity value vs with
      0 => None
    | _ => Some (OuterStorageState fs (vs ∖ {[value]}))
    end
  end.

Record outerStorageSpec Σ `{!heapG Σ} (impl: outerStorageInterface) :=
  OuterStorageSpec {
      is_outer_storage:
        namespace -> gname -> val -> iProp Σ;
      is_outer_storage_persistent N γ s:
        Persistent (is_outer_storage N γ s);
      outer_storage_contents:
        gname -> outerStorageState -> iProp Σ;
      tryInsert_spec N γ s (value : val):
        is_outer_storage N γ s -∗
        <<< ∀ state, ▷ outer_storage_contents γ state >>>
            tryInsert impl s value @ ⊤∖↑N
        <<< ∃ (b: bool),
                if b then
                  outer_storage_contents γ (insertionAddsValue state value)
                else match insertionRemovesFailure state with
                       None => False
                     | Some state' => outer_storage_contents γ state'
                     end, RET #b >>>;
      tryRetrieve_spec N γ s:
         is_outer_storage N γ s -∗
         <<< ∀ state, ▷ outer_storage_contents γ state >>>
              tryRetrieve impl s @ ⊤ ∖ ↑N
         <<< ∃ (v : option val),
                 match v with
                   | Some v' => match retrievalRemovesValue state v' with
                                 | None => False
                                 | Some state' => outer_storage_contents γ state'
                               end
                   | None => outer_storage_contents γ (retrievalAddsFailure state)
                 end, RET option_to_value v >>>;
      newStorage_spec N:
         {{{ True }}}
           newStorage impl #()
         {{{ γ v, RET v; is_outer_storage N γ v
                 ∗ outer_storage_contents γ
                     {| failuresInStorage := 0; valuesInStorage := ∅ |} }}}
      }.

Existing Instances is_outer_storage_persistent.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Compare_dec.
Require Import ZArith.
Require Import Utils.
Require Import BrandRelation.
Require Import ForeignData.
Require Import Data.
Require Import DataLift.
Require Import DataNorm.
Require Import ForeignOperators.
Require Import OperatorsUtils.
Require Import Iterators.
Require Export BinaryOperators.

Section BinaryOperatorsSem.
  (* Algebra Unary/Binary Ops *)
  Definition nat_arith_binary_op_eval (op:nat_arith_binary_op) (z1 z2:Z) : Z :=
    match op with
    | NatPlus => Z.add z1 z2
    | NatMinus=> Z.sub z1 z2
    | NatMult => Z.mul z1 z2
    | NatMin => Z.min z1 z2
    | NatMax => Z.max z1 z2
    | NatDiv=> Z.quot z1 z2
    | NatRem => Z.rem z1 z2
    end.

  Definition float_arith_binary_op_eval (op:float_arith_binary_op) (f1 f2:float) : float :=
    match op with
    | FloatPlus => float_add f1 f2
    | FloatMinus => float_sub f1 f2
    | FloatMult => float_mult f1 f2
    | FloatDiv => float_div f1 f2
    | FloatPow => float_pow f1 f2
    | FloatMin => float_min f1 f2
    | FloatMax => float_max f1 f2
    end.

  Definition float_compare_binary_op_eval (op:float_compare_binary_op) (f1 f2:float) : bool :=
    match op with
    | FloatLt => float_lt f1 f2
    | FloatLe => float_le f1 f2
    | FloatGt => float_gt f1 f2
    | FloatGe => float_ge f1 f2
    end.

  Context (h:brand_relation_t).
  Context {fdata:foreign_data}.
  Context {foperators:foreign_operators}.

  Definition binary_op_eval (bop:binary_op) (d1 d2:data) : option data :=
    match bop with
    | OpEqual => unbdata (fun x y => if data_eq_dec x y then true else false) d1 d2
    | OpRecConcat =>
      match d1, d2 with
      | (drec r1), (drec r2) => Some (drec (rec_sort (r1++r2)))
      | _, _ => None
      end
    | OpRecMerge =>
      match d1, d2 with
      | (drec r1), (drec r2) =>
        match merge_bindings r1 r2 with
        | Some x => Some (dcoll ((drec x) :: nil))
        | None => Some (dcoll nil)
        end
      | _, _ => None
      end
    | OpAnd => unbdbool andb d1 d2
    | OpOr => unbdbool orb d1 d2
    | OpLt => unbdnat (fun x y => if Z_lt_dec x y then true else false) d1 d2
    | OpLe => unbdnat (fun x y => if Z_le_dec x y then true else false) d1 d2
    | OpBagUnion => rondcoll2 bunion d1 d2
    | OpBagDiff => rondcoll2 (@bminus data data_eq_dec) d2 d1
    | OpBagMin => rondcoll2 (@bmin data data_eq_dec) d1 d2
    | OpBagMax => rondcoll2 (@bmax data data_eq_dec) d1 d2
    | OpBagNth =>
      match d1, d2 with
      | (dcoll c), (dnat n) =>
        let natish := ZToSignedNat n in
        if (fst natish) then
          match List.nth_error c (snd natish) with
          | Some d => Some (dsome d)
          | None => Some dnone
          end
        else Some dnone
      | _, _ => None
      end
    | OpContains =>
      ondcoll (fun l =>
                 if in_dec data_eq_dec d1 l
                 then dbool true else dbool false) d2
    | OpStringConcat => unsdstring append d1 d2
    | OpStringJoin =>
      match d1, d2 with
      | (dstring sep), (dcoll c) =>
        lifted_join sep c
      | _, _ => None
      end
    | OpNatBinary op =>
        match d1, d2 with
        | dnat n1, dnat n2 => Some (dnat (nat_arith_binary_op_eval op n1 n2))
        | _, _ => None
        end
    | OpFloatBinary op =>
        match d1, d2 with
        | dfloat f1, dfloat f2 => Some (dfloat (float_arith_binary_op_eval op f1 f2))
        | _, _ => None
        end
    | OpFloatCompare op =>
        match d1, d2 with
        | dfloat f1, dfloat f2 => Some (dbool (float_compare_binary_op_eval op f1 f2))
        | _, _ => None
        end
    | OpForeignBinary fb => foreign_operators_binary_interp h fb d1 d2
    end.

  Hint Constructors data_normalized Forall : qcert.

  Lemma binary_op_eval_normalized {b d1 d2 o} :
    binary_op_eval b d1 d2 = Some o ->
    data_normalized h d1 -> data_normalized h d2 ->
    data_normalized h o.
  Proof.
    destruct b; simpl; intros;
      try solve [
            unfold rondcoll2 in *;
            destruct d1; simpl in *; try discriminate;
            destruct d2; simpl in *; try discriminate;
            inversion H; subst;
            eauto 1;
            inversion H; subst;
            constructor;
            inversion H0; inversion H1; subst;
            solve [apply bunion_Forall; trivial
                  | apply bminus_Forall; trivial
                  | apply bmin_Forall; trivial
                  | apply bmax_Forall; trivial]
          ].
    - do 2 match_destr_in H.
      inversion H; clear H; subst.
      apply data_normalized_rec_sort_app; trivial.
    - do 2 match_destr_in H.
      unfold merge_bindings in H.
      destruct (Compat.compatible l l0); inversion H; qeauto.
      constructor. constructor; trivial.
      apply data_normalized_rec_concat_sort; qtrivial.
    - do 2 match_destr_in H.
      destruct z; simpl in *; try discriminate.
      + destruct l; simpl in *.
        inversion H; subst; repeat constructor.
        inversion H; subst. inversion H0; simpl in *.
        rewrite Forall_forall in H3; simpl in H3.
        specialize (H3 d).
        constructor.
        apply H3; auto.
      + case_eq (nth_error l (Pos.to_nat p)); intros; rewrite H2 in H.
        * inversion H; clear H; subst.
          inversion H0; subst.
          apply nth_error_In in H2.
          rewrite Forall_forall in H3.
          specialize (H3 d H2).
          constructor; eauto.
        * inversion H; subst; repeat constructor.
      + inversion H; subst; repeat constructor.
    - destruct d2; simpl in *; try discriminate.
      match_destr_in H; inversion H; qeauto.
    - destruct d1; destruct d2; simpl in *; try discriminate.
      unfold lifted_join in H.
      apply some_lift in H; destruct H; subst.
      qeauto.
    - eapply foreign_operators_binary_normalized; eauto.
  Qed.

End BinaryOperatorsSem.


Set Universe Polymorphism.

(** Tests for module subtyping of polymorphic terms *)

Module Type S.

Section Foo.

Universes i j.
Constraint i <= j.

Parameter foo : Type@{i} -> Type@{j}.

End Foo.

End S.

(** Same constraints *)

Module OK_1.

Definition foo@{i j} (A : Type@{i}) : Type@{j} := A.

End OK_1.

Module OK_1_Test : S := OK_1.

(** More general constraints *)

Module OK_2.

Inductive X@{i} : Type@{i} :=.
Definition foo@{i j} (A : Type@{i}) : Type@{j} := X@{j}.

End OK_2.

Module OK_2_Test : S := OK_2.

(** Wrong instance length *)

Module KO_1.

Definition foo@{i} (A : Type@{i}) : Type@{i} := A.

End KO_1.

Fail Module KO_Test_1 : S := KO_1.

(** Less general constraints *)

Module KO_2.

Section Foo.

Universe i j.
Constraint i < j.

Definition foo (A : Type@{i}) : Type@{j} := A.

End Foo.

End KO_2.

Fail Module KO_Test_2 : S := KO_2.

(** Less general constraints *)

Module KO_3.

Section Foo.

Universe i j.
Constraint i = j.

Definition foo (A : Type@{i}) : Type@{j} := A.

End Foo.

End KO_3.

Fail Module KO_Test_3 : S := KO_3.


(** * Cokernels defined in terms of colimits. *)
(** ** Contents
- Definition coincides with direct definition
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.

Require Import UniMath.CategoryTheory.limits.graphs.limits.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.limits.graphs.zero.
Require Import UniMath.CategoryTheory.limits.graphs.coequalizers.
Require Import UniMath.CategoryTheory.limits.cokernels.

(** * Definition of cokernels in terms of colimits *)
Section def_cokernels.

  Variable C : category.
  Let hs: has_homsets C := homset_property C.
  Variable Z : Zero C.

  Definition Cokernel {a b : C} (f : C⟦a, b⟧) := Coequalizer C f (ZeroArrow Z a b).

  (** ** Coincides with the direct definiton *)
  Lemma equiv_Cokernel1_eq {a b : C} (f : C⟦a, b⟧)
        (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) :
    f · (CokernelArrow CK) = ZeroArrow Z a b · (CokernelArrow CK).
  Proof.
    rewrite CokernelCompZero. rewrite postcomp_with_ZeroArrow. apply equiv_ZeroArrow.
  Qed.

  Lemma equiv_Cokernel1_isCoequalizer {a b : C} (f : C⟦a, b⟧)
        (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) :
    isCoequalizer C f (ZeroArrow Z a b) CK (CokernelArrow CK) (equiv_Cokernel1_eq f CK).
  Proof.
    use (make_isCoequalizer _).
    intros w h H.
    use unique_exists.
    (* Construction of the morphism *)
    - use CokernelOut.
      + exact h.
      + rewrite postcomp_with_ZeroArrow in H.
        use (pathscomp0 _ (!(equiv_ZeroArrow a w Z))).
        exact H.
    (* Commutativity *)
    - use CokernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y T. cbn in T.
      use CokernelOutsEq. unfold CokernelArrow.
      use (pathscomp0 T). apply pathsinv0.
      use CokernelCommutes.
  Qed.

  Definition equiv_Cokernel1 {a b : C} (f : C⟦a, b⟧)
             (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) : Cokernel f.
  Proof.
    use make_Coequalizer.
    - exact CK.
    - exact (CokernelArrow CK).
    - exact (equiv_Cokernel1_eq f CK).
    - exact (equiv_Cokernel1_isCoequalizer f CK).
  Defined.

  (* Other direction *)

  Lemma equiv_Cokernel2_eq {a b : C} (f : C⟦a, b⟧) (CK : cokernels.Cokernel (equiv_Zero2 Z) f) :
    f · CokernelArrow CK = ZeroArrow Z a b · CokernelArrow CK.
  Proof.
    rewrite CokernelCompZero. rewrite postcomp_with_ZeroArrow. apply equiv_ZeroArrow.
  Qed.

  Lemma equiv_Cokernel2_isCoequalizer {a b : C} (f : C⟦a, b⟧)
        (CK : cokernels.Cokernel (equiv_Zero2 Z) f) :
    isCoequalizer C f (ZeroArrow Z a b) CK (CokernelArrow CK) (equiv_Cokernel2_eq f CK).
  Proof.
    use (make_isCoequalizer _ ).
    intros w h H.
    use unique_exists.
    (* Construction of the morphism *)
    - use CokernelOut.
      + exact h.
      + use (pathscomp0 H). apply pathsinv0. rewrite postcomp_with_ZeroArrow. apply equiv_ZeroArrow.
    (* Commutativity *)
    - use CokernelCommutes.
    (* Equality on equalities of morphisms *)
    - intros y. apply hs.
    (* Uniqueness *)
    - intros y T. cbn in T. use CokernelOutsEq. rewrite T. rewrite CokernelCommutes.
      apply idpath.
  Qed.

  Definition equiv_Cokernel2 {a b : C} (f : C⟦a, b⟧)
             (CK : limits.cokernels.Cokernel (equiv_Zero2 Z) f) : Cokernel f.
  Proof.
    use make_Coequalizer.
    - exact CK.
    - exact (CokernelArrow CK).
    - exact (equiv_Cokernel2_eq f CK).
    - exact (equiv_Cokernel2_isCoequalizer f CK).
  Defined.

End def_cokernels.


Require Import isla.isla.
Require Import isla.aarch64.aarch64.
Require Export isla.examples.pkvm_handler.a7408.

Lemma a7408_spec `{!islaG Σ} `{!threadG} pc:
  instr pc (Some a7408) -∗
  instr_body pc (lsr_R_spec pc "R0" 26).
Proof.
  iStartProof.
  repeat liAStep; liShow.
  Unshelve. all: prepare_sidecond.
  by bv_simplify; bitblast.
Qed.

Definition a7408_spec_inst `{!islaG Σ} `{!threadG} pc :=
  entails_to_simplify_hyp 0 (a7408_spec pc).
Global Existing Instance a7408_spec_inst.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e521m1_19limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Inductive queue : Type :=
  | Queue : lst -> lst -> queue.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Lemma len_pos: forall l, (len l) >= 0.
Proof.
  induction l.
  - simpl. apply le_0_n.
  - simpl. apply le_0_n.
Qed.

Definition qlen (q : queue) : nat :=
match q with
  | Queue l1 l2 => (len l1) + (len l2)
end.

Fixpoint app (l : lst) (m: lst): lst :=
match l with
  | Nil => m
  | Cons a l1 => Cons a (app l1 m)
end.

Fixpoint rev (l: lst): lst :=
match l with
  | Nil => Nil
  | Cons a l1 => app (rev l1) (Cons a Nil)
end.

Fixpoint leb (n m : nat) : bool :=
match (n, m) with
  | (0, _) => true
  | (S n', S m') => leb n' m'
  | _ => false
end.

Definition amortizeQueue (l1 l2 : lst) : queue :=
  if leb (len l2)  (len l1) then Queue l1 l2
  else Queue (app l1 (rev l2)) Nil.

Lemma len_app : forall l1 l2, len (app l1 l2) = (len l1) + (len l2).
Proof.
  intros. induction l1.
  - reflexivity.
  - simpl. rewrite IHl1. reflexivity.
Qed.

Lemma plus_comm: forall m n, m + n = n + m.
Proof.
induction m.
- intros. simpl. rewrite <- plus_n_O. reflexivity.
- intros. simpl. rewrite IHm. rewrite plus_n_Sm. reflexivity.
Qed.

Lemma len_rev : forall l, len (rev l) = len l.
Proof.
induction l.
- reflexivity.
- simpl. rewrite len_app. simpl. rewrite plus_comm. simpl. rewrite IHl. reflexivity.
Qed.

Theorem queue_len : forall l1 l2, qlen (amortizeQueue l1 l2) = (len l1) + (len l2).
Proof.
  intros. unfold amortizeQueue. destruct (leb (len l2) (len l1)).
  - simpl. reflexivity.
  - simpl. rewrite <- plus_n_O.
    lfind. Admitted.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e192m2e64m1_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m765_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Add LoadPath "~/Schreibtisch/svnba/Elgot/Coq/".
Require Import Coq_Steroids.
Require Import ElgotMonad.
Require Import Lemmas_ElgotMonad.
Require Import CofreeElgotMonad.
Require Import Setoid.
Open Scope elgot_scope.
Section Lemmas.
Context `(CofreeElgotMonad).

(* Lemmas proven in the following:

fusion:
  u ∘ v = map (id ⊕⊕ id ×× v ^^ id) ∘ w ->
    coit w = (coit u) ∘ v.

coit_of_out_is_id:
  coit (out) = id

tuo_out_is_id:
  tuo ∘ out = id

out_tuo_is_id:
  out ∘ tuo = id

out_cong:
  out ∘ f = out ∘ g -> f = g

out_mapcofree:
  out ∘ map_cofree f =
    map (f ⊕⊕ id ×× map_cofree f ^^ id) ∘ out

out_unitcofree:
  out ∘ ηv = η  ∘ inl

mapcofree_id:
  map_cofree (a:=a) (b:=b) (id (a:=x)) = id

mapcofree_comp:
  map_cofree f ∘ map_cofree g = map_cofree (f ∘ g)

mapcofree:
  map_cofree f = (ηv ∘ f) §

mapcofree_unitcofree
  map_cofree u ∘ ηv = ηv ∘ u

mapcofree_coit (fusion!)
  map_cofree s ∘ coit t = coit (map (s ⊕⊕ id) ∘ t)

mapcofree_liftingcofree (fusion!)
  map_cofree s ∘ t § = coit (([map(s ⊕⊕ id ×× map_cofree inr ^^ id) ∘ out ∘ [t, ηv],
       η ∘ inr]) * ∘ out) ∘ map_cofree inl

mapcofree_liftingcofree_unfolded (fusion!)
  map_cofree s ∘ (coit
     (([(map (id ⊕⊕ id ×× map_cofree inr ^^ id) ∘ out) ∘ [t, ηv],
       η ∘ inr]) * ∘ out) ∘ map_cofree inl) = coit (([map(s ⊕⊕ id ×× map_cofree inr ^^ id) ∘ out ∘ [t, ηv],
       η ∘ inr]) * ∘ out) ∘ map_cofree inl

liftingcofree_unfoldtocpr:
  f § =  [f, ηv] § ∘ map_cofree inl

liftingdef_with_inr:
  coit (([(map (id ⊕⊕ id ×× map_cofree inr ^^ id) ∘ out)
                 ∘ [t, ηv], η ∘ inr]) * ∘ out) ∘ map_cofree inr = id

lifting1:
  out ∘ t § = [out ∘ t, η ∘ inr ∘ id ×× t § ^^ id]* ∘ out

lifting2:
  out ∘ s = [out ∘ t, η ∘ inr ∘ id ×× s ^^ id]* ∘ out ->
    s = t §

guardedtriangular:
  guarded f u -> ▷ f = f

guardedtriangular_def:
  guarded (▷ f) u.

itercofree_triangular:
  iter_cofree f = iter_cofree (▷ f)

liftingcofree_tuo:
  [ηv, t] § ∘ tuo = tuo ∘ [[η ∘ inl, out ∘ t], η ∘ inr ∘ id ×× [ηv, t] § ^^ id] *

unfolding_guarded1:
  guarded f -> iter_cofree f = [ηv, iter_cofree f] § ∘ f

unfolding_guarded2:
  guarded f -> g = [ηv, g] § ∘ f -> g = iter_cofree f

unfolding_triangular1:
  iter_cofree f = [ηv, iter_cofree f] § ∘ ▷ f

unfolding_triangular2:
  g = [ηv, g] § ∘ ▷ f -> g = iter_cofree f

out_itercofree:
  out ∘ iter_cofree f = ([η ∘ inl, (η ∘ inr) ∘ id ×× [ηv, iter_cofree f] § ^^ id]) *
    ∘ ((map ([inl ⊕⊕ id, inl ∘ inr]) ∘ out) ∘ f) †

*)

Lemma fusion : forall
(A B a b x : Obj)
(u: B ~> T (x ⊕ a × (exp B b)))
(v: A ~> B)
(w: A ~> T (x ⊕ a × (exp A b))),
  u ∘ v = map (id ⊕⊕ id ×× v ^^ id) ∘ w ->
    coit w = (coit u) ∘ v.
Proof.
intros.
symmetry.
apply coit2.
rewrite -> comp_assoc with (h':= out).
rewrite -> coit1.
rewrite <- comp_assoc with (f':=v).
rewrite -> H0.
rewrite -> comp_assoc with (f':=w).
rewrite -> map_comp.
apply f_equal2; trivial.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
reflexivity.
Qed.

Lemma coit_of_out_is_id : forall
(A x a b : Obj),
coit (out (x:=x) (a:=a) (b:=b)) = id.
Proof.
intros.
symmetry.
apply coit2.
rewrite -> id_l.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.
rewrite -> id_r.
reflexivity.
Qed.

Lemma tuo_out_is_id : forall
(x a b : Obj),
tuo (x:=x) (a:=a) (b:=b) ∘ out = id.
Proof.
intros.
unfold tuo.
rewrite <- fusion with (w:=out).
rewrite -> coit_of_out_is_id.
reflexivity.
trivial.
reflexivity.
Qed.

Lemma out_tuo_is_id : forall
(x a b : Obj),
out (x:=x) (a:=a) (b:=b) ∘ tuo = id.
Proof.
intros.
unfold tuo.
rewrite -> coit1.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite -> tuo_out_is_id.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.
reflexivity.
Qed.

Lemma out_cong : forall
(x y a b : Obj)
(f: x ~> coext T a b y)
(g: x ~> coext T a b y),
  out ∘ f = out ∘ g -> f = g.
Proof.
intros.
transitivity (tuo ∘ out ∘ f).
rewrite -> tuo_out_is_id.
rewrite -> id_r; trivial.
transitivity (tuo ∘ out ∘ g).
rewrite <- comp_assoc.
rewrite H0.
rewrite <- comp_assoc; trivial.
rewrite -> tuo_out_is_id.
rewrite -> id_r; trivial.
Qed.

Lemma tuo_cong : forall
(x y a b : Obj)
(f: x ~> T (y ⊕ a × (coext T a b y) $ b))
(g: x ~> T (y ⊕ a × (coext T a b y) $ b)),
  tuo ∘ f = tuo ∘ g -> f = g.
Proof.
intros.
assert (out ∘ tuo ∘ f = out ∘ tuo ∘ g).
rewrite <-2 comp_assoc.
congruence.
rewrite -> out_tuo_is_id in H1.
rewrite ->2 id_r in H1; trivial.
Qed.

Lemma out_mapcofree : forall
(x y a b : Obj)
(f: x ~> y),
  out ∘ map_cofree f =
    map (f ⊕⊕ id ×× map_cofree f ^^ id) ∘ out (a:=a) (b:=b).
Proof.
intros.

unfold map_cofree.
rewrite -> coit1.
rewrite -> comp_assoc.
apply f_equal2; trivial.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
reflexivity.
Qed.

Lemma out_unitcofree : forall
(x a b : Obj),
  out (a:=a) (b:=b) ∘ ηv = η  ∘ inl (a:=x).
Proof.
intros.
unfold ηv.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> out_tuo_is_id.
rewrite -> id_r.
trivial.
Qed.

Lemma mapcofree_id : forall
(x a b : Obj),
map_cofree (a:=a) (b:=b) (id (a:=x)) = id.
Proof.
intros.
unfold map_cofree.
rewrite -> coprodhom_id.
rewrite -> map_id.
rewrite -> id_r.
rewrite -> coit_of_out_is_id; trivial.
Qed.

Lemma mapcofree_comp : forall
(x y z a b : Obj)
(f: y ~> z)
(g: x ~> y),
  map_cofree f ∘ map_cofree g = map_cofree (a:=a) (b:=b) (f ∘ g).
Proof.
intros.
unfold map_cofree.
apply coit2.
rewrite -> comp_assoc with (h':=out).
rewrite -> coit1.
rewrite -> comp_assoc with (f':=out).
rewrite -> map_comp.
rewrite <- comp_assoc with (g':=out).
rewrite -> coit1.
rewrite -> comp_assoc with (f':=out).
rewrite -> map_comp.
rewrite -> comp_assoc with (f':=out).
rewrite -> map_comp.
rewrite -> comp_assoc with (f':=out).
rewrite -> map_comp.
apply f_equal2; trivial.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
rewrite -> coprodhom_comp.
unfold cont.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
rewrite -> exphom_comp.
reflexivity.
Qed.

Lemma mapcofree_unitcofree : forall
(x y a b : Obj) (f: x ~> y),
map_cofree (a:=a) (b:=b) f ∘ ηv = ηv ∘ f.
Proof.
intros.
unfold map_cofree.
apply out_cong.
rewrite -> comp_assoc.
rewrite -> coit1.
rewrite -> comp_assoc with (h':=out).
rewrite -> out_unitcofree.
rewrite -> comp_assoc with (f':=out).
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
rewrite <- comp_assoc with (g':=out).
rewrite -> out_unitcofree.
rewrite -> comp_assoc with (f':=inl).
rewrite -> map_unit.
rewrite <- comp_assoc with (f':=inl).
rewrite -> coprodhom_inl.
rewrite -> comp_assoc.
reflexivity.
Qed.

Lemma mapcofree_coit : forall
(x y z a b : Obj) (f: y ~> z) (g: x ~> T (y ⊕ a × x $ b)),
map_cofree f ∘ coit g = coit (map (f ⊕⊕ id) ∘ g).
Proof.
intros.
unfold map_cofree.
rewrite <- fusion with (w:= map (f ⊕⊕ id) ∘ g).
reflexivity.
rewrite <- comp_assoc.
rewrite -> coit1.
rewrite -> comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
rewrite -> comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
reflexivity.
Qed.

Lemma mapcofree_liftingcofree : forall
(x y z a b : Obj) (f: y ~> z) (g: x ~> coext T a b y),
map_cofree f ∘ g § = coit (([map(f ⊕⊕ id ×× map_cofree inr ^^ id) ∘ out ∘ [g, ηv],
       η ∘ inr]) * ∘ out) ∘ map_cofree inl.
Proof.
intros.
unfold lifting_cofree.
rewrite -> comp_assoc with (h':=map_cofree f).
rewrite -> mapcofree_coit.
apply f_equal2; trivial.
rewrite -> comp_assoc with (h':=map (f ⊕⊕ id)).
rewrite -> map_lifting.
rewrite -> f_cpr.
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite <- comp_assoc with (f':=inr).
rewrite -> coprodhom_inr.
rewrite -> id_l.
rewrite ->2 comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> id_r.
reflexivity.
Qed.

Lemma mapcofree_liftingcofree_unfolded : forall
(x y z a b : Obj) (f: y ~> z) (g: x ~> coext T a b y),
map_cofree f ∘ (coit
     (([(map (id ⊕⊕ id ×× map_cofree inr ^^ id) ∘ out) ∘ [g, ηv],
       η ∘ inr]) * ∘ out) ∘ map_cofree inl) = coit (([map(f ⊕⊕ id ×× map_cofree inr ^^ id) ∘ out ∘ [g, ηv],
       η ∘ inr]) * ∘ out) ∘ map_cofree inl.
Proof.
apply mapcofree_liftingcofree.
Qed.

Lemma liftingcofree_unfoldtocpr : forall
(x y a b : Obj) (f: x ~> coext T a b y),
f § = [f, ηv] § ∘ map_cofree inl.
Proof.
intros.
unfold lifting_cofree.
apply f_equal2; trivial.
symmetry.
apply coit2.
rewrite -> comp_assoc.
rewrite -> coit1.
rewrite -> comp_assoc.
rewrite -> map_lifting.
rewrite <- comp_assoc with (f':=map_cofree inl).
rewrite -> out_mapcofree.
rewrite -> comp_assoc.
rewrite -> lifting_map.
rewrite <- comp_assoc with (f':=inl ⊕⊕ id ×× map_cofree inl ^^ id).
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
rewrite -> comp_assoc.
apply f_equal2; trivial.

rewrite -> map_lifting.
rewrite -> f_cpr.
rewrite -> f_cpr with (h:=η ∘ inr).
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite <- comp_assoc with (h':=η).
rewrite <- comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=inr).
rewrite -> coprodhom_inr.
rewrite -> coprodhom_inr.
rewrite <- comp_assoc with (h':=inr).
rewrite -> prodhom_comp.
rewrite -> id_l.

rewrite -> exphom_comp.
apply f_equal1.
apply f_equal2; trivial.

rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> map_comp.

rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> map_comp.
apply f_equal2; trivial.
apply f_equal2; trivial.

apply f_equal1.

rewrite -> coprodhom_comp.
rewrite -> coprodhom_comp.

rewrite -> id_l.

rewrite -> prodhom_comp.
rewrite -> prodhom_comp.

rewrite -> id_l.

apply f_equal2; trivial.
apply f_equal2; trivial.

rewrite -> exphom_comp.
rewrite -> exphom_comp.

apply f_equal2; trivial.

rewrite <- comp_assoc.
rewrite <- comp_assoc.

rewrite -> mapcofree_comp.

transitivity (coit (out (a:=a) (b:=b)(x:=y))).
symmetry.
apply fusion.

rewrite <- comp_assoc.

rewrite -> out_mapcofree.
rewrite -> comp_assoc.

apply f_equal2; trivial.

rewrite -> lifting_map.
rewrite -> cpr_coprodhom.

rewrite <- comp_assoc.
rewrite <- comp_assoc.

rewrite -> cpr_inr.
rewrite -> out_unitcofree.

rewrite -> comp_assoc.

rewrite -> map_unit.

rewrite <- comp_assoc.

rewrite -> coprodhom_inl.
rewrite -> id_l.

rewrite <- comp_assoc.
rewrite <- f_cpr.
unfold map.
unfold coprodhom.
rewrite -> id_l.
trivial.

apply fusion.

rewrite <- comp_assoc.

rewrite -> out_mapcofree.
rewrite -> comp_assoc.

apply f_equal2; trivial.

rewrite -> lifting_map.
rewrite -> cpr_coprodhom.

rewrite <- comp_assoc.
rewrite <- comp_assoc.

rewrite -> comp_assoc with (g':=inl).

rewrite -> cpr_inl.
rewrite -> cpr_inr.
rewrite -> out_unitcofree.

rewrite -> comp_assoc.

rewrite -> map_unit.

rewrite <- comp_assoc.

rewrite -> coprodhom_inl.
rewrite -> id_l.

rewrite <- comp_assoc.
rewrite <- f_cpr.
unfold map.
unfold coprodhom.
rewrite -> id_l.
trivial.

Qed.

Lemma liftingdef_with_inr : forall
(x y a b : Obj) (f: x ~> coext T a b y),
coit (([(map (id ⊕⊕ id ×× map_cofree inr ^^ id) ∘ out)
                 ∘ [f, ηv], η ∘ inr]) * ∘ out) ∘ map_cofree inr = id.
Proof.
intros.
rewrite <- coit_of_out_is_id; trivial.
symmetry.
apply fusion.
rewrite <- comp_assoc.
rewrite -> out_mapcofree.
rewrite -> comp_assoc.
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inr).
rewrite -> cpr_inr.
rewrite <- comp_assoc with (f':=ηv).
rewrite -> out_unitcofree.
rewrite -> comp_assoc with (f':=inl).
rewrite -> map_unit.
rewrite <- comp_assoc with (f':=inl).
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite <- comp_assoc with (g':=inr).
rewrite <- f_cpr.
unfold map.
unfold coprodhom.
rewrite -> id_l.
reflexivity.
Qed.

Lemma lifting1 : forall
(x y a b : Obj) (f: x ~> coext T a b y),
out ∘ f § = [out ∘ f, η ∘ inr ∘ id ×× f § ^^ id]* ∘ out.
Proof.
intros.
unfold lifting_cofree.
rewrite -> comp_assoc.
rewrite -> coit1.

rewrite <- comp_assoc.
rewrite <- comp_assoc with (f':=map_cofree inl).
rewrite -> out_mapcofree.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
apply f_equal2; trivial.

rewrite <- comp_assoc.
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite -> map_lifting.

apply f_equal1.

rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.

rewrite -> f_cpr.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.

rewrite -> liftingdef_with_inr.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.
rewrite -> id_r.

rewrite <- comp_assoc with (g':=inr).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite -> comp_assoc with (g':=inr).
rewrite <- comp_assoc with (h':=η).
rewrite -> coprodhom_inr.
rewrite -> comp_assoc with (g':=inr).
rewrite <- comp_assoc with (f':=id ×× map_cofree inl ^^ id).
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
reflexivity.
Qed.

Lemma lifting2 : forall
(x y a b : Obj) (f: x ~> coext T a b y) (g: coext T a b x ~> coext T a b y),
  out ∘ g = [out ∘ f, η ∘ inr ∘ id ×× g ^^ id]* ∘ out ->
    g = f §.
Proof.
intros.

(* The idea is to introduce such w: T_a^b x + T_a^b y -> T_a^b y
    that w inl = g and w inr = id *)

remember (coit ([[(map (id ⊕⊕ id ×× inr^^id)) ∘ out ∘ f,
                    η ∘ inr ∘ id ×× inl^^id]* ∘ out,
                  (map (id ⊕⊕ id ×× inr^^id)) ∘ out])) as w eqn:W.

assert ([g, id] = [f§, id]).
transitivity w.

rewrite -> W.
apply coit2.
rewrite ->2 f_cpr.
case_distinction.

rewrite -> comp_assoc.
rewrite -> map_lifting.
rewrite -> f_cpr.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> map_comp.

rewrite -> coprodhom_comp.
rewrite -> prodhom_comp.
rewrite -> exphom_comp.
rewrite ->2 id_l.

rewrite -> cpr_inr.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.

rewrite -> id_r.

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 -> coprodhom_inr.

rewrite -> comp_assoc with (h' := η).
rewrite <- comp_assoc with (h' := η ∘ inr).

rewrite -> prodhom_comp.

rewrite -> id_r.

rewrite -> exphom_comp.
rewrite -> cpr_inl.
exact H0.

rewrite -> id_l.
rewrite -> comp_assoc.
rewrite -> map_comp.

rewrite -> coprodhom_comp.
rewrite -> prodhom_comp.
rewrite -> exphom_comp.

rewrite ->2 id_l.
rewrite -> cpr_inr.

rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.

rewrite -> id_r.
reflexivity.

rewrite -> W.
symmetry.
apply coit2.

rewrite -> f_cpr.
rewrite -> id_l.
rewrite -> f_cpr.

rewrite ->2 comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite -> cpr_inr.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.
rewrite -> id_r.
apply f_equal2;trivial.

rewrite -> map_lifting.
rewrite -> f_cpr.
rewrite -> comp_assoc with (f':=f).
rewrite -> comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite -> cpr_inr.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.
rewrite -> id_r.

rewrite <- comp_assoc with (g':=inr).
rewrite -> comp_assoc with (g':=η).
rewrite -> map_unit.
rewrite -> comp_assoc with (g':=inr).
rewrite <- comp_assoc with (h':=η).
rewrite -> coprodhom_inr.
rewrite <-2 comp_assoc with (f':=id ×× inl ^^ id).
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite -> cpr_inl.
rewrite -> comp_assoc.
apply lifting1.
trivial.

apply f_equal1 with (f:= fun x => x ∘ inl) in H1.
rewrite ->2 cpr_inl in H1; trivial.

Qed.

Lemma guardedtriangular : forall
(x y z a b : Obj) (f': x ~> coext T a b (y ⊕ x)),
guarded f' -> ▷ f' = f'.
Proof.
intros.
unfold guarded in H0.
apply out_cong.

unfold triangular.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> out_tuo_is_id.
rewrite -> id_r.
rewrite <- comp_assoc with (g':=out).

inversion H0 as [u' H1].

rewrite -> H1.
apply f_equal1.
rewrite -> comp_assoc.
rewrite -> map_comp.
rewrite -> cpr_coprodhom.
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite <- f_cpr.
rewrite -> inl_inr_is_id.
rewrite -> id_l.
rewrite -> mapinl_f_iter.
reflexivity.
Qed.

(* ▷ f is guarded by definition *)
Lemma guardedtriangular_def : forall
(x y a b : Obj) (f: x ~> coext T a b (y ⊕ x)),
guarded (▷ f).
Proof.
intros.
unfold guarded.
unfold triangular.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> out_tuo_is_id.
rewrite -> id_r.
rewrite <- comp_assoc with (g':=out).
apply ex_intro with (x:=(map ([inl ⊕⊕ id, inl ∘ inr]) ∘ (out ∘ f)) †).
reflexivity.
Qed.

Lemma itercofree_triangular : forall
(x y a b : Obj) (f: x ~> coext T a b (y ⊕ x)),
iter_cofree f = iter_cofree (▷ f).
Proof.
intros.
unfold triangular.
unfold iter_cofree.

rewrite <- comp_assoc with (h':=tuo).
rewrite -> comp_assoc with (g':=tuo).
rewrite <- comp_assoc with (f':=tuo).
rewrite -> out_tuo_is_id.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=map (inl ⊕⊕ id)).
rewrite -> map_comp.
rewrite -> cpr_coprodhom.
rewrite -> id_l.
rewrite -> coprodhom_inl.
rewrite <- f_cpr.
rewrite -> inl_inr_is_id.
rewrite -> id_l.
rewrite -> mapinl_f_iter.
reflexivity.
Qed.

Lemma liftingcofree_tuo : forall
(x y a b : Obj) (t:x ~> coext T a b y),
[ηv, t] § ∘ tuo =
  tuo ∘ [[η ∘ inl, out ∘ t],
η ∘ inr ∘ id ×× [ηv, t] § ^^ id] *.
Proof.
intros.
unfold lifting_cofree.
apply out_cong.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> coit1.
rewrite <-2 comp_assoc with (f':=map_cofree inl).
rewrite -> out_mapcofree.
rewrite <-3 comp_assoc with (f':=tuo).
rewrite -> out_tuo_is_id.
rewrite -> id_l.
rewrite <- comp_assoc.
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite <-2 comp_assoc with (f':=inl).
rewrite -> cpr_inl.

rewrite -> comp_assoc with (h':=out).
rewrite -> out_tuo_is_id.
rewrite -> id_r.

rewrite -> map_lifting.
apply f_equal1.
rewrite -> f_cpr.
rewrite ->2 comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.

rewrite -> comp_assoc with (f':=[[ηv, t], ηv]).
rewrite -> liftingdef_with_inr.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.
rewrite -> id_r.
rewrite -> f_cpr.
rewrite -> out_unitcofree.
apply f_equal1.

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 -> coprodhom_inr.
rewrite -> comp_assoc with (g':=inr).
rewrite <- comp_assoc with (h':=η ∘ inr).
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
reflexivity.
Qed.

Lemma unfolding_guarded1 :  forall
(x y a b : Obj) (f: x ~> coext T a b (y ⊕ x)),
guarded f ->
iter_cofree f = [ηv, iter_cofree f] § ∘ f.
Proof.
intros.
unfold guarded in H0.
inversion H0 as [u' H1].

(* Some preparation *)

remember (coit (([[η ∘ inl, u'], η ∘ inr]) * ∘ out)) as w eqn:W.
assert (iter_cofree f = w ∘ ηv ∘ inr).
unfold iter_cofree.

rewrite <- comp_assoc with (f':=inr).
rewrite <- comp_assoc with (f':=inr).
apply f_equal1 with (f:= fun x => x ∘ (ηv ∘ inr)).
rewrite <- comp_assoc with (g':=out).
rewrite -> H1.

rewrite -> comp_assoc.
rewrite -> map_comp.
rewrite -> cpr_coprodhom.
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite <- f_cpr.
rewrite -> inl_inr_is_id.
rewrite -> id_l.
rewrite -> mapinl_f_iter.
rewrite -> W; trivial.

assert (ηv = (w ∘ ηv) ∘ inl).
rewrite -> W.
apply out_cong.
rewrite -> out_unitcofree.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> coit1.
rewrite -> comp_assoc with (f':=out).
rewrite -> map_lifting.
rewrite <- comp_assoc with (g':=out).
rewrite -> out_unitcofree.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite <- comp_assoc.
rewrite <- comp_assoc.
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite -> cpr_inl.
rewrite -> comp_assoc with (f':=inl).
rewrite -> map_unit.
rewrite <- comp_assoc.
rewrite -> coprodhom_inl.
rewrite -> id_l; trivial.

(* Main part *)

unfold iter_cofree at 1.

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

rewrite -> comp_assoc.
rewrite -> map_comp.
rewrite -> cpr_coprodhom.
rewrite -> coprodhom_inl.
rewrite -> id_l.
rewrite <- f_cpr.
rewrite -> inl_inr_is_id.
rewrite -> id_l.
rewrite -> mapinl_f_iter.

apply out_cong.
rewrite -> comp_assoc.
rewrite -> comp_assoc.
rewrite -> coit1.

rewrite -> comp_assoc with (f':=f).
rewrite -> lifting1.

rewrite <- comp_assoc with (f':=f).

rewrite -> comp_assoc with (f':=out).
rewrite <- comp_assoc with (g':=out).
rewrite out_unitcofree.
rewrite -> comp_assoc with (f':=inl).
rewrite <- comp_assoc with (f':=η).
rewrite -> kl2.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
rewrite <- comp_assoc with (f':=inr).
rewrite -> cpr_inr.

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

rewrite -> comp_assoc with (f':=u').
rewrite -> lifting_map.
unfold map at 1.

apply f_equal1 with (f:= fun x => x* ∘ u').
unfold coprodhom.
rewrite ->2 f_cpr.
case_distinction.
rewrite -> id_l.
rewrite -> comp_assoc with (g':=inl).
rewrite -> cpr_inl.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
rewrite out_unitcofree; trivial.

rewrite -> id_l.
rewrite -> cpr_inr.
rewrite <- comp_assoc with (g':=inr).
apply f_equal1 with (f:= fun x => η ∘ (inr ∘ id ×× x ^^ id)).
rewrite <- W.
rewrite -> H2.
rewrite -> H3.
rewrite <- f_cpr.
rewrite -> inl_inr_is_id.
rewrite -> id_l.

(* Curious fact: w = (w ∘ ηv) §. May be needed in the future. *)

apply lifting2.
rewrite -> W at 1.

rewrite coit1.
rewrite <- W.

rewrite -> comp_assoc with (f':=out).
rewrite map_lifting.
unfold map at 1.
apply f_equal1 with (f:= fun x => x* ∘ out).
rewrite -> f_cpr.
case_distinction.
rewrite -> W at 2.
rewrite -> comp_assoc with (h':=out).
rewrite coit1.
rewrite <- W.
rewrite -> comp_assoc with (f':=out).
rewrite <- comp_assoc with (g':=out).
rewrite out_unitcofree.
rewrite -> comp_assoc with (g':=η).
rewrite <- comp_assoc with (f':=η).
rewrite -> kl2.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.
unfold map; trivial.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite <- comp_assoc.
rewrite -> coprodhom_inr.
rewrite <- comp_assoc; trivial.
Qed.
*)

Lemma unfolding_guarded2 :  forall
(x y a b : Obj) (f: x ~> coext T a b (y ⊕ x)) (g: x ~> coext T a b y),
guarded f -> g = [ηv, g] § ∘ f -> g = iter_cofree f.
Proof.
intros.

rewrite -> H1.
rewrite <- guardedtriangular with (f':=f) at 1;trivial.
unfold triangular.
rewrite ->2 comp_assoc.
rewrite -> liftingcofree_tuo.
unfold iter_cofree.

apply out_cong.
rewrite ->3 comp_assoc.
rewrite -> out_tuo_is_id.
rewrite -> id_r.
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite -> cpr_inl.
rewrite -> id_l.

rewrite ->2 comp_assoc.
rewrite -> coit1.
rewrite <-2 comp_assoc with (f':=ηv).
rewrite -> out_unitcofree.
rewrite -> comp_assoc with (g':=η).
rewrite -> kl2.
rewrite -> cpr_inl.
rewrite <- comp_assoc with (f':=inr).
rewrite -> cpr_inr.
apply f_equal2;trivial.
unfold map at 1.
apply f_equal1.
rewrite <- comp_assoc with (h':=η).
rewrite <- f_cpr.
apply f_equal2;trivial.
unfold coprodhom at 1.
rewrite -> id_l.
apply f_equal2;trivial.
apply f_equal2;trivial.
apply f_equal2;trivial.
apply f_equal2;trivial.

(* --- *)

apply coit2.
unfold lifting_cofree.
rewrite -> comp_assoc.
rewrite -> coit1.
rewrite <-3 comp_assoc.
rewrite -> out_mapcofree.
rewrite ->4 comp_assoc.
apply f_equal2;trivial.
rewrite ->2 map_lifting.
rewrite -> lifting_map.
apply f_equal1.
rewrite <- comp_assoc.
rewrite -> cpr_coprodhom.
rewrite <- comp_assoc with (f':=inl).
rewrite -> cpr_inl.

case_distinction.
rewrite ->2 comp_assoc.
rewrite -> map_comp.
rewrite -> coprodhom_comp.
rewrite -> id_l.
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
rewrite -> liftingdef_with_inr.
rewrite -> exphom_id.
rewrite -> prodhom_id.
rewrite -> coprodhom_id.
rewrite -> map_id.
rewrite -> id_r.

case_distinction.
rewrite -> out_unitcofree.
rewrite -> comp_assoc.
rewrite -> map_unit.
rewrite <- comp_assoc.
rewrite -> coprodhom_inl.
rewrite -> id_l.
trivial.

rewrite -> H1 at 1.
rewrite <- guardedtriangular with (f':=f) at 1;trivial.
unfold triangular.
rewrite <- comp_assoc with (h':=tuo).
rewrite -> comp_assoc with (g':=tuo).
rewrite -> liftingcofree_tuo.
rewrite ->3 comp_assoc.
rewrite -> out_tuo_is_id.
rewrite -> id_r.
rewrite -> lifting_map.
rewrite -> cpr_coprodhom.
rewrite -> cpr_inl.
rewrite -> id_l.
apply f_equal2;trivial.
unfold map at 1.
apply f_equal1.
apply coprodsplit.
rewrite -> cpr_inl.
rewrite <- comp_assoc with (f':=inl).
rewrite -> coprodhom_inl.
rewrite -> id_l.
trivial.
rewrite -> cpr_inr.
rewrite <- comp_assoc with (f':=inr).
rewrite -> coprodhom_inr.
rewrite -> comp_assoc with (h':=η).
trivial.
(* solved, because right side was equal, but the lifting unfolded *)

rewrite <- comp_assoc with (h':=η).
rewrite ->2 comp_assoc with (g':=η).
rewrite ->2 map_unit.
rewrite <-2 comp_assoc with (h':=η).
rewrite -> comp_assoc with (g':=inr).
rewrite ->2 coprodhom_inr.
rewrite <- comp_assoc with (h':=inr).
rewrite -> prodhom_comp.
rewrite -> id_l.
rewrite -> exphom_comp.
reflexivity.
Qed.

Lemma unfolding_triangular1 : forall
(x y a b : Obj) (f: x ~> coext T a b (y ⊕ x)),
iter_cofree f = [ηv, iter_cofree f] § ∘ ▷ f.
Proof.
intros.
pose proof guardedtriangular_def (_) (_) (_) (_) (f).
pose proof unfolding_guarded1 (_) (_) (_) (_) (▷f).
rewrite <- itercofree_triangular in H1.
apply H1.
apply H0.
Qed.

Lemma unfolding_triangular2 : forall
(x y a b : Obj) (f: x ~> coext T a b (y ⊕ x)) (g: x ~> coext T a b y),
g = [ηv, g] § ∘ ▷ f ->
g = iter_cofree f.
Proof.
intros.
rewrite -> itercofree_triangular.
apply unfolding_guarded2.
apply guardedtriangular_def.
apply H0.
Qed.

Lemma out_itercofree : forall
(x y a b : Obj) (f: x ~> coext T a b (y ⊕ x)),
out ∘ iter_cofree f = ([η ∘ inl,
    (η ∘ inr) ∘ id ×× [ηv, iter_cofree f] § ^^ id]) *
∘ ((map ([inl ⊕⊕ id, inl ∘ inr]) ∘ out) ∘ f) †.
Proof.
intros.
rewrite -> unfolding_triangular1 at 1.
rewrite -> comp_assoc.
rewrite -> lifting1.
unfold triangular.
rewrite <- comp_assoc with (h':=tuo).
rewrite -> comp_assoc with (g':=tuo).
rewrite <- comp_assoc with (f':=tuo).
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 -> out_unitcofree.
rewrite -> id_l.
reflexivity.
Qed.

Lemma strength1 : forall
(x y a b : Obj),
out ∘ τv (x:=x) (y:=y) (a:=a) (b:=b) = map (id ⊕⊕ id ×× τv ^^ id) ∘ map δ ∘ τ ∘ (id ×× out).
Proof.
intros.
unfold τv.
rewrite -> coit1.
rewrite ->2 comp_assoc.
reflexivity.
Qed.

Lemma strength2 : forall
(x y a b : Obj) (f: x × (coext T a b y) ~> coext T a b (x × y)),
out ∘ f = map (id ⊕⊕ id ×× f ^^ id) ∘ map δ ∘ τ ∘ (id ×× out) ->
f = τv.
Proof.
intros.
unfold τv.
apply coit2.
rewrite ->2 comp_assoc.
apply H0.
Qed.

End Lemmas.


(* Copied from RamifyCoq project *)

Require Import Coq.Classes.Morphisms.
Require Import Coq.Sorting.Permutation.
Require Export Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Relation_ext.
Require Import Logic.lib.Equivalence_ext.
Require Export Coq.Lists.List.

Local Open Scope equiv_scope.

Section ListFun2.

Context {A B: Type}.
Context {RA: relation A}.
Context {RB: relation B}.
Context {EqRA: Equivalence RA}.
Context {EqRB: Equivalence RB}.

Instance proper_fold_left: forall (f: A -> B -> A) {Proper_f: Proper (equiv ==> equiv ==> equiv) f}, Proper (Forall2 equiv ==> equiv ==> equiv) (fold_left f).
Proof.
  intros.
  hnf; intros.
  induction H; hnf; intros; simpl.
  + auto.
  + apply IHForall2.
    apply Proper_f; auto.
Qed.

Lemma monoid_fold_left_tail: forall {f: A -> B -> A} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) a l,
  fold_left f (l ++ a :: nil) e === f (fold_left f l e) a.
Proof.
  intros.
  simpl.
  pose proof (proper_fold_left f).
  revert e; induction l; intros; simpl.
  + reflexivity.
  + apply IHl.
Qed.

End ListFun2.

Existing Instance proper_fold_left.

Section ListFun1.

Context {A: Type}.
Context {RA: relation A}.
Context {EqRA: Equivalence RA}.

Lemma monoid_fold_left_head: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) a l,
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f (a :: l) e === f a (fold_left f l e).
Proof.
  intros.
  simpl.
  pose proof (proper_fold_left f).
  rewrite H.
  revert a; induction l; intros; simpl.
  + symmetry; auto.
  + rewrite (IHl (f a0 a)), H, (IHl a).
    rewrite H1.
    reflexivity.
Qed.

Lemma monoid_fold_symm: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) l,
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f l e === fold_right f e l.
Proof.
  intros.
  pose proof (proper_fold_left f).
  destruct l.
  + simpl.
    reflexivity.
  + simpl.
    rewrite H.
    revert a; induction l; intros; simpl.
    - symmetry; auto.
    - rewrite <- H1.
      apply IHl.
Qed.

Lemma monoid_fold_left_app: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (e: A) l l',
  (forall x, f e x === x) ->
  (forall x, f x e === x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  fold_left f (l ++ l') e === f (fold_left f l e) (fold_left f l' e).
Proof.
  intros.
  rewrite fold_left_app.
  generalize (fold_left f l e) as a; clear l; intros.
  pose proof @monoid_fold_left_head f _ e a l'.
  simpl in H2.
  pose proof (proper_fold_left f).
  rewrite H in H2.
  auto.
Qed.

End ListFun1.

(* Above is copied from RamifyCoq project *)

Section ListFun2'.

Context {A B: Type}.
Context {RA: relation A}.
Context {RB: relation B}.

Instance proper_fold_left': forall (f: A -> B -> A) {Proper_f: Proper (RA ==> RB ==> RA) f}, Proper (Forall2 RB ==> RA ==> RA) (fold_left f).
Proof.
  intros.
  hnf; intros.
  induction H; hnf; intros; simpl.
  + auto.
  + apply IHForall2.
    apply Proper_f; auto.
Qed.

Context {EqRA: Equivalence RA}.

Lemma proper_permutation_fold_left: forall (f: A -> B -> A) {Proper_f: Proper (RA ==> eq ==> RA) f},
  (forall x1 x2 y z, x1 === x2 -> f (f x1 y) z === f (f x2 z) y) ->
  Proper (@Permutation _ ==> RA ==> RA) (fold_left f).
Proof.
  intros.
  hnf; intros.
  hnf; intros.
  revert x0 y0 H1.
  induction H0; intros.
  + simpl.
    auto.
  + simpl.
    apply IHPermutation.
    apply Proper_f; auto.
  + simpl.
    assert (RA (f (f x0 y) x) (f (f y0 x) y)) by (apply H; auto).
    revert H0; generalize (f (f x0 y) x) (f (f y0 x) y).
    induction l; intros.
    - simpl; auto.
    - simpl.
      apply IHl.
      apply Proper_f; auto.
  + etransitivity.
    - apply IHPermutation1, H1.
    - apply IHPermutation2.
      reflexivity.
Qed.

End ListFun2'.

Definition not_nil {A: Type} (l: list A): Prop := l <> nil.

Lemma not_nil_app_l {A: Type}: forall (l l': list A), not_nil l -> not_nil (l ++ l').
Proof.
  intros.
  hnf in *.
  destruct l;intros; simpl in *; congruence.
Qed.

Lemma eq_nil_dec {A: Type}: forall (l: list A), {l = nil} + {not_nil l}.
Proof.
  intros.
  destruct l; [left | right]; auto.
  intro; congruence.
Qed.

Instance Proper_perm_not_nil {A: Type}: Proper (@Permutation A ==> iff) (@not_nil A).
Proof.
  hnf; intros.
  induction H; unfold not_nil in *.
  + reflexivity.
  + split; intros ? ?; congruence.
  + split; intros ? ?; congruence.
  + tauto.
Qed.

Definition semi_group_fold {A: Type} (default: A) (f: A -> A -> A) (l: list A): A :=
  match l with
  | nil => default
  | a :: l0 => fold_left f l0 a
  end.

Section ListFun1'.

Context {A: Type}.
Context {RA: relation A}.
Context {EqRA: Equivalence RA}.

Instance proper_semi_group_fold: forall (f: A -> A -> A) (default: A) {Proper_f: Proper (equiv ==> equiv ==> equiv) f}, Proper (Forall2 equiv ==> equiv) (semi_group_fold default f).
Proof.
  intros.
  hnf; intros.
  destruct H.
  + reflexivity.
  + simpl.
    apply proper_fold_left; auto.
Qed.

Lemma semi_group_fold_app: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (default: A) l l',
  (forall x y z, f (f x y) z === f x (f y z)) ->
  not_nil l ->
  not_nil l' ->
  semi_group_fold default f (l ++ l') === f (semi_group_fold default f l) (semi_group_fold default f l').
Proof.
  intros.
  destruct l as [| a l], l' as [| a' l']; hnf in H0, H1; try congruence; clear H0 H1.
  revert a; induction l; intros.
  + simpl.
    revert a'; induction l'; intros.
    - simpl.
      reflexivity.
    - specialize (IHl' (f a' a0)).
      simpl in *.
      rewrite <- IHl'; clear IHl'.
      specialize (H a a' a0).
      set (b := f (f a a') a0) in H |- *.
      set (c := f a (f a' a0)) in H |- *.
      clearbody b c; clear a a' a0.
      revert b c H; induction l'; intros.
      * auto.
      * simpl.
        apply IHl'.
        rewrite H; reflexivity.
  + exact (IHl (f a0 a)).
Qed.

Lemma semi_group_fold_concat: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (default: A) ls,
  (forall x y z, f (f x y) z === f x (f y z)) ->
  Forall not_nil ls ->
  semi_group_fold default f (concat ls) === semi_group_fold default f (map (semi_group_fold default f) ls).
Proof.
  intros.
  destruct H0; [reflexivity |].
  revert x H0; induction H1; intros.
  + simpl.
    rewrite app_nil_r.
    reflexivity.
  + Opaque semi_group_fold.
    simpl.
    rewrite semi_group_fold_app; auto.
      2: apply not_nil_app_l; auto.
    specialize (IHForall x H0).
    simpl in IHForall.
    rewrite IHForall.
    change (semi_group_fold default f x0 :: semi_group_fold default f x :: map (semi_group_fold default f) l)
      with ((semi_group_fold default f x0 :: nil) ++ semi_group_fold default f x :: map (semi_group_fold default f) l).
    rewrite semi_group_fold_app by (auto; intro; congruence).
    reflexivity.
    Transparent semi_group_fold.
Qed.

Lemma comm_semi_group_fold_perm: forall {f} {Proper_f: Proper (equiv ==> equiv ==> equiv) f} (default: A) l l',
  (forall x y, f x y === f y x) ->
  (forall x y z, f (f x y) z === f x (f y z)) ->
  Permutation l l' ->
  semi_group_fold default f l === semi_group_fold default f l'.
Proof.
  intros.
  induction H1.
  + reflexivity.
  + destruct (eq_nil_dec l) as [?H | ?H].
    - subst; apply Permutation_nil in H1; subst.
      reflexivity.
    - pose proof H2.
      rewrite H1 in H3.
      change (x :: l) with ((x :: nil) ++ l).
      change (x :: l') with ((x :: nil) ++ l').
      rewrite semi_group_fold_app by (auto; intro; congruence).
      rewrite semi_group_fold_app by (auto; intro; congruence).
      rewrite IHPermutation.
      reflexivity.
  + simpl.
    rewrite <- H.
    reflexivity.
  + rewrite IHPermutation1.
    auto.
Qed.

End ListFun1'.

Lemma Forall2_impl: forall {A B: Type} (P Q: A -> B -> Prop),
  (forall a b, P a b -> Q a b) ->
  (forall (lA: list A) (lB: list B), Forall2 P lA lB -> Forall2 Q lA lB).
Proof.
  intros.
  induction H0.
  + constructor.
  + constructor.
    - auto.
    - auto.
Qed.

Lemma Forall2_rev: forall {A B: Type} (P: A -> B -> Prop),
  forall (lA: list A) (lB: list B), Forall2 (fun b a => P a b) lB lA -> Forall2 P lA lB.
Proof.
  intros.
  induction H.
  + constructor.
  + constructor.
    - auto.
    - auto.
Qed.


(** * Results about commutation diagrams *)

Require Export Relations.
Set Implicit Arguments.

(** Definitions *)
Section Def1.
  Variables X X' Y Y': Type.
  Variable RX: relation2 X X'.
  Variable R:  relation2 X Y.
  Variable RY: relation2 Y Y'.
  Variable R': relation2 X' Y'.
  Definition diagram := forall x x' y, RX x x' -> R x y -> exists2 y', RY y y' & R' x' y'.
End Def1.
Section Def2.
  Variable X: Type.
  Variables R S: relation X.
  Definition strong_commute := diagram R S R S.
  Definition local_commute  := diagram R S (star R) (star S).
  Definition semi_commute   := diagram R S (star R) S.
  Definition commute        := diagram (star R) (star S) (star R) (star S).
  Definition confluent      := diagram (star R) (star R) (star R) (star R).
End Def2.

(** Variance w.r.t inclusion *)
Section Incl.
  Variables X X' Y Y': Type.
  Variable RX: relation2 X X'.
  Variable R R':  relation2 X Y.
  Variable RY: relation2 Y Y'.
  Variables S S': relation2 X' Y'.
  Hypothesis H: diagram RX R RY S.
  Hypothesis HR: forall x y, R' x y -> R x y.
  Hypothesis HS: forall x y, S x y -> S' x y.
  Theorem diagram_incl: diagram RX R' RY S'.
  Proof.
    intros x x' y Hxx' xRy.
    elim (H Hxx' (y:=y)); auto.
    intros y' Hyy' x'Ry'.
    exists y'; auto.
  Qed.
End Incl.

(** Reversing diagrams *)
Section Reverse.
  Variables X X' Y Y': Type.
  Variable RX: relation2 X X'.
  Variable R:  relation2 X Y.
  Variable RY: relation2 Y Y'.
  Variable R': relation2 X' Y'.
  Hypothesis H: diagram RX R RY R'.
  Theorem diagram_reverse: diagram R RX R' RY.
  Proof.
    intros x x' y Hxx' xRy.
    elim (H xRy Hxx'); intros y' A B.
    exists y'; assumption.
  Qed.
End Reverse.

(** Composing diagrams *)
Section Compose.
  Variables X Y Z X' Y' Z': Type.
  Variable RY: relation2 Y Y'.
  Variable RX: relation2 X X'.
  Variable R1: relation2 X Y.
  Variable R2: relation2 Y Z.
  Variable RZ: relation2 Z Z'.
  Variable S1: relation2 X' Y'.
  Variable S2: relation2 Y' Z'.
  Hypothesis H1: diagram RX R1 RY S1.
  Hypothesis H2: diagram RY R2 RZ S2.
  Theorem diagram_comp: diagram RX (comp R1 R2) RZ (comp S1 S2).
  Proof.
    intros x x' z Hxx' xRz; destruct xRz as [ y xRy yRz ].
    elim (H1 Hxx' xRy); intros y' Hyy' x'Sy'.
    elim (H2 Hyy' yRz); intros z' Hzz' y'Sz'.
    exists z'; auto.
    exists y'; assumption.
  Qed.
End Compose.

(** Merging diagrams *)
Section Union.
  Variables X Y X' Y' I: Type.
  Variable  RX: relation2 X X'.
  Variables R: I -> relation2 X Y.
  Variable  RY: relation2 Y Y'.
  Variable  S: relation2 X' Y'.
  Hypothesis H: forall i, diagram RX (R i) RY S.
  Theorem diagram_union: diagram RX (union R) RY S.
  Proof.
    intros x x' z Hxx' xRy; destruct xRy as [ i xRy ].
    elim (H Hxx' xRy); intros y' Hyy' x'Sy'.
    exists y'; assumption.
  Qed.
End Union.

(** Iterating one side of a diagram *)
Section Star.
  Variables X X': Type.
  Variable RX: relation2 X X'.
  Variable R: relation X.
  Variable S: relation X'.
  Hypothesis H: diagram RX R RX (star S).
  Theorem diagram_star: diagram RX (star R) RX (star S).
  Proof.
    intros x x' y Hxx' xRy; cgen Hxx'; cgen x'.
    induction xRy as [ x | y x z xRy yRz IH ]; intros x' Hxx'.
    exists x'; auto.
    elim (H Hxx' xRy); intros y' Hyy' x'Sy'.
    elim (IH _ Hyy'); intros z' Hzz' y'Sz'.
    exists z'; auto.
    apply star_trans with y'; assumption.
  Qed.
End Star.

(** Iterating strictly one side of a diagram *)
Section Plus.
  Variables X X': Type.
  Variable RX: relation2 X X'.
  Variable R: relation X.
  Variable S: relation X'.
  Hypothesis HR: diagram RX R RX (plus S).
  Theorem diagram_plus: diagram RX (plus R) RX (plus S).
  Proof.
    intros x x' z Hxx' xRz; destruct xRz as [ y xRy yRz ].
    elim (HR Hxx' xRy); intros y' Hyy' x'Sy'.
    elim diagram_star with X X' RX R S y y' z; auto.
    intros z' Hzz' y'Sz'.
    exists z'; auto; apply plus_star_plus with y'; assumption.
    apply diagram_incl with R (plus S); auto.
  Qed.
End Plus.

(** A First Termination Argument : Subsection 4.1 *)
Section PlusWf.

  Variable X: Set.
  Variable S: relation X.
  Variable TX: relation X.

  Hypothesis HS: diagram TX S (star TX) (plus S).
  Hypothesis Hwf: well_founded (trans S).
  Let Hpwf: well_founded (trans (plus S)) := plus_wf Hwf.

  (** Lemma 4.1 *)
  Lemma diagram_plus_wf: diagram (star TX) (plus S) (star TX) (plus S).
  Proof.
    (* induction horizontale sur la terminaison de S+ *)
    intros x x'; cgen x.
    induction x' as [x' IH ] using (well_founded_ind Hpwf).
    intros x y xTx'; cgen y.
    (* induction verticale sur la dérivation de xT*x' *)
    induction xTx' as [ x | x1 x x' xTx1 x1Ts' IHv ]; intros y xSy.
    exists y; auto.
    destruct xSy as [ w xSw wSy ].
    destruct (HS xTx1 xSw) as [ w1 wTw1 x1Sw1 ].
    elim IHv with w1; auto; intros w' w1Tw' x'Sw'.
    destar wSy z.
    exists w'; auto; apply star_trans with w1; assumption.
    elim IH with w' w y; auto.
    intros y' yTy' w'Ty'.
    exists y'; auto; apply plus_trans with w'; assumption.
    apply star_trans with w1; assumption.
  Qed.

  Variable TX': relation X.

  Hypothesis HS': diagram TX' S (comp (star TX) TX') (plus S).

  (** Lemma 4.3 *)
  Lemma diagram_plus_wf_1: strong_commute (comp (star TX) TX') (plus S).
  Proof.
    (* induction horizontale sur la terminaison de S+ *)
    intros x x'; cgen x.
    induction x' as [x' IH ] using (well_founded_ind Hpwf).
    intros x y xTx' xSy; destruct xTx' as [ x1 xTx1 x1Tx' ].
    destruct (diagram_plus_wf xTx1 xSy) as [ y1 yTy1 x1Sy1 ].
    destruct x1Sy1 as [ w1 x1Sw1 w1Sy1 ].
    destruct (HS' x1Tx' x1Sw1) as [ w' w1Tw' x'Sw' ].
    destar w1Sy1 z1.
    destruct w1Tw' as [ w2 w1Tw2 w2Tw' ];
      exists w'; auto; exists w2; auto; apply star_trans with w1; auto.
    elim IH with w' w1 y1; auto.
    intros y' y1Ty' w'Sy'; exists y'.
    destruct y1Ty' as [ y2 y1Ty2 y2Ty' ];
      exists y2; auto; apply star_trans with y1; auto.
    apply plus_trans with w'; auto.
  Qed.

  Variable Y: Type.
  Variables R R': relation2 X Y.
  Variable TY TY': relation Y.

  Hypothesis HR: diagram TX R (star TY) (comp (star S) R).
  Hypothesis HR': diagram TX' R (comp (star TY) TY') (comp (star S) R').

  (** Proposition 4.4 *)
  Theorem diagram_plus_wf_2: diagram (comp (star TX) TX') (comp (star S) R) (comp (star TY) TY') (comp (star S) R').
  Proof.
    (* induction horizontale sur la terminaison de S+ *)
    intros x x'; cgen x.
    induction x' as [x' IH ] using (well_founded_ind Hpwf).
    intros x y xTx' xSRy; destruct xSRy as [ w xSw wRy ].
    destar xSw z.
     destruct xTx' as [ x1 xTx2 x2Tx' ].
     (* induction horizontale sur la terminaison de S+ *)
     cgen wRy; cgen y; induction xTx2 as [ x | x1 x x2 xTx1 x1Tx2 IHv ]; intros y xRy.
     exact (HR' x2Tx' xRy).
     destruct (HR xTx1 xRy) as [ y1 yTy1 x1SRy1 ].
     destruct x1SRy1 as [ w1 x1Sw1 w1Ry1 ]; destar x1Sw1 z1.
     elim IHv with y1; auto; intros y' y1Ty' x'SRy'.
     destruct y1Ty' as [ y2 ].
     exists y'; auto; exists y2; auto; apply star_trans with y1; auto.

     elim diagram_plus_wf_1 with x1 x' w1; auto.
     intros w' w1Tw' x'Sw'.
     elim IH with w' w1 y1; auto.
     intros y' y1Ty' w'SRy'; exists y'; auto.
     destruct y1Ty' as [ y2 ]; exists y2; auto; apply star_trans with y1; auto.
     destruct w'SRy' as [ z' ]; exists z'; auto; apply star_trans with w'; auto.
     exists w1; auto.
     exists x2; auto.

    destruct (diagram_plus_wf_1 xTx' xSw) as [ w' wTw' x'Sw' ].
     elim IH with w' w y; auto.
     intros y' yTy' w'SRy'; exists y'; auto.
     destruct w'SRy' as [ z' ]; exists z'; auto; apply star_trans with w'; auto.
     exists w; auto.
  Qed.

End PlusWf.

(** A Generalisation of Newmann's Lemma : Subsection 4.2 *)
Section StarWf.

  Variable X: Set.
  Variable S: relation X.
  Variable TX: relation X.

  Hypothesis HS: local_commute TX S.
  Hypothesis Hwf: well_founded (trans (comp (plus S) (plus TX))).

  Section Gen.
    Variable Y: Type.
    Variable R: relation2 X Y.
    Variable TY: relation Y.

    Let SR := comp (star S) R.
    Hypothesis HR: diagram TX R (star TY) SR.

    (** Lemma 4.5 *)
    Lemma diagram_star_wf_1: diagram (star TX) SR (star TY) SR.
    Proof.
      apply diagram_reverse.
      apply diagram_star.
      apply diagram_reverse.
      (* induction sur la terminaison de S+TX+ *)
      intro x; induction x as [ x IH ] using (well_founded_ind Hwf).
      intros x' y xTx' xSRy; cgen xTx'; cgen x'.
      destruct xSRy as [ z xSz zRy ].
      (* induction sur la dérivation xS*z *)
      induction xSz as [ x | w x z xSw wSz IHh ]; intros x' xTx'.
      destruct (HR xTx' zRy) as [ y' yTy' x'SRy' ]; exists y'; auto.
      destruct (HS xTx' xSw) as [ w' wTw' x'Sw' ].
      destruct wTw' as [ w | w1 w w' wTw1 w1Tw' ].
      exists y; auto; exists z; auto; apply star_trans with w; assumption.
      elim IHh with w1; auto. (* 1 *)
      intros z1 zTz1 w1Sz1.
      cut (forall w2, (* 2 *)
        star TX w1 w2 ->
        forall w3 y2,
  	TX w2 w3 -> SR w2 y2 -> exists2 y3, star TY y2 y3 & SR w3 y3).
      clear IH IHh xTx' xSw x wSz wTw1 w; intro IH; cgen w1Sz1; cgen zTz1; cgen z1.
      (* induction sur la dérivation w1T*w' *)
      induction w1Tw' as [ w1 | w2 w1 w' w1Tw2 w2Tw' IHv ]; intros y1 yTy1 w1SRy1.
      destruct w1SRy1 as [ z1 w1Sz1 z1Ry1 ].
      exists y1; auto; exists z1; auto; apply star_trans with w1; auto.
      elim IH with w1 w2 y1; auto; intros y2 y1Ty2 w2Sy2.
      elim IHv with y2; auto.
      intros y' y2Ty' w'SRy'.
      destruct w'SRy' as [ z' w'Sz' z'Ry' ].
      exists y'; auto; exists z'; auto; apply star_trans with z1; assumption.
      intros w3 w2Tw3 w4 y3 w3Tw4 w3SRy3.
      elim IH with w3 w4 y3; auto.
      intros y4 y3Ty4 w4SRy4.
      destruct w4SRy4 as [ z4 w4Sz4 s4Ry4 ].
      exists y4; auto; exists z4; auto; apply star_trans with w3; assumption.
      apply S_star with w2; assumption.
      apply star_trans with y1; assumption.

      (* factoriser ces deux petits bouts ??? *)

      intros w2 w1Tw2 w3 y2 w2Tw3 w2SRy2; destruct w2SRy2 as [ z2 w2Sz2 z2Ry2 ].
      elim IH with w2 w3 y2; auto.
      intros y3 y2Ty3 w3SRy3.
      exists y3; auto.
      exists w; auto.
      exists w1; assumption.
      exists z2; assumption.

      intros w2 wSTw2 w3 y2 w2Tw3 w2SRy2; destruct w2SRy2 as [ z2 w2Sz2 z2Ry2 ].
      destruct wSTw2 as [ u wSu uTw2 ].
      elim IH with w2 w3 y2; auto.
      intros y3 y2Ty3 w3SRy3; destruct w3SRy3 as [ z3 w3Sz3 z3Ry3 ].
      exists y3; auto.
      exists z3; auto.
      exists u; auto; exists w; auto.
      exists z2; assumption.
    Qed.

    Variables X' Y': Type.
    Variable TaX: relation2 X X'.
    Variable TaY: relation2 Y Y'.
    Variable S' : relation2 X' X'.
    Variable R' : relation2 X' Y'.

    Let SR' := comp (star S') R'.
    Let TAX := comp (star TX) TaX.
    Let TAY := comp (star TY) TaY.

    Hypothesis HT:  diagram TaX S TAX (star S').
    Hypothesis HRT: diagram TaX R TAY SR'.

    (** Proposition 4.8 *)
    Theorem diagram_star_wf_2: diagram TAX SR TAY SR'.
    Proof.
      apply diagram_reverse.
      apply diagram_incl with TAX (comp (star TY) TAY); auto.
      unfold TAX; eapply diagram_comp;
      apply diagram_reverse.
      apply diagram_star_wf_1.
      (* induction sur la terminaison de S+TX+ *)
      intro x; induction x as [ x IH ] using (well_founded_ind Hwf).
      intros x' y xTx' xSRy; cgen xTx'; cgen x'.
      destruct xSRy as [ z xSz zRy ].
      (* induction sur la dérivation xS*z *)
      induction xSz as [ x | w x z xSw wSz IHh ]; intros x' xTx'.
      destruct (HRT xTx' zRy) as [ y' yTy' x'SRy' ]; exists y'; auto.
      destruct (HT xTx' xSw) as [ w' wTw' x'Sw' ].
      destruct wTw' as [ wa wTwa waTw' ].
      destruct wTwa as [ w | w1 w wa wTw1 w1Twa ].
       elim IHh with w'; auto.
       intros y' yTy' w'SRy'; exists y'; auto.
       destruct w'SRy' as [ z' ]; exists z'; auto; apply star_trans with w'; assumption.
       intros u Hu; apply IH; auto; destruct Hu as [ t ]; exists t; auto; apply S_plus with w; auto.

       elim diagram_star_wf_1 with w wa y.
       intros ya yTya waSRya.
       elim IH with wa w' ya; auto.
       intros y' yaTy' w'SRy'; exists y'.
       destruct yaTy' as [ yb yaTyb ybTy' ]; exists yb; auto; apply star_trans with ya; assumption.
       destruct w'SRy' as [ z' w'Tz' z'Ty' ]; exists z'; auto; apply star_trans with w'; assumption.
       exists w; auto; exists w1; assumption.
       apply S_star with w1; assumption.
       exists z; auto.

      intros x y H; destruct H as [ z H H']; destruct H' as [ t ];
	exists t; auto; apply star_trans with z; assumption.
    Qed.

  End Gen.

  (** Corollary 4.6 *)
  Lemma diagram_star_wf: commute TX S.
  Proof.
    unfold commute.
    generalize (diagram_star_wf_1 (Y:=X) (R := eq (A:=X)) (TY:=TX)); intro H.
    intros x x' y xTx' xSy.
    elim H with x x' y; auto.
    intros y' yTy' x'Sy'; exists y'; auto.
    destruct x'Sy' as [ t' XT TY ].
    destruct TY; assumption.
    intros u u' v UU' UV; destruct UV; exists u'; auto; exists u'; auto.
    exists y; auto.
  Qed.

End StarWf.


Require Import Terms.

(** * Syntax with delayed exceptions in the value space *)

(** ** Values *)

(** We tell Coq not (to try) to generate induction principles for val.
   The generated induction principles are too weak to be useful anyway *)
Unset Elimination Schemes.

Inductive Val : Type :=
| VConst : Const -> Val
| VInx : Dir -> (Box * Lab) -> Val
| VClos : list (Var * (Box * Lab)) -> Var -> Tm -> Val
with Box : Type :=
| V : Val -> Box
| D : Excp -> Box.
(* The alternative to boxes is to use sums and some Notation *)

Set Elimination Schemes.

Fixpoint fv_val (v : Val) : list Var :=
  match v with
  | VConst c => []
  | VInx _ (b,_) => fv_box b
  | VClos rho x t => remove eq_var_dec x (fv_tm t)
  end
with fv_box (b : Box) : list Var :=
  match b with
  | V v => fv_val v
  | D e => []
  end.

Definition tag_of (v : Val) : Tag :=
  match v with
  | VConst c => tag_of_const c
  | VInx _ _ => TagSum
  | VClos _ _ _ => TagFun
  end.

(** ** Boxes, Atoms and Environments *)

Definition Atom := prod Box Lab.
Definition Env := list (Var * Atom).

Definition atom_lab: Atom -> Lab := @snd Box Lab.
Definition atom_box: Atom -> Box := @fst Box Lab.

Definition fv_atom (a : Atom) : list Var := fv_box (fst a).

Definition is_abs (v : Val) : Prop :=
  match v with
  | VClos _ _ _ => True
  | _ => False
  end.

Definition is_lab (v : Val) : Prop :=
  match v with
  | VConst (CLab _) => True
  | _ => False
  end.

Definition is_excp (v : Val) : Prop :=
  match v with
  | VConst (CExcp _) => True
  | _ => False
  end.

Definition is_sum (v : Val) : Prop :=
  match v with
  | VInx _ _ => True
  | _ => False
  end.

Definition is_box (is_val : Val -> Prop) (b : Box) : Prop :=
  match b with
  | V v => is_val v
  | D _ => False
  end.

(* We start with an induction principle in Type,
   but we later specialize it to Prop and Set *)
Section atom_box_val_env_rect.
  Variable Pval : Val -> Type.
  Variable Pbox : Box -> Type.
  Variable Patom : Atom -> Type.
  Variable Penv : Env -> Type.
  Hypothesis H_v_const : forall c, Pval (VConst c).
  Hypothesis H_v_inx : forall d a,
    Patom a -> Pval (VInx d a).
  Hypothesis H_v_clos : forall r x t,
    Penv r -> Pval (VClos r x t).
  Hypothesis H_b_val : forall v,
    Pval v -> Pbox (V v).
  Hypothesis H_b_nav : forall e,
    Pbox (D e).
  Hypothesis H_atom : forall b l,
    Pbox b -> Patom (b, l).
  Hypothesis H_nil : Penv nil.
  Hypothesis H_cons : forall x a r,
    Patom a -> Penv r -> Penv ((x,a) :: r).

  Fixpoint val_rect (v : Val) {struct v} : Pval v :=
    match v as v0 return Pval v0 with
      | VConst c => H_v_const c
      | VInx d (V v,l) =>
        H_v_inx d (V v,l) (H_atom (V v) l (H_b_val v (val_rect v)))
      | VInx d (D e,l) =>
        H_v_inx d (D e,l) (H_atom (D e) l (H_b_nav e))
      | VClos r x t => H_v_clos r x t
        ((fix env_rect' (r : Env) {struct r} : Penv r :=
          match r as r0 return Penv r0 with
            | nil => H_nil
            | (x,a)::r' => H_cons x a r'
              ((fix atom_rect' (a : Atom) {struct a} : Patom a :=
                match a as a0 return Patom a0 with
                  | (V v, l) => H_atom (V v) l (H_b_val v (val_rect v))
                  | (D e, l) => H_atom (D e) l (H_b_nav e)
                end
              ) a) (env_rect' r')
          end
        ) r)
    end.

(* once we have val_rect, we can easily obtain the three nested ones *)

  Definition box_rect (b : Box) : Pbox b :=
    match b with
      | V v => H_b_val v (val_rect v)
      | D e => H_b_nav e
    end.

  Definition atom_rect (a : Atom) : Patom a :=
    match a with
      | (v,l) => H_atom v l (box_rect v)
    end.

  Fixpoint env_rect (r : Env) {struct r} : Penv r :=
    match r as r0 return Penv r0 with
      | nil => H_nil
      | (x,a)::r' => H_cons x a r'
        (atom_rect a) (env_rect r')
    end.

End atom_box_val_env_rect.

Definition atom_rec
  (Pval: Val -> Set) (Pbox: Box->Set)
  (Patom: Atom -> Set) (Penv: Env -> Set) := atom_rect Pval Pbox Patom Penv.

Definition val_ind
  (Pval: Val->Prop) (Pbox: Box->Prop)
  (Patom: Atom->Prop) (Penv: Env->Prop) := val_rect Pval Pbox Patom Penv.

Definition box_ind
  (Pval: Val -> Prop) (Pbox: Box->Prop)
  (Patom: Atom -> Prop) (Penv: Env -> Prop) := box_rect Pval Pbox Patom Penv.

Definition atom_ind
  (Pval: Val -> Prop) (Pbox: Box->Prop)
  (Patom: Atom -> Prop) (Penv: Env -> Prop) := atom_rect Pval Pbox Patom Penv.

Definition env_ind
  (Pval: Val -> Prop) (Pbox: Box->Prop)
  (Patom: Atom -> Prop) (Penv: Env -> Prop) := env_rect Pval Pbox Patom Penv.

Combined Scheme val_box_atom_env_mutind from
  val_ind, box_ind, atom_ind, env_ind.

(** * Derived forms (values) *)

(** ** Constant values *)

Definition vUnit := VConst CUnit.
Definition vLab l := VConst (CLab l).
Definition vTag T := VConst (CTag T).
Definition vExcp e := VConst (CExcp e).

(** ** Sums *)

Definition vInl : Atom -> Val := VInx DLeft.
Definition vInr : Atom -> Val := VInx DRight.

(** ** Booleans *)

Definition vTrue : Val := vInl (V vUnit, bot).
Definition vFalse : Val := vInr (V vUnit, bot).


Require Import CoqlibC.

Set Implicit Arguments.

Class Linker (A: Type) := {
  link: A -> A -> option A;
  linkorder: A -> A -> Prop;
  linkorder_refl: forall x, linkorder x x;
  linkorder_trans: forall x y z, linkorder x y -> linkorder y z -> linkorder x z;
  link_linkorder: forall x y z, link x y = Some z -> linkorder x z /\ linkorder y z
}.

Inductive link_res (A: Type): Type :=
| empty
| fail
| success: A -> link_res A.

Arguments empty [A].
Arguments fail [A].

Fixpoint link_list_aux X `{Linker X} (xs: list X): link_res X :=
  match xs with
  | [] => empty
  | x0 :: tl =>
    match link_list_aux tl with
    | empty => success x0
    | fail => fail
    | success x1 =>
      match link x0 x1 with
      | Some x => success x
      | None => fail
      end
    end
  end.

Definition link_list X `{Linker X} (xs: list X): option X :=
  match link_list_aux xs with
  | empty => None (* Note that we are not giving semantics to empty programs. *)
  | success x => Some x
  | fail => None
  end.

Lemma link_list_cons
      X `{Linker X} hd tl restl res
      (TL: link_list tl = Some restl)
      (HD: link hd restl = Some res):
    <<LINK: link_list (hd :: tl) = Some res>> /\ <<LINKORDER: Forall (fun x => linkorder x res) (hd :: tl)>>.
Proof.
  split; red.
  - unfold link_list in *. des_ifs; ss; des_ifs.
  - eapply link_linkorder in HD. des. econs; auto. clear HD. unfold link_list in TL. des_ifs.
    generalize dependent restl. generalize dependent res.
    induction tl as [|h l]; auto. i. econs; unfold link_list_aux in *; des_ifs.
    { eapply link_linkorder in Heq1. des. eapply linkorder_trans; eauto. }
    { destruct l; auto. des_ifs. }
    eapply IHl; eauto. eapply link_linkorder in Heq1. des. eapply linkorder_trans; eauto.
Qed.

Lemma link_list_linkorder
      X `{Linker X} xs xs_res
      (LINK: link_list xs = Some xs_res):
    <<LINKORDER: Forall (fun x => linkorder x xs_res) xs>>.
Proof.
  destruct xs as [| hd tl]; auto.
  unfold link_list in LINK. des_ifs. unfold link_list_aux in Heq. des_ifs; fold link_list_aux in *.
  { destruct tl; ss. econs. apply linkorder_refl. econs. des_ifs. }
  econs. { eapply link_linkorder in Heq1. des. auto. }
  assert (link_list tl = Some x).
  { unfold link_list. rewrite Heq0. auto. }
  exploit link_list_cons; eauto. i. des.
  inv LINKORDER. auto.
Qed.

Lemma link_list_cons_inv
      X `{Linker X} hd tl res
      (LINK: link_list (hd :: tl) = Some res)
      (LEN: tl <> []):
    exists restl, <<TL: link_list tl = Some restl>> /\ <<HD: link hd restl = Some res>>.
Proof.
  unfold link_list in LINK. des_ifs. unfold link_list_aux in Heq. des_ifs; fold link_list_aux in *.
  { destruct tl; ss. econs. des_ifs. }
  exists x. split; auto. unfold link_list. rewrite Heq0. auto.
  Unshelve. auto.
Qed.