Require Export Coq.ZArith.ZArith.
Require Export Coq.Strings.String.
Require Export Crypto.Specific.GF25519.
Require Import Crypto.Reflection.Reify.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.Relations.
Require Import Crypto.Reflection.ExprInversion.
Require Import Crypto.Reflection.Linearize.
Require Import Crypto.Reflection.Eta.
Require Import Crypto.Reflection.EtaInterp.
Require Import Crypto.Reflection.Z.Reify.
Require Export Crypto.Reflection.Z.Syntax.
Require Import Crypto.Reflection.InterpWfRel.
Require Import Crypto.Reflection.LinearizeInterp.
Require Import Crypto.Reflection.WfReflective.
Require Import Crypto.Spec.MxDH.
Require Import Crypto.Specific.GF25519Reflective.Common.
Require Import Crypto.Specific.GF25519Reflective.Reified.Add.
Require Import Crypto.Specific.GF25519Reflective.Reified.Sub.
Require Import Crypto.Specific.GF25519Reflective.Reified.Mul.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.HList.
Require Import Crypto.Util.Tower.
Require Import Crypto.Util.Tactics.
Require Import Crypto.Util.Notations.
Require Import Bedrock.Word.

Definition rladderstepZ' var (T:=_) (a24 x0 : T) P1 P2
  := @MxDH.ladderstep_gen
       _
       (fun x y => LetIn (Pair x y) (invert_Abs (proj1_sig raddZ_sig var)))
       (fun x y => LetIn (Pair x y) (invert_Abs (proj1_sig rsubZ_sig var)))
       (fun x y => LetIn (Pair x y) (invert_Abs (proj1_sig rmulZ_sig var)))
       a24
       _
       (fun x y z w => (x, y, z, w)%expr)
       (fun v f => LetIn v
                         (fun k => f (SmartVarf k)))
       x0
       P1 P2.

Definition rladderstepZ'' : Syntax.Expr _ _ _
  := Linearize
       (ExprEta
          (fun var
           => Abs (fun a24_x0_P1_P2 : interp_flat_type _ (_ * _ * ((_ * _) * (_ * _)))
                   => let '(a24, x0, ((P10, P11), (P20, P21)))
                          := a24_x0_P1_P2 in
                      rladderstepZ'
                        var (SmartVarf a24) (SmartVarf x0)
                        (SmartVarf P10, SmartVarf P11)
                        (SmartVarf P20, SmartVarf P21)))).

Local Notation eta x := (fst x, snd x).

Definition ladderstep_other_assoc {F Fadd Fsub Fmul} a24 (X1:F) (P1 P2:F*F) : F*F*F*F :=
  Eval cbv beta delta [MxDH.ladderstep_gen] in
    @MxDH.ladderstep_gen
      F Fadd Fsub Fmul a24
      (F*F*F*F)
      (fun X3 Y3 Z3 T3 => (X3, Y3, Z3, T3))
      (fun x f => dlet y := x in f y)
      X1 P1 P2.

Definition uncurried_ladderstep
  := fun (a24_x0_P1_P2 : _ * _ * ((_ * _) * (_ * _)))
     => let a24 := fst (fst a24_x0_P1_P2) in
        let x0 := snd (fst a24_x0_P1_P2) in
        let '(P1, P2) := eta (snd a24_x0_P1_P2) in
        let '((P10, P11), (P20, P21)) := (eta P1, eta P2) in
        @ladderstep_other_assoc
          _ add sub mul
          a24 x0 (P10, P11) (P20, P21).

Local Notation rexpr_sigPf T uncurried_op rexprZ x :=
  (Interp interp_op (t:=T) rexprZ x = uncurried_op x)
    (only parsing).
Local Notation rexpr_sigP T uncurried_op rexprZ :=
  (forall x, rexpr_sigPf T uncurried_op rexprZ x)
    (only parsing).
Local Notation rexpr_sig T uncurried_op :=
  { rexprZ | rexpr_sigP T uncurried_op rexprZ }
    (only parsing).

