(** * Miscellaneous Well-Foundedness Facts *)
Require Import Coq.Setoids.Setoid Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Classes.Morphisms Coq.Init.Wf.
Require Import Crypto.Util.Telescope.Core.
Require Import Crypto.Util.Telescope.Instances.
Require Import Crypto.Util.Telescope.Equality.
Require Import Crypto.Util.Equality.
Require Import Crypto.Util.Tactics.ETransitivity.
Require Import Crypto.Util.Tactics.SetEvars.
Require Import Crypto.Util.Tactics.SubstEvars.
Require Import Crypto.Util.Tactics.SubstLet.
Import Init.Wf.

Local Set Implicit Arguments.

Local Ltac Fix_eq_t F_ext Rwf :=
  let generalize_if_not_var x :=
      first [ is_var x; fail 1
            | generalize x ] in
  intros;
  unfold Fix;
  rewrite <- Fix_F_eq;
  apply F_ext; intros;
  repeat match goal with
           | [ |- context[Fix_F _ _ ?x] ] => generalize_if_not_var x
           | [ |- context[Fix_F _ _ ?x _] ] => generalize_if_not_var x
         end;
  clear -F_ext Rwf;
  match goal with
    | [ |- forall x : Acc _ ?a, _ ] => induction (Rwf a)
  end;
  intros; rewrite <- !Fix_F_eq;
  apply F_ext; eauto.

Local Ltac Fix_Proper_t Fix_eq wf :=
  change (@flatten_forall_eq_relation) with (@flatten_forall_eq);
  change (@flatten_forall_eq_relation_with_assumption) with (@flatten_forall_eq_with_assumption);
  let H := fresh "H" in
  let a := fresh "a" in
  unfold forall_relation, pointwise_relation, respectful;
  intros ?? H a; repeat intro;
  induction (wf a);
  rewrite !Fix_eq; [ erewrite H; [ reflexivity | .. ] | .. ]; eauto; intros;
  [ etransitivity; [ symmetry; apply H; reflexivity | apply H; eassumption ]; reflexivity
  | etransitivity; [ apply H; eassumption | symmetry; apply H; reflexivity ]; reflexivity ].

