Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Maps.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Axioms.

Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import compcert.common.Events.
Require Import compcert.common.AST.
Require Import compcert.common.Globalenvs.
Require Import VST.msl.Extensionality.

Require Import VST.sepcomp.mem_lemmas.
Require Import VST.sepcomp.semantics.

Require Import VST.concurrency.machine_semantics.

Require Import VST.msl.Coqlib2.

Section thread_stepN.
  Context {G TID SCH TR C M E:Type} (Sem:@ConcurSemantics G TID SCH TR C M) (ge:G).

  Fixpoint thread_stepN (n:nat) : SCH -> C -> M -> C -> M -> Prop :=
    match n with
      | O => fun U c m c' m' => (c,m) = ( c',m')
      | S k => fun U c1 m1 c3 m3 => exists c2, exists m2,
        @thread_step _ _ _ _ _ _ Sem ge U c1 m1 c2 m2 /\
        thread_stepN k U c2 m2 c3 m3
    end.

  Lemma thread_stepN_add : forall n m U c1 m1 c3 m3,
    thread_stepN (n+m) U c1 m1 c3 m3 <->
    exists c2, exists m2,
      thread_stepN n U c1 m1 c2 m2 /\
      thread_stepN m U c2 m2 c3 m3.
  Proof.
    induction n; simpl; intuition.
    firstorder. firstorder.
    inv H. auto.
    decompose [ex and] H. clear H.
    destruct (IHn m U x x0 c3 m3).
    apply H in H2.
    decompose [ex and] H2. clear H2.
    repeat econstructor; eauto.
    decompose [ex and] H. clear H.
    exists x1. exists x2; split; auto.
    destruct (IHn m U x1 x2 c3 m3).
    eauto.
  Qed.

  Definition thread_step_plus U c m c' m' :=
    exists n, thread_stepN (S n) U c m c' m'.

  Definition thread_step_star U c m c' m' :=
    exists n, thread_stepN n U c m c' m'.

  Lemma thread_step_plus_star : forall U c1 c2 m1 m2,
    thread_step_plus U c1 m1 c2 m2 -> thread_step_star U c1 m1 c2 m2.
  Proof. intros. destruct H as [n1 H1]. eexists. apply H1. Qed.

  Lemma thread_step_plus_trans : forall U c1 c2 c3 m1 m2 m3,
    thread_step_plus U c1 m1 c2 m2 -> thread_step_plus U c2 m2 c3 m3 ->
    thread_step_plus U c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (thread_stepN_add (S n1) (S n2) U  c1 m1 c3 m3) as [_ H].
    eexists. apply H. exists c2. exists m2. split; assumption.
  Qed.

  Lemma thread_step_star_plus_trans : forall U c1 c2 c3 m1 m2 m3,
    thread_step_star U c1 m1 c2 m2 -> thread_step_plus U c2 m2 c3 m3 ->
    thread_step_plus U c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (thread_stepN_add n1 (S n2) U  c1 m1 c3 m3) as [_ H].
    rewrite <- plus_n_Sm in H.
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma thread_step_plus_star_trans: forall U c1 c2 c3 m1 m2 m3,
    thread_step_plus U c1 m1 c2 m2 -> thread_step_star U c2 m2 c3 m3 ->
    thread_step_plus U c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (thread_stepN_add (S n1) n2 U c1 m1 c3 m3) as [_ H].
    rewrite plus_Sn_m in H.
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma thread_step_star_trans: forall U c1 c2 c3 m1 m2 m3,
    thread_step_star U c1 m1 c2 m2 -> thread_step_star U c2 m2 c3 m3 ->
    thread_step_star U c1 m1 c3 m3.
  Proof. intros. destruct H as [n1 H1]. destruct H0 as [n2 H2].
    destruct (thread_stepN_add n1 n2 U c1 m1 c3 m3) as [_ H].
    eexists. apply H.  exists c2. exists m2.  split; assumption.
  Qed.

  Lemma thread_step_plus_one: forall U c m c' m',
    thread_step  Sem ge U c m c' m' -> thread_step_plus U c m c' m'.
  Proof. intros. unfold thread_step_plus, thread_stepN. simpl.
    exists O. exists c'. exists m'. eauto.
  Qed.

  Lemma thread_step_plus_two: forall U c m c' m' c'' m'',
    thread_step  Sem ge U c m c' m' -> thread_step  Sem ge U c' m' c'' m'' ->
    thread_step_plus U c m c'' m''.
  Proof. intros.
    exists (S O). exists c'. exists m'. split; trivial.
    exists c''. exists m''. split; trivial. reflexivity.
  Qed.

  Lemma thread_step_star_zero: forall U c m, thread_step_star U c m c m.
  Proof. intros. exists O. reflexivity. Qed.

  Lemma thread_step_star_one: forall U c m c' m',
    thread_step  Sem ge U c m c' m' -> thread_step_star U c m c' m'.
  Proof. intros.
    exists (S O). exists c'. exists m'. split; trivial. reflexivity.
  Qed.

  Lemma thread_step_plus_split: forall U c m c' m',
    thread_step_plus U c m c' m' ->
    exists c'', exists m'', thread_step  Sem ge U c m c'' m'' /\
      thread_step_star U  c'' m'' c' m'.
  Proof. intros.
    destruct H as [n [c2 [m2 [Hstep Hstar]]]]. simpl in*.
    exists c2. exists m2. split. assumption. exists n. assumption.
  Qed.

End thread_stepN.


(**
 * Queue.v
 *
 * Low level queue representation.
 *)

(** Compcert helper lib *)
Require Import Coqlib.
Require Import Maps.
(** Compcert types and semantics *)
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Globalenvs.
Require Import Clight.
Require Import Ctypes.
Require Import Cop.
Require Import Smallstep.
(** CertiKOS layer library *)
Require Import Semantics.
Require Import Structures.
Require Import GenSem.
Require Import CGenSem.
Require Import CPrimitives.
Require Import SimulationRelation.
Require Import SimrelInvariant.
Require Import LayerLogicImpl.
Require Import ClightModules.
Require Import ClightXSemantics.
Require Import MakeProgramSpec.
Require Import AbstractData.
Require Import AbstractionRelation.

Require Import TutoLib.
Require Import QueueData.
Require Import Node.
Require Import QueueIntro.

(** In this file we implement the [enqueue] and [dequeue] primitives on the
  low-level linked-list representation of the queue. *)

Open Scope Z_scope.

Definition enqueue : ident := 31%positive.
Definition dequeue : ident := 32%positive.

