Require Import Coq.Strings.Ascii
        Coq.Bool.Bool
        Coq.Lists.List
        Coq.Structures.OrderedType.

Require Import
        Fiat.BinEncoders.Env.BinLib.Core
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.Compose
        Fiat.BinEncoders.Env.Common.ComposeOpt
        Fiat.BinEncoders.Env.Automation.Solver
        Fiat.BinEncoders.Env.Lib2.WordOpt
        Fiat.BinEncoders.Env.Lib2.NatOpt
        Fiat.BinEncoders.Env.Lib2.StringOpt
        Fiat.BinEncoders.Env.Lib2.EnumOpt
        Fiat.BinEncoders.Env.Lib2.FixListOpt
        Fiat.BinEncoders.Env.Lib2.SumTypeOpt.

Require Import
        Fiat.Common.SumType
        Fiat.Examples.Tutorial.Tutorial
        Fiat.Examples.DnsServer.DecomposeEnumField
        Fiat.QueryStructure.Automation.AutoDB
        Fiat.QueryStructure.Implementation.DataStructures.BagADT.BagADT
        Fiat.QueryStructure.Automation.IndexSelection
        Fiat.QueryStructure.Specification.SearchTerms.ListPrefix
        Fiat.QueryStructure.Automation.SearchTerms.FindPrefixSearchTerms
        Fiat.Examples.HACMSDemo.DuplicateFree
        Fiat.QueryStructure.Automation.MasterPlan.

Require Import
        Bedrock.Word
        Bedrock.Memory.