Section FixV.
  Context A (B : A -> Telescope)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, flattenT (B a) Type).

  Local Notation FixV := (@Fix A R Rwf (fun a : A => flatten_forall (P a))).

  Section F.
    Context (F : forall x : A, (forall y : A, R y x -> flatten_forall (P y)) -> flatten_forall (P x)).

    Definition FixV_eq
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                          (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                          -> flatten_forall_eq (@F x f) (@F x g))
    : forall a, flatten_forall_eq (@FixV F a) (@F a (fun y (_ : R y a) => @FixV F y)).
    Proof. Fix_eq_t F_ext Rwf. Defined.

    Definition FixV_eq_with_assumption
               Q
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                          (forall y (p : R y x), flatten_forall_eq_with_assumption (Q y) (f y p) (g y p))
                          -> flatten_forall_eq_with_assumption (Q x) (@F x f) (@F x g))
    : forall a, flatten_forall_eq_with_assumption (Q a) (@FixV F a) (@F a (fun y (_ : R y a) => @FixV F y)).
    Proof. Fix_eq_t F_ext Rwf. Defined.

    Definition FixV_rect
               (Q : forall a, flattenT (Telescope_append (B a) (P a)) Type)
               (H0 : forall x, (forall y, R y x -> flatten_append_forall (@Q y) (@FixV F y))
                              -> flatten_append_forall (@Q x) (@F x (fun (y : A) (_ : R y x) => @FixV F y)))
               (F_ext : forall x (f g : forall y, R y x -> flatten_forall (@P y)),
                          (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                          -> flatten_forall_eq (@F x f) (@F x g))
               a
    : flatten_append_forall (@Q a) (@FixV F a).
    Proof.
      induction (Rwf a).
      eapply flatten_append_forall_Proper; auto with nocore.
      symmetry; eapply FixV_eq; auto with nocore.
    Defined.
  End F.

  Global Instance FixV_Proper_eq
  : Proper
      ((forall_relation
          (fun a =>
             (forall_relation
                (fun a' =>
                   pointwise_relation
                     _
                     (flatten_forall_eq_relation)))
               ==> flatten_forall_eq_relation))
         ==> (forall_relation (fun a => flatten_forall_eq_relation)))
      FixV.
  Proof. Fix_Proper_t @FixV_eq Rwf. Qed.

  Global Instance FixV_Proper_eq_with_assumption
         Q
  : Proper
      ((forall_relation
          (fun a : A =>
             (forall_relation
                (fun a' : A =>
                   pointwise_relation
                     (R a' a)
                     (flatten_forall_eq_relation_with_assumption (Q a'))))
               ==> flatten_forall_eq_relation_with_assumption (Q a)))
         ==> (forall_relation (fun a => flatten_forall_eq_relation_with_assumption (Q a))))
      FixV.
  Proof. Fix_Proper_t @FixV_eq_with_assumption Rwf. Qed.
End FixV.

Arguments FixV_Proper_eq {A B R Rwf P} _ _ _ _.
Arguments FixV_Proper_eq_with_assumption {A B R Rwf P} _ _ _ _ _.

Local Arguments flatten_forall / _ _.
Local Arguments flattenT / _ _.
Local Arguments flatten_forall_eq / _ _ _ _.
Local Arguments flatten_forall_eq_relation / _ _ _ _.
Local Arguments flatten_forall_eq_with_assumption / _ _ _ _ _.
Local Arguments flatten_forall_eq_relation_with_assumption / _ _ _ _ _.
Local Arguments flatten_append_forall / _ _ _ _.

Local Notation type_of x := ((fun T (y : T) => T) _ x).

Section FixVTransfer.
  Context A (B B' : A -> Telescope)
          (f0 : forall a, flattenT_sig (B a) -> flattenT_sig (B' a))
          (g0 : forall a, flattenT_sig (B' a) -> flattenT_sig (B a))
          (sect : forall a x, g0 a (f0 a x) = x)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, flattenT (B a) Type).

  Let P' : forall a, flattenT (B' a) Type
    := fun a => flattenT_unapply (fun x => flattenT_apply (P a) (g0 _ x)).

  Local Notation FixV := (@Fix A R Rwf (fun a : A => flatten_forall (P a))).
  Local Notation FixV' := (@Fix A R Rwf (fun a : A => flatten_forall (P' a))).

  Section F.
    Context (F : forall x : A, (forall y : A, R y x -> flatten_forall (P y)) -> flatten_forall (P x)).

    Let transfer
    : forall y,
        flatten_forall
          (flattenT_unapply
             (fun x : flattenT_sig (B y) => flattenT_apply (P' y) (f0 y x)))
        -> flatten_forall (P y).
    Proof.
      intro y.
      refine (flatten_forall_eq_rect
                (transitivity
                   ((_ : Proper (pointwise_relation _ _ ==> _) flattenT_unapply)
                      _ _
                      (fun x' => transitivity
                                   (symmetry (flattenT_apply_unapply _ _))
                                   (f_equal (flattenT_apply _) (sect _ _))))
                   (symmetry (flattenT_unapply_apply _)))).
    Defined.

    Let transfer'
    : forall a,
        flatten_forall (P a)
        -> flatten_forall (P' a).
    Proof.
      intro a.
      refine (fun f' => flatten_forall_unapply (fun x' => flatten_forall_apply f' (g0 _ x'))).
    Defined.

    Let untransfer'
    : forall a,
        flatten_forall (P' a)
        -> flatten_forall (P a).
    Proof.
      intro a.
      refine (fun f' => _).
      refine (transfer
                _
                (flatten_forall_unapply (fun x => flatten_forall_apply f' (f0 _ x)))).
    Defined.

    Let F' : forall x : A, (forall y : A, R y x -> flatten_forall (P' y)) -> flatten_forall (P' x)
      := fun a F' => transfer' _ (@F a (fun y pf => transfer _ (flatten_forall_unapply (fun x => flatten_forall_apply (F' y pf) (f0 _ x))))).

    Context (F_ext : forall x (f g : forall y, R y x -> flatten_forall (P y)),
                       (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
                       -> flatten_forall_eq (@F x f) (@F x g)).

    Lemma F'_ext
    : forall x (f g : forall y, R y x -> flatten_forall (P' y)),
        (forall y (p : R y x), flatten_forall_eq (f y p) (g y p))
        -> flatten_forall_eq (@F' x f) (@F' x g).
    Proof.
      intros x f' g' IH.
      subst F' transfer transfer'; cbv beta.
      apply (_ : Proper (forall_relation _ ==> _) flatten_forall_unapply); intro.
      apply flatten_forall_apply_Proper.
      apply F_ext; intros.
      refine ((_ : Proper (flatten_forall_eq ==> _) (@flatten_forall_eq_rect _ _ _ _)) _ _ _).
      apply (_ : Proper (forall_relation _ ==> _) flatten_forall_unapply); intro.
      apply flatten_forall_apply_Proper.
      apply IH.
    Qed.

    Definition FixV_transfer_eq
               a
    : flatten_forall_eq (@FixV F a) (untransfer' _ (@FixV' F' a)).
    Proof.
      induction (Rwf a).
      rewrite FixV_eq by eauto with nocore.
      etransitivity_rev _.
      { unfold transfer, untransfer'; cbv beta.
        apply flatten_forall_eq_rect_Proper, flatten_forall_unapply_Proper; intro.
        apply flatten_forall_apply_Proper.
        rewrite FixV_eq by auto using F'_ext with nocore.
        reflexivity. }
      etransitivity.
      { apply F_ext; intros.
        set_evars.
        match goal with
          | [ H : forall y r, flatten_forall_eq _ _ |- _ ] => rewrite H by assumption
        end.
        match goal with
          | [ |- ?R ?a (?e ?x ?y) ]
            => revert x y
        end.
        match goal with
          | [ H := ?e |- _ ] => is_evar e; subst H
        end.
        match goal with
          | [ |- forall x y, ?R (@?LHS x y) (?RHS x y) ]
            => unify LHS RHS; cbv beta
        end.
        reflexivity. }
      lazymatch goal with
        | [ |- context[FixV' ?F _] ]
          => generalize (FixV' F)
      end.
      subst F'; cbv beta.
      subst untransfer' transfer transfer'; cbv beta.
      intro.
      rewrite flatten_forall_eq_rect_trans.
      match goal with
        | [ |- context[flatten_forall_eq_rect
                            (flattenT_unapply_Proper ?P ?Q ?H)
                            (flatten_forall_unapply ?f)] ]
          => rewrite (@flatten_forall_eq_rect_flattenT_unapply_Proper _ P Q H f)
      end.
      etransitivity_rev _.
      { apply flatten_forall_eq_rect_Proper.
        apply flatten_forall_unapply_Proper; intro.
        match goal with
          | [ |- context[@transitivity _ (@eq ?A) ?P _ _ _ _ _] ]
            => change (@transitivity _ (@eq ?A) P) with (@eq_trans A)
        end.
        match goal with
          | [ |- context[@symmetry _ (@eq ?A) ?P _ _ _] ]
            => change (@symmetry _ (@eq ?A) P) with (@eq_sym A)
        end.
        set_evars.
        rewrite @transport_pp.
        match goal with
          | [ |- context G[eq_rect _ (fun T => T) (flatten_forall_apply (flatten_forall_unapply ?k) ?x0) _ (eq_sym (flattenT_apply_unapply ?f1 ?x0))] ]
            => let H := fresh in
               pose proof (@eq_rect_symmetry_flattenT_apply_unapply _ f1 x0 k) as H;
                 cbv beta in H |- *;
                 let RHS := match type of H with _ = ?RHS => constr:(RHS) end in
                 let LHS := match type of H with ?LHS = _ => constr:(LHS) end in
                 let G' := context G[LHS] in
                 change G';
                   rewrite H;
                   clear H
        end.
        match goal with
          | [ |- context[f_equal _ ?p] ]
            => destruct p; unfold f_equal; simpl @eq_rect
        end.
        subst_let.
        reflexivity. }
      rewrite flatten_forall_eq_rect_symmetry_flattenT_unapply_apply.
      apply F_ext; intros.
      reflexivity.
    Qed.
  End F.
End FixVTransfer.

Section Fix_rect.
  Context (A : Type).
  Local Notation T := (fun _ : A => bottom).

  Let Fix_rect' := @FixV_rect A T.
  Let Fix_rect'T := Eval simpl in type_of Fix_rect'.

  Let Fix_Proper_eq' := @FixV_Proper_eq A T.
  Let Fix_Proper_eq'T := Eval simpl in type_of Fix_Proper_eq'.

  Let Fix_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T.
  Let Fix_Proper_eq_with_assumption'T := Eval simpl in type_of Fix_Proper_eq_with_assumption'.

  Definition Fix_rect : Fix_rect'T := Fix_rect'.
  Definition Fix_Proper_eq : Fix_Proper_eq'T := Fix_Proper_eq'.
  Definition Fix_Proper_eq_with_assumption : Fix_Proper_eq_with_assumption'T := Fix_Proper_eq_with_assumption'.
End Fix_rect.

Arguments Fix_Proper_eq {A R Rwf P} _ _ _ _.
Arguments Fix_Proper_eq_with_assumption {A R Rwf P} _ _ _ _ _ _.
Global Existing Instance Fix_Proper_eq.
Global Existing Instance Fix_Proper_eq_with_assumption.

(** A variant of [Fix] that has a nice [Fix_eq] for functions which
    doesn't require [functional_extensionality]. *)
(* Following code generated by the following Python script:
<<
ALPHA = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
alpha = ALPHA.lower()
for fixn in range(1, 11):
    print(r"""Section Fix%(fixn)d.""" % locals())
    def make_forall(n, pat, skip_forall=0):
        mycur = ''
        if n > skip_forall + 1:
            mycur += 'forall ' + ' '.join(alpha[skip_forall:n-1]) + ', '
        mycur2 = ''
        if n > 1:
            mycur2 += ' ' + ' '.join(alpha[:n-1])
        return mycur + (pat % mycur2)

    cur = '  Context A'
    for j in range(1, fixn + 1):
        cur += ' (%s : ' % ALPHA[j]
        cur += make_forall(j, '%s%%s -> Type)' % ALPHA[j-1])
    print(cur)
    print(r"""          (R : A -> A -> Prop) (Rwf : well_founded R)""")
    cur = "          (P : "
    cur += make_forall(j+1, '%s%%s -> Type).' % ALPHA[j])
    print(cur)
    print("")
    cur = "  Local Notation Fix%d := (@Fix A R Rwf (fun a : A => %s))."
    cur = cur % (j, make_forall(j+2, '@P%s', skip_forall=1))
    print(cur)
    def make_tele(chars, final, append=''):
        if chars:
            return '(fun %s => tele _ %s)' % (chars[0], make_tele(chars[1:], final, append + ' ' + chars[0]))
        else:
            return '(fun _ : %s%s => bottom)' % (final, append)
    print('  Local Notation T := %s.' % make_tele(alpha[:fixn], '@' + ALPHA[fixn]))
    fix_underscores = ' '.join('_' for i in range(fixn + 4))
    letters = ' '.join(ALPHA[:fixn+1])
    preletters = ' '.join(ALPHA[:fixn])
    print(r"""
  Let Fix%(fixn)d_eq' := @FixV_eq A T R Rwf P.
  Let Fix%(fixn)d_eq'T := Eval simpl in type_of Fix%(fixn)d_eq'.

  Let Fix%(fixn)d_rect' := @FixV_rect A T R Rwf P.
  Let Fix%(fixn)d_rect'T := Eval simpl in type_of Fix%(fixn)d_rect'.

  Let Fix%(fixn)d_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix%(fixn)d_Proper_eq'T := Eval simpl in type_of Fix%(fixn)d_Proper_eq'.

  Let Fix%(fixn)d_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix%(fixn)d_Proper_eq_with_assumption'T := Eval simpl in type_of Fix%(fixn)d_Proper_eq_with_assumption'.

  Definition Fix%(fixn)d_eq : Fix%(fixn)d_eq'T := Fix%(fixn)d_eq'.
  Definition Fix%(fixn)d_rect : Fix%(fixn)d_rect'T := Fix%(fixn)d_rect'.
  Definition Fix%(fixn)d_Proper_eq : Fix%(fixn)d_Proper_eq'T := Fix%(fixn)d_Proper_eq'.
  Definition Fix%(fixn)d_Proper_eq_with_assumption : Fix%(fixn)d_Proper_eq_with_assumption'T := Fix%(fixn)d_Proper_eq_with_assumption'.
End Fix%(fixn)d.

Arguments Fix%(fixn)d_Proper_eq {%(letters)s R Rwf P} %(fix_underscores)s.
Arguments Fix%(fixn)d_Proper_eq_with_assumption {%(letters)s R Rwf P} _ _ %(fix_underscores)s.
Global Existing Instance Fix%(fixn)d_Proper_eq.
Global Existing Instance Fix%(fixn)d_Proper_eq_with_assumption.
""" % locals())
>> *)
Section Fix1.
  Context A (B : A -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a, B a -> Type).

  Local Notation Fix1 := (@Fix A R Rwf (fun a : A => forall b, @P a b)).
  Local Notation T := (fun a => tele _ (fun _ : @B a => bottom)).

  Let Fix1_eq' := @FixV_eq A T R Rwf P.
  Let Fix1_eq'T := Eval simpl in type_of Fix1_eq'.

  Let Fix1_rect' := @FixV_rect A T R Rwf P.
  Let Fix1_rect'T := Eval simpl in type_of Fix1_rect'.

  Let Fix1_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix1_Proper_eq'T := Eval simpl in type_of Fix1_Proper_eq'.

  Let Fix1_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix1_Proper_eq_with_assumption'T := Eval simpl in type_of Fix1_Proper_eq_with_assumption'.

  Definition Fix1_eq : Fix1_eq'T := Fix1_eq'.
  Definition Fix1_rect : Fix1_rect'T := Fix1_rect'.
  Definition Fix1_Proper_eq : Fix1_Proper_eq'T := Fix1_Proper_eq'.
  Definition Fix1_Proper_eq_with_assumption : Fix1_Proper_eq_with_assumption'T := Fix1_Proper_eq_with_assumption'.
End Fix1.

Arguments Fix1_Proper_eq {A B R Rwf P} _ _ _ _ _.
Arguments Fix1_Proper_eq_with_assumption {A B R Rwf P} _ _ _ _ _ _ _.
Global Existing Instance Fix1_Proper_eq.
Global Existing Instance Fix1_Proper_eq_with_assumption.

Section Fix2.
  Context A (B : A -> Type) (C : forall a, B a -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b, C a b -> Type).

  Local Notation Fix2 := (@Fix A R Rwf (fun a : A => forall b c, @P a b c)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun _ : @C a b => bottom))).

  Let Fix2_eq' := @FixV_eq A T R Rwf P.
  Let Fix2_eq'T := Eval simpl in type_of Fix2_eq'.

  Let Fix2_rect' := @FixV_rect A T R Rwf P.
  Let Fix2_rect'T := Eval simpl in type_of Fix2_rect'.

  Let Fix2_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix2_Proper_eq'T := Eval simpl in type_of Fix2_Proper_eq'.

  Let Fix2_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix2_Proper_eq_with_assumption'T := Eval simpl in type_of Fix2_Proper_eq_with_assumption'.

  Definition Fix2_eq : Fix2_eq'T := Fix2_eq'.
  Definition Fix2_rect : Fix2_rect'T := Fix2_rect'.
  Definition Fix2_Proper_eq : Fix2_Proper_eq'T := Fix2_Proper_eq'.
  Definition Fix2_Proper_eq_with_assumption : Fix2_Proper_eq_with_assumption'T := Fix2_Proper_eq_with_assumption'.
End Fix2.

Arguments Fix2_Proper_eq {A B C R Rwf P} _ _ _ _ _ _.
Arguments Fix2_Proper_eq_with_assumption {A B C R Rwf P} _ _ _ _ _ _ _ _.
Global Existing Instance Fix2_Proper_eq.
Global Existing Instance Fix2_Proper_eq_with_assumption.

Section Fix3.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c, D a b c -> Type).

  Local Notation Fix3 := (@Fix A R Rwf (fun a : A => forall b c d, @P a b c d)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun _ : @D a b c => bottom)))).

  Let Fix3_eq' := @FixV_eq A T R Rwf P.
  Let Fix3_eq'T := Eval simpl in type_of Fix3_eq'.

  Let Fix3_rect' := @FixV_rect A T R Rwf P.
  Let Fix3_rect'T := Eval simpl in type_of Fix3_rect'.

  Let Fix3_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix3_Proper_eq'T := Eval simpl in type_of Fix3_Proper_eq'.

  Let Fix3_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix3_Proper_eq_with_assumption'T := Eval simpl in type_of Fix3_Proper_eq_with_assumption'.

  Definition Fix3_eq : Fix3_eq'T := Fix3_eq'.
  Definition Fix3_rect : Fix3_rect'T := Fix3_rect'.
  Definition Fix3_Proper_eq : Fix3_Proper_eq'T := Fix3_Proper_eq'.
  Definition Fix3_Proper_eq_with_assumption : Fix3_Proper_eq_with_assumption'T := Fix3_Proper_eq_with_assumption'.
End Fix3.

Arguments Fix3_Proper_eq {A B C D R Rwf P} _ _ _ _ _ _ _.
Arguments Fix3_Proper_eq_with_assumption {A B C D R Rwf P} _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix3_Proper_eq.
Global Existing Instance Fix3_Proper_eq_with_assumption.

Section Fix4.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d, E a b c d -> Type).

  Local Notation Fix4 := (@Fix A R Rwf (fun a : A => forall b c d e, @P a b c d e)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun _ : @E a b c d => bottom))))).

  Let Fix4_eq' := @FixV_eq A T R Rwf P.
  Let Fix4_eq'T := Eval simpl in type_of Fix4_eq'.

  Let Fix4_rect' := @FixV_rect A T R Rwf P.
  Let Fix4_rect'T := Eval simpl in type_of Fix4_rect'.

  Let Fix4_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix4_Proper_eq'T := Eval simpl in type_of Fix4_Proper_eq'.

  Let Fix4_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix4_Proper_eq_with_assumption'T := Eval simpl in type_of Fix4_Proper_eq_with_assumption'.

  Definition Fix4_eq : Fix4_eq'T := Fix4_eq'.
  Definition Fix4_rect : Fix4_rect'T := Fix4_rect'.
  Definition Fix4_Proper_eq : Fix4_Proper_eq'T := Fix4_Proper_eq'.
  Definition Fix4_Proper_eq_with_assumption : Fix4_Proper_eq_with_assumption'T := Fix4_Proper_eq_with_assumption'.
End Fix4.

Arguments Fix4_Proper_eq {A B C D E R Rwf P} _ _ _ _ _ _ _ _.
Arguments Fix4_Proper_eq_with_assumption {A B C D E R Rwf P} _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix4_Proper_eq.
Global Existing Instance Fix4_Proper_eq_with_assumption.

Section Fix5.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e, F a b c d e -> Type).

  Local Notation Fix5 := (@Fix A R Rwf (fun a : A => forall b c d e f, @P a b c d e f)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun _ : @F a b c d e => bottom)))))).

  Let Fix5_eq' := @FixV_eq A T R Rwf P.
  Let Fix5_eq'T := Eval simpl in type_of Fix5_eq'.

  Let Fix5_rect' := @FixV_rect A T R Rwf P.
  Let Fix5_rect'T := Eval simpl in type_of Fix5_rect'.

  Let Fix5_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix5_Proper_eq'T := Eval simpl in type_of Fix5_Proper_eq'.

  Let Fix5_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix5_Proper_eq_with_assumption'T := Eval simpl in type_of Fix5_Proper_eq_with_assumption'.

  Definition Fix5_eq : Fix5_eq'T := Fix5_eq'.
  Definition Fix5_rect : Fix5_rect'T := Fix5_rect'.
  Definition Fix5_Proper_eq : Fix5_Proper_eq'T := Fix5_Proper_eq'.
  Definition Fix5_Proper_eq_with_assumption : Fix5_Proper_eq_with_assumption'T := Fix5_Proper_eq_with_assumption'.
End Fix5.

Arguments Fix5_Proper_eq {A B C D E F R Rwf P} _ _ _ _ _ _ _ _ _.
Arguments Fix5_Proper_eq_with_assumption {A B C D E F R Rwf P} _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix5_Proper_eq.
Global Existing Instance Fix5_Proper_eq_with_assumption.

Section Fix6.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f, G a b c d e f -> Type).

  Local Notation Fix6 := (@Fix A R Rwf (fun a : A => forall b c d e f g, @P a b c d e f g)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun _ : @G a b c d e f => bottom))))))).

  Let Fix6_eq' := @FixV_eq A T R Rwf P.
  Let Fix6_eq'T := Eval simpl in type_of Fix6_eq'.

  Let Fix6_rect' := @FixV_rect A T R Rwf P.
  Let Fix6_rect'T := Eval simpl in type_of Fix6_rect'.

  Let Fix6_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix6_Proper_eq'T := Eval simpl in type_of Fix6_Proper_eq'.

  Let Fix6_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix6_Proper_eq_with_assumption'T := Eval simpl in type_of Fix6_Proper_eq_with_assumption'.

  Definition Fix6_eq : Fix6_eq'T := Fix6_eq'.
  Definition Fix6_rect : Fix6_rect'T := Fix6_rect'.
  Definition Fix6_Proper_eq : Fix6_Proper_eq'T := Fix6_Proper_eq'.
  Definition Fix6_Proper_eq_with_assumption : Fix6_Proper_eq_with_assumption'T := Fix6_Proper_eq_with_assumption'.
End Fix6.

Arguments Fix6_Proper_eq {A B C D E F G R Rwf P} _ _ _ _ _ _ _ _ _ _.
Arguments Fix6_Proper_eq_with_assumption {A B C D E F G R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix6_Proper_eq.
Global Existing Instance Fix6_Proper_eq_with_assumption.

Section Fix7.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g, H a b c d e f g -> Type).

  Local Notation Fix7 := (@Fix A R Rwf (fun a : A => forall b c d e f g h, @P a b c d e f g h)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun _ : @H a b c d e f g => bottom)))))))).

  Let Fix7_eq' := @FixV_eq A T R Rwf P.
  Let Fix7_eq'T := Eval simpl in type_of Fix7_eq'.

  Let Fix7_rect' := @FixV_rect A T R Rwf P.
  Let Fix7_rect'T := Eval simpl in type_of Fix7_rect'.

  Let Fix7_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix7_Proper_eq'T := Eval simpl in type_of Fix7_Proper_eq'.

  Let Fix7_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix7_Proper_eq_with_assumption'T := Eval simpl in type_of Fix7_Proper_eq_with_assumption'.

  Definition Fix7_eq : Fix7_eq'T := Fix7_eq'.
  Definition Fix7_rect : Fix7_rect'T := Fix7_rect'.
  Definition Fix7_Proper_eq : Fix7_Proper_eq'T := Fix7_Proper_eq'.
  Definition Fix7_Proper_eq_with_assumption : Fix7_Proper_eq_with_assumption'T := Fix7_Proper_eq_with_assumption'.