Local Ltac fold_interpf' :=
  let k := (eval unfold interpf, interpf_step in (@interpf base_type interp_base_type op interp_op)) in
  let k' := fresh in
  let H := fresh in
  pose k as k';
  assert (H : @interpf base_type interp_base_type op interp_op = k') by reflexivity;
  change k with k'; clearbody k'; subst k'.

Local Ltac fold_interpf :=
  let k := (eval unfold interpf in (@interpf base_type interp_base_type op interp_op)) in
  let k' := fresh in
  let H := fresh in
  pose k as k';
  assert (H : @interpf base_type interp_base_type op interp_op = k') by reflexivity;
  change k with k'; clearbody k'; subst k';
  fold_interpf'.

Local Ltac repeat_step_interpf :=
  let k := (eval unfold interpf in (@interpf base_type interp_base_type op interp_op)) in
  let k' := fresh in
  let H := fresh in
  pose k as k';
  assert (H : @interpf base_type interp_base_type op interp_op = k') by reflexivity;
  repeat (unfold interpf_step at 1; change k with k' at 1);
  clearbody k'; subst k'.

Lemma rladderstepZ_sigP' : rexpr_sigP _ uncurried_ladderstep rladderstepZ''.
Proof.
  cbv [rladderstepZ''].
  intro x; rewrite InterpLinearize, InterpExprEta.
  cbv [domain interp_flat_type interp_base_type] in x.
  destruct_head' prod.
  cbv [invert_Abs domain codomain Interp interp SmartVarf smart_interp_flat_map fst snd].
  cbv [rladderstepZ' MxDH.ladderstep_gen uncurried_ladderstep SmartVarf smart_interp_flat_map]; simpl @fst; simpl @snd.
  repeat match goal with
         | [ |- appcontext[@proj1_sig ?A ?B ?v] ]
           => let k := fresh "f" in
              let k' := fresh "f" in
              let H := fresh in
              set (k := v);
                set (k' := @proj1_sig A B k);
                pose proof (proj2_sig k) as H;
                change (proj1_sig k) with k' in H;
                clearbody k'; clear k;
                  cbv beta in *
         end.
  cbv [Interp Curry.curry2] in *.
  unfold interpf, interpf_step; fold_interpf.
  cbv [ladderstep_other_assoc interp_flat_type GF25519.fe25519].
  Time
    abstract (
      repeat match goal with
             | [ |- (dlet x := ?y in @?z x) = (dlet x' := ?y' in @?z' x') ]
               => refine ((fun pf0 pf1 => @Proper_Let_In_nd_changebody _ _ Logic.eq _ y y' pf0 z z' pf1)
                            (_ : y = y')
                            (_ : forall x, z x = z' x));
                    cbv beta; intros;
                      [ cbv [Let_In Common.ExprBinOpT] | ]
             end;
        repeat match goal with
               | _ => rewrite !interpf_invert_Abs
               | _ => rewrite_hyp !*
               | _ => progress cbv [interp_base_type]
               | [ |- ?x = ?x ] => reflexivity
               | _ => rewrite <- !surjective_pairing
               end
    ).
Time Defined.
Lemma rladderstepZ_sigP : rexpr_sigP _ uncurried_ladderstep rladderstepZ''.
Proof.
  exact rladderstepZ_sigP'.
Qed.
Definition rladderstepZ_sig
  := exist (fun v => rexpr_sigP _ _ v) rladderstepZ'' rladderstepZ_sigP.

Definition rladderstep_input_bounds
  := (ExprUnOp_bounds, ExprUnOp_bounds,
      ((ExprUnOp_bounds, ExprUnOp_bounds),
       (ExprUnOp_bounds, ExprUnOp_bounds))).

Time Definition rladderstepZ : Expr _ := Eval vm_compute in proj1_sig rladderstepZ_sig.
Time Definition rladderstepW_pkgo := Eval vm_compute in rexpr_select_word_sizes_option rladderstepZ rladderstep_input_bounds.
Time Definition rladderstepW_pkg := Eval vm_compute in rexpr_select_word_sizes_postprocess1 rladderstepW_pkgo.
Time Definition rladderstepT := get_output_type rladderstepW_pkg.
Time Definition rladderstepW' : Expr _ := Eval vm_compute in get_output_expr rladderstepW_pkg.
Time Definition rladderstepW : Expr rladderstepT := Eval cbv [rladderstepW'] in rexpr_select_word_sizes_postprocess2 rladderstepW'.


Set Implicit Arguments.

Require Import List.
Require Import Arith.
Require Import Program.

Require Import Axioms.
Require Import JMUtils.
Require Import TypeSyntax.
Require Import KripkeSemantics.

Definition app : forall g1 g2, ty_environment g1 -> ty_environment g2 -> ty_environment (g1 + g2).
intros. dependent induction X.
 apply X0.
 apply ty_cons. apply P. apply IHX. apply X0.
Defined.

Definition re_app : forall W (Worder:preorder W) g1 g2 (e11 e12 : ty_environment g1) (e21 e22 : ty_environment g2),
  rel_environment Worder e11 e12 -> rel_environment Worder e21 e22 -> rel_environment Worder (app e11 e21) (app e12 e22).
intros. dependent induction X.
 apply X0.
 eapply rel_cons. apply k. apply IHX. apply X0.
Defined.

Lemma diagonal_app : forall W (Worder:preorder W) g1 g2 (e1 : ty_environment g1) (e2 : ty_environment g2),
  diagonal Worder (app e1 e2) = re_app (diagonal Worder e1) (diagonal Worder e2).
induction e1; intros; simpl.
 reflexivity.
 rewrite IHe1. reflexivity.
Save.

(* FIXME: factor this out from Shifting.v as well *)
Definition var_eq : forall g1 g2 (v : variable (g1 + g2))
  (e1 : ty_environment g1) (e2 : ty_environment g2) (A : Set),
  lookup_var v (app e1 e2) =
  lookup_var (shift_var g2 g1 v) (app (app e1 (A;: ty_nil)) e2).
intros. dependent destruction v.
simpl. destruct (le_lt_dec g1 i).
 (* g1 <= i *)
 unfold lookup_var. revert g1 e1 g2 e2 l l0. induction i; intros.
  (* i = 0 *)
  inversion l0. subst. dependent destruction e1. simpl. apply f_equal. apply proof_irrelevance.
  (* i > 0 *)
  dependent destruction e1.
   (* e1 = ty_nil *)
   simpl. apply f_equal. apply proof_irrelevance.
   (* e1 = ty_cons ... *)
   simpl. rewrite IHi. simpl. apply f_equal. apply proof_irrelevance. apply le_S_n. apply l0.
 (* i < g1 *)
 unfold lookup_var. revert g1 e1 g2 e2 l l0. induction i; intros.
  (* i = 0 *)
  dependent destruction e1.
   (* e1 = ty_nil *)
   inversion l0.
   (* e1 = ty_cons ... *)
   simpl. reflexivity.
  (* i > 0 *)
  dependent destruction e1.
   (* e1 = ty_nil *)
   inversion l0.
   (* e1 = ty_cons ... *)
   simpl. rewrite IHi.
   match goal with [ |- (lookup ?x _) = (lookup ?y _) ] => replace x with y end.
   reflexivity. apply proof_irrelevance.
   apply le_S_n. apply l0.
Save.

Lemma rel_eq : forall g1 g2 v,
  forall W (Worder:preorder W) (e11 e12 : ty_environment g1) (e21 e22 : ty_environment g2)
    (re1 : rel_environment Worder e11 e12) (re2 : rel_environment Worder e21 e22)
    (A1 A2 : Set) (R : W -> A1 -> A2 -> Prop)
    (Rkripke : kripke_relation Worder R)
    (t1 : lookup_var v (app e11 e21))
    (t2 : lookup_var v (app e12 e22))
    (t1' : lookup_var (shift_var g2 g1 v) (app (app e11 (A1;: ty_nil)) e21))
    (t2' : lookup_var (shift_var g2 g1 v) (app (app e12 (A2;: ty_nil)) e22))
    (w : W),
    JMeq t1 t1' ->
    JMeq t2 t2' ->
    rel_lookup_var v (re_app re1 re2) w t1 t2 =
    rel_lookup_var (shift_var g2 g1 v) (re_app (re_app re1 (Rkripke;; (rel_nil Worder))) re2) w t1' t2'.
intros g1 g2 v W Worder e11 e12 e21 e22 re1 re2 A1 A2 R Rkripke t1 t2 t1' t2' w eq1 eq2.
dependent destruction v.
simpl in *. destruct (le_lt_dec g1 i).
 (* g1 <= i *)
 revert g1 e11 e12 re1 g2 e21 e22 re2 l t1 t2 t1' t2' l0 eq1 eq2. induction i; intros.
  (* i = 0 *)
  inversion l0. subst. dependent destruction re1. simpl in *.
  match goal with [ |- _ ?X _ _ = _ ?Y _ _ ] => set (y:=Y) in * end.
  assert (l = y). apply proof_irrelevance. generalize y t1' eq1 t2' eq2 H. clear y t1' eq1 t2' eq2 H. intros. subst y.
  apply f_jmequal2.
   reflexivity.
   assumption.
   assumption.
  (* i > 0 *)
  dependent destruction re1.
   (* re1 = rel_nil *)
   simpl in *.
   match goal with [ |- _ ?X _ _ = _ ?Y _ _ ] => set (y:=Y) in * end.
   assert (l = y). apply proof_irrelevance. generalize y t1' eq1 t2' eq2 H. clear y t1' eq1 t2' eq2 H. intros. subst y.
   apply f_jmequal2.
    reflexivity.
    assumption.
    assumption.
   (* re1 = rel_cons .. *)
   simpl in *. fold plus in *.
   match goal with [ |- _ = _ ?Y _ _ ] => set (y:=Y) in * end.
   assert (y = (@eq_ind_r nat (S n) (fun n : nat => S i < n + g2)
       (lt_n_S i (n + g2) (lt_S_n i (n + g2) l)) (n + 1)
       (plus_comm n 1))).
    apply proof_irrelevance.
   generalize y t1' eq1 t2' eq2 H. clear y t1' eq1 t2' eq2 H. intros. subst y.
   rewrite IHi with (l:=lt_S_n i (n + g2) l) (re1:=re1) (re2:=re2) (t1':=t1') (t2':=t2').
    reflexivity.
    apply le_S_n. apply l0.
    assumption.
    assumption.
 (* i < g1 *)
 revert g1 e11 e12 re1 g2 e21 e22 re2 l t1 t2 t1' t2' l0 eq1 eq2. induction i; intros.
  (* i = 0 *)
  dependent destruction re1.
   (* re1 = rel_nil *)
   inversion l0.
   (* re1 = rel_cons ... *)
   simpl. apply f_jmequal2; trivial.
  (* i > 0 *)
  dependent destruction re1.
   (* re1 = rel_nil *)
   inversion l0.
   (* re1 = rel_cons ... *)
   simpl in *. fold plus in *.
   match goal with [ |- _  = _ _ _ _ _ ?X _ _ _ _ _ _ ] => set (x:=X) in * end.
   assert (x= (@eq_ind nat (n + S g2) (fun n : nat => i < n)
       (@eq_ind nat (S (n + g2)) (fun n : nat => i < n)
          (le_S (S i) (n + g2) (lt_S_n i (n + g2) l))
          (n + S g2) (plus_Snm_nSm n g2)) (n + 1 + g2)
       (plus_assoc n 1 g2))).
    apply proof_irrelevance.
   generalize x t1' t2' eq1 eq2 H. clear x t1' t2' eq1 eq2 H. intros. subst x.
   rewrite IHi with (l:=lt_S_n i (n + g2) l) (re1:=re1) (re2:=re2) (t1':=t1') (t2':=t2').
    reflexivity.
    apply le_S_n. apply l0.
    assumption.
    assumption.
Save.

Definition shift_sem_rel_eq : forall g1 g2 ty,
  ( forall (e1 : ty_environment g1) (e2 : ty_environment g2) A,
      ty_sem (app e1 e2) ty = ty_sem (app (app e1 (A;:ty_nil)) e2) (shift g2 g1 ty) )
  /\
  ( forall W (Worder:preorder W) (e11 e12 : ty_environment g1) (e21 e22 : ty_environment g2)
           (re1 : rel_environment Worder e11 e12) (re2 : rel_environment Worder e21 e22)
           (A1 A2 : Set) (R : W -> A1 -> A2 -> Prop) (Rkripke : kripke_relation Worder R) t1 t2 t1' t2' w,
           JMeq t1 t1' ->
           JMeq t2 t2' ->
           ty_rel (re_app re1 re2) ty w t1 t2 =
           ty_rel (re_app (re_app re1 (Rkripke;;(rel_nil Worder))) re2) (shift g2 g1 ty) w t1' t2').
intros g1 g2 ty.
dependent induction ty.
 (* ty_var *)
 unfold ty_sem. simpl.
 split.
  (* types *)
  apply var_eq.
  (* relations *)
  apply rel_eq.
 (* ty_arr *)
 change (shift g2 g1 (ty_arr ty1 ty2)) with (ty_arr (shift g2 g1 ty1) (shift g2 g1 ty2)).
 unfold ty_sem in *. unfold ty_rel in *. simpl in *.
 destruct IHty1 as [ty_eq1 rel_eq1].
 destruct IHty2 as [ty_eq2 rel_eq2].
 split.
  (* types *)
  intros. rewrite ty_eq1 with (e1:=e1) (e2:=e2) (A:=A). rewrite ty_eq2 with (e1:=e1) (e2:=e2) (A:=A). trivial.
  (* relations *)
  intros W Worder e11 e12 e21 e22 re1 re2 A1 A2 R.
  intros. apply prop_ext. split.
   intros.
    pose (tm1 := t1 (coerce (ty_eq1 e11 e21 A1) x1)).
    pose (tm2 := t2 (coerce (ty_eq1 e12 e22 A2) x2)).
    rewrite <- rel_eq2 with (t1:=tm1) (t2:=tm2).
     unfold tm1. unfold tm2. apply H1. assumption.
     rewrite rel_eq1 with (t1':=x1) (t2':=x2) (Rkripke:=Rkripke).
      apply H3.
      apply coerce_jmeq.
      apply coerce_jmeq.
     unfold tm1. apply f_jmequal.
      apply ty_eq2. assumption.
      apply coerce_jmeq.
     unfold tm2. apply f_jmequal.
      apply ty_eq2. assumption.
      apply coerce_jmeq.
   intros.
    pose (tm1 := t1' (coerce (sym_eq (ty_eq1 e11 e21 A1)) x1)).
    pose (tm2 := t2' (coerce (sym_eq (ty_eq1 e12 e22 A2)) x2)).
    rewrite rel_eq2 with (t1':=tm1) (t2':=tm2) (Rkripke:=Rkripke).
     unfold tm1. unfold tm2. apply H1. assumption.
     rewrite <- rel_eq1 with (t1:=x1) (t2:=x2) (R:=R).
      apply H3.
      symmetry. apply coerce_jmeq.
      symmetry. apply coerce_jmeq.
     unfold tm1. apply f_jmequal.
      apply ty_eq2.
      assumption.
      symmetry. apply coerce_jmeq.
     unfold tm2. apply f_jmequal.
      apply ty_eq2.
      assumption.
      symmetry. apply coerce_jmeq.
 (* ty_forall *)
 change (shift g2 g1 (ty_forall ty)) with (ty_forall (shift g2 (S g1) ty)).
 unfold ty_sem in *. unfold ty_rel in *. simpl in *.
 destruct (IHty (S g1) g2 ty) as [ty_eq IHrel_eq].
  reflexivity.
  reflexivity.
 clear IHty.
 match goal with [|- ?X /\ _]=>assert (ty_eq':X) end.
  (* do types earlier because we need it twice *)
  intros. apply subset_type_eq.
   apply set_forall_ext. intros. apply ty_eq with (e1:=a;:e1) (e2:=e2) (A:=A).
   intros. apply forall_ext with (A:=Type). intro W. apply forall_ext. intro Worder.
           apply forall_ext. intro A1. apply forall_ext. intro A2.
           apply forall_ext. intro R. apply forall_ext. intro Rkripke. apply forall_ext. intro w.
   rewrite diagonal_app. rewrite diagonal_app. rewrite diagonal_app. simpl.
   apply IHrel_eq with (re1:=Rkripke;;diagonal Worder e1) (re2:=diagonal Worder e2) (Rkripke:=@w_eq_kripke W Worder A).
    apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=a) (g:=b) (x1:=A1) (y1:=A1).
     intros. rewrite H0. apply ty_eq with (e1:=a';:e1) (e2:=e2) (A:=A).
     apply H.
     reflexivity.
    apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=a) (g:=b) (x1:=A2) (y1:=A2).
     intros. rewrite H0. apply ty_eq with (e1:=a';:e1) (e2:=e2) (A:=A).
     apply H.
     reflexivity.
 split.
  (* types *)
  apply ty_eq'.
  (* relations *)
  intros.
  apply forall_ext. intro A3. apply forall_ext. intro A4. apply forall_ext. intro R0. apply forall_ext. intro Rkripke0.
  destruct t1. destruct t1'. destruct t2. destruct t2'. simpl in *.
  apply IHrel_eq with (re1:=Rkripke0;;re1) (re2:=re2) (Rkripke:=Rkripke).
   apply f_jmequal_type with (f:=x) (g:=x0) (x1:=A3) (y1:=A3).
    intros. rewrite H1. apply ty_eq with (e1:=a';:e11) (e2:=e21) (A:=A1).
    refine (jmeq_exist _ _ H).
     apply set_forall_ext. intro. apply ty_eq with (e1:=a;:e11) (e2:=e21) (A:=A1).
     intros. apply forall_ext with (A:=Type). intro W'. apply forall_ext. intro W'order.
             apply forall_ext. intro A5. apply forall_ext. intro A6.
             apply forall_ext. intro R1. apply forall_ext. intro R1kripke. apply forall_ext. intro w'.
     rewrite diagonal_app. rewrite diagonal_app. rewrite diagonal_app. simpl.
     apply IHrel_eq with (re1:=R1kripke;;diagonal W'order e11) (re2:=diagonal W'order e21) (Rkripke:=@w_eq_kripke W' W'order A1).
      apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=a) (g:=b) (x1:=A5) (y1:=A5).
       intros. rewrite H2. apply ty_eq with (e1:=a';:e11) (e2:=e21) (A:=A1).
        apply H1.
        reflexivity.
      apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=a) (g:=b) (x1:=A6) (y1:=A6).
       intros. rewrite H2. apply ty_eq with (e1:=a';:e11) (e2:=e21) (A:=A1).
        apply H1.
        reflexivity.
      reflexivity.
   apply f_jmequal_type with (f:=x1) (g:=x2) (x1:=A4) (y1:=A4).
    intros. rewrite H1. apply ty_eq with (e1:=a';:e12) (e2:=e22) (A:=A2).
    refine (jmeq_exist _ _ H0).
     apply set_forall_ext. intro. apply ty_eq with (e1:=a;:e12) (e2:=e22) (A:=A2).
     intros. apply forall_ext with (A:=Type). intro W'. apply forall_ext. intro W'order.
             apply forall_ext. intro A5. apply forall_ext. intro A6.
             apply forall_ext. intro R1. apply forall_ext. intros R1kripke. apply forall_ext. intro w'.
     rewrite diagonal_app. rewrite diagonal_app. rewrite diagonal_app. simpl.
     apply IHrel_eq with (re1:=R1kripke;;diagonal W'order e12) (re2:=diagonal W'order e22) (Rkripke:=@w_eq_kripke W' W'order A2).
      apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=a) (g:=b) (x1:=A5) (y1:=A5).
       intros. rewrite H2. apply ty_eq with (e1:=a';:e12) (e2:=e22) (A:=A2).
        apply H1.
        reflexivity.
      apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=a) (g:=b) (x1:=A6) (y1:=A6).
       intros. rewrite H2. apply ty_eq with (e1:=a';:e12) (e2:=e22) (A:=A2).
        apply H1.
        reflexivity.
      reflexivity.
Save.

Lemma ty_shift1_equal : forall g (ty : type g) e A,
  ty_sem e ty = ty_sem (A;:e) (shift1 ty).
intros.
destruct (shift_sem_rel_eq 0 g ty).
unfold shift1.
apply (H ty_nil e A).
Save.

Lemma rel_shift1_equal : forall g (ty : type g) W (Worder:preorder W)
  (e1 e2 : ty_environment g) (re : rel_environment Worder e1 e2)
  (A1 A2 : Set) (R : W -> A1 -> A2 -> Prop) (Rkripke : kripke_relation Worder R) t1 t2 t1' t2' w,
  JMeq t1 t1' ->
  JMeq t2 t2' ->
  ty_rel re ty w t1 t2 =
  ty_rel (Rkripke;;re) (shift1 ty) w t1' t2'.
intros.
destruct (shift_sem_rel_eq 0 g ty).
unfold shift1.
apply H2 with (re1:=rel_nil Worder) (Rkripke:=Rkripke); assumption.
Save.

Lemma ty_shift1_twice_equal : forall g (ty : type g) e A B,
  ty_sem e ty = ty_sem (A;:B;:e) (shift1 (shift1 ty)).
intros.
transitivity (ty_sem (B;:e) (shift1 ty)); apply ty_shift1_equal.
Save.

Lemma rel_shift1_twice_equal : forall g (ty : type g) W (Worder:preorder W)
  (e1 e2 : ty_environment g) (re : rel_environment Worder e1 e2)
  (A1 A2 : Set) (RA : W -> A1 -> A2 -> Prop) (RAkripke : kripke_relation Worder RA)
  (B1 B2 : Set) (RB : W -> B1 -> B2 -> Prop) (RBkripke : kripke_relation Worder RB)
  t1 t2 t1' t2' w,
  JMeq t1 t1' ->
  JMeq t2 t2' ->
  ty_rel re ty w t1 t2 =
  ty_rel (RAkripke;;RBkripke;;re) (shift1 (shift1 ty)) w t1' t2'.
intros.
transitivity (ty_rel (RBkripke;;re) (shift1 ty) w (coerce (sym_eq (ty_shift1_equal ty e1 B1)) t1)
                                                  (coerce (sym_eq (ty_shift1_equal ty e2 B2)) t2)).
 apply rel_shift1_equal; symmetry; apply coerce_jmeq.
 apply rel_shift1_equal.
  eapply JMeq_trans. apply coerce_jmeq. assumption.
  eapply JMeq_trans. apply coerce_jmeq. assumption.
Save.

Definition ty_sem_shift1 : forall g (e : ty_environment g) ty A,
  ty_sem e ty ->
  ty_sem (A;:e) (shift g 0 ty).
intros. eapply coerce. symmetry. apply ty_shift1_equal. assumption.
Defined.

Lemma ty_rel_shift1 : forall g W (Worder:preorder W) (e1 e2:ty_environment g) re ty A1 A2 t1 t2
  R (Rkripke:kripke_relation Worder R) w,
  ty_rel re ty w t1 t2 ->
  ty_rel (Rkripke;;re) (shift1 ty) w (ty_sem_shift1 e1 ty A1 t1) (ty_sem_shift1 e2 ty A2 t2).
intros. refine (coerce _ H). symmetry.
rewrite <- rel_shift1_equal with (t1:=t1) (t2:=t2).
 reflexivity.
 symmetry. apply coerce_jmeq.
 symmetry. apply coerce_jmeq.
Save.


Require Coq.Vectors.Vector.
Export Vector.VectorNotations.
Require Export CoRN.stdlib_omissions.List.
Require Import Coq.Arith.Arith Coq.PArith.BinPos.

Set Implicit Arguments.

(**
* Rasters
An n by m raster is a matrix of booleans. Do not use Vector, which stores
a slow nat on each cons.
*)
Variant raster (columns lines : positive) : Set :=
| raster_data : list (list bool) -> raster columns lines.

(* TODO directly list (list bool), length of first line then
   all lines same length. *)
Definition raster_well_formed {columns lines : positive} (r : raster columns lines) : Prop
  := match r with raster_data _ _ d =>
     length d = Pos.to_nat lines
     /\ Forall (fun line : list bool => length line = Pos.to_nat columns) d
     end.

(** A series of notation allows rasters to be rendered (and to a certain
extent parsed) in Coq *)
Notation "'⎥' a b" := (List.cons a b)
  (format "'[v' '⎥' a '/' b ']'", at level 0, a, b at level 0) : raster.
Notation "'⎥' a" := (List.cons a List.nil)
  (format "'⎥' a", at level 0, a at level 0) : raster.
(*
Notation "☙" := (Vnil (vector bool _)) (at level 0, right associativity) : raster.
*)
Notation "█ a" := (List.cons true a) (at level 0, right associativity) : raster.
Notation "⎢" := (@List.nil bool) (at level 0, right associativity) : raster.
Notation "' ' a" := (List.cons false a) (at level 0, right associativity) : raster.
Notation "░ a" := (List.cons false a) (at level 0, right associativity, only parsing) : raster_parsing.

(** Standard rasters. *)
Definition emptyRaster n m : raster n m
  := raster_data n m (List.repeat (List.repeat false (Pos.to_nat n)) (Pos.to_nat m)).

Lemma emptyRaster_wf : forall n m, raster_well_formed (emptyRaster n m).
Proof.
  split.
  - apply repeat_length.
  - apply Forall_forall. intros.
    apply repeat_spec in H. subst x.
    apply repeat_length.
Qed.

(** Indexing into a raster *)
Definition RasterIndex {n m} (r:raster n m) i j : bool
  := let (d) := r in nth j (nth i d nil) false.

Lemma nth_repeat : forall A n (x:A) k d,
    nth n (List.repeat x k) d
    = if le_lt_dec k n then d else x.
Proof.
  intros. destruct (le_lt_dec k n).
  - apply nth_overflow. rewrite repeat_length. exact l.
  - apply (repeat_spec k x).
    apply nth_In.
    rewrite repeat_length.
    exact l.
Qed.

(** Indexing into an empty raster is alway empty *)
Lemma emptyRasterEmpty : forall n m i j,
    RasterIndex (emptyRaster n m) i j = false.
Proof.
 intros n m i j.
 simpl.
 rewrite (nth_repeat i (repeat false (Pos.to_nat n)) (Pos.to_nat m) nil).
 destruct (le_lt_dec (Pos.to_nat m) i).
 - destruct j; reflexivity.
 - rewrite (nth_repeat j false (Pos.to_nat n) false).
   destruct (le_lt_dec (Pos.to_nat n) j); reflexivity.
Qed.

(** [setRaster] transforms a raster by setting (or reseting) the (i,j)th
pixel. *)
Fixpoint updateList A (v : list A) (f : A->A) : nat -> list A :=
  match v with
  | nil => fun _ => nil
  | cons a' v' => fun i =>
    match i with
    | 0 => cons (f a') v'
    | S i' => cons a' (updateList v' f i')
    end
  end.

Lemma updateList_length : forall A (v:list A) f i,
    length (updateList v f i) = length v.
Proof.
  induction v.
  - reflexivity.
  - intros. simpl. destruct i.
    reflexivity. simpl. rewrite IHv. reflexivity.
Qed.

Lemma updateList_correct1 : forall A (v: list A) f i d1 d2,
i < length v -> nth i (updateList v f i) d1 = f (nth i v d2).
Proof.
 induction v.
  intros.
  absurd (i < 0); auto with *.
 intros f [|i] d1 d2 H.
  reflexivity.
 simpl.
 apply IHv.
 auto with *.
Qed.

Lemma updateList_correct2 : forall A (v: list A) f d1 i j,
i <> j ->
nth i (updateList v f j) d1 = nth i v d1.
Proof.
 induction v.
  reflexivity.
 intros f d1 i [|j] H; destruct i as [|i]; try reflexivity.
  elim H; auto.
 simpl.
 apply IHv.
 auto.
Qed.

Lemma updateList_overflow : forall A (v : list A) f i,
    length v <= i -> updateList v f i = v.
Proof.
 induction v.
 - reflexivity.
 - intros. simpl. destruct i.
   exfalso; inversion H.
   apply f_equal. rewrite IHv. reflexivity.
   apply le_S_n, H.
Qed.

Definition setRaster {n m} (r:raster n m) (x:bool) (i j:nat) : raster n m
  := let (d) := r in
     raster_data n m (updateList d (fun row => updateList row (fun _ => x) j) i).

Lemma setRaster_wf : forall n m (r:raster n m) x i j,
    raster_well_formed r -> raster_well_formed (setRaster r x i j).
Proof.
  intros. destruct r. destruct H. split.
  - rewrite updateList_length. exact H.
  - apply Forall_forall. intros.
    apply In_nth with (d:=nil) in H1.
    destruct H1 as [k [H1 H2]]. subst x0.
    rewrite Forall_forall in H0.
    rewrite updateList_length in H1.
    destruct (Nat.eq_dec k i).
    + subst i. rewrite updateList_correct1 with (d2:=nil).
      rewrite updateList_length.
      apply H0. apply nth_In, H1. exact H1.
    + rewrite (updateList_correct2 l). 2: exact n0.
      apply H0. apply nth_In, H1.
Qed.

Lemma setRaster_correct1
  : forall {n m : positive} (r:raster n m) x i j,
    raster_well_formed r ->
 (i < Pos.to_nat m) -> (j < Pos.to_nat n) ->
 RasterIndex (setRaster r x i j) i j = x.
Proof.
 intros n m r x i j rWf Hi Hj.
 destruct r. simpl. destruct rWf.
 rewrite updateList_correct1 with (d2:=nil).
 2: rewrite H; exact Hi.
 rewrite updateList_correct1. reflexivity.
 trivial.
 rewrite Forall_forall in H0.
 rewrite (H0 (nth i l nil)). exact Hj.
 apply nth_In.
 rewrite H. exact Hi.
Qed.

Lemma setRaster_overflow : forall {n m} (r:raster n m) x i j,
    raster_well_formed r ->
    (Pos.to_nat m <= i) \/ (Pos.to_nat n <= j) ->
    (setRaster r x i j) = r.
Proof.
  intros. destruct r.
  unfold setRaster. apply f_equal.
  destruct H.
  destruct H0.
  - apply updateList_overflow.
    rewrite H. exact H0.
  - clear H m.
    rewrite Forall_forall in H1.
    revert i. induction l.
    + reflexivity.
    + intro i. simpl. destruct i.
      f_equal. apply updateList_overflow.
      rewrite (H1 a). exact H0. left. reflexivity.
      f_equal. apply IHl.
      intros. apply H1. right. exact H.
Qed.

Lemma setRaster_correct2 : forall n m (r:raster n m) x i j i0 j0,
    raster_well_formed r ->
 (i <> i0) \/ (j <> j0) ->
 RasterIndex (setRaster r x i0 j0) i j = RasterIndex r i j.
Proof.
 intros n m r x i j i0 j0 rWf H.
 destruct (le_lt_dec (Pos.to_nat m) i0) as [Hm | Hm].
  rewrite setRaster_overflow; auto with *.
 destruct (le_lt_dec (Pos.to_nat n) j0) as [Hn | Hn].
  rewrite setRaster_overflow; auto with *.
 destruct r as [l]. simpl.
 destruct H.
 + f_equal.
   rewrite updateList_correct2.
   reflexivity. exact H.
 + destruct rWf. destruct (Nat.eq_dec i i0).
   subst i0.
   rewrite updateList_correct1 with (d2:=nil).
   2: rewrite H0; exact Hm.
   rewrite updateList_correct2.
   reflexivity. exact H.
   f_equal.
   rewrite updateList_correct2.
   reflexivity. exact n0.
Qed.


(* Accelder - Petru Ciocirlan 2E1, FII UAIC *)
Require Import Strings.String.
Local Open Scope string_scope.
Local Open Scope list_scope.
Scheme Equality for string.

(* TYPE: Natural *)
Inductive typeNat :=
| errNat : typeNat
| number : nat -> typeNat.

Coercion number : nat >-> typeNat.

Inductive AExp :=
| aVar : string -> AExp
(*| acVar : string -> AExp*)
| aNum : typeNat -> AExp
| aAdd : AExp -> AExp -> AExp
| aSub : AExp -> AExp -> AExp
| aMul : AExp -> AExp -> AExp
| aDiv : AExp -> AExp -> AExp
| aMod : AExp -> AExp -> AExp.

Coercion aVar : string >-> AExp.
Coercion aNum : typeNat >-> AExp.

Notation "A +' B" := (aAdd A B)(at level 50, left associativity).
Notation "A -' B" := (aSub A B)(at level 50, left associativity).
Notation "A *' B" := (aMul A B)(at level 48, left associativity).
Notation "A /' B" := (aDiv A B)(at level 48, left associativity).
Notation "A %' B" := (aMod A B)(at level 45, left associativity).

(* TYPE: Boolean *)
Inductive typeBool :=
| errBool : typeBool
| boolean : bool -> typeBool.

Coercion boolean: bool >-> typeBool.

Inductive BExp :=
| boolTrue : BExp
| boolFalse : BExp
| bVar : string -> BExp
(*| bcVar : string -> BExp*)
| bBool : typeBool -> BExp
| bNot : BExp -> BExp
| bAnd : BExp -> BExp -> BExp
| bOr : BExp -> BExp -> BExp
| bXor : BExp -> BExp -> BExp
| bLessThan : AExp -> AExp -> BExp
| bEqual : AExp -> AExp -> BExp.

Coercion bVar : string >-> BExp.
Coercion bBool : typeBool >-> BExp.

Notation "!' A" := (bNot A)(at level 51, left associativity).
Notation "A &&' B" := (bAnd A B)(at level 52, left associativity).
Notation "A ||' B" := (bOr A B)(at level 53, left associativity).
Notation "A ^' B" := (bXor A B)(at level 54, left associativity).
Notation "A <' B" := (bLessThan A B) (at level 70).
Notation "A ==' B" := (bEqual A B) (at level 70).

(* TYPE: Integer *)
Require Import ZArith.

(* TYPE: Float *)
Require Import Floats.

(* TYPE: Character (ASCII) *)
Require Import Ascii.

(* TYPE: String *)
(* Require Import String. already imported *)

(* TYPE: Pointer? *)

(* TYPE: Declarations *)

Inductive Attribute :=
(*| static*)
(*| constant*)
| volatile. (* default *)

Inductive Decl :=
| voidParam
| declVar : Attribute -> string -> Decl
| declNat : Decl -> Decl
| declBool : Decl -> Decl
| declarations : Decl -> Decl -> Decl.
(*| declUserType : string -> Decl -> Decl.*)

(*Notation "'static' 'var' X" := (declVar static X) (at level 41).*)
(*Notation "'constant' 'var' X" := (declVar constant X) (at level 41).*)
Notation "'var' X" := (declVar volatile X) (at level 42).
Notation "X ':' 'NAT'" := (declNat X) (at level 43).
Notation "X ':' 'BOOL'" := (declBool X) (at level 43).
Notation "X ',' Y" := (declarations X Y) (at level 41, left associativity).
(*Notation "'struct' X '{>' Y '<}'" := (declUserType X Y) (at level 45).*)

(*Inductive Cases :=
| caseDefault
| case : Result -> Cases
| *)

Inductive Arguments :=
| voidArg
| argument : string -> Arguments
| arguments : Arguments -> Arguments -> Arguments.

Coercion argument: string >-> Arguments.
Notation "A 'si' B" := (arguments A B) (at level 98, left associativity).

(* TYPE: Instructions *)
Inductive Stmt :=
| nop
| declStmt: Decl -> Stmt
| declAutovalue : Decl -> string -> Stmt
(*| declAutoRvalue : Decl -> Result -> Stmt*)
| assignNat : string -> AExp -> Stmt
| assignBool : string -> BExp -> Stmt
| call : string -> Arguments -> Stmt
| sequence : Stmt -> Stmt -> Stmt
| ifthenelse : BExp -> Stmt -> Stmt -> Stmt
| ifthen : BExp -> Stmt -> Stmt
| ternary : BExp -> Stmt -> Stmt -> Stmt
| whileloop : BExp -> Stmt -> Stmt
(*| forloopst : Stmt -> BExp -> Stmt -> Stmt -> Stmt*)
| break
| continue.
(*| switch : *)

Coercion declStmt: Decl >-> Stmt.

Notation "A ':N=' B" := (assignNat A B) (at level 90).
Notation "A ':B=' B" := (assignBool A B) (at level 90).
Notation "A ':auto=' B" := (declAutovalue A B) (at level 91).
(*Notation "A ':autoR=' B" := (declAutoRvalue A B) (at level 91).*)
Notation "A '(>' B '<)' 'call!'" := (call A B) (at level 91).
Notation "S1 ':D' S2" := (sequence S1 S2) (at level 93, right associativity).
Notation "'if*' '(' cond ')' '{' S1 '}' 'else*' '{' S2 '}' 'endif'" := (ifthenelse cond S1 S2) (at level 95).
Notation "'if*' '(' cond ')' '{' S '}' 'endif'" := (ifthen cond S) (at level 94).
Notation "'(t' cond 't)' '?*' '(' Strue ')' ':' '(' Sfalse ')'" := (ternary cond Strue Sfalse) (at level 95).
Notation "'while' '(' cond ')' '{' S '}' 'endwhile'" := (whileloop cond S) (at level 96).
Notation "'forloop' '(' A '~*' B '~*' C ')' '{' S '}' 'endfor'" := (A :D while (B) { S :D C } endwhile) (at level 97).

Inductive typeFunction :=
| func : Decl -> Stmt -> typeFunction
| funcUndeclared : typeFunction.

Inductive Program :=
| function : string -> typeFunction -> Program
| globalDecl : Decl -> Program
| seqProgram : Program -> Program -> Program.

Coercion globalDecl : Decl >-> Program.

Notation "'def' N '(!' P '!)' '{' S '}'" := (function N (func P S)) (at level 92).
Notation "P1 :P P2" := (seqProgram P1 P2) (at level 99).

(* TYPE: result - value *)
Inductive Result :=
| errAssign : Result
| errRedeclared : Result
| errUndeclared : Result
| undeclared : Result
| resultNat : typeNat -> Result
| resultBool : typeBool -> Result
| resultFunc : typeFunction -> Result.

Coercion resultNat : typeNat >-> Result.
Coercion resultBool : typeBool >-> Result.
Coercion resultFunc : typeFunction >-> Result.

Definition check_eq_over_types ( t1 : Result) ( t2 : Result) : bool :=
  match t1 with
    | errAssign => match t2 with
      | errAssign => true
      | _ => false
      end

    | errRedeclared => match t2 with
      | errRedeclared => true
      | _ => false
      end

    | errUndeclared => match t2 with
      | errUndeclared => true
      | _ => false
      end

    | undeclared => true

    | resultNat a => match t2 with
      | resultNat b => true
      | _ => false
      end

    | resultBool a => match t2 with
      | resultBool b => true
      | _ => false
      end

    | resultFunc a => match t2 with
      | resultFunc b => true
      | _ => false
      end
  end.

Inductive Mem :=
  | mem_default : Mem
  | offset : nat -> Mem. (* offset which indicates the current number of memory zones *)

Scheme Equality for Mem.

(* Environment *)
Definition Env := string -> Mem.

(* Memory Layer *)
Definition MemLayer := Mem -> Result.

(* Stack *)
Definition Stack := list Env.

(* Configuration *)
Inductive Config :=
  (* nat: last memory zone
     Env: environment
     MemLayer: memory layer
     Stack: stack
  *)
  | config : nat -> Env -> MemLayer -> Stack -> Config
  | errConfig.

(* Function for updating the environment *)
Definition update_env (env: Env) (x: string) (n: Mem) : Env :=
  fun y =>
      (* If the variable has assigned a default memory zone,
         then it will be updated with the current memory offset *)
      if (andb (string_beq x y ) (Mem_beq (env y) mem_default))
      then
        n
      else
        (env y).

(* Function for updating the memory layer *)
Definition update_mem (mem : MemLayer) (env : Env) (x : string) (zone : Mem) (v : Result) : MemLayer :=
  fun y =>
      if (Mem_beq y zone)
      then
        if (Mem_beq (env x) mem_default)
        then errUndeclared
        else
          if (Mem_beq (env x) y)
          then
            if (check_eq_over_types (mem y) v)
            then v
            else errAssign
          else mem y
      else mem y.
    (* To be implemented based on the functionalities of your own language
       This implementation should be similar to the "update" function from "Week_7.v" *)

(* Each variable/function name is initially mapped to undeclared *)

Definition update_conf (conf : Config) (zone : nat) (env : Env) (mem : MemLayer) (stack : Stack) : Config :=
  config zone env mem stack.

Fixpoint aeval (exp : AExp) (conf : Config) : typeNat :=
  match conf with
  | config level env mem stack =>
    match exp with
    | aVar symbol => match (mem (env symbol)) with
      | resultNat X => X
      | _ => errNat
      end

    | aNum num => num

    | aAdd exp1 exp2 => match (aeval exp1 conf) with
      | number X => match (aeval exp2 conf) with
        | number Y => Nat.add X Y
        | _ => errNat
        end
      | _ => errNat
      end

    | aSub exp1 exp2 => match (aeval exp1 conf) with
      | number X => match (aeval exp2 conf) with
        | number Y => if (Nat.ltb X Y)
                      then errNat
                      else Nat.sub X Y
        | errNat => errNat
        end
      | _ => errNat
      end

    | aMul exp1 exp2 => match (aeval exp1 conf) with
      | number X => match (aeval exp2 conf) with
        | number Y => Nat.mul X Y
        | _ => errNat
        end
      | _ => errNat
      end

    | aDiv exp1 exp2 => match (aeval exp1 conf) with
      | number X => match (aeval exp2 conf) with
        | number Y => if (Nat.eqb Y 0)
                      then errNat
                      else Nat.div X Y
        | _ => errNat
        end
      | _ => errNat
      end

    | aMod exp1 exp2 => match (aeval exp1 conf) with
      | number X => match (aeval exp2 conf) with
        | number Y => if (Nat.eqb Y 0)
                      then errNat
                      else Nat.modulo X Y
        | _ => errNat
        end
      | _ => errNat
      end
    end
  | _ => errNat
  end.

Fixpoint beval (bexp : BExp) (conf : Config) : typeBool :=
  match conf with
  | config level env mem stack =>
    match bexp with
    | boolTrue => true

    | boolFalse => false

    | bVar symbol => match (mem (env symbol)) with
      | resultBool X => X
      | _ => errBool
      end

    | bBool X => X

    | bNot b => match (beval b conf) with
      | boolean X => negb X
      | errBool => errBool
      end

    | bAnd b1 b2 => match (beval b1 conf) with
      | boolean X => match (beval b2 conf) with
        | boolean Y => andb X Y
        | errBool => errBool
        end
      | errBool => errBool
      end

    | bOr b1 b2 => match (beval b1 conf) with
      | boolean X => match (beval b2 conf) with
        | boolean Y => orb X Y
        | errBool => errBool
        end
      | errBool => errBool
      end

    | bXor b1 b2 => match (beval b1 conf) with
      | boolean X => match (beval b2 conf) with
        | boolean Y => xorb X Y
        | errBool => errBool
        end
      | errBool => errBool
      end

    | bLessThan a1 a2 => match (aeval a1 conf) with
      | number X => match (aeval a2 conf) with
        | number Y => Nat.ltb X Y
        | errNat => errBool
        end
      | errNat => errBool
      end

    | bEqual a1 a2 => match (aeval a1 conf) with
      | number X => match (aeval a2 conf) with
        | number Y => Nat.eqb X Y
        | errNat => errBool
        end
      | errNat => errBool
      end
    end
  | _ => errBool
  end.

Definition get_fn_signature (conf : Config) (symbol : string) : typeFunction :=
  match conf with
  | config level env mem stack => match mem (env symbol) with
                                  | resultFunc X => X
                                  | _ => funcUndeclared
                                  end
  | _ => funcUndeclared
  end.

Definition check_if_fn_exists (conf : Config) (symbol : string) : bool :=
  match get_fn_signature conf symbol with
  | funcUndeclared => false
  | _ => true
  end.

Fixpoint check_fn_arguments (conf : Config) (params : Decl) (args : Arguments) : bool :=
  match params with
  | voidParam => match args with
    | voidArg => true
    | _ => false
    end
  | declVar attr symbol => false
  | declNat D => match args with
    | argument symbol => match conf with
      | config zone env mem stack => check_eq_over_types (mem (env symbol)) (number 0)
      | _ => false
      end
    | _ => false
    end
  | declBool D => match args with
    | argument symbol => match conf with
      | config zone env mem stack => check_eq_over_types (mem (env symbol)) true
      | _ => false
      end
    | _ => false
    end
  | declarations D1 D2 => match args with
    | arguments A1 A2 => (check_fn_arguments conf D1 A1) && (check_fn_arguments conf D2 A2)
    | _ => false
    end
  end.

Fixpoint update_conf_decls (decls : Decl) (conf : Config) (gas : nat) : Config :=
  match gas with
  | 0 => conf
  | S gas' => match conf with
    | config zone env mem stack => match decls with
      | voidParam => conf
      | declVar attr symbol => errConfig
      | declNat D => match D with
        | declVar attr symbol =>
            if (Mem_beq (env symbol) mem_default)
            then update_conf conf (S zone) (update_env env symbol (offset (S zone))) (update_mem mem (update_env env symbol (offset (S zone))) symbol (offset (S zone)) (number 0)) stack
            else update_conf conf zone env (update_mem mem env symbol (env symbol) errRedeclared) stack
        | _ => errConfig
        end
      | declBool D => match D with
        | declVar attr symbol => match attr with
          (*| constant => ...*)
          | volatile =>
            if (Mem_beq (env symbol) mem_default)
            then update_conf conf (S zone) (update_env env symbol (offset (S zone))) (update_mem mem (update_env env symbol (offset (S zone))) symbol (offset (S zone)) false) stack
            else update_conf conf zone env (update_mem mem env symbol (env symbol) errRedeclared) stack
          end
        | _ => errConfig
        end
      | declarations D1 D2 => update_conf_decls D2 (update_conf_decls D1 conf gas') gas'
      end
    | _ => errConfig
    end
  end.

Fixpoint parseInit (program : Program) (conf : Config) (gas : nat) : Config :=
  match gas with
  | 0 => conf
  | S gas' => match conf with
    | config zone env mem stack => match program with
      | seqProgram P1 P2 => parseInit P2 (parseInit P1 conf gas') gas'
      | function symbol signature => update_conf conf (S zone) (update_env env symbol (offset (S zone))) (update_mem mem (update_env env symbol (offset (S zone))) symbol (offset (S zone)) signature) stack
      | globalDecl X => update_conf_decls X conf gas'
      end
    | _ => errConfig
    end
  end.

Definition update_conf_argument (param : Decl) (arg : Arguments) (oldConf conf : Config) : Config :=
  match param with
  | declNat D => match D with
    | declVar attr symbol => match arg with
      | argument argname => match conf with
        | config zone env mem stack =>
          match oldConf with
          | config oldZone oldEnv oldMem oldStack =>
            update_conf conf (S zone) (update_env env symbol (offset (S zone))) (update_mem mem (update_env env symbol (offset (S zone))) symbol (offset (S zone)) (oldMem (oldEnv argname))) stack
          | _ => errConfig
          end
        | _ => errConfig
        end
      | _ => errConfig
      end
    | _ => errConfig
    end
  | declBool D => match D with
    | declVar attr symbol => match arg with
      | argument argname => match conf with
        | config zone env mem stack =>
          match oldConf with
          | config oldZone oldEnv oldMem oldStack =>
            update_conf conf (S zone) (update_env env symbol (offset (S zone))) (update_mem mem (update_env env symbol (offset (S zone))) symbol (offset (S zone)) (oldMem (oldEnv argname))) stack
          | _ => errConfig
          end
        | _ => errConfig
        end
      | _ => errConfig
      end
    | _ => errConfig
    end
  | _ => errConfig
  end.

(* DEBUGGING DEBUGGING DEBUGGING DEBUGGING *)

Fixpoint update_conf_arguments (params : Decl) (args : Arguments) (oldConf conf : Config) (gas : nat) : Config :=
  match gas with
  | 0 => conf
  | S gas' => match params with
    | declarations D1 D2 => match args with
      | arguments A1 A2 => update_conf_arguments D2 A2 oldConf (update_conf_arguments D1 A1 oldConf conf gas') gas'
      | _ => errConfig
      end
    | declNat D => match args with
      | argument A => update_conf_argument (declNat D) (argument A) oldConf conf
      | _ => errConfig
      end
    | declBool D => match args with
      | argument A => update_conf_argument (declNat D) (argument A) oldConf conf
      | _ => errConfig
      end
    | voidParam => match args with
      | voidArg => conf
      | _ => errConfig
      end
    | _ => errConfig
    end
  end.

Definition env0 : Env := fun x => mem_default.
Definition mem0 : MemLayer := fun x => undeclared.

Fixpoint evalStmts (stmts : Stmt) (conf : Config) (gas : nat) : Config :=
  match gas with
  | 0 => conf
  | S gas' => match stmts with
    | nop (*no operation*) => conf

    | declStmt D => update_conf_decls D conf 32

    | declAutovalue D esymbol =>
      match D with
      | declVar attr nsymbol =>
        match conf with
        | config zone env mem stack =>
          if (Mem_beq (env nsymbol) mem_default)
          then
            if (Mem_beq (env esymbol) mem_default)
            then update_conf conf zone env (update_mem mem env nsymbol (env nsymbol) errUndeclared) stack
            else update_conf conf (S zone) (update_env env nsymbol (offset (S zone))) (update_mem mem (update_env env nsymbol (offset (S zone))) nsymbol (offset (S zone)) (mem (env esymbol))) stack
          else update_conf conf zone env (update_mem mem env nsymbol (env nsymbol) errRedeclared) stack
        | _ => errConfig
        end
      | _ => errConfig
      end

    | assignNat symbol exp =>
      match conf with
      | config zone env mem stack =>
        if (Mem_beq (env symbol) mem_default)
        then update_conf conf zone env (update_mem mem env symbol (env symbol) errUndeclared) stack
        else update_conf conf zone env (update_mem mem env symbol (env symbol) (aeval exp conf)) stack
      | _ => errConfig
      end

    | assignBool symbol exp =>
      match conf with
      | config zone env mem stack =>
        if (Mem_beq (env symbol) mem_default)
        then update_conf conf zone env (update_mem mem env symbol (env symbol) errUndeclared) stack
        else update_conf conf zone env (update_mem mem env symbol (env symbol) (resultBool (beval exp conf))) stack
      | _ => errConfig
      end

    | call symbol args =>
      if (check_if_fn_exists conf symbol)
      then
        match (get_fn_signature conf symbol) with
        | func D St =>
          if (check_fn_arguments conf D args)
          then
            match conf with
            | config zone env mem stack =>
              match (update_conf_arguments D args conf (update_conf conf zone (update_env env0 "result" (env "result")) mem stack) 32) with
              | config zone1 env1 mem1 stack1 =>
                match evalStmts St (update_conf (config zone1 env1 mem1 stack1) zone1 env1 mem1 (env :: stack1)) gas' with
                | config zoneR envR memR stackR =>
                  update_conf (config zoneR envR memR stackR) zone(*R*) env memR stack
                | _ => errConfig
                end
              | _ => errConfig
              end
            | _ => errConfig
            end
          else errConfig
        | _ => errConfig
        end
      else errConfig

    | sequence S1 S2 => evalStmts S2 (evalStmts S1 conf gas') gas'

    | ifthenelse cond S1 S2 =>
      match (beval cond conf) with
      | boolean b =>
        if (b)
        then evalStmts S1 conf gas'
        else evalStmts S2 conf gas'
      | _ => errConfig
      end

    | ifthen cond St =>
      match (beval cond conf) with
      | boolean b =>
        if (b)
        then evalStmts St conf gas'
        else conf
      | _ => errConfig
      end

    | ternary cond S1 S2 => evalStmts (ifthenelse cond S1 S2) conf gas'

    | whileloop cond St =>
      match (beval cond conf) with
      | boolean b =>
        if (b)
        then evalStmts (whileloop cond St) (evalStmts St conf gas') gas'
        else conf
      | _ => errConfig
      end
(*
    | forloop Si cond Sr Sb => match evalStmts Si conf gas' with
      | conf2 => evalStmts (whileloop cond (sequence Sb Sr)) conf2 gas'
      end
*)
    | _ => errConfig
    end
  end.

Definition evalMain (func : Result) (conf : Config) : Config :=
  match func with
  | resultFunc fn => match fn with
    | func D stmts => match D with
      | voidParam => evalStmts stmts conf 64
      | _ => errConfig
      end
    | funcUndeclared => errConfig
    end
  | _ => errConfig
  end.

Definition run (program : Program) : Config :=
  match (parseInit program (config 0 (update_env env0 "result" (offset 0)) (update_mem mem0 (update_env env0 "result" (offset 0)) "result" (offset 0) (number 0)) nil) 32) with
  | config level env mem stack => evalMain (mem (env "main")) (config level env mem stack)
  | _ => errConfig
  end.

Definition programX :=
  def "increment" (! voidParam !)
  {
    "result" :N= "result" +' 1
  } :P

  def "assign" (! var "first" : NAT, var "second" : BOOL !)
  {
    if* ( !' "second" )
    {
      "result" :N= 123
    }
    else*
    {
      "result" :N= "first"
    } endif
  } :P

  (*struct "mystruct" {>
    var "a" : NAT,
    var "b" : BOOL
  <} :P*)

  def "main" (! voidParam !)
  {
    var "hello" : NAT :D
    "hello" :N= 5 :D

    var "boooool" : BOOL :D
    "boooool" :B= true :D

    var "test" :auto= "boooool" :D

    if* ( "test" )
    {
      while ( "hello" <' 32 )
      {
        "boooool" :B= false :D
        "hello" :N= "hello" +' 1
      } endwhile
    }
    else*
    {
      "hello" :N= 99
    } endif :D

    var "loopresult" :auto= "hello" :D

    var "sum" : NAT :D "sum" :N= 0 :D

    "result" :N= 0 :D

    var "passes5" : BOOL :D "passes5" :B= false :D

    var "counter" : NAT :D
    forloop ( "counter" :N= 5 ~* !'(("counter" %' 13) ==' 3)  ~* "counter" :N= "counter" +' 1 )
    {
      "increment"(> voidArg <) call! :D
      "sum" :N= "sum" +' "result" :D
      (t "counter" ==' 6 t) ?* ( "passes5" :B= true ) : ( nop )
    } endfor :D

    "assign"(> "hello" si "boooool" <) call! :D
    var "foobar_result" :auto= "result" :D

    "result" :N= "counter"
  }
  .

Definition programY :=
  def "main" (! voidParam !)
  {
    var "hello" : NAT :D

    "hello" :N= 9 :D

    (*var "hah" :auto= "hello" :D*)

    var "hah" : NAT :D

    (*"hah" :N= "hah" +' 3 +' "hello" :D*)

    "result" :N= "hello" +' "hello"
  }.

Check programY.

Compute match (run programX) with
  | config zone env mem stack =>
    (mem (env "foobar_result"))
  | _ => 999
  end.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext uniq_tac.
Require Import bipl seplog.

Require Import integral_type.
Module Import seplog_Z_m := Seplog ZIT.
Import seplog_Z_m.assert_m.expr_m.
Import seplog_Z_m.assert_m.

Local Open Scope Z_scope.
Local Open Scope heap_scope.
Local Open Scope seplog_expr_scope.
Local Open Scope seplog_cmd_scope.
Local Open Scope seplog_assert_scope.
Local Open Scope seplog_hoare_scope.

(** the mandatory reverse list program *)

(** the fields of the cell structure *)
Definition data := 0.
Definition next := 1.

(** i points to the input list
    rem points to the remainder of the input list (what's left to be processed)
    ret points to the output list (the reversed "head") *)
Definition reverse_list (i ret rem : var.v) :=
  ret <- nat_e 0 ;
  while.while ( var_e i \!= nat_e 0 ) (
       rem <-* (i -.> next) ;
       (i -.> next) *<- var_e ret ;
       ret <- var_e i ;
       i <- var_e rem
  ).

(** this assertion represents the fact that a list begin at some address i and
    ends pointing to some address j *)
Inductive list_seplog : seq Z -> nat -> nat -> assert :=
| list_end : forall l i j s h,
  assert_m.emp s h ->
  i = j ->
  l = nil ->
  list_seplog l i j s h
| list_next : forall l i k s h hd tl j h1 h2,
  h1 # h2 ->
  h = h1 \U h2 ->
  i <> k ->
  i <> j ->
  l = hd :: tl ->
  (nat_e i |--> cst_e hd :: nat_e j :: nil) s h1 ->
  list_seplog tl j k s h2 ->
  list_seplog l i k s h.

Lemma list_seplog_ext l i j s1 s2 h : list_seplog l i j s1 h -> list_seplog l i j s2 h.
Proof. elim; clear l i j s1 h; move=> *; by [constructor | econstructor 2; eauto]. Qed.

Lemma list_seplog_hd_neq l1 l2 hd1 hd2 s h :
  (list_seplog l1 hd1 0 ** list_seplog l2 hd2 0) s h -> hd1 <> O -> hd1 <> hd2.
Proof.
move=> H H0.
case_sepcon H.
inversion_clear H_h1 as [| l l' d i j k s0 h0 h1_ h2_ H H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11]; subst => //.
inversion H_h2; subst => //.
rewrite /= in H5; case_sepcon H5.
rewrite /= in H10; case_sepcon H10.
case : H5_h1_1 => [x1 [/= Hx1 H20]].
case : H10_h11 => [x2 [/= Hx2 H18]].
subst x1 x2.
have : h11 # h1_1 by map_tac_m.Disj.
rewrite H18 H20; move/heap.disj_sing' => X.
by apply/eqP; apply: contra X => /eqP ->.
Qed.

(** we consider well-formed lists to be terminated by the NULL pointer *)
Definition reverse_condition l hd : assert := fun s h =>
  exists v, [ var_e hd ]e_ s = Z_of_nat v /\ list_seplog l v 0 s h.

Local Open Scope uniq_scope.

Definition reverse_list_specif : Prop := forall l (i j k : nat), uniq(i, j, k) ->
    {{ reverse_condition l i }} reverse_list i j k {{ reverse_condition (rev l) j }}.

(** reverse_list verification *)

Lemma reverse_list_verif : reverse_list_specif.
Proof.
rewrite /reverse_list_specif /reverse_list /reverse_condition => l i ret rem H.
(** ret <- nat_e 0; *)
apply hoare_assign with (fun s h => exists v,
  [ i ]_ s = Z_of_nat v /\ list_seplog l v 0 s h /\ [ ret ]_ s = Z_of_nat 0).
move=> s h [x [/= Hi Hl]]; rewrite /wp_assign; exists x => /=.
repeat Store_upd.
repeat (split => //).
by move: Hl; apply list_seplog_ext.
(** while (var_e i <>e nat_e 0) *)
apply hoare_prop_m.hoare_while_invariant with (fun s h => exists l1 l2,
  l = l1 ++ l2 /\ exists v_i v_ret,
    [ var_e i ]e_ s = Z_of_nat v_i /\  [ ret ]_ s = Z_of_nat v_ret /\
    (list_seplog l2 v_i 0 ** list_seplog (rev l1) v_ret 0) s h).
- move=> s h [x [Hi [Hl Hj]]].
  exists nil, l; split; first by [].
  exists x, O; repeat (split => //).
  Compose_sepcon h heap.emp => //.
  by constructor.
- move=> s h /= [[l1 [l2 [Hl [vi [vj [H2 [H3 [h1 [h2 [Hdisj [Hunion [Hlist_h1 Hlist_h2]]]]]]]]]]]] Hi_0].
  move/negPn/eqP in Hi_0; rewrite /= in Hi_0.
  have : vi = O by rewrite Hi_0 in H2 ; destruct vi.
  move=> ?; subst vi.
  inversion_clear Hlist_h1 => //; subst l2.
  rewrite cats0 in Hl; subst l1.
  exists vj; split; first by [].
  by rewrite Hunion H0 heap.unioneh.
(** rem <-* i -.> next; *)
apply hoare_prop_m.hoare_stren with (fun s h => exists l1 l2,
  exists elt, l = l1 ++ elt :: l2 /\ exists v_i v_ret, [ i ]_ s = Z_of_nat v_i /\
    [ ret ]_ s = Z_of_nat v_ret /\ v_i <> O /\ v_i <> v_ret /\
    (list_seplog (elt :: l2) v_i 0 ** list_seplog (rev l1) v_ret 0) s h).
move=> s h /= [[l1 [l2 [Hl [x1 [x2 [Hi [Hj Hmem]]]]]]] /negbTE/eqP Hi'].
rewrite /= in Hi'.
case_sepcon Hmem.
inversion_clear Hmem_h1.
- have [//] : x1 <> O by move=> X; subst; rewrite Hi in Hi'.
- subst l2.
  exists l1, tl, hd; split; first by [].
  exists x1, x2; repeat (split => //).
  + apply (list_seplog_hd_neq (hd :: tl) (rev l1) _ _ s h); last by lia.
    Compose_sepcon h1 h2 => //.
    by eapply list_next; eauto.
  + Compose_sepcon h1 h2 => //.
    by eapply list_next; eauto.
apply hoare_lookup_back'' with (fun s h => exists l1 l2,
  exists elt, l = l1 ++ elt :: l2 /\ exists v_i v_ret v_rem,
    [ i ]_ s = Z_of_nat v_i /\ [ ret ]_ s = Z_of_nat v_ret /\ [ rem ]_ s = Z_of_nat v_rem /\
    v_i <> O /\  v_i <> v_ret /\
    (list_seplog (elt :: nil) v_i v_rem ** list_seplog l2 v_rem 0 ** list_seplog (rev l1) v_ret 0) s h).
move=> s h /= [l1 [l2 [elt [Hl [vi [vj [Hi [Hj [Hvi_not_0 [Hvi_not_vj Hmem]]]]]]]]]].
case_sepcon Hmem.
inversion_clear Hmem_h1 => //.
case: H4 => X Y; subst hd tl.
rewrite /= in H5; case_sepcon H5.
move/assert_m.con_emp : H5_h32 => H5_h32.
exists (nat_e j).
Compose_sepcon h32 (h31 \U h4 \U h2).
  rewrite /next; by Mapsto.
apply mapsto_strictly_exact' with h32; last 2 first.
  by map_tac_m.Disj.
  rewrite /next; by Mapsto.
rewrite /wp_assign.
exists l1, l2, elt; split; first by [].
repeat Store_upd.
exists vi, vj, j; repeat (split => //).
Compose_sepcon (h31 \U h32) (h4 \U h2).
-  apply list_seplog_ext with s.
   apply (list_next _ _ _ _ _ elt nil j (h31 \U h32) heap.emp) => //.
   by map_tac_m.Disj.
   by map_tac_m.Equal.
   Compose_sepcon h31 h32.
   by Mapsto.
   rewrite /=; apply assert_m.con_emp'; by Mapsto.
   by apply list_end.
- Compose_sepcon h4 h2.
  + move: H6; by apply list_seplog_ext.
  + move: Hmem_h2; by apply list_seplog_ext.
(** i -.> next *<- var_e ret ; *)
apply hoare_mutation_backwards'' with (fun s h => exists l1 l2,
  exists elt, l = l1 ++ (elt :: l2) /\ exists v_i v_rem, [ i ]_ s = Z_of_nat v_i /\
    [ rem ]_ s = Z_of_nat v_rem /\ v_i <> O /\
      (list_seplog (rev (l1 ++ elt :: nil)) v_i 0 ** list_seplog l2 v_rem 0) s h).

move=> s h /= [l1 [l2 [elt [Hl [vi [vj [vk [Hvi [Hvj [Hvk [Hvi_not_0 [Hvi_not_vj Hmem]]]]]]]]]]]].
case_sepcon Hmem.
case_sepcon Hmem_h2.
inversion_clear Hmem_h1 => //.
case: H4 => ? ?; subst hd tl.
inversion_clear H6 => //; subst j; clear H8.
rewrite /= in H5; case_sepcon H5.
move/assert_m.con_emp : H5_h32 => H5_h32.
exists (nat_e vk).
Compose_sepcon h32 (h21 \U h31 \U h22).
  rewrite /next; by Mapsto.
rewrite /imp => h32' [X1 X2] h' Hh'.
exists l1, l2, elt; split; first by [].
exists vi, vk; repeat (split=> //).
Compose_sepcon (h22 \U h31 \U h32') h21 => //.
rewrite rev_cat /=.
apply (list_next _ _ _ _ _ elt (rev l1) vj (h31 \U h32') h22) => //.
- by map_tac_m.Disj.
- by map_tac_m.Equal.
- Compose_sepcon h31 h32'.
  by Mapsto.
  rewrite /=; apply assert_m.con_emp'; rewrite /next in X2; by Mapsto.
(** ret <- var_e i; *)
apply hoare_assign with (fun s h => exists l1 l2 elt,
  l = l1 ++ elt :: l2 /\ exists v_j v_rem,
    [ ret ]_ s = Z_of_nat v_j /\ [ rem ]_ s = Z_of_nat v_rem /\
      (list_seplog (rev (l1 ++ elt :: nil)) v_j 0 ** list_seplog l2 v_rem 0) s h).
move=> s h /= [l1 [l2 [elt [H0 [vi [vj [H1 [H4 [H3 [h1 [h2 [Hdisj [Hunion [H5 H6]]]]]]]]]]]]]].
rewrite /wp_assign /=.
exists l1, l2, elt; split; first by [].
exists vi, vj; repeat Store_upd => //; repeat (split => //).
by Compose_sepcon h1 h2; eapply list_seplog_ext; eauto.
(** i <- var_e rem *)
apply hoare_assign'.
move=> s h /= [l1 [l2 [elt [H0 [vj [vk [H1 [H4 [h1 [h2 [Hdisj [Hunion [ H5 H6]]]]]]]]]]]]].
rewrite /wp_assign /=; exists (l1 ++ elt :: nil), l2; split => //.
by rewrite -catA.
exists vk, vj; repeat Store_upd; repeat (split => //).
by Compose_sepcon h2 h1; eapply list_seplog_ext; eauto.
Qed.


Require Import Coq.Program.Program.
Require Import Coq.Program.Tactics.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Reals.Reals.
Require Import Coquelicot.Rbar.
Require Import Coquelicot.Lim_seq.
Require Import Coq.fourier.Fourier.
Require Import Autosubst.Autosubst.
Require Import Coq.Logic.Classical.
Require Import Coq.Logic.ClassicalDescription.
Require Import Coq.Logic.ClassicalEpsilon.
Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Init.Wf.

Require Import Biorthogonality.Basics.
Require Import Biorthogonality.Measures.
Require Import Biorthogonality.LogRel.
Require Import Biorthogonality.Syntax.
Require Import Biorthogonality.OpSem.
Require Import Biorthogonality.MeasSem.

Set Bullet Behavior "Strict Subproofs".

Open Scope nat.

(* Vrel compatibility *)

(** Lemma 5: variables are value-compatible *)
Lemma Vrel_Var_compatible :
  forall Γ x,
    x < Γ ->
    Vrel_open Γ (Var x) (Var x).
Proof.
  unfold Vrel_open, Grel.
  cbn.
  intuition.
Qed.

Hint Resolve Vrel_Var_compatible.

Lemma Vrel_Const_compatible_closed :
  forall m r,
    Vrel m (Const r) (Const r).
Proof.
  intros.
  rewrite Vrel_Fix_eq.
  unfold Vrel_rec.
  intuition constructor.
Qed.

Hint Resolve Vrel_Const_compatible_closed.

Lemma Vrel_Const_compatible :
  forall Γ r,
    Vrel_open Γ (Const r) (Const r).
Proof.
  unfold Vrel_open, Grel.
  intros.
  cbn.
  apply Vrel_Const_compatible_closed.
Qed.

Hint Resolve Vrel_Const_compatible.

(** Lemma 6: λ-expressions are value-compatible *)
Lemma Vrel_Fun_compatible :
  forall Γ e1 e2,
    Erel_open (S Γ) e1 e2 ->
    Vrel_open Γ (Fun e1) (Fun e2).
Proof.
  intros.
  unfold Vrel_open; intros.
  inversion H0 as [? [? ?]].
  cbn.
  rewrite Vrel_Fix_eq.
  unfold Vrel_rec at 1.
  intuition idtac.
  - constructor.
    apply -> sub_preserves_scope_exp; eauto.
  - constructor.
    apply -> sub_preserves_scope_exp; eauto.
  - asimpl.
    eapply H.
    eauto.
Qed.

Hint Resolve Vrel_Fun_compatible.

(* Pitts Lemma 4.2 part 1 *)
Lemma Krel_cons :
  forall n (e1 e2 : Expr),
    (forall m v1 v2, m <= n -> Vrel m v1 v2 -> Erel m (e1.[v1/]) (e2.[v2/])) ->
    forall m K1 K2, m <= n -> Krel m K1 K2 -> Krel m (e1-:K1) (e2-:K2).
Proof.
  intros.
  destruct (Erel_closed (H m (Const 0) (Const 0) ltac:(auto) ltac:(auto)))
           as [Hclosed_e1 Hclosed_e2].
  apply sub_implies_scope_exp_1 in Hclosed_e1.
  apply sub_implies_scope_exp_1 in Hclosed_e2.
  unfold Krel, Krel'; intros.
  destruct (Krel_closed H1) as [Hclosed_K1 Hclosed_K2].
  split; [|split]; try solve [constructor; auto].
  intros.
  destruct (Vrel_closed H2) as [IsClosed_v1 IsClosed_v2].
  run_μeval_for 1.
  run_μeval_star_for 1.
  apply H with (m:=m0); eauto.
Qed.

Hint Resolve Krel_cons.

(* Pitts Lemma 4.2 part 1 *)
Lemma Expr_cons :
  forall n (e1 e2 : Expr),
    (forall m (Hmn : m <= n) v1 v2,
        Vrel m v1 v2 -> Erel m e1.[v1/] e2.[v2/]) ->
    forall m (Hmn : m <= n) e1' e2',
      Erel m e1' e2' ->
      Erel m (Seq e1' e1) (Seq e2' e2).
Proof.
  intros.
  destruct (Erel_closed H0) as [IsClosed_e1 IsClosed_e2].
  unfold Erel, Erel'.
  split; [|split];
    try solve [specialize (H 0 ltac:(auto) _ _ (Vrel_Const_compatible_closed 0 0));
               constructor; eauto using sub_implies_scope_exp_1].
  intros.
  run_μeval_for 1.
  run_μeval_star_for 1.
  eapply H0; eauto 6.
Qed.

Hint Resolve Expr_cons.

(** Lemma 7: e ::= v *)
Lemma Erel_Val_compatible_closed :
  forall {n v v'},
    Vrel n v v' ->
    Erel n v v'.
Proof.
  intros.
  unfold Erel, Erel'.
  pose proof (Vrel_possibilities H).
  intuition eauto;
    match goal with
    | [H : Krel' _ _ _ _ |- _] => apply H; eauto
    end.
Qed.

Hint Resolve Erel_Val_compatible_closed.

Lemma Erel_Val_compatible :
  forall {Γ v v'},
    Vrel_open Γ v v' ->
    Erel_open Γ v v'.
Proof.
  intros.
  unfold Erel_open, Vrel_open in *.
  auto.
Qed.

Hint Resolve Erel_Val_compatible.

Lemma Erel_Var_compatible :
  forall Γ x,
    x < Γ ->
    Erel_open Γ (Var x) (Var x).
Proof.
  auto.
Qed.

Hint Resolve Erel_Var_compatible.

Lemma Erel_Const_compatibile :
  forall Γ r,
    Erel_open Γ (Const r) (Const r).
Proof.
  auto.
Qed.

Hint Resolve Erel_Var_compatible.

(* Lemma 5: compatible under Fun *)
Lemma Erel_Fun_compatible :
  forall Γ e e',
    Erel_open (S Γ) e e' ->
    Erel_open Γ (Fun e) (Fun e').
Proof.
  auto.
Qed.

Hint Resolve Erel_Fun_compatible.

Lemma Erel_Seq_compatible :
  forall Γ (e1 e2 e1' e2': Expr),
    Erel_open (S Γ) e1 e2 ->
    Erel_open Γ e1' e2' ->
    Erel_open Γ (Seq e1' e1) (Seq e2' e2).
Proof.
  intros.
  unfold Erel_open.
  intros.
  cbn.
  eapply Expr_cons; auto.
  intros.
  asimpl.
  eauto.
Qed.

Hint Resolve Erel_Seq_compatible.

Lemma Vrel_open_Erel_open :
  forall Γ v v',
    Vrel_open Γ v v' -> Erel_open Γ v v'.
Proof.
  eauto.
Qed.

Hint Resolve Vrel_open_Erel_open.

Lemma Erel_App_compatible_closed : forall n v1 v1' v2 v2',
    Vrel n v1 v2 ->
    Vrel n v1' v2' ->
    Erel n (App v1 v1') (App v2 v2').
Proof.
  intros.
  destruct (Vrel_closed H).
  destruct (Vrel_closed H0).
  unfold Erel, Erel'.
  split; [|split];
    destruct (Vrel_possibilities H) as [[r [? ?]]|[b1 [b2 [? ?]]]];
    subst;
    try solve [constructor; auto];
    intros;
    try solve [constructor; auto;
               rewrite Vrel_Fix_eq in H0;
               unfold Vrel_rec at 1 in H0;
               destruct v1', v2';
               intuition].
  - run_μeval.
  - run_μeval_for 1.
    run_μeval_star_for 1.
    erewrite Vrel_Fix_eq in H.
    unfold Vrel_rec in H at 1.
    eapply H; eauto.
Qed.

Hint Resolve Erel_App_compatible_closed.

(* Lemma 8 *)
Lemma Erel_App_compatible : forall Γ v1 v1' v2 v2',
    Vrel_open Γ v1 v2 ->
    Vrel_open Γ v1' v2' ->
    Erel_open Γ (App v1 v1') (App v2 v2').
Proof.
  intros.
  unfold Vrel_open in H.
  unfold Vrel_open in H0.
  unfold Erel_open.
  asimpl.
  eauto.
Qed.

Hint Resolve Erel_App_compatible.

Lemma Erel_Op1_compatible_closed : forall n o v1 v2,
    Vrel n v1 v2 ->
    Erel n (Op1 o v1) (Op1 o v2).
Proof.
  intros.
  destruct (Vrel_closed H).
  unfold Erel, Erel'.
  split; [|split];
    destruct (Vrel_possibilities H) as [[r [? ?]]|[b1 [b2 [? ?]]]];
    subst;
    try solve [constructor; auto];
    intros;
    try solve [constructor; auto;
               rewrite Vrel_Fix_eq in H0;
               unfold Vrel_rec at 1 in H0;
               destruct v1', v2';
               intuition].
  - destruct m; auto.
    { rewrite μeval_0.
      apply μeval_star_nonnegative.
    }
    destruct o.
    + destruct (Req_EM_T 0 r); subst.
      * rewrite μeval_step_Op1_Log_0.
        apply μeval_star_nonnegative.
      * rewrite μeval_step_Op1_Log; auto.
        erewrite μeval_star_step_1; revgoals.
        intros.
        apply μeval_step_Op1_Log; auto.
        apply H2; auto.
    + rewrite μeval_step_Op1_Exp.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Op1_Exp.
      apply H2; auto.
    + rewrite μeval_step_Op1_Realp_1.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Op1_Realp_1.
      apply H2; auto.
  - destruct m; auto.
    { rewrite μeval_0.
      apply μeval_star_nonnegative.
    }
    destruct o;
      try solve [unfold μeval;
                 unfold eval;
                 cbn;
                 repeat rewrite integrate_0;
                 apply μeval_star_nonnegative].
    rewrite μeval_step_Op1_Realp_0.
    erewrite μeval_star_step_1; revgoals.
    intros.
    apply μeval_step_Op1_Realp_0.
    apply H2; auto.
Qed.

Hint Resolve Erel_Op1_compatible_closed.

Lemma Erel_Op1_compatible : forall Γ o v1 v2,
    Vrel_open Γ v1 v2 ->
    Erel_open Γ (Op1 o v1) (Op1 o v2).
Proof.
  intros.
  unfold Vrel_open in H.
  unfold Erel_open.
  asimpl.
  eauto.
Qed.

Hint Resolve Erel_Op1_compatible.

Lemma Erel_Op2_compatible_closed : forall n o v1 v1' v2 v2',
    Vrel n v1 v2 ->
    Vrel n v1' v2' ->
    Erel n (Op2 o v1 v1') (Op2 o v2 v2').
Proof.
  intros.
  destruct (Vrel_closed H).
  destruct (Vrel_closed H0).
  unfold Erel, Erel'.
  split; [|split];
    destruct (Vrel_possibilities H) as [[r [? ?]]|[b1 [b2 [? ?]]]];
    destruct (Vrel_possibilities H0) as [[r' [? ?]]|[b1' [b2' [? ?]]]];
    subst;
    try solve [constructor; auto];
    intros;
    try solve [constructor; auto;
               rewrite Vrel_Fix_eq in H0;
               unfold Vrel_rec at 1 in H0;
               destruct v1', v2';
               intuition
              |replace (μeval m _ _) with (Finite 0%R);
               [apply μeval_star_nonnegative|];
               destruct m;
               [rewrite μeval_0; auto|];
               destruct o;
                 unfold μeval;
                 unfold eval;
                 cbn;
                 repeat rewrite integrate_0;
                 auto].
  destruct m; auto.
  { rewrite μeval_0.
    apply μeval_star_nonnegative.
  }
  destruct o.
  + rewrite μeval_step_Op2_Plus.
    erewrite μeval_star_step_1; revgoals.
    intros.
    apply μeval_step_Op2_Plus.
    apply H5; auto.
  + rewrite μeval_step_Op2_Minus.
    erewrite μeval_star_step_1; revgoals.
    intros.
    apply μeval_step_Op2_Minus.
    apply H5; auto.
  + rewrite μeval_step_Op2_Times.
    erewrite μeval_star_step_1; revgoals.
    intros.
    apply μeval_step_Op2_Times.
    apply H5; auto.
  + destruct (Req_EM_T 0 r'); subst.
    * rewrite μeval_step_Op2_Div_0.
      apply μeval_star_nonnegative.
    * rewrite μeval_step_Op2_Div; auto.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Op2_Div; auto.
      apply H5; auto.
  + destruct (Rlt_dec r r').
    * rewrite μeval_step_Op2_Lt_1; auto.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Op2_Lt_1; auto.
      apply H5; auto.
    * rewrite μeval_step_Op2_Lt_0; auto using Rnot_lt_le.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Op2_Lt_0;  auto using Rnot_lt_le.
      apply H5; auto.
  + destruct (Rle_dec r r').
    * rewrite μeval_step_Op2_Le_1; auto.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Op2_Le_1; auto.
      apply H5; auto.
    * rewrite μeval_step_Op2_Le_0; auto using Rnot_le_lt.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Op2_Le_0;  auto using Rnot_le_lt.
      apply H5; auto.
  + replace (μeval m _ K1 A) with (Finite 0);
      auto.
    destruct m; auto.
    * rewrite μeval_0; auto.
    * unfold μeval.
      unfold eval.
      destruct o;
        cbn;
        repeat rewrite integrate_0;
        auto.
  + replace (μeval m _ K1 A) with (Finite 0);
      auto.
    destruct m; auto.
    * rewrite μeval_0; auto.
    * unfold μeval.
      unfold eval.
      destruct o;
        cbn;
        repeat rewrite integrate_0;
        auto.
  + replace (μeval m _ K1 A) with (Finite 0);
      auto.
    destruct m; auto.
    * rewrite μeval_0; auto.
    * unfold μeval.
      unfold eval.
      destruct o;
        cbn;
        repeat rewrite integrate_0;
        auto.
Qed.

Hint Resolve Erel_Op2_compatible_closed.

Lemma Erel_Op2_compatible : forall Γ o v1 v1' v2 v2',
    Vrel_open Γ v1 v2 ->
    Vrel_open Γ v1' v2' ->
    Erel_open Γ (Op2 o v1 v1') (Op2 o v2 v2').
Proof.
  intros.
  unfold Vrel_open in H.
  unfold Erel_open.
  asimpl.
  eauto.
Qed.

Hint Resolve Erel_Op2_compatible.

Lemma Erel_Cond_compatible_closed : forall n vp vp' et et' ef ef',
    Vrel n vp vp' ->
    Erel n et et' ->
    Erel n ef ef' ->
    Erel n (Cond vp et ef) (Cond vp' et' ef').
Proof.
  intros.
  destruct (Vrel_closed H).
  destruct (Erel_closed H0).
  destruct (Erel_closed H1).
  unfold Erel, Erel'.
  split; [|split];
    destruct (Vrel_possibilities H) as [[r [? ?]]|[b1 [b2 [? ?]]]];
    subst;
    try solve [constructor; auto];
    intros;
    try solve [constructor; auto;
               rewrite Vrel_Fix_eq in H0;
               unfold Vrel_rec at 1 in H0;
               destruct v1', v2';
               intuition
              |replace (μeval m _ _) with (Finite 0%R);
               [apply μeval_star_nonnegative|];
               destruct m;
               [rewrite μeval_0; auto|];
               unfold μeval;
               unfold eval;
               cbn;
               repeat rewrite integrate_0;
               auto].
  destruct m; auto.
  { rewrite μeval_0.
    apply μeval_star_nonnegative.
  }
  + destruct (Rlt_dec 0 r).
    * rewrite μeval_step_Cond_true; auto.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Cond_true; auto.
      apply H0; eauto.
    * rewrite μeval_step_Cond_false; auto using Rnot_lt_le.
      erewrite μeval_star_step_1; revgoals.
      intros.
      apply μeval_step_Cond_false; auto using Rnot_lt_le.
      apply H1; eauto.
  + replace (μeval m _ K1 A) with (Finite 0);
      auto.
    destruct m; auto.
    * rewrite μeval_0; auto.
    * unfold μeval.
      unfold eval.
      cbn.
      repeat rewrite integrate_0.
      auto.
Qed.

Hint Resolve Erel_Cond_compatible_closed.

Lemma Erel_Cond_compatible : forall Γ vp vp' et et' ef ef',
    Vrel_open Γ vp vp' ->
    Erel_open Γ et et' ->
    Erel_open Γ ef ef' ->
    Erel_open Γ (Cond vp et ef) (Cond vp' et' ef').
Proof.
  intros.
  unfold Vrel_open in H.
  unfold Erel_open.
  asimpl.
  eauto.
Qed.

Hint Resolve Erel_Cond_compatible.

(* Lemma 9 *)

(* Lemma 9 *)
Lemma Krel_Knil_refl : forall n,
    Krel n Knil Knil.
Proof.
  intros.
  unfold Krel, Krel'.
  intuition auto.
  destruct (Vrel_possibilities H) as [[r [? ?]]|[b1 [b2 [? ?]]]];
    subst;
    auto;
    run_μeval_for 1.
Qed.

Hint Resolve Krel_Knil_refl.

Instance Sup_seq_Proper_ext : Proper (pointwise_relation nat eq==>eq) Sup_seq.
Proof.
  unfold Proper, respectful, pointwise_relation.
  intros.
  apply Sup_seq_ext.
  auto.
Qed.

(* Lemma 13: compatible under factor *)
Lemma Erel_Factor_compatible_closed : forall n r1 r2,
    Vrel n r1 r2 ->
    Erel n (Factor r1) (Factor r2).
Proof.
  unfold Erel, Erel'.
  intuition eauto.
  destruct (Vrel_possibilities H) as [[r [? ?]]|[b1 [b2 [? ?]]]];
    subst;
    eauto;
    revgoals;
    try solve [run_μeval_for 1].
  destruct (Rbar_lt_dec 0%R r); revgoals.
  { replace (μeval m (Factor (Const r)) K1 A)
      with (Finite 0%R).
    apply μeval_star_nonnegative.
    unfold μeval.
    rewrite <- integrate_0.
    rewrite <- integrate_0.
    f_equal.
    extensionality σ2.
    f_equal.
    extensionality σ1.
    destruct m; auto.
    unfold eval.
    cbn.
    destruct Rlt_dec; try contradiction; auto.
  }
  run_μeval_for 1.
  replace (μeval_star _ _ _) with (Rbar_mult r (μeval_star (Const r) K2 A)).
  { apply Rbar_mult_le_compat_l; cbn in *; auto.
    apply H0; eauto.
  }
  rewrite μeval_lim_interchange with (e:=(Factor _)).
  rewrite Sup_seq_incr_1; auto.
  setoid_rewrite (μeval_step_Factor _ _ _ _ r0).
  rewrite Sup_seq_scal_l; cbn in *; auto.
  rewrite <- μeval_lim_interchange.
  auto.
Qed.

Hint Resolve Erel_Factor_compatible_closed.

Lemma Erel_Factor_compatible : forall Γ r1 r2,
    Vrel_open Γ r1 r2 ->
    Erel_open Γ (Factor r1) (Factor r2).
Proof.
  unfold Erel_open; intros.
  asimpl.
  eauto.
Qed.

Hint Resolve Erel_Factor_compatible.

Lemma Erel_Sample_compatible_closed : forall n,
    Erel n Sample Sample.
Proof.
  intros.
  unfold Erel.
  unfold Erel'.
  intuition auto.
  run_μeval_for 1; eauto.
  rewrite μeval_star_step_Sample.
  apply integrate_monotonic.
  intros.
  eapply H; auto.
Qed.

Hint Resolve Erel_Sample_compatible_closed.

Lemma Erel_Sample_compatible : forall Γ,
    Erel_open Γ Sample Sample.
Proof.
  unfold Erel_open.
  auto.
Qed.

Hint Resolve Erel_Sample_compatible.

(* Fundamental Theorem *)

Theorem Erel_Vrel_Fundamental_helper :
  forall (e : Expr),
    (forall Γ, EXP Γ ⊢ e -> Erel_open Γ e e) /\
    (forall Γ, VAL Γ ⊢ e -> Vrel_open Γ e e).
Proof.
  induction e;
    intuition auto;
    try solve_inversion.
  - eapply Erel_App_compatible; eauto.
  - eapply Erel_Seq_compatible; eauto.
  - eapply Erel_Op1_compatible; eauto.
  - eapply Erel_Op2_compatible; eauto.
  - eapply Erel_Cond_compatible; eauto.
Qed.

Theorem Erel_Fundamental :
  forall (e : Expr) (Γ : Env),
    EXP Γ ⊢ e ->
    Erel_open Γ e e.
Proof.
  intros.
  apply Erel_Vrel_Fundamental_helper.
  auto.
Qed.

Hint Resolve Erel_Fundamental.

Theorem Vrel_Fundamental :
  forall (v : Expr) (Γ : Env),
    VAL Γ ⊢ v ->
    Vrel_open Γ v v.
Proof.
  intros.
  apply Erel_Vrel_Fundamental_helper.
  auto.
Qed.

Hint Resolve Vrel_Fundamental.

Theorem Krel_Fundamental_closed :
  forall (K : Kont) (n : nat),
    KCLOSED K ->
    Krel n K K.
Proof.
  induction K; intros.
  - cbn.
    auto.
  - inversion H; subst.
    apply Krel_cons with (n:=n); auto; intros; asimpl.
    destruct (Vrel_closed H1) as [Hclosed_v1 Hclosed_v2].
    eapply Erel_Fundamental; eauto.
    unfold Grel.
    intuition idtac.
    + apply cons_scope; auto.
    + apply cons_scope; auto.
    + inversion H4; subst; auto.
      exfalso; auto.
Qed.

Hint Resolve Krel_Fundamental_closed.

Lemma Grel_ids : forall n, Grel n 0 ids ids.
Proof.
  intros.
  unfold Grel.
  intuition auto using scope_ids.
  exfalso; auto.
Qed.

Theorem Vrel_Fundamental_closed :
  forall (v : Expr),
    VCLOSED v ->
    forall n, Vrel n v v.
Proof.
  intros.
  replace v with (v.[ids]) by autosubst.
  eapply Vrel_Fundamental; eauto using Grel_ids.
Qed.

Hint Resolve Vrel_Fundamental_closed.

Theorem Erel_Fundamental_closed :
  forall (e : Expr),
    ECLOSED e ->
    forall n, Erel n e e.
Proof.
  intros.
  replace e with (e.[ids]) by autosubst.
  eapply Erel_Fundamental; eauto using Grel_ids.
Qed.

Hint Resolve Erel_Fundamental_closed.

Theorem Grel_Fundamental :
  forall (γ : var -> Expr) (Γ : Env),
    SUBSCOPE Γ ⊢ γ ∷ 0 ->
    forall n, Grel n Γ γ γ.
Proof.
  intros.
  unfold Grel.
  intuition.
Qed.

Hint Resolve Grel_Fundamental.


Require Export CatSem.STS.STS_initial.
Require Export CatSem.TLC.TLC_types.
Require Export CatSem.PCF.PCF_types.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section example_signatures.

(** two examples of signatures :
    - simply typed lambda calculus
    - a fragment of PCF (just to make it shorter)
*)
Notation "'T'" := TLCtypes.
Notation "s ~> t" := (TLCarrow s t)(at level 40).
Notation "[ S ]" := (list S) (at level 5).

Inductive TLC_index : T -> Type :=
   | TLC_abs : forall s t : T, TLC_index (s ~> t)
   | TLC_app : forall s t : T, TLC_index t.

Definition TLC_arguments : forall t, TLC_index t -> [[T] * T] :=
    fun t r => match r with
      | TLC_abs u v => (u::nil,v)::nil
      | TLC_app u v => (nil,u ~> v)::(nil,u)::nil
      end.

Definition TLC_sig t := Build_Signature_t t
      (@TLC_arguments t).

(*
Definition TLC_sig t := Build_Signature_t t
  (fun r : TLC_index t => match r with
      | TLC_abs s t => (s::nil,t)::nil
      | TLC_app s t => (nil,s ~> t)::(nil,s)::nil
      end).
*)

Notation "'Bool'" := PCF.Bool.
Notation "'Nat'" := PCF.Nat.
Notation "'T'" := PCF.Sorts.
Notation "a ~> b" := (PCF.Arrow a b)(at level 40).

Inductive PCF_index_t : T -> Type :=
  | PCF_abs : forall s t : T, PCF_index_t (s ~> t)
  | PCF_app : forall s t : T, PCF_index_t t
  | PCF_rec : forall t : T, PCF_index_t t
  | PCF_true : PCF_index_t Bool
  | PCF_false : PCF_index_t Bool
  | PCF_nat : forall n : nat, PCF_index_t Nat
  | PCF_succ : PCF_index_t (Nat ~> Nat)
  | PCF_zero : PCF_index_t (Nat ~> Bool)
  | PCF_condN : PCF_index_t (Bool ~> Nat ~> Nat ~> Nat)
  | PCF_condB : PCF_index_t (Bool ~> Bool ~> Bool ~> Bool)
  | PCF_bottom : forall t : T, PCF_index_t t.

Definition PCF_sig t := Build_Signature_t t
      (fun r : PCF_index_t t => match r in PCF_index_t t with
            | PCF_abs s t => (s::nil,t)::nil
            | PCF_app s t => (nil, s ~> t)::(nil,s)::nil
            | PCF_rec t => (nil, t ~> t)::nil
            | _ => nil
            end).

End example_signatures.

(** we are interested in TLC *)

(** short name for its types *)
Definition T := TLCtypes.

Notation "a ~> b" := (TLCarrow a b) (at level 60).

(** the category of reps of TLC_sig *)
Definition TLCreps : Cat := REPRESENTATION TLC_sig.

(** initiality of TLCreps *)
Definition TLCInitial : Representation TLC_sig :=
     Init (Initial := STS_initial TLC_sig).

(** we isolate the monad *)
Definition TLC : Monad (ITYPE T) := rep_monad TLCInitial.

(** we want to have a short name for its simultaneous substitution *)
Definition bind V W (f : V ---> TLC W) t x
             := kleisli f t x.

(** and the substitution of a single variable, for beta *)
Definition TLCsubstar r s V (M : TLC (opt r V) s)
         (N : TLC V r) : TLC V s :=
      substar (S:=TLC_sig) N M.

(** and a nice notation *)
Notation "x >>= f" := (bind f x) (at level 60).
Notation "M [*:= N ]" := (TLCsubstar M N) (at level 40).

Definition app r s V (M : TLC V (r ~> s)) (N : TLC V r) : TLC V s :=
   Build (S:=TLC_sig) (i:=TLC_app r s)
         (constr (b:=(nil,r~>s))(S:=TLC_sig) M
                     (constr (b:=(nil,r)) N (TT (T:=T) TLC_sig V))).

Definition abs r s V (M : TLC (opt r V) s) : TLC V (r ~> s) :=
  Build (S:=TLC_sig) (t:=r ~> s) (i:=TLC_abs r s)
    (constr (b:=(r :: nil, s)) M (TT (T:=T) TLC_sig V)).

Notation "M @ N" := (app M N) (at level 30).
Notation "'\*' M" := (abs M) (at level 32).

Reserved Notation "x >> y" (at level 50).

Inductive beta : forall V t, relation (TLC V t) :=
| app_abs : forall V r s (M : TLC (opt r V) s) N,
       (\* M) @ N >> M [*:= N]
| beta_app1 : forall V r s (M M' : TLC V (r ~> s)) N,
         M >> M' -> M @ N >> M' @ N
| beta_app2 : forall V r s (M : TLC V (r ~> s)) N N',
         N >> N' -> M @ N >> M @ N'
| beta_abs : forall V r s (M M': TLC (opt r V) s),
         M >> M' -> \* M >> \* M'

where "x >> y" := (beta x y).

(** we could now start to define reduction relations etc. *)


(************************************************************************)
(* This file is copied from the std library of Coq, with only one modification *)
(* in order to benefit from universe polymorphism: *)
(* the command [Set Universe Polymorphism.] below *)
(************************************************************************)

(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Definitions of Vectors and functions to use them

   Author: Pierre Boutillier
   Institution: PPS, INRIA 12/2010
*)

(**
Names should be "caml name in list.ml" if exists and order of arguments
have to be the same. complain if you see mistakes ... *)

Require Import Arith_base HoTT.
Require Vectors.Fin.
Import EqNotations.
Local Open Scope nat_scope.

Set Universe Polymorphism.
Unset Universe Minimization ToSet.

(**
A vector is a list of size n whose elements belong to a set A. *)

Inductive t A : nat -> Type :=
  |nil : t A O
  |cons : forall (h:A) (n:nat), t A n -> t A (S n).

Local Notation "[ ]" := (nil _) (format "[ ]").
Local Notation "h :: t" := (cons _ h _ t) (at level 60, right associativity).

Section SCHEMES.

(** An induction scheme for non-empty vectors *)

Definition rectS {A} (P:forall {n}, t A (S n) -> Type)
 (bas: forall a: A, P (a :: []))
 (rect: forall a {n} (v: t A (S n)), P v -> P (a :: v)) :=
 fix rectS_fix {n} (v: t A (S n)) : P v :=
 match v with
 |@cons _ a O v =>
   match v with
     |nil _ => bas a
     |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
   end
 |@cons _ a (S nn') v => rect a v (rectS_fix v)
 |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
 end.

(** A vector of length [0] is [nil] *)
Definition case0 {A} (P:t A O -> Type) (H:P (nil A)) v:P v :=
match v with
  |[] => H
  |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
end.

(** A vector of length [ S _] is [cons] *)
Definition caseS {A} (P : forall {n}, t A (S n) -> Type)
  (H : forall h {n} t, @P n (h :: t)) {n} (v: t A (S n)) : P v :=
match v with
  |h :: t => H h t
  |_ => fun devil => False_ind (@IDProp) devil (* subterm !!! *)
end.

Definition caseS' {A} {n : nat} (v : t A (S n)) : forall (P : t A (S n) -> Type)
  (H : forall h t, P (h :: t)), P v :=
  match v with
  | h :: t => fun P H => H h t
  | _ => fun devil => False_rect (@IDProp) devil
  end.

(** An induction scheme for 2 vectors of same length *)
Definition rect2 {A B} (P:forall {n}, t A n -> t B n -> Type)
  (bas : P [] []) (rect : forall {n v1 v2}, P v1 v2 ->
    forall a b, P (a :: v1) (b :: v2)) :=
  fix rect2_fix {n} (v1 : t A n) : forall v2 : t B n, P v1 v2 :=
  match v1 with
  | [] => fun v2 => case0 _ bas v2
  | @cons _ h1 n' t1 => fun v2 =>
    caseS' v2 (fun v2' => P (h1::t1) v2') (fun h2 t2 => rect (rect2_fix t1 t2) h1 h2)
  end.

End SCHEMES.

Section BASES.
(** The first element of a non empty vector *)
Definition hd {A} := @caseS _ (fun n v => A) (fun h n t => h).
Global Arguments hd {A} {n} v.

(** The last element of an non empty vector *)
Definition last {A} := @rectS _ (fun _ _ => A) (fun a => a) (fun _ _ _ H => H).
Global Arguments last {A} {n} v.

(** Build a vector of n{^ th} [a] *)
Definition const {A} (a:A) := nat_rect _ [] (fun n x => cons _ a n x).

(** Remove the first element of a non empty vector *)
Definition tl {A} := @caseS _ (fun n v => t A n) (fun h n t => t).
Global Arguments tl {A} {n} v.

Definition map {A} {B} (f : A -> B) : forall {n} (v:t A n), t B n :=
  fix map_fix {n} (v : t A n) : t B n := match v with
  | [] => []
  | a :: v' => (f a) :: (map_fix v')

                                       end.

(** Concatenation of two vectors *)
Fixpoint append {A}{n}{p} (v:t A n) (w:t A p):t A (n + p) :=
  match v with
  | [] => w
  | a :: v' => a :: (append v' w)
  end.

End BASES.


Require Export Base.

Definition is_product {C: Category} (a b p: C) (p1: p ~> a) (p2: p ~> b) :=
  forall (z: C) (f: z ~> a) (g: z ~> b), exists! h: z ~> p, p1 ∘ h = f /\ p2 ∘ h = g.

Definition is_prod_obj {C: Category} (a b p: C) :=
  exists (p1: p ~> a) (p2: p ~> b), is_product a b p p1 p2.

Definition ex_product {C: Category} (a b: C) :=
  exists (p: C), is_prod_obj a b p.

Instance is_prod_obj_iso (C: Category): Proper (isomorphic C ==> isomorphic C ==> isomorphic C ==> iff) is_prod_obj.
Proof.
  enough (Proper (isomorphic C ==> isomorphic C ==> isomorphic C ==> impl) is_prod_obj).
  now split; apply H.
  intros a x [i] b y [j] p q [k] [p1 [p2 H]].
  exists (i ∘ p1 ∘ k⁻¹), (j ∘ p2 ∘ k⁻¹).
  intros z f' g'.
  assert (exists f: z ~> a, i ∘ f = f').
    exists (i⁻¹ ∘ f').
    rewrite comp_assoc, inv_r.
    apply comp_id_l.
  destruct H0 as [f].
  subst f'.
  assert (exists g: z ~> b, j ∘ g = g').
    exists (j⁻¹ ∘ g').
    rewrite comp_assoc, inv_r.
    apply comp_id_l.
  destruct H0 as [g].
  subst g'.
  specialize (H z f g).
  destruct H as [h [[H1 H2] Hh]].
  subst f g.
  exists (k ∘ h).
  repeat split.
  1, 2: rewrite !comp_assoc.
  1, 2: f_equal.
  1, 2: rewrite <- comp_assoc, inv_l.
  1, 2: apply comp_id_r.
  intros h' [H1 H2].
  rewrite <- !comp_assoc in H1.
  rewrite <- !comp_assoc in H2.
  apply iso_monic in H1.
  apply iso_monic in H2.
  apply (iso_monic k⁻¹).
  rewrite comp_assoc, inv_l, comp_id_l.
  now apply Hh.
Qed.

Instance ex_product_iso (C: Category): Proper (isomorphic C ==> isomorphic C ==> iff) ex_product.
Proof.
  intros a x H1 b y H2.
  unfold ex_product.
  f_equiv.
  intros p.
  now f_equiv.
Qed.

Lemma prod_obj_euniqueness {C: Category} (a b: C): euniqueness (is_prod_obj a b).
Proof.
  intros p q [p1 [p2 Hp]] [q1 [q2 Hq]].
  destruct (Hq p p1 p2) as [f [Hf _]].
  destruct (Hp q q1 q2) as [g [Hg _]].
  constructor.
  exists f, g.
  all: symmetry.
  + specialize (Hp p p1 p2).
    destruct Hp as [p' [Hp H]].
    transitivity p'.
    symmetry.
    all: apply H.
    all: split.
    1, 2: apply comp_id_r.
    all: rewrite comp_assoc.
    now rewrite (proj1 Hg).
    now rewrite (proj2 Hg).
  + specialize (Hq q q1 q2).
    destruct Hq as [q' [Hq H]].
    transitivity q'.
    symmetry.
    all: apply H.
    all: split.
    1, 2: apply comp_id_r.
    all: rewrite comp_assoc.
    now rewrite (proj1 Hf).
    now rewrite (proj2 Hf).
Qed.

Lemma ex_product_eunique {C: Category} (a b: C): ex_product a b <-> exists!! p, is_prod_obj a b p.
Proof.
  rewrite <- eunique_existence.
  split.
  + intros H.
    split.
    now apply is_prod_obj_iso.
    split.
    exact H.
    apply prod_obj_euniqueness.
  + intros [_ [H _]].
    exact H.
Qed.

Module ProdCategory.

Structure mixin_of (C: Category) := Mixin {
  prod: C -> C -> C;
  fork {a b c: C}: a ~> b -> a ~> c -> a ~> prod b c;
  pi1 {a b: C}: prod a b ~> a;
  pi2 {a b: C}: prod a b ~> b;
  fork_pi {a b c: C} (f: a ~> b) (g: a ~> c) (h: a ~> prod b c): h = fork f g <-> pi1 ∘ h = f /\ pi2 ∘ h = g;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack { sort: Category; _: class_of sort }.
Local Coercion sort: type >-> Category.

Variable T: type.
Definition class := match T return class_of T with Pack _ c => c end.

Definition Cat: Cat := T.

End ClassDef.

Lemma mixin_eq {C: Category} (m n: mixin_of C): m = n <-> forall x y, prod C m x y = prod C n x y /\ forall (e: prod C m x y = prod C n x y), @pi1 C m x y = @pi1 C n x y ∘ eq_iso e /\ @pi2 C m x y = @pi2 C n x y ∘ eq_iso e.
Proof.
  split.
  + intros H.
    subst n.
    intros x y.
    split.
    reflexivity.
    intros e.
    rewrite eq_iso_refl; clear e.
    split.
    all: symmetry.
    all: apply comp_id_r.
  + destruct m as [p fp p1 p2 Hp], n as [q fq q1 q2 Hq]; simpl.
    intros H.
    enough (p = q).
    subst q.
    enough (p1 = q1 /\ p2 = q2) as [].
    subst q1 q2.
    enough (fp = fq).
    subst fq.
    f_equal; apply proof_irrelevance.
    - extensionality x.
      extensionality y.
      extensionality z.
      extensionality f.
      extensionality g.
      now apply Hq, Hp.
    - split.
      all: extensionality x.
      all: extensionality y.
      all: specialize (H x y).
      all: apply proj2 in H.
      all: specialize (H eq_refl).
      all: simpl in H.
      all: now rewrite !comp_id_r in H.
    - extensionality x.
      extensionality y.
      apply H.
Qed.

Module Exports.

Coercion sort: type >-> Category.
Coercion Cat: type >-> Category.obj.
Notation ProdCategory := type.

End Exports.

End ProdCategory.

Export ProdCategory.Exports.

Section Product.
Context {C: ProdCategory}.

Definition prod: C -> C -> C := ProdCategory.prod C (ProdCategory.class C).
Definition fork: forall {a b c: C}, a ~> b -> a ~> c -> a ~> prod b c := @ProdCategory.fork C (ProdCategory.class C).
Definition pi1: forall {a b: C}, prod a b ~> a := @ProdCategory.pi1 C (ProdCategory.class C).
Definition pi2: forall {a b: C}, prod a b ~> b := @ProdCategory.pi2 C (ProdCategory.class C).

Infix "×" := prod (at level 40, left associativity).
Notation "⟨ f , g ⟩" := (fork f g).
Notation π₁ := pi1.
Notation π₂ := pi2.

Lemma fork_pi {a b c: C} (f: a ~> b) (g: a ~> c) (h: a ~> b × c): h = ⟨f, g⟩ <-> π₁ ∘ h = f /\ π₂ ∘ h = g.
Proof. apply ProdCategory.fork_pi. Qed.

Lemma pi1_fork {a b c: C} (f: a ~> b) (g: a ~> c): π₁ ∘ ⟨f, g⟩ = f.
Proof. now apply fork_pi with g. Qed.

Lemma pi2_fork {a b c: C} (f: a ~> b) (g: a ~> c): π₂ ∘ ⟨f, g⟩ = g.
Proof. now apply fork_pi with f. Qed.

Lemma fork_eta {a b c: C} (f: a ~> b × c): ⟨π₁ ∘ f, π₂ ∘ f⟩ = f.
Proof.
  symmetry.
  now apply fork_pi.
Qed.

Lemma fork_inj {a b c: C} (f f': a ~> b) (g g': a ~> c):
  ⟨f, g⟩ = ⟨f', g'⟩ <-> f = f' /\ g = g'.
Proof.
  symmetry.
  split.
  all: intros H.
  now f_equiv.
  split.
  1: rewrite <- (pi1_fork f g).
  2: rewrite <- (pi2_fork f g).
  all: rewrite H.
  apply pi1_fork.
  apply pi2_fork.
Qed.

Lemma fork_id {a b: C}: ⟨π₁, π₂⟩ = id (a × b).
Proof.
  symmetry.
  apply fork_pi.
  split.
  all: apply comp_id_r.
Qed.

Lemma fork_comp {a b c d: C} (f: b ~> c) (g: b ~> d) (h: a ~> b): ⟨f, g⟩ ∘ h = ⟨f ∘ h, g ∘ h⟩.
Proof.
  apply fork_pi.
  split.
  all: rewrite comp_assoc.
  all: f_equal.
  apply pi1_fork.
  apply pi2_fork.
Qed.

Definition fprod {a b c d: C} (f: a ~> b) (g: c ~> d): a × c ~> b × d :=
  ⟨ f ∘ π₁, g ∘ π₂⟩.

Infix "(×)" := fprod (at level 40, left associativity).

Lemma fprod_id (a b: C): id a (×) id b = id (a × b).
Proof.
  symmetry.
  apply fork_pi.
  now rewrite !comp_id_l, !comp_id_r.
Qed.

Lemma fprod_fork {a b b' c c'} (f: b ~> c) (f': b' ~> c') (g: a ~> b) (g': a ~> b'): (f (×) f') ∘ ⟨g, g'⟩ = ⟨f ∘ g, f' ∘ g'⟩.
Proof.
  unfold fprod.
  rewrite fork_comp.
  f_equal.
  all: rewrite <- !comp_assoc.
  all: f_equal.
  apply pi1_fork.
  apply pi2_fork.
Qed.

Lemma fprod_comp {a a' b b' c c': C} (f: b ~> c) (f': b' ~> c') (g: a ~> b) (g': a' ~> b'): (f ∘ g) (×) (f' ∘ g') = (f (×) f') ∘ (g (×) g').
Proof.
  symmetry.
  unfold fprod at 2 3.
  rewrite <- !comp_assoc.
  apply fprod_fork.
Qed.

Lemma fprod_inv_l {a b c d: C} (f: a <~> b) (g: c <~> d): (f⁻¹ (×) g⁻¹) ∘ (f (×) g) = id (a × c).
Proof.
  rewrite <- fprod_comp, <- fprod_id.
  f_equal.
  all: apply inv_l.
Qed.

Lemma fprod_inv_r {a b c d: C} (f: a <~> b) (g: c <~> d): (f (×) g) ∘ (f⁻¹ (×) g⁻¹) = id (b × d).
Proof.
  rewrite <- fprod_comp, <- fprod_id.
  f_equal.
  all: apply inv_r.
Qed.

Definition iprod {a b c d: C} (f: a <~> b) (g: c <~> d): a × c <~> b × d :=
  Isomorphism.Pack (f (×) g) (Isomorphism.Mixin _ _ _ (f (×) g) (f⁻¹ (×) g⁻¹) (fprod_inv_l f g) (fprod_inv_r f g)).

Lemma is_iso_fprod {a b c d: C} (f: a ~> b) (g: c ~> d): is_iso f -> is_iso g -> is_iso (f (×) g).
Proof.
  intros [f' [Hfl Hfr]] [g' [Hgl Hgr]].
  exists (f' (×) g'); split.
  all: rewrite <- fprod_comp, <- fprod_id.
  all: now f_equal.
Qed.

Lemma is_eq_fprod {a b c d: C} (f: a ~> b) (g: c ~> d): is_eq f -> is_eq g -> is_eq (f (×) g).
Proof.
  intros [e1 H1] [e2 H2].
  subst f g.
  destruct e1, e2.
  simpl.
  rewrite fprod_id.
  apply is_eq_id.
Qed.

Global Instance prod_iso: Proper (isomorphic C ==> isomorphic C ==> isomorphic C) prod.
Proof.
  intros x x' [f] y y' [g].
  constructor.
  exact (iprod f g).
Qed.

Definition flip (x y: C): x × y ~> y × x := ⟨π₂, π₁⟩.

Lemma flip_invol (x y: C): flip y x ∘ flip x y = id (x × y).
Proof.
  unfold flip.
  rewrite fork_comp, <- fork_id.
  f_equal.
  apply pi2_fork.
  apply pi1_fork.
Qed.

Canonical flip_iso (x y: C): x × y <~> y × x :=
  Isomorphism.Pack (flip x y) (Isomorphism.Mixin C _ _ (flip x y) (flip y x) (flip_invol x y) (flip_invol y x)).

Lemma prod_comm (x y: C): x × y ≃ y × x.
Proof.
  constructor.
  exact (flip_iso x y).
Qed.

Section prod_associator.
Context (x y z: C).

Definition prod_associator_to: x × (y × z) ~> (x × y) × z :=
  ⟨⟨π₁, π₁ ∘ π₂⟩, π₂ ∘ π₂⟩.

Definition prod_associator_from: (x × y) × z ~> x × (y × z) :=
  ⟨π₁ ∘ π₁, ⟨π₂ ∘ π₁, π₂⟩⟩.

Lemma prod_associator_inv_l: prod_associator_from ∘ prod_associator_to = id (x × (y × z)).
Proof.
  unfold prod_associator_to, prod_associator_from.
  rewrite fork_comp, <- fork_id.
  f_equal.
  rewrite <- comp_assoc.
  rewrite pi1_fork.
  apply pi1_fork.
  rewrite <- comp_id_l, <- fork_id.
  rewrite !fork_comp.
  f_equal.
  rewrite <- comp_assoc.
  rewrite pi1_fork.
  apply pi2_fork.
  apply pi2_fork.
Qed.

Lemma prod_associator_inv_r: prod_associator_to ∘ prod_associator_from = id (x × y × z).
Proof.
  unfold prod_associator_to, prod_associator_from.
  rewrite fork_comp, <- fork_id.
  f_equal.
  rewrite <- comp_id_l, <- fork_id.
  rewrite !fork_comp.
  f_equal.
  apply pi1_fork.
  rewrite <- comp_assoc.
  rewrite pi2_fork.
  apply pi1_fork.
  rewrite <- comp_assoc.
  rewrite pi2_fork.
  apply pi2_fork.
Qed.

Definition prod_associator: x × (y × z) <~> (x × y) × z :=
  Isomorphism.Pack prod_associator_to (Isomorphism.Mixin _ _ _ prod_associator_to prod_associator_from prod_associator_inv_l prod_associator_inv_r).

Lemma prod_assoc: x × (y × z) ≃ (x × y) × z.
Proof.
  constructor.
  exact prod_associator.
Qed.

End prod_associator.

Lemma prod_assoc_fork {a x y z: C} (f: a ~> x) (g: a ~> y) (h: a ~> z): prod_associator x y z ∘ ⟨f, ⟨g, h⟩⟩ = ⟨⟨f, g⟩, h⟩.
Proof.
  simpl.
  unfold prod_associator_to.
  rewrite !fork_comp.
  repeat f_equal.
  apply pi1_fork.
  all: rewrite <- comp_assoc.
  all: rewrite pi2_fork.
  apply pi1_fork.
  apply pi2_fork.
Qed.

Lemma prod_assoc_inv_fork {a x y z: C} (f: a ~> x) (g: a ~> y) (h: a ~> z): (prod_associator x y z)⁻¹ ∘ ⟨⟨f, g⟩, h⟩ = ⟨f, ⟨g, h⟩⟩.
Proof.
  rewrite <- prod_assoc_fork.
  rewrite comp_assoc.
  rewrite inv_l.
  apply comp_id_l.
Qed.

Lemma pi_is_product (a b: C): is_product a b (a × b) π₁ π₂.
Proof.
  intros z f g.
  exists ⟨f, g⟩.
  repeat split.
  apply pi1_fork.
  apply pi2_fork.
  intros h H.
  symmetry.
  now apply fork_pi.
Qed.

Lemma prod_is_prod_obj (a b: C): is_prod_obj a b (a × b).
Proof.
  exists π₁, π₂.
  apply pi_is_product.
Qed.

Definition FProd: Bifunctor C C C := {|
  bobj a b := a × b;
  bmap a1 a2 b1 b2 f g := f (×) g;
  bmap_id := fprod_id;
  bmap_comp a b c a' b' c' f g f' g' := fprod_comp f f' g g';
|}.

End Product.

Infix "×" := prod (at level 40, left associativity).
Infix "(×)" := fprod (at level 40, left associativity).
Notation "⟨ f , g ⟩" := (fork f g).
Canonical iprod.
Notation π₁ := pi1.
Notation π₂ := pi2.

Lemma product_correct C: inhabited (ProdCategory.mixin_of C) <-> (forall a b: C, ex_product a b).
Proof.
  split.
  + intros [[p fork p1 p2 H]] a b.
    exists (p a b), (p1 a b), (p2 a b).
    intros z f g.
    exists (fork z a b f g); split.
    now apply H.
    intros h Hh.
    symmetry.
    now apply H.
  + intros H.
    generalize (fun a => proj1 (ex_forall _) (H a)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [P H].
    generalize (fun a => proj1 (ex_forall _) (H a)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [p1 H].
    generalize (fun a => proj1 (ex_forall _) (H a)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [p2 H].
    generalize (fun a b z f => proj1 (ex_forall _) (H a b z f)).
    clear H; intros H.
    generalize (fun a b z => proj1 (ex_forall _) (H a b z)).
    clear H; intros H.
    generalize (fun a b => proj1 (ex_forall _) (H a b)).
    clear H; intros H.
    generalize (fun a => proj1 (ex_forall _) (H a)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [fo H].
    constructor.
    exists P (fun a b c => fo b c a) p1 p2.
    intros a b c f g h.
    specialize (H b c a f g).
    destruct H as [H u].
    split.
    intros Hh.
    now subst h.
    intros Hh.
    symmetry.
    now apply u.
Qed.