Section Queue.

  Context `{Hmem: BaseMemoryModel}.
  Context `{MakeProgramSpec.MakeProgram}.

  (** ** Abstract Data *)
  Section AbsData.

    Definition intro_L := node_L ⊕ queue_intro_L.

    Definition intro_M := node_M ⊕ queue_intro_M.

    Lemma intro_pres_inv :
      ForallPrimitive _ (CPrimitivePreservesInvariant _) intro_L.
    Proof. unfold intro_L, node_L, queue_intro_L. typeclasses eauto. Qed.

    (** We now require that once initialized, all nodes in range are valid,
      and everything else is undefined. *)
    Record queue_inv (d: abs_data) : Prop := {
      npool_valid: forall node,
        init_flag d = true ->
        0 <= node < MAX_NODES ->
        node_valid (ZMap.get node (npool d));
      npool_range: forall node,
        ~(0 <= node < MAX_NODES) ->
        ZMap.get node (npool d) = NodeUndef;
      preinit_q: init_flag d = false -> queue d = QueueUndef;
      q_valid: init_flag d = true -> queue_valid (queue d);
    }.

    Instance queue_data_ops : AbstractDataOps abs_data :=
      {|
        init_data := abs_data_init;
        data_inv := queue_inv;
        data_inject := fun _ _ _ => True
      |}.

    Instance queue_data_data : AbstractData abs_data.
    Proof.
      constructor; constructor; cbn; intros; try congruence.
      rewrite ZMap.gi; reflexivity.
    Qed.

    Definition queue_layerdata : layerdata :=
      {|
        ldata_type := abs_data;
        ldata_ops  := queue_data_ops;
        ldata_prf  := queue_data_data
      |}.

  End AbsData.

  (** ** High Level Specifications *)
  Section HighSpec.

    (** The two possibilities for [enqueue] are:
        - Queue is empty: set head and tail equal to the new node
        - Queue is not empty: set tail to the new node and make the new node
          and the old tail point to each other *)
    Definition enqueue_high_spec (node: Z) (abs: queue_layerdata)
        : option queue_layerdata :=
      if init_flag abs
        then if decide (0 <= node < MAX_NODES)
          then match queue abs, ZMap.get node (npool abs) with
            | Queue hd tl, Node dat _ _ =>
                if decide (tl = MAX_NODES)
                  then let n := Node dat MAX_NODES MAX_NODES in
                    Some abs {queue: Queue node node}
                             {npool: ZMap.set node n (npool abs)}
                  else match ZMap.get tl (npool abs) with
                    | Node tldat _ tlprv =>
                        let n := Node dat MAX_NODES tl in
                        let tl' := Node tldat node tlprv in
                        Some abs {queue: Queue hd node}
                                 {npool: ZMap.set node n (ZMap.set tl tl' (npool abs))}
                    | _ => None
                  end
            | _, _ => None
          end
          else None
        else None.

    Definition enqueue_high_sem : cprimitive queue_layerdata :=
      cgensem _ enqueue_high_spec.

    Global Instance enqueue_pres_inv :
      GenSemPreservesInvariant queue_layerdata enqueue_high_spec.
    Proof.
      split; auto.
      intros ? ? ? ? ? Hsem ? Hinv.
      inv_generic_sem Hsem.
      unfold enqueue_high_spec in H2.
      destruct Hinv.
      repeat destr_in H2; inv H2.
      - (** tl = MAX_NODES *)
        constructor; cbn; intros; auto; try congruence.
        + (** npool_valid *)
          destr_eq node (Int.unsigned i); [subst |].
          * rewrite ZMap.gss; constructor; omega.
          * rewrite ZMap.gso; auto.
        + (** npool_range *)
          destr_eq node (Int.unsigned i); [subst |].
          * omega.
          * rewrite ZMap.gso; auto.
        + (** q_valid *)
          constructor; omega.
      - (** tl <> MAX_NODES *)
        constructor; cbn; intros; auto; try congruence.
        + (** npool_valid *)
          destr_eq node (Int.unsigned i); [subst |].
          * rewrite ZMap.gss; constructor; try omega.
            specialize (q_valid0 eq_refl).
            inv q_valid0; auto.
          * rewrite ZMap.gso; auto.
            destr_eq node tail; [subst |].
            -- rewrite ZMap.gss.
               apply npool_valid0 in H2; auto; inv H2.
               constructor; (omega || congruence).
            -- rewrite ZMap.gso; auto.
        + (** npool_range *)
          destr_eq node (Int.unsigned i); [subst |].
          * omega.
          * rewrite ZMap.gso; auto.
            destr_eq node tail; [subst |].
            -- apply npool_range0 in H1. congruence.
            -- rewrite ZMap.gso; auto.
        + (** q_valid *)
          constructor; try omega.
          specialize (q_valid0 eq_refl).
          inv q_valid0; auto.
    Qed.

    (** [dequeue] also has two cases:
        - Queue has 1 element: set head and tail to [MAX_NODES]
        - Queue has more elements: set head to the old head's next node node
          and set the new head's prev to [MAX_NODES]

        One subtlety is that the order we update hd and hdnxt in the second
        case is important. We want to ensure that the node that is returned has
        its next and prev fields set to [MAX_NODES] so only nodes actually in
        the queue point to other nodes. Since we do not yet require that there
        are no cycles at this layer, it is possible for hd.next = hd in which
        case updating hd, then hd.next would undo the first step. Of course it
        is possible to design the specification to allow this behaviour, but it
        would require a change in the C code.

        TUTORIAL (optional):
        If you feel adventurous, uncomment the alternative version below and
        see how far through the proofs you get before you are stuck. You will
        find that at some point in the code proof you have to prove something
        like:
        [ZMap.set hd (Node data MAX_NODES MAX_NODES) =
         ZMap.set hd (Node data hd MAX_NODES)] *)
    Definition dequeue_high_spec (abs: queue_layerdata)
        : option (queue_layerdata * Z) :=
      if init_flag abs
        then match queue abs with
          | Queue hd tl =>
              if decide (hd <> MAX_NODES)
                then match ZMap.get hd (npool abs) with
                  | Node hddat hdnxt _ =>
                      let n := Node hddat MAX_NODES MAX_NODES in
                      let pool' := ZMap.set hd n (npool abs) in
                      if decide (hdnxt = MAX_NODES)
                        then Some (abs {queue: Queue MAX_NODES MAX_NODES}
                                       {npool: pool'},
                                   hd)
                        else match ZMap.get hdnxt (npool abs) with
                          | Node nxtdat nxtnxt _ =>
                              Some (abs {queue: Queue hdnxt tl}
                                        (** Swap these npools to see why the
                                           order matters *)
                                        (** {npool: ZMap.set hdnxt (Node nxtdat nxtnxt MAX_NODES ) pool'}, *)
                                        {npool: ZMap.set hd n
                                                  (ZMap.set hdnxt
                                                            (Node nxtdat nxtnxt MAX_NODES)
                                                            (npool abs))},
                                    hd)
                          | _ => None
                        end
                  | _ => None
                end
                else None
          | _ => None
        end
        else None.

    Definition dequeue_high_sem : cprimitive queue_layerdata :=
      cgensem _ dequeue_high_spec.

    Global Instance dequeue_pres_inv :
      GenSemPreservesInvariant queue_layerdata dequeue_high_spec.
    Proof.
      Opaque Z.mul.
      split; auto.
      intros ? ? ? ? ? Hsem ? Hinv.
      inv_generic_sem Hsem.
      unfold dequeue_high_spec in H2.
      destruct Hinv.
      pose proof MAX_NODES_range as Hmn_range.
      repeat destr_in H2; inv H2.
      - constructor; cbn; intros; auto; try congruence.
        + (** npool_valid *)
          destr_eq node (Int.unsigned z); [subst |].
          * rewrite ZMap.gss; constructor; omega.
          * rewrite ZMap.gso; auto.
        + (** npool_range *)
          destr_eq node (Int.unsigned z); [subst |].
          * apply npool_range0 in H1. congruence.
          * rewrite ZMap.gso; auto.
        + (** q_valid *)
          constructor; omega.
      - constructor; cbn; intros; auto; try congruence.
        + (** npool_valid *)
          destr_eq node (Int.unsigned z); [subst |].
          * rewrite ZMap.gss.
            constructor; omega.
          * rewrite ZMap.gso; auto.
            destr_eq node next; [subst |].
            -- rewrite ZMap.gss.
               apply npool_valid0 in H2; auto; inv H2.
               constructor; (omega || congruence).
            -- rewrite ZMap.gso; auto.
        + (** npool_range *)
          destr_eq node (Int.unsigned z); [subst |].
          * apply npool_range0 in H1. congruence.
          * rewrite ZMap.gso; auto.
            destr_eq node next; [subst |].
            -- apply npool_range0 in H1. congruence.
            -- rewrite ZMap.gso; auto.
        + (** q_valid *)
          specialize (q_valid0 eq_refl).
          inv q_valid0.
          assert (Hz: 0 <= Int.unsigned z < MAX_NODES).
          { cut (0 <= Int.unsigned z <= MAX_NODES /\ Int.unsigned z <> MAX_NODES);
            [omega | split]; eauto. }
          apply npool_valid0 in Hz; auto; inv Hz.
          constructor; congruence.
      Qed.

  End HighSpec.

  (** ** Module Implementation *)
  Section Code.

    Definition e_node : ident := 35%positive.
    Definition e_tail : ident := 36%positive.

    Definition f_enqueue' :=
      {|
        fn_return := tvoid;
        fn_callconv := cc_default;
        fn_params := (e_node, tuint) :: nil;
        fn_vars := nil;
        fn_temps := (e_tail, tuint) :: nil;
        fn_body :=
          Ssequence
           (Scall (Some e_tail)
             (Evar get_tail (Tfunction Ctypes.Tnil tuint cc_default)) nil)
           (Sifthenelse (Ebinop Oeq (Etempvar e_tail tuint)
                          (Econst_int (Int.repr MAX_NODES) tint) tint)
             (Ssequence
               (Scall None
                 (Evar set_next (Tfunction (Ctypes.Tcons tuint (Ctypes.Tcons tuint Ctypes.Tnil)) tvoid
                                   cc_default))
                 ((Etempvar e_node tuint) :: (Econst_int (Int.repr MAX_NODES) tint) :: nil))
               (Ssequence
                 (Scall None
                   (Evar set_prev (Tfunction (Ctypes.Tcons tuint (Ctypes.Tcons tuint Ctypes.Tnil)) tvoid
                                     cc_default))
                   ((Etempvar e_node tuint) :: (Econst_int (Int.repr MAX_NODES) tint) ::
                    nil))
                 (Ssequence
                   (Scall None
                     (Evar set_head (Tfunction (Ctypes.Tcons tuint Ctypes.Tnil) tvoid cc_default))
                     ((Etempvar e_node tuint) :: nil))
                   (Scall None
                     (Evar set_tail (Tfunction (Ctypes.Tcons tuint Ctypes.Tnil) tvoid cc_default))
                     ((Etempvar e_node tuint) :: nil)))))
             (Ssequence
               (Scall None
                 (Evar set_next (Tfunction (Ctypes.Tcons tuint (Ctypes.Tcons tuint Ctypes.Tnil)) tvoid
                                   cc_default))
                 ((Etempvar e_tail tuint) :: (Etempvar e_node tuint) :: nil))
               (Ssequence
                 (Scall None
                   (Evar set_prev (Tfunction (Ctypes.Tcons tuint (Ctypes.Tcons tuint Ctypes.Tnil)) tvoid
                                     cc_default))
                   ((Etempvar e_node tuint) :: (Etempvar e_tail tuint) :: nil))
                 (Ssequence
                   (Scall None
                     (Evar set_next (Tfunction (Ctypes.Tcons tuint (Ctypes.Tcons tuint Ctypes.Tnil)) tvoid
                                       cc_default))
                     ((Etempvar e_node tuint) :: (Econst_int (Int.repr MAX_NODES) tint) ::
                      nil))
                   (Scall None
                     (Evar set_tail (Tfunction (Ctypes.Tcons tuint Ctypes.Tnil) tvoid cc_default))
                     ((Etempvar e_node tuint) :: nil))))))
      |}.

    Program Definition f_enqueue : function :=
      inline f_enqueue' _.

    Definition d_head : ident := 37%positive.
    Definition d_next : ident := 38%positive.
    Definition d_node : ident := 39%positive.

    Definition f_dequeue' :=
      {|
        fn_return := tuint;
        fn_callconv := cc_default;
        fn_params := nil;
        fn_vars := nil;
        fn_temps := (d_head, tuint) :: (d_next, tuint) :: (d_node, tuint) :: nil;
        fn_body :=
          Ssequence
           (Sset d_node (Econst_int (Int.repr MAX_NODES) tint))
           (Ssequence
             (Scall (Some d_head)
               (Evar get_head (Tfunction Ctypes.Tnil tuint cc_default)) nil)
             (Ssequence
               (Sifthenelse (Ebinop One (Etempvar d_head tuint)
                              (Econst_int (Int.repr MAX_NODES) tint) tint)
                 (Ssequence
                   (Sset d_node (Etempvar d_head tuint))
                   (Ssequence
                     (Scall (Some d_next)
                       (Evar get_next (Tfunction (Ctypes.Tcons tuint Ctypes.Tnil) tuint
                                         cc_default))
                       ((Etempvar d_head tuint) :: nil))
                     (Ssequence
                       (Sifthenelse (Ebinop Oeq (Etempvar d_next tuint)
                                      (Econst_int (Int.repr MAX_NODES) tint) tint)
                         (Ssequence
                           (Scall None
                             (Evar set_head (Tfunction (Ctypes.Tcons tuint Ctypes.Tnil) tvoid
                                               cc_default))
                             ((Econst_int (Int.repr MAX_NODES) tint) :: nil))
                           (Scall None
                             (Evar set_tail (Tfunction (Ctypes.Tcons tuint Ctypes.Tnil) tvoid
                                               cc_default))
                             ((Econst_int (Int.repr MAX_NODES) tint) :: nil)))
                         (Ssequence
                           (Scall None
                             (Evar set_prev (Tfunction
                                               (Ctypes.Tcons tuint (Ctypes.Tcons tuint Ctypes.Tnil)) tvoid
                                               cc_default))
                             ((Etempvar d_next tuint) ::
                              (Econst_int (Int.repr MAX_NODES) tint) :: nil))
                           (Scall None
                             (Evar set_head (Tfunction (Ctypes.Tcons tuint Ctypes.Tnil) tvoid
                                               cc_default))
                             ((Etempvar d_next tuint) :: nil))))
                       (Ssequence
                         (Scall None
                           (Evar set_next (Tfunction (Ctypes.Tcons tuint (Ctypes.Tcons tuint Ctypes.Tnil))
                                             tvoid cc_default))
                           ((Etempvar d_node tuint) ::
                            (Econst_int (Int.repr MAX_NODES) tint) :: nil))
                         (Scall None
                           (Evar set_prev (Tfunction (Ctypes.Tcons tuint (Ctypes.Tcons tuint Ctypes.Tnil))
                                             tvoid cc_default))
                           ((Etempvar d_node tuint) ::
                            (Econst_int (Int.repr MAX_NODES) tint) :: nil))))))
                 Sskip)
               (Sreturn (Some (Etempvar d_node tuint)))))
      |}.

    Program Definition f_dequeue : function :=
      inline f_dequeue' _.

  End Code.

  (** ** Low Level Specifications *)
  Section LowSpec.

    Definition enqueue_csig :=
      mkcsig (type_of_list_type (tuint :: nil)) tvoid.

    Inductive enqueue_step :
      csignature -> list val * mwd intro_layerdata -> val * mwd intro_layerdata -> Prop :=
    | enqueue_step_intro m d nd d':
        enqueue_high_spec (Int.unsigned nd) d = Some d' ->
        enqueue_step enqueue_csig
                     (Vint nd :: nil, (m, d))
                     (Vundef, (m, d')).

    Definition dequeue_csig :=
      mkcsig (type_of_list_type nil) tuint.

    Inductive dequeue_step :
      csignature -> list val * mwd intro_layerdata -> val * mwd intro_layerdata -> Prop :=
    | dequeue_step_intro m d nd d':
        dequeue_high_spec d = Some (d', Int.unsigned nd) ->
        dequeue_step dequeue_csig
                     (nil, (m, d))
                     (Vint nd, (m, d')).

    Program Definition enqueue_cprim : cprimitive intro_layerdata :=
      mkcprimitive _ enqueue_step enqueue_csig _.
    Next Obligation.
      now inv H0.
    Qed.

    Program Definition dequeue_cprim : cprimitive intro_layerdata :=
      mkcprimitive _ dequeue_step dequeue_csig _.
    Next Obligation.
      now inv H0.
    Qed.

    Global Instance enqueue_cprim_pres_inv : CPrimitivePreservesInvariant _ enqueue_cprim.
    Proof.
      constructor; intros.
      - inv H0. unfold enqueue_high_spec in H4.
        inv H1. inv cprimitive_inv_init_state_data_inv.
        repeat destr_in H4; inv H4.
        { (** tail = MAX_NODES *)
          constructor; auto.
          constructor; cbn; try congruence; intros.
          - destr_eq node (Int.unsigned nd); subst.
            + rewrite ZMap.gss. right. constructor; omega.
            + rewrite ZMap.gso; auto.
          - constructor; omega.
        }
        { (** tail <> MAX_NODES *)
          constructor; auto.
          specialize (q_valid0 eq_refl); inv q_valid0.
          constructor; cbn; try congruence; intros.
          - destr_eq node (Int.unsigned nd); subst.
            + rewrite ZMap.gss.
              right. constructor; omega.
            + rewrite ZMap.gso; auto.
              destr_eq node tail; subst.
              * rewrite ZMap.gss.
                apply npool_valid0 in H0.
                destruct H0; try congruence.
                inv H0. rewrite Heqn0 in H1; inv H1.
                right. constructor; try omega.
              * rewrite ZMap.gso; auto.
          - constructor; omega.
        }
      - inv H0; reflexivity.
    Qed.

    Global Instance dequeue_cprim_pres_inv : CPrimitivePreservesInvariant _ dequeue_cprim.
    Proof.
      Opaque Z.mul.
      pose proof MAX_NODES_range as Hmn_range.
      constructor; intros.
      - inv H0. unfold dequeue_high_spec in H4.
        inv H1. inv cprimitive_inv_init_state_data_inv.
        repeat destr_in H4; inv H4.
        { (** next = MAX_NODES *)
          constructor; auto.
          constructor; cbn; try congruence; intros.
          - destr_eq node (Int.unsigned nd); subst.
            + rewrite ZMap.gss. right. constructor; omega.
            + rewrite ZMap.gso; auto.
          - constructor; omega.
        }
        { (** next <> MAX_NODES *)
          constructor; auto.
          specialize (q_valid0 eq_refl); inv q_valid0.
          constructor; cbn; try congruence; intros.
          - destr_eq node (Int.unsigned nd); subst.
            + rewrite ZMap.gss.
              right. constructor; omega.
            + rewrite ZMap.gso; auto.
              destr_eq node next; subst.
              * rewrite ZMap.gss.
                apply npool_valid0 in H0.
                destruct H0; try congruence.
                inv H0. rewrite Heqn1 in H1; inv H1.
                right. constructor; try omega.
              * rewrite ZMap.gso; auto.
          - assert (0 <= Int.unsigned nd < MAX_NODES) by omega.
            apply npool_valid0 in H1.
            destruct H1; try congruence.
            inv H1. rewrite Heqn0 in H4; inv H4.
            constructor; omega.
        }
      - inv H0; reflexivity.
      Qed.

  End LowSpec.

  (** ** Code Proofs *)
  Section CodeLowSpecSim.

    Context `{ce: ClightCompositeEnv}.

    (** We can automatically solve the additional goal introduced by
      [code_proof_tac] by using a hint. *)
    Hint Resolve intro_pres_inv : linking.

    Lemma enqueue_code :
      intro_L ⊢ (inv, enqueue ↦ f_enqueue) : (enqueue ↦ enqueue_cprim).
    Proof.
      Opaque Z.mul.
      code_proof_tac.
      find_prim get_tail.
      find_prim set_next.
      find_prim set_prev.
      find_prim set_head.
      find_prim set_tail.
      inv Hmatch; inv CStep.
      destruct cprimitive_inv_init_state_data_inv.
      unfold enqueue_high_spec in H2.
      do 4 (destr_in H2; try discriminate).
      rename Heqb into Hinit;
      rename Heqq into Hqueue;
      rename Heqn into Hnode;
      rename Heqs into Hnode_range.
      cprim_step.
      pose proof MAX_NODES_range as Hmn_range.
      repeat (destr_in H2; inv H2).
      { (** tail = MAX_NODES *)
        repeat step_tac.
        - unfold get_tail_high_spec.
          rewrite Hinit, Hqueue.
          rewrite Int.unsigned_repr; [reflexivity | cbn; omega].
        - reflexivity.
        - repeat step_tac.
          + unfold set_next_high_spec.
            rewrite Hnode_range, Hnode.
            rewrite Int.unsigned_repr; try (cbn; omega). destr; try omega.
            reflexivity.
          + unfold set_prev_high_spec; cbn.
            rewrite Hnode_range.
            rewrite Int.unsigned_repr; try (cbn; omega). destr; try omega.
            rewrite ZMap.gss.
            reflexivity.
          + unfold set_head_high_spec; cbn.
            rewrite Hinit, Hqueue.
            destr; try omega.
            reflexivity.
          + unfold set_tail_high_spec; cbn.
            rewrite Hinit.
            destr; try omega.
            unfold update_queue, update_npool; cbn.
            rewrite ZMap.set2.
            reflexivity.
      }
      { (** tail <> MAX_NODES *)
        (** Need invariant to prove *)
        assert (Htail_range: 0 <= tail <= MAX_NODES).
        { specialize (q_valid0 eq_refl); inv q_valid0; auto. }
        destr_in H1; inv H1.
        rename Heqn0 into Htail.
        repeat step_tac.
        - unfold get_tail_high_spec.
          rewrite Hinit, Hqueue.
          rewrite Int.unsigned_repr; [reflexivity | cbn; omega].
        - rewrite Int.eq_false; [reflexivity |].
          red; intros.
          apply (f_equal Int.unsigned) in H0.
          repeat (rewrite Int.unsigned_repr in H0; try (cbn; omega)).
        - destr_eq tail (Int.unsigned nd); [subst |].
          + repeat step_tac.
            * unfold set_next_high_spec.
              rewrite Int.unsigned_repr; try (cbn; omega).
              rewrite Htail.
              repeat destr; try omega.
              reflexivity.
            * unfold set_prev_high_spec; cbn.
              rewrite Hnode_range.
              rewrite Int.unsigned_repr; try (cbn; omega). destr; try omega.
              subst; rewrite ZMap.gss. reflexivity.
            * unfold set_next_high_spec.
              rewrite Int.unsigned_repr; try (cbn; omega).
              rewrite Hnode_range.
              destr; try omega.
              rewrite ZMap.gss. reflexivity.
            * unfold set_tail_high_spec; cbn.
              rewrite Hinit, Hqueue.
              destr; try omega.
              unfold update_npool, update_queue; cbn.
              repeat rewrite ZMap.set2.
              congruence.
          + repeat step_tac.
            * unfold set_next_high_spec.
              rewrite Int.unsigned_repr; try (cbn; omega).
              rewrite Htail.
              repeat destr; try omega.
              reflexivity.
            * unfold set_prev_high_spec; cbn.
              rewrite Hnode_range.
              rewrite Int.unsigned_repr; try (cbn; omega). destr; try omega.
              subst; rewrite ZMap.gso; auto. rewrite Hnode.
              reflexivity.
            * unfold set_next_high_spec.
              rewrite Int.unsigned_repr; try (cbn; omega).
              rewrite Hnode_range.
              destr; try omega.
              rewrite ZMap.gss. reflexivity.
            * unfold set_tail_high_spec; cbn.
              rewrite Hinit, Hqueue.
              destr; try omega.
              unfold update_npool, update_queue; cbn.
              repeat rewrite ZMap.set2.
              congruence.
      }
    Qed.

    Lemma dequeue_code :
      intro_L ⊢ (inv, dequeue ↦ f_dequeue) : (dequeue ↦ dequeue_cprim).
    Proof.
      Opaque Z.mul.
      code_proof_tac.
      find_prim get_head.
      find_prim get_next.
      find_prim set_next.
      find_prim set_prev.
      find_prim set_head.
      find_prim set_tail.
      inv Hmatch; inv CStep.
      destruct cprimitive_inv_init_state_data_inv.
      unfold dequeue_high_spec in H2.
      do 4 (destr_in H2; try discriminate).
      rename Heqb into Hinit;
      rename Heqq into Hqueue;
      rename Heqn0 into Hnode.
      cprim_step.
      pose proof MAX_NODES_range as Hmn_range.
      (** Need invariant to prove *)
      assert (Hhead_range: 0 <= head < MAX_NODES).
      { cut (0 <= head <= MAX_NODES /\ head <> MAX_NODES);
        [omega | split]; auto.
        specialize (q_valid0 eq_refl); inv q_valid0; auto.
      }
      repeat (destr_in H2; inv H2).
      { (** next = MAX_NODES *)
        repeat step_tac.
        - unfold get_head_high_spec.
          rewrite Hinit, Hqueue.
          reflexivity.
        - rewrite Int.eq_false; [reflexivity |].
          red; intros Heq.
          pose proof n as Hneq; rewrite Heq in Hneq.
          rewrite Int.unsigned_repr in Hneq; [contradiction | cbn; omega].
        - repeat step_tac.
          + unfold get_next_high_spec.
            rewrite Hnode.
            destruct (decide (_ <= _ < _)); try omega.
            rewrite Int.unsigned_repr; [reflexivity | cbn; omega].
          + reflexivity.
          + repeat step_tac.
            * unfold set_head_high_spec.
              rewrite Hinit, Hqueue.
              rewrite Int.unsigned_repr; try (cbn; omega).
              destr; try omega.
              reflexivity.
            * unfold set_tail_high_spec; cbn.
              rewrite Hinit.
              rewrite Int.unsigned_repr; try (cbn; omega).
              destr; try omega.
              reflexivity.
            * unfold set_next_high_spec; cbn.
              rewrite Hnode.
              rewrite Int.unsigned_repr; try (cbn; omega).
              destr; try omega. destr; try omega.
              reflexivity.
            * unfold set_prev_high_spec; cbn.
              rewrite ZMap.gss.
              rewrite Int.unsigned_repr; try (cbn; omega).
              destr; try omega. destr; try omega.
              unfold update_queue, update_npool; cbn.
              rewrite ZMap.set2.
              reflexivity.
      }
      { (** next <> MAX_NODES *)
        (** Need invariant to prove *)
        assert (Hnext_range: 0 <= next <= MAX_NODES).
        { apply npool_valid0 in Hhead_range. rewrite Hnode in Hhead_range.
          destruct Hhead_range as [Hvalid | Hvalid]; inv Hvalid; auto.
        }
        destr_in H1; inv H1.
        rename Heqn1 into Hnext.
        repeat step_tac.
        - unfold get_head_high_spec.
          rewrite Hinit, Hqueue.
          rewrite Int.unsigned_repr; [reflexivity | cbn; omega].
        - rewrite Int.eq_false; [reflexivity |].
          red; intros Heq.
          apply (f_equal Int.unsigned) in Heq.
          repeat (rewrite Int.unsigned_repr in Heq; try (cbn; omega)).
        - repeat step_tac.
          + unfold get_next_high_spec.
            rewrite Int.unsigned_repr; try (cbn; omega).
            rewrite Hnode.
            destruct (decide (_ <= _ < _)); try omega.
            rewrite Int.unsigned_repr; [reflexivity | cbn; omega].
          + rewrite Int.eq_false; [reflexivity |].
            red; intros Heq.
            apply (f_equal Int.unsigned) in Heq.
            repeat (rewrite Int.unsigned_repr in Heq; try (cbn; omega)).
          + destr_eq next (Int.unsigned nd); [subst |].
            * repeat step_tac.
              -- unfold set_prev_high_spec.
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 rewrite Hnext.
                 destr; try omega. destr; try omega.
                 reflexivity.
              -- unfold set_head_high_spec; cbn.
                 rewrite Hinit, Hqueue.
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 destr; try omega.
                 reflexivity.
              -- unfold set_next_high_spec; cbn.
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 destr; try omega. destr; try omega.
                 rewrite ZMap.gss. reflexivity.
              -- unfold set_prev_high_spec; cbn.
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 destr; try omega. destr; try omega.
                 rewrite ZMap.gss. reflexivity.
              -- unfold update_queue, update_npool; cbn.
                 repeat rewrite ZMap.set2.
                 rewrite Hnext in Hnode. inv Hnode.
                 rewrite Int.repr_unsigned.
                 step_tac.
            * repeat step_tac.
              -- unfold set_prev_high_spec.
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 rewrite Hnext.
                 destr; try omega. destr; try omega.
                 reflexivity.
              -- unfold set_head_high_spec; cbn.
                 rewrite Hinit, Hqueue.
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 destr; try omega.
                 reflexivity.
              -- unfold set_next_high_spec; cbn.
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 destr; try omega. destr; try omega.
                 rewrite ZMap.gso; auto. rewrite Hnode.
                 reflexivity.
              -- unfold set_prev_high_spec; cbn.
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 rewrite Int.unsigned_repr; try (cbn; omega).
                 destr; try omega. destr; try omega.
                 rewrite ZMap.gss. reflexivity.
              -- unfold update_queue, update_npool; cbn.
                 repeat rewrite ZMap.set2.
                 rewrite Int.repr_unsigned.
                 step_tac.
      }
    Qed.

  End CodeLowSpecSim.

  (** ** Layer Relation *)
  Section LowHighSpecRel.

    Inductive match_data : queue_layerdata -> mem -> Prop :=
    | match_data_intro: forall m abs,
        match_data abs m.

    Record relate_data (hadt: queue_layerdata) (ladt: intro_layerdata) := {
      init_rel: init_flag hadt = init_flag ladt;
      npool_rel: npool hadt = npool ladt;
      queue_rel: queue hadt = queue ladt
    }.

    Definition abrel_components_queue_intro :
      abrel_components queue_layerdata intro_layerdata :=
      {|
        abrel_relate := relate_data;
        abrel_match  := match_data;
        abrel_new_glbl := nil
      |}.

    Global Instance rel_ops :
      AbstractionRelation _ _ abrel_components_queue_intro.
    Proof. repeat constructor. Qed.

    Definition abrel_queue_intro : abrel queue_layerdata intro_layerdata :=
      {|
        abrel_ops := abrel_components_queue_intro;
        abrel_prf := rel_ops
      |}.

    Definition queue_R : simrel _ _ := abrel_simrel _ _ abrel_queue_intro.

  End LowHighSpecRel.

  (** ** Refinement Proofs *)
  Section LowHighSpecSim.

    Context `{ce: ClightCompositeEnv}.

    Lemma enqueue_refine :
      (enqueue ↦ enqueue_cprim) ⊢ (queue_R, ∅) : (enqueue ↦ enqueue_high_sem).
    Proof.
      refine_proof_tac.
      inv CStep. inv_generic_sem H8.
      inverse_hyps.
      inversion MemRel.
      inv abrel_match_mem_match.
      inv abrel_match_mem_relate.
      unfold enqueue_high_spec in H1.
      repeat destr_in H1; inv H1;
      rename Heqn into Hnode.
      { (** tail = MAX_NODES *)
        do 3 eexists; split.
        - econstructor. unfold enqueue_high_spec.
          rewrite <- init_rel0, <- queue_rel0, <- npool_rel0, Hnode.
          destr; try omega. destr; try omega.
          reflexivity.
        - repeat (constructor; auto).
          cbn; congruence.
      }
      { (** tail <> MAX_NODES *)
        rename Heqn0 into Htail.
        do 3 eexists; split.
        - econstructor. unfold enqueue_high_spec.
          rewrite <- init_rel0, <- queue_rel0, <- npool_rel0, Hnode, Htail.
          destr; try omega. destr; try omega.
          reflexivity.
        - repeat (constructor; auto).
          cbn; congruence.
      }
    Qed.

    Lemma dequeue_refine :
      (dequeue ↦ dequeue_cprim) ⊢ (queue_R, ∅) : (dequeue ↦ dequeue_high_sem).
    Proof.
      refine_proof_tac.
      inv CStep. inv_generic_sem H8.
      inverse_hyps.
      inversion MemRel.
      inv abrel_match_mem_match.
      inv abrel_match_mem_relate.
      unfold dequeue_high_spec in H1.
      repeat destr_in H1; inv H1;
      rename Heqs into Hz_neq;
      rename Heqn0 into Hnode.
      { (** tail = MAX_NODES *)
        do 3 eexists; split.
        - econstructor. unfold dequeue_high_spec.
          rewrite <- init_rel0, <- queue_rel0, <- npool_rel0, Hz_neq, Hnode.
          destr; try omega.
          reflexivity.
        - repeat (constructor; auto).
          cbn; congruence.
      }
      { (** tail <> MAX_NODES *)
        rename Heqn1 into Hnext.
        rename  Heqs0 into Hnext_neq.
        do 3 eexists; split.
        - econstructor. unfold dequeue_high_spec.
          rewrite <- init_rel0, <- queue_rel0, <- npool_rel0, Hz_neq, Hnode,
                  Hnext, Hnext_neq.
          reflexivity.
        - repeat (constructor; auto).
          cbn; congruence.
      }
    Qed.

  End LowHighSpecSim.

  (** ** Linking *)
  Section Linking.

    Context `{ce: ClightCompositeEnv}.
    Hypothesis Hce :
      build_composite_env (node_t_comp :: queue_t_comp :: nil) = OK ce.

    Definition queue_L : clayer queue_layerdata :=
      enqueue ↦ enqueue_high_sem
      ⊕ dequeue ↦ dequeue_high_sem.

    Definition queue_Σ : clayer intro_layerdata :=
      enqueue ↦ enqueue_cprim
      ⊕ dequeue ↦ dequeue_cprim.

    Definition queue_M : cmodule :=
      enqueue ↦ f_enqueue
      ⊕ dequeue ↦ f_dequeue.

    Hint Resolve enqueue_code enqueue_refine
                 dequeue_code dequeue_refine : linking.

    (** [link_tac] still works even though [queue_L] is built on top of a
      composition of layers. *)
    Theorem queue_link :
      intro_L ⊢ (inv ∘ queue_R ∘ inv, queue_M) : queue_L.
    Proof. link_tac queue_Σ. Qed.

    Lemma queue_pres_inv :
      ForallPrimitive _ (CPrimitivePreservesInvariant _) queue_L.
    Proof. unfold queue_L. typeclasses eauto. Qed.

    Hint Resolve node_link queue_intro_link queue_link : linking.

    Theorem queue_boot_link :
      boot_L ⊢ (intro_R ∘ inv ∘ queue_R ∘ inv, intro_M ⊕ queue_M) : queue_L.
    Proof.
      apply (vdash_rel_equiv _ _ (intro_R ∘ (inv ∘ queue_R ∘ inv))).
      rewrite cat_compose_assoc; rewrite cat_compose_assoc; reflexivity.
      eapply vcomp_rule; eauto with linking.
      unfold intro_M, intro_L.
      apply hcomp_rule; auto with linking.
    Qed.

  End Linking.

End Queue.


From melocoton.language Require Export weakestpre lifting.
From melocoton.c_lang Require Export lang.
From melocoton.c_lang Require Import tactics notation.
From iris.prelude Require Import options.

Section pure_exec.
  Variable (p:language.prog C_lang).
  Local Ltac solve_exec_safe := intros; subst; do 2 eexists; try (repeat (econstructor; eauto); done).
  Local Ltac solve_exec_puredet := simpl; intros; inv_head_step; try done.
  Local Ltac solve_pure_exec :=
    subst; intros ?; apply nsteps_once, pure_head_step_pure_step;
      constructor; [solve_exec_safe | solve_exec_puredet].

  Local Ltac destruct_bool_decide := repeat (let H := fresh "Heq" in
    try destruct bool_decide eqn:H;
    [apply bool_decide_eq_true_1 in H| apply bool_decide_eq_false_1 in H]).

  Global Instance pure_unop op v v' :
    PureExec (un_op_eval op v = Some v') 1 p (UnOp op (Val v)) (Val v').
  Proof. solve_pure_exec. Qed.

  Global Instance pure_binop op v1 v2 v' :
    PureExec (bin_op_eval op v1 v2 = Some v') 1 p (BinOp op (Val v1) (Val v2)) (Val (LitV v')) | 10.
  Proof. solve_pure_exec. Qed.

  Global Instance pure_if_true v e1 e2 : asTruth v = true ->
    PureExec True 1 p (If (Val $ v) e1 e2) e1.
  Proof. intros H. solve_pure_exec. congruence. Qed.
  Global Instance pure_if_non_zero (v0:Z) e1 e2 : v0 ≠ 0%Z ->
    PureExec True 1 p (If (Val $ LitV $ LitInt v0) e1 e2) e1.
  Proof. intros H. apply pure_if_true. destruct v0; cbn; congruence. Qed.
  Global Instance pure_if_true_bool e1 e2 :
    PureExec True 1 p (If (Val $ LitV $ LitBool true) e1 e2) e1.
  Proof. apply pure_if_true. easy. Qed.
  Global Instance pure_if_false v e1 e2 : asTruth v = false ->
    PureExec True 1 p (If (Val $ v) e1 e2) e2.
  Proof. intros H. solve_pure_exec. congruence. Qed.
  Global Instance pure_if_zero e1 e2 :
    PureExec True 1 p (If (Val $ LitV $ LitInt (0%Z)) e1 e2) e2.
  Proof. apply pure_if_false. easy. Qed.
  Global Instance pure_if_false_bool e1 e2 :
    PureExec True 1 p (If (Val $ LitV $ LitBool false) e1 e2) e2.
  Proof. apply pure_if_zero. Qed.

  Global Instance pure_while e1 e2 :
    PureExec True 1 p (While e1 e2) (If e1 (Let BAnon e1 (While e1 e2)) (Val $ LitV $ LitInt 0)).
  Proof. solve_pure_exec. Qed.

  Global Instance pure_let x (v1:val) e2 :
    PureExec True 1 p (Let x v1 e2) (subst' x v1 e2).
  Proof. solve_pure_exec. Qed.

  Global Instance pure_funcall s va args res e :
    PureExec ((p : gmap.gmap string function) !! s = Some (Fun args e) ∧ zip_args args va = Some res) 1 p (FunCall (Val $ LitV $ LitFunPtr s) (map Val va)) (subst_all res e).
  Proof. solve_pure_exec; destruct H as [H1 H2].
    1: econstructor; first done.
    + unfold apply_function. rewrite H2. reflexivity.
    + repeat split; try congruence. destruct (zip_args args0 va) eqn:Heq; last congruence.
      congruence.
  Qed.
End pure_exec.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype seq.
Require Import Init_ext ZArith_ext uniq_tac machine_int multi_int encode_decode integral_type.
Import MachineInt.
Require Import mips_bipl mips_seplog mips_tactics mips_syntax mips_mint.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.
Require Import multi_zero_u_prg multi_zero_u_triple multi_zero_u_termination.

Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.

Lemma multi_zero_u_safe_termination a0 a1 rx x rk d : uniq(rk, rx, a0, a1, r0) ->
  safe_termination
  (state_mint (x |=> unsign rk rx \U+ d)) (multi_zero_u rk rx a0 a1).
Proof.
move=> Hset.
rewrite /safe_termination => st s h st_s_h.
set code := multi_zero_u _ _ _ _.
move: (multi_zero_u_termination s h _ _ _ _ Hset) => [x0 Htermi].
have H1 : (u2Z ([ rx ]_ s) + 4 * Z_of_nat (Z.abs_nat (u2Z ([rk ]_ s))) < Zbeta 1)%asm_expr.
  apply state_mint_head_unsign_fit with x d st h.
  by apply st_s_h.
have H2 : (size (Z2ints 32 (Z.abs_nat (u2Z ([ rk ]_ s))) ([ x ]_st)%pseudo_expr) =
  Z.abs_nat (u2Z ([rk ]_ s)))%asm_expr.
  by rewrite size_Z2ints.
move: (multi_zero_u_triple _ _ _ _ Hset _ _ _ H2 H1) => triple_hoare.
apply constructive_indefinite_description'.
apply (mips_syntax.triple_exec_precond _ _ _ triple_hoare _ _ _ Htermi (List.seq
      (Z.abs_nat (u2Z ([rx ]_ s) / 4)) (Z.abs_nat (u2Z ([rk ]_ s))))%asm_expr).
split; first done.
split.
- rewrite Z_of_nat_Zabs_nat //; by apply min_u2Z.
- apply (state_mint_var_mint _ _ _ _ x (unsign rk rx)) in st_s_h; last by assoc_get_Some.
  by apply st_s_h.
Qed.


From iris.algebra Require Import auth agree excl csum.
From Perennial.base_logic Require Import ae_invariants.
From iris.bi Require Export weakestpre.
From iris.proofmode Require Import base tactics classes.
From Perennial.base_logic Require Export invariants fancy_updates2.
From Perennial.program_logic Require Import step_fupd_extra ae_invariants_mutable.
From Perennial.algebra Require Export own_discrete.
From Perennial.base_logic.lib Require Export ncfupd.
From iris.prelude Require Import options.
Import uPred.

(* first, define a modality for establishing crash conditions *)
Section cfupd.
  Context `{crashGS Σ} `{invGS Σ}.
  Implicit Types (P: iProp Σ).

  Definition cfupd E1 :=
    λ P, (C -∗ |={E1}=> P)%I.

  Lemma cfupd_wand  (E1 E1' : coPset) P Q:
    E1' ⊆ E1 →
    cfupd E1' P -∗
    (P -∗ Q) -∗
    cfupd E1 Q.
  Proof.
    iIntros (?) "HP HPQ".
    iIntros "HC". iSpecialize ("HP" with "[$]").
    iMod (fupd_mask_mono with "HP") as "HP"; auto.
    iModIntro. by iApply "HPQ".
  Qed.

  Global Instance cfupd_proper_ent E1 :
    Proper ((⊢) ==> (⊢)) (cfupd E1).
  Proof.
    iIntros (P Q Hent) "Hfupd".
    iApply (cfupd_wand with "Hfupd"); eauto.
    iApply Hent.
  Qed.

  Global Instance cfupd_proper_equiv E1 :
    Proper ((⊣⊢) ==> (⊣⊢)) (cfupd E1).
  Proof.
    intros P Q Hequiv.
    iSplit; iIntros "H".
    - iApply (cfupd_wand with "H"); eauto.
      rewrite Hequiv; auto.
    - iApply (cfupd_wand with "H"); eauto.
      rewrite Hequiv; auto.
  Qed.

  Global Instance from_modal_fupd_iter k E P :
    FromModal True modality_id
              (Nat.iter k (fupd E E) P)
              (Nat.iter k (fupd E E) P) P.
  Proof.
    rewrite /FromModal /=.
    iIntros (_) "HP".
    iInduction k as [|k] "IH".
    - simpl; auto.
    - simpl.
      iModIntro.
      iApply "IH"; iFrame.
  Qed.

  Theorem step_fupd_iter_intro k E1 E2 P :
    E2 ⊆ E1 →
    ▷^k P -∗ (Nat.iter k (fun P : iProp Σ =>
                        fupd E1 E2 (▷ (fupd E2 E1 P))) P).
  Proof.
    iIntros (?) "HP".
    iInduction k as [|k] "IH".
    - simpl; auto.
    - simpl.
      iMod (fupd_mask_subseteq E2) as "Hclo"; auto.
      iModIntro.
      iModIntro.
      iMod "Hclo" as "_".
      iModIntro.
      iApply ("IH" with "HP").
  Qed.

  Lemma fupd_iter_intro E1 k P :
    ▷^k P -∗ |={E1,E1}_(k)=> P.
  Proof.
    iIntros "HP".
    iMod (fupd_mask_subseteq ∅) as "Hclo"; first by set_solver.
    iModIntro.
    iApply step_fupd_iter_intro; first by set_solver.
    iModIntro.
    iMod "Hclo" as "_".
    by iFrame.
  Qed.

  Lemma step_fupd_mask_weaken_iter k E1 E2 P :
    E1 ⊆ E2 →
    ▷^k P -∗ |={E2,E1}_k=> P.
  Proof.
    iIntros (?) "HP".
    iApply step_fupd_iter_intro; first by set_solver.
    iMod (fupd_mask_subseteq ∅) as "Hclo"; first by set_solver.
    iModIntro. iModIntro.
    iMod "Hclo" as "_".
    iApply fupd_mask_intro_discard; auto.
  Qed.

  Global Instance from_modal_cfupd E1 P :
    FromModal True modality_id (cfupd E1 P) (cfupd E1 P) (P).
  Proof.
    rewrite /FromModal /=.
    iIntros (_) "HP".
    iIntros "_".
    iModIntro. by iFrame.
  Qed.

  Lemma ineq_to_diff n1 n2 :
    (n1 ≤ n2)%nat →
    ∃ n1' d,
      (n2 - n1 = d) ∧
      n1 = n1' ∧
      n2 = n1' + d.
  Proof.
    intros.
    exists n1, (n2-n1); lia.
  Qed.

  Theorem elim_modal_step_fupdN_subtract E1 E2 k1 k2 P Q :
    (k1 ≤ k2)%nat →
    (|={E1}[E2]▷=>^k1 P) -∗
    (P -∗ |={E1}[E2]▷=>^(k2-k1) Q) -∗
    |={E1}[E2]▷=>^k2 Q.
  Proof.
    iIntros (Hle) "HP HQ".
    destruct (ineq_to_diff _ _ Hle) as (k&kd&->&?&?); subst.
    clear Hle.
    iInduction k as [|k] "IH"; simpl.
    - iApply "HQ"; auto.
    - iMod "HP"; iModIntro. iNext.
      iMod "HP"; iModIntro.
      iApply ("IH" with "HP HQ").
  Qed.

  Theorem elim_modal_step_fupdN_mono E1 E2 k P Q :
    (|={E1}[E2]▷=>^k P) -∗
    (P -∗ Q) -∗
    |={E1}[E2]▷=>^k Q.
  Proof.
    iIntros "HP HQ".
    iApply (elim_modal_step_fupdN_subtract with "HP"); auto.
    replace (k-k) with 0 by lia; simpl.
    auto.
  Qed.

  Theorem elim_modal_step_fupd_masks k1 k2 E1 E2 P Q :
    (k1 ≤ k2)%nat →
    E1 ⊆ E2 →
    (|={E1,E2}_k1=> P) -∗
    (P -∗ (|={E1,E2}_(k2-k1)=> Q)) -∗
    (|={E1,E2}_k2=> Q).
  Proof.
    iIntros (Hle ?) "Hfupd HQ".
    (* rearrange theorem to an addition rather than a subtraction *)
    destruct (ineq_to_diff _ _ Hle) as (k&kd&->&?&?); subst; clear Hle.
    iApply step_fupdN_inner_add.
    iMod "Hfupd". iModIntro.
    iApply (elim_modal_step_fupdN_mono with "Hfupd").
    iIntros "HP".
    iMod "HP".
    iSpecialize ("HQ" with "HP").
    iApply fupd_mask_intro_discard; auto.
  Qed.

  Lemma step_fupdN_fupd E1 E2 k P :
    E1 ⊆ E2 →
    (|={E1}▷=>^k |={E1,E2}=> P) ⊣⊢ (|={E1}=> |={E1}▷=>^k |={E1,E2}=> P).
  Proof.
    intros Hsub.
    destruct k; simpl.
    - iSplit; iIntros "H".
      + iMod "H".
        iApply fupd_mask_intro_subseteq; auto.
      + iMod "H"; auto.
    - iSplit; iIntros "H".
      + by iFrame.
      + by iMod "H".
  Qed.

  Lemma step_fupdN_fupd_empty E2 k P :
    (|={∅}▷=>^k |={∅,E2}=> P) ⊣⊢ (|={∅}=> |={∅}▷=>^k |={∅,E2}=> P).
  Proof.
    apply step_fupdN_fupd; set_solver.
  Qed.

  Theorem elim_modal_step_fupd_masks_trans k1 k2 E1 E2 E3 P Q :
    (k1 ≤ k2)%nat →
    (|={E1,E2}_k1=> P) -∗
    (P -∗ (|={E2,E3}_(k2-k1)=> Q)) -∗
    (|={E1,E3}_k2=> Q).
  Proof.
    iIntros (Hle) "Hfupd HQ".
    (* rearrange theorem to an addition rather than a subtraction *)
    destruct (ineq_to_diff _ _ Hle) as (k&kd&->&?&?); subst; clear Hle.
    iApply (elim_modal_step_fupdN_subtract with "Hfupd"); first lia.
    iIntros "HP".
    iEval (rewrite step_fupdN_fupd_empty).
    iMod "HP".
    iMod ("HQ" with "HP") as "HQ".
    iModIntro.
    iApply (elim_modal_step_fupdN_subtract with "HQ"); first lia.
    iIntros "HQ".
    iApply step_fupd_iter_intro; auto.
  Qed.

  Lemma step_fupdN_weaken_mask E1 E1' k P :
    E1' ⊆ E1 →
    (|={E1',E1'}_k=> P) -∗
    |={E1,E1}_k=> P.
  Proof.
    iIntros (?) "HP".
    iMod (fupd_mask_subseteq E1') as "Hclo"; first auto.
    iApply (elim_modal_step_fupdN_mono with "HP").
    iIntros "HP".
    iMod "HP".
    iMod "Hclo" as "_".
    auto.
  Qed.

  Theorem cfupd_weaken_mask E1 E1' P :
    E1' ⊆ E1 →
    cfupd  E1'  P -∗ cfupd E1 P.
  Proof.
    iIntros (?) "H".
    iApply (cfupd_wand with "[$]"); eauto.
  Qed.

  (* these instances are local to avoid breaking the proofs in this file *)

  Local Instance elim_modal_step_fupd p k1 k2 E P Q :
    ElimModal (k1 ≤ k2)%nat p false (|={E,E}_k1=> P) P
              (|={E,E}_k2=> Q) (|={E,E}_(k2-k1)=> Q).
  Proof.
    rewrite /ElimModal intuitionistically_if_elim /=.
    iIntros (?) "[Hfupd HQ]".
    iApply (elim_modal_step_fupd_masks with "Hfupd"); auto.
  Qed.

  Local Instance elim_modal_step_fupd_same p k E P Q :
    ElimModal True p false (|={E,E}_k=> P) P
              (|={E,E}_k=> Q) (|={E}=> Q).
  Proof.
    rewrite /ElimModal intuitionistically_if_elim.
    iIntros (?) "[Hfupd HQ]".
    iMod "Hfupd" as "HP".
    replace (k-k) with 0 by lia.
    simpl.
    iSpecialize ("HQ" with "HP").
    iMod "HQ".
    iApply fupd_mask_intro_subseteq; first set_solver; auto.
  Qed.

  Global Instance elim_modal_cfupd p E1 P Q :
    ElimModal True p false (cfupd E1 P) (P)
              (cfupd E1 Q) (cfupd E1 Q).
  Proof.
    rewrite /ElimModal intuitionistically_if_elim /cfupd /=.
    iIntros (?) "[Hfupd HQ]".
    iIntros "#HC".
    iSpecialize ("Hfupd" with "HC").
    iMod "Hfupd".
    iMod ("HQ" with "Hfupd HC") as "HQ".
    iModIntro. auto.
  Qed.

  Global Instance cfupd_frame p E1 R P Q :
    Frame p R P Q →
    Frame p R (cfupd E1 P) (cfupd E1 Q).
  Proof.
    rewrite /Frame.
    iIntros (Hframe) "[HR Hfupd]".
    iIntros "HC".
    iSpecialize ("Hfupd" with "HC").
    iMod "Hfupd". iModIntro. iApply Hframe; by iFrame.
  Qed.

  Lemma cfupd_big_sepL_aux {A} (l: list A) (Φ: nat → A → iProp Σ) n E1 :
    ([∗ list] i↦a ∈ l, cfupd E1 (Φ (n + i) a)) -∗
    cfupd E1 ([∗ list] i↦a ∈ l, Φ (n + i) a).
  Proof.
    iIntros "H".
    iInduction l as [| x l] "IH" forall (n).
    - iModIntro.
      simpl; auto.
    - rewrite -> !big_sepL_cons by set_solver.
      simpl.
      iDestruct "H" as "(Hx & Hrest)".
      iMod "Hx".
      iFrame "Hx".
      assert (forall k, n + S k = S n + k) as Harith by lia.
      setoid_rewrite Harith.
      iMod ("IH" with "Hrest") as "Hrest".
      iModIntro. eauto.
  Qed.

  Lemma cfupd_big_sepL {A} (l: list A) (Φ: nat → A → iProp Σ) E1 :
    ([∗ list] i↦a ∈ l, cfupd E1 (Φ i a)) -∗
    cfupd E1 ([∗ list] i↦a ∈ l, Φ i a).
  Proof. iApply (cfupd_big_sepL_aux _ _ 0). Qed.

  Lemma cfupd_big_sepS `{Countable A} (σ: gset A)(P: A → iProp Σ) E1  :
    ([∗ set] a ∈ σ, cfupd E1 (P a)) -∗
    cfupd E1 ([∗ set] a ∈ σ, P a).
  Proof. rewrite big_op.big_opS_unseal. apply cfupd_big_sepL. Qed.

  Lemma is_except_0_wand {PROP:bi} (P Q: PROP) :
    IsExcept0 Q → IsExcept0 (P -∗ Q).
  Proof.
    rewrite /IsExcept0.
    intros HQ.
    rewrite -{2}HQ.
    iIntros ">HQ HP !>".
    iApply ("HQ" with "HP").
  Qed.

  Global Instance cfupd_is_except0 E Q : IsExcept0 (cfupd E Q).
  Proof.
    rewrite /cfupd.
    apply is_except_0_wand.
    apply _.
  Qed.

  Global Instance from_pure_cfupd a E P φ :
    FromPure a P φ → FromPure a (cfupd E P) φ.
  Proof.
    rewrite /FromPure=> HP. iIntros "? !>". by iApply HP.
  Qed.

End cfupd.

(* Open to alternative notation for this. *)
Notation "|C={ E1 }=> P" := (cfupd E1 P)
      (at level 99, E1 at level 50, P at level 200,
       format "'[  ' |C={ E1 }=>  '/' P ']'").

Global Hint Extern 1 (environments.envs_entails _ (|C={_}=> _)) => iModIntro : core.


Require Import Utf8 List Basics FinFun.
Import ListNotations.
Require Import CpdtTactics.
Require Import LibLN.
Set Implicit Arguments.

Implicit Types EP EV LV V L : Set.

Notation "x ∈ E" := (mem x E) (at level 39) : fset_scope.
Notation "x ∉ E" := (notin x E) (at level 39) : fset_scope.
Notation "E ⊆ F" := (subset E F) (at level 38) : fset_scope.

(** * Syntax *)

(**
If [V] is the type of the representation of a variable, then [inc V]
is the type of the representation of the same variable after the free
variable environment is extended by one.
*)
Inductive inc (V : Set) : Set :=
| VZ : inc V
| VS : V → inc V
.

Arguments VZ [V].
Arguments VS [V].

Fixpoint incn V (n : nat) : Set :=
  match n with
  | O => V
  | S m => inc (incn V m)
  end
.

Lemma incSn n : ∀ L, inc (incn L n) = incn (inc L) n.
induction n ; crush.
Defined.

Notation "∅" := Empty_set.
Notation incN := (incn ∅).

(** Introduce [n] more free variables *)
Fixpoint nVS (n : nat) V {struct n} : V → incn V n.
Proof.
destruct n as [ | n ] ; simpl.
+ refine (λ x, x).
+ intro x.
  refine (VS (nVS n V x)).
Defined.

Definition empty_fun {T} : ∅ → T :=
  λ y, match y with end.

Notation "∅→" := empty_fun.

Lemma empty_fun_is_injective T : Injective (∅→ : ∅ → T).
Proof. intro x ; destruct x. Qed.

(** Extend a variable mapping. *)
Definition env_ext (V : Set) (T : Type) (env : V → T) (t : T) :
    inc V → T :=
  λ y, match y with
  | VZ => t
  | VS x => env x
  end.

Parameter 𝔽 : Set.

Inductive
(** label identifiers *)
lid L : Set :=
| lid_b : L → lid L
| lid_f : var → lid L
.

Inductive
(** labels *)
lbl LV L : Set :=
| lbl_var : LV → lbl LV L
| lbl_id : lid L → lbl LV L
.

Inductive
  (** effects *)
  ef EP EV LV L : Set :=
  | ef_par : EP → ef EP EV LV L
  | ef_var : EV → ef EP EV LV L
  | ef_lbl : lbl LV L → ef EP EV LV L
.

(** effect sequences *)
Notation eff EP EV LV L := (list (ef EP EV LV L)).

Inductive
  (** signature kind *)
  sk : Set :=
  | sk_ms : sk
  | sk_ep : sk → sk
.

Notation "'𝕄'" := sk_ms.
Notation "'𝔼' → κ" := (sk_ep κ) (at level 60).

Parameter (IKind : 𝔽 → sk).

Inductive
  (** interfaces *)
  it EP EV LV L : sk → Set :=
  | it_name : ∀ F, it EP EV LV L (IKind F)
  | it_inst : ∀ κ, it EP EV LV L (𝔼 → κ) → eff EP EV LV L → it EP EV LV L κ
.

Inductive
  (** types *)
  ty EP EV LV L : Set :=
  | ty_unit : ty EP EV LV L
  | ty_cont : ty EP EV LV L → eff EP EV LV L → ty EP EV LV L → eff EP EV LV L → ty EP EV LV L
  | ty_it   : it EP EV LV L 𝕄 → lbl LV L → ty EP EV LV L
  | ty_ms   : ms EP EV LV L → lbl LV L → ty EP EV LV L
with
  (** method signatures *)
  ms EP EV LV L : Set :=
  | ms_ev : ms EP (inc EV) LV L → ms EP EV LV L
  | ms_lv : ms EP EV (inc LV) L → ms EP EV LV L
  | ms_tm  : ty EP EV LV L → ms EP EV LV L → ms EP EV LV L
  | ms_res : ty EP EV LV L → eff EP EV LV L → ms EP EV LV L
.

Inductive
  (** method definitions *)
  md EV LV V L : Set :=
  | md_ev : md (inc EV) LV V L → md EV LV V L
  | md_lv : md EV (inc LV) V L → md EV LV V L
  | md_tm  : md EV LV (inc V) L → md EV LV V L
  | md_res : tm EV LV (inc V) L → md EV LV V L
with
  (** evaluation contexts *)
  ktx EV LV V L : Set :=
  | ktx_hole    : ktx EV LV V L
  | ktx_op      : ktx EV LV V L → ktx EV LV V L
  | ktx_up      : ktx EV LV V L → ktx EV LV V L
  | ktx_down    : ktx EV LV V L → var → ktx EV LV V L
  | ktx_let     : ktx EV LV V L → tm EV LV (inc V) L → ktx EV LV V L
  | ktx_throw   : ktx EV LV V L → tm EV LV V L → ktx EV LV V L
  | ktx_app_eff : ktx EV LV V L → eff ∅ EV LV L → ktx EV LV V L
  | ktx_app_lbl : ktx EV LV V L → lbl LV L → ktx EV LV V L
  | ktx_app_tm1 : ktx EV LV V L → tm EV LV V L → ktx EV LV V L
  | ktx_app_tm2 : ktx EV LV V L → val EV LV V L → ktx EV LV V L
with
  (** values *)
  val EV LV V L : Set :=
  | val_unit : val EV LV V L
  | val_var  : V → val EV LV V L
  | val_cont : ktx EV LV V L → val EV LV V L
  | val_md   : md EV LV V L → lid L → val EV LV V L
  | val_fix  : md EV LV (inc V) L → lid L → val EV LV V L
with
  (** terms *)
  tm EV LV V L : Set :=
  | tm_val     : val EV LV V L → tm EV LV V L
  | tm_op      : tm EV LV V L → tm EV LV V L
  | tm_up      : tm EV LV V L → tm EV LV V L
  | tm_Down    : tm EV LV V (inc L) → tm EV LV V L
  | tm_down    : var → tm EV LV V L → tm EV LV V L
  | tm_let     : tm EV LV V L → tm EV LV (inc V) L → tm EV LV V L
  | tm_throw   : tm EV LV V L → tm EV LV V L → tm EV LV V L
  | tm_app_eff : tm EV LV V L → eff ∅ EV LV L → tm EV LV V L
  | tm_app_lbl : tm EV LV V L → lbl LV L → tm EV LV V L
  | tm_app_tm  : tm EV LV V L → tm EV LV V L → tm EV LV V L
.

Arguments lid_f [L].
Arguments lbl_var [LV L].
Arguments lbl_id [LV L].
Arguments ef_par  [EP EV LV L].
Arguments ef_var  [EP EV LV L].
Arguments ef_lbl  [EP EV LV L].
Arguments it_name [EP EV LV L].
Arguments it_inst [EP EV LV L κ].
Arguments ty_unit [EP EV LV L].
Arguments ty_it [EP EV LV L].

Arguments ktx_hole [EV LV V L].
Arguments val_unit [EV LV V L].
Arguments val_var  [EV LV V L].

Coercion val_cont : ktx >-> val.
Coercion tm_val : val >-> tm.

Notation "𝟙" := ty_unit.
Notation "⇧" := tm_up.
Notation "⬇" := tm_Down.
Notation "⇩" := tm_down.
Notation "'λₜ'" := md_tm.
Notation "'λₑ'" := md_ev.
Notation "'λₗ'" := md_lv.
Notation "'λᵣ'" := md_res.

(** Syntactic objects that do not contain any kind of free variables. *)
Notation lid0 := (lid ∅).
Notation lbl0 := (lbl ∅ ∅).
Notation ef0 := (ef ∅ ∅ ∅ ∅).
Notation eff0 := (eff ∅ ∅ ∅ ∅).
Notation it0 := (it ∅ ∅ ∅ ∅).
Notation ty0 := (ty ∅ ∅ ∅ ∅).
Notation ms0 := (ms ∅ ∅ ∅ ∅).
Notation tm0 := (tm ∅ ∅ ∅ ∅).
Notation val0 := (val ∅ ∅ ∅ ∅).
Notation md0 := (md ∅ ∅ ∅ ∅).
Notation ktx0 := (ktx ∅ ∅ ∅ ∅).

Inductive
(** interface signatures *)
is EP EV LV L : Set :=
| is_ms : ms EP EV LV L → is EP EV LV L
| is_ep : is (inc EP) EV LV L → is EP EV LV L
.

Fixpoint sk_is EP EV LV L (Σ : is EP EV LV L) : sk :=
match Σ with
| is_ms σ => 𝕄
| is_ep Σ => 𝔼 → sk_is Σ
end.

Notation is0 := (is ∅ ∅ ∅ ∅).

Parameter (Signature : 𝔽 → is0).
Parameter (SignatureKind : ∀ F, IKind F = sk_is (Signature F)).

(** label-identifier environments *)
Notation XEnv EV LV := (env (ty ∅ EV LV ∅ * eff ∅ EV LV ∅)).

Inductive LEnv EV LV : Set → Type :=
| LEnv_empty : LEnv EV LV ∅
| LEnv_push  : ∀ L, LEnv EV LV L → ty ∅ EV LV L → eff ∅ EV LV L → LEnv EV LV (inc L)
.

Arguments LEnv_empty [EV LV].

(** Well-founded measures *)

Fixpoint size_eff EP EV LV L (E : eff EP EV LV L) : nat :=
match E with
| [] => 0
| e :: E => 1 + size_eff E
end.

Fixpoint size_it EP EV LV L κ (N : it EP EV LV L κ) : nat :=
match N with
| it_name _ => 0
| it_inst N E => 1 + size_it N + size_eff E
end.

Fixpoint
  size_ty EP EV LV L (T : ty EP EV LV L) : nat :=
  match T with
  | ty_unit => 0
  | ty_cont Ta Ea Tb Eb => 1 + size_ty Ta + size_eff Ea + size_ty Tb + size_eff Eb
  | ty_it N _ => 1 + size_it N
  | ty_ms σ _ => 1 + size_ms σ
  end
with
  size_ms EP EV LV L (σ : ms EP EV LV L) : nat :=
  match σ with
  | ms_ev σ => 1 + size_ms σ
  | ms_lv σ => 1 + size_ms σ
  | ms_tm T σ => 1 + size_ty T + size_ms σ
  | ms_res T E => 1 + size_ty T + size_eff E
  end
.

Definition size_lbl EV LV (Ξ : XEnv EV LV) (ℓ : lbl LV ∅) :=
match ℓ with
| lbl_id (lid_f X) =>
  match (get X Ξ) with
  | Some (T, E) => 1 + size_ty T + size_eff E
  | None => 0
  end
| _ => 0
end.

Require Export Utf8 List Basics.
Export ListNotations.
Require Export CpdtTactics.
Require Export LibLN.
Open Scope program_scope.

Hint Extern 1 => match goal with
| [ |- ∀ x : ∅, _ ] => let x := fresh "x" in (intro x ; destruct x)
| [ x : ∅ |- _ ] => destruct x
| [ x : inc ?V |- _ ] => destruct x ; simpl ; crush
| [ |- context[ _ ∘ _ ] ] => unfold compose ; crush
end.


(* TRINC instance *)

Require Export TrInc.
Require Export TrInctacs.
Require Export TrIncbreak.
Require Export MinBFTrep.
Require Export MinBFTsim1.
Require Export ComponentAxiom.
Require Export ComponentSM3.

(* Move to ComponentSM2 *)
Hint Resolve are_procs_empty_ls : comp.
Hint Resolve wf_empty_ls : comp.

Section TrIncsubs.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Definition is_replica {eo : EventOrdering} (e : Event) :=
    exists r, loc e = MinBFT_replica r.

  Lemma in_output_implies_is_replica :
    forall {eo : EventOrdering} (e : Event) o,
      In o (M_output_sys_on_event MinBFTsys e)
      -> is_replica e.
  Proof.
    introv h.
    unfold M_output_sys_on_event in *.
    unfold is_replica.
    remember (loc e) as w; destruct w; simpl in *; tcsp; eauto.
    apply not_in_M_output_ls_on_event_empty_ls in h; tcsp.
  Qed.
  Hint Resolve in_output_implies_is_replica : minbft.

  Lemma local_pred_preserves_is_replica :
    forall {eo : EventOrdering} (e1 e2 : Event),
      e1 ⊂ e2
      -> is_replica e2
      -> is_replica e1.
  Proof.
    introv lte isrep.
    unfold is_replica in *; exrepnd; exists r; rewrite <- isrep0; eauto 3 with eo.
  Qed.
  Hint Resolve local_pred_preserves_is_replica : minbft.

  Lemma are_procs_MinBFTls : forall n, are_procs_n_procs (MinBFTlocalSys n).
  Proof.
    introv; simpl;
      try (complete (eexists; introv; unfold proc2upd; simpl; try reflexivity));
      try (complete (introv i; simpl in *; repndors; subst; tcsp; simpl;
                     eexists; introv; unfold proc2upd;  reflexivity)).
  Qed.
  Hint Resolve are_procs_MinBFTls : minbft.

  Lemma wf_MinBFTls : forall n, wf_procs (MinBFTlocalSys n).
  Proof.
    repeat introv; unfold wf_procs; simpl;
      dands; try (complete (introv xx; repndors; tcsp; ginv));
        repeat constructor; simpl; tcsp;
          try (complete (introv xx; repndors; tcsp; ginv)).
  Qed.
  Hint Resolve wf_MinBFTls : minbft.

  Lemma are_procs_MinBFTsys : are_procs_sys MinBFTsys.
  Proof.
    introv; destruct n; simpl; eauto 3 with comp minbft.
  Qed.
  Hint Resolve are_procs_MinBFTsys : minbft.

  Lemma wf_MinBFTsys : wf_sys MinBFTsys.
  Proof.
    introv; destruct n; simpl; eauto 3 with comp minbft.
  Qed.
  Hint Resolve wf_MinBFTsys : minbft.

  Lemma MinBFTsys_preserves_subs :
    sys_preserves_subs MinBFTsys.
  Proof.
    introv; eauto 3 with comp minbft.
  Qed.
  Hint Resolve MinBFTsys_preserves_subs : minbft.

  Lemma similar_minbft_implies_subs :
    forall (subs : n_procs 1) r,
      similar_subs subs (MinBFTsubs r)
      -> exists (s1 : TRINC_state) (s2 : LOG_state),
        subs = MinBFTsubs_new s1 s2.
  Proof.
    introv sim.
    inversion sim; subst; clear sim.
    inversion sims; subst; clear sims.
    inversion sims0; subst; clear sims0.
    applydup @similar_procs_implies_same_name in simp; simpl in *.
    applydup @similar_procs_implies_same_name in simp0; simpl in *.
    destruct p1, p0; simpl in *; subst; simpl in *.
    destruct pp_proc, pp_proc0; simpl in *; tcsp;[].
    apply @similar_procs_implies_same_proc in simp.
    apply @similar_procs_implies_same_proc in simp0.
    simpl in *; repnd; subst.
    destruct a, a0; simpl in *; subst; simpl in *; tcsp;[].
    unfold similar_sms_at in *; repnd; simpl in *; subst; tcsp.
    unfold MinBFTsubs_new, build_m_sm, build_mp_sm, at2sm; simpl; eauto.
  Qed.

  Lemma similar_subs_MinBFTlocalSys_implies :
    forall r (ls : n_procs 2),
      similar_subs (MinBFTlocalSys r) ls
      -> exists s s1 s2, ls = MinBFTlocalSys_new r s s1 s2.
  Proof.
    introv sim.
    apply similar_subs_MinBFTlocalSysP  in sim; exrepnd; subst.
    apply similar_subs_sym in sim1; apply similar_minbft_implies_subs in sim1; exrepnd; subst.
    exists s s1 s2; auto.
  Qed.

  (* We can also prove some preservation lemmas:
       for example that the replica field in the USIG does not change *)
  Lemma M_run_ls_before_event_ls_is_minbft :
    forall {eo : EventOrdering}
           (e  : Event)
           (r  : Rep)
           (ls : MinBFTls),
      M_run_ls_before_event (MinBFTlocalSys r) e = Some ls
      ->
      exists (s : MAIN_state) (s1 : TRINC_state) (s2 : LOG_state),
        ls = MinBFTlocalSys_new r s s1 s2.
  Proof.
    introv run.
    apply M_run_ls_before_event_preserves_subs in run; eauto 3 with comp minbft.
    repnd; simpl in *.
    apply similar_subs_MinBFTlocalSys_implies in run2; auto.
  Qed.

  Lemma M_run_ls_on_event_ls_is_minbft :
    forall {eo : EventOrdering}
           (e  : Event)
           (r  : Rep)
           (ls : MinBFTls),
      M_run_ls_on_event (MinBFTlocalSys r) e = Some ls
      ->
      exists (s : MAIN_state) (s1 : TRINC_state) (s2 : LOG_state),
        ls = MinBFTlocalSys_new r s s1 s2.
  Proof.
    introv run.
    apply M_run_ls_on_event_preserves_subs in run; eauto 3 with comp minbft.
    repnd; simpl in *.
    apply similar_subs_MinBFTlocalSys_implies in run2; auto.
  Qed.

  Lemma similar_minbft_implies_level :
    forall r {n} (subs : n_procs n),
      similar_subs subs (MinBFTsubs r)
      -> n = 1.
  Proof.
    introv sim.
    applydup @similar_subs_implies_same_level in sim; auto.
    destruct subs; simpl in *; auto; try omega.
    inversion sim.
  Qed.

(*  Lemma call_usig_preserves_subs :
    forall r i o {n} (subs1 subs2 : n_procs n),
      call_proc USIGname i subs1 = (subs2, o)
      -> similar_subs subs1 (MinBFTsubs r)
      -> similar_subs subs1 subs2.
  Proof.
    introv c sim.
    unfold call_proc in c; smash_minbft; eauto 3 with comp;[].
    applydup similar_minbft_implies_level in sim; subst n.
    applydup similar_minbft_implies_subs in sim; exrepnd; subst; simpl in *.
    repndors; subst; tcsp; ginv.
    inversion Heqx; subst; simpl in *; clear Heqx.
    unfold USIG_update in *; simpl in *.
    destruct i; simpl in *; smash_minbft; simpl in *;
      unfold build_mp_sm, decr_n_procs, sm_s_to_sm, bind, lift_M_O in Heqx1; simpl in *;
        inversion Heqx1; substs; simpl in *; repeat constructor.
  Qed.
  Hint Resolve call_usig_preserves_subs : minbft.

  Lemma call_log_preserves_subs :
    forall r i o {n} (subs1 subs2 : n_procs n),
      call_proc LOGname i subs1 = (subs2, o)
      -> similar_subs subs1 (MinBFTsubs r)
      -> similar_subs subs1 subs2.
  Proof.
    introv c sim.
    unfold call_proc in c; smash_minbft; eauto 3 with comp;[].
    applydup similar_minbft_implies_level in sim; subst n.
    applydup similar_minbft_implies_subs in sim; exrepnd; subst; simpl in *.
    repndors; subst; tcsp; ginv.
    inversion Heqx; subst; simpl in *; clear Heqx.
    unfold USIG_update in *; simpl in *.
    destruct i; simpl in *; smash_minbft; simpl in *;
      unfold build_mp_sm, decr_n_procs, sm_s_to_sm, bind, lift_M_O in Heqx1; simpl in *;
        inversion Heqx1; substs; simpl in *; repeat constructor.
  Qed.
  Hint Resolve call_log_preserves_subs : minbft.*)

  Lemma implies_similar_subs_MinBFTsubs_new :
    forall s1 s2 s3 s4,
      similar_subs (MinBFTsubs_new s1 s2) (MinBFTsubs_new s3 s4).
  Proof.
    introv.
    repeat constructor.
  Qed.
  Hint Resolve implies_similar_subs_MinBFTsubs_new : minbft.

  Lemma is_trusted_ls_usig :
    forall n, is_trusted_ls USIGname (MinBFTlocalSys n).
  Proof.
    introv; tcsp.
  Qed.
  Hint Resolve is_trusted_ls_usig : minbft.

  Definition USIG_sm_new s :=
    build_m_sm USIG_update s.

(*  Lemma trusted_run_sm_on_inputs_usig :
    forall s n l,
      trusted_run_sm_on_inputs s (USIG_comp n) l
      = Some (run_sm_on_inputs_trusted (USIG_sm_new s) l).
  Proof.
    tcsp.
  Qed.*)

  Lemma usig_id_try_update_USIG :
    forall cid old new s,
      trinc_id (try_update_TRINC cid old new s) = trinc_id s.
  Proof.
    introv; unfold try_update_TRINC; smash_minbft.
  Qed.
  Hint Rewrite usig_id_try_update_USIG : minbft.

(*  Lemma run_sm_on_inputs_trusted_usig_preserves_id :
    forall l s,
      trinc_id (run_sm_on_inputs_trusted (USIG_sm_new s) l) = trinc_id s.
  Proof.
    induction l; introv; simpl in *; tcsp;[].
    pose proof (run_sm_on_inputs_trusted_cons _ _ _ (USIG_sm_new s) a l) as xx.
    simpl in *; rewrite xx; auto; clear xx.
    match goal with
    | [ |- context[fst ?x]] => remember (fst x) as w; symmetry in Heqw
    end.
    unfold update_state_op_m; dest_cases z; symmetry in Heqz.
    subst.
    rewrite IHl.

    unfold USIG_update in Heqw.
    destruct a; simpl in *; repnd; simpl in *; inversion Heqw; simpl in *;
      autorewrite with minbft; auto.
  Qed.*)

  Lemma similar_sms_at_log :
    forall s p,
      similar_sms_at (build_mp_sm LOG_update s) p
      <-> exists s', p = build_mp_sm LOG_update s'.
  Proof.
    introv; split; intro h; exrepnd; subst; eauto.

    { inversion h; subst.
      destruct p as [up st]; simpl in *; subst; eauto.
      exists st; auto. }

    { constructor; auto. }
  Qed.
  Hint Rewrite similar_sms_at_log : minbft.

  Lemma similar_sms_at_usig :
    forall s p,
      similar_sms_at (build_mp_sm USIG_update s) p
      <-> exists s', p = build_mp_sm USIG_update s'.
  Proof.
    introv; split; intro h; exrepnd; subst; eauto.

    { inversion h; subst.
      destruct p as [up st]; simpl in *; subst; eauto.
      exists st; auto. }

    { constructor; auto. }
  Qed.
  Hint Rewrite similar_sms_at_usig : minbft.

End TrIncsubs.

Hint Resolve in_output_implies_is_replica : minbft.
Hint Resolve local_pred_preserves_is_replica : minbft.
Hint Resolve are_procs_MinBFTls : minbft.
Hint Resolve wf_MinBFTls : minbft.
Hint Resolve are_procs_MinBFTsys : minbft.
Hint Resolve wf_MinBFTsys : minbft.
(*Hint Resolve call_usig_preserves_subs : minbft.
Hint Resolve call_log_preserves_subs : minbft.*)
Hint Resolve MinBFTsys_preserves_subs : minbft.
Hint Resolve implies_similar_subs_MinBFTsubs_new : minbft.
Hint Resolve is_trusted_ls_usig : minbft.

Hint Rewrite @similar_sms_at_log : minbft.
Hint Rewrite @similar_sms_at_usig : minbft.
Hint Rewrite @usig_id_try_update_USIG : minbft.


(* ** Reduction from ZF' to finite ZF *)

From Undecidability.FOL
     Require Import Syntax.Facts Semantics.Tarski.FullFacts Deduction.FullNDFacts.

From Undecidability.FOL.Sets
     Require Import ZF.
Require Import Undecidability.FOL.ZF.

Require Import Lia.

From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations ListAutomationHints ListAutomationInstances.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Definition add_om phi :=
  ax_om1 → ax_om2 → phi.

Theorem reduction_entailment phi :
  entailment_ZF' phi <-> entailment_HF (add_om phi).
Proof.
  split; intros Hp D I rho HE HI.
  - intros H1 H2. apply Hp; trivial.
    intros sigma psi [<-|[<-|[<-|[<-|[<-|[<-|[<-|[]]]]]]]]; trivial.
    all: apply HI; unfold HF; intuition.
  - apply Hp; fold sat; trivial. 2,3: apply HI; unfold ZF'; intuition eauto 7.
    intros sigma psi [<-|[<-|[<-|[<-|[<-|[]]]]]].
    all: apply HI; unfold ZF'; intuition.
Qed.

Theorem reduction_deduction phi :
  deduction_ZF' phi <-> deduction_HF (add_om phi).
Proof.
  unfold deduction_ZF', deduction_HF, add_om. rewrite !imps.
  split; intros H; apply (Weak H); unfold ZFeq', HFeq, ZF', HF; firstorder.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Lists.ListSet.
Require Import Coq.Strings.String.
Require Import BinInt.
Require Import VerifiedVerifier.Machine.
Require Import VerifiedVerifier.Bits.
Require Import VerifiedVerifier.Maps.

Type map.
(*TODO: figure out if we need uints vs ints*)
Definition registers_ty := total_map register int64.

Definition stack_ty := list int64.

Definition heap_ty := total_map int64 int64.

Definition flags_ty := total_map flag int1.

Definition function_table_ty := partial_map int64 string.

Record state := {
  regs : registers_ty;
  flags : flags_ty;
  stack : stack_ty;
  heap : heap_ty;
  heap_base : int64;
  function_table : function_table_ty;
  error_state : bool;
}.

Fixpoint value_to_int64 (s : state) (v :value) : int64 :=
match v with
| Const c => c
end.

Definition get_register (s : state) (r : register) : int64 :=
  s.(regs) r.

Definition set_register (s : state) (r : register) (v : int64) : state :=
{| regs := t_update register_eq_dec s.(regs) r v;
   flags := s.(flags);
   stack := s.(stack);
   heap := s.(heap);
   heap_base := s.(heap_base);
   function_table := s.(function_table);
   error_state := s.(error_state) |}.

Definition set_flags (s : state) (f : flags_ty) : state :=
{| regs := s.(regs);
   flags := f;
   stack := s.(stack);
   heap := s.(heap);
   heap_base := s.(heap_base) ;
   function_table := s.(function_table);
   error_state := s.(error_state) |}.

Definition expand_stack (s : state) (i : nat) : state :=
{| regs := s.(regs);
   flags := s.(flags);
   stack := s.(stack) ++ (repeat Word.zero i);
   heap := s.(heap);
   heap_base := s.(heap_base) ;
   function_table := s.(function_table);
   error_state := s.(error_state) |}.

Fixpoint contract_stack (s : state) (i : nat) : state :=
match i with
| 0 => s
| S n =>
contract_stack {| regs := s.(regs);
   flags := s.(flags);
   stack := removelast s.(stack);
   heap := s.(heap);
   heap_base := s.(heap_base) ;
   function_table := s.(function_table);
   error_state := s.(error_state) |}
 n
end.

Definition read_stack (s : state) (i : nat) : int64 :=
nth_default Word.zero s.(stack) i.

Definition write_stack (s : state) (i : nat) (val : int64) : state :=
{| regs := s.(regs);
   flags := s.(flags);
   stack := Machine.update s.(stack) i val;
   heap := s.(heap);
   heap_base := s.(heap_base) ;
   function_table := s.(function_table);
   error_state := s.(error_state) |}.

Definition read_heap (s : state) (i : int64) : int64 :=
s.(heap) i.

Definition write_heap (s : state) (i : int64) (v : int64) : state :=
{| regs := s.(regs);
	 flags := s.(flags);
	 stack := s.(stack);
	 heap := t_update int64_eq_dec s.(heap) i v;
   heap_base := s.(heap_base);
   function_table := s.(function_table);
   error_state := s.(error_state) |}.

Definition set_error_state (s : state) : state :=
{| regs := s.(regs);
	 flags := s.(flags);
	 stack := s.(stack);
	 heap := s.(heap);
   heap_base := s.(heap_base);
   function_table := s.(function_table);
   error_state := true |}.

Definition fourGB : int64 := (Word.shl (Word.repr 2) (Word.repr 32)).

(*TODO: This doesn't handle signed/unsigned conversions correctly*)
Definition run_conditional (c : conditional) (s : state) : bool :=
  match c with
| Not_Equal r1 r2 => negb (Word.eq (get_register s r1) (get_register s r2))
| Equal r1 r2 => Word.eq (get_register s r1) (get_register s r2)
| Greater r1 r2 => Word.lt (get_register s r2) (get_register s r1)
| Greater_Equal r1 r2 => orb (Word.lt (get_register s r2) (get_register s r1)) (Word.eq (get_register s r1) (get_register s r2))
| Above r1 r2 => Word.ltu (get_register s r2) (get_register s r1)
| Above_Equal r1 r2 => orb (Word.ltu (get_register s r2) (get_register s r1)) (Word.eq (get_register s r1) (get_register s r2))
| Lesser r1 r2 => Word.lt (get_register s r1) (get_register s r2)
| Lesser_Equal r1 r2 => orb (Word.lt (get_register s r1) (get_register s r2)) (Word.eq (get_register s r1) (get_register s r2))
| Below r1 r2 => Word.ltu (get_register s r1) (get_register s r2)
| Below_Equal r1 r2 => orb (Word.ltu (get_register s r1) (get_register s r2)) (Word.eq (get_register s r1) (get_register s r2))
| Counter_Register_Zero => Word.eq (get_register s rcx) (Word.repr 0)
end.

Definition run_instr (inst : instr_class) (s : state) : state :=
  match inst with
| Heap_Read r_dst r_src r_base => set_register s r_dst (read_heap s (Word.add (get_register s r_src) (get_register s r_base)))
| Heap_Write r_dst r_val r_base => write_heap s (Word.add (get_register s r_dst) (get_register s r_base)) (get_register s r_val)
| Heap_Check r => set_register s r (Word.modu (get_register s r) fourGB)
| Call_Check r => s (*TODO: Figure out wtf to do.*)
| Reg_Write r v => set_register s r (value_to_int64 s v)
| Reg_Move r_dst r_src => set_register s r_dst (get_register s r_src)
| Stack_Expand i => expand_stack s i
| Stack_Contract i => contract_stack s i
| Stack_Read r i => set_register s r (read_stack s i)
| Stack_Write i r => write_stack s i (get_register s r)
(*TODO: Make sure calls are right*)
| Indirect_Call r => s
| Direct_Call name => s
| Branch c => s
| UniOp op r_dst => s
| BinOp op r_dst r_src => s
| DivOp r_dst => s
| Ret => s
end.

Theorem run_instr_deterministic : forall init_st st st' i,
  run_instr i init_st = st ->
  run_instr i init_st = st' ->
  st = st'.
Proof.
  intros init_st st st' i H1 H2. rewrite <- H1, H2. auto.
Qed.

Reserved Notation " i '/' st 'i-->' st' "
                  (at level 40, st' at level 39).
Inductive instr_class_istep : instr_class -> state -> state -> Prop :=
| I_Heap_Read: forall st r_base r_src r_dst,
    Heap_Read r_dst r_src r_base / st i--> set_register st r_dst (read_heap st (Word.add (get_register st r_src) (get_register st r_base)))
| I_Heap_Write: forall st r_base r_val r_dst,
    Heap_Write r_dst r_val r_base / st i--> write_heap st (Word.add (get_register st r_dst) (get_register st r_base)) (get_register st r_val)
| I_Heap_Check: forall st r_src,
    Heap_Check r_src / st i--> set_register st r_src (Word.modu (get_register st r_src) fourGB)
| I_Call_Check: forall st r_src,
    Call_Check r_src / st i--> st (* probably wrong *)
| I_Reg_Move: forall st r_src r_dst,
    Reg_Move r_dst r_src / st i--> set_register st r_dst (get_register st r_src)
| I_Reg_Write: forall st r_dst val,
    Reg_Write r_dst val / st i--> set_register st r_dst (value_to_int64 st val)
| I_Stack_Expand: forall st i,
    Stack_Expand i / st i--> expand_stack st i
| I_Stack_Contract: forall st i,
    Stack_Contract i / st i--> contract_stack st i
| I_Stack_Read: forall st i r_dst,
    Stack_Read r_dst i / st i--> set_register st r_dst (read_stack st i)
| I_Stack_Write: forall st i r_src,
    Stack_Write i r_src / st i--> write_stack st i (get_register st r_src)
(* those calls might also be wrong *)
| I_Indirect_Call: forall st reg,
    Indirect_Call reg / st i-->  st
| I_Direct_Call: forall st name,
    Direct_Call name / st i-->  st
| I_Branch: forall st c,
    (Branch c) / st i--> st
| I_UniOp: forall st op r_dst,
    (UniOp op r_dst) / st i--> st
| I_BinOp: forall st op r_dst r_src,
    (BinOp op r_dst r_src) / st i--> st
| I_DivOp : forall st r_dst,
    (DivOp r_dst) / st i--> st
| I_Ret: forall st,
    Ret / st i-->  st
  where " i '/' st 'i-->' st'" := (instr_class_istep i st st').

Theorem instr_class_istep_deterministic : forall init_st st st' i,
  i / init_st i--> st ->
  i / init_st i--> st' ->
  st = st'.
Proof.
  intros init_st st st' i H1 H2. inversion H1; inversion H2; subst;
  try (inversion H8; auto);
  try (inversion H7; auto);
  try (inversion H6; auto);
  try (inversion H5; auto);
  try (inversion H4; auto).
Qed.

Theorem instr_class_always_isteps : forall st i,
  exists st', i / st i--> st'.
Proof.
  intros st i. induction i; eexists.
- apply I_Heap_Read.
- apply I_Heap_Write.
- apply I_Heap_Check.
- apply I_Call_Check.
- apply I_Reg_Move.
- apply I_Reg_Write.
- apply I_Stack_Expand.
- apply I_Stack_Contract.
- apply I_Stack_Read.
- apply I_Stack_Write.
- apply I_Indirect_Call.
- apply I_Direct_Call.
- apply I_Branch.
- apply I_UniOp.
- apply I_BinOp.
- apply I_DivOp.
- apply I_Ret.
Qed.

Definition run_basic_block (bb : basic_block) (s : state) : state :=
  fold_left (fun s i => run_instr i s) bb s.

(* TODO: Not sure why this is necessary, but it won't go through
 * if I try to inline node_ty_eqb_dec *)
Definition node_ty_eqb (a : node_ty) (b : node_ty) : bool :=
  if node_ty_eq_dec a b
  then true
  else false.

(* TODO: Not sure why this is necessary, but it won't go through
 * if I try to inline edge_class_eqb_dec *)
Definition edge_class_eqb (a : edge_class) (b : edge_class) : bool :=
  if edge_class_eq_dec a b
  then true
  else false.

Definition find_edge (cfg : cfg_ty) (n : node_ty) (e : edge_class) : option node_ty :=
  match find (fun x => andb (node_ty_eqb (fst (fst x)) n)
                            (edge_class_eqb (snd x) e))
             cfg.(edges) with
  | Some edge => Some (snd (fst edge))
  | None => None
  end.

Definition next_node (cfg : cfg_ty) (s : state) (n : node_ty) : option node_ty :=
  match last (fst n) Ret with
  | Branch c => if run_conditional c s
                then find_edge cfg n True_Branch
                else find_edge cfg n False_Branch
  | Ret => None
  | _ => find_edge cfg n Non_Branch
  end.

Definition get_function_from_name (p : program_ty) (name : string) : option function_ty :=
  find (fun x => eqb (snd x) name) p.(funs).

Definition function_lookup (p : program_ty) (s : state) (i : int64) : option function_ty :=
match (s.(function_table) i) with
| Some name => get_function_from_name p name
| None => get_function_from_name p "trap"
end.

(* TODO: Make sure we are handling errors correctly *)
Fixpoint run_program (p : program_ty) (cfg : cfg_ty) (n : node_ty) (s : state) (fuel : nat) : state :=
  match fuel with
  | 0 => set_error_state s
  | S fuel' =>
    let bb := fst n in
    let s' := run_basic_block bb s in
    let s'' := match last bb Ret with
               | Direct_Call name =>
                   match get_function_from_name p name with
                   | Some f => run_program p (fst f) (fst f).(start_node) s' fuel'
                   | None => set_error_state s'
                   end
               | Indirect_Call r =>
                   match function_lookup p s' (get_register s r) with
                   | Some f => run_program p (fst f) (fst f).(start_node) s' fuel'
                   | None => set_error_state s'
                   end
               | _ => s'
               end in
    match next_node cfg s n with
    | Some n' => run_program p cfg n' s'' fuel'
    | None => s''
    end
  end.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

(* Used to generate micromega.ml *)

Require Import ZMicromega.
Require Import QMicromega.
Require Import RMicromega.
Require Import VarMap.
Require Import RingMicromega.
Require Import NArith.
Require Import QArith.

Extract Inductive prod => "( * )" [ "(,)" ].
Extract Inductive List.list => list [ "[]" "(::)" ].
Extract Inductive bool => bool [ true false ].
Extract Inductive sumbool => bool [ true false ].
Extract Inductive option => option [ Some None ].
Extract Inductive sumor => option [ Some None ].
(** Then, in a ternary alternative { }+{ }+{ },
   -  leftmost choice (Inleft Left) is (Some true),
   -  middle choice (Inleft Right) is (Some false),
   -  rightmost choice (Inright) is (None) *)

(** To preserve its laziness, andb is normally expansed.
    Let's rather use the ocaml && *)
Extract Inlined Constant andb => "(&&)".

Extraction "micromega.ml"
  List.map simpl_cone (*map_cone  indexes*)
  denorm Qpower
  n_of_Z Nnat.N_of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


Require Import
        Fiat.Common.ilist
        Fiat.Common.SumType
        Fiat.Narcissus.Common.Specs.

Require Import
        Coq.Sets.Ensembles
        Bedrock.Word.

Section SumType.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : MonoidUnit monoid bool}.

  Definition format_SumType {m}
             (types : Vector.t Type m)
             (formatrs : ilist (B := fun T => T -> CacheFormat -> B * CacheFormat) types)
             (st : SumType types)
    : CacheFormat -> B * CacheFormat :=
    ith formatrs (SumType_index types st) (SumType_proj types st).

  Definition decode_SumType {m}
             (types : Vector.t Type m)
             (decoders : ilist (B := fun T => B -> CacheDecode -> T * B * CacheDecode) types)
             (idx : Fin.t m)
             (b : B)
             (cd : CacheDecode)
    : SumType types * B * CacheDecode :=
    let z := (ith decoders idx b cd) in
    (inj_SumType types idx (fst (fst z)), snd (fst z), snd z).

  Lemma tri_proj_eq {A C D} : forall a c d (acd : A * C * D),
      a = fst (fst acd)
      -> c = snd (fst acd)
      -> d = snd acd
      -> acd = ((a, c), d).
  Proof.
    intros; subst; intuition.
  Qed.

  Theorem SumType_decode_correct {m}
          (types : Vector.t Type m)
          (formatrs : ilist (B := fun T => T -> CacheFormat -> B * CacheFormat) types)
          (decoders : ilist (B := fun T => B -> CacheDecode -> T * B * CacheDecode) types)
          (invariants : forall idx, Vector.nth types idx -> Prop)
          (formatrs_decoders_correct : forall idx,
              format_decode_correct
                monoid
                (fun st => invariants idx st)
                (ith formatrs idx)
                (ith decoders idx))
          idx
    :
    format_decode_correct monoid (fun st => SumType_index types st = idx /\ invariants _ (SumType_proj types st))
                          (format_SumType types formatrs)
                          (decode_SumType types decoders idx).
  Proof.
    revert types formatrs decoders invariants formatrs_decoders_correct.
    unfold format_decode_correct, format_SumType, decode_SumType.
    induction types.
    - inversion idx.
    - revert types IHtypes h; pattern n, idx; apply Fin.caseS;
        clear n idx; intros; destruct H0.
      + (* First element *)
        destruct types.
        * unfold SumType in data, data'.
          eapply (formatrs_decoders_correct Fin.F1); eauto.
          injection H2; intros; subst.
          apply tri_proj_eq; eauto.
        * destruct data; try discriminate.
          injection H2; intros; subst.
          repeat split; try f_equal;
          eapply (formatrs_decoders_correct Fin.F1) with
          (ext := ext)
            (ext' := snd (fst (prim_fst decoders (mappend bin ext) env')))
            (data' := fst (fst (prim_fst decoders (mappend bin ext) env'))); intuition eauto; apply tri_proj_eq; eauto.
      + (* Second element *)
        destruct types; try discriminate.
        destruct data as [s | s]; try discriminate.
        destruct data' as [s' | s']; try discriminate.
        assert (p = SumType_index (Vector.cons Type h0 n types) s) by
            (apply Fin.FS_inj in H0;
             rewrite <- H0; reflexivity).
        assert (invariants
                  (Fin.FS (SumType_index (Vector.cons Type h0 n types) s))
                  (SumType_proj (Vector.cons Type h0 n types) s)) as H3' by
            eapply H3.
        assert (ith formatrs
                    (Fin.FS (SumType_index (Vector.cons Type h0 n types) s))
                    (SumType_proj (Vector.cons Type h0 n types) s) env =
                (bin, xenv)) as H1' by apply H1; clear H1.
        assert (Equiv xenv xenv' /\ s = s' /\ ext = ext').
        eapply IHtypes; eauto.
        intros; eapply (fun idx => formatrs_decoders_correct (Fin.FS idx));
          eauto.
        eapply H5.
        split.
        symmetry; apply H4.
        apply H3'.
        eapply tri_proj_eq;
          try solve [injection H2; intros; subst; eauto].
        intuition.
        congruence.
  Qed.
End SumType.

Arguments SumType : simpl never.