End Fix7.

Arguments Fix7_Proper_eq {A B C D E F G H R Rwf P} _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix7_Proper_eq_with_assumption {A B C D E F G H R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix7_Proper_eq.
Global Existing Instance Fix7_Proper_eq_with_assumption.

Section Fix8.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h, I a b c d e f g h -> Type).

  Local Notation Fix8 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i, @P a b c d e f g h i)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun _ : @I a b c d e f g h => bottom))))))))).

  Let Fix8_eq' := @FixV_eq A T R Rwf P.
  Let Fix8_eq'T := Eval simpl in type_of Fix8_eq'.

  Let Fix8_rect' := @FixV_rect A T R Rwf P.
  Let Fix8_rect'T := Eval simpl in type_of Fix8_rect'.

  Let Fix8_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix8_Proper_eq'T := Eval simpl in type_of Fix8_Proper_eq'.

  Let Fix8_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix8_Proper_eq_with_assumption'T := Eval simpl in type_of Fix8_Proper_eq_with_assumption'.

  Definition Fix8_eq : Fix8_eq'T := Fix8_eq'.
  Definition Fix8_rect : Fix8_rect'T := Fix8_rect'.
  Definition Fix8_Proper_eq : Fix8_Proper_eq'T := Fix8_Proper_eq'.
  Definition Fix8_Proper_eq_with_assumption : Fix8_Proper_eq_with_assumption'T := Fix8_Proper_eq_with_assumption'.
End Fix8.

Arguments Fix8_Proper_eq {A B C D E F G H I R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix8_Proper_eq_with_assumption {A B C D E F G H I R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix8_Proper_eq.
Global Existing Instance Fix8_Proper_eq_with_assumption.

Section Fix9.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type) (J : forall a b c d e f g h, I a b c d e f g h -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h i, J a b c d e f g h i -> Type).

  Local Notation Fix9 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i j, @P a b c d e f g h i j)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun i => tele _ (fun _ : @J a b c d e f g h i => bottom)))))))))).

  Let Fix9_eq' := @FixV_eq A T R Rwf P.
  Let Fix9_eq'T := Eval simpl in type_of Fix9_eq'.

  Let Fix9_rect' := @FixV_rect A T R Rwf P.
  Let Fix9_rect'T := Eval simpl in type_of Fix9_rect'.

  Let Fix9_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix9_Proper_eq'T := Eval simpl in type_of Fix9_Proper_eq'.

  Let Fix9_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix9_Proper_eq_with_assumption'T := Eval simpl in type_of Fix9_Proper_eq_with_assumption'.

  Definition Fix9_eq : Fix9_eq'T := Fix9_eq'.
  Definition Fix9_rect : Fix9_rect'T := Fix9_rect'.
  Definition Fix9_Proper_eq : Fix9_Proper_eq'T := Fix9_Proper_eq'.
  Definition Fix9_Proper_eq_with_assumption : Fix9_Proper_eq_with_assumption'T := Fix9_Proper_eq_with_assumption'.
End Fix9.

