Require Import List.
Import ListNotations.
Require Import PeanoNat.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.NatInt.NZOrder.

From Verbatim Require Import ltac.
From Verbatim Require Import memo.
From Verbatim Require Import lexer.impl.
From Verbatim Require Import lexer.lemmas.

Module ImplFn (Import MEM : memo.T).

  Module Import MEMO := MEM.MemTy.
  Module Import Defs := MEM.Defs.
  Import Defs.Invariants.
  Import Defs.NaiveLexer.
  Import Defs.NaiveLexer.LEM.IMPL.
  Import MEM.STT.Defs.
  Import MEM.STT.Ty.
  Module Import L := LemmasFn MEM.STT.
  Import L.Lemmas.

  Module Export Utils.

    Lemma app_cons_comm2 : forall {A : Type} ys xs (y : A),
      xs ++ y :: ys = (xs ++ [y]) ++ ys.
    Proof.
      intros. rewrite <- app_assoc. sis. auto.
    Qed.

    Fixpoint zip {A B : Type} (a : list A) (b: list B) : list (A * B) :=
      match a, b with
      | ha :: ta, hb :: tb => (ha,hb) :: (zip ta tb)
      | _, _ => []
      end.

    Fixpoint unzip {A B : Type} (ab : list (A * B)) : (list A) * (list B) :=
      match ab with
      | [] => ([], [])
      | (ha, hb) :: t =>
        match unzip t with
        | (ta, tb) => (ha :: ta, hb :: tb)
        end
      end.

    Lemma len_zip_L : forall {X Y : Type} (xs : list X) (ys : list Y),
        length xs = length ys
        -> length (zip xs ys) = length xs.
    Proof.
      induction xs; intros; auto.
      destruct ys.
      - sis. omega.
      - sis. apply f_equal. apply IHxs. omega.
    Qed.

    Lemma len_zip_R : forall {X Y : Type} (xs : list X) (ys : list Y),
        length xs = length ys
        -> length (zip xs ys) = length ys.
    Proof.
      induction xs; intros; auto.
      destruct ys.
      - sis. omega.
      - sis. apply f_equal. apply IHxs. omega.
    Qed.

    Lemma nth_zip : forall n {X Y : Type} (xs : list X) (ys : list Y) dx dy,
        length xs = length ys
        -> n < length xs
        -> nth n (zip xs ys) (dx, dy) = (nth n xs dx, nth n ys dy).
    Proof.
      induction n; intros.
      - destruct xs; destruct ys; try(sis; auto; omega).
      - destruct xs; destruct ys; try(sis; auto; omega).
        sis. apply IHn; omega.
    Qed.

    Definition ssnd {A B C : Type} (x : A * (B * C)) := snd (snd x).

  End Utils.

  Module Export MPref.

    (** Single-rule Prefixer **)
    Fixpoint max_pref_fn_M (M : Memo) (s : String) (i : index) (state : State)
    : Memo * option (String * String * index) :=
      match s with
      (* in a regex approach, accepting := nullable *)
      | [] => if accepting state then (M, Some ([],[],i))
             else ((set_Memo M (fst state) i None), None)
      | a :: s' =>
        let
          (* in a regex approach, transition := derivative *)
          state' := transition a state in
        let
          lookup := get_Memo M (fst state') (decr i) in
        let
          mpxs :=
          match lookup with
          | None => max_pref_fn_M M s' (decr i) state'
          | Some o => (M, o)
          end
        in

        match mpxs with
        | (M', None) => if (accepting state') then (M' , Some ([a], s', (decr i))) else
                         if (accepting state) then (M', Some ([], s, i)) else
                           ((set_Memo M' (fst state) i None), None)
        | (M', Some (p, q, qi)) => (M', Some (a :: p, q, qi))
        end
      end.

    (** Multi-rule Prefixer **)
    Definition extract_fsm_for_max_M (code : String) (i : index)
               (sru : Memo * (Label * State))
      : Memo * (Label * option (Prefix * Suffix * index)) :=
      match sru with
        (M, (a, fsm)) =>
        match max_pref_fn_M M code i fsm with
          (M', o) => (M', (a, o))
        end
      end.

    Definition max_prefs_M (Ms : list Memo) (code : String)
               (i : index) (erules : list (Label * State))
      : (list Memo) * list (Label * option (Prefix * Suffix * index))
      :=
        let
          zipped := zip Ms erules
        in
        let
          mapped := map (extract_fsm_for_max_M code i) zipped
        in
        unzip mapped.

    Fixpoint max_of_prefs_M (mprefs : list Memo
                                     * list (Label * (option (Prefix * Suffix * index))))
      : list Memo * Label * option (Prefix * Suffix * index) :=
      match mprefs with
        (Ms, prefs) =>
        match max_of_prefs prefs with
          (l, o) => (Ms, l, o)
        end
      end.

  End MPref.

  Module Export TypeCheckLemmas.

    Module Export MemoEq.

      Lemma ith_suffix_cons : forall z code a i,
        ith_suffix code (a :: z) i -> ith_suffix code z (decr i).
      Proof.
        intros.
        unfold ith_suffix in *. destruct H. split.
        - sis. rewrite <- H. rewrite decr_inv_S. auto.
        - destruct H0. exists (x ++ [a]). rewrite <- app_cons_comm2. auto.
      Qed.

      Lemma lexy_correct : forall M pnt z o d code i,
        lexy code M d
        -> ith_suffix code z i
        -> get_Memo M pnt i = Some (o)
        -> max_pref_fn z i (pnt, d) = o.
      Proof.
        intros. unfold lexy in H. eapply H in H0; eauto.
      Qed.

      Theorem mpref_memo_eq_lexy_F : forall z pnt o M M' d code i,
          lexy code M d
          -> ith_suffix code z i
          -> max_pref_fn_M M z i (pnt, d) = (M', o)
          -> max_pref_fn z i (pnt, d) = o.
      Proof.
        induction z; intros.
        - simpl in *. repeat dm; repeat inj_all; auto.
        - simpl in *.
          repeat dm;
          try( repeat inj_all; unfold lexy in H; apply ith_suffix_cons in H0;
            eapply H in E3; eauto; unfold fst in E3; dm; apply transition_Delta in E; subst;
            rewrite E3 in *; repeat inj_all; auto; discriminate );
          try( repeat inj_all; apply ith_suffix_cons in H0;
               destruct (transition a (pnt, d)) eqn:E7; apply transition_Delta in E7;
               rewrite E7 in *; eapply IHz in E; eauto; rewrite E in *; repeat inj_all;
               auto; discriminate ).
          + repeat inj_all. unfold lexy in H. apply ith_suffix_cons in H0. eapply H in E2; eauto.
            unfold fst in E2. dm. apply transition_Delta in E. rewrite E in *. rewrite E2 in *.
            discriminate.
          + repeat inj_all. unfold lexy in H. apply ith_suffix_cons in H0. eapply H in E2; eauto.
      Qed.

      Lemma cons_mprefs__M : forall m Ms z a rules m' Ms' p lst i,
          max_prefs_M (m :: Ms) z i (a :: rules) = (m' :: Ms', p :: lst)
          -> max_prefs_M [m] z i [a] = ([m'], [p]) /\ max_prefs_M Ms z i rules = (Ms', lst).
      Proof.
        intros. unfold max_prefs_M in *. simpl in *. repeat dm; repeat inj_all; subst. auto.
      Qed.

      Theorem mprefs_memo_F : forall z rules Ms Ms' lst i code,
          lexy_list code (zip Ms (map ssnd rules))
          -> length Ms = length rules
          -> max_prefs_M Ms z i rules = (Ms', lst)
          -> ith_suffix code z i
          -> max_prefs z i rules = lst.
      Proof.
        induction rules; intros.
        - destruct Ms;
            unfold max_prefs_M in H1; simpl in H1; repeat inj_all; subst; auto.
        - destruct Ms; try(discriminate).
          assert(A0 : lexy_list code (zip Ms (map ssnd rules))).
          { unfold lexy_list in *. intros. apply H. simpl. right. auto. }
          assert(A1 : length Ms = length rules).
          { simpl in H0. inv H0. auto. }
          destruct lst.
          + unfold max_prefs_M in H1. simpl in H1. repeat dm. discriminate.
          + destruct Ms'.
            * unfold max_prefs_M in H1. simpl in H1. repeat dm. discriminate.
            * simpl. unfold extract_fsm_for_max. dm. subst.
              apply cons_mprefs__M in H1. eapply IHrules in A0; destruct H1; eauto.
              unfold max_prefs_M in e. simpl in e. repeat dm. repeat inj_all; subst.
              destruct p0.
              assert(A2 : lexy code m d).
              { unfold lexy_list in *. apply H. simpl. left. auto. }
              eapply mpref_memo_eq_lexy_F in A2; eauto. subst. auto.
      Qed.

    End MemoEq.

    Module Export Accessible.

      Lemma acc_helper__M : forall Ms code rules Ms' label o i orig,
        lexy_list orig (zip Ms (map ssnd rules))
        -> length Ms = length rules
        -> max_of_prefs_M (max_prefs_M Ms code i rules) = (Ms', label, o)
        -> ith_suffix orig code i
        -> max_of_prefs (max_prefs code i rules) = (label, o).
      Proof.
        intros. destruct (max_prefs code i rules) eqn:E;
                  destruct (max_prefs_M Ms code i rules) eqn:E1.
        - simpl in *. repeat dm; repeat inj_all; subst. eapply mprefs_memo_F in H; eauto.
          + rewrite E in H. subst. simpl in E0. auto.
        - simpl in *. repeat dm; repeat inj_all; subst. eapply mprefs_memo_F in H; eauto.
          rewrite E in H. subst. simpl in E0. auto.
      Qed.

      Lemma acc_recursive_call__M :
        forall code rules label s l suffix Ms Ms' i i' orig,
          Acc lt (length code)
          -> lexy_list orig (zip Ms (map ssnd rules))
          -> length Ms = length rules
          -> max_of_prefs_M (max_prefs_M Ms code i rules)
            = (Ms', label, Some (s :: l, suffix, i'))
          -> ith_suffix orig code i
          -> ith_suffix orig suffix i'
          -> Acc lt (length suffix).
      Proof.
        intros. eapply acc_helper__M in H0; eauto; eapply acc_recursive_call; eauto.
      Defined.

    End Accessible.

    Module Export Lengths.

      Lemma memo_len_const : forall n Ms rules code Ms' l0 i,
        n = length Ms'
        -> length Ms = length rules
        -> max_prefs_M Ms code i rules = (Ms', l0)
        -> length Ms' = length Ms.
      Proof.
        induction n; intros; destruct rules; destruct Ms; destruct Ms'; destruct l0;
          try(simpl in *; auto; discriminate);
          try(unfold max_prefs_M in *; simpl in *; repeat dm; repeat inj_all; subst; discriminate).
        + simpl in *. injection H; intros; clear H. injection H0; intros; clear H0.
          apply cons_mprefs__M in H1. destruct H1. eapply IHn in H2; eauto.
      Qed.

      Lemma labeled_len_const : forall n Ms rules code Ms' l0 i,
          n = length Ms'
          -> length Ms = length rules
          -> max_prefs_M Ms code i rules = (Ms', l0)
          -> length Ms' = length l0.
      Proof.
        induction n; intros; destruct rules; destruct Ms; destruct Ms'; destruct l0;
          try(simpl in *; auto; discriminate);
          try(unfold max_prefs_M in *; simpl in *; repeat dm; repeat inj_all; subst; discriminate).
        + simpl in *. injection H; intros; clear H. injection H0; intros; clear H0.
          apply cons_mprefs__M in H1. destruct H1. eapply IHn in H2; eauto.
      Qed.

      Lemma all_lens_const' : forall n Ms rules code Ms' l0 i,
          n = length Ms'
          -> length Ms = length rules
          -> max_prefs_M Ms code i rules = (Ms', l0)
          -> length Ms' = length Ms /\ length Ms' = length l0.
      Proof.
        intros. split.
        - eapply memo_len_const; eauto.
        - eapply labeled_len_const; eauto.
      Qed.

      Lemma all_lens_const : forall Ms rules code Ms' l0 i,
          length Ms = length rules
          -> max_prefs_M Ms code i rules = (Ms', l0)
          -> length Ms' = length Ms /\ length Ms' = length l0.
      Proof.
        intros. eapply all_lens_const'; eauto.
      Qed.

      Lemma len_recursive_call :
        forall code rules label s l suffix Ms Ms' i i',
          length Ms = length rules
          -> max_of_prefs_M (max_prefs_M Ms code i rules)
            = (Ms', label, Some (s :: l, suffix, i'))
          -> length Ms' = length rules.
      Proof.
        intros. destruct (max_prefs_M Ms code i rules) eqn:E.
        assert(l0 = Ms').
        {
          simpl in H0. repeat dm. injection H0; auto.
        }
        subst. clear H0.
        assert(L := all_lens_const Ms rules code Ms' l1 i H E). destruct L. omega.
      Qed.

    End Lengths.

    Module Export LexyClosure.

      Lemma nth_labels_match'' : forall m n rules Ms code Ms' l0 o ru label label' i,
        m = length rules
        -> length Ms = length rules
        -> length rules = length l0
        -> length Ms' = length Ms
        -> n < length Ms'
        -> max_prefs_M Ms code i rules = (Ms', l0)
        -> nth n l0 (defLabel, None) = (label, o)
        -> nth n rules (defLabel, defState) = (label', ru)
        -> label = label'.
      Proof.
        induction m; intros; destruct Ms; destruct rules; destruct Ms'; destruct l0; destruct n;
          try(simpl in *; omega).
        - apply cons_mprefs__M in H4. destruct H4. clear H7. simpl in *.
          unfold max_prefs_M in H4. simpl in *. repeat dm; repeat inj_all. auto.
        - simpl in *.
          apply Nat.succ_inj in H.  apply Nat.succ_inj in H0.
          apply Nat.succ_inj in H1. apply Nat.succ_inj in H2.
          apply lt_S_n in H3.
          apply cons_mprefs__M in H4. destruct H4.
          eapply IHm; eauto.
      Qed.

      Lemma nth_labels_match' : forall m n rules Ms code Ms' l0 o ru label label' i,
          m = length rules
          -> length Ms = length rules
          -> n < length Ms'
          -> max_prefs_M Ms code i rules = (Ms', l0)
          -> nth n l0 (defLabel, None) = (label, o)
          -> nth n rules (defLabel, defState) = (label', ru)
          -> label = label'.
      Proof.
        intros.
        assert(L := all_lens_const Ms rules code Ms' l0 i H0 H2). destruct L.
        eapply nth_labels_match''; eauto. omega.
      Qed.

      Lemma nth_labels_match : forall n rules Ms code Ms' l0 o ru label label' i,
          max_prefs_M Ms code i rules = (Ms', l0)
          -> length Ms = length rules
          -> n < length Ms'
          -> nth n l0 (defLabel, None) = (label, o)
          -> nth n rules (defLabel, defState) = (label', ru)
          -> label = label'.
      Proof.
        intros. eapply nth_labels_match'; eauto.
      Qed.

      Lemma mprefs__M_associates :
        forall n rules Ms Ms' code (l0 : list (Label * option (Prefix * Suffix * index)))
          M M' o label ru i,
          length Ms = length rules
          -> max_prefs_M Ms code i rules =
            (Ms', l0)
          -> n < length Ms'
          -> nth n Ms emptyMemo = M
          -> nth n Ms' emptyMemo = M'
          -> nth n l0 (defLabel, None) = (label, o)
          -> nth n rules (defLabel, defState) = (label, ru)
          -> max_pref_fn_M M code i ru = (M', o).
      Proof.
        induction n; intros; destruct Ms; destruct Ms'; destruct l0; destruct rules;
          try(simpl in *; omega);
          try(rewrite nil_mprefs__M in *; repeat inj_all; discriminate);
          try(simpl in *; repeat inj_all; unfold max_prefs_M in *; simpl in *;
              repeat dm; repeat inj_all; discriminate).
        + simpl in *. subst. unfold max_prefs_M in *. simpl in *.
          repeat dm. repeat inj_all. auto.
        + simpl in *. injection H; intros; clear H.
          apply lt_S_n in H1. eapply IHn; eauto. eapply cons_mprefs__M; eauto.
      Qed.

      Lemma eq_len_suffix : forall {A : Type} (z0 z x0 x : list A),
          x0 ++ z0 = x ++ z
          -> length z = length z0
          -> x0 = x /\  z0 = z.
      Proof.
        induction z0; destruct z; intros; sis; auto; try(discriminate).
        - split; auto. do 2 rewrite <- app_nil_end in *. auto.
        - do 2 (rewrite app_cons_comm2 in H; symmetry in H).
          apply IHz0 in H; auto. destruct H. subst.
          assert(rev (x0 ++ [a]) = rev (x ++ [a0])).
          { apply f_equal. auto. }
          do 2 rewrite rev_unit in *. inv H1.
          assert(rev (rev x0) = rev (rev x)).
          { apply f_equal. auto. }
          do 2 rewrite rev_involutive in *. subst. auto.
      Qed.

      Lemma set_Memo_lexy : forall z z0 o o' p p0 d m code i i0,
          max_pref_fn z i (p, d) = o'
          -> lexy code m d
          -> get_Memo (set_Memo m p i o') p0 i0 = Some o
          -> ith_suffix code z i
          -> ith_suffix code z0 i0
          -> max_pref_fn z0 i0 (p0, d) = o.
      Proof.
        intros. destruct (String_dec z z0).
        (* originally tried to find an ordering on State *)
        (* realized that was too much, tried to find decidable equality *)
        (* seems like even that is too much, considering that
           the Table and final states doesn't change, only the state-pointer *)
        - rewrite e in *. clear e.
          assert(i = i0).
          { unfold ith_suffix in *. destruct H2. destruct H3. destruct H4. destruct H5.
            subst. auto. }
          rewrite H4 in *. clear H4. clear i.
          subst. destruct (pointer_compare p p0) eqn:E.
          + apply pointer_compare_eq in E. subst. rewrite correct_Memo in H1. inv H1. auto.
          + assert(p <> p0).
            { intros C. apply pointer_compare_eq in C. rewrite C in *. discriminate. }
            clear E.
            assert(p0 <> p \/ i0 <> i0); auto.
            eapply correct_Memo_moot in H4; eauto. rewrite H4 in H1.
            eapply lexy_correct; eauto.
          + assert(p <> p0).
            { intros C. apply pointer_compare_eq in C. rewrite C in *. discriminate. }
            clear E.
            assert(p0 <> p \/ i0 <> i0); auto.
            eapply correct_Memo_moot in H4; eauto. rewrite H4 in H1.
            eapply lexy_correct; eauto.
        - assert(i <> i0).
          { intros C. destruct n. unfold ith_suffix in *.
            destruct H2. destruct H3. destruct H4. destruct H5.
            subst. apply n_det_index in C. apply eq_len_suffix in H5; auto. destruct H5. auto. }
           assert(p0 <> p \/ i0 <> i); auto.
          clear n. eapply correct_Memo_moot in H5; eauto. rewrite H5 in H1.
          eapply lexy_correct; eauto.
      Qed.

      Lemma ith_suffix_unique : forall z z' i orig,
          ith_suffix orig z i
          -> ith_suffix orig z' i
          -> z = z'.
      Proof.
        induction z; destruct z'; intros.
        - auto.
        - unfold ith_suffix in *. destruct H. destruct H0. rewrite <- H in *. sis.
          apply n_det_index in H0. discriminate.
        - unfold ith_suffix in *. destruct H. destruct H0. rewrite <- H in *. sis.
          apply n_det_index in H0. discriminate.
        - assert(z = z').
          {
            apply ith_suffix_cons in H. apply ith_suffix_cons in H0.
            eapply IHz; eauto.
          }
          subst z'.
          assert(a = s).
          {
            unfold ith_suffix in *. destruct H. destruct H0.
            destruct H1. destruct H2. rewrite <- H1 in *.
            apply f_equal with (f := @rev Sigma) in H2. repeat rewrite rev_app_distr in H2.
            sis. repeat rewrite <- app_assoc in *. apply app_inv_head in H2. sis.
            injection H2; intros; subst; auto.
          }
          subst a. auto.
      Qed.

      Lemma lexy_closure :
        forall code p d M o M' i orig,
          lexy orig M d
          -> max_pref_fn_M M code i (p,d) = (M', o)
          -> ith_suffix orig code i
          -> lexy orig M' d.
      Proof.
        induction code; intros.
        {
          assert(max_pref_fn [] i (p,d) = o).
          { eapply mpref_memo_eq_lexy_F; eauto. }
          simpl in H0. repeat dm.
          - inv H0. auto.
          - inv H0. rewrite H5. clear H5 E. unfold lexy. intros.
            destruct (Pointer_as_UCT.Pointer_eq_dec p stt).
            + destruct (index_eq_dec i i0).
              * subst.
                assert(z = []).
                { unfold ith_suffix in *. destruct H1. destruct H2.
                  rewrite <- H1 in *. apply n_det_index in H2.
                  sis. rewrite length_zero_iff_nil in H2. auto.
                }
                subst z.
                rewrite correct_Memo in H0. injection H0. sis. auto.
              * rewrite correct_Memo_moot in H0; auto.
            + rewrite correct_Memo_moot in H0; auto.
        }
        {
          destruct o;
            assert (H0' := H0);
            simpl in H0;
            repeat dm;
            try(repeat inj_all; auto; discriminate);
            try(repeat inj_all; assert(H1' := H1); inv H1; sis; rewrite decr_inv_S in *;
                destruct (transition a (p, d)) eqn:E0;
                apply transition_Delta in E0; subst;
                eapply IHcode in E; eauto; apply ith_suffix_cons in H1';
                rewrite decr_inv_S in *; auto; discriminate).
          - repeat inj_all. destruct (transition a (p,d)) eqn:E.
            apply transition_Delta in E. subst.
            clear IHcode. eapply mpref_memo_eq_lexy_F in H0'; eauto.
            rewrite <- H0'. clear H0' E1 E2 E3. unfold lexy. intros.
            destruct (Pointer_as_UCT.Pointer_eq_dec p stt).
            + destruct (index_eq_dec i i0).
              * subst.
                rewrite correct_Memo in H0.
                assert(z = (a :: code)).
                {
                  eapply ith_suffix_unique; eauto.
                }
                subst z. injection H0. auto.
              * rewrite correct_Memo_moot in H0; auto.
            + rewrite correct_Memo_moot in H0; auto.
          - repeat inj_all.
            assert(lexy orig m d).
            {
              clear H0' E1 E2. apply ith_suffix_cons in H1.
              destruct (transition a (p,d)) eqn:E1. apply transition_Delta in E1. subst d.
              eapply IHcode; eauto.
            }
            eapply mpref_memo_eq_lexy_F in H0'; eauto.
            clear E1 E2 E2 IHcode E E3 H M.
            unfold lexy. intros.
            destruct (Pointer_as_UCT.Pointer_eq_dec p stt).
            + destruct (index_eq_dec i i0).
              * subst.
                rewrite correct_Memo in H.
                assert(z = (a :: code)).
                {
                  eapply ith_suffix_unique; eauto.
                }
                subst z. injection H. intros. subst. auto.
              * rewrite correct_Memo_moot in H; auto.
            + rewrite correct_Memo_moot in H; auto.
        }
      Qed.

      Lemma lexy_list_closure :
        forall code rules Ms l0 Ms' i orig,
          lexy_list orig (zip Ms (map ssnd rules))
          -> length Ms = length rules
          -> max_prefs_M Ms code i rules = (Ms', l0)
          -> ith_suffix orig code i
          -> lexy_list orig (zip Ms' (map ssnd rules)).
      Proof.
        intros. unfold lexy_list in *. intros M' d H3.
        apply In_nth with (d := (emptyMemo, defDelta)) in H3. destruct H3 as [n]. destruct H3.
        assert(L := all_lens_const Ms rules code Ms' l0 i H0 H1). destruct L.
        assert(exists M, nth n Ms emptyMemo = M).
        { eexists; eauto. }
        destruct H7 as [M].
        assert(exists label o, nth n l0 (defLabel, None) = (label, o)).
        { destruct (nth n l0 (defLabel, None)). eexists; eauto. }
        destruct H8 as [label]. destruct H8 as [o].
        assert(exists label' ru, nth n rules (defLabel, defState) = (label', ru)).
        { destruct (nth n rules (defLabel, defState)). eexists; eauto. }
        destruct H9 as [label']. destruct H9 as [ru].
        assert(label = label').
        {
          eapply nth_labels_match; eauto. rewrite len_zip_L in H3; auto.
          rewrite map_length. omega.
        }
        rewrite H10 in *. clear H10.
        rewrite nth_zip in *.
        assert(nth n (zip Ms (map (fun x : Label * (Pointer * Delta) => snd (snd x)) rules))
                   (emptyMemo, defDelta) = (M, d)).
        {
          rewrite nth_zip.
          - inv H4. auto.
          - rewrite map_length. omega.
          - rewrite len_zip_L in H3; try omega. rewrite map_length. omega.
        }
        assert(n < length (zip Ms (map (fun x : Label * (Pointer * Delta) => snd (snd x)) rules))).
        {
          rewrite len_zip_L; [ rewrite len_zip_L in H3 | ]; try rewrite map_length; omega.
        }
        eapply mprefs__M_associates in H0; eauto.
        - destruct ru.
          assert(d = d0).
          {
            injection H4; intros.
            clear H H1 H2 H3 H4 H5 H6 H7 H8 H10 H11 H13 H0 code Ms l0.
            unfold defState.
            assert(exists x, nth n rules (x, (defPointer, defDelta)) = (label', (p, d0))).
            { eexists; eauto. }
            clear H9. destruct H as (x & H).
            assert(defDelta = ssnd (x, (defPointer, defDelta))).
            { auto. }
            rewrite H0 in H12. rewrite map_nth in H12. rewrite H in H12.
            unfold ssnd in *. sis. auto.
          }
          subst.
          assert(In (nth n Ms emptyMemo, d0)
                    (zip Ms (map (fun x : Label * (Pointer * Delta) => snd (snd x)) rules))).
          {
            eapply nth_In in H11. rewrite H10 in H11. auto.
          }
          inv H4. eapply lexy_closure; eauto.
        - rewrite len_zip_L in H3; auto. rewrite map_length. omega.
        - rewrite map_length. omega.
        - rewrite len_zip_L in H3; try omega. rewrite map_length. omega.
      Qed.

      Lemma lexy_recursive_call_gen :
        forall code rules Ms label o Ms' i orig,
          lexy_list orig (zip Ms (map (fun x => snd (snd x)) rules))
          -> length Ms = length rules
          -> max_of_prefs_M (max_prefs_M Ms code i rules) = (Ms', label, o)
          -> ith_suffix orig code i
          -> lexy_list orig (zip Ms' (map (fun x => snd (snd x)) rules)).
      Proof.
        intros. destruct (max_prefs_M Ms code i rules) eqn:E.
        assert(l = Ms').
        {
          simpl in H1. repeat dm. injection H1; auto.
        }
        subst. clear H1.
        eapply lexy_list_closure in H; eauto.
      Qed.

      Lemma lexy_recursive_call :
        forall code rules Ms label s l suffix Ms' i i' orig,
          lexy_list orig (zip Ms (map (fun x => snd (snd x)) rules))
          -> length Ms = length rules
          -> max_of_prefs_M (max_prefs_M Ms code i rules)
            = (Ms', label, Some (s :: l, suffix, i'))
          -> ith_suffix orig code i
          -> ith_suffix orig suffix i'
          -> lexy_list orig (zip Ms' (map (fun x => snd (snd x)) rules)).
      Proof.
        intros. eapply lexy_recursive_call_gen in H; eauto.
      Qed.

    End LexyClosure.

    Module Export IndexClosure.

      Lemma index_rec_call__M_gen : forall code rules Ms label z suffix Ms' i i' orig,
           lexy_list orig (zip Ms (map ssnd rules))
           -> length Ms = length rules
           -> max_of_prefs_M (max_prefs_M Ms code i rules) = (Ms', label, Some (z, suffix, i'))
           -> ith_suffix orig code i
           -> ith_suffix orig suffix i'.
      Proof.
        intros.
        destruct (max_prefs_M Ms code i rules) eqn:E. eapply mprefs_memo_F in E; eauto.
        rewrite <- E in H1. unfold max_of_prefs_M in *. dm. inv H1.
        unfold ith_suffix in *. destruct H2. destruct H2.
        split.
        - apply index_rec_call_gen in E0; auto.
        - exists (x ++ z). rewrite <- app_assoc. rewrite <- H1 in *.
          apply exists_rus_of_mpref_gen in E0. destruct E0 as (r & HIn & E0).
          symmetry in E0. apply max_pref_fn_splits in E0. rewrite <- E0. auto.
      Qed.

      Lemma index_rec_call__M : forall code rules Ms label s l suffix Ms' i i' orig,
           lexy_list orig (zip Ms (map ssnd rules))
           -> length Ms = length rules
           -> max_of_prefs_M (max_prefs_M Ms code i rules) = (Ms', label, Some (s :: l, suffix, i'))
           -> ith_suffix orig code i
           -> ith_suffix orig suffix i'.
      Proof.

        intros.
        destruct (max_prefs_M Ms code i rules) eqn:E. eapply mprefs_memo_F in E; eauto.
        rewrite <- E in H1. unfold max_of_prefs_M in *. dm. inv H1.
        unfold ith_suffix in *. destruct H2. destruct H2.
        split.
        - apply index_rec_call in E0; auto.
        - exists (x ++ (s :: l)). rewrite <- app_assoc. rewrite <- H1 in *.
          apply exists_rus_of_mpref_gen in E0. destruct E0 as (r & HIn & E0).
          symmetry in E0. apply max_pref_fn_splits in E0. rewrite <- E0. auto.
      Defined.

    End IndexClosure.

  End TypeCheckLemmas.

  Module Export Lex.

    Fixpoint lex'_M
             (orig : String)
             (Ms : list Memo)
             (rules : list (sRule))
             (code : String)
             (i : index)
             (Hindex : ith_suffix orig code i)
             (Ha : Acc lt (length code))
             (Hlexy : lexy_list orig (zip Ms (map ssnd rules)))
             (Hlen : length Ms = length rules)
             {struct Ha} : (list Memo) * (list Token) * String :=
      match max_of_prefs_M (max_prefs_M Ms code i rules) as mpref'
            return max_of_prefs_M (max_prefs_M Ms code i rules) = mpref' -> _
      with
      | (Ms', _, None) => fun _ => (Ms', [], code) (* Code cannot be processed further *)
      | (Ms', _, Some ([], _, _)) => fun _ => (Ms', [], code) (* Code cannot be processed further *)
      | (Ms', label, Some (ph :: pt, suffix, i')) =>
        fun Heq =>
          let Hindex' := (index_rec_call__M _ _ _ _ _ _ _ _ _ _ _ Hlexy Hlen Heq Hindex) in
          match (lex'_M orig Ms' rules suffix i'
                       Hindex'
                       (acc_recursive_call__M _ _ _ _ _ _ _ _ _ _ _ Ha Hlexy Hlen Heq Hindex Hindex')
                       (lexy_recursive_call _ _ _ _ _ _ _ _ _ _ _ Hlexy Hlen Heq Hindex Hindex')
                       (len_recursive_call _ _ _ _ _ _ _ _ _ _ Hlen Heq)
                )
          with
          | (Ms'', lexemes, rest) => (Ms'', ((label, ph :: pt) :: lexemes), rest)
          end
      end eq_refl.

    Definition init_srule (rule : Rule) : sRule :=
      match rule with
      | (label, re) => (label, init_state re)
      end.

    Definition init_Memos (srules : list sRule) : list Memo :=
      (map (fun x => emptyMemo) srules).

    Lemma lexy_list_cons : forall M Ms d code,
        lexy code M d -> lexy_list code Ms -> lexy_list code ((M, d) :: Ms).
    Proof.
      intros. unfold lexy_list in *. intros. sis. destruct H1.
      - inv H1. auto.
      - apply H0; auto.
    Qed.

    Lemma init_Memos_lexy : forall srules code,
        lexy_list code (zip (init_Memos srules) (map ssnd srules)).
    Proof.
      intros. induction srules.
      - simpl. unfold lexy_list. intros. contradiction.
      - simpl. apply lexy_list_cons; auto. unfold lexy. intros.
        rewrite correct_emptyMemo in H. discriminate.
    Qed.

    Lemma init_Memos_parallel : forall srules,
        length (init_Memos srules) = length srules.
    Proof.
      intros. induction srules; auto. sis. omega.
    Qed.

    Lemma init_index_self : forall code,
        ith_suffix code code (init_index (length code)).
    Proof.
      intros. split; auto. exists []. auto.
    Qed.

    Definition lex_M (rules : list Rule) (code : String) : list Token * String :=
      let
        srules := map init_srule rules
      in
      match
        lex'_M code (init_Memos srules) srules code (init_index (length code))
              (init_index_self _) (lt_wf _) (init_Memos_lexy _ _) (init_Memos_parallel _)
       with
       | (_, ts, rest) => (ts, rest)
       end.

  End Lex.

End ImplFn.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** THIS FILE IS DEPRECATED. Use [NPeano.Nat] instead. *)

Require Import NPeano.

Local Open Scope nat_scope.
Implicit Types m n p : nat.

Notation max := Peano.max (only parsing).

Definition max_0_l := Nat.max_0_l.
Definition max_0_r := Nat.max_0_r.
Definition succ_max_distr := Nat.succ_max_distr.
Definition plus_max_distr_l := Nat.add_max_distr_l.
Definition plus_max_distr_r := Nat.add_max_distr_r.
Definition max_case_strong := Nat.max_case_strong.
Definition max_spec := Nat.max_spec.
Definition max_dec := Nat.max_dec.
Definition max_case := Nat.max_case.
Definition max_idempotent := Nat.max_id.
Definition max_assoc := Nat.max_assoc.
Definition max_comm := Nat.max_comm.
Definition max_l := Nat.max_l.
Definition max_r := Nat.max_r.
Definition le_max_l := Nat.le_max_l.
Definition le_max_r := Nat.le_max_r.
Definition max_lub_l := Nat.max_lub_l.
Definition max_lub_r := Nat.max_lub_r.
Definition max_lub := Nat.max_lub.

(* begin hide *)
(* Compatibility *)
Notation max_case2 := max_case (only parsing).
Notation max_SS := Nat.succ_max_distr (only parsing).
(* end hide *)

Hint Resolve
 Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith v62.

Hint Resolve
 Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith v62.


From isla Require Import opsem.

Definition a34 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "x9" [] (RegVal_Base (Val_Bits (BV 64%N 0x0%Z))) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.


Require Import List.
Require Import String.

Require Import Cryptol.Coqlib.

Require Import Cryptol.AST.
Require Import Cryptol.Builtins.
Require Import Cryptol.Values.
Require Import Cryptol.Bitvectors.

Require Import Cryptol.BuiltinSyntax.

Open Scope string.

(* It is safe to force evaluation of all the arguments to this builtin *)
Definition strict_builtin (b : builtin) : Prop :=
  match b with
  | Demote => True (* purely type leve computation *)
  | Plus => False (* lazily lifts pointwise over streams *)
  | Minus => False (* lazily lifts pointwise over streams *)
  | Times => False (* lazily lifts pointwise over streams *)
  | Div => False (* lazily lifts pointwise over streams *)
  | Mod => False (* lazily lifts pointwise over streams *)
  | Exp => False (* lazily lifts pointwise over streams *)
  | lg2 => False (* lazily lifts pointwise over streams *)
  | true_builtin => True (* no arguments to be lazy/strict *)
  | false_builtin => True (* no arguments to be lazy/strict *)
  | Neg => False (* lazily lifts pointwise over streams *)
  | Compl => False (* lazily lifts pointwise over streams *)
  | Lt => True (* Lexicographically lifts, thus forces everything *)
  | Gt => True (* Lexicographically lifts, thus forces everything *)
  | Le => True (* Lexicographically lifts, thus forces everything *)
  | Ge => True (* Lexicographically lifts, thus forces everything *)
  | Eq => True (* Lexicographically lifts, thus forces everything *)
  | Neq => True (* Lexicographically lifts, thus forces everything *)
  | And => False (* lazily lifts pointwise over streams *)
  | Or => False (* lazily lifts pointwise over streams *)
  | Xor => False (* lazily lifts pointwise over streams *)
  | Zero => True (* only one argument, that is the result type *)
  | Shiftl => False (* can shift infinite streams, s << 2 is just (rest (rest s)) *)
  | Shiftr => False (* can shift infinite streams, just inserts 0 at beginning *)
  | Rotl => True (* can't lazily rotate in either direction *)
  | Rotr => True (* can't lazily rotate in either direction *)
  | Append => False (* a # b works as long as a is finite (though why both can't be infinite I don't know)*)
  | splitAt => False (* You can split a stream into some elements and another stream *)
  | join => False (* Input can't be infinite in both dimensions, but can be in one *)
  | split => False (* You can split an infinite stream into a stream of lists of elements *)
  | reverse => False (* You can reverse a finite list of infinite streams *)
  | transpose => False (* I don't know how to build [inf][inf]a, but you could transpose it *)
  | At => False (* just take the 3rd element of a stream *)
  | AtAt => False (* same argument for At. Why is this a primitive at all? *)
  | Bang => False (* subtle one: you can reverse index into a finite list of streams *)
  | BangBang => False (* same as for Bang *)
  | update => False (* again, like At or Bang, polymorphic over the contained type, which could be a stream *)
  | updateEnd => False (* same as update *)
  | fromThen => True (* I'm not sure about this, but probably *)
  | fromTo => True
  | fromThenTo => True
  | infFrom => True
  | infFromThen => True
  | pmult => True (* according to the types, must be finite *)
  | pdiv => True (* according to the types, must be finite *)
  | pmod => True (* according to the types, must be finite *)
  end.

Definition binary (b : builtin) : Prop :=
  match b with
  | Plus => True
  | Minus => True
  | Times => True
  | Div => True
  | Mod => True
  | Exp => True
  | Lt => True
  | Gt => True
  | Le => True
  | Ge => True
  | Eq => True
  | Neq => True
  | And => True
  | Or => True
  | Xor => True
  | Shiftl => True
  | Shiftr => True
  | Rotl => True (* can't lazily rotate in either direction *)
  | Rotr => True (* can't lazily rotate in either direction *)
  | Append => True
  | At => True
  | AtAt => True
  | Bang => True
  | BangBang => True
  | pmult => True
  | pdiv => True
  | pmod => True
  | _ => False
  end.

Definition unary (b : builtin) : Prop :=
  match b with
  | Neg => True
  | Compl => True
  | lg2 => True
  | _ => False
  end.

Definition other_arity (b : builtin) : Prop :=
  match b with
  | Demote => True
  | true_builtin => True
  | false_builtin => True
  | Zero => True
  | splitAt => True
  | join => True
  | split => True
  | reverse => True
  | transpose => True
  | update => True
  | updateEnd => True
  | fromThen => True
  | fromTo => True
  | fromThenTo => True
  | infFrom => True
  | infFromThen => True
  | _ => False
  end.

Lemma binary_dec (b : builtin) :
  { binary b } + { ~ binary b }.
Proof.
  destruct b; simpl; auto.
Defined.

Lemma unary_dec (b : builtin) :
  { unary b } + { ~ unary b }.
Proof.
  destruct b; simpl; auto.
Defined.

Lemma arity_complete ( b : builtin) :
  { binary b } + { unary b } + { other_arity b }.
Proof.
  destruct b; simpl; try solve [left; auto]; right; auto.
Defined.

Fixpoint last_two {A : Type} (l : list A) : option (A * A) :=
  match l with
  | nil => None
  | f :: nil => None
  | a :: b :: nil => Some (a,b)
  | a :: b => last_two b
  end.

Fixpoint last_one {A : Type} (l : list A) : option A :=
  match l with
  | nil => None
  | f :: nil => Some f
  | f :: r => last_one r
  end.

(* TODO: This might be a good way to define the correct lifting of binary operations over values *)
Definition evaluate_binary (bi : builtin) (a b : val) : option val := None.

Definition evaluate_unary (bi : builtin) (a : val) : option val := None.

Definition evaluate_builtin (bi : builtin) (lv : list val) : option val :=
  if binary_dec bi then
    match last_two lv with
    | Some (a,b) => evaluate_binary bi a b
    | None => None
    end
  else if unary_dec bi then
         match last_one lv with
         | Some a => evaluate_unary bi a
         | None => None
         end
       else None
.


From stdpp Require Import gmap.
From iris.algebra Require Export local_updates proofmode_classes.

Inductive argmax `{Countable A} :=
| prodZ : gset A → Z → argmax
| botZ : argmax.
Global Arguments argmax _ {_ _}.

Section cmra.
  Context `{Countable A}.
  Local Open Scope Z.
  Local Arguments op _ _ !_ !_ /.
  Local Arguments cmra_op _ !_ !_ /.
  Local Arguments ucmra_op _ !_ !_ /.

  Canonical Structure argmax0 := leibnizO (argmax A).

  Local Instance argmax_valid_instance : Valid (argmax A) := λ _, True.
  Local Instance argmax_unit_instance : Unit (argmax A) := botZ.
  Local Instance argmax_pcore_instance : PCore (argmax A) := Some.
  Local Instance argmax_op_instance : Op (argmax A) := λ n m,
    match m, n with
    | prodZ a i, prodZ b j => if (decide (i = j)) then prodZ (a ∪ b) i
                              else if (decide (i < j)) then n else m
    | botZ, _ => n
    | _, botZ => m
    end.

  Global Instance : IdemP (=@{argmax A}) (⋅).
  Proof. intros [a i|]; rewrite ///op/argmax_op_instance idemp_L; by case_decide. Qed.

  Lemma argmax_ra_mixin : RAMixin (argmax A).
  Proof.
    apply ra_total_mixin; apply _ || eauto.
    + intros [a i|] [b j|] [c k|];
        repeat rewrite ///op/argmax_op_instance; repeat case_decide; try done; try lia.
      rewrite assoc_L //.
    + intros [a i|] [b j|];
        repeat rewrite ///op/argmax_op_instance; repeat case_decide; try done; try lia.
      subst; rewrite comm_L //.
    + intros x; rewrite idemp //.
  Qed.
  Canonical Structure argmaxR : cmra := discreteR (argmax A) argmax_ra_mixin.

  Global Instance argmax_cmra_discrete : CmraDiscrete argmaxR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma argmax_ucmra_mixin : UcmraMixin (argmax A).
  Proof. split; try apply _ || done. intros [x|]; done. Qed.
  Canonical Structure argmaxUR : ucmra := Ucmra (argmax A) argmax_ucmra_mixin.

  Global Instance argmax_core_id (x : argmax A) : CoreId x.
  Proof. by constructor. Qed.

  Lemma argmax_included (x y: argmax A) : x ≼ y ↔ x ⋅ y = y.
  Proof.
    split; last by exists y.
    intros [z ->]; rewrite assoc idemp //.
  Qed.

  Lemma argmax_lt (a b : gset A) (i j : Z)  :
    i < j → prodZ a i ⋅ prodZ b j = prodZ b j.
  Proof. intros; rewrite /op/argmax_op_instance; repeat case_decide; try lia; done. Qed.
  Lemma argmax_eq (a b : gset A) (i : Z) :
    prodZ a i ⋅ prodZ b i = prodZ (a ∪ b) i.
  Proof. rewrite comm_L /op/argmax_op_instance; by case_decide. Qed.
  Lemma argmax_bot (m : argmax A) :
    m ⋅ botZ = m.
  Proof. by destruct m. Qed.

  Lemma argmax_local_update (x y z : argmax A) :
    (x,y) ~l~> (z ⋅ x,z ⋅ y).
  Proof. by apply op_local_update. Qed.

  Global Instance argmax_is_op (x y : argmax A) :
    IsOp (x ⋅ y) x y.
  Proof. done. Qed.
End cmra.

Global Arguments argmaxR _ {_ _}.
Global Arguments argmaxUR _ {_ _}.


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

Open Scope N_scope.
Open Scope zdsl_scope.

Definition fe25519_sq : program :=
let         wsize :=   64%nat in

let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)

let            z0 :=   5 in (* *[uint64 *](rp +  0) *)
let            z1 :=   6 in (* *[uint64 *](rp +  8) *)
let            z2 :=   7 in (* *[uint64 *](rp + 16) *)
let            z3 :=   8 in (* *[uint64 *](rp + 24) *)
let            z4 :=   9 in (* *[uint64 *](rp + 32) *)

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

let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in
let            c5 :=  35 in
let            c6 :=  36 in
let            c7 :=  37 in

let          x119 :=  41 in
let          x219 :=  42 in
let          x319 :=  43 in
let          x419 :=  44 in

let           r01 :=  50 in
let           r11 :=  51 in
let           r21 :=  52 in
let           r31 :=  53 in
let           r41 :=  54 in
let           rax :=  55 in
let           rdx :=  56 in

let             t :=  60 in
let       redmask :=  61 in

let           tmp := 998 in
let         carry := 999 in

[::
      (*  *)
      (* int64 rp *)
      (* int64 xp *)
      (*  *)
      (* input rp *)
      (* input xp *)
      (*  *)
      (* int64 r0 *)
      (* int64 r1 *)
      (* int64 r2 *)
      (* int64 r3 *)
      (* int64 r4 *)
      (*  *)
      (* int64 c1 *)
      (* int64 c2 *)
      (* int64 c3 *)
      (* int64 c4 *)
      (* int64 c5 *)
      (* int64 c6 *)
      (* int64 c7 *)
      (* caller c1 *)
      (* caller c2 *)
      (* caller c3 *)
      (* caller c4 *)
      (* caller c5 *)
      (* caller c6 *)
      (* caller c7 *)
      (* stack64 c1_stack *)
      (* stack64 c2_stack *)
      (* stack64 c3_stack *)
      (* stack64 c4_stack *)
      (* stack64 c5_stack *)
      (* stack64 c6_stack *)
      (* stack64 c7_stack *)
      (* stack64 x119_stack *)
      (* stack64 x219_stack *)
      (* stack64 x319_stack *)
      (* stack64 x419_stack *)
      (*  *)

      (* #required for  macro *)

      (* int64 r01 *)
      (* int64 r11 *)
      (* int64 r21 *)
      (* int64 r31 *)
      (* int64 r41 *)
      (* int64 rax *)
      (* int64 rdx *)

      (* int64 t *)
      (* int64 redmask *)

      (*  *)
      (* enter fe25519_sq *)
      (*  *)
      (* c1_stack = c1 *)
      (* c2_stack = c2 *)
      (* c3_stack = c3 *)
      (* c4_stack = c4 *)
      (* c5_stack = c5 *)
      (* c6_stack = c6 *)
      (* c7_stack = c7 *)
      (*  *)
      (*   #BEGIN MACRO  *)
      (*   rax = *[uint64 *](xp + 0) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 0) *)
      (*   r0 = rax *)
      (*   r01 = rdx *)
zAssign rax (zVar x0);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x0)) wsize;
zAssign r0 (zVar rax);
zAssign r01 (zVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 8) *)
      (*   r1 = rax *)
      (*   r11 = rdx *)
zAssign rax (zVar x0);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x1)) wsize;
zAssign r1 (zVar rax);
zAssign r11 (zVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   r2 = rax *)
      (*   r21 = rdx *)
zAssign rax (zVar x0);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x2)) wsize;
zAssign r2 (zVar rax);
zAssign r21 (zVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   r3 = rax *)
      (*   r31 = rdx *)
zAssign rax (zVar x0);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x3)) wsize;
zAssign r3 (zVar rax);
zAssign r31 (zVar rdx);
      (*   rax = *[uint64 *](xp + 0) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   r4 = rax *)
      (*   r41 = rdx *)
zAssign rax (zVar x0);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r4 (zVar rax);
zAssign r41 (zVar rdx);
      (*  *)
      (*   rax = *[uint64 *](xp + 8) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 8) *)
      (*   carry? r2 += rax *)
      (*   r21 += rdx + carry *)
zAssign rax (zVar x1);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x1)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar rax));
zSplit carry r2 (zVar r2) wsize;
zAssign r21 (zBinop zAdd (zVar r21) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   carry? r3 += rax *)
      (*   r31 += rdx + carry *)
zAssign rax (zVar x1);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x2)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar rax));
zSplit carry r3 (zVar r3) wsize;
zAssign r31 (zBinop zAdd (zVar r31) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax <<= 1 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r4 += rax *)
      (*   r41 += rdx + carry *)
zAssign rax (zVar x1);
zAssign rax (zBinop zMul (zVar rax) ztwo);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x3)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar rax));
zSplit carry r4 (zVar r4) wsize;
zAssign r41 (zBinop zAdd (zVar r41) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 8) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r0 += rax *)
      (*   r01 += rdx + carry *)
zAssign rax (zVar x1);
zAssign rax (zBinop zMul (zVar rax) (zConst 38%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar rax));
zSplit carry r0 (zVar r0) wsize;
zAssign r01 (zBinop zAdd (zVar r01) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*    *)
      (*   rax = *[uint64 *](xp + 16) *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 16) *)
      (*   carry? r4 += rax *)
      (*   r41 += rdx + carry *)
zAssign rax (zVar x2);
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x2)) wsize;
zAssign r4 (zBinop zAdd (zVar r4) (zVar rax));
zSplit carry r4 (zVar r4) wsize;
zAssign r41 (zBinop zAdd (zVar r41) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 16) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r0 += rax *)
      (*   r01 += rdx + carry *)
zAssign rax (zVar x2);
zAssign rax (zBinop zMul (zVar rax) (zConst 38%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x3)) wsize;
zAssign r0 (zBinop zAdd (zVar r0) (zVar rax));
zSplit carry r0 (zVar r0) wsize;
zAssign r01 (zBinop zAdd (zVar r01) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 16) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r1 += rax *)
      (*   r11 += rdx + carry *)
zAssign rax (zVar x2);
zAssign rax (zBinop zMul (zVar rax) (zConst 38%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar rax));
zSplit carry r1 (zVar r1) wsize;
zAssign r11 (zBinop zAdd (zVar r11) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*    *)
      (*   rax = *[uint64 *](xp + 24) *)
      (*   rax *= 19 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 24) *)
      (*   carry? r1 += rax *)
      (*   r11 += rdx + carry *)
zAssign rax (zVar x3);
zAssign rax (zBinop zMul (zVar rax) (zConst 19%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x3)) wsize;
zAssign r1 (zBinop zAdd (zVar r1) (zVar rax));
zSplit carry r1 (zVar r1) wsize;
zAssign r11 (zBinop zAdd (zVar r11) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*   rax = *[uint64 *](xp + 24) *)
      (*   rax *= 38 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r2 += rax *)
      (*   r21 += rdx + carry *)
zAssign rax (zVar x3);
zAssign rax (zBinop zMul (zVar rax) (zConst 38%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r2 (zBinop zAdd (zVar r2) (zVar rax));
zSplit carry r2 (zVar r2) wsize;
zAssign r21 (zBinop zAdd (zVar r21) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*    *)
      (*   rax = *[uint64 *](xp + 32) *)
      (*   rax *= 19 *)
      (*   (uint128) rdx rax = rax * *[uint64 *](xp + 32) *)
      (*   carry? r3 += rax *)
      (*   r31 += rdx + carry *)
zAssign rax (zVar x4);
zAssign rax (zBinop zMul (zVar rax) (zConst 19%Z));
zSplit rdx rax (zBinop zMul (zVar rax) (zVar x4)) wsize;
zAssign r3 (zBinop zAdd (zVar r3) (zVar rax));
zSplit carry r3 (zVar r3) wsize;
zAssign r31 (zBinop zAdd (zVar r31) (zBinop zAdd (zVar rdx) (zVar carry)));
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   redmask = *[uint64 *] &crypto_sign_ed25519_amd64_51_REDMASK51 *)
      (*   r01 = (r01.r0) << 13 *)
      (*   r0 &= redmask *)
zSplit tmp r0 (zVar r0) 51;
zAssign r01 (zBinop zAdd (zmul2p (zVar r01) 13) (zVar tmp));
      (*    *)
      (*   r11 = (r11.r1) << 13 *)
      (*   r1 &= redmask *)
      (*   r1 += r01 *)
zSplit tmp r1 (zVar r1) 51;
zAssign r11 (zBinop zAdd (zmul2p (zVar r11) 13) (zVar tmp));
zAssign r1 (zBinop zAdd (zVar r1) (zVar r01));
      (*    *)
      (*   r21 = (r21.r2) << 13 *)
      (*   r2 &= redmask *)
      (*   r2 += r11 *)
zSplit tmp r2 (zVar r2) 51;
zAssign r21 (zBinop zAdd (zmul2p (zVar r21) 13) (zVar tmp));
zAssign r2 (zBinop zAdd (zVar r2) (zVar r11));
      (*    *)
      (*   r31 = (r31.r3) << 13 *)
      (*   r3 &= redmask *)
      (*   r3 += r21 *)
zSplit tmp r3 (zVar r3) 51;
zAssign r31 (zBinop zAdd (zmul2p (zVar r31) 13) (zVar tmp));
zAssign r3 (zBinop zAdd (zVar r3) (zVar r21));
      (*    *)
      (*   r41 = (r41.r4) << 13 *)
      (*   r4 &= redmask *)
      (*   r4 += r31 *)
zSplit tmp r4 (zVar r4) 51;
zAssign r41 (zBinop zAdd (zmul2p (zVar r41) 13) (zVar tmp));
zAssign r4 (zBinop zAdd (zVar r4) (zVar r31));
      (*   r41 = r41 * 19 *)
zAssign r41 (zBinop zMul (zVar r41) (zConst 19%Z));
      (*   r0 += r41 *)
zAssign r0 (zBinop zAdd (zVar r0) (zVar r41));
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (*   t = r0 *)
      (*   (uint64) t >>= 51 *)
      (*   t += r1 *)
      (*   r0 &= redmask *)
zAssign t (zVar r0);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zAdd (zVar t) (zVar r1));
zAssign r0 (zVar tmp);
      (*    *)
      (*   r1 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r2 *)
      (*   r1 &= redmask *)
zAssign r1 (zVar t);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zAdd (zVar t) (zVar r2));
zAssign r1 (zVar tmp);
      (*    *)
      (*   r2 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r3 *)
      (*   r2 &= redmask *)
zAssign r2 (zVar t);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zAdd (zVar t) (zVar r3));
zAssign r2 (zVar tmp);
      (*    *)
      (*   r3 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t += r4 *)
      (*   r3 &= redmask *)
zAssign r3 (zVar t);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zAdd (zVar t) (zVar r4));
zAssign r3 (zVar tmp);
      (*    *)
      (*   r4 = t *)
      (*   (uint64) t >>= 51 *)
      (*   t *= 19 *)
      (*   r0 += t *)
      (*   r4 &= redmask *)
zAssign r4 (zVar t);
zSplit t tmp (zVar t) 51;
zAssign t (zBinop zMul (zVar t) (zConst 19%Z));
zAssign r0 (zBinop zAdd (zVar r0) (zVar t));
zAssign r4 (zVar tmp);
      (*   #END MACRO  *)
      (*  *)
      (*  *)
      (*  *)
      (*  *)
      (* *[uint64 *](rp + 0) = r0 *)
zAssign z0 (zVar r0);
      (* *[uint64 *](rp + 8) = r1 *)
zAssign z1 (zVar r1);
      (* *[uint64 *](rp + 16) = r2 *)
zAssign z2 (zVar r2);
      (* *[uint64 *](rp + 24) = r3 *)
zAssign z3 (zVar r3);
      (* *[uint64 *](rp + 32) = r4 *)
zAssign z4 (zVar r4)
      (*   *)
      (*  *)
      (* c1 =c1_stack *)
      (* c2 =c2_stack *)
      (* c3 =c3_stack *)
      (* c4 =c4_stack *)
      (* c5 =c5_stack *)
      (* c6 =c6_stack *)
      (* c7 =c7_stack *)
      (*  *)
      (* leave *)
] .

Definition fe25519_sq_inputs : VS.t :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
VSLemmas.OP.P.of_list [:: x0; x1; x2; x3; x4].

Definition fe25519_sq_pre : bexp := zTrue.

Definition fe25519_sq_post : bexp :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
let            z0 :=   5 in
let            z1 :=   6 in
let            z2 :=   7 in
let            z3 :=   8 in
let            z4 :=   9 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (
    zPow (radix51 [::zVar x0; zVar x1; zVar x2; zVar x3; zVar x4]) 2
  )
  (radix51 [::zVar z0; zVar z1; zVar z2; zVar z3; zVar z4])
  (zConst n25519).

Definition fe25519_sq_spec :=
  {| spre := fe25519_sq_pre;
     sprog := fe25519_sq;
     spost := fe25519_sq_post |}.

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

Lemma valid_fe25519_sq : valid_zspec (fe25519_sq_inputs, fe25519_sq_spec).
Proof.
  time "valid_fe25519_sq" verify_zspec.
Qed.

Close Scope zdsl_scope.
Close Scope N_scope.


(************************************************************************)
(* Copyright (c) 2010, Martijn Vermaat <martijn@vermaat.name>           *)
(*                                                                      *)
(* Licensed under the MIT license, see the LICENSE file or              *)
(* http://en.wikipedia.org/wiki/Mit_license                             *)
(************************************************************************)

(** This library defines the type [s ->> t] of transfinite rewrite
   sequences.

   The inductive definition of rewrite sequences is based on that of the
   tree ordinals (see the [Ordinal] library). A rewrite sequence of ordinal
   length alpha is represented by the tree structure of (the tree ordinal)
   alpha where all [Succ] constructors are labeled with rewrite steps.

   The notion of predecessor index and the order on [ord] are lifted to
   [sequence]. The order then becomes an embedding relation on rewrite
   sequences.

   The lifting of ordinal addition yields a concatenation function on
   rewrite sequences.

   For more information, see:

     Martijn Vermaat.
     Infinitary Rewriting in Coq.
     Master Thesis, VU University Amsterdam, 2010.

   % http://martijn.vermaat.name/master-project %
   # http://martijn.vermaat.name/master-project #
*)

Require Import Prelims.
Require Export List.
Require Export FiniteTerm.
Require Export Term.
Require Export Substitution.
Require Export Context.
Require Export ContextEquality.
Require Export Ordinal.
Require Export TermEquality.
Require Import Equality.

Set Implicit Arguments.

Section Rule.

(** We define rewrite rules as pairs of finite terms with the usual
   restrictions. A term rewriting system (TRS) is a list of rewrite
   rules (where the order of no importance). *)

Variable F : signature.
Variable X : variables.

Notation fterm := (finite_term F X).

(** Rewrite rules of finite terms. *)
Record rule : Type := Rule {
  lhs     : fterm;
  rhs     : fterm;
  rule_wf : is_var lhs = false /\ incl (vars rhs) (vars lhs)
}.

(** Left hand side is linear. *)
Definition left_linear (r : rule) : Prop :=
  linear (lhs r).

(** A Term Rewriting System as a finite list of of rewrite rules. *)
Definition trs := list rule.

(** All rules are left-linear. *)
Definition trs_left_linear (s : trs) : Prop := Forall left_linear s.

End Rule.

Implicit Arguments rule [F X].

Section TRS.

(** We consider a TRS and define rewrite steps over its rewrite rules.
   The rewrite steps are then used to construct transfinite rewrite
   sequences. *)

Variable F : signature.
Variable X : variables.

Notation term := (term F X).
Notation fterm := (finite_term F X).
Notation context := (context F X).
Notation substitution := (substitution F X).
Notation trs := (trs F X).

Variable system : trs.

(* Only needed in Coq 8.3 *)
Generalizable All Variables.

(** Critical pairs denote overlap of rewrite rules. Note that we do not
   consider most general common instances, minimality of substitutions, and
   freshness conditions in the defition of [critical_pair]. This definition
   suffices for our present purposes and is not too complex. *)

(* finite_subterm is a quick hack, substitute should be generalized *)
Definition critical_pair (t1 t2 : term) : Prop :=
  exists r1 : rule, exists r2 : rule,
    exists p : position,
      exists sigma : substitution, exists tau : substitution,
      In r1 system /\ In r2 system /\
      (r1 = r2 -> p <> nil) /\
      match finite_subterm (lhs r1) p, dig (substitute sigma (lhs r1)) p with
      | Some s, Some c =>
          is_var s = false /\
          substitute sigma s [~] substitute tau (lhs r2) /\
          t1 [~] fill c (substitute tau (rhs r2)) /\
          t2 [~] substitute sigma (rhs r1)
      | _, _           => False
      end.

(** An orthogonal TRS is left-linear and has no critical pairs. A weakly
   orthogonal TRS is left-linear and has only trivial critical pairs. *)

Definition orthogonal : Prop :=
  trs_left_linear system /\
  forall t1 t2, ~ critical_pair t1 t2.

Definition weakly_orthogonal : Prop :=
  trs_left_linear system /\
  forall t1 t2, critical_pair t1 t2 -> t1 [~] t2.

(** The type [s [>] t] of rewrite steps is parameterised by source and
   target terms [s] and [t]. We allow some flexivility in [s] and [t] in
   the form of bisimilarity. *)

Reserved Notation "s [>] t" (no associativity, at level 40).

Inductive step : term -> term -> Type :=
  | Step : forall (s t : term) (r : rule) (c : context) (u : substitution),
             In r system ->
             fill c (substitute u (lhs r)) [~] s ->
             fill c (substitute u (rhs r)) [~] t ->
             s [>] t
where "s [>] t" := (step s t).

(** Equality of steps [step_eq] requires;
   - bisimilarity of contexts
   - equality of rules
   - equality of substitutions for all variables in the rule.

   This implies bisimilarity of source and target terms. *)

Definition step_eq `(p : s [>] t, o : u [>] v) :=
  match p, o with
  | Step _ _ r c u _ _ _, Step _ _ r' c' u' _ _ _ =>
    context_bis c c' /\ r = r' /\ substitution_eq (vars (lhs r)) u u'
  end.

(** Note that this lemma is tainted by [substitution_eq_substitute], which
   is not proved yet. See the [Substitution] library. *)
Lemma step_eq_source :
  forall `(p : s [>] t, o : u [>] v),
    step_eq p o ->
    s [~] u.
Proof.
intros _ _ [s t r c a Hr Hs Ht] _ _ [u v r' c' b Hr' Hu Hv] H.
apply term_bis_trans with (fill c (substitute a (lhs r))).
apply term_bis_symm; assumption.
apply term_bis_trans with (fill c' (substitute b (lhs r'))).
destruct H as [H1 [H2 H3]].
rewrite <- H2.
apply term_bis_trans with (fill c (substitute b (lhs r))).
apply fill_term_bis.
apply substitution_eq_substitute.
assumption.
apply fill_context_bis.
assumption.
assumption.
Qed.

(** Note that this lemma is tainted by [substitution_eq_substitute] and
   [substitution_eq_incl, which are not proved yet. See the [Substitution]
   library. *)
Lemma step_eq_target :
  forall `(p : s [>] t, o : u [>] v),
    step_eq p o ->
    t [~] v.
Proof.
intros _ _ [s t r c a Hr Hs Ht] _ _ [u v r' c' b Hr' Hu Hv] H.
apply term_bis_trans with (fill c (substitute a (rhs r))).
apply term_bis_symm; assumption.
apply term_bis_trans with (fill c' (substitute b (rhs r'))).
destruct H as [H1 [H2 H3]].
rewrite <- H2.
apply term_bis_trans with (fill c (substitute b (rhs r))).
apply fill_term_bis.
apply substitution_eq_substitute.
apply substitution_eq_incl with (vars (lhs r)).
apply rule_wf.
assumption.
apply fill_context_bis.
assumption.
assumption.
Qed.

(** [step_eq_refl] is an equivalence. *)

Lemma step_eq_refl :
  forall `(p : s [>] t), step_eq p p.
Proof.
intros _ _ [].
constructor.
apply context_bis_refl.
split.
reflexivity.
apply substitution_eq_refl.
Qed.

Lemma step_eq_symm :
  forall `(p : s [>] t, o : u [>] v),
    step_eq p o ->
    step_eq o p.
Proof.
intros.
destruct p, o.
constructor.
apply context_bis_symm.
apply H.
destruct H as [_ [H H']].
split.
rewrite H.
reflexivity.
apply substitution_eq_symm.
rewrite <- H.
assumption.
Qed.

Lemma step_eq_trans :
  forall `(p : s [>] t, o : u [>] v, m : w [>] z),
    step_eq p o ->
    step_eq o m ->
    step_eq p m.
Proof.
intros.
destruct p, o, m.
constructor.
apply context_bis_trans with c0.
apply H.
apply H0.
destruct H as [_ [H H']].
split.
rewrite H.
apply H0.
apply substitution_eq_trans with u.
apply H'.
rewrite H.
apply H0.
Qed.

(** Depth of rule application in a rewriting step. *)
Definition depth s t (p : s [>] t) : nat :=
  match p with
  | Step _ _ _ c _ _ _ _ => hole_depth c
  end.

(** Source and target terms are equal up to the depth of the rewrite step. *)
Lemma eq_up_to_rewriting_depth :
  forall `(p : s [>] t) n,
    n <= depth p ->
    term_eq_up_to n s t.
Proof.
destruct p as [s t r c u Hr Hs Ht].
intros n H.
exact (term_eq_up_to_trans
  (term_eq_up_to_symm ((term_bis_implies_term_eq Hs) n))
  (term_eq_up_to_trans
    (fill_eq_up_to c (substitute u (lhs r)) (substitute u (rhs r)) H)
    ((term_bis_implies_term_eq Ht) n))).
Qed.

(** A term is a normal form if no rule left-hand side matches. *)
Definition normal_form t :=
  ~ exists c : context, exists r, exists u,
    In r system /\ fill c (substitute u (lhs r)) [~] t.

(** An alternative formulation would be [~exists p : t [>] _, True]. *)

(** The type [s ->> t] of rewrite sequences is parameterised by source and
   target terms [s] and [t]. This structure is based on that of the tree
   ordinals (see the [Ordinal] library). *)

Reserved Notation "s ->> t" (no associativity, at level 40).

Inductive sequence : term -> term -> Type :=
  | Nil   : forall t, t ->> t
  | Cons  : forall `(r : s ->> t, p : t [>] u), s ->> u
  | Lim   : forall `(f : (forall n, s ->> ts n), c : converges ts t), s ->> t
where "s ->> t" := (sequence s t).

(** Coq ignores the recursive call in the [Lim] constructor and therefore
   the induction principle is missing a hypothesis. We reset the
   generated induction principle and create a new one below.

   UPDATE: This was only true for our old [Sigma] type definition, Coq
   generates a perfectly fine induction principle now. For the moment, we
   keep our own induction principle though, because the order of parameters
   is different (this affects all proofs with [induction r as [...]]). *)

Reset sequence_rect.

Notation "s ->> t" := (sequence s t).
Implicit Arguments Cons [s t u].

Section InductionPrinciple.

Variable P : forall `(r : s ->> t), Type.

Hypothesis H1 : forall t, P (Nil t).

Hypothesis H2 :
  forall `(r : s ->> t, p : t [>] u),
    P r ->
    P (Cons r p).

Hypothesis H3 :
  forall `(f : forall n, s ->> ts n, c : converges ts t),
    (forall n, P (f n)) ->
    P (Lim f c).

Fixpoint sequence_rect `(r : s ->> t) : P r :=
  match r return P r with
  | Nil t          => H1 t
  | Cons s t r u p => H2 p (sequence_rect r)
  | Lim s ts f t c => H3 f c (fun n => sequence_rect (f n))
  end.

End InductionPrinciple.

Definition sequence_ind (P : `(s ->> t -> Prop)) :=
  sequence_rect P.

(** We can [Cons] steps that fit by bisimilarity. *)
Definition cons_term_bis `(r : s ->> t, p : u [>] v) : u [~] t -> s ->> v :=
  match p in u [>] v return u [~] t -> s ->> v with
  | Step u v rul c sub Hr Hs Ht =>
      fun H => Cons r (Step rul c sub Hr (term_bis_trans Hs H) Ht)
  end.

(** Trivial image of rewrite sequences in ordinals. *)
Fixpoint length `(r : s ->> t) : ord :=
  match r with
  | Nil _          => Zero
  | Cons _ _ r _ _ => Succ (length r)
  | Lim _ _ f _ _  => Limit (fun n => length (f n))
  end.

(** We lift [pd_type], [pd], and [ord_le] from ordinals to rewrite sequences.
   See the [Ordinal] library for the original definitions. *)

Fixpoint pred_type `(r : s ->> t) : Type :=
  match r with
  | Nil _          => False
  | Cons _ _ r _ _ => (unit + pred_type r) % type
  | Lim _ _ f _ _  => { n : nat & pred_type (f n) }
  end.

Reserved Notation "r [ i ]" (at level 60).

(** The difference with ordinals is that [Succ] constructors carry no
   additional information, whereas [Cons] constructors carry a rewrite
   step. The predecessor indices of a rewrite sequence always point to
   a [Cons] constructor and it is useful to get both the predecessor
   rewrite sequence and the rewrite step pointed to by the predecessor
   index. Therefore, [pred] returns a pair (rewrite sequence, rewrite
   step). The pair is wrapped in a [Sigma] type that includes the
   source and target terms of the rewrite step. *)
Fixpoint pred `(r : s ->> t) :
  pred_type r -> { ts : (term * term)%type & ((s ->> (fst ts)) * ((fst ts) [>] (snd ts)))%type } :=
  match r in s ->> t return pred_type r -> { ts : (term * term)%type & ((s ->> (fst ts)) * ((fst ts) [>] (snd ts)))%type } with
  | Nil _           => !
  | Cons s t' q u p => fun i => match i with
                                  (* TODO: i would like t instead of u here *)
                                | inl tt => existT (fun ts => (s ->> fst ts) * (fst ts [>] snd ts))%type (t', u) (q, p)
                                | inr j  => q[j]
                                end
  | Lim _ _ f _ _   => fun i => match i with
                                | existT n j => (f n)[j]
                                end
  end
where "r [ i ]" := (pred r i).

Notation "r [1 i ]" := (fst (projT1 (pred r i))) (at level 60).
Notation "r [2 i ]" := (snd (projT1 (pred r i))) (at level 60).
Notation "r [seq i ]" := (fst (projT2 (pred r i))) (at level 60).
Notation "r [stp i ]" := (snd (projT2 (pred r i))) (at level 60).

(** [pred_type] is transitively closed. *)
Lemma pred_trans :
  forall `(r : s ->> t, i : pred_type r, j : pred_type (r[seq i])),
    exists k : pred_type r, r[k] = r[seq i][j].
Proof.
induction r; intros.
elim i.
destruct i as [[] | i]; simpl in j |- *.
exists (inr _ j).
reflexivity.
destruct (IHr i j) as [k H].
exists (inr _ k).
assumption.
destruct i as [n i]; simpl in j |- *.
destruct (H n i j) as [k H1].
exists (existT (fun n => pred_type (f n)) n k).
assumption.
Qed.

Implicit Arguments pred_trans [s t r].

(** Image of [pred_type] (on rewrite sequences) in [pd_type] (on ordinals).
   Maybe we should make this a coercion. *)

Fixpoint pred_type_as_pd_type `(r : s ->> t) : pred_type r -> pd_type (length r) :=
  match r in s ->> t return pred_type r -> pd_type (length r) with
  | Nil _          => !
  | Cons _ _ q _ _ => fun i => match i with
                               | inl tt => inl _ tt
                               | inr j  => inr _ (pred_type_as_pd_type q j)
                               end
  | Lim _ _ f _ _  => fun i => match i with
                               | existT n j => existT _ n (pred_type_as_pd_type (f n) j)
                               end
  end.

Implicit Arguments pred_type_as_pd_type [s t r].

Lemma pred_type_as_pd_type_ok :
  forall `(r : s ->> t, i : pred_type r),
    length (r[seq i]) = pd (length r) (pred_type_as_pd_type i).
Proof.
intros s t r i.
induction r as [t| s t r u p IH | s ts f t c IH].
elim i.
destruct i as [[] | i].
reflexivity.
apply IH.
destruct i as [n i].
apply IH.
Qed.

(** Image of [pd_type] (on ordinals) in [pred_type] (on rewrite sequences).
   Maybe we should make this a coercion. *)

Fixpoint pd_type_as_pred_type `(r : s ->> t) : pd_type (length r) -> pred_type r :=
  match r in s ->> t return pd_type (length r) -> pred_type r with
  | Nil _          => !
  | Cons _ _ q _ _ => fun i => match i with
                               | inl tt => inl _ tt
                               | inr j  => inr _ (pd_type_as_pred_type q j)
                               end
  | Lim _ _ f _ _  => fun i => match i with
                               | existT n j => existT _ n (pd_type_as_pred_type (f n) j)
                               end
  end.

Implicit Arguments pd_type_as_pred_type [s t r].

Lemma pd_type_as_pred_type_ok :
  forall `(r : s ->> t, i : pd_type (length r)),
    length (r[seq pd_type_as_pred_type i]) = ((length r)[i])%ord.
Proof.
intros s t r i.
induction r as [t| s t r u p IH | s ts f t c IH].
elim i.
destruct i as [[] | i]; simpl.
reflexivity.
apply IH.
destruct i as [n i]; simpl.
apply IH.
Qed.

Lemma pd_type_pred_type_inv :
  forall `(r : s ->> t, i : pred_type r),
    i = pd_type_as_pred_type (pred_type_as_pd_type i).
Proof.
intros s t r i.
induction r as [t| s t r u p IH | s ts f t c IH].
elim i.
destruct i as [[] | i]; simpl; [| rewrite <- (IH i)]; reflexivity.
destruct i as [n i]; simpl.
rewrite <- (IH n i).
reflexivity.
Qed.

(** The order [ord_le] on ordinals lifted to rewrite sequences is an embedding
   relation on rewrite sequences. *)

Inductive embed : forall `(r : s ->> t, q : u ->> v), Prop :=
  | Embed_Nil  : forall s `(q : u ->> v),
                   Nil s <= q
  | Embed_Cons : forall `(q : u ->> v, r : s ->> (q[1 i]), p : (q[1 i]) [>] t),
                   r <= q[seq i] ->
                   step_eq p (q[stp i]) ->
                   Cons r p <= q
  | Embed_Lim  : forall `(f : (forall n, s ->> ts n), c : converges ts t, q : u ->> v),
                   (forall n, (f n) <= q) ->
                   Lim f c <= q
where "r <= q" := (embed r q).

Definition embed_strict `(r : s ->> t, q : u ->> v) := exists i, r <= q[seq i].
Infix " < " := embed_strict (no associativity, at level 70).

(* TODO: define equality based on embed *)

(** Some lemmas on rewrite sequences and relations follow. Most of them are
   analoguous to lemmas on ordinals that can be found in the [Ordinal]
   library. *)

Lemma embed_length :
  forall `(r : s ->> t, q : u ->> v),
    r <= q -> (length r <= length q)%ord.
Proof.
induction r as [t | s t r w p IH | s ts f t c IH]; simpl; intros u v q H.
constructor.
dependent destruction H.
apply Ord_le_Succ with (pred_type_as_pd_type i).
rewrite <- pred_type_as_pd_type_ok.
apply IH.
assumption.
dependent destruction H.
constructor.
intro n.
apply IH.
apply H.
Qed.

Lemma embed_pred_right :
  forall `(r : s ->> t, q : u ->> v, i : pred_type q),
    r <= q[seq i] ->
    r <= q.
Proof.
induction r as [t | s t r w p IH | s ts f t c IH]; intros u v q i H.
constructor.
dependent destruction H.
destruct (pred_trans i i0) as [k T].
revert r p IH H H0.
rewrite <- T.
intros r p IH H H0.
apply Embed_Cons; assumption.
constructor.
intro n.
dependent destruction H.
apply IH with i.
trivial.
Qed.

Lemma embed_pred_left :
  forall `(r : s ->> t, q : u ->> v, i : pred_type r),
    r <= q ->
    r[seq i] <= q.
Proof.
intros s t r u v q i H.
induction H as [s u v q | u v q s j r t p H IH Hp | s ts f t c u v q H IH].
elim i.
destruct i as [[] | i]; apply embed_pred_right with j.
apply H.
apply IH.
destruct i.
apply IH.
Qed.

Lemma embed_not_cons_nil :
  forall `(r : s ->> t, p : t [>] u) v,
    ~ Cons r p <= Nil v.
Proof.
intros s t r u p v H.
dependent destruction H.
destruct i.
Qed.

Lemma embed_cons_elim :
  forall `(r : s ->> t, q : u ->> v, p : t [>] w, o : v [>] x),
    Cons r p <= Cons q o ->
    r <= q.
Proof.
intros s t r u v q w p x o H.
dependent destruction H.
destruct i as [[] |]; [| apply embed_pred_right with p0]; assumption.
Qed.

Lemma first_pred_after_cons_id :
  forall `(r : s ->> t, p : t [>] u),
    r = (Cons r p)[seq (inl (pred_type r) tt)].
Proof.
trivial.
Qed.

Lemma embed_cons_left :
  forall `(r : s ->> t, q : v ->> w, p : t [>] u),
    Cons r p <= q ->
    r <= q.
Proof.
intros s t r v w q u p H.
rewrite (first_pred_after_cons_id r) with p.
apply (@embed_pred_left s u (Cons r p) v w q (inl (pred_type r) tt)).
assumption.
Qed.

Lemma embed_cons_right :
  forall `(r : s ->> t, q : u ->> v, p : v [>] w),
    r <= q ->
    r <= Cons q p.
Proof.
induction r as [t | s t r z o _ | s ts f t c IH]; intros u v q w p H.
constructor.
dependent destruction H.
apply (@Embed_Cons u w (Cons q p) s (inr _ i) r); assumption.
constructor.
intro n.
apply IH.
dependent destruction H.
trivial.
Qed.

Lemma embed_cons_intro :
  forall `(r : s ->> t, q : u ->> t, p : t [>] v, o : t [>] w),
    r <= q ->
    step_eq p o ->
    Cons r p <= Cons q o.
Proof.
intros.
apply (@Embed_Cons u w (Cons q o) s (inl _ tt) r); assumption.
Qed.

Lemma embed_lim_right :
  forall `(r : s ->> t, f : (forall n, u ->> ts n), c : converges ts v) n,
    r <= f n ->
    r <= Lim f c.
Proof.
induction r as [t | s t r w p _ | s ts f t c IH]; intros u ts' g v c' n H.
constructor.
dependent destruction H.
apply (@Embed_Cons u v (Lim g c') s (existT (fun n => pred_type (g n)) n i) r); assumption.
constructor.
intro m.
apply (IH m u ts' g v c' n).
dependent destruction H.
trivial.
Qed.

Lemma embed_refl :
  forall `(r : s ->> t), r <= r.
Proof.
induction r as [t | s t r u p IH | s ts f t c IH].
constructor.
apply Embed_Cons with (q := Cons r p) (i := inl (pred_type r) tt).
assumption.
apply step_eq_refl.
constructor.
intro n.
apply embed_lim_right with n.
apply IH.
Qed.

Lemma embed_trans :
  forall `(r : s ->> t, q : u ->> v, x : w ->> z),
    r <= q ->
    q <= x ->
    r <= x.
Proof.
intros s t r u v q w z x H1.
revert w z x.
induction H1 as [s u v q | u v q s i r t p H IH Hp | s ts f t c u v q H IH]; intros w z x H2.
constructor.
induction H2 as [u w z x | w z x u j q v o H' IH' Ho | u ts' f v c' w z x H' IH'].
destruct i.
destruct i as [[] | i']; simpl in * |- *.
apply Embed_Cons.
apply IH.
assumption.
apply step_eq_trans with (x[1 j]) v o.
assumption.
assumption.
apply embed_pred_right with j.
apply IH'; assumption.
destruct i as [n i]; simpl in * |- *.
apply (IH' n i r p H Hp IH).
constructor.
intro n.
exact (IH n w z x H2).
Qed.

(** This lemma is surprisingly hard to prove directly due to complexities
   with dependent types. Fortunately we can use our results on ordinals with
   the length of rewrite sequences to make a shortcut. *)
Lemma embed_not_cons :
  forall `(r : s ->> t, p : t [>] u),
    ~ Cons r p <= r.
Proof.
intros s t r u p H.
assert (H1 := embed_length H).
contradict H1.
apply ord_le_not_succ.
Qed.

Lemma embed_not_pred_right_strong :
  forall `(r : s ->> t, q : u ->> v, i : pred_type r),
    r <= q ->
    ~ q <= r[seq i].
Proof.
induction r as [t | s t r w p IH | s ts f t c IH]; intros u v q i H1 H2.
destruct i.
destruct i as [[] | i]; simpl in H2.
apply (embed_not_cons (embed_trans H1 H2)).
exact (IH u v q i (embed_cons_left H1) H2).
destruct i as [n i]; simpl in H2.
dependent destruction H1.
exact (IH n u v q i (H n) H2).
Qed.

Lemma embed_not_pred_right :
  forall `(r : s ->> t, i : pred_type r),
    ~ r <= r[seq i].
Proof.
intros.
apply embed_not_pred_right_strong.
apply embed_refl.
Qed.

Lemma embed_strict_cons_right :
  forall `(r : s ->> t, q : u ->> v, p : v [>] w),
    r < q ->
    r < Cons q p.
Proof.
intros s t r u v q w p.
destruct 1 as [i H].
exists (inl (pred_type q) tt).
apply embed_pred_right with i.
assumption.
Qed.

Lemma embed_strict_embed :
  forall `(r : s ->> t, q : u ->> v),
    r < q ->
    r <= q.
Proof.
intros s t r u v q.
destruct 1 as [i H].
apply embed_pred_right with i.
assumption.
Qed.

Lemma embed_strict_trans :
  forall `(r : s ->> t, q : u ->> v, x : w ->> z),
    r < q ->
    q < x ->
    r < x.
Proof.
intros s t r u v q w z x.
destruct 1 as [i Hi].
destruct 1 as [j Hj].
exists j.
apply embed_trans with u v q; [apply embed_pred_right with i |]; assumption.
Qed.

(** Well-formed rewrite sequences have limit functions [f] where [n < m]
   implies that [f n] is strictly embedded in [f m]. *)
Fixpoint wf s t (r : s ->> t) : Prop :=
  match r with
  | Nil _          => True
  | Cons _ _ q _ _ => wf q
  | Lim _ _ f _ _  =>
    (forall n, wf (f n)) /\
    forall n m, (n < m)%nat -> f n < f m
  end.

(** The following convergence definitions are not at all useful. It is
   unclear whether there exist more natural translations of convergence
   to our representation of rewrite sequences. We define some lemmas on
   these definitions below, but have not been able to really work with
   them. *)

(** Weakly convergent sequences have limit functions [f] where for
   any depth [d], from some [n], the end term of [r] is equal up to
   depth [d] where [f n <= r] and [r] is contained in the limit. *)
Fixpoint weakly_convergent `(r : s ->> t) : Prop :=
  match r with
  | Nil _          => True
  | Cons _ _ q _ _ => weakly_convergent q
  | Lim _ _ f t _  =>
    (forall n, weakly_convergent (f n)) /\
    forall d, exists n, forall j,
      f n <= r[seq j] ->
      term_eq_up_to d (r[1 j]) t
  end.

(** Strongly convergent sequences have limit functions [f] where for
   any depth [d], from some [n], the step after [r] is below depth
   [d] where [f n <= r] and [r] is contained in the limit. *)
Fixpoint strongly_convergent `(r : s ->> t) : Prop :=
  weakly_convergent r /\
  match r with
  | Nil _          => True
  | Cons _ _ q _ _ => strongly_convergent q
  | Lim _ _ f t _  =>
    (forall n, strongly_convergent (f n)) /\
    forall d, exists n, forall j,
      f n <= r[seq j] ->
      (depth (r[stp j]) > d)%nat
  end.

(** We should probably be able to prove that [weakly_converent] implies
   [strongly_converent]. Note that this is not true in the traditional
   theory of infinitary rewriting, the relevant difference is that we
   have a condition in the definition of rewrite sequences. *)

Fixpoint all_terms_eq_up_to d `(r : s ->> t) u : Prop :=
  match r with
  | Nil s          => term_eq_up_to d s u
  | Cons _ _ q t _ => all_terms_eq_up_to d q u /\ term_eq_up_to d t u
  | Lim _ _ f t _  =>
    (forall n, all_terms_eq_up_to d (f n) u) /\ term_eq_up_to d t u
  end.

Lemma all_terms_eq_up_to_0 :
  forall `(r : s ->> t, u : term),
    all_terms_eq_up_to 0 r u.
Proof.
induction r as [t | s t r v p IH | s ts f t c IH]; simpl; intro q.
constructor.
split.
apply IH.
constructor.
split.
intro n; apply IH.
constructor.
Qed.

(** Predicate saying that a rewrite sequence is finite. This is useful to
   prove certain properties via a shortcut.

   Maybe it's cleaner to define this via the length of the rewrite
   sequence? *)
Fixpoint finite `(r : s ->> t) : Prop :=
  match r with
  | Nil _          => True
  | Cons _ _ q _ _ => finite q
  | Lim _ _ f t c  => False
  end.

(** Finite rewrite sequences are well-formed. *)
Lemma wf_finite :
  forall `(r : s ->> t),
    finite r ->
    wf r.
Proof.
induction r as [t | s t r u p IH | s ts f t c IH]; intro H.
exact I.
apply IH.
assumption.
elim H.
Qed.

(** Finite rewrite sequences are weakly convergent. *)
Lemma weakly_convergent_finite :
  forall `(r : s ->> t),
    finite r ->
    weakly_convergent r.
Proof.
induction r as [t | s t r u p IH | s ts f t c IH]; intro H.
exact I.
apply IH.
assumption.
elim H.
Qed.

(** [snoc] prepends (not appends) a rewrite step to a rewrite sequence. It
   is analoguous to 1 + alpha on ordinals.

   We define [snoc] via an auxiliary function [snoc_rec] to escape some
   type-checker problems (due to [snoc] being recursive in its right
   argument). *)

Fixpoint snoc_rec (s t u : term) (r : t ->> u) : s [>] t -> s ->> u :=
  match r in t ->> u return s [>] t -> s ->> u with
  | Nil _          => fun p => Cons (Nil s) p
  | Cons _ _ q _ o => fun p => Cons (snoc_rec q p) o
  | Lim _ _ f u c  => fun p => Lim (fun o => snoc_rec (f o) p) c
  end.

Definition snoc `(p : s [>] t, r : t ->> u) : s ->> u := snoc_rec r p.

Lemma all_terms_eq_up_to_snoc :
  forall d `(p : s [>] t, r : t ->> u, v : term),
    term_eq_up_to d s v ->
    all_terms_eq_up_to d r v ->
    all_terms_eq_up_to d (snoc p r) v.
Proof.
induction r as [u | t u r w o IH | t us f u c IH]; simpl; intros v Hs Hr.
split; assumption.
split.
apply IH.
assumption.
apply Hr.
apply Hr.
split.
intro n.
apply IH.
assumption.
apply Hr.
apply Hr.
Qed.

Lemma embed_snoc_right :
  forall `(r : s ->> t, p : u [>] s),
    r <= snoc p r.
Proof.
induction r as [s | s t r v o IH | s ts f t c IH]; intros u p; simpl.
constructor.
apply embed_cons_intro.
apply IH.
apply step_eq_refl.
constructor.
intro n.
apply embed_lim_right with n.
apply IH.
Qed.

Lemma snoc_embed :
  forall `(p : s [>] t, r : t ->> u, q : t ->> v),
    r <= q ->
    snoc p r <= snoc p q.
Proof.
(** This is a very ad-hoc and hairy proof. *)
intros s t p u r v q H.
dependent induction H.
induction q as [t | t v q w o IH | t vs f v c IH]; simpl.
apply embed_refl.
apply embed_cons_right; simpl in IH.
trivial.
apply embed_lim_right with 0; simpl in IH |- *.
trivial.
induction q as [w | w v q z o IH | w vs f v c IH]; simpl.
destruct i.
destruct i as [[] | i].
simpl.
change (Cons (snoc p r) (Cons (snoc p q) p0 [stp inl _ tt]) <= Cons (snoc p q) o).
apply (@Embed_Cons s z (Cons (snoc p q) o) s (inl _ tt) (snoc p r)).
simpl. simpl in IH. simpl in IHembed.
apply IHembed.
assumption.
assumption.
simpl in H. simpl in IH. simpl in IHembed. fold (@pred_type t v) in i.
apply embed_cons_right.
apply IH.
assumption.
assumption.
trivial.
destruct i as [n i].
simpl.
apply embed_lim_right with n.
simpl. simpl in IHembed. simpl in H. simpl in r. fold (pred_type (f n)) in i.
apply IH.
assumption.
assumption.
assumption.
simpl.
constructor.
simpl.
intro n.
apply H0.
assumption.
Qed.

Lemma snoc_embed_strict :
  forall `(p : s [>] t, r : t ->> u, q : t ->> v),
    r < q ->
    snoc p r < snoc p q.
Proof.
intros s t p u r v q H.
unfold embed_strict; destruct H as [i H].
induction q as [t | t v q w o _ | t vs f v c IH]; simpl.
destruct i.
exists (inl _ tt); simpl.
apply snoc_embed.
destruct i as [[] | i]; simpl in H.
assumption.
apply embed_pred_right with i.
assumption.
destruct i as [n i]; simpl in H; fold (pred_type (f n)) in i.
specialize IH with n p r i.
destruct IH as [j IH].
assumption.
exists (existT (fun n => pred_type (snoc p (f n))) n j).
assumption.
Qed.

Lemma embed_not_snoc_nil :
  forall `(p : s [>] t, r : t ->> u) v,
    ~ snoc p r <= Nil v.
Proof.
induction r as [u | t u r w o IH | t us f u c IH]; simpl; intros v H.
dependent destruction H.
elim i.
dependent destruction H.
elim i.
dependent destruction H.
specialize H with 0.
contradict H.
apply IH.
Qed.

Lemma embed_snoc_elim :
  forall `(p : s [>] t, r : t ->> u, q : t ->> v),
    snoc p r <= snoc p q ->
    r <= q.
Proof.
induction r as [u | t u r w o IH | t us f u c IH]; simpl; intros v q H.
constructor.
dependent destruction H.
induction q.
destruct i as [[] | []].
contradict H.
apply embed_not_snoc_nil.
destruct i as [[] | i]; simpl in * |- *.
apply embed_cons_intro.
apply IH with p.
assumption.
assumption.
fold snoc_rec in i.
apply embed_cons_right.
apply IHq; assumption.
destruct i as [n i].
apply embed_lim_right with n.
simpl. (* This is pretty weird, because nothing changes... *)
apply H1; assumption.
constructor.
intro n.
apply IH with p.
dependent destruction H.
apply H.
Qed.

Lemma snoc_finite :
  forall `(p : s [>] t, r : t ->> u),
    finite r ->
    finite (snoc p r).
Proof.
induction r as [u | t u r v o IH | t us f u c IH]; simpl; intro H.
exact I.
apply IH.
assumption.
elim H.
Qed.

Lemma snoc_wf :
  forall `(p : s [>] t, r : t ->> u),
    wf r ->
    wf (snoc p r).
Proof.
induction r as [u | t u r v o IH | t us f u c IH]; simpl.
trivial.
apply IH.
intros [H1 H2].
split.
intro n.
apply IH.
apply H1.
intros n m H.
apply snoc_embed_strict.
apply H2.
assumption.
Qed.

Lemma snoc_weakly_convergent_helper :
  forall d x `(p : s [>] t, r : t ->> u, q : t ->> v, j : pred_type (snoc p q)),
    snoc p r <= snoc p q [seq j] ->
    exists i : pred_type q,
      r <= q[seq i] /\
      (term_eq_up_to d (q[1 i]) x ->
        term_eq_up_to d (snoc p q [1 j]) x).
Proof.
induction q as [v | t v q w o IH | t vs f v c IH]; simpl; intros j H.
destruct j as [[] | []].
contradict H.
apply embed_not_snoc_nil.
destruct j as [[] | j].
simpl in H.
exists (inl _ tt). simpl.
split.
apply embed_snoc_elim with p.
assumption.
trivial.
specialize IH with p r j.
destruct IH as [i H1].
assumption.
exists (inr _ i).
assumption.
destruct j as [n j].
specialize IH with n p r j.
destruct IH as [i H1].
assumption.
exists (existT (fun n => pred_type (f n)) n i).
assumption.
Qed.

Lemma snoc_weakly_convergent :
  forall `(p : s [>] t, r : t ->> u),
    weakly_convergent r ->
    weakly_convergent (snoc p r).
Proof.
intros s t p u r H.
induction r.
trivial.
simpl.
apply IHr.
apply H.
split; simpl.
intro n.
apply H0.
apply H.
intro d.
simpl in H.
destruct H as [_ H].
specialize H with d.
destruct H as [n H].
exists n.
intros [m j] H1.
(* this seems a rather strange way of proving *)
destruct (snoc_weakly_convergent_helper d t p (f n) (f m) j) as [i M].
assumption.
specialize H with (existT (fun n => pred_type (f n)) m i).
simpl in H.
apply M.
apply H.
apply M.
Qed.

(** [append] concatenates two rewrite sequences. Like [snoc], it is recursive
   in its right argument and defined via a [append_rec] helper function. It
   is the analogue of [add] on ordinals. *)

Fixpoint append_rec (s t u : term) (q : t ->> u) : s ->> t -> s ->> u :=
  match q in t ->> u return s ->> t -> s ->> u with
  | Nil t0         => fun r => r
  | Cons _ _ q _ p => fun r => Cons (append_rec q r) p
  | Lim _ _ f u c  => fun r => Lim (fun o => append_rec (f o) r) c
  end.

Definition append `(r : s ->> t, q : t ->> u) : s ->> u := append_rec q r.

Lemma append_length :
  forall `(r : s ->> t, q : t ->> u),
    (length (append r q) == add (length r) (length q)) % ord.
Proof.
induction q as [u | t u q v p IH | t us f u c IH]; simpl.
apply ord_eq_refl.
split.
apply Ord_le_Succ with (inl (pd_type (add (length r) (length q))) tt).
apply (IH r).
apply Ord_le_Succ with (inl (pd_type (length (append r q))) tt).
apply (IH r).
split; constructor; intro n; apply ord_le_limit_right with n; apply (IH n r).
Qed.

Lemma embed_append_right :
  forall `(r : s ->> t, q : t ->> u),
    r <= append r q.
Proof.
induction q as [u | t u q v p IH | t us f u c IH]; simpl.
apply embed_refl.
apply embed_cons_right.
apply IH.
apply embed_lim_right with 0.
apply IH.
Qed.

Lemma append_embed :
  forall `(r : s ->> t, q : t ->> u, z : t ->> v),
    q <= z ->
    append r q <= append r z.
Proof.
(** So this proof is a verbatim copy of [snoc_embed] an thus is also quite
   hairy and ad-hoc.
   There should be a way to at least not repeat ourselves here. The same
   goes for [snoc_embed_strict] and [append_embed_strict] by the way. *)
intros s t r u q v z H.
dependent induction H.
induction z as [t | t v z w o IH | t vs f v c IH]; simpl.
apply embed_refl.
apply embed_cons_right; simpl in IH.
trivial.
apply embed_lim_right with 0; simpl in IH |- *.
trivial.
induction z as [w | w v z x o IH | w vs f v c IH]; simpl.
destruct i.
destruct i as [[] | i].
simpl.
change (Cons (append r r0) (Cons (append r z) p [stp inl _ tt]) <= Cons (append r z) o).
apply (@Embed_Cons s x (Cons (append r z) o) s (inl _ tt) (append r r0)).
simpl. simpl in IH. simpl in IHembed.
apply IHembed.
assumption.
assumption.
simpl in H. simpl in IH. simpl in IHembed. fold (@pred_type t v) in i.
apply embed_cons_right.
apply IH; assumption.
destruct i as [n i].
simpl.
apply embed_lim_right with n.
simpl. simpl in IHembed. simpl in H. simpl in r. fold (pred_type (f n)) in i.
apply IH; assumption.
simpl.
constructor.
simpl.
intro n.
apply H0.
assumption.
Qed.

Lemma append_embed_strict :
  forall `(r : s ->> t, q : t ->> u, z : t ->> v),
    q < z ->
    append r q < append r z.
Proof.
intros s t r u q v z H.
unfold embed_strict; destruct H as [i H].
induction z as [t | t v z w o _ | t vs f v c IH]; simpl.
destruct i.
exists (inl _ tt); simpl.
apply append_embed.
destruct i as [[] | i]; simpl in H.
assumption.
apply embed_pred_right with i.
assumption.
destruct i as [n i]; simpl in H; fold (pred_type (f n)) in i.
specialize IH with n r q i.
destruct IH as [j IH].
assumption.
exists (existT (fun n => pred_type (append r (f n))) n j).
assumption.
Qed.

Lemma append_finite :
  forall `(r : s ->> t, q : t ->> u),
    finite r ->
    finite q ->
    finite (append r q).
Proof.
induction q as [u | t u q v p IH | t us f u c IH]; simpl; intros H1 H2.
assumption.
apply IH; assumption.
elim H2.
Qed.

Lemma append_wf :
  forall `(r : s ->> t, q : t ->> u),
    wf r ->
    wf q ->
    wf (append r q).
Proof.
induction q as [u | t u q v p IH | t us f u c IH]; simpl.
trivial.
apply IH.
intros G [H1 H2].
split.
intro n.
apply IH.
assumption.
apply H1.
intros n m H.
apply append_embed_strict.
apply H2.
assumption.
Qed.

Lemma pred_append :
  forall `(r : s ->> t, q : t ->> u, i : pred_type r),
    exists j : pred_type (append r q),
      append r q [j] = r[i].
Proof.
induction q as [u | t u q v p IH | t us f u c IH]; simpl; intro i.
exists i.
reflexivity.
destruct (IH r i) as [j H].
exists (inr _ j).
assumption.
destruct (IH 0 r i) as [j H].
exists (existT (fun n => pred_type (append r (f n))) 0 j).
assumption.
Qed.

Lemma embed_not_append_pred_left :
  forall `(r : s ->> t, q : t ->> u, j : pred_type r),
    ~ append r q <= r[seq j].
Proof.
induction q; simpl; intros i H1.
contradict H1.
apply embed_not_pred_right.
dependent destruction H1.
destruct (pred_trans i i0) as [j H2].
specialize IHq with r j.
apply IHq.
rewrite H2.
assumption.
dependent destruction H1.
specialize H0 with 0.
contradict H0.
apply H.
Qed.

(** The infinitary unique normal forms property (UN-inf).

   Note that this defines uniqueness of normal forms with respect to
   rewriting, not the more general unique normal forms property. *)

Definition unique_normal_forms : Prop :=
  forall t u v (r : t ->> u) (q : t ->> v),
    wf r ->
    wf q ->
    normal_form u ->
    normal_form v ->
    u [~] v.

End TRS.

Implicit Arguments normal_form [F X].
Implicit Arguments critical_pair [F X].