Require Import
        Coq.Logic.Eqdep_dec
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.Compose
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Formats.WordOpt.
Require Import
        Coq.Vectors.Vector
        Coq.omega.Omega
        Bedrock.Word.

Section AlignWord.
  Context {len : nat}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Variable addD_addD_plus :
    forall cd n m, addD (addD cd n) m = addD cd (n + m).

  Lemma If_Opt_Then_Else_DecodeBindOpt {A ResultT ResultT'}
    : forall (a_opt : option A)
             (t : A -> option (ResultT * B * CacheDecode))
             (e : option (ResultT * B * CacheDecode))
             (k : _ -> _ -> _ -> option (ResultT' * B * CacheDecode)),
      (`(w, b', cd') <- Ifopt a_opt as a Then t a Else e;
         k w b' cd') =
      (Ifopt a_opt as a Then
                        (`(w, b', cd') <- t a; k w b' cd')
                        Else (`(w, b', cd') <- e; k w b' cd')).
  Proof.
    destruct a_opt; simpl; intros; reflexivity.
  Qed.

  Fixpoint split1' (sz sz' : nat) : word (sz + sz') -> word sz :=
    match sz return word (sz + sz') -> word sz with
    | 0 => fun _ => WO
    | S n' => fun w => SW_word (word_split_hd w)
                               (split1' n' sz' (word_split_tl w))
    end.

  Fixpoint split2' (sz sz' : nat) : word (sz + sz') -> word sz' :=
    match sz return word (sz + sz') -> word sz' with
    | 0 => fun w => w
    | S n' => fun w => split2' n' sz' (word_split_tl w)
    end.

  Definition trans_S_comm : forall n m : nat, S (n + m) = n + S m.
  Proof.
    fix 1; destruct n.
    - intro; reflexivity.
    - simpl; intro; destruct (trans_S_comm n m); reflexivity.
  Defined.

  Lemma trans_plus_comm : forall n m, n + m = m + n.
  Proof.
    fix 1.
    destruct n.
    - fix 1.
      destruct m.
      + reflexivity.
      + simpl.
        destruct (trans_plus_comm0 m); reflexivity.
    - simpl; intro; rewrite (trans_plus_comm n m).
      apply trans_S_comm.
  Defined.

  Lemma wtl_eq_rect_S : forall sz sz' w eq_comm eq_comm',
      wtl (eq_rect (S sz) word w (S sz') eq_comm) =
      eq_rect sz word (wtl w) sz' eq_comm'.
  Proof.
    intros.
    destruct (shatter_word_S w) as (?, (w', H)); rewrite H in *; clear.
    revert w' eq_comm.
    rewrite eq_comm'; clear eq_comm'; intros.
    unfold eq_rect; simpl.
    revert w'.
    pattern eq_comm.
    apply K_dec_set; eauto; decide equality.
  Qed.

  Lemma wtl_eq_rect_comm : forall sz sz' w eq_comm eq_comm',
      wtl (eq_rect (S (sz + sz')) word w (S (sz' + sz)) eq_comm) =
      eq_rect (sz + sz') word (wtl w) (sz' + sz) eq_comm'.
  Proof.
    intros.
    eapply wtl_eq_rect_S.
  Qed.

  Lemma whd_eq_rect_comm : forall sz sz' w eq_comm,
      whd (eq_rect (S (sz + sz')) word w (S (sz' + sz)) eq_comm) =
      whd w.
  Proof.
    intros ? ?; rewrite trans_plus_comm; intros.
    destruct (shatter_word_S w) as (?, (w', H)); rewrite H in *; clear.
    unfold eq_rect; simpl.
    pattern eq_comm.
    apply K_dec_set; eauto; decide equality.
  Qed.

  Lemma eq_rect_WS : forall b sz sz' w e e',
      eq_rect (S sz) _ (WS b w) (S sz') e = WS b (eq_rect sz _ w sz' e').
  Proof.
    simpl; intros.
    revert e w.
    rewrite e'; intro; pattern e.
    apply K_dec_set; eauto; decide equality.
  Qed.

  Lemma eq_rect_split_tl
    : forall (sz sz' : nat) (x0 : bool) (w'' : word (sz' + sz)) (e : sz' + sz = sz + sz') (e1 : sz + sz' = sz' + sz),
      word_split_tl (WS x0 w'') =
      eq_rect (sz + sz') word (word_split_tl (WS x0 (eq_rect (sz' + sz) word w'' (sz + sz') e))) (sz' + sz) e1.
  Proof.
    induction sz; simpl.
    - intro; rewrite <- plus_n_O; intros.
      pattern e1.
      apply K_dec_set; eauto; try decide equality; clear e1.
      pattern e.
      apply K_dec_set; eauto; try decide equality; clear e.
    - intro; rewrite <- (trans_S_comm sz' sz); intros.
      intros; destruct (shatter_word_S w'') as (?, (w', H)); rewrite H in *; clear H.
      simpl.
      rewrite (IHsz sz' x w' (trans_plus_comm _ _) (trans_plus_comm _ _)); repeat f_equal.
      erewrite !eq_rect_WS; reflexivity.
  Qed.

  Lemma split1'_eq : forall sz sz' w,
      split1' sz sz' w = split2 sz' sz (eq_rect _ _ w _ (trans_plus_comm _ _)).
  Proof.
    induction sz; simpl; intros.
    - induction sz'; simpl.
      + shatter_word w; reflexivity.
      + destruct (shatter_word_S w) as (?, (w', H)); rewrite H in *; clear H.
        erewrite wtl_eq_rect_comm.
        eapply IHsz'.
    - intros; destruct (shatter_word_S w) as (?, (w', H)); rewrite H in *; clear H.
      simpl; rewrite IHsz; clear.
      generalize (eq_ind_r (fun n : nat => S n = sz' + S sz) (trans_S_comm sz' sz) (trans_plus_comm sz sz')).
      generalize (trans_plus_comm sz sz').
      fold (plus sz sz').
      revert x sz w'; induction sz'; simpl.
      + intros ? ?; rewrite <- (plus_n_O sz); simpl.
        intros.
        pattern e.
        apply K_dec_set; eauto; try decide equality.
        pattern e0.
        apply K_dec_set; eauto; try decide equality.
        unfold eq_rect; simpl.
        rewrite <- word_split_SW; reflexivity.
      + intros ? ?.
        rewrite <- !trans_S_comm.
        rewrite trans_plus_comm.
        intros; pattern e.
        apply K_dec_set; eauto; try decide equality; clear e.
        intros; destruct (shatter_word_S w') as (?, (w'', H)); rewrite H in *; clear H.
        rewrite (wtl_eq_rect_S _ _ _ e0 (trans_S_comm _ _)); simpl.
        assert (S (sz + sz') = sz' + S sz) by omega.
        replace (eq_rect (S (sz' + sz)) word (WS x0 w'') (sz' + S sz) (trans_S_comm sz' sz)) with
        (eq_rect (S (sz + sz')) word (WS x0 (eq_rect _ _ w'' _ (trans_plus_comm _ _))) (sz' + S sz) H).
        erewrite <- (IHsz' x0 sz _ (trans_plus_comm _ _)).
        repeat f_equal.
        { generalize (trans_plus_comm sz' sz); intros; clear.
          revert sz' x0 w'' e; induction sz; simpl.
          - intro; rewrite <- plus_n_O; intros.
            destruct e; reflexivity.
          - intro; rewrite <- (trans_S_comm sz' sz); intros.
            intros; destruct (shatter_word_S w'') as (?, (w', H)); rewrite H in *; clear H.
            simpl.
            rewrite (IHsz sz' x w' (trans_plus_comm _ _)); repeat f_equal.
            erewrite eq_rect_WS; eauto.
        }
        { eapply eq_rect_split_tl. }
        revert H; clear. revert w''; generalize (trans_S_comm sz' sz).
        rewrite (trans_plus_comm sz' sz); intros; simpl.
        destruct e; simpl.
        rewrite eq_rect_WS with (e' := eq_refl _); reflexivity.
  Qed.

  Lemma split2'_eq : forall sz sz' w,
      split2' sz sz' w = split1 sz' sz (eq_rect _ _ w _ (trans_plus_comm _ _)).
  Proof.
    induction sz; simpl; intros.
    - induction sz'; simpl.
      + shatter_word w; reflexivity.
      + destruct (shatter_word_S w) as (?, (w', H)); rewrite H in *; clear H.
        rewrite whd_eq_rect_comm; simpl.
        erewrite wtl_eq_rect_comm.
        rewrite (IHsz' w') at 1; reflexivity.
    - intros; destruct (shatter_word_S w) as (?, (w', H)); rewrite H in *; clear H.
      simpl; rewrite IHsz; clear.
      generalize (eq_ind_r (fun n : nat => S n = sz' + S sz) (trans_S_comm sz' sz) (trans_plus_comm sz sz')).
      generalize (trans_plus_comm sz sz').
      fold (plus sz sz').
      revert x sz w'; induction sz'; simpl; eauto.
      intros.
      assert (sz + S sz' = sz' + S sz) by omega.
      rewrite eq_rect_WS with (e' := H); simpl.
      revert w' e0 H; rewrite e; intros.
      destruct (shatter_word_S w') as (?, (w'', H')); rewrite H' in *; clear H'; simpl.
      f_equal.
      assert (S (sz + sz') = sz' + S sz) by omega.
      replace (eq_rect (S (sz' + sz)) word (WS x0 w'') (sz' + S sz) H)
      with (eq_rect (S (sz + sz')) word (WS x0 (eq_rect _ _ w'' _ (trans_plus_comm _ _))) (sz' + S sz) H0)
        by (revert w'' H H0; clear;
            rewrite (trans_plus_comm sz' sz); intros; simpl;
            destruct H; simpl;
            erewrite eq_rect_WS with (e' := eq_refl _); reflexivity).
      rewrite <- IHsz' with (e := trans_plus_comm _ _);
        f_equal; simpl.
      eapply eq_rect_split_tl.
  Qed.

    Lemma CollapseWord {ResultT}
    : forall sz sz' (b : B)
             (cd : CacheDecode)
             (k : _ -> _ -> _ -> _ -> option (ResultT * B * CacheDecode)),
      (`(w, b', cd') <- decode_word (sz:=sz) b cd;
         `(w', b', cd') <- decode_word (sz:=sz') b' cd';
         k w w' b' cd') =
      (`(w , b', cd') <- decode_word (sz:=sz + sz') b cd;
         k (split1' sz sz' w)
           (split2' sz sz' w) b' cd').
  Proof.
    unfold decode_word; repeat setoid_rewrite If_Opt_Then_Else_DecodeBindOpt; simpl.
    induction sz; simpl; intros.
    - rewrite !If_Opt_Then_Else_DecodeBindOpt; simpl.
      rewrite addD_addD_plus; reflexivity.
    - destruct (dequeue_opt b) as [ [? ?] | ]; simpl; eauto.
      pose proof (IHsz sz' b1 (addD cd 1) (fun w => k (SW_word b0 w))).
      destruct (decode_word' sz b1) as [ [? ?] | ]; simpl in *.
      + rewrite !If_Opt_Then_Else_DecodeBindOpt;
          rewrite !If_Opt_Then_Else_DecodeBindOpt in H; simpl in *;
            rewrite !addD_addD_plus in H;
            rewrite !addD_addD_plus; simpl in *.
        rewrite H.
        destruct (decode_word' (sz + sz') b1) as [ [? ?] | ]; simpl; eauto.
        repeat f_equal; clear.
        * induction sz; simpl in *.
          induction sz'; simpl in *; try shatter_word w0; simpl; eauto.
          pose proof (shatter_word_S w0); destruct_ex; subst;
            simpl; eauto.
          pose proof (shatter_word_S w0); destruct_ex; subst;
            simpl; eauto.
        * induction sz; simpl in *.
          induction sz'; simpl in *; try shatter_word w0; simpl; eauto.
          pose proof (shatter_word_S w0); destruct_ex; subst;
            simpl; f_equal; eauto.
          pose proof (shatter_word_S w0); destruct_ex; subst;
            simpl; f_equal; eauto.
        * induction sz; simpl in *.
          induction sz'; simpl in *; try shatter_word w0; simpl; eauto.
          pose proof (shatter_word_S w0); destruct_ex; subst;
            simpl; f_equal; eauto.
          pose proof (shatter_word_S w0); destruct_ex; subst;
            simpl; f_equal; eauto.
      + destruct (decode_word' (sz + sz') b1) as [ [? ?] | ]; simpl in *; eauto.
        rewrite addD_addD_plus in H; simpl in *.
        rewrite H; repeat f_equal; clear.
        * induction sz; simpl in *.
          induction sz'; simpl in *; try shatter_word w; simpl; eauto.
          pose proof (shatter_word_S w); destruct_ex; subst;
            simpl; eauto.
          pose proof (shatter_word_S w); destruct_ex; subst;
            simpl; eauto.
        * induction sz; simpl in *.
          induction sz'; simpl in *; try shatter_word w; simpl; eauto.
          pose proof (shatter_word_S w); destruct_ex; subst;
            simpl; f_equal; eauto.
          pose proof (shatter_word_S w); destruct_ex; subst;
            simpl; f_equal; eauto.
        * induction sz; simpl in *.
          induction sz'; simpl in *; try shatter_word w; simpl; eauto.
          pose proof (shatter_word_S w); destruct_ex; subst;
            simpl; f_equal; eauto.
          pose proof (shatter_word_S w); destruct_ex; subst;
            simpl; f_equal; eauto.
  Qed.

  Lemma CollapseWord' {ResultT}
    : forall sz' sz (b : B)
             (cd : CacheDecode)
             (k : _ -> _ -> _ -> _ -> option (ResultT * B * CacheDecode)),
      (`(w, b', cd') <- decode_word (sz:=sz) b cd;
         `(w', b', cd') <- decode_word (sz:=sz') b' cd';
         k w w' b' cd') =
      (`(w , b', cd') <- decode_word (sz:=sz + sz') b cd;
         k (split2 sz' sz (eq_rect _ _ w _ (trans_plus_comm sz sz')))
           (split1 sz' sz (eq_rect _ _ w _ (trans_plus_comm sz sz'))) b' cd').
  Proof.
    intros; rewrite CollapseWord.
    destruct (decode_word b cd) as [ [ [? ?] ?] | ]; simpl.
    rewrite split2'_eq, split1'_eq; eauto.
    reflexivity.
  Qed.

  Lemma CollapseWord'' {ResultT}
    : forall sz' sz (b : B)
             (cd : CacheDecode)
             (k : _ -> _ -> _ -> _ -> option (ResultT * B * CacheDecode)),
      (`(w, b', cd') <- decode_word (sz:=sz) b cd;
         `(w', b', cd') <- decode_word (sz:=sz') b' cd';
         k w w' b' cd') =
      (`(w , b', cd') <- decode_word (sz:=sz' + sz) b cd;
         k (split2 sz' sz w)
           (split1 sz' sz w) b' cd').
  Proof.
    intros; rewrite CollapseWord'.
    replace (decode_word (sz:=sz' + sz) b cd) with (eq_rect _ (fun n => option (word n * B * _)) (decode_word (sz:=sz + sz') b cd) _ (trans_plus_comm _ _)).
    - destruct (decode_word b cd) as [ [ [? ?] ?] | ]; simpl.
      + revert w; rewrite (trans_plus_comm sz sz'); simpl; eauto.
      + rewrite (trans_plus_comm sz sz'); simpl; eauto.
    - rewrite (trans_plus_comm sz sz'); simpl; reflexivity.
  Qed.

  Variable addE_addE_plus :
    forall (ce : CacheFormat) (n m : nat), addE (addE ce n) m = addE ce (n + m).

  Lemma format_word_S {n}
    : forall (w : word (S n)) (bs : B),
      encode_word' (S n) w bs =
      encode_word' n (word_split_tl w) (enqueue_opt (word_split_hd w) bs).
  Proof.
    intros; pose proof (shatter_word_S w); destruct_ex; subst.
    simpl.
    clear; revert x; induction x0; simpl; intros.
    - simpl; reflexivity.
    - rewrite IHx0.
      reflexivity.
  Qed.

  Lemma word_split_hd_SW_word {n}
    : forall b (w : word n),
      word_split_hd (SW_word b w) = b.
  Proof.
    induction w; simpl; intros; eauto.
  Qed.

  Lemma word_split_tl_SW_word {n}
    : forall b (w : word n),
      word_split_tl (SW_word b w) = w.
  Proof.
    induction w; simpl; intros; eauto.
    f_equal; eauto.
  Qed.

  Lemma CollapseFormatWord
    : forall {sz sz'} (w : word sz) (w' : word sz') k ce,
      refine (((format_word w)
                ThenC (format_word w')
                ThenC k) ce)
             (((format_word (combine w' w))
                 ThenC k) ce).
  Proof.
    intros; unfold compose, format_word, Bind2.
    autorewrite with monad laws.
    simpl; rewrite addE_addE_plus.
    rewrite Plus.plus_comm; f_equiv; intro.
    rewrite mappend_assoc.
    destruct a; simpl.
    f_equiv; f_equiv; f_equiv.
    revert sz' w'; induction w; simpl; intros.
    - rewrite mempty_left.
      generalize mempty; clear; induction w'; intros.
      + reflexivity.
      + simpl; rewrite IHw'; reflexivity.
    - rewrite !enqueue_opt_format_word.
      replace (encode_word' (sz' + S n) (combine w' (WS b0 w)) mempty)
      with (encode_word' (S sz' + n) (combine (SW_word b0 w') w) mempty).
      + rewrite <- IHw.
        simpl; rewrite format_word_S.
        rewrite <- mappend_assoc, word_split_tl_SW_word, word_split_hd_SW_word.
        f_equal.
        clear; induction w'.
        * simpl; rewrite mempty_right; reflexivity.
        * simpl; rewrite !enqueue_opt_format_word.
          rewrite <- IHw'.
          rewrite mappend_assoc; reflexivity.
      + clear; revert n w; induction w'; intros.
        * simpl; eauto.
        * simpl; rewrite <- IHw'; reflexivity.
  Qed.

  Lemma format_SW_word {n}
    : forall b (w : word n) ce,
          refine (format_word (SW_word b w) ce)
                 (`(bs, ce') <- format_word w (addE ce 1);
                    ret (mappend (enqueue_opt b mempty) bs, ce')).
  Proof.
    induction n; simpl; intros.
    - shatter_word w; simpl.
      unfold format_word; simpl.
      autorewrite with monad laws.
      simpl; rewrite addE_addE_plus; rewrite mempty_right; reflexivity.
    - pose proof (shatter_word_S w); destruct_ex; subst.
      simpl.
      unfold format_word; simpl.
      autorewrite with monad laws; simpl.
      assert (computes_to (`(bs, ce') <- ret (encode_word' n x0 mempty, addE (addE ce 1) n);
                           ret (mappend (enqueue_opt b mempty) bs, ce'))
                          (mappend (enqueue_opt b mempty) (encode_word' n x0 mempty), addE (addE ce 1) n)) by repeat computes_to_econstructor.
      pose proof (IHn b x0 ce _ H).
      unfold format_word in H0.
      computes_to_inv; inversion H0; subst.
      rewrite H2.
      rewrite enqueue_mappend_opt.
      rewrite addE_addE_plus.
      reflexivity.
  Qed.

  Lemma If_Opt_Then_Else_DecodeBindOpt_swap {A C ResultT : Type}
    : forall (a_opt : option A)
             (b : B)
             (cd : CacheDecode)
             (dec_c : B -> CacheDecode -> option (C * B * CacheDecode))
             (k : A -> C -> B -> CacheDecode -> option (ResultT * B * CacheDecode)),
      (`(a, b', cd') <- Ifopt a_opt as a Then Some (a, b, cd) Else None;
         `(c, b', cd') <- dec_c b' cd';
         k a c b' cd') =
      (`(c, b', cd') <- dec_c b cd;
         `(a, b', cd') <- Ifopt a_opt as a Then Some (a, b', cd') Else None;
         k a c b' cd').
  Proof.
    destruct a_opt; simpl; intros; eauto.
    destruct (dec_c b cd) as [ [ [? ?] ? ] | ]; reflexivity.
  Qed.

  Lemma If_Then_Else_Bind {sz} {C ResultT : Type}
    : forall (w w' : word sz)
             (b : B)
             (cd : CacheDecode)
             (dec_c : B -> CacheDecode -> option (C * B * CacheDecode))
             (k : C -> B -> CacheDecode -> option (ResultT * B * CacheDecode)),
      (if weq w w' then
         `(c, b', cd') <- dec_c b cd;
           k c b' cd'
       else
         None) =
      (`(c, b', cd') <- dec_c b cd;
         if weq w w' then
           k c b' cd'
         else None).
  Proof.
    intros; find_if_inside; eauto.
    destruct (dec_c b cd) as [ [ [? ?] ? ] | ]; reflexivity.
  Qed.

End AlignWord.

Ltac collapse_word addD_addD_plus :=
  match goal with
  | |- DecodeBindOpt2
         (decode_word (sz := ?sz) ?b ?cd)
         (fun w b' cd' =>
            DecodeBindOpt2 (decode_word (sz := ?sz') b' cd')
                           (fun w' b' cd' => @?k w w' b' cd')) = _ =>
    etransitivity;
    [let H := fresh in
     pose proof (@CollapseWord'' _ _ _ _ _ addD_addD_plus _ sz' sz b cd k);
     apply H | ]
  end.


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

(***
Modulus : 2^450 - 2^225 - 1
Base: 22.5
***)

Definition curve : CurveParameters :=
  {|
    sz := 20%nat;
    base := 22 + 1/2;
    bitwidth := 32;
    s := 2^450;
    c := [(1, 1); (2^225, 1)];
    carry_chains := Some [[9; 19]; [10; 0; 11; 1; 12; 2; 13; 3; 14; 4; 15; 5; 16; 6; 17; 7; 18; 8; 19; 9]; [10; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

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

    mul_code := None;

    square_code := None;

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

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


Require
  MathClasses.theory.rings.
Require Import
  Coq.setoid_ring.Ring
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders MathClasses.orders.semirings.

Local Existing Instance pseudo_srorder_semiring.

Section nonneg_semiring_elements.
Context `{FullPseudoSemiRingOrder R} `{Apart R}.

Add Ring R : (rings.stdlib_semiring_theory R).

(* * Embedding of R⁺ into R *)
Global Instance NonNeg_inject: Cast (R⁺) R := @proj1_sig R _.

(* Operations *)
Global Program Instance NonNeg_plus: Plus (R⁺) := λ x y, (`x + `y)↾_.
Next Obligation.
  destruct x as [x Hx], y as [y Hy].
  now apply nonneg_plus_compat.
Qed.

Global Program Instance NonNeg_mult: Mult (R⁺) := λ x y, (`x * `y)↾_.
Next Obligation.
  destruct x as [x Hx], y as [y Hy].
  now apply nonneg_mult_compat.
Qed.

Global Program Instance NonNeg_0: Zero (R⁺) := 0↾_.

Global Program Instance NonNeg_1: One (R⁺) := 1↾_.
Next Obligation. apply le_0_1. Qed.

(* * Equalitity *)
Local Ltac unfold_equivs := unfold equiv, sig_equiv in *; simpl in *.

Instance: Proper ((=) ==> (=) ==> (=)) NonNeg_plus.
Proof.
  intros [x1 Ex1] [y1 Ey1] E1 [x2 Ex2] [y2 Ey2] E2. unfold_equivs.
  now rewrite E1, E2.
Qed.

Instance: Proper ((=) ==> (=) ==> (=)) NonNeg_mult.
Proof.
  intros [x1 Ex1] [y1 Ey1] E1 [x2 Ex2] [y2 Ey2] E2. unfold_equivs.
  now rewrite E1, E2.
Qed.

(* It is indeed a semiring *)
Global Instance: SemiRing (R⁺).
Proof. repeat (split; try apply _); repeat intro; unfold_equivs; ring. Qed.

Instance: Proper ((=) ==> (=)) NonNeg_inject.
Proof. now repeat intro. Qed.

Global Instance: SemiRing_Morphism NonNeg_inject.
Proof. repeat (split; try apply _); now repeat intro. Qed.

Global Instance: Injective NonNeg_inject.
Proof. split. trivial. apply _. Qed.

(* Misc *)
Global Instance NonNeg_trivial_apart `{!TrivialApart R} :  TrivialApart (R⁺).
Proof. intros x y. now rapply trivial_apart. Qed.

Global Instance NonNeg_equiv_dec `{∀ x y : R, Decision (x = y)} : ∀ x y: R⁺, Decision (x = y)
  := λ x y, decide_rel (=) ('x : R) ('y : R).

Global Instance NonNeg_apart_dec `{∀ x y : R, Decision (x ≶ y)} : ∀ x y: R⁺, Decision (x ≶ y)
  := λ x y, decide_rel (≶) ('x : R) ('y : R).

(* Order *)
Global Instance NonNeg_le: Le (R⁺) := λ x y, 'x ≤ 'y.
Global Instance NonNeg_lt: Lt (R⁺) := λ x y, 'x < 'y.

Global Instance: Proper ((=) ==> (=) ==> iff) NonNeg_le.
Proof. intros x1 y1 E1 x2 y2 E2. unfold NonNeg_le. now rewrite E1, E2. Qed.

Instance: PartialOrder NonNeg_le.
Proof. now apply (maps.projected_partial_order NonNeg_inject). Qed.

Global Instance: OrderEmbedding NonNeg_inject.
Proof. repeat (split; try apply _); intuition. Qed.

(*
Global Instance: TotalOrder NonNeg_le.
Proof maps.embed_totalorder NonNeg_le.

Global Instance: SemiRingOrder NonNeg_order.
Proof.
  split; try apply _.
   intros x y. split; intros E.
    apply (order_preserving NonNeg_inject) in E.
    apply srorder_plus in E. destruct E as [z [Ez1 Ez2]].
    exists (z↾Ez1); intuition.
   destruct E as [z [Ez1 Ez2]].
   rewrite Ez2.
   apply (order_reflecting NonNeg_inject).
   rewrite rings.preserves_plus.
   now apply nonneg_plus_compat_r.
  intros x E1 y E2.
  apply (order_reflecting NonNeg_inject).
  rewrite rings.preserves_0, rings.preserves_mult.
  now apply srorder_mult.
Qed.
*)
Global Program Instance NonNeg_le_dec `{∀ x y : R, Decision (x ≤ y)} : ∀ x y: R⁺, Decision (x ≤ y) := λ x y,
  match decide_rel (≤) ('x) ('y) with
  | left E => left _
  | right E => right _
  end.
End nonneg_semiring_elements.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Opaque NonNeg_le.
#[global]
Typeclasses Opaque NonNeg_lt.


Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Globalenvs.
Require Import Events.
Require Import Smallstep.
Require Import Asm.
Require Import Axioms.
Require Import Floats.

Require Import PeekTactics.

Definition int_eq: forall a b : int,
 {a = b} + {a <> b}.
Proof.
  destruct a. destruct b.
  destruct (zeq intval intval0).
  * subst. left. replace intrange with intrange0. auto. apply proof_irr.
  * right. intro HC. inv HC. congruence.
Defined.

Definition int_id_eq: forall a b : int + ident * int,
 {a = b} + {a <> b}.
Proof.
  decide equality. apply int_eq. decide equality. apply int_eq. decide equality.
Defined.

Definition opt_ireg_int_eq : forall a b : option (ireg * int),
 {a = b} + {a <> b}.
Proof.
  decide equality. decide equality.
  apply int_eq. decide equality.
Defined.

Definition float_eq : forall a b : Floats.float,
 {a = b} + {a <> b}.
Proof.
  apply Float.eq_dec.
Defined.

Definition float32_eq : forall a b : Floats.float32,
 {a = b} + {a <> b}.
Proof.
  apply Float32.eq_dec.
Defined.

Definition instr_eq: forall a b : instruction,
 {a = b} + {a <> b}.
Proof.
  repeat decide equality;
  try apply int_eq;
  try apply int_id_eq;
  try apply float_eq;
  try apply float32_eq;
  try apply opt_ireg_eq;
  apply Int64.eq_dec.
Defined.

Fixpoint prefix_match (a b : code) : option code :=
  match a,b with
    | fa::ra,fb::rb =>
      if instr_eq fa fb then prefix_match ra rb else None
    | nil,_ => Some b
    | _,nil => None
  end.

Fixpoint split_pat (a b : code) : option (code * code) :=
  match a,b with
    | fa::ra,fb::rb =>
      match prefix_match a b with
        | Some t => Some (nil,t)
        | None =>
          match split_pat (fa::ra) rb with
            | Some (h,t) => Some (fb::h,t)
            | None => None
          end
      end
    | nil,b => Some (nil,b)
    | _,nil => None
  end.

Theorem prefix_match_spec:
  forall c p c1,
    prefix_match p c = Some(c1) -> c = p ++ c1.
Proof.
  induction c.
  * simpl. intros.
    unfold prefix_match in H. destruct p.
    - inv H. auto.
    - inversion H.
  * intros. destruct p.
    - unfold prefix_match in H. inv H. auto.
    - destruct (instr_eq i a) eqn:Heq.
      + subst. simpl in H. destruct (instr_eq a a).
        apply (IHc p c1) in H. subst. auto.
        inv H.
      + unfold prefix_match in H. rewrite Heq in H.
        inversion H.
Qed.

Theorem prefix_match_neq:
  forall i j a b,
    i<>j -> prefix_match (i::a) (j::b) = None.
Proof.
  intros. unfold prefix_match. destruct instr_eq.
  * apply H in e. contradiction.
  * auto.
Qed.

Theorem split_pat_spec:
  forall c p c1 c2,
    split_pat p c = Some(c1,c2) -> c = c1 ++ p ++ c2.
Proof.
  induction c.
  * intros. simpl in *. destruct p; inv H; auto.
  * intros. destruct p.
    - unfold split_pat in H. inv H. auto.
    - unfold split_pat in H. fold split_pat in H. destruct (instr_eq i a ).
      (* instructions are equal *)
      + subst. simpl in H. destruct (instr_eq a a).
          (* a=a *)
          destruct (prefix_match p c) eqn:Hpre.
            (* Some *)
            inv H. simpl. apply prefix_match_spec in Hpre.
            f_equal. assumption.
            (* None *)
            destruct (split_pat (a::p) c) eqn:Hsplit_pat.
              (* Some *)
              destruct p0. inv H. apply (IHc (a::p) c0 c2) in Hsplit_pat.
              simpl. f_equal. assumption.
              (* None *)
              inv H.
          (* a<>a *)
          unfold not in n. destruct n. auto.
      (* instructions are different *)
      + apply (prefix_match_neq i a p c) in n.
        rewrite n in H. destruct c1.
          (* nil *)
          simpl. destruct (split_pat (i :: p) c). destruct p0. inv H. inv H.
          (* cons *)
          specialize IHc with (i::p) c1 c2.
          destruct (split_pat (i::p) c) eqn:Hsplit_pat.
            (* Some *)
            destruct p0. inversion H. subst. simpl in IHc.
            inv H. assert (H0: Some (c1,c2) = Some (c1,c2)).
              auto.
            apply IHc in H0. simpl. f_equal. assumption.
            (* None *)
            inversion H.
Qed.

Lemma split_pat_none:
  forall i c p,
    split_pat p (i::c) = None -> split_pat p c = None.
Proof.
  intros. unfold split_pat in H. fold split_pat in H.
  destruct p. inversion H.
  destruct (prefix_match (i0::p) (i::c)). inversion H.
  destruct (split_pat (i0::p) c). destruct p0. inversion H.
  auto.
Qed.


Require Import Kami.AllNotations FpuKami.Definitions FpuKami.Round String.
Require Export Nat.

Section FpuConvert2.
  Variable name: string.
  Variable expWidthMinus2 sigWidthMinus2: nat.
  Variable out_expWidthMinus2 out_sigWidthMinus2: nat.
  Local Notation "^ x" := (name ++ "#" ++ x)%string (at level 100).

  Open Scope kami_expr.
  Definition NF_from_FN :=
    MODULE {
        Rule ^"NF_from_FN" :=
          Call input: FN expWidthMinus2 sigWidthMinus2  <- "input" ();
          Call tiny: Bool <- "tiny" ();
          Call roundMode: Bit 3 <- "roundMode" ();
          LET inputNF <- getNF_from_FN #input;
          LET roundInput: RoundInput _ _ <-
                                             STRUCT {
                                               "in" ::= #inputNF;
                                               "afterRounding" ::= #tiny;
                                               "roundingMode" ::= #roundMode
                                             };

          LETA roundOutput <- (RoundNF_action out_expWidthMinus2 out_sigWidthMinus2
                                              (2 ^ (out_expWidthMinus2 + 1) - 2)%nat
                                              (2 ^ (out_expWidthMinus2 + 1) + (out_sigWidthMinus2 + 1) - 2)%nat
                                              (2 ^ (out_expWidthMinus2 + 1) - 1)%nat
                                              #roundInput);

          Call "exceptionFlags" (#roundOutput @% "exceptionFlags": _) ;
          Call "outputFN" (((#roundOutput @% "out")): _);
        Retv
      }.
  Close Scope kami_expr.

End FpuConvert2.


(**

Instantiate the hypotheses of InitialHSS with Lam for HSET.

Written by: Anders Mörtberg, 2016

*)

Require Import UniMath.Foundations.PartD.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.PointedFunctors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.SubstitutionSystems.BinSumOfSignatures.
Require Import UniMath.SubstitutionSystems.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.LamSignature.
Require Import UniMath.SubstitutionSystems.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.MonadsFromSubstitutionSystems.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.

Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.
Require Import UniMath.CategoryTheory.Chains.All.

Section LamHSET.

Let Lam_S : Signature HSET _ _ :=
  Lam_Sig HSET TerminalHSET BinCoproductsHSET BinProductsHSET.

Local Notation "'EndHSET'":= ([HSET, HSET]) .

Local Lemma is_omega_cocont_Lam_S : is_omega_cocont Lam_S.
Proof.
apply is_omega_cocont_Lam.
* apply is_omega_cocont_constprod_functor1.
  apply Exponentials_functor_HSET.
* apply ColimsHSET_of_shape.
Defined.

Lemma Lam_Initial_HSET : Initial (category_FunctorAlg (Id_H _ BinCoproductsHSET Lam_S)).
Proof.
use colimAlgInitial.
- apply (Initial_functor_precat _ _ InitialHSET).
- unfold Id_H, Const_plus_H.
  apply is_omega_cocont_BinCoproduct_of_functors.
  + apply is_omega_cocont_constant_functor.
  + apply is_omega_cocont_Lam_S.
- apply ColimsFunctorCategory_of_shape; apply ColimsHSET_of_shape.
Defined.

(* Lemma KanExt_HSET : ∏ Z : precategory_Ptd HSET has_homsets_HSET, *)
(*    RightKanExtension.GlobalRightKanExtensionExists HSET HSET *)
(*      (U Z) HSET has_homsets_HSET has_homsets_HSET. *)
(* Proof. *)
(* intro Z. *)
(* apply RightKanExtension_from_limits, LimsHSET. *)
(* Defined. *)

Definition LamHSS_Initial_HSET : Initial (hss_category BinCoproductsHSET Lam_S).
Proof.
apply InitialHSS.
- apply InitialHSET.
- apply ColimsHSET_of_shape.
- apply is_omega_cocont_Lam_S.
Defined.

Definition LamMonad : Monad HSET.
Proof.
use Monad_from_hss.
- apply BinCoproductsHSET.
- apply Lam_S.
- apply LamHSS_Initial_HSET.
Defined.

End LamHSET.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Product of Data Structures                                              *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Inhabited *)

Instance prod_inhab : forall `{Inhab A, Inhab B}, Inhab (A * B).
Proof. intros. apply (prove_Inhab (arbitrary, arbitrary)). Qed.

(* ********************************************************************** *)
(** * Structure *)

(** Decomposition as projection *)

Lemma tuple2_from_proj : forall A1 A2 (x:A1*A2),
  (fst x, snd x) = x.
Proof. intros. destruct~ x. Qed.

(** Structural equality *)

Section Properties.
Variables (A1 A2 A3 A4 : Type).
Lemma eq_prod2 : forall (x1 y1:A1) (x2 y2:A2),
  x1 = y1 -> x2 = y2 -> (x1, x2) = (y1, y2).
Proof. intros. subst~. Qed.

Lemma eq_prod3 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3),
  x1 = y1 -> x2 = y2 -> x3 = y3 -> (x1, x2, x3) = (y1, y2, y3).
Proof. intros. subst~. Qed.

Lemma eq_prod4 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
  x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> (x1, x2, x3, x4) = (y1, y2, y3, y4).
Proof. intros. subst~. Qed.

End Properties.

Hint Immediate eq_prod2 eq_prod3 eq_prod4.

(* ********************************************************************** *)
(** * Operations *)

(** [fst] and [snd] are defined in the standard library *)

Implicit Arguments fst [[A] [B]].
Implicit Arguments snd [[A] [B]].

(* ---------------------------------------------------------------------- *)
(** ** Notation for projections *)

(** N-ary projections are defined as notations and not as
    definitions, which has appeared to be more flexible with
    respect to type inference.
    TODO: investigate the possibility of using definitions. *)

Notation "'proj11' P" := P (at level 69, only parsing).

Notation "'proj21' P" := (proj1 P) (at level 69, only parsing).
Notation "'proj22' P" := (proj2 P) (at level 69, only parsing).

Notation "'proj31' P" := (proj1 P) (at level 69).
Notation "'proj32' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj33' P" := (proj2 (proj2 P)) (at level 69).

Notation "'proj41' P" := (proj1 P) (at level 69).
Notation "'proj42' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj43' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj44' P" := (proj2 (proj2 (proj2 P))) (at level 69).

Notation "'proj51' P" := (proj1 P) (at level 69).
Notation "'proj52' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj53' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj54' P" := (proj1 (proj2 (proj2 (proj2 P)))) (at level 69).
Notation "'proj55' P" := (proj2 (proj2 (proj2 (proj2 P)))) (at level 69).

(*-----------------------------------------------------*)
(** ** Currying *)

Section Currying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition curry1 f : A1 -> B :=
  f.
Definition curry2 f : A1 -> A2 -> B :=
  fun x1 x2 => f (x1,x2).
Definition curry3 f : A1 -> A2 -> A3 -> B :=
  fun x1 x2 x3 => f (x1,x2,x3).
Definition curry4 f : A1 -> A2 -> A3 -> A4 -> B :=
  fun x1 x2 x3 x4 => f (x1,x2,x3,x4).
Definition curry5 f : A1 -> A2 -> A3 -> A4 -> A5 -> B :=
  fun x1 x2 x3 x4 x5 => f (x1,x2,x3,x4,x5).
End Currying.

(*-----------------------------------------------------*)
(** ** Uncurrying *)

Section Uncurrying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition uncurry1 f : A1 -> B :=
  f.
Definition uncurry2 f : A1*A2 -> B :=
  fun p => match p with (x1,x2) =>
  f x1 x2 end.
Definition uncurry3 f : A1*A2*A3 -> B :=
  fun p => match p with (x1,x2,x3) =>
  f x1 x2 x3 end.
Definition uncurry4 f : A1*A2*A3*A4 -> B :=
  fun p => match p with (x1,x2,x3,x4) =>
  f x1 x2 x3 x4 end.
Definition uncurry5 f : A1*A2*A3*A4*A5 -> B :=
  fun p => match p with (x1,x2,x3,x4,x5) =>
  f x1 x2 x3 x4 x5 end.
End Uncurrying.

(* ---------------------------------------------------------------------- *)
(** ** Uncurrying for relations *)

(** [uncurrypN] turns a function of type [A1 -> A1 -> .. -> AN -> AN -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Uncurryp.
Variables (A1 A2 A3 A4 B : Type).
Definition uncurryp1 f : A1 -> A1 -> B :=
  f.
Definition uncurryp2 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 x2 y2 end.
Definition uncurryp3 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 x2 x3 y1 y2 y3 end.
Definition uncurryp4 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 x2 x3 x4 y1 y2 y3 y4 end.
End Uncurryp.

(** Unfolding *)

Tactic Notation "unfold_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4.

Tactic Notation "unfolds_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4 in *.

(* ---------------------------------------------------------------------- *)
(** ** Inverse projections for relations *)

(* TODO: rename to [unprojpNK] and define also [unprojNK] *)

(** [unprojNK] turns a function of type [AK -> AK -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Unproj.
Variables (A1 A2 A3 A4 B : Type).
Definition unproj21 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 end.
Definition unproj22 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x2 y2 end.
Definition unproj31 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 y1 end.
Definition unproj32 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x2 y2 end.
Definition unproj33 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x3 y3 end.
Definition unproj41 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 y1 end.
Definition unproj42 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x2 y2 end.
Definition unproj43 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x3 y3 end.
Definition unproj44 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x4 y4 end.
End Unproj.

Implicit Arguments unproj21 [ A1 B ].
Implicit Arguments unproj22 [ A2 B ].
Implicit Arguments unproj31 [ A1 B ].
Implicit Arguments unproj32 [ A2 B ].
Implicit Arguments unproj33 [ A3 B ].
Implicit Arguments unproj41 [ A1 B ].
Implicit Arguments unproj42 [ A2 B ].
Implicit Arguments unproj43 [ A3 B ].
Implicit Arguments unproj44 [ A4 B ].

(** Unfolding *)

Tactic Notation "unfold_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44.

Tactic Notation "unfolds_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44 in *.


Require Import String List.
Import ListNotations.
From CTI Require Import BaseFix.
Open Scope string_scope.

Definition ECadr e := ECar (ECdr e).
Definition ECaddr e := ECar (ECdr (ECdr e)).
Definition ECadddr e := ECar (ECdr (ECdr (ECdr e))).

Definition maybe_lift e := EApp (EVar 1) e.
Definition eval e := EApp (EVar 2) e.
Definition exp := EVar 3.
Definition env := EVar 5.
Definition local n := EVar (6 + n).

(* Meta-circular stage-parametric evaluator for Pink *)
Definition pink_eval :=
  ELam (*_ maybe_lift*) (ELam (*eval exp*) (ELam (*_ env*)
    (EIf (EIsNat exp) (maybe_lift exp)
    (EIf (EIsStr exp) (EApp env exp)
    (EIf (EEq "quote"  (ECar exp)) (maybe_lift (ECadr exp))
    (EIf (EEq "+"      (ECar exp)) (EAdd (EApp (eval (ECadr exp)) env) (EApp (eval (ECaddr exp)) env))
    (EIf (EEq "-"      (ECar exp)) (ESub (EApp (eval (ECadr exp)) env) (EApp (eval (ECaddr exp)) env))
    (EIf (EEq "*"      (ECar exp)) (EMul (EApp (eval (ECadr exp)) env) (EApp (eval (ECaddr exp)) env))
    (EIf (EEq "eq?"    (ECar exp)) (EEq  (EApp (eval (ECadr exp)) env) (EApp (eval (ECaddr exp)) env))
    (EIf (EEq "if"     (ECar exp)) (EIf  (EApp (eval (ECadr exp)) env) (EApp (eval (ECaddr exp)) env)
                                                                       (EApp (eval (ECadddr exp)) env))
    (EIf (EEq "lambda" (ECar exp)) (maybe_lift (ELam (*f x*) (EApp (eval (ECadddr exp))
                                                                   (ELam (*_ y*) (EIf (EEq (local 3 (*y*)) (ECadr exp)) (local 0 (*f*))
                                                                                (EIf (EEq (local 3 (*y*)) (ECaddr exp)) (local 1 (*x*))
                                                                                (EApp env (local 3 (*y*)))))))))
    (EIf (EEq "let"    (ECar exp)) (ELet (*x*) (EApp (eval (ECaddr exp)) env)
                                                     (EApp (eval (ECadddr exp))
                                                           (ELam (*_ y*) (EIf (EEq (local 2 (*y*)) (ECadr exp)) (local 0 (*x*)) (EApp env (local 2 (*y*)))))))
    (EIf (EEq "lift"   (ECar exp)) (ELift   (EApp (eval (ECadr exp)) env))
    (EIf (EEq "num?"   (ECar exp)) (EIsNat  (EApp (eval (ECadr exp)) env))
    (EIf (EEq "str?"   (ECar exp)) (EIsStr  (EApp (eval (ECadr exp)) env))
    (EIf (EEq "pair?"  (ECar exp)) (EIsPair (EApp (eval (ECadr exp)) env))
    (EIf (EEq "car"    (ECar exp)) (ECar    (EApp (eval (ECadr exp)) env))
    (EIf (EEq "cdr"    (ECar exp)) (ECdr    (EApp (eval (ECadr exp)) env))
    (EIf (EEq "cons"   (ECar exp)) (maybe_lift (ECons (EApp (eval (ECadr exp)) env) (EApp (eval (ECaddr exp)) env)))
    (EIf (EEq "app"    (ECar exp)) (EApp (EApp (eval (ECadr exp)) env) (EApp (eval (ECaddr exp)) env))
    (EErr ErrPinkEval))))))))))))))))))))).

Module Tests.
Goal (mk_state, VNat 5)                  = eval0 (EApp (EApp (EApp pink_eval (ELam (EVar 1))) (ENat 5)) (ELam (EErr ErrUnboundVar))). reflexivity. Qed.
Goal (mk_state, VPair (VNat 5) (VNat 6)) = eval0 (EApp (EApp (EApp pink_eval (ELam (EVar 1))) (ECons "cons" (ECons (ENat 5) (ECons (ENat 6) ".")))) (ELam (EErr ErrUnboundVar))). reflexivity. Qed.
Goal (mk_state, VNat 3)                  = eval0 (EApp (EApp (EApp pink_eval (ELam (EVar 1))) (ECons "app" (ECons (ECons "lambda" (ECons "_" (ECons "x" (ECons (ECons "+" (ECons "x" (ECons (ENat 1) "."))) ".")))) (ECons (ENat 2) ".")))) (ELam (EErr ErrUnboundVar))). reflexivity. Qed.
End Tests.


(*Require Import Coqlib Maps.

Definition node := positive.
Definition nodelist := list positive.
Definition graph := PTree.t nodelist.

Lemma fold_left_snd_property:
  forall (A B: Type) (a: A) (l1: list (A * B)) (l2: list A),
    In a (fold_left (fun (al: list A) (p: A * B) => fst p :: al) l1 l2) ->
    In a l2 \/ exists b, In (a, b) l1.
Proof.
  intros. generalize dependent l2.
  induction l1; intros; unfold fold_left; simpl; auto.
  - destruct a0. simpl in H. apply IHl1 in H. destruct H.
    + inversion H; subst; auto. right. eexists; eauto.
    + right. destruct H. eexists; eauto.
Qed.

Section Graph.

Variable G: graph.

Definition V: nodelist :=
  PTree.fold (fun l v _ => v :: l) G nil.

Lemma V_in_G: forall v,
    In v V -> exists l, PTree.get v G = Some l.
Proof.
  intros. unfold V in H. rewrite PTree.fold_spec in H.
  apply fold_left_snd_property in H. destruct H. inversion H.
  destruct H. apply PTree.elements_complete in H. eauto.
Qed.

Definition adj_list (v: node) : nodelist :=
  match G ! v with Some l => l | None => nil end.

Definition adj (u v: node) : bool :=
  in_dec peq u (adj_list v).

Definition in_degree (v: node) : Z :=
  fold_left (fun n u => if adj v u then Z.succ n else n) V 0.

Definition zero_in_degree (v: node) : bool :=
  match Z.compare (in_degree v) 0 with
  | Eq => true
  | _ => false
  end.

Definition zero_in_degree_nodes : nodelist :=
  filter (fun v => zero_in_degree v) V.

Definition in_degrees : PTree.t Z :=
  PTree.map (fun v _ => in_degree v) G.

End Graph.

Definition init_graph (l: nodelist) : graph :=
  PTree.empty nodelist.

Program Fixpoint naive_topological_sort_rec (g: graph) (l: nodelist) {measure (PTree_Properties.cardinal g)} : nodelist :=
  match zero_in_degree_nodes g with
  | nil => l
  | v :: _ =>
    v :: naive_topological_sort_rec (PTree.remove v g) l
  end.
Next Obligation.
  unfold zero_in_degree_nodes in *.
  assert (In v (filter (fun v : node => zero_in_degree g v) (V g))).
  rewrite <- Heq_anonymous; simpl; auto. apply filter_In in H.
  destruct H as [H _]. apply V_in_G in H. destruct H.
  eapply PTree_Properties.cardinal_remove; eauto.
Qed.

Definition naive_topological_sort (g: graph) : nodelist :=
  naive_topological_sort_rec g nil.
*)
Require Import Coqlib Maps.

Definition node := positive.
Definition nodeset := PTree.t unit.
Definition empty_nodeset := PTree.empty unit.
Definition graph := PTree.t nodeset.
Definition empty_graph := PTree.empty nodeset.

Lemma fold_left_list_property:
  forall (A B: Type) (a: A) (l1: list (A * B)) (l2: list A),
    In a (fold_left (fun (al: list A) (p: A * B) => fst p :: al) l1 l2) ->
    In a l2 \/ exists b, In (a, b) l1.
Proof.
  intros. generalize dependent l2.
  induction l1; intros; unfold fold_left; simpl; auto.
  - destruct a0. simpl in H. apply IHl1 in H. destruct H.
    + inversion H; subst; auto. right. eexists; eauto.
    + right. destruct H. eexists; eauto.
Qed.

Lemma fold_left_set_property:
  forall (i: positive) (l: list (positive * nodeset)) (s: nodeset),
    (fold_left (fun (s0: nodeset) (x: positive * nodeset) => PTree.set (fst x) tt s0) l s) ! i = Some tt ->
    s ! i = Some tt \/ exists s1, In (i, s1) l.
Proof.
  intros. generalize dependent s.
  induction l; intros; unfold fold_left; simpl; auto.
  destruct a. simpl in H. apply IHl in H. destruct H.
  - destruct (peq i p); subst; eauto.
    rewrite PTree.gso in H; auto.
  - right. destruct H. eexists; eauto.
Qed.

Section Graph.

Variable G: graph.

Definition V: nodeset :=
  PTree.fold (fun s v _ => PTree.set v tt s) G empty_nodeset.

Lemma V_in_G: forall v,
    V ! v = Some tt -> exists l, G ! v = Some l.
Proof.
  intros. unfold V in H. rewrite PTree.fold_spec in H.
  apply fold_left_set_property in H. destruct H.
  - rewrite PTree.gempty in H. congruence.
  - destruct H. apply PTree.elements_complete in H. eauto.
Qed.

Definition add_node (v: node) : graph :=
  match G ! v with
  | Some s => G
  | None => PTree.set v empty_nodeset G
  end.

Definition add_edge (u v: node) : graph :=
  match G ! u with
  | Some s =>
    match s ! v with
    | Some tt => G
    | None => PTree.set u (PTree.set v tt s) G
    end
  | None => PTree.set u (PTree.set v tt empty_nodeset) G
  end.

Definition adj (u v: node) : bool :=
  match G ! u with
  | Some s =>
    match s ! v with
    | Some tt => true
    | None => false
    end
  | None => false
  end.

Definition in_degree (v: node) : Z :=
  PTree.fold (fun n u _ => if adj u v then Z.succ n else n) V 0.

Definition in_degrees : PTree.t Z :=
  PTree.map (fun v _ => in_degree v) G.

(* Two ways to calculate nodes with zero in_degree, I don't know which one is more efficient. *)

Definition zero_in_degree (v: node) : bool :=
  match Z.compare (in_degree v) 0 with
  | Eq => true
  | _ => false
  end.

Definition zero_in_degree' (v: node) : bool :=
  match in_degrees ! v with
  | Some n =>
    match Z.compare n 0 with
    | Eq => true
    | _ => false
    end
  | None => false
  end.

Definition zero_in_degree_nodes : nodeset :=
  PTree.fold (fun s v _ => if zero_in_degree v then (PTree.set v tt s) else s) V empty_nodeset.

Definition find_zero_in_degree_node : option node :=
  find (fun v => zero_in_degree v) (map fst (PTree.elements V)).

End Graph.

Program Fixpoint naive_topological_sort_rec (g: graph) (l: list node) {measure (PTree_Properties.cardinal g)} : list node :=
  match find_zero_in_degree_node g with
  | None => l
  | Some v =>
    v :: naive_topological_sort_rec (PTree.remove v g) l
  end.
Next Obligation.
  unfold find_zero_in_degree_node in *.
  symmetry in Heq_anonymous. apply find_some in Heq_anonymous.
  destruct Heq_anonymous. apply list_in_map_inv in H.
  destruct H as [x [H H1]]. destruct x. simpl in H. subst.
  destruct u. apply PTree.elements_complete in H1.
  apply V_in_G in H1. destruct H1.
  eapply PTree_Properties.cardinal_remove; eauto.
Qed.

Definition naive_topological_sort (g: graph) : list node :=
  naive_topological_sort_rec g nil.

(*
Definition remove_node (g: graph) (in_degs: PTree.t Z) (v: node) : graph * PTree.t Z :=
  (PTree.remove v g, PTree.map (fun u n => if adj g u v then (Z.pred n) else n) in_degs).

Fixpoint topological_sort_rec (g: graph) (zl: nodelist) (in_deg: PTree.t Z) (ol: nodelist) : nodelist :=
  match zl with
  | nil => ol
  | v :: zl' =>
    let (g', in_degs') := remove_node g in_degs v in
    v :: topological_sort g' in_degs' ol
*)


(* PUBLIC DOMAIN *)
(* Author: Georgy Dunaev, georgedunaev@gmail.com *)
Require Coq.Vectors.Vector.
Require Coq.Structures.Equalities.
Import Coq.Structures.Equalities.
Module Terms_mod (SetVars FuncSymb: UsualDecidableTypeFull).
(*Local Notation SetVars := SetVars.t (*only parsing*).
Local Notation FuncSymb := FuncSymb.t (*only parsing*).*)

Record FSV := {
 fs : FuncSymb.t;
 fsv : nat;
}.

Unset Elimination Schemes.
Inductive Terms : Type :=
| FVC :> SetVars.t -> Terms
| FSC (f:FSV) : (Vector.t Terms (fsv f)) -> Terms.
Set Elimination Schemes.

Definition Terms_rect (T : Terms -> Type)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.

Definition Terms_ind (T : Terms -> Prop)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.
(*Check Terms_ind.*)

Fixpoint substT (t:Terms) (xi: SetVars.t) (u:Terms): Terms.
Proof.
destruct u as [s|f t0].
2 : {
 refine (FSC _ _).
 exact ( @Vector.map _ _ (substT t xi) _ t0 ).
}
{
 destruct (SetVars.eqb s xi).
 exact t.
 exact s.
}
(*Show Proof.*)
Defined.

Fixpoint isParamT (xi : SetVars.t) (t : Terms) {struct t} : bool :=
   match t with
   | FVC s => SetVars.eqb s xi
   | FSC f t0 => Vector.fold_left orb false (Vector.map (isParamT xi) t0)
   end.

Section Interpretation.
Context {X} {fsI:forall(q:FSV),(Vector.t X (fsv q))->X}.
Fixpoint teI
   (val:SetVars.t->X) (t:Terms): X :=
   match t with
   | FVC s => val s
   | FSC f t0 => fsI f (Vector.map (teI val) t0)
   end.
End Interpretation.
End Terms_mod.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** * replacement_corollaries.v *)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export replacement_theorem.
Require Export counting_elements.

Section MAIN.
Variable F : field.
Variable V : vectorspace F.
(** - %\intoc{Corollary 1 to 1.10}% *)
Lemma finite_bases_always_equally_big :
 forall (n : Nat) (beta : basis V),
 has_n_elements n beta ->
 forall Sset : part_set V,
 lin_indep Sset -> has_n_elements n Sset -> is_basis Sset.
intros.
generalize replacement_theorem.
intro p.
generalize (p _ _ _ _ H); clear p; intro p.
assert (n <= n); auto.
generalize (p _ H0 _ H2 H1).
clear p.
intro.
inversion_clear H3.
inversion_clear H4.
assert (x =' empty beta in _).
red in H3.
inversion_clear H3.
inversion_clear H4.
simpl in |- *.
red in |- *.
split; intros.
simpl in |- *.
simpl in H3.
red in H3.
simpl in H3.
generalize (H3 (Build_subtype H4)).
clear H3; intro H3; inversion_clear H3.
generalize (H7 I); clear H7 H8; intro H3; inversion_clear H3.
generalize (minus_n_n n); intro.
generalize (cast_fin x2 (sym_eq H3)).
auto with algebra.
simpl in H4.
contradiction.
red in |- *.
split.
2: auto.
apply generates_comp with (union Sset (inject_subsets x)) (full V);
 auto with algebra.
apply Trans with (union Sset (inject_subsets (empty beta)));
 auto with algebra.
apply Trans with (union Sset (empty V)); auto with algebra.
apply union_comp; auto with algebra.
simpl in |- *.
red in |- *.
split; intro.
2: simpl in H6; contradiction.
simpl in H6.
inversion_clear H6.
inversion_clear x1.
simpl in subtype_prf.
contradiction.
Qed.

(** - %\intoc{Corollary 2 to 1.10}% (partly) *)
Lemma finite_basis_bounds_lin_indep_set_size :
 forall (n : Nat) (beta : basis V),
 has_n_elements n beta ->
 forall Sset : part_set V, has_at_least_n_elements (S n) Sset -> lin_dep Sset.
intros.
apply NNPP; intro.

inversion_clear H0.
assert (exists S1 : part_set V, included S1 Sset /\ has_n_elements n S1).
set (S1 := seq_set (Map_embed (Seqtl x))) in *.
exists S1.
split.
red in |- *.
intros.
rename x0 into v.
inversion_clear H0.
apply in_part_comp_l with (Map_embed (Seqtl x) x0); auto with algebra.
simpl in |- *.
destruct x0.
auto with algebra.
red in |- *.
exists (seq_set_seq (Map_embed (Seqtl x))).
split.
simpl in |- *; red in |- *; simpl in |- *.
intros; split; intro; auto.
unfold subtype_image_equal in |- *.
simpl in |- *.
destruct x0.
rename subtype_elt into v.
rename subtype_prf into Hv.
simpl in Hv.
inversion_clear Hv.
exists x0.
destruct x0.
simpl in |- *.
auto.
red in |- *.
intros.
simpl in |- *.
unfold subtype_image_equal in |- *.
simpl in |- *.
destruct i; destruct j; simpl in |- *.
intro.
apply
 (H2 (Build_finiteT (lt_n_S index n in_range_prf))
    (Build_finiteT (lt_n_S index0 n in_range_prf0)));
 auto with algebra.
simpl in |- *.
simpl in H0.
auto with arith.
inversion_clear H0.
rename x0 into S1.
inversion_clear H3.

generalize (finite_bases_always_equally_big H).
intro p.
assert (lin_indep S1).
apply lin_indep_include with Sset; auto with algebra.
generalize (p _ H3 H4).
clear p; intro.
rename x into Sseq.
assert (exists x : V, in_part x Sset /\ ~ in_part x S1).
apply has_extra_element_strong with n (S n); auto with algebra.
red in |- *.
exists Sseq; auto.
inversion_clear H6.
inversion_clear H7.
assert (in_part x (span S1)).
inversion_clear H5.
red in H7.
apply in_part_comp_r with (full V); auto with algebra.

assert (lin_dep (union S1 (single x))).
elim (lin_dep_vs_span_lemma H3 H8).
intros.
apply H10; auto with algebra.

assert (included (union S1 (single x)) Sset).
red in |- *.
intros v H13.
simpl in H13.
inversion_clear H13.
auto with algebra.
apply in_part_comp_l with x; auto with algebra.

assert (lin_dep Sset).
apply lin_dep_include with (union S1 (single x)); auto with algebra.
apply H1; auto with algebra.
Qed.

(** - Corollary 2 to 1.10 (the rest): *)
Lemma finite_basis_bounds_lin_indep_set_size' :
 forall (n : Nat) (beta : basis V),
 has_n_elements n beta ->
 forall Sset : part_set V, lin_indep Sset -> has_at_most_n_elements n Sset.
intros.
generalize (finite_basis_bounds_lin_indep_set_size H).
intro p; generalize (p Sset); clear p; intro p.
apply not_at_least_then_at_most; auto with algebra.
Qed.

(** - %\intoc{Corollary 3 to 1.10}% *)

Lemma all_finite_bases_equally_big :
 forall (n : Nat) (beta : basis V),
 has_n_elements n beta -> forall Sset : basis V, has_n_elements n Sset.
intros.
generalize (finite_basis_bounds_lin_indep_set_size H).
intro p; generalize (p Sset); clear p; intro p.
inversion H.
assert (has_at_most_n_elements n Sset).
apply not_at_least_then_at_most; auto with algebra.
intro.
generalize (p H1).
elim (is_basis_prf Sset); auto with algebra.

inversion_clear H1.
rename x0 into m.
inversion_clear H2.
elim (is_basis_prf beta); intros.
generalize (finite_basis_bounds_lin_indep_set_size' H3 H4).
intros.
inversion_clear H5.
inversion_clear H6.

assert (x0 = n).
generalize has_n_elements_inj.
intros.
apply (H6 _ _ _ H7 _ _ H); auto with algebra.

assert (m = n).
rewrite H6 in H7.
apply le_antisym; auto with algebra.
rewrite <- H6.
auto.
rewrite <- H8.
auto.
Qed.

End MAIN.


(** * Deferred fix *)

(**
This file shows that the axioms in [GHC.DeferredFix] follow from classical choice
and fuctional extensionality.*)

Definition recurses {a b} (R : a -> a -> Prop) (f : (a -> b) -> (a -> b)) :=
    forall g h x, (forall y, R y x -> g y = h y) -> f g x = f h x.

Definition recurses_on {a b} (P : a -> Prop) (R : a -> a -> Prop) (f : (a -> b) -> (a -> b)) :=
  forall g h x, P x -> (forall y, P y ->  R y x -> g y = h y) -> f g x = f h x.

(**
We want to justify these axioms:

  Axiom deferredFix: forall {a r}, r -> ((a -> r) -> (a -> r)) -> a -> r.

  Axiom deferredFix_eq_on: forall {a b} (d : b) (f : (a -> b) -> (a -> b)) (P : a -> Prop) (R : a -> a -> Prop),
     well_founded R -> recurses_on P R f ->
     forall x, P x -> deferredFix d f x = f (deferredFix d f) x.
*)

Require Import Coq.Logic.Epsilon.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.ClassicalDescription.
Require Import Coq.Wellfounded.Wellfounded.

Definition constructFixpoint :forall {a b} (d : b)
  (F : (a -> b) -> (a -> b))
  (R : a -> a -> Prop),
 well_founded R -> a -> b.
Proof.
  intros ????? Hwf.
  refine (Fix Hwf _ _).
  intros x f'.
  refine (F _ x).
  intro y.
  case (excluded_middle_informative (R y x)).
  * apply f'.
  * intro. exact d.
Defined.

Lemma constructFixpoint_eq : forall {a b} (d : b)
  (F : (a -> b) -> (a -> b))
  (R : a -> a -> Prop)
  (HWf : well_founded R)
  (P : a -> Prop)
  (Hterm : recurses_on P R F),
  forall x, P x ->
  constructFixpoint d F R HWf x = F (constructFixpoint d F R HWf) x.
Proof.
  intros.
  unfold constructFixpoint.
  rewrite Fix_eq.
  - apply Hterm; only 1: assumption.
    intros y Py Ryx.
    destruct (excluded_middle_informative _).
    * reflexivity.
    * contradict n. assumption.
  - intros.
    f_equal.
    extensionality y.
    destruct (excluded_middle_informative _).
    * apply H0.
    * reflexivity.
Qed.

Lemma constructFixpoint_eq_iff : forall {a b} (d : b)
  (F : (a -> b) -> (a -> b))
  (R : a -> a -> Prop)
  (HWf : well_founded R)
  (P : a -> Prop)
  (Hterm : recurses_on P R F),
  forall f,
  (forall x, P x -> F f x = f x) ->
  forall x, P x -> constructFixpoint d F R HWf x = f x.
Proof.
  intros.
  pose proof (HWf x).
  induction H1.
  rewrite <- H by assumption.
  rewrite @constructFixpoint_eq with (P := P) by assumption.
  apply Hterm; only 1: assumption.
  intuition.
Qed.

Lemma construct_fixpoint_sub : forall {a b} (d : b)
  (F : (a -> b) -> (a -> b))
  (R : a -> a -> Prop)
  (HWf : well_founded R)
  (P : a -> Prop)
  (Hterm : recurses_on P R F)
  (R' : a -> a -> Prop)
  (HWf' : well_founded R')
  (P' : a -> Prop)
  (Hterm' : recurses_on P' R' F)
  (HsubR : forall x y, R' x y -> R x y)
  (HsubP : forall x, P' x -> P x),
  forall y, P' y ->
  constructFixpoint d F R HWf y = constructFixpoint d F R' HWf' y.
Proof.
  intros.
  pose proof (HWf' y) as HAcc.
  induction HAcc.
  assert (P x) by intuition.
  erewrite @constructFixpoint_eq by eassumption.
  erewrite @constructFixpoint_eq by eassumption.
  apply Hterm'; only 1: assumption.
  intros y HPy HRy.
  apply H1; assumption.
Qed.

Lemma recurses_on_intersection: forall {a b} (d : b)
  (F : (a -> b) -> (a -> b))
  (R : a -> a -> Prop)
  (P : a -> Prop)
  (Hterm : recurses_on P R F)
  (R' : a -> a -> Prop)
  (P' : a -> Prop)
  (Hterm' : recurses_on P' R' F),
  let P'' := fun x => P x /\ P' x in
  let R'' := fun x y => R x y /\ R' x y in
  recurses_on P'' R'' F.
Proof.
  intros.
  intros g h x [Px P'x] Heq.
  set (gh := fun y => if excluded_middle_informative (P y /\ R y x) then g y else h y).
  transitivity (F gh x).
  * apply Hterm; only 1: assumption.
    intros. unfold gh.
    destruct (excluded_middle_informative _); try reflexivity.
    apply Heq; tauto.
  * apply Hterm'; only 1: assumption.
    intros. unfold gh.
    destruct (excluded_middle_informative _); try reflexivity.
    apply Heq; unfold R'', P'' in *; tauto.
Qed.

Lemma construct_fixpoint_ext : forall {a b} (d : b)
  (F : (a -> b) -> (a -> b))
  (R : a -> a -> Prop)
  (HWf : well_founded R)
  (P : a -> Prop)
  (Hterm : recurses_on P R F)
  (R' : a -> a -> Prop)
  (HWf' : well_founded R')
  (P' : a -> Prop)
  (Hterm' : recurses_on P' R' F),
  forall y, P y -> P' y ->
  constructFixpoint d F R HWf y = constructFixpoint d F R' HWf' y.
Proof.
  intros.
  set (P'' := fun x => P x /\ P' x).
  set (R'' := fun x y => R x y /\ R' x y).
  assert (Hterm'' : recurses_on P'' R'' F)
    by (eapply recurses_on_intersection; eassumption).
  assert (HWf'' : well_founded R''). {
    apply wf_incl with (R2 := R).
    * intros ???. unfold R'' in *; intuition.
    * assumption.
  }
  etransitivity.
  * eapply @construct_fixpoint_sub with (HWf' := HWf'').
    - apply Hterm.
    - apply Hterm''.
    - intros. unfold R'' in *. intuition.
    - intros. unfold P'' in *. intuition.
    - unfold P'' in *. intuition.
  * symmetry.
    eapply @construct_fixpoint_sub with (HWf' := HWf'').
    - apply Hterm'.
    - apply Hterm''.
    - intros. unfold R'' in *. intuition.
    - intros. unfold P'' in *. intuition.
    - unfold P'' in *. intuition.
Qed.

Definition deferredFix: forall {a r}, r -> ((a -> r) -> (a -> r)) -> a -> r.
Proof.
  intros ?? d F x.
  case (excluded_middle_informative (
    (exists P, P x /\ (exists R, well_founded R /\ recurses_on P R F))
  )); intro H.
  * apply constructive_indefinite_description in H.
    destruct H as [P [HPx HR]].
    apply constructive_indefinite_description in HR.
    destruct HR as [R [HWf Hterm]].
    exact (constructFixpoint d F R HWf x).
  * exact d.
Defined.

Lemma deferredFix_eq_on: forall {a b} (d : b) (F : (a -> b) -> (a -> b)) (P : a -> Prop) (R : a -> a -> Prop),
   well_founded R -> recurses_on P R F ->
   forall x, P x -> deferredFix d F x = F (deferredFix d F) x.
Proof.
  intros ?????? HWf Hterm x Px.
  unfold deferredFix.
  destruct (excluded_middle_informative _) as [H|H].
  * destruct (constructive_indefinite_description _) as [P' [HP'x HexR']].
    destruct (constructive_indefinite_description _) as [R' [HWf' Hterm']].
    erewrite @constructFixpoint_eq with (P := P') by assumption.
    apply Hterm'; only 1: assumption.
    intros y P'y R'y.
    destruct (excluded_middle_informative _) as [H'|H'].
    - destruct (constructive_indefinite_description _) as [P'' [HP''x HexR'']].
      destruct (constructive_indefinite_description _) as [R'' [HWf'' Hterm'']].
      apply @construct_fixpoint_ext with (P := P') (P' := P''); assumption.
    - contradict H'.
      exists P'.
      split; try assumption.
  * contradict H.
    exists P.
    split; try assumption.
    exists R. split; assumption.
Qed.


(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.PIWNew.

Require Import Template.Template.

(* Inductive nat : Set :=  O : nat | S : forall ns:nat, nat. *)

Set Printing All.
Require Import ReflParam.Trecord.
Run TemplateProgram (genParamInd [] true true "Coq.Init.Datatypes.nat").

(*
Definition natSInv :=
(fun (H H0 : nat)
   (sigt_R : @sigT (Coq_Init_Datatypes_nat_pmtcty_RR0 H H0)
               (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 H H0 =>
                Coq_Init_Datatypes_nat_pmtcty_RR0_indices))
   (retTyp_R : forall
                 _ : @sigT (Coq_Init_Datatypes_nat_pmtcty_RR0 H H0)
                       (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 H H0 =>
                        Coq_Init_Datatypes_nat_pmtcty_RR0_indices),
               IndicesInvUniv)
   (rett_R : forall H1 : Coq_Init_Datatypes_nat_pmtcty_RR0 H H0,
             retTyp_R
               (@existT (Coq_Init_Datatypes_nat_pmtcty_RR0 H H0)
                  (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 H H0 =>
                   Coq_Init_Datatypes_nat_pmtcty_RR0_indices) H1
                  Coq_Init_Datatypes_nat_pmtcty_RR0_indicesc)) =>
 @sigT_rect (Coq_Init_Datatypes_nat_pmtcty_RR0 H H0)
   (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 H H0 =>
    Coq_Init_Datatypes_nat_pmtcty_RR0_indices)
   (fun
      sigt_R0 : @sigT (Coq_Init_Datatypes_nat_pmtcty_RR0 H H0)
                  (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 H H0 =>
                   Coq_Init_Datatypes_nat_pmtcty_RR0_indices) =>
    retTyp_R sigt_R0)
   (fun (H1 : Coq_Init_Datatypes_nat_pmtcty_RR0 H H0)
      (sigt_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0_indices) =>
    match
      sigt_R0 as sigt_R1
      return
        (retTyp_R
           (@existT (Coq_Init_Datatypes_nat_pmtcty_RR0 H H0)
              (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 H H0 =>
               Coq_Init_Datatypes_nat_pmtcty_RR0_indices) H1 sigt_R1))
    with
    | Coq_Init_Datatypes_nat_pmtcty_RR0_indicesc => rett_R H1
    end) sigt_R).
*)

Run TemplateProgram (mkIndEnv "indTransEnv" ["Coq.Init.Datatypes.nat"]).
Require Import Nat.

Fixpoint nat0 (n:nat) {struct n} : nat := 0.

Run TemplateProgram (genParam indTransEnv false true "nat0").
Run TemplateProgram (genParam indTransEnv false true "Coq.Init.Nat.add").

Notation S_RR := Coq_Init_Datatypes_nat_pmtcty_RR0_constr_1.
Notation O_RR := Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0.
Notation add_RR := Coq_Init_Nat_add_pmtcty_RR.
Locate add.

(* add 0 m = m *)
Lemma add_RR0_computes : forall m1 m2 mr,
  add_RR 0 0 O_RR m1 m2 mr = mr.
Proof.
reflexivity.
Qed.

(* add (S n) m = S (add n m) *)
Lemma add_RRS_computes : forall n1 n2 nr m1 m2 mr,
  add_RR (S n1) (S n2) (S_RR n1 n2 nr) m1 m2 mr =
  S_RR (add n1 m1) (add n2 m2) (add_RR _ _ nr _ _ mr).
Proof.
reflexivity.
Qed.

(*
this fails because we need Fix F = F (Fix F)

(fix
 nat0_R (n n₂ : nat) (n_R : Coq_Init_Datatypes_nat_pmtcty_RR0 n n₂) {struct
        n} :
   Coq_Init_Datatypes_nat_pmtcty_RR0 ((fix nat0 (n0 : nat) : nat := 0%nat) n)
     ((fix nat0 (n0 : nat) : nat := 0%nat) n₂) :=
   Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0)

It checks after manual unfolding:
*)

Definition nat0_RR_manual_unfold :=
(fix
 nat0_R (n n₂ : nat) (n_R : Coq_Init_Datatypes_nat_pmtcty_RR0 n n₂) {struct
        n} :
   Coq_Init_Datatypes_nat_pmtcty_RR0 0
     0 :=
   Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0).

(*
Run TemplateProgram (genParam indTransEnv false true "add").
Print add_RR.
*)
(*
Query commands should not be inserted in scripts
add_RR =
let
  fix add (n m : nat) {struct n} : nat := match n with
                                          | 0%nat => m
                                          | S p => S (add p m)
                                          end in
let
  fix add₂ (n₂ m₂ : nat) {struct n₂} : nat :=
    match n₂ with
    | 0%nat => m₂
    | S p₂ => S (add₂ p₂ m₂)
    end in
fun n m : nat =>
match n as n0 return (match n0 with
                      | 0%nat => m
                      | S p => S (add p m)
                      end = add n0 m) with
| 0%nat => eq_refl
| S x => eq_refl
end
     : forall n m : nat,
       match n with
       | 0%nat => m
       | S p =>
           S
             ((fix add (n0 m0 : nat) {struct n0} : nat :=
                 match n0 with
                 | 0%nat => m0
                 | S p0 => S (add p0 m0)
                 end) p m)
       end =
       (fix add (n0 m0 : nat) {struct n0} : nat :=
          match n0 with
          | 0%nat => m0
          | S p => S (add p m0)
          end) n m

Argument scopes are [nat_scope nat_scope]
*)

(* Run TemplateProgram (genParam indTransEnv false true "add"). Succeeded, but need to remove
fiat because this needs to compute *)

(*
(let fix add (n m : nat) {struct n} : nat := match n with
                                             | 0%nat => m
                                             | S p => S (add p m)
                                             end in
 let
   fix add₂ (n₂ m₂ : nat) {struct n₂} : nat :=
     match n₂ with
     | 0%nat => m₂
     | S p₂ => S (add₂ p₂ m₂)
     end in
 fix
 add_R (n n₂ : nat) (n_R : Coq_Init_Datatypes_nat_pmtcty_RR0 n n₂) (m m₂ : nat)
       (m_R : Coq_Init_Datatypes_nat_pmtcty_RR0 m m₂) {struct n} :
   Coq_Init_Datatypes_nat_pmtcty_RR0 (add n m) (add₂ n₂ m₂) :=
   UsefulTypes.transport (fiat (match n with
                                | 0%nat => m
                                | S p => S (add p m)
                                end = add n m))
     (UsefulTypes.transport
        (fiat (match n₂ with
               | 0%nat => m₂
               | S p₂ => S (add₂ p₂ m₂)
               end = add₂ n₂ m₂))
        (match
           n as n0
           return
             ((fun n1 n₂0 : nat : Set =>
               Coq_Init_Datatypes_nat_pmtcty_RR0 n1 n₂0 ->
               Coq_Init_Datatypes_nat_pmtcty_RR0 match n1 with
                                                 | 0 => m
                                                 | S p => S (add p m)
                                                 end
                 match n₂0 with
                 | 0 => m₂
                 | S p₂ => S (add₂ p₂ m₂)
                 end) n0 n₂)
         with
         | 0%nat =>
             match
               n₂ as n₂0
               return
                 ((fun n0 n₂1 : nat : Set =>
                   Coq_Init_Datatypes_nat_pmtcty_RR0 n0 n₂1 ->
                   Coq_Init_Datatypes_nat_pmtcty_RR0 match n0 with
                                                     | 0 => m
                                                     | S p => S (add p m)
                                                     end
                     match n₂1 with
                     | 0 => m₂
                     | S p₂ => S (add₂ p₂ m₂)
                     end) 0%nat n₂0)
             with
             | 0%nat =>
                 fun n_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0 0 0 =>
                 Coq_Init_Datatypes_nat_pmtcty_RR0_constr_0_inv n_R0
                   (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 0 0 =>
                    Coq_Init_Datatypes_nat_pmtcty_RR0
                      match 0%nat with
                      | 0 => m
                      | S p => S (add p m)
                      end match 0%nat with
                          | 0 => m₂
                          | S p₂ => S (add₂ p₂ m₂)
                          end) m_R
             | S p₂ =>
                 fun n_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0 0 (S p₂) =>
                 False_rectt
                   (Coq_Init_Datatypes_nat_pmtcty_RR0
                      match 0%nat with
                      | 0 => m
                      | S p => S (add p m)
                      end match S p₂ with
                          | 0 => m₂
                          | S p₂0 => S (add₂ p₂0 m₂)
                          end) n_R0
             end
         | S p =>
             match
               n₂ as n₂0
               return
                 ((fun n0 n₂1 : nat : Set =>
                   Coq_Init_Datatypes_nat_pmtcty_RR0 n0 n₂1 ->
                   Coq_Init_Datatypes_nat_pmtcty_RR0
                     match n0 with
                     | 0 => m
                     | S p0 => S (add p0 m)
                     end match n₂1 with
                         | 0 => m₂
                         | S p₂ => S (add₂ p₂ m₂)
                         end) (S p) n₂0)
             with
             | 0%nat =>
                 fun n_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0 (S p) 0 =>
                 False_rectt
                   (Coq_Init_Datatypes_nat_pmtcty_RR0
                      match S p with
                      | 0 => m
                      | S p0 => S (add p0 m)
                      end match 0%nat with
                          | 0 => m₂
                          | S p₂ => S (add₂ p₂ m₂)
                          end) n_R0
             | S p₂ =>
                 fun n_R0 : Coq_Init_Datatypes_nat_pmtcty_RR0 (S p) (S p₂) =>
                 Coq_Init_Datatypes_nat_pmtcty_RR0_constr_1_inv p p₂ n_R0
                   (fun _ : Coq_Init_Datatypes_nat_pmtcty_RR0 (S p) (S p₂) =>
                    Coq_Init_Datatypes_nat_pmtcty_RR0
                      match S p with
                      | 0 => m
                      | S p0 => S (add p0 m)
                      end match S p₂ with
                          | 0 => m₂
                          | S p₂0 => S (add₂ p₂0 m₂)
                          end)
                   (fun p_R : Coq_Init_Datatypes_nat_pmtcty_RR0 p p₂ =>
                    Coq_Init_Datatypes_nat_pmtcty_RR0_constr_1 (add p m)
                      (add₂ p₂ m₂) (add_R p p₂ p_R m m₂ m_R))
             end
         end n_R)))
*)
Open Scope nat_scope.

Lemma addUnfold (n m:nat ):
         (match n with
         | 0%nat => m
         | S p => S (add p m)
          end)= add n m.
Proof.
  intros. destruct n; reflexivity.
Qed.

(*
Run TemplateProgram (genParam indTransEnv false true "nat0").
 *)

(*
(fix Coq_Init_Datatypes_natparam_RR0 (H H0 : nat) {struct H} : Prop :=
   match H with
   | 0%nat =>
       match H0 with
       | 0%nat => Coq_Init_Datatypes_natparam_RR0_indices
       | S _ => False
       end
   | S x =>
       match H0 with
       | 0%nat => False
       | S x0 =>
           {_ : Coq_Init_Datatypes_natparam_RR0 x x0 &
           Coq_Init_Datatypes_natparam_RR0_indices}
       end
   end)
(fun (H H0 : nat)
   (sigt_R : {_ : Coq_Init_Datatypes_natparam_RR0 H H0 &
             Coq_Init_Datatypes_natparam_RR0_indices})
   (retTyp_R : {_ : Coq_Init_Datatypes_natparam_RR0 H H0 &
               Coq_Init_Datatypes_natparam_RR0_indices} -> Set)
   (_ : forall H1 : Coq_Init_Datatypes_natparam_RR0 H H0,
        retTyp_R
          (existT (Coq_Init_Datatypes_natparam_RR0 H H0)
             (fun _ : Coq_Init_Datatypes_natparam_RR0 H H0 =>
              Coq_Init_Datatypes_natparam_RR0_indices) H1
             Coq_Init_Datatypes_natparam_RR0_indicesc)) => fiat (retTyp_R sigt_R))
(fun (H H0 : nat) (H1 : Coq_Init_Datatypes_natparam_RR0 H H0) =>
 existT (Coq_Init_Datatypes_natparam_RR0 H H0)
   (fun _ : Coq_Init_Datatypes_natparam_RR0 H H0 => Coq_Init_Datatypes_natparam_RR0_indices)
   H1 Coq_Init_Datatypes_natparam_RR0_indicesc)
(fun (sigt_R : Coq_Init_Datatypes_natparam_RR0_indices)
   (retTyp_R : Coq_Init_Datatypes_natparam_RR0_indices -> Set)
   (_ : retTyp_R Coq_Init_Datatypes_natparam_RR0_indicesc) => fiat (retTyp_R sigt_R))
Coq_Init_Datatypes_natparam_RR0_indicesc

*)

Notation nat_RR :=  Coq_Init_Datatypes_nat_pmtcty_RR0.

Open Scope nat_scope.
(*
Fixpoint Coq_Init_Nat_add_pmtcty_RR (n1 n2 : nat)
         (n_R : nat_RR n1 n2) (m1 m2 : nat) (m_R : nat_RR m1 m2):
nat_RR (n1 + m1) (n2 + m2) :=
let reT := fun n1 n2 => nat_RR n1 n2 -> nat_RR (n1 + m1) (n2 + m2) in
(match n1 return reT n1 n2 with
| 0 =>
  match n2 return reT 0 n2 with
  | 0 => fun _ => m_R
  | S _ => fun n_R => False_rect _ n_R
  end
| S p1 =>
  match n2 return reT (S p1) n2 with
  | 0 => fun n_R => False_rect _ n_R
  | S p2 => fun n_R =>
             let n_R := projT1 n_R in
             S_RR _ _ (Coq_Init_Nat_add_pmtcty_RR p1 p2 n_R m1 m2 m_R)
  end
end) n_R.
*)

(* Notation add_RR := Coq_Init_Nat_add_pmtcty_RR. *)

Run TemplateProgram (genParam indTransEnv false true "pred").

(*
Parametricity Recursive Nat.pred. (* no error. the error was in sub *)
Print nat_R.
Parametricity Recursive Nat.add.
*)

Inductive nat_R : nat -> nat -> Set :=
    nat_R_O_R : nat_R 0 0 | nat_R_S_R : forall H H0 : nat, nat_R H H0 -> nat_R (S H) (S H0).

(*
Print Coq_o_Init_o_Nat_o_pred_R.
Print Coq_o_Init_o_Nat_o_add_R.
*)
Definition Coq_o_Init_o_Nat_o_pred_R2 :=
fun (n₁ n₂ : nat) (n_R : nat_R n₁ n₂) =>
match
  n_R in (nat_R n₁0 n₂0)
  return (nat_R match n₁0 with
                | 0 => n₁
                | S u => u
                end match n₂0 with
                    | 0 => n₂
                    | S u => u
                    end)
with
| nat_R_O_R => n_R (* this accidentally has the right type. not so lucky in sub *)
| nat_R_S_R _ _ u_R => u_R
end.

(*
Fixpoint sub_R (n₁ n₂ : nat) (n_R : nat_R n₁ n₂) (m₁ m₂ : nat) (m_R : nat_R m₁ m₂)
  {struct n_R} : nat_R (sub n₁ m₁) (sub n₂  m₂) :=
match n_R in nat_R n₁ n₂ return nat_R (sub n₁ m₁) (sub n₂ m₂)  with
| nat_R_O_R => n_R (*type error. expecting nat_R 0 0, found nat_R n₁ n₂. this should be O_R*)
| nat_R_S_R nr₁ nr₂ nr_R => fiat _
end.
*)
Fixpoint sub_R (n₁ n₂ : nat) (n_R : nat_R n₁ n₂) (m₁ m₂ : nat) (m_R : nat_R m₁ m₂)
  {struct n_R} : nat_R (sub n₁ m₁) (sub n₂  m₂) :=
(match n_R in nat_R n₁ n₂ return nat_R n₁ n₂ -> nat_R (sub n₁ m₁) (sub n₂ m₂)  with
| nat_R_O_R => fun n_R => n_R (*type error. expecting nat_R 0 0, found nat_R n₁ n₂. this should be O_R*)
| nat_R_S_R nr₁ nr₂ nr_R => fun n_R => fiat _
end) n_R.

(*
Parametricity Recursive Nat.pred. (* no error. the error was in sub *)
Parametricity Recursive Nat.add.
Print Coq_o_Init_o_Nat_o_add_R.
*)


(* Andrew W. Appel and Stephen Yi-Hsien Lin,
    May 2013, October 2013, March 2014 *)

(* OEUF: modified to remove dependencies on other VST files. *)

Require Recdef.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Coqlib.
Require Import List.
Import ListNotations.

(* OEUF: definitions copied from VST sha/general_lemmas.v *)

Lemma skipn_length:
  forall {A} n (al: list A),
    (length al >= n)%nat ->
    (length (skipn n al) = length al - n)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 apply IHn. omega.
Qed.

Lemma skipn_length_short:
  forall {A} n (al: list A),
    (length al < n)%nat ->
    (length (skipn n al) = 0)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 omega.
 apply IHn. omega.
Qed.

Fixpoint map2 {A B C: Type} (f: A -> B -> C) (al: list A) (bl: list B) : list C :=
 match al, bl with
  | a::al', b::bl' => f a b :: map2 f al' bl'
  | _, _ => nil
  end.

Definition Shr b x := Int.shru x (Int.repr b).

Fixpoint intlist_to_Zlist (l: list int) : list Z :=
 match l with
 | nil => nil
 | i::r =>
     Int.unsigned (Shr 24 i) ::
     Int.unsigned (Int.and (Shr 16 i) (Int.repr 255)) ::
     Int.unsigned (Int.and (Shr 8 i) (Int.repr 255)) ::
     Int.unsigned (Int.and i (Int.repr 255)) ::
     intlist_to_Zlist r
 end.

(*combining four Z into a Integer*)
Definition Z_to_Int (a b c d : Z) : Int.int :=
  Int.or (Int.or (Int.or (Int.shl (Int.repr a) (Int.repr 24)) (Int.shl (Int.repr b) (Int.repr 16)))
            (Int.shl (Int.repr c) (Int.repr 8))) (Int.repr d).

Fixpoint Zlist_to_intlist (nl: list Z) : list int :=
  match nl with
  | h1::h2::h3::h4::t => Z_to_Int h1 h2 h3 h4 :: Zlist_to_intlist t
  | _ => nil
  end.

(* THIS BLOCK OF STUFF is not needed to define SHA256,
  but is useful for reasoning about it *)
  (*
Definition LBLOCKz : Z := 16. (* length of a block, in 32-bit integers *)
Definition WORD : Z := 4.  (* length of a word, in bytes *)
Definition CBLOCKz : Z := (LBLOCKz * WORD)%Z. (* length of a block, in characters *)
Definition hi_part (z: Z) := Int.repr (z / Int.modulus).
Definition lo_part (z: Z) := Int.repr z.

Fixpoint little_endian_integer (contents: list int) : int :=
 match contents with
 | nil => Int.zero
 | c::cr => Int.or (Int.shl (little_endian_integer cr) (Int.repr 8)) c
 end.
Definition big_endian_integer (contents: list int) : int :=
   little_endian_integer (rev contents).
*)
(* END OF "THIS BLOCK OF STUFF" *)

(* PREPROCESSING: CONVERTING STRINGS TO PADDED MESSAGE BLOCKS *)

Definition generate_and_pad msg :=
  let n := Zlength msg in
   Zlist_to_intlist (msg ++ [128%Z]
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0)
           ++ [Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)].

(*ROUND FUNCTION*)

(*hardcoding the constants, first 32 bits of the fractional parts of the cube roots of the first 64 prime numbers*)
Definition K256 := map Int.repr
  [1116352408 ; 1899447441; 3049323471; 3921009573;
   961987163   ; 1508970993; 2453635748; 2870763221;
   3624381080; 310598401  ; 607225278  ; 1426881987;
   1925078388; 2162078206; 2614888103; 3248222580;
   3835390401; 4022224774; 264347078  ; 604807628;
   770255983  ; 1249150122; 1555081692; 1996064986;
   2554220882; 2821834349; 2952996808; 3210313671;
   3336571891; 3584528711; 113926993  ; 338241895;
   666307205  ; 773529912  ; 1294757372; 1396182291;
   1695183700; 1986661051; 2177026350; 2456956037;
   2730485921; 2820302411; 3259730800; 3345764771;
   3516065817; 3600352804; 4094571909; 275423344;
   430227734  ; 506948616  ; 659060556  ; 883997877;
   958139571  ; 1322822218; 1537002063; 1747873779;
   1955562222; 2024104815; 2227730452; 2361852424;
   2428436474; 2756734187; 3204031479; 3329325298].

(*functions used for round function*)
Definition Ch (x y z : int) : int :=
  Int.xor (Int.and x y) (Int.and (Int.not x) z).

Definition Maj (x y z : int) : int :=
  Int.xor (Int.xor (Int.and x z) (Int.and y z) ) (Int.and x y).

Definition Rotr b x := Int.ror x (Int.repr b).

Definition Sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 2 x) (Rotr 13 x)) (Rotr 22 x).
Definition Sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 6 x) (Rotr 11 x)) (Rotr 25 x).
Definition sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 7 x) (Rotr 18 x)) (Shr 3 x).
Definition sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 17 x) (Rotr 19 x)) (Shr 10 x).

(* word function *)
Function W (M: Z -> int) (t: Z) {measure Z.to_nat t} : int :=
  if zlt t 16
  then M t
  else  (Int.add (Int.add (sigma_1 (W M (t-2))) (W M (t-7)))
               (Int.add (sigma_0 (W M (t-15))) (W M (t-16)))).
Proof.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
Qed.

(*registers that represent intermediate and final hash values*)
Definition registers := list int.

(*initializing the values of registers, first thirty-two bits of the fractional
    parts of the square roots of the first eight prime numbers*)
Definition init_registers : registers :=
  map Int.repr  [1779033703; 3144134277; 1013904242; 2773480762;
                        1359893119; 2600822924; 528734635; 1541459225].

Definition nthi (il: list int) (t: Z) := nth (Z.to_nat t) il Int.zero.

Definition rnd_function (x : registers) (k : int) (w : int) : registers:=
  match x with
  |  [a; b; c; d; e; f; g; h] =>
     let T1 := Int.add (Int.add (Int.add (Int.add h (Sigma_1 e)) (Ch e f g)) k) w in
     let T2 := Int.add (Sigma_0 a) (Maj a b c) in
       [Int.add T1 T2; a; b; c; Int.add d T1; e; f; g]
  | _ => nil  (* impossible *)
  end.

Function Round  (regs: registers) (M: Z ->int) (t: Z)
        {measure (fun t => Z.to_nat(t+1)) t} : registers :=
 if zlt t 0 then regs
 else rnd_function (Round regs M (t-1)) (nthi K256 t) (W M t).
Proof. intros; apply Z2Nat.inj_lt; omega.
Qed.

Definition hash_block (r: registers) (block: list int) : registers :=
      map2 Int.add r (Round r (nthi block) 63).

Function hash_blocks (r: registers) (msg: list int) {measure length msg} : registers :=
  match msg with
  | nil => r
  | _ => hash_blocks (hash_block r (firstn 16 msg)) (skipn 16 msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) 16).
 rewrite skipn_length_short. simpl; omega. subst; simpl in *; omega.
 rewrite <- teq; auto.
 rewrite skipn_length. simpl; omega. omega.
Qed.

Definition SHA_256 (str : list Z) : list Z :=
    intlist_to_Zlist (hash_blocks init_registers (generate_and_pad str)).


From AIM Require Export Coqlib.
From AIM Require Export Map.
Require Import Arith.
From AIM Require Export Machine.
From AIM Require Export Assertions.
From AIM Require Export Assertion_Lemmas4.
From AIM Require Export Assertion_Lemmas_prev.

Set Implicit Arguments.
Unset Strict Implicit.

Lemma ptoxW_indom:
  forall l h,
  ptoxW l h
  -> MemMod.in_dom l h /\ MemMod.in_dom (l+1) h.
Proof.
intros.
assert (exists x, h ||- (ptoW l x)).
eapply ptoxW_ptoW. apply H.
destruct H0.
eapply ptoW_indom.
unfold mjudge in H0.
apply H0.
Qed.

Lemma ptoxW_MemUpd16_MonoL : forall l x M1 M2 M M',
  MemMod.disjUnion M1 M2 M
  -> ptoxW l M1
  -> MemUpd16 M l x M'
  -> exists M1', MemMod.disjUnion M1' M2 M'
    /\ MemUpd16 M1 l x M1'.
Proof.
  unfold MemUpd16.
  intros l x M1 M2 M M' djM ldxW mup.
  destruct mup as [x0 mup].   rewrite mup.
  exists (MemMod.put (MemMod.put M1 l x) (l + 1) x0).
  destruct (ptoxW_indom ldxW).
  split.
    apply MemMod.update_presv_disjUnion_left.
    apply MemMod.update_presv_disjUnion_left; auto.
    assert (MemMod.sub_dom M1 (MemMod.put M1 l x)).
    apply MemMod.subDom_update; auto.
    apply H1; auto.
  exists x0; auto.
Qed.

Lemma ptoxW_MemUpd16_MonoR : forall l x M1 M2 M M',
  MemMod.disjUnion M1 M2 M
  -> ptoxW l M2
  -> MemUpd16 M l x M'
  -> exists M2', MemMod.disjUnion M1 M2' M'
    /\ MemUpd16 M2 l x M2'.
Proof.
  unfold MemUpd16.
  intros l x M1 M2 M M' djM ldxW mup.
  destruct mup as [x0 mup].   rewrite mup.
  exists (MemMod.put (MemMod.put M2 l x) (l + 1) x0).
  destruct (ptoxW_indom ldxW).
  split.
    apply MemMod.update_presv_disjUnion_right.
    apply MemMod.update_presv_disjUnion_right; auto.
    assert (MemMod.sub_dom M2 (MemMod.put M2 l x)).
    apply MemMod.subDom_update; auto.
    apply H1; auto.
  exists x0; auto.
Qed.

Arguments ptoxW_MemUpd16_MonoL [l x M1 M2 M M'].
Arguments ptoxW_MemUpd16_MonoR [l x M1 M2 M M'].

(* requisite *)
Lemma leadsToW_leadsToBlk:
  forall ax x h,  (ax  |~>w x) h ->  leadsToBlk ax 2 h.
Proof.
intros.
destruct H as [M1 [M2 [Mdis [MH MH1]]]].
exists M1.
exists M2.
split. auto.
split.
destruct MH as [M3 [M4 [Mdis1 [MH2 MH3]]]].
exists M3. exists M4.
split. apply Mdis1.
split. exists x.
auto.
exists M4. exists MemMod.emp.
split.
apply MemMod.unit_emp_disjUnion.
split. auto.
unfold ptoxBlk.
unfold Aemp.
reflexivity.
auto.
Qed.

Hint Resolve mstar_assoc_left_right mstar_assoc_right_left.


Require Import Raft.
Require Import RaftRefinementInterface.

Section AllEntriesLogMatching.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition allEntries_log_matching net :=
    forall e e' h h',
      In e (log (snd (nwState net h))) ->
      In e' (map snd (allEntries (fst (nwState net h')))) ->
      eTerm e = eTerm e' ->
      eIndex e = eIndex e' ->
      e = e'.

  Class allEntries_log_matching_interface : Prop :=
    {
      allEntries_log_matching_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          allEntries_log_matching net
    }.
End AllEntriesLogMatching.


(* -*- mode: coq; mode: visual-line -*-  *)

From HoTT Require Import Basics.
From WildCat Require Import Basics.
From WildCat Require Export Cat0.  (* ooCat.Laxity. *)

Generalizable Variables m n p A B C.

(** * Fibrations *)

(** TODO: Do general fibrations with Laxity. *)

(** ** Isofibrations *)

(** An isofibration is a displayed category with isomorphism-lifting in all dimensions. *)
CoInductive IsIsoFib {m A} n B `{DHasEquivs m A n B} :=
{
  lift_obj : forall {a b : A} (f : a $<~> b) (u : B a), B b ;
  lift_cate : forall {a b : A} (f : a $<~> b) (u : B a),
      DCatEquiv f u (lift_obj f u) ;
  isisofib_dhom : forall {a b : A} {u : B a} {v : B b},
      @IsIsoFib (pred m) (a $-> b) (pred n) (fun f => DHom f u v)
                _ _ _ _ _ _ ;
}.

Existing Class IsIsoFib.
Global Existing Instance isisofib_dhom.