Lemma exists_CompletelyUnConstrFreshIdx:
  forall (qs_schema : RawQueryStructureSchema)
    (BagIndexKeys : ilist3 (qschemaSchemas qs_schema))
    (r_o : UnConstrQueryStructure qs_schema)
    (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
  DelegateToBag_AbsR r_o r_n ->
  exists bnd : nat,
  forall idx : Fin.t (numRawQSschemaSchemas qs_schema),
    UnConstrFreshIdx (GetUnConstrRelation r_o idx) bnd.
Proof.
  intros.
  generalize (exists_UnConstrFreshIdx H); clear H.
  remember (GetUnConstrRelation r_o); clear.
  destruct qs_schema; simpl in *.
  clear qschemaConstraints.
  induction numRawQSschemaSchemas; simpl in *; intros.
  - exists 0; intros; inversion idx.
  - revert i IHnumRawQSschemaSchemas H.
    pattern numRawQSschemaSchemas, qschemaSchemas;
      apply Vector.caseS; simpl; intros.
    destruct (IHnumRawQSschemaSchemas
                t
                (fun idx => i (Fin.FS idx))
                (fun idx => H (Fin.FS idx))
             ).
    destruct (H Fin.F1).
    exists (max x x0).
    unfold UnConstrFreshIdx in *; simpl in *; intros.
    pose proof (Max.le_max_l x x0);
      pose proof (Max.le_max_r x x0).
    generalize dependent idx; intro; generalize t i x x0 H0 H1 H3 H4;
      clear; pattern n, idx; apply Fin.caseS; simpl; intros.
    apply H1 in H2; omega.
    apply H0 in H2; omega.
Qed.

Lemma refine_Pick_CompletelyUnConstrFreshIdx
  : forall (qs_schema : RawQueryStructureSchema)
    (BagIndexKeys : ilist3 (qschemaSchemas qs_schema))
    (r_o : UnConstrQueryStructure qs_schema)
    (r_n : IndexedQueryStructure qs_schema BagIndexKeys),
    DelegateToBag_AbsR r_o r_n ->
    forall (bnd : nat),
      (forall (idx : Fin.t (numRawQSschemaSchemas qs_schema)),
          UnConstrFreshIdx (GetUnConstrRelation r_o idx) bnd) ->
      refine {bnd0 : nat | forall idx, UnConstrFreshIdx (GetUnConstrRelation r_o idx) bnd0} (ret bnd).
Proof.
  intros; refine pick val _; eauto.
  reflexivity.
Qed.

Instance Query_eq_word32 : Query_eq (word 32) :=
  {| A_eq_dec := @weq 32 |}.

Global Instance GetAttributeRawTermCounter' {A : Type} {qsSchema}
         {Ridx : Fin.t _}
         {tup : @RawTuple (Vector.nth _ Ridx)}
         {BAidx : _ }
         a
    : (TermAttributeCounter qsSchema (@GetAttributeRaw {| NumAttr := S _;
                                                          AttrList := Vector.cons _ A _ _ |} {|prim_fst := a; prim_snd := tup |} (Fin.FS BAidx)) Ridx BAidx) | 0 := Build_TermAttributeCounter qsSchema _ Ridx BAidx.

Ltac GetAttributeRawTermCounterTac t ::=
     lazymatch goal with
       _ =>
       match goal with
         |- TermAttributeCounter
              ?qs_schema
              (GetAttributeRaw {| prim_fst := ?a;
                             prim_snd := ?tup |} (Fin.FS ?BAidx))
         _ _ =>
    match type of tup with
    | @RawTuple (@GetNRelSchemaHeading _ _ ?Ridx) =>
      apply (@GetAttributeRawTermCounter' _ qs_schema Ridx tup _ a)
    end
    end
  end.

Lemma refineEquiv_Query_Where_And
      {ResultT}
  : forall P P' bod,
    (P \/ ~ P)
    -> refineEquiv (@Query_Where ResultT (P /\ P') bod)
                (Query_Where P (Query_Where P' bod)).
Proof.
  split; unfold refine, Query_Where; intros;
    computes_to_inv; computes_to_econstructor;
      intuition.
  - computes_to_inv; intuition.
  - computes_to_inv; intuition.
  - computes_to_econstructor; intuition.
Qed.

Corollary refineEquiv_For_Query_Where_And
          {ResultT}
          {qs_schema}
  : forall (r : UnConstrQueryStructure qs_schema) idx P P' bod,
    (forall tup, P tup \/ ~ P tup)
    -> refine (For (UnConstrQuery_In
                      r idx
                      (fun tup => @Query_Where ResultT (P tup /\ P' tup) (bod tup))))
              (For (UnConstrQuery_In
                      r idx
                      (fun tup => Where (P tup) (Where (P' tup) (bod tup))))).
Proof.
  intros; apply refine_refine_For_Proper.
  apply refine_UnConstrQuery_In_Proper.
  intro; apply refineEquiv_Query_Where_And; eauto.
Qed.

Lemma refine_If_IfOpt {A B}
  : forall (a_opt : option A) (t e : Comp B),
    refine (If_Then_Else (If_Opt_Then_Else a_opt (fun _ => false) true)
                         t e)
           (If_Opt_Then_Else a_opt (fun _ => e) t).
Proof.
  destruct a_opt; simpl; intros; reflexivity.
Qed.

Global Arguments icons2 _ _ _ _ _ _ _ / .
Global Arguments GetAttributeRaw {heading} !tup !attr .
Global Arguments ilist2_tl _ _ _ _ !il / .
Global Arguments ilist2_hd _ _ _ _ !il / .

Global Opaque If_Opt_Then_Else.
Ltac implement_DecomposeRawQueryStructure :=
  first [ simplify with monad laws; simpl
        | rewrite refine_If_IfOpt
        | match goal with
            |- refine (b <- If_Opt_Then_Else _ _ _; _) _ =>
            etransitivity;
            [ apply refine_If_Opt_Then_Else_Bind
            | simpl; eapply refine_If_Opt_Then_Else_trans;
              intros; set_refine_evar ]
          end
        | match goal with
            H0 : DecomposeRawQueryStructureSchema_AbsR' _ _ _ _ ?r_o ?r_n |- refine _ ?H => unfold H;
                                                                                apply (refine_UnConstrFreshIdx_DecomposeRawQueryStructureSchema_AbsR_Equiv H0 Fin.F1)
          end
        | match goal with
            H0 : DecomposeRawQueryStructureSchema_AbsR' (qs_schema := ?qs_schema) _ _ _ _ ?r_o ?r_n |- refine (Query_For _ ) _ =>
            rewrite (refineEquiv_For_Query_Where_And r_o Fin.F1); eauto
          end
        |
        match goal with
          H0 : DecomposeRawQueryStructureSchema_AbsR' (qs_schema := ?qs_schema) _ _ _ _ ?r_o ?r_n |- refine (Query_For _ ) _ =>
          rewrite (@refine_QueryIn_Where _ qs_schema Fin.F1 _ _ _ _ _ H0 _ _ _ );
          unfold Tuple_DecomposeRawQueryStructure_inj; simpl
        end
        | match goal with
            H0 : DecomposeRawQueryStructureSchema_AbsR' _ _ _ _ ?r_o ?r_n
            |- refine { r_n | DecomposeRawQueryStructureSchema_AbsR' _ _ _ _ _ r_n} _ =>
            first [refine pick val _; [ | eassumption ]
                  | refine pick val _;
                    [ | apply (DecomposeRawQueryStructureSchema_Insert_AbsR_eq H0) ] ]
          end
        ].

Ltac implement_DecomposeRawQueryStructure' H :=
  first [
      simplify with monad laws; simpl
    | rewrite H
    | apply refine_pick_eq'
    | etransitivity;
      [ apply refine_If_Opt_Then_Else_Bind
      | simpl; eapply refine_If_Opt_Then_Else_trans;
        intros; set_refine_evar ] ].

  Lemma GetAttributeRaw_FS
    : forall {A} {heading} (a : A) (tup : @RawTuple heading) n,
      @GetAttributeRaw {| AttrList := Vector.cons _ A _ (AttrList heading) |}
                       {| prim_fst := a; prim_snd := tup |} (Fin.FS n)
    = GetAttributeRaw tup n.
  Proof.
    unfold GetAttributeRaw; simpl; reflexivity.
  Qed.

    Lemma GetAttributeRaw_F1
    : forall {A} {heading} (a : A) (tup : @RawTuple heading),
      @GetAttributeRaw {| AttrList := Vector.cons _ A _ (AttrList heading) |}
                       {| prim_fst := a; prim_snd := tup |} Fin.F1
    = a.
  Proof.
    unfold GetAttributeRaw; simpl; reflexivity.
  Qed.

  Module word_as_OT <: OrderedType.
    Definition t := word 32.
    Definition eq (c1 c2 : t) := c1 = c2.
    Definition lt (c1 c2 : t) := wlt c1 c2.

    Definition eq_dec : forall l l', {eq l l'} + {~eq l l'} := @weq 32 .

    Lemma eq_refl : forall x, eq x x.
    Proof. reflexivity. Qed.

    Lemma eq_sym : forall x y, eq x y -> eq y x.
    Proof. intros. symmetry. eauto. Qed.

    Lemma eq_trans : forall x y z, eq x y -> eq y z -> eq x z.
    Proof. intros. unfold eq in *. rewrite H. rewrite H0. eauto. Qed.

    Lemma lt_trans : forall x y z, lt x y -> lt y z -> lt x z.
    Proof. intros. unfold lt in *. eapply N.lt_trans; eauto. Qed.

    Lemma lt_not_eq : forall x y, lt x y -> ~eq x y.
    Proof.
      intros. unfold eq, lt, wlt in *. intro.
      rewrite <- N.compare_lt_iff in H.
      subst; rewrite N.compare_refl in H; discriminate.
    Qed.

    Lemma compare : forall x y, Compare lt eq x y.
    Proof.
      intros. unfold lt, eq, wlt.
      destruct (N.compare (wordToN x) (wordToN y)) eqn: eq.
      - eapply EQ. apply N.compare_eq_iff in eq; apply wordToN_inj; eauto.
      - eapply LT. abstract (rewrite <- N.compare_lt_iff; eauto).
      - eapply GT. abstract (rewrite <- N.compare_gt_iff; eauto).
    Defined.
End word_as_OT.

Module wordIndexedMap := FMapAVL.Make word_as_OT.

Module wordTreeBag := TreeBag wordIndexedMap.

Ltac BuildQSIndexedBag heading AttrList BuildEarlyBag BuildLastBag k ::=
  lazymatch AttrList with
  | (?Attr :: [ ])%list =>
    let AttrKind := eval simpl in (KindIndexKind Attr) in
        let AttrIndex := eval simpl in (KindIndexIndex Attr) in
            let is_equality := eval compute in (string_dec AttrKind "EqualityIndex") in

                lazymatch is_equality with
                | left _ =>
                  let AttrType := eval compute in (Domain heading AttrIndex) in
                      lazymatch AttrType with
                      | BinNums.N =>
                        k (@NTreeBag.IndexedBagAsCorrectBag
                             _ _ _ _ _ _ _
                             (@CountingListAsCorrectBag
                                (@RawTuple heading)
                                (IndexedTreeUpdateTermType heading)
                                (IndexedTreebupdate_transform heading))
                             (fun x => GetAttributeRaw (heading := heading) x AttrIndex)
                          )
                      | word 32 =>
                        k (@wordTreeBag.IndexedBagAsCorrectBag
                             _ _ _ _ _ _ _
                             (@CountingListAsCorrectBag
                                (@RawTuple heading)
                                (IndexedTreeUpdateTermType heading)
                                (IndexedTreebupdate_transform heading))
                             (fun x => GetAttributeRaw (heading := heading) x AttrIndex)
                          )

                      | BinNums.Z =>
                        k (@ZTreeBag.IndexedBagAsCorrectBag
                             _ _ _ _ _ _ _
                             (@CountingListAsCorrectBag
                                (@RawTuple heading)
                                (IndexedTreeUpdateTermType heading)
                                (IndexedTreebupdate_transform heading))
                             (fun x => GetAttributeRaw (heading := heading) x AttrIndex)
                          )
                      | nat =>
                        k (@NatTreeBag.IndexedBagAsCorrectBag
                             _ _ _ _ _ _ _
                             (@CountingListAsCorrectBag
                                (@RawTuple heading)
                                (IndexedTreeUpdateTermType heading)
                                (IndexedTreebupdate_transform heading))
                             (fun x => GetAttributeRaw (heading := heading) x AttrIndex)
                          )
                      | string =>
                        k (@StringTreeBag.IndexedBagAsCorrectBag
                             _ _ _ _ _ _ _
                             (@CountingListAsCorrectBag
                                (@RawTuple heading)
                                (IndexedTreeUpdateTermType heading)
                                (IndexedTreebupdate_transform heading))
                             (fun x => GetAttributeRaw (heading := heading) x AttrIndex)
                          )
                      end
                | right _ =>
                  BuildLastBag heading AttrList AttrKind AttrIndex k
                end
  | (?Attr :: ?AttrList')%list =>
    let AttrKind := eval simpl in (KindIndexKind Attr) in
        let AttrIndex := eval simpl in (KindIndexIndex Attr) in
            let is_equality := eval compute in (string_dec AttrKind "EqualityIndex") in
                lazymatch is_equality with
                | left _ =>
                  let AttrType := eval compute in (Domain heading AttrIndex) in
                      lazymatch AttrType with
                      | BinNums.N =>
                        BuildQSIndexedBag
                          heading AttrList'
                          BuildEarlyBag BuildLastBag
                          ltac:(fun subtree =>
                                  k (@NTreeBag.IndexedBagAsCorrectBag
                                       _ _ _ _ _ _ _ subtree
                                       (fun x => GetAttributeRaw (heading := heading) x AttrIndex)))
                      | BinNums.Z =>
                        BuildQSIndexedBag
                          heading AttrList'
                          BuildEarlyBag BuildLastBag
                          (fun x => GetAttributeRaw x AttrIndex)
                          ltac:(fun subtree =>
                                  k (@ZTreeBag.IndexedBagAsCorrectBag
                                       _ _ _ _ _ _ _ subtree
                                       (fun x => GetAttributeRaw (heading := heading) x AttrIndex)))
                      | nat =>
                        BuildQSIndexedBag
                          heading AttrList'
                          BuildEarlyBag BuildLastBag
                          ltac:(fun subtree =>
                                  k (@NatTreeBag.IndexedBagAsCorrectBag
                                       _ _ _ _ _ _ _ subtree
                                       (fun x => GetAttributeRaw (heading := heading) x AttrIndex)))
                      | string =>
                        BuildQSIndexedBag
                          heading AttrList'
                          BuildEarlyBag BuildLastBag
                          ltac:(fun subtree =>
                                  k (@StringTreeBag.IndexedBagAsCorrectBag
                                       _ _ _ _ _ _ _ subtree
                                       (fun x => GetAttributeRaw (heading := heading) x AttrIndex)))
                      end
                | right _ =>
                  BuildQSIndexedBag
                    heading AttrList'
                    BuildEarlyBag BuildLastBag
                    ltac:(fun subtree =>
                            BuildEarlyBag
                                 heading AttrList AttrKind AttrIndex subtree k)
                end
  | ([ ])%list =>
    k (@CountingListAsCorrectBag
         (@RawTuple heading)
         (IndexedTreeUpdateTermType heading)
         (IndexedTreebupdate_transform heading))
  end.

  Ltac rewrite_drill ::=
       subst_refine_evar; (first
                             [
                               match goal with
                                 |- refine (b <- If_Opt_Then_Else _ _ _; _) _ =>
                                 etransitivity;
                                 [ apply refine_If_Opt_Then_Else_Bind
                                 | simpl; eapply refine_If_Opt_Then_Else_trans;
                                   intros; set_refine_evar ]
                               end
                             | eapply refine_under_bind_both; [ set_refine_evar | intros; set_refine_evar ]
                             | eapply refine_If_Then_Else; [ set_refine_evar | set_refine_evar ] ] ).

  Ltac implement_insert CreateTerm EarlyIndex LastIndex
       makeClause_dep EarlyIndex_dep LastIndex_dep ::=
    repeat first
           [simplify with monad laws; simpl
           | match goal with
               |- context [(@GetAttributeRaw ?heading {| prim_fst := ?a;
                                                         prim_snd := ?tup |} (Fin.FS ?BAidx)) ] =>
               setoid_rewrite (@GetAttributeRaw_FS
                                 (Vector.hd (AttrList heading))
                                 {| AttrList := Vector.tl (AttrList heading)|} a _ BAidx)
             end
           | match goal with
             | |- context [(@GetAttributeRaw ?heading {| prim_fst := ?a;
                                                         prim_snd := ?tup |} Fin.F1) ] =>
               rewrite (@GetAttributeRaw_F1
                          (Vector.hd (AttrList heading))
                          {| AttrList := Vector.tl (AttrList heading) |} a)
             end
           | setoid_rewrite refine_If_Then_Else_Bind
           | match goal with
               H : DelegateToBag_AbsR ?r_o ?r_n
               |- context[Pick (fun idx => forall Ridx, UnConstrFreshIdx (GetUnConstrRelation ?r_o Ridx) idx)] =>
               let freshIdx := fresh in
               destruct (exists_CompletelyUnConstrFreshIdx _ _ _ _ H) as [? freshIdx];
               rewrite (refine_Pick_CompletelyUnConstrFreshIdx _ _ _ _ H _ freshIdx)
             end
           | implement_Query CreateTerm EarlyIndex LastIndex
                             makeClause_dep EarlyIndex_dep LastIndex_dep
           | progress (rewrite ?refine_BagADT_QSInsert; try setoid_rewrite refine_BagADT_QSInsert); [ | solve [ eauto ] .. ]
           | progress (rewrite ?refine_Pick_DelegateToBag_AbsR; try setoid_rewrite refine_Pick_DelegateToBag_AbsR); [ | solve [ eauto ] .. ] ].

  Ltac choose_data_structures :=
    simpl; pose_string_ids; pose_headings_all;
    pose_search_term;  pose_SearchUpdateTerms;
    match goal with
      |- context [ @Build_IndexedQueryStructure_Impl_Sigs _ ?indices ?SearchTerms _ ] => try unfold SearchTerms
    end; BuildQSIndexedBags' BuildEarlyBag BuildLastBag.

  Ltac insertOne :=
    insertion CreateTerm EarlyIndex LastIndex
              makeClause_dep EarlyIndex_dep LastIndex_dep.

Global Instance cache : Cache :=
  {| CacheEncode := unit;
     CacheDecode := unit;
     Equiv ce cd := True |}.
Global Instance cacheAddNat : CacheAdd cache nat :=
  {| addE ce n := tt;
     addD cd n := tt;
     add_correct ce cd t m := I |}.

Definition transformer : Transformer bin := btransformer.
Global Instance transformerUnit : TransformerUnitOpt transformer bool :=
  {| T_measure t := 1;
     transform_push_opt b t := (b :: t)%list;
     transform_pop_opt t :=
       match t with
       | b :: t' => Some (b, t')
       | _ => None
       end%list
  |}.
abstract (simpl; intros; omega).
abstract (simpl; intros; omega).
abstract (destruct b;
          [ simpl; discriminate
          | intros; injections; simpl; omega ] ).
reflexivity.
reflexivity.
abstract (destruct b; destruct b'; simpl; intros; congruence).
Defined.
Definition Empty : CacheEncode := tt.

  Ltac decompose_EnumField Ridx Fidx :=
    match goal with
      |- appcontext[ @BuildADT (UnConstrQueryStructure (QueryStructureSchemaRaw ?qs_schema)) ]
      =>
      let n := eval compute in (NumAttr (GetHeading qs_schema Ridx)) in
    let AbsR' := constr:(@DecomposeRawQueryStructureSchema_AbsR' n qs_schema ``Ridx ``Fidx id (fun i => ibound (indexb i))
                                                (fun val =>
                                                   {| bindex := _;
                                                      indexb := {| ibound := val;
                                                                   boundi := @eq_refl _ _ |} |})) in hone representation using AbsR'
    end;
      try first [ solve [simplify with monad laws;
                         apply refine_pick_val;
                         apply DecomposeRawQueryStructureSchema_empty_AbsR ]
                | doAny ltac:(implement_DecomposeRawQueryStructure)
                               rewrite_drill ltac:(cbv beta; simpl; finish honing) ];
  simpl; hone representation using (fun r_o r_n => snd r_o = r_n);
    try first [
        solve [simplify with monad laws; apply refine_pick_val; reflexivity ]
      |
      match goal with
        H : snd ?r_o = ?r_n |- _
        => doAny ltac:(implement_DecomposeRawQueryStructure' H)
                        ltac:(rewrite_drill; simpl)
                               ltac:(finish honing)
      end
        ];
    cbv beta; unfold DecomposeRawQueryStructureSchema, DecomposeSchema; simpl.

  Ltac makeEvar T k :=
    let x := fresh in evar (x : T); let y := eval unfold x in x in clear x; k y.

  Ltac shelve_inv :=
    let H' := fresh in
    let data := fresh in
    intros data H';
    repeat destruct H';
    match goal with
    | H : ?P data |- ?P_inv' =>
      is_evar P;
      let P_inv' := (eval pattern data in P_inv') in
      let P_inv := match P_inv' with ?P_inv data => P_inv end in
      let new_P_T := type of P in
      makeEvar new_P_T
               ltac:(fun new_P =>
                       unify P (fun data => new_P data /\ P_inv data)); apply (Logic.proj2 H)
    end.

  Ltac solve_data_inv :=
    first [ intros; exact I
          | solve
              [ let data := fresh in
                let H' := fresh in
                let H'' := fresh in
                intros data H' *;
                match goal with
                  proj : BoundedIndex _ |- _ =>
                  instantiate (1 := ibound (indexb proj));
                  destruct H' as [? H'']; intuition;
                  try (rewrite <- H''; reflexivity);
                  destruct data; simpl; eauto
                end ]
          | shelve_inv ].

  Ltac apply_compose :=
    intros;
    match goal with
      H : cache_inv_Property ?P ?P_inv |- _ =>
      first [eapply (compose_encode_correct_no_dep H); clear H
            | eapply (compose_encode_correct H); clear H
            ]
    end.

  Ltac build_decoder :=
    first [ solve [eapply Enum_decode_correct; [   repeat econstructor; simpl; intuition;
    repeat match goal with
            H : @Vector.In _ _ _ _ |- _ =>
            inversion H;
              apply_in_hyp Eqdep.EqdepTheory.inj_pair2; subst
          end
 | .. ]; eauto  ]
          | solve [eapply Word_decode_correct ]
          | solve [eapply Nat_decode_correct ]
          | solve [eapply String_decode_correct ]
          | eapply (SumType_decode_correct
            [ _ ]%vector
            (icons _ inil)
            (icons _ inil)
            (@Iterate_Dep_Type_equiv' 1 _ (icons _ inil))
            (@Iterate_Dep_Type_equiv' 1 _ (icons _ inil)));
            [let idx' := fresh in
             intro idx'; pattern idx';
             eapply Iterate_Ensemble_equiv' with (idx := idx'); simpl;
             repeat (match goal with |- prim_and _ _ => apply Build_prim_and; try exact I end)
            | .. ]
          | eapply (SumType_decode_correct
            [ _; _]%vector
            (icons _ (icons _ inil))
            (icons _ (icons _ inil))
            (@Iterate_Dep_Type_equiv' 2 _ (icons _ (icons _ inil)))
            (@Iterate_Dep_Type_equiv' 2 _ (icons _ (icons _ inil))));
            [let idx' := fresh in
             intro idx'; pattern idx';
             eapply Iterate_Ensemble_equiv' with (idx := idx'); simpl;
             repeat (match goal with |- prim_and _ _ => apply Build_prim_and; try exact I end)
                     | .. ]
          | eapply (SumType_decode_correct
            [ _; _; _ ]%vector
            (icons _ (icons _ (icons _ inil)))
            (icons _ (icons _ (icons _ inil)))
            (@Iterate_Dep_Type_equiv' 3 _ (icons _ (icons _ (icons _ inil))))
            (@Iterate_Dep_Type_equiv' 3 _ (icons (icons _ (icons _ inil)))));
            [let idx' := fresh in
             intro idx'; pattern idx';
             eapply Iterate_Ensemble_equiv' with (idx := idx'); simpl;
             repeat (match goal with |- prim_and _ _ => apply Build_prim_and; try exact I  end)
            | .. ]
          | intros;
            match goal with
              |- encode_decode_correct_f
                   _ _ _
                   (encode_list_Spec _) _ _ =>
              eapply FixList_decode_correct end
          | apply_compose ].

  Lemma Fin_inv :
    forall n (idx : Fin.t (S n)),
      idx = Fin.F1 \/ exists n', idx = Fin.FS n'.
  Proof. apply Fin.caseS; eauto. Qed.

  Ltac solve_cache_inv :=
    repeat instantiate (1 := fun _ => True);
    unfold cache_inv_Property; intuition;
    repeat match goal with
           | idx : Fin.t (S _) |- _ =>
             destruct (Fin_inv _ idx) as [? | [? ?] ]; subst; simpl; eauto
           | idx : Fin.t 0 |- _ =>  inversion idx
           end.

  Ltac finalize_decoder P_inv :=
  (unfold encode_decode_correct_f; intuition eauto);
    [ computes_to_inv; injections; subst; simpl;
      match goal with
        H : Equiv _ ?env |- _ =>
        eexists env; intuition eauto;
        simpl;
        match goal with
          |- ?f ?a ?b ?c = ?P =>
          let P' := (eval pattern a, b, c in P) in
          let f' := match P' with ?f a b c => f end in
          unify f f'; reflexivity
        end
      end
    | injections; eauto
    | eexists _; eexists _;
      intuition eauto; injections; eauto using idx_ibound_eq;
      try match goal with
        |- P_inv ?data => destruct data;
                                 simpl in *; eauto
      end
    ].

  Ltac build_decoder_component :=
    (build_decoder || solve_data_inv).


Require Import VerdiRaft.Raft.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.RefinementSpecLemmas.
Require Import VerdiRaft.SpecLemmas.

Require Import VerdiRaft.AllEntriesLeaderLogsTermInterface.
Require Import VerdiRaft.AppendEntriesRequestLeaderLogsInterface.

Section AllEntriesLeaderLogsTerm.

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

  Context {rri : raft_refinement_interface}.

  Context {aerlli : append_entries_leaderLogs_interface}.

  Lemma allEntries_leaderLogs_term_append_entries :
    refined_raft_net_invariant_append_entries allEntries_leaderLogs_term.
  Proof using aerlli.
    red. unfold allEntries_leaderLogs_term. intros. simpl in *. subst.
    repeat find_higher_order_rewrite.
    destruct_update; simpl in *;
    [|find_apply_hyp_hyp; intuition;
      right; break_exists_exists; intuition;
      find_higher_order_rewrite;
      destruct_update; simpl in *; eauto;
      rewrite update_elections_data_appendEntries_leaderLogs; eauto].
    find_apply_lem_hyp update_elections_data_appendEntries_allEntries_term.
    intuition;
      [find_apply_hyp_hyp; intuition;
       right; break_exists_exists; intuition;
       find_higher_order_rewrite;
       destruct_update; simpl in *; eauto;
       rewrite update_elections_data_appendEntries_leaderLogs; eauto|].
    subst.
    match goal with
      | H : context [pBody] |- _ =>
        eapply append_entries_leaderLogs_invariant in H; eauto
    end.
    break_exists. break_and. subst. do_in_app.
    case H7; intros; try find_apply_hyp_hyp; auto.
    right.
    find_eapply_lem_hyp Prefix_In; eauto.
    repeat eexists; eauto.
    find_higher_order_rewrite;
      destruct_update; simpl in *; eauto;
      rewrite update_elections_data_appendEntries_leaderLogs; subst; eauto.
  Qed.

  (* rest of cases are easy *)
  Lemma allEntries_leaderLogs_term_init :
    refined_raft_net_invariant_init allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_init, allEntries_leaderLogs_term.
    simpl. intuition.
  Qed.

  Lemma allEntries_leaderLogs_term_client_request :
    refined_raft_net_invariant_client_request allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_client_request, allEntries_leaderLogs_term.
    simpl.
    intros.
    subst.
    repeat find_higher_order_rewrite.
    destruct_update.
    - simpl in *.
      find_copy_apply_lem_hyp update_elections_data_client_request_allEntries.
      intuition.
      + repeat find_rewrite.
        find_apply_hyp_hyp.
        intuition.
        right.
        break_exists_exists.
        find_higher_order_rewrite.
        destruct_update.
        * simpl in *. rewrite update_elections_data_client_request_leaderLogs.
          intuition.
        * intuition.
      + break_exists. intuition.
        find_rewrite. simpl in *. intuition.
        * find_inversion.
          find_copy_apply_lem_hyp handleClientRequest_type.
          intuition.
          repeat find_rewrite. intuition.
        * find_apply_hyp_hyp.
          intuition.
          right.
          break_exists_exists.
          find_higher_order_rewrite.
          { destruct_update.
            * simpl in *. rewrite update_elections_data_client_request_leaderLogs.
              intuition.
            * intuition.
          }
    - find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      { destruct_update.
        * simpl in *. rewrite update_elections_data_client_request_leaderLogs.
          intuition.
        * intuition.
      }
  Qed.

  Lemma allEntries_leaderLogs_term_timeout :
    refined_raft_net_invariant_timeout allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_timeout, allEntries_leaderLogs_term.
    simpl. intros.
    repeat find_higher_order_rewrite.
    destruct_update.
    - simpl in *.
      find_rewrite_lem update_elections_data_timeout_allEntries.
      find_apply_hyp_hyp.
      intuition.
      right. break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl in *. rewrite update_elections_data_timeout_leaderLogs. intuition.
      + intuition.
    - find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl in *. rewrite update_elections_data_timeout_leaderLogs. intuition.
      + intuition.
  Qed.

  Lemma allEntries_leaderLogs_term_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_append_entries_reply, allEntries_leaderLogs_term.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    destruct_update.
    - simpl in *. find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl in *. auto.
      + intuition.
    - find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl in *. auto.
      + intuition.
  Qed.

  Lemma allEntries_leaderLogs_term_request_vote :
    refined_raft_net_invariant_request_vote allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_request_vote, allEntries_leaderLogs_term.
    simpl.
    intros.
    repeat find_higher_order_rewrite.
    destruct_update.
    - simpl in *. find_rewrite_lem update_elections_data_requestVote_allEntries.
      find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl in *. rewrite leaderLogs_update_elections_data_requestVote. auto.
      + intuition.
    - find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl in *. rewrite leaderLogs_update_elections_data_requestVote. auto.
      + intuition.
  Qed.

  Lemma allEntries_leaderLogs_term_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_request_vote_reply, allEntries_leaderLogs_term.
    simpl. intros.
    repeat find_higher_order_rewrite.
    destruct_update.
    - simpl in *. find_rewrite_lem update_elections_data_requestVoteReply_allEntries.
      find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl. intuition.
        apply update_elections_data_requestVoteReply_old.
        auto.
      + auto.
    - find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl. intuition.
        apply update_elections_data_requestVoteReply_old.
        auto.
      + auto.
  Qed.

  Lemma allEntries_leaderLogs_term_do_leader :
    refined_raft_net_invariant_do_leader allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_do_leader, allEntries_leaderLogs_term.
    simpl. intros.
    repeat find_higher_order_rewrite.
    match goal with
    | [ H : nwState ?net ?h = (?gd, ?d) |- _ ] =>
      ((replace gd with (fst (nwState net h)) in * by (now rewrite H));
        (replace d with (snd (nwState net h)) in * by (now rewrite H))); clear H
    end.
    destruct_update.
    - simpl in *.
      find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update; auto.
    - find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      repeat find_higher_order_rewrite.
      destruct_update; auto.
  Qed.

  Lemma allEntries_leaderLogs_term_do_generic_server :
    refined_raft_net_invariant_do_generic_server allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_do_generic_server, allEntries_leaderLogs_term.
    simpl. intros.
    repeat find_higher_order_rewrite.
    match goal with
    | [ H : nwState ?net ?h = (?gd, ?d) |- _ ] =>
      ((replace gd with (fst (nwState net h)) in * by (now rewrite H));
        (replace d with (snd (nwState net h)) in * by (now rewrite H))); clear H
    end.
    destruct_update.
    - simpl in *.
      find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update; auto.
    - find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      repeat find_higher_order_rewrite.
      destruct_update; auto.
  Qed.

  Lemma allEntries_leaderLogs_term_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_state_same_packet_subset, allEntries_leaderLogs_term.
    simpl.
    intros.
    find_reverse_higher_order_rewrite.
    find_apply_hyp_hyp.
    intuition.
    right. break_exists_exists.
    find_reverse_higher_order_rewrite.
    auto.
  Qed.

  Lemma allEntries_leaderLogs_term_reboot :
    refined_raft_net_invariant_reboot allEntries_leaderLogs_term.
  Proof using.
    unfold refined_raft_net_invariant_reboot, allEntries_leaderLogs_term.
    simpl. intros.
    find_higher_order_rewrite.
    match goal with
    | [ H : nwState ?net ?h = (?gd, ?d) |- _ ] =>
      ((replace gd with (fst (nwState net h)) in * by (now rewrite H));
        (replace d with (snd (nwState net h)) in * by (now rewrite H))); clear H
    end.
    subst.
    destruct_update.
    - simpl in *.
      find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl. intuition.
      + auto.
    - find_apply_hyp_hyp.
      intuition.
      right.
      break_exists_exists.
      find_higher_order_rewrite.
      destruct_update.
      + simpl. intuition.
      + auto.
  Qed.

  Lemma allEntries_leaderLogs_term_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      allEntries_leaderLogs_term net.
  Proof using aerlli rri.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply allEntries_leaderLogs_term_init.
    - apply allEntries_leaderLogs_term_client_request.
    - apply allEntries_leaderLogs_term_timeout.
    - apply allEntries_leaderLogs_term_append_entries.
    - apply allEntries_leaderLogs_term_append_entries_reply.
    - apply allEntries_leaderLogs_term_request_vote.
    - apply allEntries_leaderLogs_term_request_vote_reply.
    - apply allEntries_leaderLogs_term_do_leader.
    - apply allEntries_leaderLogs_term_do_generic_server.
    - apply allEntries_leaderLogs_term_state_same_packet_subset.
    - apply allEntries_leaderLogs_term_reboot.
  Qed.

  Instance aellti : allEntries_leaderLogs_term_interface.
  split.
  exact allEntries_leaderLogs_term_invariant.
  Qed.
End AllEntriesLeaderLogsTerm.


Require Import msl.msl_standard.
Require Import Maps.
Require Import FuncListMachine.
Require Import lemmas.
Require Import hoare_total.
Require Import wp.

(* This is some tentative work-in-progress *)

Fixpoint list_nat (n:nat) (x:value) {struct n} :=
  match n, x with
  | 0, value_label 1%positive => True
  | S n', value_cons (value_label 1%positive) x' => list_nat n' x'
  | _, _ => False
  end.

Fixpoint list_length (x:value) :=
  match x with
  | value_cons _ x' => S (list_length x')
  | _ => 0
  end.

Definition list_nat_var (n:nat) (v:var) (r:store) :=
  match r#v with
  | None => False
  | Some x => list_nat n x
  end.

Program Definition add_term_measure : termMeas :=
  fun r n =>
  match r#(V 1) with
  | Some x => list_length x = n
  | None => False
  end.
Next Obligation.
  destruct x; intuition.
  destruct x1; intuition.
  destruct o0; intuition.
Qed.

Definition add_P' n m st :=
    list_nat_var n (V 1) st /\
    list_nat_var m (V 2) st.

Definition add_Q' n m st := list_nat_var (n+m) (V 2) st.

Definition add_P (nm:nat*nat) := store_op (add_P' (fst nm) (snd nm)).
Definition add_Q (nm:nat*nat) := store_op (add_Q' (fst nm) (snd nm)).

Definition valueTermMeas :=
  { R: value -> nat -> Prop |
    forall v n n', R v n -> R v n' -> n = n' }.

Record stdFunspec A :=
  { sfs_t     : valueTermMeas
  ; sfs_P     : A -> value -> pred prog
  ; sfs_Q     : A -> value -> pred prog
  }.

Implicit Arguments sfs_t.
Implicit Arguments sfs_P.
Implicit Arguments sfs_Q.

Program Definition value_to_store_termMeas (vt:valueTermMeas) : termMeas :=
  fun s n => match s#(V 0) with
             | Some v => proj1_sig vt v n
             | None   => False
             end.
Next Obligation.
  destruct x; intuition. destruct o; intuition. destruct vt; simpl in *.
  eauto.
Qed.

(* Define a simple calling convention for "standard"
   functions.  register 0 is for arguments and results.
   registers 1 2 3 and 4 are callee-saves registers,
   and registers >= 5 are caller-saves.

   It is not specified, but register 1 is usually
   used as a value stack.
 *)
Definition stdfun (l:label) (fs:{A:Type & stdFunspec A}) :=
  funptr l (projT1 fs * (value*value*value*value))
         (value_to_store_termMeas (sfs_t (projT2 fs)))
         (fun avs =>
           match avs with
             (a,(v1,v2,v3,v4)) =>
             EX v0:_,
             world_op
               (sfs_P (projT2 fs) a v0)
               (fun s =>
                 s#(V 0) = Some v0 /\
                 s#(V 1) = Some v1 /\
                 s#(V 2) = Some v2 /\
                 s#(V 3) = Some v3 /\
                 s#(V 4) = Some v4)
           end)
         (fun avs =>
           match avs with
             (a,(v1,v2,v3,v4)) =>
             EX v0:_,
             world_op
                (sfs_Q (projT2 fs) a v0)
                (fun s =>
                  s#(V 0) = Some v0 /\
                  s#(V 1) = Some v1 /\
                  s#(V 2) = Some v2 /\
                  s#(V 3) = Some v3 /\
                  s#(V 4) = Some v4)
           end).

Definition apply_P (fs:{ A:Type & stdFunspec A}) (x:projT1 fs) (v:value) : pred prog :=
  match v with
  | value_cons (value_label l) v' =>
       stdfun l fs && sfs_P (projT2 fs) x v'
  | _ => FF
  end.

Definition apply_Q (fs:{A :Type & stdFunspec A}) (x:projT1 fs) (v:value) : pred prog :=
  sfs_Q (projT2 fs) x v.

Program Definition apply_tm (fs:{A:Type & stdFunspec A}) : valueTermMeas :=
  fun v n =>
  match v, n with
  | value_cons (value_label l) v', S n' =>
      sfs_t (projT2 fs) v' n'
  | _, _ => False
  end.
Next Obligation.
  destruct v; intuition. destruct v1; intuition. destruct n; intuition. destruct n'; intuition.
  destruct (sfs_t X); simpl in *. eauto.
Qed.

Definition apply_fs (fs:{A:Type & stdFunspec A}) : {A:Type & stdFunspec A} :=
  existT _ (projT1 fs)
     (Build_stdFunspec (projT1 fs) (apply_tm fs) (apply_P fs) (apply_Q fs)).

Program Definition phi : map instruction :=
  set _ (set _ (set _ (set _ (set _ (set _ (empty _)

  (* The "map" wrapper function *)
  (L 5)
    ( (* push the values of V2 and V3 *)
      instr_cons (V 2) (V 1) (V 1) ;;
      instr_cons (V 3) (V 1) (V 1) ;;
      (* load the function pointer into V2 *)
      instr_fetch_field (V 0) 0 (V 2) ;;
      (* load the remainder of the list into V3 *)
      instr_fetch_field (V 0) 1 (V 3) ;;
      (* call the map worker function *)
      instr_getlabel (L 4) (V 5) ;;
      instr_call (V 5) ;;
      (* restore V3 *)
      instr_fetch_field (V 1) 0 (V 3) ;;
      instr_fetch_field (V 1) 1 (V 1) ;;
      (* restore V2 *)
      instr_fetch_field (V 1) 0 (V 2) ;;
      instr_fetch_field (V 1) 1 (V 1) ;;
      instr_return
    ))

  (* The "map" worker function *)
  (L 4)
    ( instr_if_nil (V 3)
       (*if nil, return nil *)
        ( instr_getlabel (L 0) (V 0) ;;
          instr_return )
       (*otherwise, recursive call*)
        ( (* get the head of the list *)
          instr_fetch_field (V 3) 0 (V 0) ;;
          (* call the mapping function *)
          instr_call (V 2) ;;
          (* push the mapped value *)
          instr_cons (V 0) (V 1) (V 1) ;;
          (* pop the head of the list *)
          instr_fetch_field (V 3) 1 (V 3) ;;
          (* recursive "map" call *)
          instr_getlabel (L 4) (V 5) ;;
          instr_call (V 5) ;;
          (* add the new list head *)
          instr_fetch_field (V 1) 0 (V 5) ;;
          instr_cons (V 5) (V 0) (V 0) ;;
          (* pop the stack *)
          instr_fetch_field (V 1) 1 (V 1) ;;
          instr_return
         )
       (* endif *)
    ))

  (* The "succ" function *)
  (L 3)
    ( instr_getlabel (L 0) (V 5) ;;
      instr_cons (V 5) (V 0) (V 0) ;;
      instr_return
    ))

  (* Set up a double-indirect call to succ.
     Call apply, which indirectly calls apply to
     call succ.
  *)
  (L 2)
    ( instr_getlabel (L 0) (V 0) ;;
      instr_getlabel (L 3) (V 1) ;;
      instr_getlabel (L 0) (V 2) ;;
      instr_getlabel (L 0) (V 3) ;;
      instr_getlabel (L 0) (V 4) ;;
      instr_cons (V 2) (V 0) (V 0) ;;
      instr_cons (V 2) (V 0) (V 0) ;;
      instr_cons (V 1) (V 0) (V 0) ;;
      instr_getlabel (L 1) (V 1) ;;
      instr_cons (V 1) (V 0) (V 0) ;;
      instr_call (V 1) ;;
      instr_return
    ))

  (* The "apply" function *)
  (L 1)
    ( instr_fetch_field (V 0) 0 (V 5) ;;
      instr_fetch_field (V 0) 1 (V 0) ;;
      instr_call (V 5) ;;
      instr_return
    ))

  (* An addition function *)
  (L 0)
    ( instr_assert (EX nm:_, add_P nm) ;;
      instr_if_nil (V 1)
        (*then *) (
          instr_return
        ) (*else *) (
          (instr_fetch_field (V 1) 0 (V 3) ;;
          instr_fetch_field (V 1) 1 (V 1) ;;
          instr_cons (V 3) (V 2) (V 2)) ;;
          instr_getlabel (L 0) (V 0) ;;
          (instr_call (V 0) ;;
           instr_return)
        )
    ).

Program Definition succ_fs : stdFunspec nat :=
  Build_stdFunspec nat
    (fun _ n => n = 0)
    (fun n v => !!(list_nat n v))
    (fun n v => !!(list_nat (S n) v)).

Definition succ_fs' : {A:Type & stdFunspec A} :=
  existT (fun X => stdFunspec X) nat succ_fs.

Lemma succ_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    (stdfun (L 3) succ_fs' && G).
Proof.
  intros.
  eapply verify_func_simple; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]].
  intuition.
  rewrite H7 in H5.
  inv H5.
  inv H3.
  simpl in H0.
  rewrite get_set_same.
  rewrite get_set_other. 2: discriminate.
  do 2 econstructor. intuition; eauto.
  inv H3.
  econstructor; split.
  2: repeat split;
    repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  simpl. auto.
Qed.

Section map_tm.
  Variable (f_tm : valueTermMeas).

  Fixpoint map_inner_tm (v:value) : nat -> Prop :=
    fun n =>
    match v with
      | value_label _ => n = 0
      | value_cons v1 v2 =>
          exists x1, exists x2,
           proj1_sig f_tm v1 x1 /\
           map_inner_tm v2 x2  /\
           n = 1 + x1 + 1 + x2
    end.

  Lemma map_inner_tm_fun : forall v x1 x2,
    map_inner_tm v x1 ->
    map_inner_tm v x2 ->
    x1 = x2.
  Proof.
    induction v; simpl; intros. congruence.
    destruct H as [a1 [a2 [? [? ?]]]].
    destruct H0 as [b1 [b2 [? [? ?]]]].
    subst.
    cut (a1 = b1 /\ a2 = b2).
    intuition congruence.
    split; auto.
    eapply (proj2_sig f_tm); eauto.
  Qed.
End map_tm.

Program Definition map_worker_tm (fs:{A:Type & stdFunspec A}) : termMeas :=
  fun s n =>
  match s#(V 3) with
  | Some v => map_inner_tm (sfs_t (projT2 fs)) v n
  | _ => False
  end.
Next Obligation.
  destruct (x#4); intuition.
  eapply map_inner_tm_fun; eauto.
Qed.

Program Definition map_tm (fs:{A:Type & stdFunspec A}) : valueTermMeas :=
  fun v n =>
  match v, n with
  | value_cons _ v, S n'  =>
     map_inner_tm (sfs_t (projT2 fs)) v n'
  | _, _ => False
  end.
Next Obligation.
  destruct v. elim H.
  destruct n; destruct n'; try tauto.
  f_equal.
  eapply map_inner_tm_fun; eauto.
Qed.

Section map_pre_post.
  Variable A:Type.
  Variable P:A->value->pred prog.

  Fixpoint list_val_match (l:list A) (v:value) {struct l} : pred prog :=
    match l, v with
    | nil, value_label 1%positive => TT
    | x::l', value_cons v1 v2 => P x v1 && list_val_match l' v2
    | _, _ => FF
    end.
End map_pre_post.

Definition map_worker_pre (fs:{A:Type & stdFunspec A}) (x:value*label*list (projT1 fs)*value) :=
  match x with
    (v1,lab,l,v4) =>
    EX v3:_,
    world_op
      (stdfun lab fs &&
       list_val_match (projT1 fs) (sfs_P (projT2 fs)) l v3)
      (fun s =>
         s#(V 1) = Some v1 /\
         s#(V 2) = Some (value_label lab) /\
         s#(V 3) = Some v3 /\
         s#(V 4) = Some v4)
  end.

Definition map_worker_post (fs:{A:Type & stdFunspec A}) (x:value*label*list (projT1 fs)*value) :=
  match x with
    (v1,lab,l,v4) =>
    EX v0:_,
    world_op
      (stdfun lab fs &&
        list_val_match (projT1 fs) (sfs_Q (projT2 fs)) l v0)
      (fun s =>
         s#(V 0) = Some v0 /\
         s#(V 1) = Some v1 /\
         s#(V 2) = Some (value_label lab) /\
         s#(V 4) = Some v4)
  end.

Definition map_pre
  (fs:{A:Type & stdFunspec A})
  l
  (x:value) :=
  match x with
  | value_cons (value_label lab) v =>
      stdfun lab fs &&
      list_val_match (projT1 fs) (sfs_P (projT2 fs)) l v
  | _ => FF
  end.

Definition map_post
  (fs:{A:Type & stdFunspec A})
  l
  (x:value) :=
  list_val_match (projT1 fs) (sfs_Q (projT2 fs)) l x.

Definition map_spec (fs:{A:Type & stdFunspec A}) : {A:Type & stdFunspec A} :=
  existT (fun X => stdFunspec X) (list (projT1 fs))
    (Build_stdFunspec _ (map_tm fs) (map_pre fs) (map_post fs)).

Lemma map_worker_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A},
         funptr (L 4) _ (map_worker_tm fs) (map_worker_pre fs) (map_worker_post fs)) && G).
Proof.
  intros.
Transparent get set.
  eapply verify_func; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [[[v1 lab] l] v4].
  clear H2. unfold map_worker_pre in H0.
  destruct H0 as [v3 [[? ?] ?]].
  intuition.
  clear H.
  econstructor. intuition.
  eauto.
  destruct l; simpl in H2; [ left | right ].
  destruct v3; try (elim H2; fail).
  destruct l; try (elim H2; fail).
  split; auto.
  intros. inv H.
  unfold map_worker_post.
  simpl. exists (value_label 1%positive).
  intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  destruct v3; try (elim H2; fail).
  destruct H2.
  split. eauto.
  do 2 econstructor; intuition.
  eauto.
  hnf in H5.
  unfold map_worker_tm in H5.
  simpl in H7.
  rewrite H7 in H5. simpl in H5.
  destruct H5 as [n0 [n1 [? [? ?]]]].
  subst n.
  exists (1+n0). exists (1+n1).
  split. 2: omega.
  inv H8.
  do 5 econstructor; intuition.
  exists n0.
  econstructor.
  intuition.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  2: apply H0.
  simpl.
  rewrite get_set_same; auto.
  simpl.
  instantiate (1:=(p0,(v1,(value_label lab),value_cons v3_1 v3_2,v4))).
  simpl. econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  simpl in H12.
  destruct a'.
  hnf in H8. simpl in H8. subst.
  destruct a'0.
  rewrite worldNec_unfold in H11.
  destruct H11; subst.
  destruct H12; intuition.
  do 2 econstructor; intuition; eauto.
  inv H16.
  do 2 econstructor. intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  inv H16. inv H18.
  do 5 econstructor. exists n1.
  exists (value_cons x v1,lab,l,v4).
  intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  2: eapply pred_nec_hereditary; [ | apply H1 ]; auto.
  unfold map_worker_tm. simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl. split.
  econstructor; intuition; auto.
  eapply pred_nec_hereditary; eauto.
  eapply pred_nec_hereditary; eauto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  split. auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl.
  exists n1. split. auto.
  omega.
  destruct a'. destruct a'0.
  inv H16. rewrite worldNec_unfold in H18.
  destruct H18; simpl in *; subst.
  destruct H19 as [? [? ?] ?]; intuition.
  do 2 econstructor; intuition; eauto.
  inv H23.
  do 2 econstructor; intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H23.
  do 2 econstructor; intuition;
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H23.
  exists (value_cons x x0); intuition.
  split; auto.
  eapply pred_nec_hereditary; eauto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
    repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
Qed.

Lemma map_verify : forall G,
    verify_prog phi G ->
    verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 5) (map_spec fs)) &&
    ((ALL fs:{A:Type & stdFunspec A},
         funptr (L 4) _ (map_worker_tm fs) (map_worker_pre fs) (map_worker_post fs))
        && G)).
Proof.
  intros.
Transparent get set.
  eapply verify_func.
  simpl. auto.
  2: apply map_worker_verify; auto.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]]. intuition.
  rewrite H7 in H5.
  clear H H2.
  unfold map_pre in H0.
  destruct v0; try (elim H0; fail).
  destruct v0_1; try (elim H0; fail).
  destruct H0.
  do 2 econstructor; intuition; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H2; inv H10.
  simpl in H5.
  destruct n; try tauto.
  do 5 econstructor.
  exists n.
  exists (value_cons v3 (value_cons v2 v1),l,x,v4).
  intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  unfold map_worker_tm. simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  simpl. econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; auto.
  eauto.
  destruct a'; destruct a'0.
  rewrite worldNec_unfold in H10.
  destruct H10; subst.
  destruct H12 as [? [? ?] ?]; intuition.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  do 2 econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
  inv H16.
  destruct H2. simpl in *; subst.
  econstructor; intuition;
  repeat (rewrite get_set_other; [ | discriminate]);
      try rewrite get_set_same; eauto.
Qed.

Lemma apply_verify : forall G,
  verify_prog phi G ->
  verify_prog
    phi
    ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 1) (apply_fs fs)) && G).
Proof.
  intros.
Transparent get set.
  eapply verify_func; auto.
  simpl. reflexivity.
  clear H.
Opaque get set funptr.
  simpl; intros.
  apply hoare_wp. simpl.
  intros [? ?].
  simpl. intuition.
  destruct a as [x [[[v1 v2] v3] v4]].
  destruct H0 as [v0 [? ?]]. intuition.
  rewrite H6 in H5.
  unfold apply_tm in H5.
  destruct v0; try tauto.
  destruct v0_1; try tauto.
  destruct n; try tauto.
  do 2 econstructor.
  intuition; eauto.
  inv H9.
  do 2 econstructor.
  intuition; eauto.
  rewrite get_set_other. 2: discriminate.
  eauto.
  inv H9.
  do 5 econstructor.
  exists n.
  exists (x,(v1,v2,v3,v4)).
  econstructor.
  intuition.
  destruct H0.
  3: apply H0.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  simpl.
  simpl. rewrite get_set_same. auto.
  simpl.
  destruct H0.
  econstructor. split. eauto.
  repeat split;
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  simpl. intros. auto.
Qed.

Lemma add_verify : forall G,
  verify_prog phi G ->
  verify_prog phi (funptr (L 0) _ add_term_measure add_P add_Q && G).
Proof.
  intros. eapply verify_func_simple; auto.

Transparent get set.
  simpl. reflexivity.
  intros.
Opaque get set funptr.
  intros. apply hoare_wp.
  subst Pr Pr'. simpl.
  intros [? ?].
  destruct a as [n1 m1]; simpl in *.
  simpl; intuition.
  exists (n1,m1). simpl; split; auto.
  intuition; subst; auto.
  destruct H6.
  hnf in H4, H6. simpl V in *.
  case_eq (s#2); intros;
    rewrite H8 in H4; try tauto.
  case_eq (s#3); intros;
    rewrite H9 in H6; try tauto.
  unfold add_term_measure in H7.
  simpl in H7; rewrite H8 in H7.
  inv H7.
  exists v; intuition.
  destruct n1; simpl in H4;
    destruct v; try tauto.
  destruct l; try tauto.
  left; simpl; intuition.
  hnf. simpl. rewrite H9. auto.
  destruct v1; try tauto.
  destruct l; try tauto.
  simpl in *.
  right; simpl; intuition.
  eauto.
  do 2 econstructor; intuition.
  inv H7.
  do 2 econstructor; intuition.
  rewrite get_set_other. 2: discriminate. eauto.
  inv H7.
  do 2 econstructor; intuition.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  eauto.
  inv H7. inv H10.
  exists (L 0). exists (nat * nat)%type.
  exists add_term_measure.
  do 2 econstructor.
  exists (list_length v2).
  exists (n1, S m1).
  intuition.
  rewrite get_set_same. auto.
  unfold add_term_measure; simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  apply H2.
  simpl; intuition.
  split; hnf; simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  exists (list_length v2).
  unfold add_term_measure. simpl.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_other. 2: discriminate.
  rewrite get_set_same. auto.
  destruct a' as [? ?].
  inv H7. simpl in *.
  destruct a'0 as [? ?].
  intuition; subst.
  apply worldNec_unfold in H10. destruct H10; subst.
  hnf in H13. hnf.
  simpl V in *.
  destruct (s1#3).
  replace (S n1 + m1) with (n1 + S m1) by omega. auto.
  auto.
Qed.

Program Definition main_tm : termMeas :=
  fun _ n => n = 5.

Let PROG_G :=
  (funptr (L 2) unit main_tm
                     (fun _ => TT)
                     (fun _ => store_op (fun r => exists v, r#(V 0) = Some v /\ list_nat 3 v))) &&
  ((stdfun (L 3) succ_fs') &&
   ((ALL fs:{A:Type & stdFunspec A}, stdfun (L 1) (apply_fs fs)) &&
    ((funptr (L 0) _ add_term_measure add_P add_Q) && TT))).

Lemma main_verify :
  verify_prog phi PROG_G.
Proof.
  unfold PROG_G.
  eapply verify_func_simple.
Transparent get set.
  simpl. reflexivity.
  2: apply succ_verify.
  2: apply apply_verify.
  2: apply add_verify.
  2: repeat intro; hnf; auto.
  intros.
Opaque get set funptr list_nat.
  apply hoare_wp; subst.
  simpl. intros [? ?]. subst Pr Pr'.
  simpl; intuition.
  inv H5.
  inv H7; inv H9; inv H10; inv H11; inv H12.
  clear H H0 H2 H8.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H. inv H0.
  do 2 econstructor; intuition;
      repeat (rewrite get_set_other; [ | discriminate]);
        try rewrite get_set_same; auto.
  inv H.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  do 5 econstructor.
  exists 2.
  evar (x1:value).
  evar (x2:value).
  evar (x3:value).
  evar (x4:value).
  exists (2,(x1,x2,x3,x4)).
  subst x1 x2 x3 x4.
  intuition.
  2: apply (H4 (apply_fs succ_fs')).
  simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  simpl.
  repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  econstructor; split.
  2: repeat split;
   repeat (rewrite get_set_other; [ | discriminate]);
    try rewrite get_set_same; auto.
  unfold apply_P.
  simpl. intuition.
Transparent list_nat.
  simpl. auto.
Opaque list_nat.
  simpl in H2.
  destruct H2.
  hnf in H. simpl in H. subst.
  destruct a'0.
  intuition.
  exists x. split; auto.
Qed.

Lemma main_totally_correct :
  forall r c,
    phi#(L 2) = Some c ->
    exists n', exists p', exists r',
      stepstar (K.squash (n',phi)) p'
        r ((c ;; instr_assert FF)::nil)
        r' nil /\
        exists v, r'#(V 0) = Some v /\ list_nat 3 v.
Proof.
  intros.
  generalize (verify_totally_correct PROG_G unit (fun _ => TT)
    (fun _ => store_op (fun r => exists v, r#(V 0) = Some v /\ list_nat 3 v))
    phi (L 2) main_tm tt); intros.
  spec H0. apply main_verify.
  spec H0. unfold PROG_G. hnf; simpl; intuition.
  spec H0 r. spec H0. intros; hnf. auto.
  spec H0 5.
  spec H0 c.
  spec H0. simpl; auto.
  spec H0. auto.
  destruct H0 as [p' [r' [? ?]]].
  econstructor.
  exists p'. exists r'.
  split; eauto.
  destruct H1; auto.
Qed.

(* For every store satisfying the addition precondition,
   calling the addition function will halt with a store
   satisfing the postcondition.
 *)

Transparent list_nat.
Lemma addition_totally_correct :
  forall r n m c,
    add_P' n m r ->
    phi#(L 0) = Some c ->
    exists n', exists p', exists r',
      stepstar (K.squash (n',phi)) p'
        r ((c ;; instr_assert FF)::nil)
        r' nil /\
      add_Q' n m r'.
Proof.
  intros.
  generalize (verify_totally_correct (funptr (L 0) _ add_term_measure add_P add_Q && TT) _ add_P add_Q phi (L 0) add_term_measure (n,m)); intros.
  spec H1. apply add_verify.
  repeat intro; hnf; auto.
  spec H1. hnf; simpl; intuition.
  spec H1 r. spec H1.
  simpl; intuition.
  spec H1 n c.
  spec H1.
  destruct H. simpl.
  unfold list_nat_var in *.
  simpl in *.
  destruct (r#2); auto.

  clear - H.
  revert v H; induction n; simpl; intros;
    destruct v; try tauto.
  destruct v1; try tauto.
  destruct l; try tauto.
  simpl. f_equal. auto.
  spec H1; auto.
  destruct H1 as [p' [r' [? ?]]].
  do 3 econstructor; split; eauto.
  destruct H2; auto.
Qed.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From Coq Require Import List Lia ZArith.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.

From bpf.comm Require Import Monad.
From bpf.clightlogic Require Import CommonLemma CommonLib Clightlogic CorrectRel.
From bpf.verifier.comm Require Import monad.

From bpf.verifier.synthesismodel Require Import verifier_synthesis.
From bpf.verifier.clightmodel Require Import verifier.
From bpf.verifier.simulation Require Import VerifierSimulation VerifierRel.

(**
Check is_well_jump.
is_well_jump
     : int64 -> M bool
*)

Section Is_well_jump.
  Context {S: special_blocks}.

  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(nat:Type); (nat:Type); (int:Type)].
  Definition res : Type := (bool:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M state.state res) := is_well_jump.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_is_well_jump.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
    dcons (fun x => StateLess _ (nat_correct x))
      (dcons (fun x => StateLess _ (nat_correct x))
        (dcons (fun x => StateLess _ (sint32_correct x))
          (DList.DNil _))).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv state.state := fun x => StateLess _ (bool_correct x).

  Instance correct_function_is_well_jump : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.

    unfold f. unfold is_well_jump.
    correct_forward.

    get_invariant _pc.
    get_invariant _len.
    get_invariant _ofs.
    unfold eval_inv, nat_correct in c2, c3.
    unfold eval_inv, sint32_correct in c4.
    destruct c2 as (c2 & Hc2_range).
    destruct c3 as (c3 & Hc3_range).
    destruct c4 as (c4 & Hc4_range).
    subst.

    eexists.

    split_and; auto.
    {
      unfold exec_expr. repeat
      match goal with
      | H: ?X = _ |- context [match ?X with _ => _ end] =>
        rewrite H
      end. simpl.
      unfold Cop.sem_cmp; simpl.
      unfold Cop.sem_binarith; simpl.
      unfold Val.of_bool; simpl.
      unfold Vtrue, Vfalse.
      reflexivity.
    }
    unfold eval_inv, match_res, state.is_well_jump'.
    unfold bool_correct, Val.of_bool.
    unfold Int.cmpu.
    match goal with
    | |- context[if ?X then _ else _] =>
      destruct X; reflexivity
    end.
    unfold Cop.sem_cast; simpl.
    match goal with
    | |- context[if ?X then _ else _] =>
      destruct X; reflexivity
    end.
    intros.
    match goal with
    | |- Cop.val_casted (if ?X then _ else _) _ =>
      destruct X; constructor; reflexivity
    end.
  Qed.

End Is_well_jump.

Existing  Instance correct_function_is_well_jump.