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.


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.


Require Import RGref.DSL.DSL.
Require Import RGref.DSL.Concurrency.
Require Import RGref.DSL.Fields.
Require Import TrieberStack. (* Reuse the node implementation *)

(** Elimination Stack
    We'll roughly follow the paper "A Scalable Lock-free Stack Algorithm"
    by Hendler, Shavit, and Yerushalmi, from SPAA'04. *)
Inductive Op : Set := PUSH | POP.
Inductive  ThreadInfo : Set :=
  | mkTI : nat -> Op -> Node -> nat -> ThreadInfo.
Inductive TIFields : Set := id | op | cell | spin.
Instance ti_ft : FieldTyping ThreadInfo TIFields.
Instance ti_id : FieldType ThreadInfo TIFields id nat :=
{ getF := (fun ti => match ti with mkTI i o c s => i end);
  setF := (fun ti v => match ti with mkTI i o c s => mkTI v o c s end)
}.
Instance ti_op : FieldType ThreadInfo TIFields op Op :=
{ getF := (fun ti => match ti with mkTI i o c s => o end);
  setF := (fun ti v => match ti with mkTI i o c s => mkTI i v c s end)
}.
Instance ti_cell : FieldType ThreadInfo TIFields cell Node :=
{ getF := (fun ti => match ti with mkTI i o c s => c end);
  setF := (fun ti v => match ti with mkTI i o c s => mkTI i o v s end)
}.
Instance ti_spin : FieldType ThreadInfo TIFields spin nat :=
{ getF := (fun ti => match ti with mkTI i o c s => s end);
  setF := (fun ti v => match ti with mkTI i o c s => mkTI i o c v end)
}.

Section Body.

  Parameter size : nat.
  Parameter mypid : nat.
  Parameter pid_size : mypid < size.

  (* Each thread may only modify its own entry in the location array *)
  Definition SingleCellHavoc {n c:nat} {T:Set} (pf:c < n) : hrel (Array n T) :=
    fun (a a':Array n T) (h h':heap) => forall (i:fin n), i=(of_nat_lt pf) \/ array_read a i = array_read a' i.
  Lemma precise_single_cell_havoc : forall n c T (rch:ImmediateReachability T) (pf:c<n),
                                      precise_rel (@SingleCellHavoc n c T pf).
  Proof.
    intros. compute -[of_nat_lt]. intros.
    induction (H1 i); eauto.
  Qed. (* SingleCellHavoc is local *)
  Hint Resolve @precise_single_cell_havoc.

  Inductive ElimStack : Set :=
  | mkES : option (ref{Node|any}[local_imm,local_imm]) ->
           ref{(Array size (option (ref{ThreadInfo|any}[havoc,local_imm])))|any}[havoc,SingleCellHavoc pid_size] ->
           ref{(Array size nat)|any}[havoc,havoc] ->
           ElimStack.
  Inductive ES_fields : Set := stack | location | collision.
  Instance es_ft : FieldTyping ElimStack ES_fields.
  Instance es_stack : FieldType ElimStack ES_fields stack _ :=
  { getF := fun es => match es with mkES st loc col => st end;
    setF := fun es v => match es with mkES st loc col => mkES v loc col end
  }.
  Instance es_loc : FieldType ElimStack ES_fields location _ :=
  { getF := fun es => match es with mkES st loc col => loc end;
    setF := fun es v => match es with mkES st loc col => mkES st v col end
  }.
  Instance es_col : FieldType ElimStack ES_fields collision _ :=
  { getF := fun es => match es with mkES st loc col => col end;
    setF := fun es v => match es with mkES st loc col => mkES st loc v end
  }.
  Print ImmediateReachability.
  Inductive es_reachability : forall T P R G, ref{T|P}[R,G] -> ElimStack -> Prop :=
  | st_reach : forall st loc col,
                 es_reachability _ _ _ _ st (mkES (Some st) loc col)
  | loc_reach : forall st loc col,
                  es_reachability _ _ _ _ loc (mkES st loc col)
  | col_reach : forall st loc col,
                  es_reachability _ _ _ _ col (mkES st loc col).
  Instance reach_es : ImmediateReachability ElimStack :=
  { imm_reachable_from_in := es_reachability }.
  Print Containment.
  Instance cont_es : Containment ElimStack.
  Admitted. (* TODO *)
  Instance fold_es : rel_fold ElimStack.
  Admitted. (* TODO: This is one of those cases where the result of folding
               isn't necessarily valid; if you weaken guarantees of the
               ES interior pointers, you can't compose the results into
               an ES!  In this case we could parameterize ES by
               relations for the pointer members, and then folding would
               work.  But for recursive strucutures like the M&S queue or
               Heller set, this is important.  Might need to go ahead and
               directly specify a field-specific fold, since we're going
               to access these things field-at-a-time anyways.

               Then in general I could build Allocatable, FullDeref, and
               FieldDeref parameterized typeclasses for different use
               cases, and derive those from instances of rel_fold, Containment,
               etc. as appropriate.  This way I can easily have types
               that for example can be accessed field-at-a-time without
               the ability to be accessed all-at-once (like ElimStack) *)

  (* TODO: More precise rely, guarantee, for arrays, ElimStack. *)
  Definition EliminationStack := ref{ElimStack|any}[havoc,havoc].

  Program Definition alloc_es {Γ} (_:unit) : rgref Γ EliminationStack Γ :=
    locarr <- Alloc (new_array size _ None);
    colarr <- Alloc (new_array size _ 0);
    Alloc (mkES None locarr colarr).

  (* TODO: more precise rely, guarantee, predicate for ThreadInfo operations. *)
  Program Definition TryCollision {Γ} (es:EliminationStack) (him:nat) (p:ref{ThreadInfo|any}[havoc,havoc]) (q:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ bool Γ :=
    match p~>op with
    | PUSH => (*@field_cas_core _ _ _ _ _ _ _ _ (es~>location) mypid _ _ (Some q) None _ *)
              fCAS((es~>location)→him, Some q, Some p) (* WTF? where is 'him' scoped in the original paper??? globally? *)
    | POP => res <- fCAS((es~>location)→him, Some q, None);
             if res
             then (_ <- {[p ~~> cell ]}:= (q ~> cell);
                   _ <- {[(es~>location)~~>mypid]}:= @None _;
                   rgret true)
             else rgret false
    end.

  (* Paper uses a type 'ProcessInfo' which appears to be intended to be 'ThreadInfo' *)
  Program Definition FinishCollision {Γ} (es:EliminationStack) (p:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ unit Γ :=
    match (p ~> op) with
    | POP =>
        (*[ @field_read ThreadInfo _ _ _ _ _ _ _ _ _ p cell _ ti_cell ]:= _*)
        (*[ @field_read ThreadInfo _ _ _ _ _ _ _ _ _ p cell _ _ ]:= _*)
        (*[ @field_read _ _ _ _ _ _ _ _ _ _ p cell _ _ ]:= _*)
        _ <- {[ p ~~> cell ]}:= ( ((es ~> location)~>mypid)~>cell );
        {[ (es~>location)~~>mypid ]}:= @None _
    | _ => rgret tt
    end.

  Program Definition LesOP {Γ} (es:EliminationStack) (p:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ unit Γ.
  Admitted.

  Program Definition TryPerformStackOp {Γ} (es:EliminationStack) (p:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ bool Γ :=
    match (p ~> op) with
    | PUSH => (phead <- (es~>stack);
               _ <- {[ (p~>cell)~~>next ]}:= phead;
               fCAS(es → stack, phead, Some _ ) (* Needs to be &p~>cell, but cell is embedded in ThreadInfo atm. Also need Node fields.
                                                   What should the R,G be for the Node ptr in ThreadInfo? We assign to it here, so
                                                   it can't be local_imm.  Later we set cell field of ThreadInfo to null, so
                                                   it should actually be an option of a ref to a Node.

                                                   OH! Or not... Fig. 3 seems to use EMPTY as value-copying the empty node... Line T11 vs. T15,
                                                   and the ThreadInfo def in Fig. 2 has the Cell inline...
                                                 *)
               )
    | POP => (phead <- es~>stack;
              match phead with
              | None => ( _ <- {[ p ~~> cell ]}:= EMPTY;
                          rgret true)
              | Some hd => (
                    pnext <- hd~>next;
                    IF fCAS(es→stack, phead, pnext)
                    THEN (_ <- {[ p ~~> cell ]}:= phead;
                          rgret true)
                    ELSE (_ <- {[ p ~~> cell ]}:= EMPTY;
                          rgref false)
                    )
               end
    end.

  Program Definition StackOp {Γ} (es:EliminationStack) (pInfo:ref{ThreadInfo|any}[havoc,havoc]) : rgref Γ unit Γ :=
    op <- TryPerformStackOp es pInfo;
    if op
    then rgret tt
    else LesOP pInfo.


Require Import POCS.

Require Import OneDiskAPI.
Require Import NbdAPI.
Require Import NbdImpl.

Module nbd := NbdImpl.

Module NBDServer (d : OneDiskAPI).

  Fixpoint read (off:nat) n : proc (bytes (n*blockbytes)) :=
    match n with
    | 0 => Ret bnull
    | S n => b <- d.read off;
              rest <- read (off+1) n;
              Ret (bappend b rest)
    end.

  Fixpoint write (off:nat) (bl : list (bytes blockbytes)) : proc unit :=
    match bl with
    | nil => Ret tt
    | b :: bl' =>
      _ <- d.write off b;
      write (off+1) bl'
    end.

  Theorem read_ok : forall n off, proc_spec (fun (_ : unit) state => {|
      pre := True;
      post := fun r state' => state' = state /\ read_match state off n r;
      recovered := fun _ state' => state' = state
    |}) (read off n) d.recover d.abstr.
  Proof.
    induction n; intros.
    - simpl.
      step_proc.
    - simpl read.

      step_proc.
      step_proc.
      step_proc.

      rewrite bsplit_bappend.
      intuition subst; eauto.
      + destruct (diskGet state off); simpl in *; intuition (subst; eauto).
      + replace (S off) with (off + 1) by lia; auto.
  Qed.

  Theorem write_ok : forall blocks off, proc_spec (fun (_ : unit) state => {|
      pre := True;
      post := fun r state' =>
        r = tt /\ state' = write_upd state off blocks;
      recovered := fun _ state' =>
        exists nwritten,
        state' = write_upd state off (firstn nwritten blocks)
    |}) (write off blocks) d.recover d.abstr.
  Proof.
    induction blocks; intros.
    - simpl.
      step_proc.
      intuition eauto.
      exists 0; simpl; eauto.

    - simpl write.

      step_proc.
      { intuition eauto.
        + exists 0; simpl; auto.
        + exists 1; simpl; auto.
      }
      specialize (IHblocks (off + 1)).
      step_proc.

      + f_equal; lia.

      + intuition.
        exists (S nwritten); simpl.
        f_equal; lia.
  Qed.

  CoFixpoint handle : proc unit :=
    req <- nbd.getRequest;
    match req with
    | Read h off blocks =>
      (* TODO: bounds checks *)
      data <- read off blocks;
      _ <- nbd.sendResponse
        {| rhandle := h; error := ESuccess; data := data; |};
      handle
    | Write h off _ dat =>
      _ <- write off (bsplit_list dat);
      _ <- nbd.sendResponse
        {| rhandle := h; error := ESuccess; data := bnull |};
      handle
    | Flush h =>
      _ <- nbd.sendResponse
        {| rhandle := h; error := ESuccess; data := bnull |};
      handle
    | UnknownOp h =>
      _ <- nbd.sendResponse
        {| rhandle := h; error := EInvalid; data := bnull |};
      handle
    | Disconnect => Ret tt
    end.

  Definition serverLoop : proc unit :=
    _ <- nbd.recover;
    _ <- d.recover;
    handle.

  Definition size : proc nat :=
    d.size.

  Definition init := then_init nbd.init d.init.

End NBDServer.


Require Import ZF ZFpairs ZFsum ZFnats ZFrelations ZFord ZFfix ZFstable.
Require Import ZFlist.
Import ZFrepl.

Section W_theory.

Variable A : set.

Definition path := List A.

Definition tree := power path.

Definition node f :=
  singl Nil ∪ sup A (fun x => replf (f x) (Cons x)).

Lemma text1 X x : ext_fun X (Cons x).
do 2 red; intros; apply couple_morph; auto with *.
Qed.
Lemma text2 f : ext_fun A f -> ext_fun A (fun x => replf (f x) (Cons x)).
do 2 red; intros; apply replf_morph; auto with *.
red; intros; apply couple_morph; trivial.
Qed.
Hint Resolve text1 text2.

Lemma node_def : forall f p,
  ext_fun A f ->
  (p ∈ node f <->
   p == Nil \/ exists2 i, i ∈ A & exists2 p', p' ∈ f i & p == Cons i p').
intros; unfold node.
split; intros.
 apply union2_elim in H0; destruct H0; [left|right].
  apply singl_elim in H0; trivial.

  rewrite sup_ax in H0; auto; destruct H0.
  exists x; trivial.
  rewrite replf_ax in H1; trivial.

 destruct H0; [apply union2_intro1|apply union2_intro2].
  rewrite H0; apply singl_intro.

  destruct H0 as (i,tyi,(p',infi,eqp)).
  rewrite sup_ax; auto.
  exists i; trivial.
  rewrite replf_ax; eauto.
Qed.

Lemma node_tl f i p :
  ext_fun A f ->
  i ∈ A ->
  (Cons i p ∈ node f <-> p ∈ f i).
intros.
rewrite node_def; trivial.
split; intros; eauto with *.
destruct H1 as [abs|(i',tyi,(p',typ',eqp))].
 symmetry in abs; apply discr_mt_pair in abs; contradiction.

 apply couple_injection in eqp; destruct eqp.
 rewrite H2; rewrite (H _ _ H0 H1); trivial.
Qed.

Lemma node_mono f f':
  ext_fun A f ->
  ext_fun A f' ->
  (forall i, i ∈ A -> f i ⊆ f' i) ->
  node f ⊆ node f'.
red; intros.
rewrite node_def in H2|-*; trivial.
destruct H2;[left;trivial|right].
destruct H2 as (i,tyi,(p,typ,eqp)).
exists i; trivial.
exists p; auto.
apply H1; trivial.
Qed.

Lemma node_morph f f' :
  eq_fun A f f' -> node f == node f'.
intros.
assert (e1 := eq_fun_ext _ _ _ H).
assert (e2 := eq_fun_ext _ _ _ (symmetry H)).
apply incl_eq; apply node_mono; trivial; intros.
 rewrite <- (H _ _ H0 (reflexivity _)); reflexivity.
 rewrite <- (H _ _ H0 (reflexivity _)); reflexivity.
Qed.

Lemma node_inv_mono f f' :
  ext_fun A f ->
  ext_fun A f' ->
  node f ⊆ node f' ->
  forall i, i ∈ A -> f i ⊆ f' i.
red; intros.
rewrite <- node_tl in H3; trivial.
apply H1 in H3.
rewrite node_tl in H3; trivial.
Qed.

Lemma node_inj f f' :
  ext_fun A f ->
  ext_fun A f' ->
  node f == node f' ->
  eq_fun A f f'.
red; intros.
apply incl_eq.
 rewrite <- (H0 _ _ H2 H3).
 apply node_inv_mono; trivial.
 rewrite H1; reflexivity.

 rewrite <- (H0 _ _ H2 H3).
 apply node_inv_mono; trivial.
 rewrite H1; reflexivity.
Qed.

Lemma node_typ f :
  ext_fun A f ->
  typ_fun f A tree ->
  node f ∈ tree.
intros.
apply power_intro; intros.
rewrite node_def in H1; trivial.
destruct H1 as [hd|(i,tyi,(p,typ,eqp))].
 rewrite hd; apply Nil_typ.

 rewrite eqp; apply Cons_typ; auto.
 apply power_elim with (2:=typ); auto.
Qed.

Lemma text3 X : ext_fun (cc_arr A X) (fun f => node (cc_app f)).
do 2 red; intros.
apply node_morph.
red; intros; apply cc_app_morph; auto with *.
Qed.
Lemma text4 X f : ext_fun X (cc_app f).
do 2 red; intros; apply cc_app_morph; auto with *.
Qed.
Hint Resolve text3 text4.

(* X a set of trees *)
Definition nodeF X := replf (cc_arr A X) (fun f => node (cc_app f)).

Lemma nodeF_def X t :
  t ∈ nodeF X <-> exists2 f, f ∈ cc_arr A X & t == node (cc_app f).
unfold nodeF.
rewrite replf_ax; auto with *.
Qed.

Instance nodeF_mono : Proper (incl_set ==> incl_set) nodeF.
do 3 red; intros.
rewrite nodeF_def in H0 |- *.
destruct H0.
exists x0; auto.
revert H0; apply cc_prod_covariant; auto with *.
Qed.

Instance nodeF_morph : morph1 nodeF.
Proof Fmono_morph _ nodeF_mono.

Lemma nodeF_typ X : X ⊆ tree -> nodeF X ⊆ tree.
unfold nodeF; red; intros.
rewrite replf_ax in H0; trivial.
destruct H0.
rewrite H1.
apply node_typ; trivial.
red; intros.
apply H.
apply cc_arr_elim with (1:=H0); trivial.
Qed.

Definition trees := Ffix nodeF tree.

(***************************************************************************)

(* No! *)
Definition node x f :=
  sup ts (fun t => replf t (Cons x)).

Lemma node_def : forall x ts p,
  p ∈ node x ts <-> exists2 t, t ∈ ts & exists2 p', p' ∈ t & p == Cons x p'.

Lemma node_inj : forall x x' t t', node x t == node x' t' -> x == x' /\ t == t'.

(* Prefix order on paths *)
Definition leP := exists2 x, x ∈ A & p2 == Cons x p1.
Definition leT t p1 p2 := (p1 ∈ t /\ p2 ∈ t) /\ leP t1 t2.
Lemma leT_node : forall x ts t p1 p2,
  t ∈ ts ->
  leT t p1 p2 ->
  leT (node x ts) (Cons x p1) (Cons x p2).

Lemma node_typ :
  x ∈ A -> ts ⊆ tree -> node x t ∈ tree

Definition nodeF ts := sup A (fun x => replf ts (node x)).

Lemma nodeF_typ : forall ts,
  ts ⊆ tree -> nodeF ts ⊆ tree.

Lemma nodeF_mono : Proper (incl_set ==> incl_set) nodeF.

Lemma nodeF_stable : forall X Y,
  X ⊆ tree ->
  Y ⊆ tree ->
  nodeF (X ∩ Y) == nodeF X ∩ nodeF Y.

Definition trees := Ffix tree nodeF.

 sup ts (fun t => replf A (fun

Definition wftree t := well_founded (leT t).

Definition trees := subset (power tree) wftree.

Lemma node_typ_wf :
  x ∈ A -> ts ∈ tress -> wftree (node x t)

Lemma wft_constr :

Variable F : set -> set.
Hypothesis Fmono : Proper (incl_set ==> incl_set) F.
Hypothesis Fstab : stable F.

Let Fm : morph1 F.
apply Fmono_morph; trivial.
Qed.

Variable Fdom : set -> set.
Hypothesis Fdm : morph1 Fdom.
Hypothesis Fds : forall X x, x ∈ F X -> Fdom x ⊆ A.

Variable Fsub : set -> set -> set.
Hypothesis Fsm : morph2 Fsub.
Hypothesis Fstyp : forall X x i, x ∈ F X -> i ∈ Fdom x -> Fsub x i ∈ X.

(* The construction domain and the constructor *)
Definition Wdom := power (List A).

Definition Wsup x :=
  singl Nil ∪ sup (Fdom x) (fun i => replf (Fsub x i) (fun p => Cons i p)).

Instance Wsup_morph : Proper (eq_set ==> eq_set) Wsup.
do 2 red; intros.
unfold Wsup.
apply union2_morph; auto with *.
apply sup_morph; auto with *.
red; intros.
apply replf_morph_raw; auto.
 apply Fsm; trivial.

 red; intros.
 apply couple_morph; trivial.
Qed.

Lemma wext1 : forall i y,
  ext_fun y (fun p => Cons i p).
do 2 red; intros.
rewrite H0; reflexivity.
Qed.

Lemma wext2 : forall X f,
  ext_fun X (fun y =>
     replf (Fsub f y) (fun p => Cons y p)).
do 2 red; intros.
apply replf_morph_raw; auto.
 rewrite H0; reflexivity.

 red; intros.
 rewrite H0; rewrite H1; reflexivity.
Qed.
Hint Resolve wext1 wext2.

Lemma Wsup_def :
  forall x p,
  (p ∈ Wsup x <->
   p == Nil \/
   exists2 i, i ∈ Fdom x &
   exists2 q, q ∈ Fsub x i &
   p == Cons i q).
intros.
unfold Wsup.
split; intros.
 apply union2_elim in H; destruct H;[left|right].
  apply singl_elim in H; trivial.

  rewrite sup_ax in H; trivial.
  destruct H as (i,?,?); exists i; trivial.
  rewrite replf_ax in H0; trivial.

 destruct H as [eqp|(i,?,(q,?,eqp))]; rewrite eqp; clear eqp.
  apply union2_intro1.
  apply singl_intro.

  apply union2_intro2.
  rewrite sup_ax; trivial.
  exists i; trivial.
  rewrite replf_ax; trivial.
  exists q; auto with *.
Qed.

Lemma Wsup_hd_prop : forall x, Nil ∈ Wsup x.
intros.
unfold Wsup.
apply union2_intro1.
apply singl_intro.
Qed.

Lemma Wsup_tl_prop : forall i l x,
  x ∈ F Wdom ->
  (Cons i l ∈ Wsup x <-> i ∈ Fdom x /\ l ∈ Fsub x i).
intros.
split; intros.
 apply union2_elim in H0; destruct H0.
  apply singl_elim in H0.
  symmetry in H0.
  apply discr_mt_pair in H0; contradiction.

  rewrite sup_ax in H0; trivial.
  destruct H0.
  rewrite replf_ax in H1; trivial.
  destruct H1.
  apply couple_injection in H2; destruct H2.
  rewrite H2; split; trivial.
  rewrite H3; trivial.

 destruct H0.
 unfold Wsup.
 apply union2_intro2.
 rewrite sup_ax; trivial.
 exists i; trivial.
 rewrite replf_ax; trivial.
 exists l; auto with *.
Qed.
(*
Lemma Wsup_inj : forall x x',
  x ∈ F Wdom ->
  x' ∈ F Wdom ->
  Wsup x == Wsup x' -> x == x'.
intros.
assert (fst x == fst x').
 generalize (Wsup_hd_prop (fst x) x); intro.
 generalize (Wsup_hd_prop (fst x) x'); intro.
 apply H3.
 rewrite <- H1.
 apply H2.
 reflexivity.
assert (snd x == snd x').
 specialize cc_eta_eq with (1:=tys _ _ H); intros.
 specialize cc_eta_eq with (1:=tys _ _ H0); intros.
 rewrite H3; rewrite H4.
 apply cc_lam_ext.
  apply Bmorph; trivial.

  red; intros.
  assert (x'0 ∈ A (fst x')).
   rewrite <- H6; rewrite <- H2; trivial.
  assert (cc_app (snd x) x0 ⊆ prodcart (List (sup A A)) A).
   red; intros.
   apply power_elim with (2:=H8).
   apply cc_prod_elim with (1:=tys _ _ H); trivial.
  assert (cc_app (snd x') x'0 ⊆ prodcart (List (sup A A)) A).
   red; intros.
   apply power_elim with (2:=H9); trivial.
   apply cc_prod_elim with (1:=tys _ _ H0); trivial.
  generalize (fun z l => Wsup_tl_prop x0 l z _ H); intros.
  generalize (fun z l => Wsup_tl_prop x'0 l z _ H0); intros.
  apply eq_intro; intros.
   generalize (surj_pair _ _ _ (H8 _ H12)); intro.
   rewrite H13.
   apply H11.
   rewrite <- H6; rewrite <- H1.
   apply <- H10.
   rewrite <- H13; auto.

   generalize (surj_pair _ _ _ (H9 _ H12)); intro.
   rewrite H13.
   apply H10.
   rewrite H1; rewrite H6.
   apply <- H11.
   rewrite <- H13; auto.
apply subset_elim1 in H.
apply subset_elim1 in H0.
rewrite (surj_pair _ _ _ H).
rewrite (surj_pair _ _ _ H0).
rewrite H2; rewrite H3; reflexivity.
Qed.
*)
Lemma Wsup_typ_gen : forall x,
  x ∈ F Wdom ->
  Wsup x ∈ Wdom.
intros.
apply power_intro; intros.
rewrite Wsup_def in H0.
destruct H0 as [eqz|(i,?,(q,?,eqz))]; rewrite eqz; clear z eqz.
 apply Nil_typ.

 assert (q ∈ List A).
  apply power_elim with (2:=H1); auto.
 apply Cons_typ; auto.
 revert H0; apply (Fds Wdom); trivial.
Qed.

(* The type operator on the construction domain *)
Definition Wf X := replf (F X) Wsup.

Lemma wfext1 : forall X, ext_fun (F X) Wsup.
do 2 red; intros.
rewrite H0; reflexivity.
Qed.
Hint Resolve wfext1.

Lemma Wf_intro : forall x X,
  x ∈ F X ->
  Wsup x ∈ Wf X.
intros.
unfold Wf.
rewrite replf_ax; trivial.
exists x; auto with *.
Qed.

Lemma Wf_elim : forall a X,
  a ∈ Wf X ->
  exists2 x, x ∈ F X &
  a == Wsup x.
intros.
unfold Wf in H.
rewrite replf_ax in H; trivial.
Qed.

Lemma Wf_mono : Proper (incl_set ==> incl_set) Wf.
do 3 red; intros.
apply Wf_elim in H0; destruct H0 as (f,?,?).
rewrite H1; apply Wf_intro; trivial.
clear H1; revert f H0.
apply Fmono; trivial.
Qed.
Hint Resolve Wf_mono Fmono_morph.

Lemma Wf_typ : forall X,
  X ⊆ Wdom -> Wf X ⊆ Wdom.
red; intros.
apply Wf_elim in H0; destruct H0 as (x,?,?).
rewrite H1.
apply Wsup_typ_gen; trivial.
clear H1; revert x H0.
apply Fmono; trivial.
Qed.
Hint Resolve Wf_typ.

Lemma Wf_stable : forall X,
  X ⊆ power Wdom ->
  inter (replf X Wf) ⊆ Wf (inter X).
red; intros X Xty z H.
unfold Wf.
assert (forall a, a ∈ X -> z ∈ Wf a).
 intros.
 apply inter_elim with (1:=H).
 rewrite replf_ax.
 2:red;red;intros;apply Fmono_morph; trivial.
 exists a; auto with *.
rewrite replf_ax.
2:red;red;intros;apply Wsup_morph; trivial.
destruct inter_wit with (2:=H).
 apply Fmono_morph; trivial.
assert (z ∈ Wf x); auto.
apply Wf_elim in H2.
destruct H2.
exists x0; auto.
apply Fstab.
apply inter_intro.
 intros.
 rewrite replf_ax in H4.
 2:apply morph_is_ext; trivial.
 destruct H4.
 rewrite H5; clear y H5.
 specialize H0 with (1:=H4).
 apply Wf_elim in H0; destruct H0.
 admit.
(* rewrite H3 in H5; apply Wsup_inj in H5.
  rewrite H5; trivial.

  revert H2; apply W_F_mono.
  red; intros; apply power_elim with (1:=Xty _ H1); trivial.

  revert H0; apply W_F_mono.
  red; intros; apply power_elim with (1:=Xty _ H4); trivial.
*)
 exists (F x).
 rewrite replf_ax.
 2:apply morph_is_ext; trivial.
 exists x; auto with *.
Qed.
Hint Resolve Wf_stable.

(* The fixpoint *)

Definition W := Ffix Wf Wdom.

Lemma Wtyp : W ⊆ Wdom.
apply Ffix_inA.
Qed.

Lemma Wi_W : forall o, isOrd o -> TI Wf o ⊆ W.
apply TI_Ffix; auto.
Qed.

Lemma TI_Wf_elim : forall a o,
  isOrd o ->
  a ∈ TI Wf o ->
  exists2 o', lt o' o &
  exists2 x, x ∈ F (TI Wf o') &
  a == Wsup x.
intros.
apply TI_elim in H0; trivial.
2:apply Fmono_morph; trivial.
destruct H0.
apply Wf_elim in H1.
eauto.
Qed.

Lemma Wsup_typ : forall o x,
  isOrd o ->
  x ∈ F (TI Wf o) ->
  Wsup x ∈ TI Wf (osucc o).
intros.
rewrite TI_mono_succ; auto.
apply Wf_intro; trivial.
Qed.
(*
Lemma W_ind : forall (P:set->Prop),
  Proper (eq_set ==> iff) P ->
  (forall o' x, isOrd o' -> x ∈ W_F (TI Wf o') ->
   (forall i, i ∈ A (fst x) -> P (cc_app (snd x) i)) -> P (Wsup x)) ->
  forall a, a ∈ W -> P a.
intros.
unfold W in H1; rewrite Ffix_def in H1; auto.
destruct H1.
revert a H2.
apply isOrd_ind with (2:=H1); intros.
apply TI_Wf_elim in H5; trivial.
destruct H5 as (o',?,(x',?,?)).
rewrite H7; clear a H7.
apply H0 with o'; trivial.
 apply isOrd_inv with y; trivial.

 intros.
 apply H4 with o'; trivial.
 apply cc_prod_elim with (1:=tys _ _ H6); trivial.
Qed.
*)
(* The closure ordinal of W *)
  Definition W_ord := Ffix_ord Wf Wdom.

  Lemma W_o_o : isOrd W_ord.
apply Ffix_o_o; auto.
Qed.
Hint Resolve W_o_o.

  Lemma W_post : forall a,
   a ∈ W ->
   a ∈ TI Wf W_ord.
apply Ffix_post; eauto.
Qed.

  Lemma W_eqn : W == Wf W.
apply Ffix_eqn; eauto.
Qed.

  Lemma Fix_reached : TI F (osucc W_ord) ⊆ TI F W_ord.

(*
Parameter hd : set -> set.
Parameter tl : set -> set -> set.
Parameter hd_eq : forall x, hd (Wsup x) == fst x.

Parameter Wf_eta : forall X x,
  X ⊆ Wdom ->
  x ∈ Wf X ->
  x == Wsup (couple (hd x) (cc_lam (A (hd x)) (tl x))).

  Definition trad := Fix_rec Wf Wdom
    (fun g x => couple (hd x)
       (cc_lam (A (hd x)) (fun i => g (tl x i)))).

  Lemma trad_ok : forall o,
    isOrd o ->
    forall x,
    x ∈ TI Wf o ->
    trad x ∈ TI W_F o.
intros o oo.
apply isOrd_ind with (2:=oo); intros.
unfold trad.
rewrite Fr_eqn with (o:=y); auto.
2:admit.
apply TI_Wf_elim in H2; trivial.
destruct H2 as (o',?,(x',?,?)).
apply TI_intro with o'; auto.
 apply Fmono_morph; apply W_F_mono.

 assert (x ∈ Wf (TI Wf o')).
  rewrite <- TI_mono_succ; auto.
  2:apply isOrd_inv with y; trivial.
  rewrite H4; apply Wsup_typ; trivial.
  apply isOrd_inv with y; trivial.
 apply Wf_eta in H5.
 2:admit.
 apply couple_intro_sigma.
  admit.

  admit.

  apply cc_prod_intro; intros.
   admit.
   admit.
  apply H1; trivial.
  admit.
Qed.

  Lemma trad_inj : forall o,
    isOrd o ->
    forall x y, x ∈ TI Wf o ->
    y ∈ TI Wf o ->
    trad x == trad y -> x == y.
intros o oo.
apply isOrd_ind with (2:=oo); intros.
unfold trad in H4.
rewrite Fr_eqn with (o:=y) in H4; auto.
2:admit.
rewrite Fr_eqn with (o:=y) in H4; auto.
2:admit.
apply couple_injection in H4; destruct H4.
rewrite (Wf_eta (TI Wf y)).
2:admit.
2:admit.
rewrite (Wf_eta (TI Wf y) y0).
2:admit.
2:admit.
apply Wsup_morph.
apply couple_morph; trivial.
apply cc_lam_ext; intros.
 apply Amorph; trivial.

 red; intros.
 generalize (cc_app_morph _ _ H5 _ _ H7).
 rewrite cc_beta_eq; trivial.
 2:admit.
 rewrite cc_beta_eq; trivial.
 2:admit.
 2:rewrite <- H7; rewrite <- H4; trivial.
 apply H1 with (z:=y).
  admit.
  admit.
  admit.
Qed.
*)

End W_theory.