Arguments Fix9_Proper_eq {A B C D E F G H I J R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix9_Proper_eq_with_assumption {A B C D E F G H I J R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix9_Proper_eq.
Global Existing Instance Fix9_Proper_eq_with_assumption.

Section Fix10.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type) (F : forall a b c d, E a b c d -> Type) (G : forall a b c d e, F a b c d e -> Type) (H : forall a b c d e f, G a b c d e f -> Type) (I : forall a b c d e f g, H a b c d e f g -> Type) (J : forall a b c d e f g h, I a b c d e f g h -> Type) (K : forall a b c d e f g h i, J a b c d e f g h i -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d e f g h i j, K a b c d e f g h i j -> Type).

  Local Notation Fix10 := (@Fix A R Rwf (fun a : A => forall b c d e f g h i j k, @P a b c d e f g h i j k)).
  Local Notation T := (fun a => tele _ (fun b => tele _ (fun c => tele _ (fun d => tele _ (fun e => tele _ (fun f => tele _ (fun g => tele _ (fun h => tele _ (fun i => tele _ (fun j => tele _ (fun _ : @K a b c d e f g h i j => bottom))))))))))).

  Let Fix10_eq' := @FixV_eq A T R Rwf P.
  Let Fix10_eq'T := Eval simpl in type_of Fix10_eq'.

  Let Fix10_rect' := @FixV_rect A T R Rwf P.
  Let Fix10_rect'T := Eval simpl in type_of Fix10_rect'.

  Let Fix10_Proper_eq' := @FixV_Proper_eq A T R Rwf P.
  Let Fix10_Proper_eq'T := Eval simpl in type_of Fix10_Proper_eq'.

  Let Fix10_Proper_eq_with_assumption' := @FixV_Proper_eq_with_assumption A T R Rwf P.
  Let Fix10_Proper_eq_with_assumption'T := Eval simpl in type_of Fix10_Proper_eq_with_assumption'.

  Definition Fix10_eq : Fix10_eq'T := Fix10_eq'.
  Definition Fix10_rect : Fix10_rect'T := Fix10_rect'.
  Definition Fix10_Proper_eq : Fix10_Proper_eq'T := Fix10_Proper_eq'.
  Definition Fix10_Proper_eq_with_assumption : Fix10_Proper_eq_with_assumption'T := Fix10_Proper_eq_with_assumption'.
End Fix10.

Arguments Fix10_Proper_eq {A B C D E F G H I J K R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Arguments Fix10_Proper_eq_with_assumption {A B C D E F G H I J K R Rwf P} _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _.
Global Existing Instance Fix10_Proper_eq.
Global Existing Instance Fix10_Proper_eq_with_assumption.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                               egaliteTS.v                                *)
(****************************************************************************)

(*****************************************************************************)
(*          Projet Coq  - Calculus of Inductive Constructions V5.8           *)
(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

                      (* egalite dans les termes-sub_explicits (TS) *)

Require Import TS.

(***********************************************)
(*            Inegalites dans TS               *)
(***********************************************)

Goal forall (n : nat) (a b : terms), var n <> app a b.
intros; discriminate.
Save diff_var_app.

Goal forall (n : nat) (a : terms), var n <> lambda a.
intros; discriminate.
Save diff_var_lambda.

Goal forall (n : nat) (a : terms) (s : sub_explicits), var n <> env a s.
intros; discriminate.
Save diff_var_env.

Goal forall a b c : terms, app a b <> lambda c.
intros; discriminate.
Save diff_app_lambda.

Goal forall (a b c : terms) (s : sub_explicits), app a b <> env c s.
intros; discriminate.
Save diff_app_env.

Goal forall (a b : terms) (s : sub_explicits), lambda a <> env b s.
intros; discriminate.
Save diff_lambda_env.

Goal id <> shift.
intros; discriminate.
Save diff_id_shift.

Goal forall (a : terms) (s : sub_explicits), id <> cons a s.
intros; discriminate.
Save diff_id_cons.

Goal forall s t : sub_explicits, id <> comp s t.
intros; discriminate.
Save diff_id_comp.

Goal forall s : sub_explicits, id <> lift s.
intros; discriminate.
Save diff_id_lift.

Goal forall (a : terms) (s : sub_explicits), shift <> cons a s.
intros; discriminate.
Save diff_shift_cons.

Goal forall s t : sub_explicits, shift <> comp s t.
intros; discriminate.
Save diff_shift_comp.

Goal forall s : sub_explicits, shift <> lift s.
intros; discriminate.
Save diff_shift_lift.

Goal forall (a : terms) (s t u : sub_explicits), cons a s <> comp t u.
intros; discriminate.
Save diff_cons_comp.

Goal forall (a : terms) (s t : sub_explicits), cons a s <> lift t.
intros; discriminate.
Save diff_cons_lift.

Goal forall s t u : sub_explicits, comp s t <> lift u.
intros; discriminate.
Save diff_comp_lift.

(***********************************************)
(*             Egalite dans TS                 *)
(***********************************************)

Goal forall n1 n2 : nat, var n1 = var n2 -> n1 = n2.
intros n1 n2 H; injection H; trivial.
Save proj_var.

Goal forall a1 b1 a2 b2 : terms, app a1 b1 = app a2 b2 -> a1 = a2.
intros a1 b1 a2 b2 H; injection H; trivial.
Save proj_app1.

Goal forall a1 b1 a2 b2 : terms, app a1 b1 = app a2 b2 -> b1 = b2.
intros a1 b1 a2 b2 H; injection H; trivial.
Save proj_app2.

Goal forall a b : terms, lambda a = lambda b -> a = b.
intros a b H; injection H; trivial.
Save proj_lambda.

Goal forall (a b : terms) (s t : sub_explicits), env a s = env b t -> a = b.
intros a b s t H; injection H; trivial.
Save proj_env1.

Goal forall (a b : terms) (s t : sub_explicits), env a s = env b t -> s = t.
intros a b s t H; injection H; trivial.
Save proj_env2.

Goal
forall (a b : terms) (s t : sub_explicits), cons a s = cons b t -> a = b.
intros a b s t H; injection H; trivial.
Save proj_cons1.

Goal
forall (a b : terms) (s t : sub_explicits), cons a s = cons b t -> s = t.
intros a b s t H; injection H; trivial.
Save proj_cons2.

Goal forall s1 s2 t1 t2 : sub_explicits, comp s1 t1 = comp s2 t2 -> s1 = s2.
intros s1 s2 t1 t2 H; injection H; trivial.
Save proj_comp1.

Goal forall s1 s2 t1 t2 : sub_explicits, comp s1 t1 = comp s2 t2 -> t1 = t2.
intros s1 s2 t1 t2 H; injection H; trivial.
Save proj_comp2.

Goal forall s t : sub_explicits, lift s = lift t -> s = t.
intros s t H; injection H; trivial.
Save proj_lift.


Require Import Kami.Extraction.
Require Import BinNat.
Import FinFun.Fin2Restrict.
Require Import Kami.AllNotations.

Class toString (X : Type) := {
  to_string : X -> string
  }.

Instance toString_prod{X Y}`{toString X, toString Y} : toString (X * Y) := {|
  to_string := fun '(x,y) => (to_string x ++ "_" ++ to_string y)%string
  |}.

Instance toString_sigma{X}{Y : X -> Type}`{toString X}`{forall x, toString (Y x)} : toString {x : X & Y x} := {|
  to_string := fun '(existT x y) => (to_string x ++ "_" ++ to_string y)%string
  |}.

Definition cart_prod{X Y}(xs : list X)(ys : list Y) : list (X * Y) :=
  List.concat (map (fun x => map (pair x) ys) xs).

Inductive FileType :=
  | AsyncF
  | SyncIsAddr
  | SyncNotIsAddr.

Inductive OverlapType :=
  | Over (* write  -----
            read     -----
          *)

  | Under (* write    -----
             read  -----
           *)

  | Disjoint (* write -----
                read        -----
              *)
  .

Inductive MaskType :=
  | IsWrMask
  | NotIsWrMask.

Inductive Schedule :=
  | WriteFirst
  | WriteSecond
  | WriteThird.

Definition FileTuple := (FileType * Schedule * OverlapType * MaskType)%type.

Definition async_file_varieties : list FileTuple :=
  cart_prod (cart_prod (cart_prod [AsyncF] [WriteFirst; WriteSecond]) [Over; Under; Disjoint]) [IsWrMask; NotIsWrMask].

Definition syncIsAddr_file_varieties : list FileTuple :=
  cart_prod (cart_prod (cart_prod [SyncIsAddr] [WriteFirst; WriteSecond; WriteThird]) [Over; Under; Disjoint]) [IsWrMask; NotIsWrMask].

Definition syncNotIsAddr_file_varieties : list FileTuple :=
  cart_prod (cart_prod (cart_prod [SyncNotIsAddr] [WriteFirst; WriteSecond; WriteThird]) [Over; Under; Disjoint]) [IsWrMask; NotIsWrMask].

Definition dep_cart_prod{X}{Y : X -> Type}(xs : list X)(ys : forall x, list (Y x)) : list ({x : X & Y x}) :=
  concat (map (fun x => map (fun y => existT Y x y) (ys x)) xs).

Section Params.

Definition num := 5.
Definition idxNum := 20.
Definition Xlen := 32.
Definition Data := Bit Xlen.
Definition Counter := Bit 2.
Definition init_val : word Xlen := Xlen 'h"e".

(* mask = {true; false; false; false; true} *)
Definition mask_func1 : Fin.t num -> bool := fun (i : Fin.t num) =>
  match i with
  | F1 _ => true
  | FS _ (F1 _) => false
  | FS _ (FS _ (F1 _)) => false
  | FS _ (FS _ (FS _ (F1 _))) => false
  | _ => true
  end.

Definition mask_func2 : Fin.t num -> bool := fun i => negb (mask_func1 i).

Definition mask1 : ConstT (Array num Bool) := ConstArray mask_func1.
Definition mask2 : ConstT (Array num Bool) := ConstArray mask_func2.

Definition write_index := 4.
Definition read_under_index := 2.
Definition read_over_index := 6.
Definition read_disjoint_index := 12.

Definition write_val_1 : word Xlen := Xlen 'h"1e".
Definition write_val_2 : word Xlen := Xlen 'h"3e".

(* reality check lemmas *)

(* good read/write indices*)

Lemma read_under_bounds : read_under_index < write_index < read_under_index + num.
Proof.
  cbv delta; try split; lia.
Qed.

Lemma read_over_bounds : read_over_index < write_index + num < read_over_index + num.
Proof.
  cbv delta; try split; lia.
Qed.

Lemma read_disjoint_bounds : write_index + num < read_disjoint_index /\ read_disjoint_index + num < idxNum.
Proof.
  cbv delta; try split; lia.
Qed.

(*good masks*)

Lemma mask1_under_true : exists (i : Fin.t num), mask_func1 i = true /\ f2n i < num - (write_index - read_under_index).
Proof.
  exists F1; simpl; auto.
Qed.

Lemma mask1_under_false : exists (i : Fin.t num), mask_func1 i = false /\ f2n i < num - (write_index - read_under_index).
Proof.
  exists (FS F1); simpl; auto.
Qed.

Lemma mask1_over_true : exists (i : Fin.t num), mask_func1 i = true /\ f2n i > (read_over_index - write_index).
Proof.
  exists (FS (FS (FS (FS F1)))); unfold f2n; simpl; auto.
Qed.

Lemma mask1_over_false : exists (i : Fin.t num), mask_func1 i = false /\ f2n i > (read_over_index - write_index).
Proof.
  exists (FS (FS (FS F1))); unfold f2n; simpl; auto.
Qed.

Lemma mask2_under_true : exists (i : Fin.t num), mask_func2 i = true /\ f2n i < num - (write_index - read_under_index).
Proof.
  exists (FS F1); simpl; auto.
Qed.

Lemma mask2_under_false : exists (i : Fin.t num), mask_func2 i = false /\ f2n i < num - (write_index - read_under_index).
Proof.
  exists F1; simpl; auto.
Qed.

Lemma mask2_over_true : exists (i : Fin.t num), mask_func2 i = true /\ f2n i > (read_over_index - write_index).
Proof.
  exists (FS (FS (FS F1))); unfold f2n; simpl; auto.
Qed.

Lemma mask2_over_false : exists (i : Fin.t num), mask_func2 i = false /\ f2n i > (read_over_index - write_index).
Proof.
  exists (FS (FS (FS (FS F1)))); unfold f2n; simpl; auto.
Qed.

(* good values *)

Lemma init_write1_neq : weqb init_val write_val_1 = false.
Proof.
  auto.
Qed.

Lemma init_write2_neq : weqb init_val write_val_2 = false.
Proof.
  auto.
Qed.

Lemma write1_write2_neq : weqb write_val_1 write_val_2 = false.
Proof.
  auto.
Qed.

End Params.

Section Files.

Instance toString_FileType : toString FileType := {|
  to_string := fun x => match x with
                        | AsyncF => "async"
                        | SyncIsAddr => "syncIsAddr"
                        | SyncNotIsAddr => "syncNotIsAddr"
                        end
  |}.

Instance toString_OverlapType : toString OverlapType := {|
  to_string := fun x => match x with
                        | Over => "over"
                        | Under => "under"
                        | Disjoint => "disjoint"
                        end
  |}.

Instance toString_MaskType : toString MaskType := {|
  to_string := fun x => match x with
                        | IsWrMask => "isWrMask"
                        | NotIsWrMask => "notIsWrMask"
                        end
  |}.

Instance toString_Schedule : toString Schedule := {|
  to_string := fun x => match x with
                        | WriteFirst => "writeFirst"
                        | WriteSecond => "writeSecond"
                        | WriteThird => "writeThird"
                        end
  |}.

Definition dataArray_name : FileTuple -> string :=
  fun tup => ("dataArray_" ++ to_string tup)%string.

Definition read_name : FileTuple -> string :=
  fun tup => ("read_" ++ to_string tup)%string.

Definition readReq_name : FileTuple -> string :=
  fun tup => ("readReq_" ++ to_string tup)%string.

Definition readRes_name : FileTuple -> string :=
  fun tup => ("readRes_" ++ to_string tup)%string.

Definition readReg_name : FileTuple -> string :=
  fun tup => ("readReg_" ++ to_string tup)%string.

Definition write_name : FileTuple -> string :=
  fun tup => ("write_" ++ to_string tup)%string.

Definition make_RFB(tup : FileTuple) : RegFileBase :=
  let '(ft,sch,ot,mt) := tup in
    {|
      rfIsWrMask := match mt with
                    | IsWrMask => true
                    | NotIsWrMask => false
                    end;
      rfNum := num;
      rfDataArray := dataArray_name tup;
      rfRead :=  match ft with
                 | AsyncF => Async [read_name tup]
                 | SyncIsAddr => Sync true
                     [
                       {| readReqName := readReq_name tup;
                          readResName := readRes_name tup;
                          readRegName := readReg_name tup
                       |}
                     ]
                 | SyncNotIsAddr => Sync false
                     [
                       {| readReqName := readReq_name tup;
                          readResName := readRes_name tup;
                          readRegName := readReg_name tup
                       |}
                     ]
                 end;
      rfWrite := write_name tup;
      rfIdxNum := idxNum;
      rfData := Data;
      rfInit := RFNonFile idxNum (Some (ConstBit init_val))
    |}.

End Files.

Section Rules.

Local Open Scope kami_expr.
Local Open Scope kami_action.

Variable tup : FileTuple.

Definition all_init : ConstT (Array num Data) :=
  ConstArray (fun _ => init_val).

Definition expected_read_under(val : word Xlen) : ConstT (Array num Data) :=
    ConstArray (fun i => if f2n i <? write_index - read_under_index then init_val else val).

Definition expected_read_over(val : word Xlen) : ConstT (Array num Data) :=
    ConstArray (fun i => if f2n i <? num - (read_over_index - write_index) then val else init_val).

(*translations*)
Definition read_under_Fin_to_write_Fin(i : Fin.t num) : Fin.t num.
Proof.
  refine (@of_nat_lt (f2n i - (write_index - read_under_index)) num _).
  unfold f2n.
  destruct to_nat.
  simpl; lia.
Defined.

Definition read_over_Fin_to_write_Fin(i : Fin.t num)(pf : (f2n i < num - (read_over_index - write_index))%nat) : Fin.t num.
Proof.
  refine (@of_nat_lt (f2n i + (read_over_index - write_index)) num _).
  unfold f2n.
  unfold f2n in pf.
  destruct to_nat.
  simpl proj1_sig.
  simpl in pf.
  simpl.
  unfold num.
  lia.
Defined.

Definition expected_read_under_masked(mask_val non_mask_val : word Xlen)(mf nmf : Fin.t num -> bool) : ConstT (Array num Data) :=
  ConstArray (fun i => if f2n i <? write_index - read_under_index then init_val else
    if mf (read_under_Fin_to_write_Fin i) then mask_val else
    if nmf (read_under_Fin_to_write_Fin i) then non_mask_val else init_val).

Definition expected_read_over_masked(mask_val non_mask_val : word Xlen)(mf nmf : Fin.t num -> bool) : ConstT (Array num Data) :=
  ConstArray (fun i => match Compare_dec.le_lt_dec (num - (read_over_index - write_index)) (f2n i) with
                       | left _ => init_val
                       | right pf => if mf (read_over_Fin_to_write_Fin i pf) then mask_val else
                                     if nmf (read_over_Fin_to_write_Fin i pf) then non_mask_val else init_val
                       end).

Definition expected_read_ot_mt(write_val old_val : word Xlen)(wmf omf : Fin.t num -> bool)(ot : OverlapType)(mt : MaskType) :=
  match ot,mt with
  | Over,IsWrMask => expected_read_over_masked write_val old_val wmf omf
  | Over,NotIsWrMask => expected_read_over write_val
  | Under,IsWrMask => expected_read_under_masked write_val old_val wmf omf
  | Under,NotIsWrMask => expected_read_under write_val
  | Disjoint,_ => all_init
  end.

Definition expected_read_val_first_cycle : ConstT (Array num Data) :=
  let '(p,ot,mt) := tup in
    match p with
    | (AsyncF,WriteFirst) => expected_read_ot_mt write_val_1 init_val mask_func1 mask_func2 ot mt
    | (AsyncF,_) => all_init
    | _ => getDefaultConst (Array num Data)
    end.

Definition expected_read_val_second_cycle : ConstT (Array num Data) :=
  let '(p,ot,mt) := tup in
    match p with
    | (AsyncF, WriteFirst) => expected_read_ot_mt write_val_2 write_val_1 mask_func2 mask_func1 ot mt
    | (AsyncF, _) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt
    | (SyncIsAddr, WriteFirst) => expected_read_ot_mt write_val_2 write_val_1 mask_func2 mask_func1 ot mt
    | (SyncIsAddr, WriteSecond) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt
    | (SyncIsAddr, WriteThird) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt
    | (SyncNotIsAddr, WriteFirst) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt
    | (SyncNotIsAddr, WriteSecond) => expected_read_ot_mt write_val_1 init_val mask_func1 (fun _ => true) ot mt
    | (SyncNotIsAddr, WriteThird) => all_init
    end.

Definition make_write : RuleT :=
  let '(ft,sch,ot,mt) := tup in
  match mt with
  | IsWrMask => (("rule_" ++ write_name tup)%string,
      fun ty : (Kind -> Type) =>
        Read c : Counter <- "counter";
        LET write_val <- ITE (#c == $1) $$write_val_2 $$write_val_1;
        LET mask <- ITE (#c == $1) $$mask2 $$mask1;
        Call (write_name tup)(@createWriteRqMask ty idxNum num Data ($write_index) (BuildArray (fun _ => #write_val)) #mask : _);
        Retv
      )
  | NotIsWrMask => (("rule_" ++ write_name tup)%string,
      fun ty : (Kind -> Type) =>
        Read c : Counter <- "counter";
        LET write_val <- ITE (#c == $1) $$write_val_2 $$write_val_1;
        Call (write_name tup)(@createWriteRq ty idxNum num Data ($write_index) (BuildArray (fun _ => #write_val)) : _);
        Retv
      )
  end.

Definition print_comparison{ty k}(val exp_val : Expr ty (SyntaxKind k)) : ActionT ty Void :=
  System (
    [DispString _ "Read Value:     ";
     DispHex val;
     DispString _ "\n";
     DispString _ "Expected Value: ";
     DispHex exp_val;
     DispString _ "\n"
    ]
  );
  Read curr_passing : Bool <- "passing";
  Write "passing" <- #curr_passing && (val == exp_val);
  If (val == exp_val)
  then (System [DispString _ "Passed.\n\n"]; Retv)
  else (System [DispString _ "FAILED FAILED FAILED FAILED FAILED FAILED FAILED FAILED\n\n"]; Retv);
  Retv.

Definition print_read{ty}(read_idx : Expr ty (SyntaxKind (Bit (Nat.log2_up idxNum)))) : list (SysT ty) :=
  [DispString _ "Read Index: ";
   DispHex read_idx;
   DispString _ "\n\n"
  ].

Definition make_read : RuleT :=
  let '(ft,sch,ot,mt) := tup in
  let read_index := match ot with
                    | Over => read_over_index
                    | Under => read_under_index
                    | Disjoint => read_disjoint_index
                    end in
  (("rule_" ++ read_name tup)%string,
  fun (ty : Kind -> Type) =>
    Call val : Array num Data <- (read_name tup)($read_index : Bit (Nat.log2_up idxNum));
    Read c : Counter <- "counter";
    LET exp_val : Array num Data <- ITE (#c == $1) $$expected_read_val_second_cycle $$expected_read_val_first_cycle;
    System ([DispString _  ("rule_" ++ read_name tup ++ ":\n")%string] ++ print_read ($read_index))%list;
    LETA _ : _ <- (print_comparison #val #exp_val);
    Retv
  ).

Definition make_readReq : RuleT :=
  let '(ft,sch,ot,mt) := tup in
  let read_index := match ot with
                    | Over => read_over_index
                    | Under => read_under_index
                    | Disjoint => read_disjoint_index
                    end in
  (("rule_" ++ readReq_name tup)%string,
  fun ty =>
      Call (readReq_name tup)($read_index : Bit (Nat.log2_up idxNum));
      System ([DispString _  ("rule_" ++ readReq_name tup ++ ":\n")%string] ++ print_read ($read_index))%list;
      Retv
  ).

Definition make_readResp : RuleT :=
  (("rule_" ++ readRes_name tup)%string,
  fun (ty : Kind -> Type) =>
    Call val : Array num Data <- (readRes_name tup)();
    Read c : Counter <- "counter";
    LET exp_val : Array num Data <- ITE (#c == $1) $$expected_read_val_second_cycle $$expected_read_val_first_cycle;
    System [DispString _  ("rule_" ++ readRes_name tup ++ ":\n")%string];
    If (#c == $1) then (print_comparison #val #exp_val);
    Retv
  ).

Definition make_rules : list RuleT :=
  let '(p,ot,mt) := tup in
  match p with
  | (AsyncF, WriteFirst) => [make_write; make_read]
  | (AsyncF, _) => [make_read; make_write]
  | (SyncIsAddr, WriteFirst) => [make_write; make_readResp; make_readReq]
  | (SyncIsAddr, WriteSecond) => [make_readResp; make_write; make_readReq]
  | (SyncIsAddr, WriteThird) => [make_readResp; make_readReq; make_write]
  | (SyncNotIsAddr, WriteFirst) => [make_write; make_readResp; make_readReq]
  | (SyncNotIsAddr, WriteSecond) => [make_readResp; make_write; make_readReq]
  | (SyncNotIsAddr, WriteThird) => [make_readResp; make_readReq; make_write]
  end.

End Rules.

Section TestMod.

Local Open Scope kami_expr.
Local Open Scope kami_action.

Definition all_async_rules : list RuleT :=
  concat (map make_rules async_file_varieties).

Definition all_syncIsAddr_rules : list RuleT :=
  concat (map make_rules syncIsAddr_file_varieties).

Definition all_syncNotIsAddr_rules : list RuleT :=
  concat (map make_rules syncNotIsAddr_file_varieties).

(* registers *)
(* write then read *)

Definition write_reg_WR : RuleT :=
  ("write_reg_WR", fun ty : (Kind -> Type) =>
      Read c : Counter <- "counter";
      LET new_val : Data <- ITE (#c == $1) $$write_val_2 $$write_val_1;
      System ([DispString _  ("write_reg_WR: ")%string; DispHex #new_val; DispString _ "\n\n"]);
      Write "reg_WR" <- #new_val;
      Retv
      ).

Definition read_reg_WR : RuleT :=
  ("read_reg_WR", fun ty : (Kind -> Type) =>
      Read c : Counter <- "counter";
      Read val : Data <- "reg_WR";
      LET exp_val : Data <- ITE (#c == $1) $$write_val_2 $$write_val_1;
      System [DispString _ "read_reg_WR:\n"];
      LETA _ : _ <- print_comparison #val #exp_val;
      Retv
      ).

(* read then write *)

Definition read_reg_RW : RuleT :=
  ("read_reg_RW", fun ty : (Kind -> Type) =>
      Read c : Counter <- "counter";
      Read val : Data <- "reg_RW";
      LET exp_val : Data <- ITE (#c == $1) $$write_val_1 $$init_val;
      System [DispString _ "read_reg_RW:\n"];
      LETA _ : _ <- print_comparison #val #exp_val;
      Retv
      ).

Definition write_reg_RW : RuleT :=
  ("write_reg_RW", fun ty : (Kind -> Type) =>
      Read c : Counter <- "counter";
      LET new_val : Data <- ITE (#c == $1) $$write_val_2 $$write_val_1;
      System ([DispString _  "write_reg_RW: "; DispHex #new_val; DispString _ "\n\n"]);
      Write "reg_RW" <- #new_val;
      Retv
      ).

Definition reg_3_rule_1 : RuleT :=
  ("reg_3_write_1", fun ty : (Kind -> Type) =>
      Write "reg_3" <- $$write_val_1;
      Read val : Data <- "reg_3";
      System [DispString _ "reg_3_write_1:\n"];
      LETA _ : _ <- print_comparison #val $$init_val;
      Retv
      ).

Definition reg_3_rule_2 : RuleT :=
  ("reg_3_write_2", fun ty : (Kind -> Type) =>
      Write "reg_3" <- $$write_val_2;
      Read val : Data <- "reg_3";
      System [DispString _ "reg_3_write_2:\n"];
      LETA _ : _ <- print_comparison #val $$write_val_1;
      Retv
      ).

Definition reg_3_rule_3 : RuleT :=
  ("reg_3_init", fun ty : (Kind -> Type) =>
      Write "reg_3" <- $$init_val;
      Read val : Data <- "reg_3";
      System [DispString _ "reg_3_init:\n"];
      LETA _ : _ <- print_comparison #val $$write_val_2;
      Retv
      ).

(* counter rule*)

Definition counter : RuleT :=
  ("counter", fun ty : (Kind -> Type) =>
      Read c : Counter <- "counter";
      System [DispString _ "End of cycle "; DispHex #c; DispString _ "\n"];
      Write "counter" <- #c + $1;
      If(#c == $1) then
        (Read passed : Bool <- "passing";
        If (#passed)
        then (System [DispString _ "Test Suite Passed.\n"; Finish _]; Retv)
        else (System [DispString _ "Test Suite Failed.\n"; Finish _]; Retv);
        Retv);
      Retv).

Definition all_reg_rules := [write_reg_WR; read_reg_WR; read_reg_RW; write_reg_RW; reg_3_rule_1; reg_3_rule_2; reg_3_rule_3].

Definition testRegBaseMod := BaseMod [
  ("reg_WR", (existT _ (SyntaxKind _) (Some (SyntaxConst init_val))));
  ("reg_RW", (existT _ (SyntaxKind _) (Some (SyntaxConst init_val))));
  ("reg_3", (existT _ (SyntaxKind _) (Some (SyntaxConst init_val))));
  ("counter", (existT _ (SyntaxKind (Counter)) (Some (SyntaxConst (getDefaultConst _)))));
  ("passing", (existT _ (SyntaxKind Bool) (Some (SyntaxConst (ConstBool true)))))
  ]
 (all_reg_rules ++ [counter]) [].

Definition testAsyncBaseMod := BaseMod [
  ("counter", (existT _ (SyntaxKind (Counter)) (Some (SyntaxConst (getDefaultConst _)))));
  ("passing", (existT _ (SyntaxKind Bool) (Some (SyntaxConst (ConstBool true)))))
  ]
  (all_async_rules ++ [counter]) [].

Definition testSyncIsAddrBaseMod := BaseMod [
  ("counter", (existT _ (SyntaxKind (Counter)) (Some (SyntaxConst (getDefaultConst _)))));
  ("passing", (existT _ (SyntaxKind Bool) (Some (SyntaxConst (ConstBool true)))))
  ]
  (all_syncIsAddr_rules ++ [counter]) [].

Definition testSyncNotIsAddrBaseMod := BaseMod [
  ("counter", (existT _ (SyntaxKind (Counter)) (Some (SyntaxConst (getDefaultConst _)))));
  ("passing", (existT _ (SyntaxKind Bool) (Some (SyntaxConst (ConstBool true)))))
  ]
  (all_syncNotIsAddr_rules ++ [counter]) [].

Definition testAsyncRFs := map make_RFB async_file_varieties.

Definition testSyncIsAddrRFs := map make_RFB syncIsAddr_file_varieties.

Definition testSyncNotIsAddrRFs := map make_RFB syncNotIsAddr_file_varieties.

Definition mkTestMod(bm : BaseModule)(rfs : list RegFileBase) :=
  let md := (fold_right ConcatMod bm (map (fun m => Base (BaseRegFile m)) rfs)) in
  createHideMod md (map fst (getAllMethods md)).

Definition testReg := mkTestMod testRegBaseMod [].

Definition testAsync := mkTestMod testAsyncBaseMod testAsyncRFs.

Definition testSyncIsAddr := mkTestMod testSyncIsAddrBaseMod testSyncIsAddrRFs.

Definition testSyncNotIsAddr := mkTestMod testSyncNotIsAddrBaseMod testSyncNotIsAddrRFs.

End TestMod.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Import GRing.Theory Num.Def Num.Theory.

Require Import OUVerT.extrema OUVerT.dist.

Local Open Scope ring_scope.

(** This module defines an interface over multiplayer games. *)

(** Operational type classe for 'cost';
    cf. "Type Classes for Mathematics in Type Theory",
        Spitters and van der Weegen,
        http://www.eelis.net/research/math-classes/mscs.pdf*)

Class CostClass (cN : nat) (rty : realFieldType) (cT : finType) :=
  cost_fun : 'I_cN -> {ffun 'I_cN -> cT} -> rty.
Notation "'cost'" := (@cost_fun _ _ _) (at level 30).

Class CostAxiomClass cN rty cT `(CostClass cN rty cT) :=
  cost_axiom (i : 'I_cN) (f : {ffun 'I_cN -> cT}) : 0 <= cost i f.

Section costLemmas.
  Context {N rty T} `(CostAxiomClass N rty T).

  Lemma cost_pos i f : 0 <= cost i f.
  Proof. apply: cost_axiom. Qed.
End costLemmas.

(*Instance finCloneCostInstance cN rty cT `(H : CostClass cN rty cT) :
  CostClass cN rty [finType of cT] :=
  @cost_fun cN rty [finType of cT] H.*)

Class CostMaxClass (N : nat) (rty : realFieldType) (T : Type) :=
  costmax_fun : rty.

Class CostMaxAxiomClass (N : nat) (rty : realFieldType) (T : finType)
      (costClass : CostClass N rty T)
      (costMaxClass : CostMaxClass N rty T) :=
  costMaxAxiom_fun : forall i s, cost i s  <= costmax_fun.

Class game (T : finType) (N : nat) (rty : realFieldType)
      (costClass : CostClass N rty T)
      (costAxiomClass : CostAxiomClass costClass)
      (costMaxClass : CostMaxClass N rty T)
      (costMaxAxiomClass : CostMaxAxiomClass costClass costMaxClass)
  : Type := {}.

Notation "'gameOf' " := (@game _ _ _ _ _ _ _) (at level 30).

(***********************)
(** Negative cost game *)

Class NegativeCostAxiomClass cN rty cT `(CostClass cN rty cT) :=
  negative_cost_axiom (i : 'I_cN) (f : {ffun 'I_cN -> cT}) : cost i f <= 0.

Section negativeCostLemmas.
  Context {N rty T} `(NegativeCostAxiomClass N rty T).

  Lemma cost_neg i f : cost i f <= 0.
  Proof. apply: negative_cost_axiom. Qed.
End negativeCostLemmas.

Class negative_cost_game (T : finType) (N : nat) (rty : realFieldType)
      `(negativeCostAxiomClass : NegativeCostAxiomClass N rty T)
  : Type := {}.

(** End negative cost game *)
(***************************)

(****************)
(** Payoff game *)

Class PayoffClass (cN : nat) (rty : realFieldType) (cT : finType) :=
  payoff_fun : 'I_cN -> {ffun 'I_cN -> cT} -> rty.
Notation "'payoff'" := (@payoff_fun _ _ _) (at level 30).

Class PayoffAxiomClass cN rty cT `(PayoffClass cN rty cT) :=
  payoff_axiom (i : 'I_cN) (f : {ffun 'I_cN -> cT}) : 0 <= payoff i f.

Section payoffLemmas.
  Context {N rty T} `(PayoffAxiomClass N rty T).

  Lemma payoff_pos i f : 0 <= payoff i f.
  Proof. apply: payoff_axiom. Qed.
End payoffLemmas.

Class payoff_game (T : finType) (N : nat) (rty : realFieldType)
      `(payoffAxiomClass : PayoffAxiomClass N rty T)
  : Type := {}.

(** End payoff game *)
(********************)

(**************************************)
(** Payoff game -> negative cost game *)

Instance negativeCostInstance_of_payoffInstance
         N rty (T : finType)
         `(payoffInstance : @PayoffClass N rty T)
  : CostClass _ _ _ | 99 :=
  fun i f => - payoff i f.

(* 0 <= payoff -> cost <= 0 *)

Instance negativeCostAxiomInstance_of_payoffAxiomInstance
         N rty (T : finType)
         `(payoffAxiomInstance : PayoffAxiomClass N rty T) :
  NegativeCostAxiomClass (negativeCostInstance_of_payoffInstance _) | 99.
Proof.
  move=> i f. rewrite /cost_fun /negativeCostInstance_of_payoffInstance.
  rewrite /PayoffAxiomClass in payoffAxiomInstance.
    by rewrite oppr_le0.
Qed.

Instance negative_cost_game_of_payoff_game
         N rty (T : finType)
         `(_ : payoff_game T N rty)
  : negative_cost_game _ | 99 :=
  Build_negative_cost_game
    (negativeCostAxiomInstance_of_payoffAxiomInstance
       N rty T payoffAxiomClass). (* payoffAxiomClass is an auto-generated name *)

(******************************************)
(** End payoff game -> negative cost game *)

Local Open Scope ring_scope.

(** An arithmetic fact that should probably be moved elsewhere, and
    also generalized. *)
Lemma ler_mull (rty : realFieldType) (x y z : rty) (Hgt0 : 0 < z) :
  x <= y -> z * x <= z * y.
Proof.
  move=> H; rewrite -ler_pdivr_mull=> //; rewrite mulrA.
  rewrite [z^(-1) * _]mulrC divff=> //; first by rewrite mul1r.
  apply/eqP=> H2; rewrite H2 in Hgt0.
  by move: (ltr0_neq0 Hgt0); move/eqP.
Qed.

(** The iff version of this was causing the apply tactic to hang
    in the gen_smooth proof for the location residual game. *)
Lemma ler_mull2 (rty : realFieldType) (x y z : rty) (Hgt0 : 0 < z) :
  z * x <= z * y -> x <= y.
Proof.
   move=> H. rewrite -ler_pdivr_mull in H=> //. rewrite mulrA in H.
  rewrite [z^(-1) * _]mulrC divff in H=> //. rewrite mul1r in H.
  apply H.
  apply/eqP=> H2; rewrite H2 in Hgt0.
  by move: (ltr0_neq0 Hgt0); move/eqP.
Qed.

(** A state is a finite function from player indices to strategies. *)
Definition state N T := ({ffun 'I_N -> T})%type.

Section payoffGameDefs.
  Context {T} {N} `(gameAxiomClassA : payoff_game T N)
          `(gameAxiomClassB : payoff_game T N).
  Definition Payoff (t : state N T) : rty := \sum_i (payoff i t).
End payoffGameDefs.

(** All equilibrium notions are parameterized by a [moves] relation
    (via the typeclass [Moveable T]). *)
Section gameDefs.
  Context {T} {N} `(gameAxiomClassA : game T N) `(gameAxiomClassB : game T N).

  (** We assume there's at least one strategy vector. *)
  Variable t0 : state N T.

  (** [t] is a Pure Nash Equilibrium (PNE) if no player is better off
      by moving to another strategy. *)
  Definition PNE (t : state N T) : Prop :=
    forall (i : 'I_N) (t' : state N T),
      cost i t <= cost i t'.

  (** PNE is decidable. *)
  Definition PNEb (t : state N T) : bool :=
    [forall i : 'I_N,
       [forall t' : state N T, (cost i t <= cost i t')]].

  Lemma PNE_PNEb t : PNE t <-> PNEb t.
  Proof.
    split.
    { move=> H1; apply/forallP=> x //.
      by apply/forallP=> x0; apply: H1.
    }
    by move/forallP=> H1 x t'; apply: (forallP (H1 x)).
  Qed.

  Lemma PNEP t : reflect (PNE t) (PNEb t).
  Proof.
    move: (PNE_PNEb t).
    case H1: (PNEb t).
    { by move=> H2; constructor; rewrite H2.
    }
    move=> H2; constructor=> H3.
    suff: false by [].
    by rewrite -H2.
  Qed.

  (** The social Cost of a state is the sum of all players' costs. *)
  Definition Cost (t : state N T) : rty := \sum_i (cost i t).

  (** A state is optimal if its social cost can't be improved. *)
  Definition optimal : pred (state N T) :=
    fun t => [forall t0, Cost t <= Cost t0].

  (** The Price of Anarchy for game [T] is the ratio of WORST
      equilibrium social cost to optimal social cost. We want the
      ratio to be as close to 1 as possible. *)
  Definition POA : rty :=
    Cost (arg_max PNEb Cost t0) / Cost (arg_min optimal Cost t0).

  (** The Price of Stability for game [T] is the ratio of BEST
      equilibrium social cost to optimal social cost. We want the
      ratio to be as close to 1 as possible. *)
  Definition POS : rty :=
    Cost (arg_min PNEb Cost t0) / Cost (arg_min optimal Cost t0).

  Lemma POS_le_POA (H1 : PNEb t0) (Hcost : forall t, Cost t > 0) : POS <= POA.
  Proof.
    rewrite /POS /POA.
    move: (min_le_max Cost H1); rewrite /min /max=> H2.
    rewrite ler_pdivr_mulr=> //.
    move: H2; move: (Cost _)=> x; move: (Cost _)=> y.
    have Hx: Cost (arg_min optimal Cost t0) != 0.
    { move: (Hcost (arg_min optimal Cost t0)); rewrite ltr_def.
      by case/andP=> H2 H3. }
    move: Hx; move: (Cost _)=> z Hx H2.
    have H3: (z = z / 1) by rewrite (GRing.divr1 z).
    rewrite {2}H3 mulf_div GRing.mulr1 -GRing.mulrA GRing.divff=> //.
    by rewrite GRing.mulr1.
  Qed.

  (** The expected cost (to player [i]) of a particular distribution
      over configurations.  Note that the distribution [d] need not
      be a product distribution -- in order to define Coarse
      Correlated Equilibria (below), we allow player distributions to
      be correlated with one another. *)
  Definition expectedCost
             (i : 'I_N)
             (d : dist [finType of state N T] rty) :=
    expectedValue d (cost i).

  Definition ExpectedCost (d : dist [finType of state N T] rty) :=
    \sum_(i : 'I_N) expectedCost i d.

  Lemma ExpectedCost_linear d :
    ExpectedCost d
    = expectedValue d (fun v => \sum_(i : 'I_N) (cost i v)).
  Proof.
    rewrite /ExpectedCost /expectedCost /expectedValue.
    by rewrite -exchange_big=> /=; apply/congr_big=> //= i _; rewrite mulr_sumr.
  Qed.

  Definition expectedCondCost
             (i : 'I_N)
             (d : dist [finType of state N T] rty)
             (t_i : T) :=
    expectedCondValue
      d
      (fun t : state N T => cost i t)
      [pred tx : state N T | tx i == t_i].

  Definition upd (i : 'I_N) :=
    [fun t t' : (T ^ N)%type =>
       finfun (fun j => if i == j then t' j else t j)].

  (** This second version of update takes a value of type [T] rather
      than a complete state as its second parameter. *)
  Definition upd1 (i : 'I_N) :=
    [fun t : (T ^ N)%type =>
       [fun t_i' : T =>
          finfun (fun j => if i == j then t_i' else t j)]].

  Lemma upd1_upd i (t t' : T^N) : upd1 i t (t' i) = upd i t t'.
  Proof.
    rewrite /upd1 /upd /=; apply/ffunP => x; rewrite 2!ffunE.
    case Heq: (i == x) => //.
    by move: (eqP Heq) => ->.
  Qed.

  (** The expected cost of an i-unilateral deviation to strategy [t'] *)
  Definition expectedUnilateralCost
             (i : 'I_N)
             (d : dist [finType of state N T] rty)
             (t' : state N T) :=
    expectedValue d (fun t : state N T => cost i (upd i t t')).

  Lemma expectedUnilateralCost_linear d t' :
    \sum_(i < N) expectedUnilateralCost i d t'
    = expectedValue d (fun t : state N T =>
                         \sum_(i : 'I_N) cost i (upd i t t')).
  Proof.
    rewrite /expectedUnilateralCost /expectedValue.
    by rewrite -exchange_big=> /=; apply/congr_big=> //= i _; rewrite mulr_sumr.
  Qed.

  (** The expected cost of an i-unilateral deviation to strategy [t' i],
      conditioned on current i-strategy equal [t_i]. *)
  Definition expectedUnilateralCondCost
             (i : 'I_N)
             (d : dist [finType of state N T] rty)
             (t_i t_i' : T) :=
    expectedCondValue
      d
      (fun t : state N T => cost i (upd1 i t t_i'))
      [pred tx : state N T | tx i == t_i].

  (** \epsilon-Approximate Coarse Correlated Equilibria
      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      The expected cost of a unilateral deviation to state (t' i) is greater
      or equal to (1 + \epsilon) times the expected cost of distribution [d].

      NOTES:
      - [t'] must be a valid move for [i] from any state in the
        support of [d].

      - For this definition to make sense in context, the cost function
        for game [T] should be normalized to range [0,1].
   *)
  Definition eCCE (epsilon : rty) (d : dist [finType of state N T] rty) : Prop :=
    forall (i : 'I_N) (t' : state N T),
      expectedCost i d <= (1 + epsilon) * expectedUnilateralCost i d t'.

  Lemma eCCE_elim
    (epsilon : rty) (d : dist [finType of state N T] rty) (H1 : eCCE epsilon d) :
    forall (i : 'I_N) (t' : state N T),
    expectedCost i d <= (1 + epsilon) * expectedUnilateralCost i d t'.
  Proof.
    rewrite /eCCE in H1 => i t'.
    by move: (H1 i t').
  Qed.

  Definition eCCE2 (epsilon : rty) (d : dist [finType of state N T] rty) : Prop :=
    forall (i : 'I_N) (t' : state N T),
      expectedCost i d <= expectedUnilateralCost i d t' + epsilon.

  Lemma eCCE2_elim
    (epsilon : rty) (d : dist [finType of state N T] rty) (H1 : eCCE2 epsilon d) :
    forall (i : 'I_N) (t' : state N T),
    expectedCost i d <= expectedUnilateralCost i d t' + epsilon.
  Proof.
    rewrite /eCCE2 in H1 => i t'.
    by move: (H1 i t').
  Qed.

  (* FixMe: Consider a better place to put this *)
  Lemma costmax_UnilaterCost_sup i (d : dist [finType of state N T] rty) t:
    expectedUnilateralCost i d t <= costmax_fun.
  Proof.
    rewrite /expectedUnilateralCost /expectedValue /expectedCondValue.
    have H: \sum_t1 d t1 * (cost) i ((upd i t1) t) <= \sum_t costmax_fun * d t.
    {
      apply ler_sum => t' _. rewrite [costmax_fun * _] mulrC.
      apply ler_pmul. apply dist_positive. apply costAxiomClass.
      apply lerr. apply costMaxAxiomClass.
    }
    apply: ler_trans. apply H.
    have H' : \sum_t1 costmax_fun * d t1 = costmax_fun.
    {
      rewrite -big_distrr //=.
      rewrite dist_normalized mulr1 //.
    }
    rewrite H'. apply lerr.
  Qed.

  Lemma eCCE2_of_eCCE (d : dist [finType of state N T] rty) (eps1 eps2 : rty)
    (pf : 0 <= eps1) (eps2_value : eps2 = eps1 * costmax_fun):
    eCCE eps1 d -> eCCE2 eps2 d.
  Proof.
    move => H i t'. rewrite /eCCE in H. rewrite eps2_value.
    apply: ler_trans; first by apply (H i t').
    rewrite mulrDl mul1r ler_add //= ler_pmul //=.
    rewrite /expectedUnilateralCost.
    rewrite /expectedValue /expectedCondValue.
    apply big_ind; first by apply lerr. apply Num.Internals.addr_ge0.
    move => i' _. rewrite mulr_ge0 //=. apply dist_positive.
    apply costmax_UnilaterCost_sup.
  Qed.

  Lemma eCCE_of_eCCE2 (d : dist [finType of state N T] rty) (eps1 eps2 : rty)
    (pf : 0 <= eps2)
    (cost_min : rty)
    (cost_min_pos : 0 < cost_min) (cost_min_is_min : forall i s, cost_min <= (cost) i s)
    (eps1_value : eps1 = eps2 /cost_min):
    eCCE2 eps2 d -> eCCE eps1 d.
  Proof.
    move => H i t'. rewrite /eCCE2 in H.
    apply: ler_trans; first by apply (H i t').
    rewrite mulrDl mul1r ler_add //=. rewrite eps1_value.
    rewrite -mulrA. rewrite -[eps2] mulr1.
    rewrite ler_pmul //. rewrite ler01 //.
    rewrite mulr1 lerr //.
    move: (@ler_pmulr rty (cost_min^-1 * expectedUnilateralCost i d t')
            cost_min cost_min_pos) => H0.
    rewrite -H0 mulrA GRing.mulfV. rewrite mul1r.
    rewrite /expectedUnilateralCost /expectedValue /expectedCondValue.
    have H': \sum_t cost_min * d t <= \sum_t1 d t1 * (cost) i ((upd i t1) t').
    {
      apply ler_sum => t _. rewrite [cost_min * _] mulrC.
      rewrite ler_pmul //=. apply dist_positive. apply ltrW. by [].
    }
    apply: ler_trans; last first. apply H'.
    have H'' : \sum_t1 cost_min * d t1 = cost_min.
    {
      rewrite -big_distrr //=.
      rewrite dist_normalized mulr1 //.
    }
    rewrite H''. apply lerr.
    move: (@ltr_def rty 0 cost_min) => H1.
    rewrite H1 in cost_min_pos. move/andP: cost_min_pos => H2.
    inversion H2; by [].
  Qed.

  Definition eCCEb (epsilon : rty) (d : dist [finType of state N T] rty) : bool :=
    [forall i : 'I_N,
       [forall t' : state N T,
           (expectedCost i d <= (1 + epsilon) * expectedUnilateralCost i d t')]].

  Lemma eCCE_eCCEb eps d : eCCE eps d <-> eCCEb eps d.
  Proof.
    split; first by move=> H1; apply/forallP=> x; apply/forallP=> y.
    by move/forallP=> H1 x y; move: (forallP (H1 x)); move/(_ y).
  Qed.

  Lemma eCCEP eps d : reflect (eCCE eps d) (eCCEb eps d).
  Proof.
    move: (eCCE_eCCEb eps d); case H1: (eCCEb eps d).
    by move=> H2; constructor; rewrite H2.
    by move=> H2; constructor; rewrite H2.
  Qed.

  (** Coarse Correlated Equilibria
      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      The expected cost of a unilateral deviation to state (t' i) is greater
      or equal to the expected cost of distribution [d].

      NOTES:
      - [t'] must be a valid move for [i] from any state in the
        support of [d].
   *)
  Definition CCE (d : dist [finType of state N T] rty) : Prop := eCCE 0 d.

  Lemma CCE_elim (d : dist [finType of state N T] rty) (H1 : CCE d) :
    forall (i : 'I_N) (t' : state N T),
    expectedCost i d <= expectedUnilateralCost i d t'.
  Proof.
    rewrite /CCE /eCCE in H1 => i t'.
    by move: (H1 i t'); rewrite addr0 mul1r.
  Qed.

  Definition CCEb (d : dist [finType of state N T] rty) : bool := eCCEb 0 d.

  Lemma CCE_CCEb d : CCE d <-> CCEb d.
  Proof. apply: eCCE_eCCEb. Qed.

  Lemma CCEP d : reflect (CCE d) (CCEb d).
  Proof. apply: eCCEP. Qed.

  (** \epsilon-Approximate Correlated Equilibria
      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      The expected cost of a unilateral deviation to state (t' i),
      conditioned on current strategy (t i), is no greater than
       \epsilon plus the expected cost of distribution [d].

      NOTES:
      - [t' i] must be a valid move for [i] from [t i].
   *)
  Definition eCE (epsilon : rty) (d : dist [finType of state N T] rty) : Prop :=
    forall (i : 'I_N) (t_i t_i' : T),
      expectedCondCost i d t_i <= expectedUnilateralCondCost i d t_i t_i' + epsilon.

  Definition eCEb (epsilon : rty) (d : dist [finType of state N T] rty) : bool :=
    [forall i : 'I_N,
      [forall t_i : T,
        [forall t_i' : T,
          expectedCondCost i d t_i <= expectedUnilateralCondCost i d t_i t_i' + epsilon]]].

  Lemma eCE_eCEb eps d : eCE eps d <-> eCEb eps d.
  Proof.
    split.
    { move=> H1; apply/forallP=> x; apply/forallP=> y; apply/forallP=> z; apply/implyP=> H2.
      by move: (H1 x y z) => H3; move: (H2 H3). }
    move => H1 x y z; move: (forallP H1).
    by move/(_ x)/forallP/(_ y)/forallP/(_ z).
  Qed.

  Lemma eCEP eps d : reflect (eCE eps d) (eCEb eps d).
  Proof.
    move: (eCE_eCEb eps d); case H1: (eCEb eps d).
    by move=> H2; constructor; rewrite H2.
    by move=> H2; constructor; rewrite H2.
  Qed.

  Definition CE (d : dist [finType of state N T] rty) : Prop := eCE 0 d.

  Definition CEb (d : dist [finType of state N T] rty) : bool := eCEb 0 d.

  Lemma CE_CEb d : CE d <-> CEb d.
  Proof. apply: eCE_eCEb. Qed.

  Lemma CEP d : reflect (CE d) (CEb d).
  Proof. apply: eCEP. Qed.

  Lemma marginal_unfold (F : {ffun 'I_N -> T} -> rty) i :
    let P t (p : {ffun 'I_N -> T}) := p i == t in
    \sum_(p : [finType of (T * {ffun 'I_N -> T})] | P p.1 p.2) (F p.2) =
    \sum_(p : {ffun 'I_N -> T}) (F p).
  Proof.
    move => P.
    set (G (x : T) y := F y).
    have ->:
      \sum_(p | P p.1 p.2) F p.2 =
      \sum_(p | predT p.1 && P p.1 p.2) G p.1 p.2 by apply: eq_big.
    rewrite -pair_big_dep /= /G /P.
    have ->:
         \sum_i0 \sum_(j : {ffun 'I_N -> T} | j i == i0) F j =
    \sum_i0 \sum_(j : {ffun 'I_N -> T} | predT j && (j i == i0)) F j.
    { by apply: eq_big. }
    rewrite -partition_big //.
  Qed.

  Lemma sum1_sum (f : state N T -> rty) i :
    \sum_(ti : T) \sum_(t : state N T | [pred tx | tx i == ti] t) f t =
    \sum_t f t.
  Proof. by rewrite -(marginal_unfold f i) pair_big_dep //. Qed.

(* (** Mixed Nash Equilibria *)
(*       ~~~~~~~~~~~~~~~~~~~~~ *)
(*       The expected cost of a unilateral deviation to state (t' i) is greater *)
(*       or equal to the expected cost of distribution [d].  *)

(*       NOTES:  *)
(*       - [d] must be a product distribution, of the form  *)
(*         [d_0 \times d_1 \times ... \times d_{#players-1}]. *)

(*       - [t'] must be a valid move for [i] from any state in the  *)
(*         support of [d]. *)
   *)
  Definition MNE (f : {ffun 'I_N -> dist T rty}) : Prop :=
    CE (prod_dist f).

  Definition MNEb (f : {ffun 'I_N -> dist T rty}) : bool :=
    CEb (prod_dist f).

  Lemma MNE_MNEb d : MNE d <-> MNEb d.
  Proof. by apply: CE_CEb. Qed.

  Lemma MNEP d : reflect (MNE d) (MNEb d).
  Proof. by apply: CEP. Qed.
End gameDefs.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Definitions from Section 3.5.2 *)
(* Brian Milnes 2016 *)

(* Questions:
   Do I need context substitution?  Yes, two forms.
*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax.

(* Substituting a type into a type for a type variable. *)

Fixpoint subst_t_tv_t  (tau : Tau) (alpha : var) (t : Tau) {struct t} : Tau :=
  match t with
    | btvar i      => btvar i
    | ftvar beta   => If (alpha = beta) then tau else (ftvar beta)
    | cint         => cint
    | cross t0 t1  => cross (subst_t_tv_t tau alpha t0) (subst_t_tv_t tau alpha t1)
    | arrow t0 t1  => arrow (subst_t_tv_t tau alpha t0) (subst_t_tv_t tau alpha t1)
    | ptype t0     => ptype (subst_t_tv_t tau alpha t0)
    | utype k t0   => utype k (subst_t_tv_t tau alpha t0)
    | etype p k t0 => etype p k (subst_t_tv_t tau alpha t0)
end.

Hint Resolve subst_t_tv_t.

Notation "[ t 'ttvt>' alpha ] tm" := (subst_t_tv_t t alpha tm) (at level 68) : cyclone_scope.

(* Substituting a type variable into a term. *)

(* This is identity but I fill it out in the hopes it affects inversion. *)
Function subst_t_tv_tm_v (tau : Tau) (alpha : var) (v : V) {struct v} : V :=
  match v with
    | fevar i => fevar i
    | bevar i => bevar i
  end.

Hint Resolve subst_t_tv_tm_v.

Fixpoint subst_t_tv_tm_e (tau : Tau) (alpha : var) (e : E) {struct e} : E :=
 match e with
   | v_e v         => v_e (subst_t_tv_tm_v tau alpha v)
   | i_e i         => i_e i
   | p_e x p       => p_e x p
   | f_e f         =>        (f_e (subst_t_tv_tm_f  tau alpha f))
   | amp e'        => amp    (subst_t_tv_tm_e     tau alpha e')
   | star e'       => star   (subst_t_tv_tm_e     tau alpha e')
   | cpair e1 e2   => cpair  (subst_t_tv_tm_e     tau alpha e1) (subst_t_tv_tm_e tau alpha e2)
   | dot e' i      => dot    (subst_t_tv_tm_e     tau alpha e') i
   | assign e1 e2  => assign (subst_t_tv_tm_e     tau alpha e1) (subst_t_tv_tm_e tau alpha e2)
   | appl  e1 e2   => appl   (subst_t_tv_tm_e     tau alpha e1) (subst_t_tv_tm_e tau alpha e2)
   | call s        => call   (subst_t_tv_tm_st    tau alpha s)
   | inst e' t     => inst   (subst_t_tv_tm_e     tau alpha e') (subst_t_tv_t tau alpha t)
   | pack t e' t'  => pack   (subst_t_tv_t tau alpha t) (subst_t_tv_tm_e tau alpha e')
                             (subst_t_tv_t tau alpha t')
 end
with subst_t_tv_tm_st (tau : Tau) (alpha : var) (s: St) {struct s} : St :=
  match s with
    | e_s e         => e_s      (subst_t_tv_tm_e tau alpha e)
    | retn e        => retn     (subst_t_tv_tm_e tau alpha e)
    | seq s1 s2     => seq      (subst_t_tv_tm_st tau alpha s1) (subst_t_tv_tm_st tau alpha s2)
    | if_s e s1 s2  => if_s     (subst_t_tv_tm_e tau alpha e)
                                (subst_t_tv_tm_st tau alpha s1) (subst_t_tv_tm_st tau alpha s2)
    | while e s     => while    (subst_t_tv_tm_e tau alpha e)   (subst_t_tv_tm_st tau alpha s)
    | letx e s      => letx     (subst_t_tv_tm_e tau alpha e)   (subst_t_tv_tm_st tau alpha s)
    | open     e s  => open     (subst_t_tv_tm_e tau alpha e)   (subst_t_tv_tm_st tau alpha s)
    | openstar e s  => openstar (subst_t_tv_tm_e tau alpha e)   (subst_t_tv_tm_st tau alpha s)
end
with subst_t_tv_tm_f (tau : Tau) (alpha : var) (f : F) {struct f} : F  :=
 match f with
   | (dfun tau1 tau2 s) =>
     (dfun (subst_t_tv_t tau alpha tau1) (subst_t_tv_t tau alpha tau2) (subst_t_tv_tm_st tau alpha s))
   | ufun k f => (ufun k (subst_t_tv_tm_f tau alpha f))
end.

Hint Resolve subst_t_tv_tm_e.
Hint Resolve subst_t_tv_tm_st.
Hint Resolve subst_t_tv_tm_f.

Notation "[ t 'ttvtm_v>'  alpha ] tm" := (subst_t_tv_tm_v  t alpha tm) (at level 68) : cyclone_scope.
Notation "[ t 'ttvtm_e>'  alpha ] tm" := (subst_t_tv_tm_e  t alpha tm) (at level 68) : cyclone_scope.
Notation "[ t 'ttvtm_st>' alpha ] tm" := (subst_t_tv_tm_st t alpha tm) (at level 68) : cyclone_scope.
Notation "[ t 'ttvtm_f>'  alpha ] tm" := (subst_t_tv_tm_f  t alpha tm) (at level 68) : cyclone_scope.

Function subst_t_tv_tm (tau : Tau) (alpha : var) (t: Term) {struct t} : Term :=
  match t with
    | term_st s => term_st (subst_t_tv_tm_st tau alpha s)
    | term_e  e => term_e  (subst_t_tv_tm_e tau alpha e)
    | term_f  f => term_f  (subst_t_tv_tm_f tau alpha f)
  end.

Hint Resolve subst_t_tv_tm.

Notation "[ t 'ttvtm>' alpha ] tm" := (subst_t_tv_tm t alpha tm) (at level 68) : cyclone_scope.
(* Subtituting an expression into a term for a term variable. *)

(* Cyclone semantics are odd in that &xp is used as a value and
 explicitly defined syntactically. So to put an expression into
 a term for a variable, it can be substituted in two places:
 v_e (fevar x) and p_e x p in our abstract syntax.

 v_e (fevar x) can be replaced with a new expression, e, as v_e e.

 But p_e x p can not and so must be translated to (e.i0).i1... where
 p = i0 i1 ...
 and for each u we must insert a pack.

 It's not worth finishing this unless I actually need it.
 *)

(* However the more limited substitution of variables for variables works. *)

Function subst_v_v_tm_v (x y : var) (v : V) : V :=
  match v with
   | (bevar y)   => (bevar y)
   | (fevar y)   => If (x = y) then (fevar x) else (fevar y)
end.

Fixpoint subst_v_v_tm_e (x y : var) (e : E) {struct e} : E :=
 match e with
   | v_e v         => v_e (subst_v_v_tm_v x y v)
   | i_e i         => e
   | p_e v p       => p_e (subst_v_v_tm_v x y v) p
   | f_e f         =>        (f_e (subst_v_v_tm_f x y f))
   | amp e'        => amp    (subst_v_v_tm_e   x y e')
   | star e'       => star   (subst_v_v_tm_e   x y e')
   | cpair e1 e2   => cpair  (subst_v_v_tm_e   x y e1) (subst_v_v_tm_e x y e2)
   | dot e' i      => dot    (subst_v_v_tm_e   x y e') i
   | assign e1 e2  => assign (subst_v_v_tm_e   x y e1) (subst_v_v_tm_e x y e2)
   | appl   e1 e2  => appl   (subst_v_v_tm_e   x y e1) (subst_v_v_tm_e x y e2)
   | call s        => call   (subst_v_v_tm_st  x y s)
   | inst e' t     => inst   (subst_v_v_tm_e   x y e') t
   | pack t e' t'  => pack   t (subst_v_v_tm_e x y e') t'
 end
with subst_v_v_tm_st (x y : var ) (s: St) {struct s} : St :=
  match s with
    | e_s e         => e_s      (subst_v_v_tm_e x y e)
    | retn e        => retn     (subst_v_v_tm_e x y e)
    | seq s1 s2     => seq      (subst_v_v_tm_st x y s1) (subst_v_v_tm_st x y s2)
    | if_s e s1 s2  => if_s     (subst_v_v_tm_e x y e)
                                (subst_v_v_tm_st x y s1) (subst_v_v_tm_st x y s2)
    | while e s     => while    (subst_v_v_tm_e x y e)   (subst_v_v_tm_st x y s)
    | letx e s      => letx     (subst_v_v_tm_e x y e)   (subst_v_v_tm_st x y s)
    | open     e s  => open     (subst_v_v_tm_e x y e)   (subst_v_v_tm_st x y s)
    | openstar e s  => openstar (subst_v_v_tm_e x y e)   (subst_v_v_tm_st x y s)
end
with subst_v_v_tm_f (x y : var) (f : F) {struct f} : F  :=
 match f with
   | (dfun tau1 tau2 s) => (dfun tau1 tau2 (subst_v_v_tm_st x y s))
   | ufun k f => (ufun k (subst_v_v_tm_f x y f))
 end.

Notation "[ x 'vtm_v>' y ] tm" := (subst_v_v_tm_v x y tm) (at level 68) : cyclone_scope.
Notation "[ x 'vtm_e>' y ] tm" := (subst_v_v_tm_e x y tm) (at level 68) : cyclone_scope.
Notation "[ x 'vtm_st>' y ] tm" := (subst_v_v_tm_st x y tm) (at level 68) : cyclone_scope.
Notation "[ x 'vtm_f>' y ] tm" := (subst_v_v_tm_f x y tm) (at level 68) : cyclone_scope.

Function subst_v_v_tm (x y : var) (t : Term) {struct t} :=
  match t with
    | term_st s => term_st (subst_v_v_tm_st x y s)
    | term_e  e => term_e  (subst_v_v_tm_e  x y e)
    | term_f  f => term_f  (subst_v_v_tm_f  x y f)
end.

Notation "[ x 'vtm>' y ] tm" := (subst_v_v_tm x y tm) (at level 68) : cyclone_scope.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C I H1 H2 Aprime Cprime : Universe, ((wd_ H1 B /\ (wd_ H2 B /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Cprime /\ (wd_ B Aprime /\ (wd_ I H2 /\ (wd_ I H1 /\ (wd_ I B /\ (col_ B H1 A /\ (col_ B H2 C /\ (col_ C B Cprime /\ (col_ A B Aprime /\ col_ B H1 Aprime)))))))))))))))) -> col_ B Cprime H2)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.