Require Import
        HoTT.Basics
        HoTT.DProp
        HoTT.BoundedSearch
        HoTT.Spaces.Finite
        HoTT.ExcludedMiddle.

Require Import
        HoTT.Classes.interfaces.abstract_algebra
        HoTT.Classes.interfaces.orders
        HoTT.Classes.interfaces.rationals
        HoTT.Classes.interfaces.cauchy
        HoTT.Classes.interfaces.archimedean
        HoTT.Classes.interfaces.round
        HoTT.Classes.interfaces.naturals
        HoTT.Classes.implementations.peano_naturals
        HoTT.Classes.orders.archimedean
        HoTT.Classes.orders.dec_fields
        HoTT.Classes.orders.lattices
        HoTT.Classes.theory.apartness
        HoTT.Classes.theory.rationals.

(* Strangely, it seems that combining the next import with the above list breaks some instance search? *)
Require Import
        HoTT.Classes.orders.fields
        HoTT.Classes.theory.fields
        HoTT.Classes.theory.dec_fields.

Local Open Scope type_scope.

Section locator.
  Context (Q : Type).
  Context `{Qrats : Rationals Q}.
  Context {Qdec_paths : DecidablePaths Q}.
  Context {Qtriv : TrivialApart Q}.
  Context `{!Trichotomy (<)}.
  Context (F : Type).
  Context `{Forderedfield : OrderedField F}.
  Context {Fabs : Abs F}.
  Context {Farchimedean : ArchimedeanProperty Q F}.
  Context {Fcomplete : IsComplete Q F}.
  Context {Qroundup : RoundUpStrict Q}.

  Context `{Funext} `{Univalence}.

  (* Assume we have enumerations of the rationals, and of pairs of ordered rationals. *)
  Context (Q_eq : nat <~> Q).
  Context (QQpos_eq : nat <~> Q * Qpos Q).

  Instance qinc : Cast Q F := rationals_to_field Q F.
  (* TODO The following two instances should probably come from the `Rationals` instance. *)
  Context (cast_pres_ordering : StrictlyOrderPreserving qinc)
          (qinc_strong_presving : IsSemiRingStrongPreserving qinc).
  Existing Instance cast_pres_ordering.
  Existing Instance qinc_strong_presving.

  (* Definition of a locator for a fixed real number. *)
  Definition locator (x : F) := forall q r : Q, q < r -> (' q < x) + (x < ' r).

  (* Alternative definition; see equivalence below *)
  Record locator' (x : F) :=
    { locates_right : forall q r : Q, q < r -> DHProp
    ; locates_right_true : forall q r : Q, forall nu : q < r, locates_right q r nu -> ' q < x
    ; locates_right_false : forall q r : Q, forall nu : q < r, ~ locates_right q r nu -> x < ' r
    }.

  Arguments locates_right       [x] _ [q] [r] _.
  Arguments locates_right_true  [x] _ [q] [r] _.
  Arguments locates_right_false [x] _ [q] [r] _.

  Definition locates_left {x : F} (l : locator' x) {q r : Q} : q < r -> DHProp :=
    fun nu => Build_DHProp (Build_HProp (~ (locates_right l nu))) _.

  Section classical.
    Context `{ExcludedMiddle}.

    Lemma all_reals_locators (x : F) : locator x.
    Proof.
      intros q r ltqr.
      case (LEM (' q < x)).
      - apply _.
      - exact inl.
      - intros notlt.
        apply inr.
        assert (ltqr' : ' q < ' r)
          by auto.
        exact (nlt_lt_trans notlt ltqr').
    Qed.

  End classical.

  Section rational.
    Context (s : Q).

    Lemma locator_left : locator (' s).
    Proof.
      intros q r ltqr.
      destruct (trichotomy _ q s) as [ltqs|[eqqs|ltsq]].
      - apply inl. apply (strictly_order_preserving _); assumption.
      - rewrite eqqs in ltqr. apply inr, (strictly_order_preserving _); assumption.
      - apply inr, (strictly_order_preserving _), (transitivity ltsq ltqr); assumption.
    Qed.

    Definition locator_second : locator (' s).
    Proof.
      intros q r ltqr.
      destruct (trichotomy _ s r) as [ltsr|[eqsr|ltrs]].
      - apply inr, (strictly_order_preserving _); assumption.
      - rewrite <- eqsr in ltqr. apply inl, (strictly_order_preserving _); assumption.
      - apply inl, (strictly_order_preserving _), (transitivity ltqr ltrs).
    Qed.

  End rational.

  Section logic.

    Context {x : F}.

    Definition locator_locator' : locator x -> locator' x.
    Proof.
      intros l.
      refine (Build_locator' x (fun q r nu => Build_DHProp (Build_HProp (is_inl (l q r nu))) _) _ _).
      - intros q r nu. simpl. apply un_inl.
      - intros q r nu. simpl. destruct (l q r nu) as [ltqx|].
        + simpl; intros f; destruct (f tt).
        + intros ?; assumption.
    Defined.

    Definition locator'_locator : locator' x -> locator x.
    Proof.
      intros l' q r nu.
      destruct (dec (locates_right l' nu)) as [yes|no].
      - apply inl. exact (locates_right_true l' nu yes).
      - apply inr. exact (locates_right_false l' nu no).
    Defined.
  End logic.

  Section logic2.

    Context {x : F}.

    Coercion locator_locator' : locator >-> locator'.

    Definition locator_locator'_locator (l : locator x) : locator'_locator (locator_locator' l) = l.
    Proof.
      apply path_forall; intros q.
      apply path_forall; intros r.
      apply path_forall; intros nu.
      unfold locator'_locator, locator_locator'. simpl.
      destruct (l q r nu); auto.
    Qed.

    Local Definition locsig : _ <~> locator' x := ltac:(issig).

    Lemma locator'_locator_locator' (l' : locator' x)
      : locator_locator' (locator'_locator l') = l'.
    Proof.
      enough (p : locsig ^-1 (locator_locator' (locator'_locator l')) = locsig ^-1 l').
      - refine (equiv_inj (locsig ^-1) p).
      - unfold locsig; simpl.
        destruct l'; unfold locator'_locator, locator_locator'; simpl.
        apply path_sigma_hprop; simpl.
        apply path_forall; intro q;
          apply path_forall; intro r;
            apply path_arrow; intro nu.
        apply equiv_path_dhprop; simpl.
        rewrite (path_dec (locates_right0 q r nu)).
        destruct (dec (locates_right0 q r nu)); auto.
    Qed.

    Definition equiv_locator_locator' : locator x <~> locator' x
      := equiv_adjointify
           locator_locator'
           locator'_locator
           locator'_locator_locator'
           locator_locator'_locator.

    Lemma nltqx_locates_left {q r : Q} (l' : locator' x) (ltqr : q < r)
      : ~ (' q < x) -> locates_left l' ltqr.
    Proof.
      assert (f := locates_right_true l' ltqr).
      exact (not_contrapositive f).
    Qed.

    Lemma ltxq_locates_left {q r : Q} (l' : locator' x) (ltqr : q < r)
      : x < ' q -> locates_left l' ltqr.
    Proof.
      intros ltxq. apply nltqx_locates_left.
      apply lt_flip; assumption.
    Qed.

    Lemma nltxr_locates_right {q r : Q} (l' : locator' x) (ltqr : q < r)
      : ~ (x < ' r) -> locates_right l' ltqr.
    Proof.
      intros nltxr.
      apply stable.
      assert (f := locates_right_false l' ltqr).
      exact (not_contrapositive f nltxr).
    Qed.

    Lemma ltrx_locates_right {q r : Q} (l' : locator' x) (ltqr : q < r)
      : 'r < x -> locates_right l' ltqr.
    Proof.
      intros ltrx. apply nltxr_locates_right.
      apply lt_flip; assumption.
    Qed.

  End logic2.

  Local Definition ltQnegQ (q : Q) (eps : Qpos Q) : q - 'eps < q.
  Proof.
    apply (pos_minus_lt_compat_r q ('eps)), eps.
  Qed.

  Local Open Scope mc_scope.

  Local Definition ltQposQ (q : Q) (eps : Qpos Q) : q < q + 'eps.
  Proof.
    apply (pos_plus_lt_compat_r q ('eps)), eps.
  Qed.

  Section bounds.
    (* Given a real with a locator, we can find (integer) bounds. *)
    Context {x : F}
            (l : locator x).

    Local Definition ltN1 (q : Q) : q - 1 < q := ltQnegQ q 1.

    Local Definition P_lower (q : Q) : Type := locates_right l (ltN1 q).

    Definition P_lower_prop {k} : IsHProp (P_lower k).
    Proof.
      apply _.
    Qed.

    Local Definition ltxN1 : x - 1 < x := (fst (pos_minus_lt_compat_r x 1) lt_0_1).

    Local Definition P_lower_inhab : hexists (fun q => P_lower q).
    Proof.
      assert (hqlt : hexists (fun q => ' q < x)).
      {
        assert (hex := archimedean_property Q F (x-1) x ltxN1).
        refine (Trunc_rec _ hex); intros hex'.
        apply tr.
        destruct hex' as [q [ltx1q ltqx]]; exists q; assumption.
      }
      refine (Trunc_rec _ hqlt); intros hqlt'.
      induction hqlt' as [q lt].
      apply tr.
      exists q.
      unfold P_lower.
      apply ltrx_locates_right; assumption.
    Qed.

    Definition lower_bound : {q : Q | ' q < x}.
    Proof.
      assert (qP_lower : {q : Q | P_lower q})
        by refine (minimal_n_alt_type Q Q_eq P_lower _ P_lower_inhab).
      destruct qP_lower as [q Pq].
      exists (q - 1).
      unfold P_lower in Pq. simpl in *.
      apply (un_inl _ Pq).
    Qed.

    Local Definition lt1N (r : Q) : r < r + 1 := ltQposQ r 1.

    Local Definition P_upper (r : Q) : DHProp := locates_left l (lt1N r).

    Definition P_upper_prop {k} : IsHProp (P_upper k).
    Proof.
      apply _.
    Qed.

    Local Definition ltx1N : x < x + 1 := (fst (pos_plus_lt_compat_r x 1) lt_0_1).

    Local Definition P_upper_inhab : hexists (fun r => P_upper r).
    Proof.
      assert (hqlt : hexists (fun r => x < ' r)).
      {
        assert (hex := archimedean_property Q F x (x+1) ltx1N).
        refine (Trunc_rec _ hex); intros hex'.
        apply tr.
        destruct hex' as [r [ltxr ltrx1]]; exists r; assumption.
      }
      refine (Trunc_rec _ hqlt); intros hqlt'.
      induction hqlt' as [r lt].
      apply tr.
      exists r.
      unfold P_upper.
      apply ltxq_locates_left; assumption.
    Qed.

    Definition upper_bound : {r : Q | x < ' r}.
    Proof.
      assert (rP_upper : {r : Q | P_upper r})
        by refine (minimal_n_alt_type Q Q_eq P_upper _ P_upper_inhab).
      destruct rP_upper as [r Pr].
      exists (r + 1).
      unfold P_upper in Pr. simpl in *.
      destruct (l r (r + 1) (lt1N r)).
      - simpl in Pr. destruct (Pr tt).
      - assumption.
    Qed.

    Instance inc_N_Q : Cast nat Q := naturals_to_semiring nat Q.

    Instance inc_fin_N {n} : Cast (Fin n) nat := fin_to_nat.

    Lemma tight_bound (epsilon : Qpos Q) : {u : Q | ' u < x < ' (u + ' epsilon)}.
    Proof.
      destruct
        lower_bound as [q ltqx]
      , upper_bound as [r ltxr]
      , (round_up_strict Q ((3/'epsilon)*(r-q))) as [n lt3rqn].
      assert (lt0 : 0 < 'epsilon / 3).
      {
        apply pos_mult.
        - apply epsilon.
        - apply pos_dec_recip_compat, lt_0_3.
      }
      assert (lt0' : 0 < 3 / ' epsilon).
      {
        apply pos_mult.
        - apply lt_0_3.
        - apply pos_dec_recip_compat, epsilon.
      }
      assert (ap30 : (3 : Q) <> 0)
        by apply lt_ne_flip, lt_0_3.
      clear - l q ltqx r ltxr n lt3rqn lt0' ap30 Qtriv Qdec_paths H cast_pres_ordering.
      assert (ltn3eps : r < q + ' n * ' epsilon / 3).
      {
        rewrite (commutativity q (' n * ' epsilon / 3)).
        apply flip_lt_minus_l.
        apply (pos_mult_reflect_r (3 / ' epsilon) lt0').
        rewrite (commutativity (r-q) (3 / ' epsilon)).
        rewrite <- (associativity ('n) ('epsilon) (/3)).
        rewrite <- (associativity ('n) (' epsilon / 3) (3 / ' epsilon)).
        rewrite <- (associativity ('epsilon) (/3) (3/'epsilon)).
        rewrite (associativity (/3) 3 (/'epsilon)).
        rewrite (commutativity (/3) 3).
        rewrite (dec_recip_inverse 3 ap30).
        rewrite mult_1_l.
        assert (apepsilon0 : 'epsilon <> 0)
          by apply lt_ne_flip, epsilon.
        rewrite (dec_recip_inverse ('epsilon) apepsilon0).
        rewrite mult_1_r.
        assumption.
      }
      set (grid (k : Fin n.+3) := q + (' (' k) - 1)*('epsilon/3) : Q).
      assert (lt_grid : forall k : Fin _, grid (fin_incl k) < grid (fsucc k)).
      {
        intros k. unfold grid.
        change (' fin_incl k) with (fin_to_nat (fin_incl k));
          rewrite path_nat_fin_incl.
        change (' fsucc k) with (fin_to_nat (fsucc k));
          rewrite path_nat_fsucc.
        assert (' (S (' k)) = (' (' k) + 1)) as ->.
        {
          rewrite S_nat_plus_1.
          rewrite (preserves_plus (' k) 1).
          rewrite preserves_1.
          reflexivity.
        }
        assert (' (' k) + 1 - 1 = ' (' k) - 1 + 1) as ->.
        {
          rewrite <- (associativity _ 1 (-1)).
          rewrite (commutativity 1 (-1)).
          rewrite (associativity _ (-1) 1).
          reflexivity.
        }
        assert (lt1 : ' (' k) - 1 < ' (' k) - 1 + 1)
          by apply pos_plus_lt_compat_r, lt_0_1.
        assert (lt2 : (' (' k) - 1) * (' epsilon / 3) < (' (' k) - 1 + 1) * (' epsilon / 3)).
        {
          nrefine (pos_mult_lt_r ('epsilon/3) _ (' (' k) - 1) (' (' k) - 1 + 1) _); try apply _.
          apply lt1.
        }
        apply pseudo_srorder_plus.
        exact lt2.
      }
      set (P k := locates_right l (lt_grid k)).
      assert (left_true : P fin_zero).
      {
        apply ltrx_locates_right.
        unfold grid.
        change (' fsucc fin_zero) with (fin_to_nat (@fsucc (S n) fin_zero)).
        rewrite path_nat_fsucc, path_nat_fin_zero.
        rewrite (@preserves_1 nat Q _ _ _ _ _ _ _ _ _ _).
        rewrite plus_negate_r.
        rewrite mult_0_l.
        rewrite plus_0_r.
        assumption.
      }
      assert (right_false : ~ P fin_last).
      {
        apply ltxq_locates_left.
        unfold grid.
        change (' fin_incl fin_last) with (fin_to_nat (@fin_incl (S (S n)) fin_last)).
        rewrite path_nat_fin_incl, path_nat_fin_last.
        rewrite S_nat_plus_1.
        rewrite (preserves_plus n 1).
        rewrite (@preserves_1 nat Q _ _ _ _ _ _ _ _ _ _).
        rewrite <- (associativity (' n) 1 (-1)).
        rewrite plus_negate_r.
        rewrite plus_0_r.
        rewrite (associativity ('n) ('epsilon) (/3)).
        transitivity ('r).
        - exact ltxr.
        - apply strictly_order_preserving; try trivial.
      }
      destruct (sperners_lemma_1d P left_true right_false) as [u [Pltux Pltxueps]].
      exists (grid (fin_incl (fin_incl u))).
      unfold P in Pltux, Pltxueps.
      split.
      - apply (locates_right_true l (lt_grid (fin_incl u)) Pltux).
      - clear - Pltxueps Qtriv Qdec_paths ap30 cast_pres_ordering.
        set (ltxbla := locates_right_false l (lt_grid (fsucc u)) Pltxueps).
        unfold grid in *.
        change (' fin_incl (fin_incl u)) with (fin_to_nat (fin_incl (fin_incl u))).
        rewrite path_nat_fin_incl, path_nat_fin_incl.
        change (' fsucc (fsucc u)) with (fin_to_nat (fsucc (fsucc u))) in ltxbla.
        rewrite path_nat_fsucc, path_nat_fsucc in ltxbla.
        rewrite S_nat_plus_1, S_nat_plus_1 in ltxbla.
        rewrite (preserves_plus (fin_to_nat u + 1) 1) in ltxbla.
        rewrite (preserves_plus (fin_to_nat u) 1) in ltxbla.
        rewrite preserves_1 in ltxbla.
        rewrite <- (associativity (' fin_to_nat u) 1 1) in ltxbla.
        rewrite <- (associativity (' fin_to_nat u) 2 (-1)) in ltxbla.
        rewrite (commutativity 2 (-1)) in ltxbla.
        rewrite (associativity (' fin_to_nat u) (-1) 2) in ltxbla.
        rewrite plus_mult_distr_r in ltxbla.
        rewrite (associativity q ((' fin_to_nat u - 1) * (' epsilon / 3)) (2 * (' epsilon / 3))) in ltxbla.
        refine (transitivity ltxbla _).
        apply strictly_order_preserving; try apply _.
        apply pseudo_srorder_plus.
        rewrite (associativity 2 ('epsilon) (/3)).
        rewrite (commutativity 2 ('epsilon)).
        rewrite <- (mult_1_r ('epsilon)).
        rewrite <- (associativity ('epsilon) 1 2).
        rewrite (mult_1_l 2).
        rewrite <- (associativity ('epsilon) 2 (/3)).
        apply pos_mult_lt_l.
        + apply epsilon.
        + nrefine (pos_mult_reflect_r (3 : Q) lt_0_3 _ _ _); try apply _.
          rewrite <- (associativity 2 (/3) 3).
          rewrite (commutativity (/3) 3).
          rewrite (dec_recip_inverse (3 : Q) ap30).
          rewrite (mult_1_r 2).
          rewrite (mult_1_l 3).
          exact lt_2_3.
    Qed.

  End bounds.

  Section arch_struct.

    Context {x y : F}
            (l : locator x)
            (m : locator y)
            (ltxy : x < y).

    Local Definition P (qeps' : Q * Qpos Q) : Type :=
      match qeps' with
      | (q' , eps') =>
        (prod
           (locates_left l (ltQnegQ q' eps'))
           (locates_right m (ltQposQ q' eps')))
      end.

    Local Definition P_isHProp qeps' : IsHProp (P qeps').
    Proof.
      destruct qeps' as [q eps'].
      apply istrunc_prod.
    Qed.

    Local Definition P_dec qeps' : Decidable (P qeps').
    Proof.
      destruct qeps' as [q eps'].
      unfold P.
      apply _.
    Qed.

    Local Definition P_inhab : hexists P.
    Proof.
      assert (hs := (archimedean_property Q F x y ltxy)).
      refine (Trunc_ind _ _ hs); intros [s [ltxs ltsy]].
      assert (ht := (archimedean_property Q F ('s) y ltsy)).
      refine (Trunc_ind _ _ ht); intros [t [ltst' ltty]].
      set (q := (t + s) / 2).
      assert (ltst : s < t).
      {
        Existing Instance full_pseudo_order_reflecting.
        refine (strictly_order_reflecting _ _ _ ltst').
      }
      set (epsilon := (Qpos_diff s t ltst) / 2).
      apply tr.
      exists (q, epsilon).
      unfold P; split.
      - apply ltxq_locates_left.
        assert (q - ' epsilon = s) as ->.
        {
          unfold q; cbn.
          rewrite <- path_avg_split_diff_l.
          rewrite <- (plus_assoc s ((t-s)/2) (-((t-s)/2))).
          rewrite plus_negate_r.
          rewrite plus_0_r.
          reflexivity.
        }
        assumption.
      - apply ltrx_locates_right.
        assert (q + ' epsilon = t) as ->.
        {
          unfold q; cbn.
          rewrite <- path_avg_split_diff_r.
          rewrite <- (plus_assoc t (-((t-s)/2)) ((t-s)/2)).
          rewrite plus_negate_l.
          rewrite plus_0_r.
          reflexivity.
        }
        assumption.
    Qed.

    Definition archimedean_structure : {q : Q | x < 'q < y}.
    Proof.
      assert (R : sig P).
      {
        apply minimal_n_alt_type.
        - apply QQpos_eq.
        - apply P_dec.
        - apply P_inhab.
      }
      unfold P in R.
      destruct R as [[q eps] [lleft mright]].
      exists q; split.
      - nrefine (locates_right_false l _ lleft).
      - nrefine (locates_right_true  m _ mright).
    Qed.

  End arch_struct.

  Section unary_ops.

    Context {x : F}
            (l : locator x).

    Definition locator_minus : locator (-x).
    Proof.
      intros q r ltqr.
      assert (ltnrnq := snd (flip_lt_negate q r) ltqr : -r < -q).
      destruct (l _ _ ltnrnq) as [ltnrx|ltxnq].
      - apply inr. apply char_minus_left. rewrite <- preserves_negate. assumption.
      - apply inl. apply char_minus_right. rewrite <- preserves_negate. assumption.
    Qed.

    Section recip_pos.
      Context (xpos : 0 < x).

      Local Definition recip_nu := positive_apart_zero x xpos.

      Definition locator_recip_pos : locator (// (x ; recip_nu)).
      Proof.
        assert (recippos : 0 < // (x ; recip_nu))
          by apply pos_recip_compat.
        intros q r ltqr. destruct (trichotomy _ q 0) as [qneg|[qzero|qpos]].
        + apply inl. refine (transitivity _ _).
          * apply (strictly_order_preserving _). exact qneg.
          * rewrite preserves_0; assumption.
        + apply inl. rewrite qzero, preserves_0; assumption.
        + assert (qap0 : q ≶ 0)
            by apply (pseudo_order_lt_apart_flip _ _ qpos).
          assert (rap0 : r ≶ 0).
          {
            refine (pseudo_order_lt_apart_flip _ _ _).
            apply (transitivity qpos ltqr).
          }
          assert (ltrrrq : / r < / q)
            by (apply flip_lt_dec_recip; assumption).
          destruct (l (/r) (/q) ltrrrq) as [ltrrx|ltxrq].
          * apply inr.
            assert (rpos : 0 < r)
              by (transitivity q; assumption).
            assert (rpos' : 0 < ' r).
            {
              rewrite <- (@preserves_0 Q F _ _ _ _ _ _ _ _ _ _).
              apply strictly_order_preserving; try apply _; assumption.
            }
            rewrite (dec_recip_to_recip r (positive_apart_zero ('r) rpos')) in ltrrx.
            assert (ltxrr := flip_lt_recip_l x ('r) rpos' ltrrx).
            cbn in ltxrr.
            rewrite
              (recip_irrelevant
                 x
                 (positive_apart_zero
                    x
                    (transitivity (pos_recip_compat (' r) rpos') ltrrx)) recip_nu) in ltxrr.
            exact ltxrr.
          * apply inl.
            assert (qpos' : 0 < ' q).
            {
              rewrite <- (@preserves_0 Q F _ _ _ _ _ _ _ _ _ _).
              apply strictly_order_preserving; try apply _; assumption.
            }
            rewrite (dec_recip_to_recip q (positive_apart_zero ('q) qpos')) in ltxrq.
            assert (ltrqx := flip_lt_recip_r ('q) x qpos' xpos ltxrq).
            rewrite (recip_irrelevant x (positive_apart_zero x xpos) recip_nu) in ltrqx.
            exact ltrqx.
      Qed.
    End recip_pos.

  End unary_ops.

  Section recip_neg.
    Context {x : F}
            (l : locator x)
            (xneg : x < 0).

    Local Definition recip_neg_nu := negative_apart_zero x xneg.

    Definition locator_recip_neg : locator (// (x ; recip_neg_nu)).
    Proof.
      assert (negxpos : 0 < (-x))
        by (apply flip_neg_negate; assumption).
      assert (l' := locator_minus (locator_recip_pos (locator_minus l) negxpos)).
      rewrite (recip_negate (-x)) in l'.
      unfold negate_apart in l'.
      rewrite
        (recip_proper_alt
           (- - x)
           x
           (apart_negate (- x) (positive_apart_zero (- x) negxpos)) recip_neg_nu)
        in l'.
      - assumption.
      - apply negate_involutive.
    Qed.

  End recip_neg.

  Section unary_ops2.

    Context {x : F}
            (l : locator x)
            (nu : x ≶ 0).

    Definition locator_recip : locator (// (x ; nu)).
    Proof.
      destruct (fst (apart_iff_total_lt x 0) nu) as [xneg|xpos].
      - set (l' := locator_recip_neg l xneg).
        rewrite (recip_proper_alt x x (negative_apart_zero x xneg) nu) in l';
          try reflexivity; exact l'.
      - set (l' := locator_recip_pos l xpos).
        rewrite (recip_proper_alt x x (positive_apart_zero x xpos) nu) in l';
          try reflexivity; exact l'.
    Qed.

  End unary_ops2.

  Section binary_ops.

    Context {x y : F}
            (l : locator x)
            (m : locator y).

    (** TODO the following two should be proven in Classes/orders/archimedean.v *)
    Context (char_plus_left : forall (q : Q) (x y : F),
                ' q < x + y <-> hexists (fun s : Q => (' s < x) /\ (' (q - s) < y)))
            (char_plus_right : forall (r : Q) (x y : F),
                x + y < ' r <-> hexists (fun t : Q => (x < ' t) /\ (y < ' (r - t)))).

    Definition locator_plus : locator (x + y).
    Proof.
      intros q r ltqr.
      set (epsilon := (Qpos_diff q r ltqr) / 2).
      assert (q+'epsilon=r-'epsilon)
        by (rewrite path_avg_split_diff_l, path_avg_split_diff_r; reflexivity).
      destruct (tight_bound m epsilon) as [u [ltuy ltyuepsilon]].
      set (s := q-u).
      assert (qsltx : 'q-'s<y).
      {
        unfold s.
        rewrite (preserves_plus q (-u)).
        rewrite negate_plus_distr.
        rewrite (associativity ('q) (-'q) (-'(-u))).
        rewrite plus_negate_r.
        rewrite plus_0_l.
        rewrite (preserves_negate u).
        rewrite negate_involutive.
        assumption.
      }
      assert (sltseps : s<s+' epsilon)
        by apply ltQposQ.
      destruct (l s (s+' epsilon) sltseps) as [ltsx|ltxseps].
      - apply inl. apply char_plus_left. apply tr; exists s; split; try assumption.
        rewrite preserves_minus; assumption.
      - apply inr. apply char_plus_right. apply tr.
        set (t := s + ' epsilon); exists t.
        split; try assumption.
        assert (r-(q-u+(r-q)/2)=u+'epsilon) as ->.
        {
          change ((r - q) / 2) with ('epsilon).
          rewrite negate_plus_distr.
          rewrite <- negate_swap_l.
          rewrite (plus_comm (-q) u).
          rewrite (plus_assoc r (u-q) (-'epsilon)).
          rewrite (plus_assoc r u (-q)).
          rewrite (plus_comm r u).
          rewrite <- (plus_assoc u r (-q)).
          rewrite <- (plus_assoc u (r-q) (-'epsilon)).
          rewrite (plus_comm r (-q)).
          rewrite <- (plus_assoc (-q) r (-'epsilon)).
          rewrite path_avg_split_diff_r.
          rewrite <- path_avg_split_diff_l.
          rewrite (plus_assoc (-q) q ((r-q)/2)).
          rewrite (plus_negate_l q).
          rewrite (plus_0_l _).
          reflexivity.
        }
        assumption.
    Qed.

    (* TODO construct locators for multiplications. *)
    Lemma locator_times : locator (x * y).
    Proof. Abort.

    Lemma locator_meet : locator (meet x y).
    Proof.
      intros q r ltqr.
      destruct (l q r ltqr, m q r ltqr) as [[ltqx|ltxr] [ltqy|ltyr]].
      - apply inl, meet_lt_l; assumption.
      - apply inr, meet_lt_r_r; assumption.
      - apply inr, meet_lt_r_l; assumption.
      - apply inr, meet_lt_r_r; assumption.
    Qed.

    Lemma locator_join : locator (join x y).
    Proof.
      intros q r ltqr.
      destruct (l q r ltqr, m q r ltqr) as [[ltqx|ltxr] [ltqy|ltyr]].
      - apply inl, join_lt_l_l; assumption.
      - apply inl, join_lt_l_l; assumption.
      - apply inl, join_lt_l_r; assumption.
      - apply inr, join_lt_r; assumption.
    Qed.

  End binary_ops.

  Section limit.

    Context {xs : nat -> F}.
    Context {M} {M_ismod : CauchyModulus Q F xs M}.
    Context (ls : forall n, locator (xs n)).

    Lemma locator_limit {l} : IsLimit _ _ xs l -> locator l.
    Proof.
      intros islim.
      intros q r ltqr.
      set (epsilon := (Qpos_diff q r ltqr) / 3).
      (* TODO we are doing trisection so we have the inequality: *)
      assert (ltqepsreps : q + ' epsilon < r - ' epsilon).
      {
        apply (strictly_order_reflecting (+'epsilon)).
        rewrite <- (plus_assoc r (-'epsilon) ('epsilon)).
        rewrite plus_negate_l.
        rewrite plus_0_r.
        rewrite <- (plus_assoc q ('epsilon) ('epsilon)).
        apply (strictly_order_reflecting ((-q)+)).
        rewrite (plus_assoc (-q) q _).
        rewrite plus_negate_l, plus_0_l.
        rewrite (plus_comm (-q) r).
        rewrite <- (mult_1_r ('epsilon)).
        rewrite <- plus_mult_distr_l.
        unfold epsilon, cast, Qpos_diff; cbn.
        rewrite <- (mult_assoc (r-q) (/3) 2).
        pattern (r-q) at 2.
        rewrite <- (mult_1_r (r-q)).
        assert (rqpos : 0 < r-q) by apply (Qpos_diff q r ltqr).
        apply (strictly_order_preserving ((r-q)*.)).
        apply (strictly_order_reflecting (3*.)).
        rewrite (mult_assoc 3 (/3) 2).
        rewrite (dec_recip_inverse 3).
        - rewrite mult_1_r, mult_1_l. exact lt_2_3.
        - apply apart_ne, positive_apart_zero, lt_0_3.
      }
      destruct (ls (M (epsilon / 2)) (q + ' epsilon) (r - ' epsilon) ltqepsreps)
        as [ltqepsxs|ltxsreps].
      + apply inl.
        rewrite preserves_plus in ltqepsxs.
        assert (ltqxseps : ' q < xs (M (epsilon / 2)) - ' (' epsilon))
          by (apply flip_lt_minus_r; assumption).
        refine (transitivity ltqxseps _).
        apply (modulus_close_limit _ _ _ _ _).
      + apply inr.
        rewrite (preserves_plus r (-'epsilon)) in ltxsreps.
        rewrite (preserves_negate ('epsilon)) in ltxsreps.
        assert (ltxsepsr : xs (M (epsilon / 2)) + ' (' epsilon) < ' r)
          by (apply flip_lt_minus_r; assumption).
        refine (transitivity _ ltxsepsr).
        apply (modulus_close_limit _ _ _ _ _).
    Qed.

  End limit.

End locator.


Require Import Coq.PArith.BinPos.
Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Named.Syntax.
Require Import Crypto.Compilers.Named.ContextDefinitions.
Require Import Crypto.Compilers.Named.InterpretToPHOASWf.
Require Import Crypto.Compilers.Named.WfFromUnit.
Require Import Crypto.Compilers.Named.PositiveContext.
Require Import Crypto.Compilers.Named.PositiveContext.Defaults.
Require Import Crypto.Compilers.Named.PositiveContext.DefaultsProperties.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.GeneralizeVar.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.Tactics.BreakMatch.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          (base_type_code_beq : base_type_code -> base_type_code -> bool)
          (base_type_code_bl_transparent : forall x y, base_type_code_beq x y = true -> x = y)
          (base_type_code_lb : forall x y, x = y -> base_type_code_beq x y = true)
          (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t))
          {interp_base_type : base_type_code -> Type}
          (interp_op : forall src dst, op src dst -> interp_flat_type interp_base_type src -> interp_flat_type interp_base_type dst).

  Local Notation GeneralizeVar
    := (@GeneralizeVar
          base_type_code op base_type_code_beq base_type_code_bl_transparent
          failb).

  Local Notation PositiveContextOk := (@PositiveContextOk base_type_code _ base_type_code_beq base_type_code_bl_transparent base_type_code_lb).

  Local Instance dec_base_type_code_eq : DecidableRel (@eq base_type_code).
  Proof using base_type_code_lb base_type_code_bl_transparent.
    refine (fun x y => (if base_type_code_beq x y as b return base_type_code_beq x y = b -> Decidable (x = y)
                        then fun pf => left (base_type_code_bl_transparent _ _ pf)
                        else fun pf => right _) eq_refl).
    { clear -pf base_type_code_lb.
      let pf := pf in
      abstract (intro; erewrite base_type_code_lb in pf by eassumption; congruence). }
  Defined.

  Local Arguments Compile.compile : simpl never.
  Lemma Wf_GeneralizeVar
        {t} (e1 : expr base_type_code op t)
        e'
        (He' : GeneralizeVar e1 = Some e')
    : Wf e'.
  Proof using base_type_code_lb.
    unfold GeneralizeVar, option_map in *.
    break_innermost_match_hyps; try congruence; intros v v'; [].
    inversion_option; subst.
    unfold InterpretToPHOAS.Named.InterpToPHOAS, InterpretToPHOAS.Named.InterpToPHOAS_gen.
    destruct t as [src dst].
    eapply (@wf_interp_to_phoas
              base_type_code op FMapPositive.PositiveMap.key _ _ _ _
              (PositiveContext base_type_code _ base_type_code_beq base_type_code_bl_transparent)
              (PositiveContext base_type_code _ base_type_code_beq base_type_code_bl_transparent)
              PositiveContextOk PositiveContextOk
              (failb _) (failb _) _ _);
      [ revert v | revert v' ];
      refine (_ : Wf.Named.Wf _ e);
      apply Wf_from_unit; auto using PositiveContextOk.
  Qed.

  Lemma Wf_GeneralizeVar_arrow
        {s d} (e : expr base_type_code op (Arrow s d))
        e'
        (He' : GeneralizeVar e = Some e')
    : Wf e'.
  Proof using base_type_code_lb. eapply Wf_GeneralizeVar; eassumption. Qed.
End language.

Hint Resolve Wf_GeneralizeVar Wf_GeneralizeVar_arrow : wf.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.
Import ListNotations.

(* In any of these functions, whenever there is a [list ident],
  we assume it is unsorted without duplicates. *)

(* Take the union of two lists *)
Fixpoint deadvars_union (al bl: list ident) : list ident :=
 match al with
 | a::al' => let cl := deadvars_union al' bl in
                   if id_in_list a bl then cl else a::cl
 | nil => bl
 end.
(* Take the intersection of two lists *)
Fixpoint deadvars_intersection (al bl: list ident) : list ident :=
 match al with
 | a::al' => if id_in_list a bl
                then a :: deadvars_intersection al' bl
                else deadvars_intersection al' bl
 | nil => nil
 end.

(* Assume [vl,live] are disjoint.  If [i] is present in [vl], move it to [live] *)
Fixpoint deadvars_remove1 i vl live :=
 match vl with
 | j::vl' => if Pos.eqb i j
             then (vl', i::live)
             else let (vl2, live2) := deadvars_remove1 i vl' live
                     in (j::vl2, live2)
 | nil => (nil, live)
 end.

(* Whenever  (vl',live')=deadvars_remove e vl live,   that means
    disjoint [vl,live],   disjoint [vl',live'],   [vl U live]=[vl' U live'],
    and vl' is the maximal subset of vl that contains no tempvar of e *)
Fixpoint deadvars_remove (e: expr) (vl live: list ident) : list ident * list ident :=
 match e with
 | Etempvar i _ => deadvars_remove1 i vl live
 | Ederef e1 _ => deadvars_remove e1 vl live
 | Eaddrof e1 _ => deadvars_remove e1 vl live
 | Eunop _ e1 _ => deadvars_remove e1 vl live
 | Ebinop _ e1 e2 _ => let (vl', live') := deadvars_remove e1 vl live
                                    in deadvars_remove e2 vl' live'
 | Ecast e1 _ => deadvars_remove e1 vl live
 | Efield e1 _ _ => deadvars_remove e1 vl live
 | _ => (vl, live)
 end.

(* Whenever  (vl',live')=deadvars_removel e vl live,   that means
    disjoint [vl,live],   disjoint [vl',live'],   [vl U live]=[vl' U live'],
    and vl' is the maximal subset of vl that contains no tempvar of el *)
Fixpoint deadvars_removel (el: list expr) (vl live: list ident) : list ident * list ident :=
  match el with
  | nil => (vl , live)
  | e::el' => let (vl', live') := deadvars_remove e vl live
                   in deadvars_removel el' vl' live'
  end.

Fixpoint deadvars_dead (i: ident) (vl: list ident) : list ident * list ident :=
 match vl with
 | j::vl' => if Pos.eqb i j
             then ([i],vl')
             else let (k,vl'') := deadvars_dead i vl' in (k,j::vl')
 | nil => (nil, nil)
 end.

(* (vl',live')=deadvars_delete al vl live,   that means
    disjoint [vl,live],   disjoint [vl',live'],   [vl U live]=[vl' U live'],
    and vl' is the maximal subset of vl that contains no element of al *)
Fixpoint deadvars_delete (al vl live: list ident) : list ident * list ident :=
 match al with
 | a::al' => let (vl',live') := deadvars_delete al' vl live
                   in deadvars_remove1 a vl' live'
 | nil => (vl,live)
 end.

Fixpoint nobreaks (s: statement) : bool :=
match s with
| Sbreak => false
| Scontinue => false
| Ssequence c1 c2 => nobreaks c1 && nobreaks c2
| Sloop c1 c2 => nobreaks c1 && nobreaks c2
| Sifthenelse _ c1 c2 => nobreaks c1 && nobreaks c2
| _ => true
end.

(* (live'',dead'') = deadvars_stmt vl live dead c (fun vl' live' dead' => B) (bcont)    means,
   Let ubd = the variables of vl, used-before-defined in c
   Let def = variables of vl, defined-before-used in c
   Let vl = ubd U def U vl'
   That is, ubd we know for sure are live before c,
     def we know for sure are dead,
     and vl' we need to keep investigating the commands after c.
   Finally, live' = ubd U live,      dead' = def U dead
     and we continue the flow analysis with B, or for break statements we continue with bcont.
   What's returned is a pair (live'',dead'') such that live'' U dead'' = vl.  *)
Fixpoint deadvars_stmt (vl: list ident) (live dead: list ident) (c: statement)
                   (cont bcont: list ident -> list ident -> list ident -> list ident * list ident) : list ident * list ident :=
  match vl with nil => (live,dead) | _ =>
   match c with
   | Sskip => cont vl live dead
   | Sassign e1 e2 => let (vl',live') := deadvars_removel [e1;e2] vl live in
                         cont vl' live' dead
   | Sset i e => let (vl',live') := deadvars_remove e vl live in
                     let (d,vl'') := deadvars_dead i vl' in
                      cont vl'' live' (d++dead)
   | Scall i e el => let (vl',live') := deadvars_removel (e::el) vl live in
                      let (d,vl'') := match i with
                                      | Some i' => deadvars_dead i' vl'
                                      | None => (nil,vl')
                                      end
                      in cont vl'' live' (d++dead)
   | Sbuiltin i ef tl el =>
                     let (vl',live') := deadvars_removel el vl live in
                      let (d,vl'') := match i with
                                      | Some i' => deadvars_dead i' vl'
                                      | None => (nil,vl')
                                      end
                      in cont vl'' live' (d++dead)
   | Ssequence c1 c2 =>
          deadvars_stmt vl live dead c1 (fun vl' live' dead' =>
             deadvars_stmt vl' live' dead' c2 cont bcont) bcont
   | Sreturn None => (nil, vl++dead)
   | Sreturn (Some e) => let (vl',live') := deadvars_removel [e] vl live
                          in (live', vl' ++ dead)
   | Sifthenelse e c1 c2 =>
      if nobreaks c1 && nobreaks c2
      then
           let (vl', live')  := deadvars_removel [e] vl live in
            let (live1,dead1) := deadvars_stmt vl' nil dead c1 (fun _ l d => (l,d)) bcont in
            let (live2,dead2) := deadvars_stmt vl' nil dead c2 (fun _ l d => (l,d)) bcont in
            let live'' := deadvars_union live1 live2 in
            let dead'' := deadvars_intersection dead1 dead2 in
            let (vl'',live3) := deadvars_delete live'' vl' live' in
            let (vl3, _) := deadvars_delete dead'' vl'' nil in
            cont vl3 live3 dead''
     else
           let (vl', live')  := deadvars_removel [e] vl live in
            let (live1,dead1) := deadvars_stmt vl' live' dead c1 cont bcont in
            let (live2,dead2) := deadvars_stmt vl' live' dead c2 cont bcont in
            let live'' := deadvars_union live1 live2 in
            let dead'' := deadvars_intersection dead1 dead2 in
            (live'',dead'')
   | Sbreak => bcont vl live dead
   | Sloop c1 c2 =>
                             (* on the next line, using  vlx++deadx  instead of just deadx  is rather aggressive; is it sound?  *)
            let cont0 := fun vlx livex deadx => (livex,vlx++deadx) in
            let cont1 := fun vl' live' dead' => deadvars_stmt vl' live' dead' c2 cont0 cont
            in deadvars_stmt vl live dead c1 cont1 cont
   | _ => (live,dead)
   end
  end.

Fixpoint temps_of_localdefs (dl: list localdef) : list ident :=
 match dl with
 | nil => nil
 | temp i _ :: dl' => i :: temps_of_localdefs dl'
 | _ :: dl' => temps_of_localdefs dl'
 end.

(*  (live',dead') = deadvars_post post vl live dead.
  The forward flow analysis has reached a postcondition whose LOCALS clause contains
   exactly the tempvars in [post], and by this time in the forward flow analysis we have
   classified our starting variables into three disjoint lists:
     live: definitely live
     dead: definitely dead
     vl:  not yet sure.
   So now we know that the intersection of (vl, post) are all definitely live,
    and the rest of vl are definitely dead, so we can construct
      live' = (vl intersect post) ++ live
      dead' = (vl - post) ++ dead' *)
Fixpoint deadvars_post (post: list ident) (vl: list ident) (live dead: list ident) : list ident * list ident :=
 match post with
 | nil => (nil, vl++dead)
 | i :: post' => let (vl',live') := deadvars_remove1 i vl live in
                             deadvars_post post' vl' live' dead
 end.

Ltac inhabited_value T :=
 match T with
 | nat => constr:(O)
 | Z => constr:(0%Z)
 | list ?A => constr:(@nil A)
 | positive => xH
 | bool => false
 | prod ?A ?B => let x := inhabited_value A in
                           let y := inhabited_value B in
                               constr:(pair x y)
 | _ => match goal with x:T |- _ => x | x := _ : T |- _ => x end
 end.

Fixpoint expr_temps (e: expr) (vl: list ident) : list ident :=
 match e with
 | Etempvar i _ => if id_in_list i vl then vl else i::vl
 | Ederef e1 _ => expr_temps e1 vl
 | Eaddrof e1 _ => expr_temps e1 vl
 | Eunop _ e1 _ => expr_temps e1 vl
 | Ebinop _ e1 e2 _ => expr_temps e2 (expr_temps e1 vl)
 | Ecast e1 _ => expr_temps e1 vl
 | Efield e1 _ _ => expr_temps e1 vl
 | _ => vl
 end.

Ltac locals_of_assert P :=
 match P with
 | (PROPx _ (LOCALx ?Q _)) => constr:(temps_of_localdefs Q)
 | emp => constr:(@nil ident)
 | andp ?A ?B => let a := locals_of_assert A in
                  let b := locals_of_assert B in
                  constr:(a++b)
 | stackframe_of _ => constr:(@nil ident)
 | local (liftx (eq _) (eval_expr ?E)) =>
            let vl := constr:(expr_temps E nil) in vl
 | @exp _ _ ?T ?F =>
    let x := inhabited_value T in
     let d := constr:(F x) in
      let d := eval cbv beta in d in
       let d := locals_of_assert d in
           d
 end.

Ltac locals_of_ret_assert Post :=
 match Post with
 | @abbreviate ret_assert ?P => locals_of_ret_assert P
 | normal_ret_assert ?P => let a := locals_of_assert P in
                                          constr:(pair a (@nil ident))
 | loop1_ret_assert ?P ?R => let a := locals_of_assert P in
                                            let b := locals_of_ret_assert R in
                                               constr:(pair a (fst b))
 | loop2_ret_assert ?P _ => let a := locals_of_assert P in
                                          constr:(pair a (@nil ident))
 | function_body_ret_assert _ _ => constr:(pair (@nil ident) (@nil ident))
 | overridePost ?P ?R => let b := locals_of_ret_assert R in
                                      let a := locals_of_assert P in
                                         constr:(pair a (snd b))
 | frame_ret_assert ?A ?B =>
     let vlA :=  locals_of_ret_assert A
      in let vlB := locals_of_assert B
       in let vl := constr:(pair (fst vlA ++ vlB) (snd vlA ++ vlB))
        in vl
 end.

Ltac find_dead_vars P c Q :=
     let vl := locals_of_assert P in
     let post := locals_of_ret_assert Q in
     let post := eval compute in post in
     let d := constr:(snd (deadvars_stmt vl nil nil c
                                     (deadvars_post (fst post))
                                     (deadvars_post (snd post)))) in
      let d := eval compute in d in
      d.

Ltac deadvars :=
 match goal with
 | X := @abbreviate ret_assert ?Q |-
    semax _ ?P ?c ?Y =>
    constr_eq X Y;
    match find_dead_vars P c Q with
    | nil => idtac
    | ?d =>  idtac "Dropping dead vars!"; drop_LOCALs d
     end + fail 99 "deadvars failed for an unknown reason"
 | |- semax _ _ _ _ =>
       fail "deadvars: Postcondition must be an abbreviated local definition (POSTCONDITION); try abbreviate_semax first"
 | |- _ |-- _ => idtac
 | |- _ => fail "deadvars: the proof goal should be a semax"
 end.

Tactic Notation "deadvars" "!" :=
 match goal with
 | X := @abbreviate ret_assert ?Q |-
    semax _ ?P ?c ?Y =>
    constr_eq X Y;
    match find_dead_vars P c Q with
    | nil => fail 2 "deadvars!: Did not find any dead variables"
    | ?d =>  drop_LOCALs d
     end
 | |- semax _ _ _ _ =>
       fail 1 "deadvars!: Postcondition must be an abbreviated local definition (POSTCONDITION); try abbreviate_semax first"
 | |- _ => fail 1 "deadvars!: the proof goal should be a semax"
 end.


From iris.proofmode Require Import base tactics classes.
From Perennial.base_logic Require Import lib.own.
From iris.bi.lib Require Import fractional.
From Perennial.program_proof Require Import proof_prelude.
From Perennial.base_logic Require Export lib.ghost_map.
From iris.algebra Require Import excl agree auth gmap csum.

Section replica_ghost.

Definition one_shotR V := csumR (exclR unitR) (agreeR (leibnizO V)).

Class paxosG Σ (V : Type) := PaxosG {
  paxos_oneshotG :> inG Σ (one_shotR V);
  paxos_proposalG :> ghost_mapG Σ nat (option V);
  paxos_acceptG :> ghost_mapG Σ (nat*nat) (option bool);
}.

Context (f:nat).
Context {V:Type}.
Context `{!paxosG Σ V}.
Context `{!invGS Σ}.

Record single_names :=
{
  acc_gn: gname;
  pn_gn : gname;
  val_gn : gname;
}
.

Implicit Types γ:single_names.
Implicit Types (pn:nat).
Implicit Types (pid:nat).
Implicit Types c:V.

(*
  If entry ↦ c, then ∃ pn, pn ↦ c ∗ (committed pn).

  Want pn ↦ c ∗ pn' ↦ c' ∗ (committed pn) ∗ ⌜pn' > pn⌝ ={⊤}=∗ c = c'.

  Then, pn' ↦ c
*)

Definition undecided γ pid pn : iProp Σ :=
  (pn,pid) ↪[γ.(acc_gn)] None
.

Definition accepted γ pid pn : iProp Σ :=
  (pn,pid) ↪[γ.(acc_gn)]□ Some true
.

Definition rejected γ pid pn : iProp Σ :=
  (pn,pid) ↪[γ.(acc_gn)]□ Some false
.

Lemma do_accept γ pid pn :
  undecided γ pid pn ==∗ accepted γ pid pn.
Proof. (* Don't want auth again... *)
Admitted.

Definition is_valid (Q:gset nat) : Prop :=
  (∀ q, q ∈ Q → q < (2 * f + 1))
.

Definition is_majority (Q:gset nat) : Prop :=
  is_valid Q ∧
  size Q > f + 1.

Definition committed γ pn : iProp Σ :=
  ∃ (Q:gset nat),
    (∃ c, pn ↪[γ.(pn_gn)]□ Some c) ∗
    ⌜is_majority Q⌝ ∗
    [∗ set] pid ∈ Q, accepted γ pid pn
.

(* witness that all smaller pn that were committed must have command c *)
Definition pn_prop γ (pn:nat) c : iProp Σ :=
  □(
    ∀ (pn':nat),
      ⌜pn' ≤ pn⌝ →
      committed γ pn' -∗
      pn' ↪[γ.(pn_gn)]□ Some c (* NOTE: generalize this to knowledge that c is a superset of what was proposed earlier *)
    )
.

(* each witness for a proposal choice carries a witness that all smaller
proposals that were committed must match the value that this proposal chose *)
Definition pn_ptsto γ pn (c:V) : iProp Σ :=
  pn ↪[γ.(pn_gn)]□ Some c ∗
  pn_prop γ pn c
.

Lemma pn_ptsto_agree γ pn c c':
  pn_ptsto γ pn c -∗ pn_ptsto γ pn c' -∗ ⌜c = c'⌝.
Proof. (* Don't want auth again... *)
Admitted.

Definition pn_undec γ pn : iProp Σ :=
  pn ↪[γ.(pn_gn)] None
.

Definition cmd_undec γ : iProp Σ :=
  own γ.(val_gn) (Cinl (Excl ()))
.

Definition cmd_is γ c : iProp Σ :=
  own γ.(val_gn) (Cinr (to_agree (c:leibnizO V))) ∗
  (∃ pn, pn_ptsto γ pn c ∗ committed γ pn)
.

Definition consensus_inv γ : iProp Σ :=
  cmd_undec γ ∨
  (∃ c, cmd_is γ c).

Definition trivial_inv γ : iProp Σ :=
  ∃ (pnM:gmap nat (option V)),
  "HpnM" ∷ ghost_map_auth γ.(pn_gn) 1 pnM
.

Lemma key_fact1 N γ pn c :
  inv N (consensus_inv γ) -∗
  pn_ptsto γ pn c -∗
  committed γ pn ={⊤}=∗
  cmd_is γ c
.
Proof.
  iIntros "#Hcinv #Hptsto #Hcom".
  iInv "Hcinv" as "[>Hc|>#Hc]" "Hclose".
  { (* trivial; we get to take the fupd that decides the command *)
    iMod (own_update _ _ (Cinr (to_agree (c:leibnizO V))) with "[$Hc]") as "#Hcmd".
    {
      apply cmra_update_exclusive.
      done.
    }
    iFrame "Hcmd".
    iExists pn.
    iFrame "#".
    iMod ("Hclose" with "[]"); last done.
    iNext.
    iRight.
    iExists _; iFrame "#".
    iExists _; iFrame "#".
  }
  {
    (* want to match c0 with c; use pn_prop *)
    iDestruct "Hc" as (c') "Hc".
    iAssert (_) with "Hc" as "#Hcbackup".
    iDestruct "Hc" as "[#Hc' #Hpn]".

    iDestruct "Hpn" as (pn') "[#Hptsto' #Hcom']".

    assert (pn' ≤ pn ∨ pn < pn') as [Hineq|Hineq] by lia. (* cases *)
    {
      iDestruct "Hptsto" as "[Hptsto Hprop]".
      iDestruct ("Hprop" $! pn' with "[] Hcom'") as "Hptsto'2".
      { done. }
      Search "ghost_map".
      iDestruct "Hptsto'" as "[Hptsto' Hprop']".
      iDestruct (ghost_map_elem_agree with "Hptsto' Hptsto'2") as %Heq.
      replace (c) with (c') by naive_solver.
      iFrame "#".
      iMod ("Hclose" with "[]"); last done.
      iRight.
      iExists _; iFrame "#".
    }
    {
      iDestruct "Hptsto'" as "[Hptsto' Hprop']".
      iDestruct ("Hprop'" $! pn with "[] Hcom") as "Hptsto2".
      { iPureIntro. lia. }
      iDestruct "Hptsto" as "[Hptsto Hprop]".
      iDestruct (ghost_map_elem_agree with "Hptsto Hptsto2") as %Heq.
      replace (c) with (c') by naive_solver.
      iFrame "#".
      iMod ("Hclose" with "[]"); last done.
      iRight.
      iExists _; iFrame "#".
    }
  }
Qed.

(* Choosing proposals; this is where the real heavy-lifting will be *)
Lemma key_fact2 γ pn pn' c :
  pn_undec γ pn -∗
  pn_ptsto γ pn' c -∗
  □(∀ pn'', ⌜pn' < pn''⌝ → ⌜pn'' < pn⌝ → committed γ pn'' -∗ False) ==∗
  pn_ptsto γ pn c
.
Proof.
  iIntros "Hpn #Hptsto #Hrej".
  iMod (ghost_map_update (Some c) with "[] Hpn") as "[_ Hpn]".
  { admit. }
  iMod (ghost_map_elem_persist with "Hpn") as "#Hpn".
  iFrame "Hpn".

  iModIntro. iModIntro.
  unfold pn_prop.
  iIntros (pm' Hmineq) "Hcom'".
  (* case 1: pm' < pn' *)
  assert (pm' <= pn' ∨ pn' < pm') as [Hcase|Hcase] by lia.
  (* TODO: missing pm' = pn' case *)
  {
    iDestruct "Hptsto" as "[Hptsto Hprop]".
    iDestruct ("Hprop" with "[] Hcom'") as "$".
    { done. }
  }
  {
    assert (pm' = pn ∨ pm' < pn) as [Hcase2|Hcase2] by lia.
    { (* equality case; we already have ghost state for that *)
      rewrite Hcase2.
      iFrame "#".
    }

    iSpecialize ("Hrej" $! pm' with "[] [] Hcom'").
    { done. }
    { done. }
    done.
  }
Admitted. (* FIXME: don't use ghost_map, because we don't want an auth *)

End replica_ghost.


From stdpp Require Import base.
Require Import Monoids.

Class Mealy (state action out : Type) := {
  initial : state;
  step : state -> action -> state;
  output : state -> action -> out
}.

(** ** Auxiliary functions

We define a [run] of a machine [M], which is an extension of
the [step] function to lists of actions. We use a shortcut
[do_actions] for running the machine from the [initial] state. *)

Fixpoint run `{Mealy state action out} (s : state) (ls : list action) : state :=
  match ls with
    | nil => s
    | a::tl => run (step s a) tl
  end.

Definition do_actions `{Mealy state action out} : list action -> state := run initial.

(** The [test] function runs the required list of actions and examines the output of the resulting state on a specified action. *)
Definition test `{Mealy state action out} (ls : list action) : action -> out := output (do_actions ls).

Global Instance MealyMRet `{Monoid out op e} : MRet (λ A, (A * out)%type) :=
  fun A x => (x, e).
Global Instance MealyMBind `{Monoid out op e} : MBind (λ A, (A * out)%type) :=
  fun A B (f : A → B * out) (x : A * out) =>
    match x with
      (x₁,x₂) => match f x₁ with
                   (y₁,y₂) => (y₁, op x₂ y₂)
                 end
    end.
Global Instance MealyMonad `{Monoid out op e} `{Mealy state action out} :
  Monad (λ A, (A * out)%type).
Proof. split; intros;
unfold mret, mbind; unfold MealyMRet, MealyMBind.
destruct m. rewrite right_id; auto.
apply H. (* TODO: why is this not being picked up automatically? *)

destruct (f x). rewrite left_id; auto. apply H.

destruct m. destruct (f a). destruct (g b).
rewrite associative. reflexivity. apply H.
Qed.
About run.

Class MSync (state action out : Type)
  := {
  msync_mealy : Mealy state action out;
  delayed : action -> (state -> Prop);
  delayed_dec :> forall a s, Decision (delayed a s)
}.

Global Instance MSync_as_Mealy `{MS: MSync state action out}
  : Mealy state action (option out) :=
  { initial := @initial _ _ _ msync_mealy
  ; step := fun s a => if (decide (delayed a s))
                   then s
                   else @step _ _ _ msync_mealy s a
  ; output := fun s a => if (decide (delayed a s))
                   then None
                   else Some (@output _ _ _ msync_mealy s a)
  }.

Class MApi (domain : Type) (API : Type) (state action out : Type) :=
  { mapi_mealy : Mealy state action out
  ; domain_dec :> forall (x y : domain), Decision (x = y)
  ; dom_api : API -> domain
  ; sem_api : API -> list action
  }.

Definition upd `{MApi domain API s a o}
           (f : domain -> list a) a b :=
  fun d => if (decide (a = d)) then b else f d.

Global Instance MApi_as_Mealy `{MA: MApi domain API state action out}
  : Mealy (state * (domain -> list action)) API (option out)
  :=
  { initial := (@initial _ _ _ mapi_mealy, (λ _,[]))
  ; step := fun s a => let (s', f) := s
                       in let step' := @step _ _ _ mapi_mealy
                       in match (f (dom_api a)) with
                          | [] => (s', upd f (dom_api a) (sem_api a))
                          | (x::xs) => (step' s' x, upd f (dom_api a) xs)
                          end
  ; output := fun s a => let (s', f) := s
                         in let output' := @output _ _ _ mapi_mealy
                         in match (f (dom_api a)) with
                          | [] => None
                          | (x::xs) => Some (output' s' x)
                          end
  }.


Require Import floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.bdo_lemmas.
Local Open Scope nat.
Local Open Scope logic.

Lemma example1:  (* from rearrange_regs_proof *)
name _a ->
name _b ->
name _c ->
name _d ->
name _e ->
name _f ->
name _g ->
name _h ->
name _l ->
name _Ki ->
name _i ->
name _T1 ->
name _T2 ->
name _data ->
name _ctx ->
forall (i : nat) (data : val) (bl : list int) (ctx : val),
isptr data ->
length bl = LBLOCK ->
i < 16 ->
forall w : int,
nth_error bl i = Some w ->
forall k : int,
nth_error K256 i = Some k ->
forall regs' : registers,
let Delta' :=
  initialized _Ki (initialized _l (initialized _l' Delta_loop1)) in
PROP  ()
LOCAL  (tc_environ Delta'; `(eq ctx) (eval_id _ctx);
`(eq (offset_val (Int.repr (Z.succ (Z.of_nat i) * 4)) data)) (eval_id _data);
`(eq
    (Vint
       (big_endian_integer
          (fun z : Z =>
           force_int
             (ZnthV tuchar (map Vint (map Int.repr (intlist_to_Zlist bl)))
                (z + Z.of_nat i * 4)))))) (eval_id _l);
`(eq (nth_error K256 i)) (`Some (`force_int (eval_id _Ki)));
`(eq (Vint (Int.repr (Z.of_nat i)))) (eval_id _i);
`(eq (map Vint regs'))
  (`cons (eval_id _a)
     (`cons (eval_id _b)
        (`cons (eval_id _c)
           (`cons (eval_id _d)
              (`cons (eval_id _e)
                 (`cons (eval_id _f)
                    (`cons (eval_id _g) (`cons (eval_id _h) `[])))))))))
SEP()
|-- PROP  (exists a b c d e f g h : int, regs' = [a, b, c, d, e, f, g, h])
    LOCAL  (`(eq ctx) (eval_id _ctx);
    `(eq (offset_val (Int.repr (Z.succ (Z.of_nat i) * 4)) data))
      (eval_id _data); `(eq (Vint w)) (eval_id _l);
    `(eq (Vint k)) (eval_id _Ki);
    `(eq (Vint (Int.repr (Z.of_nat i)))) (eval_id _i);
    `(eq (map Vint regs'))
      (`cons (eval_id _a)
         (`cons (eval_id _b)
            (`cons (eval_id _c)
               (`cons (eval_id _d)
                  (`cons (eval_id _e)
                     (`cons (eval_id _f)
                        (`cons (eval_id _g) (`cons (eval_id _h) `[])))))))))
    SEP().
Proof.
intros; ungather_entail.
unfold Delta'; clear Delta'.
unfold Delta_loop1.
 simplify_Delta.
entailer!.
* do 8 (destruct regs' as [ | ? regs']; [inv H9 | ]);
     destruct regs'; inv H9;  repeat eexists; reflexivity.
* apply nth_big_endian_integer; auto .
* congruence.
Qed.


From Coq Require Import List Streams Nat Bool Lia FunctionalExtensionality FinFun Eqdep.
Import ListNotations.

From CasperCBC
Require Import Lib.StreamExtras Lib.ListExtras Lib.Preamble VLSM.Common VLSM.Composition.

(** * VLSM Projection Traces *)

Section ProjectionTraces.

Context
  {message : Type}
  {index : Type}
  {IndEqDec : EqDecision index}
  (IM : index -> VLSM message)
  {i0 : Inhabited index}
  (constraint : composite_label IM -> composite_state IM * option message -> Prop)
  (X := composite_vlsm IM constraint)
  (j : index)
  (Xj := composite_vlsm_constrained_projection IM constraint j)
  .

(** Extracted common functionality for both [finite_trace_projection_list]
    and [finite_trace_projection_list_alt]. *)
Definition composite_transition_item_projection_from_eq
  (item : composite_transition_item IM)
  (i := projT1 (l item))
  j
  (e : j = i)
  : vtransition_item (IM j)
  :=
  let lj := eq_rect_r _ (projT2 (l item)) e in
  @Build_transition_item _ (type (IM j)) lj (input item) (destination item j) (output item).

Definition composite_transition_item_projection
  (item : composite_transition_item IM)
  (i := projT1 (l item))
  : vtransition_item (IM i)
  :=
  composite_transition_item_projection_from_eq item i eq_refl.

Fixpoint finite_trace_projection_list
  (trx : list (composite_transition_item IM))
  : list (vtransition_item (IM j))
  :=
  match trx with
  | [] => []
  | item :: trx =>
    let tail := finite_trace_projection_list trx in
    match decide (j = (projT1 (l item))) with
    | left e => composite_transition_item_projection_from_eq item j e :: tail
    | _ => tail
    end
  end.

Definition from_projection
  (a : composite_transition_item IM)
  : Prop
  := j = projT1 (l a).

Instance dec_from_projection (a : transition_item) : Decision (from_projection a) :=
  decide (from_projection a).

Definition finite_trace_projection_list_alt
  (trx : list (composite_transition_item IM))
  (ftrx := (filter (fun a => bool_decide (from_projection a)) trx))
  (Hall: Forall from_projection ftrx)
  :=
  List.map
    (fun item : {a : composite_transition_item IM | from_projection a} =>
      let (item, e) := item in
      let lj := eq_rect_r _ (projT2 (l item)) e in
      @Build_transition_item _ (type (IM j))
        lj
        (input item)
        (destination item j)
        (output item)
    )
  (list_annotate from_projection ftrx Hall).

Lemma finite_trace_projection_list_alt_iff
  (trx : list (composite_transition_item IM))
  (ftrx := (filter (fun a => bool_decide (from_projection a)) trx))
  (Hall: Forall from_projection ftrx)
  : finite_trace_projection_list_alt trx Hall = finite_trace_projection_list trx.
Proof.
  unfold ftrx in *. clear ftrx.
  generalize dependent Hall.
  induction trx; intros; try reflexivity.
  simpl.
  destruct
    (decide (j =
    (@projT1 index (fun n : index => @vlabel message (IM n))
       (@l message (@composite_type message index IM) a))))
    eqn:Heq.
  - assert
    (Hunroll :
      filter (fun a => bool_decide (from_projection a)) (a :: trx)
      = a :: filter (fun a => bool_decide (from_projection a)) trx
    ).
    { simpl.
      unfold bool_decide, dec_from_projection, from_projection.
      replace
        (decide (j =
        (@projT1 index (fun n : index => @vlabel message (IM n))
           (@l message (@type message X) a))))
      with
        (@left
           (@eq index j
              (@projT1 index (fun n : index => @vlabel message (IM n))
                 (@l message (@composite_type message index IM) a)))
           (not
              (@eq index j
                 (@projT1 index (fun n : index => @vlabel message (IM n))
                    (@l message (@composite_type message index IM) a)))) e)
      .
      reflexivity.
    }
    unfold finite_trace_projection_list_alt.
    generalize dependent Hall.
    rewrite Hunroll.
    intro Hall.
    rewrite list_annotate_unroll.
    specialize (IHtrx (Forall_tl Hall)).
    rewrite <- IHtrx.
    simpl.
    f_equal.
    f_equal; try reflexivity.
    replace (Forall_hd Hall) with e; try reflexivity.
    apply UIP.
  - assert
    (Hunroll :
      filter (fun a => bool_decide (from_projection a)) (a :: trx)
      = filter (fun a => bool_decide (from_projection a)) trx
    ).
    { simpl.
      unfold bool_decide, dec_from_projection, from_projection.
      replace
        (decide (j =
        (@projT1 index (fun n0 : index => @vlabel message (IM n0))
           (@l message (@type message X) a))))
      with
        (@right
          (@eq index j
             (@projT1 index (fun n : index => @vlabel message (IM n))
                (@l message (@composite_type message index IM) a)))
          (not
             (@eq index j
                (@projT1 index (fun n : index => @vlabel message (IM n))
                   (@l message (@composite_type message index IM) a)))) n)
        .
      reflexivity.
    }
    unfold finite_trace_projection_list_alt.
    generalize dependent Hall.
    rewrite Hunroll.
    intro Hall.
    specialize (IHtrx Hall).
    rewrite <- IHtrx.
    reflexivity.
Qed.

Lemma finite_trace_projection_empty
  (s : vstate X)
  (trx : list (vtransition_item X))
  (Htr : finite_protocol_trace_from X s trx)
  (Hempty : finite_trace_projection_list trx = [])
  (t : (vtransition_item X))
  (Hin : In t trx)
  : destination t j = s j.
Proof.
  generalize dependent t.
  induction Htr; simpl; intros t Hin.
  - inversion Hin.
  - destruct l as [i l].
    destruct H as [[[_om Hs'] [[_s Hiom] Hvalid]] Htransition].
    unfold transition in Htransition; simpl in Htransition.
    destruct (vtransition (IM i) l (s' i, iom)) as [si' om'] eqn:Hteq.
    inversion Htransition; subst. clear Htransition.
    destruct Hin as [Heq | Hin]; subst; simpl in *; destruct (decide (j = i)).
    + inversion Hempty.
    + apply state_update_neq. assumption.
    + inversion Hempty.
    + specialize (IHHtr Hempty t Hin). rewrite IHHtr.
      apply state_update_neq. assumption.
Qed.

Lemma finite_trace_projection_list_app
  (tr1 tr2 : list (composite_transition_item IM))
  : finite_trace_projection_list (tr1 ++ tr2) =
    finite_trace_projection_list tr1 ++ finite_trace_projection_list tr2.
Proof.
  induction tr1;[reflexivity|].
  simpl.
  match goal with
  |- context [decide ?d] => destruct (decide d)
  end
  ; [|assumption].
  simpl. rewrite IHtr1. reflexivity.
Qed.

Lemma preloaded_finite_trace_projection_last_state
  (start : vstate X)
  (transitions : list (vtransition_item X))
  (Htr : finite_protocol_trace_from (pre_loaded_with_all_messages_vlsm X) start transitions)
  (lstx := finite_trace_last start transitions)
  (lstj := finite_trace_last (start j) (finite_trace_projection_list transitions))
  : lstj = lstx j.
Proof.
  unfold lstx. unfold lstj. clear lstx. clear lstj.
  induction Htr; try reflexivity.
  destruct l as [i l].
  rewrite finite_trace_last_cons.
  simpl.
  destruct (decide (j = i)).
  - rewrite finite_trace_last_cons.
    simpl.
    assumption.
  - replace (s' j) with (s j). assumption.
    destruct H as [[[_om Hs'] [[_s Hiom] Hvalid]] Htransition].
    cbn in Htransition.
    destruct (vtransition (IM i) l (s' i, iom)) as [si' om'] eqn:Hteq.
    inversion Htransition; subst. clear Htransition.
    apply state_update_neq.
    assumption.
Qed.

Lemma finite_trace_projection_last_state
  (start : vstate X)
  (transitions : list (vtransition_item X))
  (Htr : finite_protocol_trace_from X start transitions)
  (lstx := finite_trace_last start transitions)
  (lstj := finite_trace_last (start j) (finite_trace_projection_list transitions))
  : lstj = lstx j.
Proof.
  apply preloaded_finite_trace_projection_last_state.
  apply VLSM_incl_finite_protocol_trace_from; [|assumption].
  apply vlsm_incl_pre_loaded_with_all_messages_vlsm.
Qed.

Local Lemma _finite_ptrace_projection
  (s : vstate X)
  (Psj : protocol_state_prop Xj (s j))
  (trx : list (vtransition_item X))
  (Htr : finite_protocol_trace_from X s trx)
   : finite_protocol_trace_from Xj (s j) (finite_trace_projection_list trx).
Proof.
  induction Htr.
  - constructor. assumption.
  - destruct l as [x lx]; simpl.
    destruct H as [[Ps' [Piom [Hv Hc]]] Ht].
    assert (Hpp : protocol_prop X (s, oom)).
    { rewrite <- Ht. destruct Ps' as [_om Ps']. destruct Piom as [_s Piom].
      apply protocol_generated with _om _s; try assumption. split; assumption.
    }
    assert (Hps : protocol_state_prop X s) by (exists oom; assumption).
    destruct (decide (j = x)).
    + subst x.
      simpl in Ht.
      destruct (vtransition (IM j) lx (s' j, iom)) as [si' om'] eqn:Hteq.
      inversion Ht; subst. unfold composite_transition_item_projection_from_eq.
      simpl.
      rewrite state_update_eq in *.
      simpl in Hv.
      apply (finite_ptrace_extend Xj).
      * apply IHHtr.
        exists oom.
        replace (@pair (@state message (@type message Xj)) (option message) si' oom)
          with (vtransition (IM j) lx (s' j, iom)).
        destruct Psj as [os'j Psj].
        specialize (protocol_message_projection IM constraint j _ Piom); intros [sj HPjiom].
        apply (protocol_generated Xj lx (s' j) os'j Psj sj iom HPjiom).
        unfold valid; simpl.
        exists s'.
        split; try reflexivity.
        split; try assumption.
        split; try assumption.
        destruct iom as [im|]
        ; repeat split; assumption.
      * assert
          (Heqlx :
            (@eq_rect_r index j (fun n : index => vlabel (IM n)) lx j (@eq_refl index j))
            = lx
          ) by reflexivity.
        rewrite Heqlx.
        specialize (protocol_message_projection IM constraint j _ Piom); intros HPjiom.
        repeat split; try assumption.
        exists s'.
        repeat split; assumption.
    + simpl in Ht. destruct (vtransition (IM x) lx (s' x, iom)) eqn:Hteq.
      inversion Ht; subst.
      rewrite state_update_neq in IHHtr; try assumption.
      apply IHHtr.
      assumption.
Qed.

Lemma protocol_state_projection
  (s : state)
  (Hps : protocol_state_prop X s)
  : protocol_state_prop Xj (s j).
Proof.
  apply protocol_state_has_trace in Hps.
  destruct Hps as [is [tr [Htr Hinit]]].
  pose proof (ptrace_get_last Htr) as Hlast.
  apply ptrace_forget_last in Htr.
  specialize (finite_trace_projection_last_state _ _ Htr) as Hlst.
  apply _finite_ptrace_projection in Htr as Hptr.
  - apply finite_ptrace_last_pstate in Hptr.
    simpl in *.
    congruence.
  - apply initial_is_protocol. apply (Hinit j).
Qed.

(* The projection of a finite protocol trace remains a protocol trace *)

Lemma finite_ptrace_projection
  (s : vstate X)
  (trx : list (vtransition_item X))
  (Htr : finite_protocol_trace_from X s trx)
   : finite_protocol_trace_from Xj (s j) (finite_trace_projection_list trx).
Proof.
  apply _finite_ptrace_projection; [|assumption].
  apply protocol_state_projection.
  apply finite_ptrace_first_pstate in Htr.
  assumption.
Qed.

(* The projection of a preloaded finite protocol trace remains a preloaded protocol trace *)

Lemma _preloaded_finite_ptrace_projection
  (s : vstate X)
  (Psj : protocol_state_prop (pre_loaded_with_all_messages_vlsm (IM j)) (s j))
  (trx : list (vtransition_item X))
  (Htr : finite_protocol_trace_from (pre_loaded_with_all_messages_vlsm X) s trx)
   : finite_protocol_trace_from (pre_loaded_with_all_messages_vlsm (IM j)) (s j) (finite_trace_projection_list trx).
Proof.
  induction Htr.
  - constructor. assumption.
  - destruct l as [x lx]; simpl.
    destruct H as [[Ps' [Piom [Hv Hc]]] Ht].
    assert (Hpp : protocol_prop (pre_loaded_with_all_messages_vlsm X) (s, oom)).
    { rewrite <- Ht. destruct Ps' as [_om Ps']. destruct Piom as [_s Piom].
      apply protocol_generated with _om _s; try assumption. split; assumption.
    }
    assert (Hps : protocol_state_prop (pre_loaded_with_all_messages_vlsm X) s) by (exists oom; assumption).
    destruct (decide (j = x)).
    + subst x.
      unfold vtransition in Ht. simpl in Ht.
      unfold vtransition in Ht. simpl in Ht.
      destruct (vtransition (IM j) lx (s' j, iom)) as [si' om'] eqn:Hteq.
      inversion Ht; subst.
      unfold composite_transition_item_projection_from_eq. simpl.
      rewrite state_update_eq in *.
      simpl in Hv.
      apply (finite_ptrace_extend (pre_loaded_with_all_messages_vlsm (IM j))).
      * apply IHHtr.
        exists oom.

        replace
          (@pair
            (@state message
              (@type message (@pre_loaded_with_all_messages_vlsm message (IM j))))
            (option message)
            si' oom)
          with (vtransition (IM j) lx (s' j, iom)).
        destruct Psj as [os'j Psj].
        specialize (protocol_generated (pre_loaded_with_all_messages_vlsm (IM j)) lx (s' j) os'j Psj)
          as Hgen.
        specialize (Hgen (proj1_sig (vs0 (IM j))) iom).
        spec Hgen; [apply (pre_loaded_with_all_messages_message_protocol_prop (IM j))|].
        spec Hgen; [| apply Hgen].
        assumption.
      * assert
          (Heqlx :
            (@eq_rect_r index j (fun n : index => vlabel (IM n)) lx j (@eq_refl index j))
            = lx
          ) by reflexivity.
        rewrite Heqlx.
        split; [|assumption].
        split; [assumption|].
        split; [|assumption].
        exists (proj1_sig (vs0 (IM j))).
        apply (pre_loaded_with_all_messages_message_protocol_prop (IM j)).
    + simpl in Ht. unfold vtransition in Ht.
      simpl in Ht.
      destruct (vtransition (IM x) lx (s' x, iom)) eqn:Hteq.
      inversion Ht; subst.
      rewrite state_update_neq in IHHtr by assumption.
      apply IHHtr.
      assumption.
Qed.

Lemma preloaded_protocol_state_projection
  (s : state)
  (Hps : protocol_state_prop (pre_loaded_with_all_messages_vlsm X) s)
  : protocol_state_prop (pre_loaded_with_all_messages_vlsm (IM j)) (s j).
Proof.
  apply protocol_state_has_trace in Hps.
  destruct Hps as [is [tr [Htr His]]].
  pose proof (ptrace_get_last Htr).
  apply ptrace_forget_last in Htr.
  specialize (preloaded_finite_trace_projection_last_state _ _ Htr) as Hlst.
  apply _preloaded_finite_ptrace_projection in Htr as Hptr.
  - apply finite_ptrace_last_pstate in Hptr.
    simpl in *.
    congruence.
  - apply initial_is_protocol. specialize (His j). assumption.
Qed.

Lemma preloaded_finite_ptrace_projection
  (s : vstate X)
  (trx : list (vtransition_item X))
  (Htr : finite_protocol_trace_from (pre_loaded_with_all_messages_vlsm X) s trx)
   : finite_protocol_trace_from (pre_loaded_with_all_messages_vlsm (IM j)) (s j) (finite_trace_projection_list trx).
Proof.
  apply _preloaded_finite_ptrace_projection; [|assumption].
  apply preloaded_protocol_state_projection.
  apply finite_ptrace_first_pstate in Htr.
  assumption.
Qed.

Lemma in_futures_projection
  (s1 s2 : state)
  (Hfutures : in_futures X s1 s2)
  : in_futures Xj (s1 j) (s2 j).
Proof.
  destruct Hfutures as [tr Htr].
  pose proof (ptrace_get_last Htr) as Hs2.
  apply ptrace_forget_last in Htr.
  specialize (finite_ptrace_projection s1 tr Htr); intros Htrj.
  exists (finite_trace_projection_list tr).
  apply ptrace_add_last;[assumption|].
  subst s2.
  apply finite_trace_projection_last_state.
  assumption.
Qed.

Definition in_projection
   (tr : Stream (composite_transition_item IM))
   (n : nat)
   := from_projection (Str_nth n tr).

Definition in_projection_dec
  := forall (tr : Stream (composite_transition_item IM)),
       bounding (in_projection tr)
       + { ss : monotone_nat_stream
         | filtering_subsequence from_projection tr ss
         }.

Definition infinite_trace_projection_stream
  (ss: Stream (composite_transition_item IM))
  (ks: monotone_nat_stream)
  (Hfilter: filtering_subsequence from_projection ss ks)
  : Stream (vtransition_item (IM j))
  :=
  let subs := stream_subsequence ss ks in
  let HForAll := stream_filter_Forall from_projection ss ks Hfilter in
  let subsP := stream_annotate from_projection subs HForAll in
  Streams.map
    (fun item : {a : vtransition_item X | from_projection a} =>
      let (item, e) := item in
      let lj := eq_rect_r _ (projT2 (l item)) e in
      @Build_transition_item _ (type Xj) lj (input item) (destination item j) (output item)
    )
    subsP.

Lemma finite_trace_projection_stream
  (ss: Stream (composite_transition_item IM))
  (ks: monotone_nat_stream)
  (Hfilter: filtering_subsequence from_projection ss ks)
  (n : nat)
  (kn := Str_nth n (proj1_sig ks))
  (ss_to_kn := stream_prefix ss (succ kn))
  (sproj := infinite_trace_projection_stream ss ks Hfilter)
  : stream_prefix sproj (succ n) = finite_trace_projection_list ss_to_kn.
Proof.
  unfold sproj. unfold infinite_trace_projection_stream.
  rewrite <- stream_prefix_map.
  specialize
    (stream_prefix_annotate
      from_projection
      (stream_subsequence ss ks)
      (stream_filter_Forall from_projection ss ks Hfilter)
      (succ n)
    ); intros [Hall Heq].
  clear -Heq.
  match goal with
  |- List.map _ ?s = _ => replace s with
      (list_annotate from_projection (stream_prefix (stream_subsequence ss ks) (succ n)) Hall)
  end.
  specialize
    (stream_filter_prefix
       ss
       ks
       Hfilter
       n
    ); intros Hsfilter.
  remember stream_prefix as sp.
  simpl in Hsfilter. subst.
  unfold succ in *.
  generalize dependent Hall.
  rewrite Hsfilter.
  intros.
  unfold ss_to_kn. unfold kn.
  apply finite_trace_projection_list_alt_iff.
Qed.

Definition trace_projection
  (Hproj_dec : in_projection_dec)
  (tr : vTrace X)
  : vTrace (IM j).
Proof.
  destruct tr as [s ls | s ss].
  - exact (Finite (s j) (finite_trace_projection_list ls)).
  - specialize (Hproj_dec ss).
    destruct Hproj_dec as [[n1 _] | [ks Hfilter]].
    + exact (Finite (s j) (finite_trace_projection_list (stream_prefix ss n1))).
    + exact (Infinite (s j) (infinite_trace_projection_stream ss ks Hfilter)).
Defined.

Lemma trace_projection_initial_state
  (Hproj_dec : in_projection_dec)
  (tr : vTrace X)
  : trace_first (trace_projection Hproj_dec tr)
  = trace_first tr j.
Proof.
  destruct tr; try reflexivity.
  simpl.
  destruct (Hproj_dec s0).
  - destruct b; reflexivity.
  - destruct s1; reflexivity.
Qed.

Lemma infinite_ptrace_projection
  (s: vstate X)
  (ss: Stream transition_item)
  (Psj: protocol_state_prop Xj (s j))
  (Htr: infinite_protocol_trace_from X s ss)
  (fs : monotone_nat_stream)
  (Hfs: filtering_subsequence from_projection ss fs)
  : infinite_protocol_trace_from Xj (s j) (infinite_trace_projection_stream ss fs Hfs).
Proof.
  apply infinite_protocol_trace_from_prefix_rev.
  specialize (infinite_protocol_trace_from_prefix X s ss Htr); intro Hftr.
  intros [| n].
  - constructor. assumption.
  - rewrite finite_trace_projection_stream.
    apply finite_ptrace_projection; try assumption.
    apply Hftr.
Qed.

(* The projection of an protocol trace remains a protocol trace *)

Lemma ptrace_from_projection
  (Hproj_dec : in_projection_dec)
  (tr : vTrace X)
  (Psj : protocol_state_prop Xj (trace_first tr j))
  (Htr : ptrace_from_prop X tr)
   : ptrace_from_prop Xj (trace_projection Hproj_dec tr).
Proof.
  destruct tr as [s ls | s ss].
  - apply finite_ptrace_projection; assumption.
  - simpl. destruct (Hproj_dec ss) as [[n _]|Hinf].
    + apply finite_ptrace_projection; try assumption.
      apply infinite_protocol_trace_from_prefix. assumption.
    + destruct Hinf as [ks HFilter].
      apply infinite_ptrace_projection; assumption.
Qed.

Lemma protocol_trace_projection
  (Hproj_dec : in_projection_dec)
  (tr : vTrace X)
  (Htr : protocol_trace_prop X tr)
  : protocol_trace_prop Xj (trace_projection Hproj_dec tr).
Proof.
  assert (Hfrom := protocol_trace_from X tr Htr).
  assert (Hinit := protocol_trace_initial X tr Htr).
  apply protocol_trace_from_iff.
  split.
  - apply ptrace_from_projection; try assumption.
    apply protocol_state_prop_iff.
    left.
    apply (initial_state_projection IM constraint j) in Hinit.
    exists (exist _ _ Hinit).
    reflexivity.
  - rewrite trace_projection_initial_state.
    apply initial_state_projection.
    assumption.
Qed.

(* We axiomatize projection friendliness as the converse of protocol_trace_projection *)
Definition finite_projection_friendly
  := forall
    (sj : vstate (IM j))
    (trj : list (vtransition_item (IM j)))
    (Htrj : finite_protocol_trace Xj sj trj),
    exists (sx : vstate X) (trx : list (vtransition_item X)),
      finite_protocol_trace X sx trx
      /\ sx j = sj
      /\ finite_trace_projection_list trx = trj.

Definition projection_friendly
  (Hproj_dec : in_projection_dec)
  := forall
  (trj : vTrace (IM j))
  (Htrj : protocol_trace_prop Xj trj),
  exists (tr : vTrace X),
    protocol_trace_prop X tr
    /\ trace_projection Hproj_dec tr = trj.

Lemma projection_friendly_finite
  (Hproj_dec : in_projection_dec)
  (Hfr : projection_friendly Hproj_dec)
  : finite_projection_friendly.
Proof.
  unfold finite_projection_friendly;  intros.
  specialize (Hfr (Finite sj trj) Htrj).
  destruct Hfr as [[s tr| s tr] [Htr Heq]].
  + exists s. exists tr.
    split; try assumption.
    unfold trace_projection in Heq.
    inversion Heq.
    split; reflexivity.
  + unfold trace_projection in Heq.
    destruct (Hproj_dec tr) as [[n1 _] | (ks, Hfilter)]; inversion Heq.
    subst; clear Heq.
    exists s. exists (stream_prefix tr n1).
    destruct Htr as [Htr Hinit].
    repeat split; try reflexivity; try assumption.
    apply infinite_protocol_trace_from_prefix.
    assumption.
Qed.

Lemma projection_friendly_in_futures'
  (sx: state)
  (trx: list transition_item)
  (Htrx: finite_protocol_trace X sx trx)
  (sj: state)
  (Hsx: sx j = sj)
  (Hall: Forall from_projection
         (filter (fun a => bool_decide (from_projection a)) trx))
  (s1 s2: state)
  (n1 n2: nat)
  (Hle: n1 <= n2)
  (Hs1: finite_trace_nth sj (finite_trace_projection_list_alt trx Hall)
        n1 = Some s1)
  (Hs2: finite_trace_nth sj (finite_trace_projection_list_alt trx Hall)
        n2 = Some s2)
  : exists sX1 sX2 : vstate X, sX1 j = s1 /\ sX2 j = s2 /\ in_futures X sX1 sX2.
Proof.
    assert
      (HsX1 :
        exists (nX1 nX2 : nat) (sX1 sX2 : vstate X),
          nX1 <= nX2 /\ sX1 j = s1 /\ sX2 j = s2
          /\ finite_trace_nth sx trx nX1 = Some sX1
          /\ finite_trace_nth sx trx nX2 = Some sX2
      ).
    {
      destruct n1; destruct n2.
      - exists 0; exists 0; exists sx; exists sx
        ; inversion Hs1; inversion Hs2; subst; repeat split; assumption.
      - exists 0; inversion Hs1; clear Hs1; subst.
        unfold finite_trace_nth in Hs2.
        simpl in Hs2.
        rewrite nth_error_map in Hs2.
        unfold finite_trace_projection_list_alt in Hs2.
        rewrite nth_error_map in Hs2.
        specialize
          (nth_error_list_annotate
            from_projection
            (filter (fun a => bool_decide (from_projection a)) trx)
            Hall
            n2
          ); intros [oitem [Hoa Hnth]].
        match type of Hs2 with
        | option_map _ (option_map _ ?n) = _ => replace n with oitem in Hs2
        end.
        clear Hoa.
        destruct oitem as [[item Hitem]|]; try inversion Hs2; subst; clear Hs2.
        simpl in Hnth.
        symmetry in Hnth.
        apply nth_error_filter in Hnth.
        destruct Hnth as [nX2 [Hindex Hnth]].
        exists (S nX2).
        exists sx.
        exists (destination item).
        repeat split.
        + lia.
        + unfold finite_trace_nth.
          simpl. rewrite nth_error_map.
          replace
            (@nth_error (@transition_item message (@composite_type message index IM)) trx nX2)
            with (Some item).
          reflexivity.
      - inversion Hle.
      - unfold finite_trace_nth in Hs1, Hs2.
        simpl in Hs1. simpl in Hs2.
        rewrite nth_error_map in Hs1.
        rewrite nth_error_map in Hs2.
        unfold finite_trace_projection_list_alt in Hs1.
        unfold finite_trace_projection_list_alt in Hs2.
        rewrite nth_error_map in Hs1.
        rewrite nth_error_map in Hs2.
        specialize
          (nth_error_list_annotate
            from_projection
            (filter (fun a => bool_decide (from_projection a)) trx)
            Hall
            n2
          ); intros [oitem2 [Hoa2 Hn2th]].
        specialize
          (nth_error_list_annotate
            from_projection
            (filter (fun a => bool_decide (from_projection a)) trx)
            Hall
            n1
          ); intros [oitem1 [Hoa1 Hn1th]].
        match type of Hs2 with
        | option_map _ (option_map _ ?n) = _ => replace n with oitem2 in Hs2
        end.
        match type of Hs1 with
        | option_map _ (option_map _ ?n) = _ => replace n with oitem1 in Hs1
        end.
        clear Hoa1.
        destruct oitem2 as [[item2 Hitem2]|]; try inversion Hs2; subst; clear Hs2.
        destruct oitem1 as [[item1 Hitem1]|]; try inversion Hs1; subst; clear Hs1.
        simpl in Hn1th.
        simpl in Hn2th.
        symmetry in Hn1th.
        symmetry in Hn2th.
        apply nth_error_filter in Hn1th.
        apply nth_error_filter in Hn2th.
        destruct Hn2th as [nX2 [Hindex2 Hn2th]].
        destruct Hn1th as [nX1 [Hindex1 Hn1th]].
        exists (S nX1).
        exists (S nX2).
        exists (destination item1).
        exists (destination item2).
        repeat split; try assumption.
        + assert (Hle' : n1 <= n2) by lia.
          specialize (nth_error_filter_index_le _ _ _ _ Hle' _ _ Hindex1 Hindex2).
          intro; lia.
        + unfold finite_trace_nth.
          simpl. rewrite nth_error_map.
          replace (@nth_error (@transition_item message (@composite_type message index IM)) trx nX1)
            with (Some item1).
          reflexivity.
        + unfold finite_trace_nth.
          simpl. rewrite nth_error_map.
          replace (@nth_error (@transition_item message (@composite_type message index IM)) trx nX2)
            with (Some item2).
          reflexivity.
    }
    destruct HsX1 as [nX1 [nX2 [sX1 [sX2 [HleX [Hps1 [Hps2 [HsX1 HsX2]]]]]]]].
    exists sX1. exists sX2. repeat split; try assumption.
    specialize (in_futures_witness_reverse X sX1 sX2 (exist (protocol_trace_prop X) (Finite sx trx) Htrx) nX1 nX2 HleX HsX1 HsX2).
    intros; assumption.
Qed.

Lemma projection_friendly_in_futures
  (Hfr : finite_projection_friendly)
  (s1 s2 : vstate (IM j))
  (Hfuture : in_futures Xj s1 s2)
  : exists (sX1 sX2 : vstate X),
    sX1 j = s1 /\ sX2 j = s2 /\ in_futures X sX1 sX2.
Proof.
  specialize (in_futures_witness Xj s1 s2 Hfuture)
  ; intros [trj [n1 [n2 [Hle [Hs1 Hs2]]]]].
  clear Hfuture.
  destruct trj as [trj Htrj].
  specialize (trace_prefix_fn_protocol Xj trj Htrj n2); intros Hpref.
  remember (trace_prefix_fn Xj trj n2) as trj2.
  destruct trj2 as [sj' lj' | sj' lj']; destruct trj as [sj lj | sj lj]
  ; inversion Heqtrj2
  ; subst sj' lj'.
  - specialize (Hfr sj (list_prefix lj n2) Hpref).
    destruct Hfr as [sx [trx [Htrx [Hsx Hproj]]]].
    assert (Hall : Forall from_projection
              (filter (fun a => bool_decide (from_projection a)) trx))
      by apply filter_Forall.
    specialize (finite_trace_projection_list_alt_iff trx Hall); intro Heq.
    rewrite <- Heq in Hproj.
    simpl in Hs1.
    simpl in Hs2.
    assert
      (Hs1' :
        finite_trace_nth sj lj n1 =
        finite_trace_nth sj (list_prefix lj n2) n1
      ).
    {
      rewrite <- (list_prefix_suffix lj n2) at 1.
      rewrite finite_trace_nth_app1. reflexivity.
      rewrite list_prefix_length. assumption.
      apply finite_trace_nth_length in Hs2. assumption.
    }
    assert
      (Hs2' :
        finite_trace_nth sj lj n2 =
        finite_trace_nth sj (list_prefix lj n2) n2
      ).
    {
      rewrite <- (list_prefix_suffix lj n2) at 1.
      rewrite finite_trace_nth_app1. reflexivity.
      rewrite list_prefix_length. reflexivity.
      apply finite_trace_nth_length in Hs2. assumption.
    }
    apply projection_friendly_in_futures' with sx trx sj Hall n1 n2; try assumption
    ; rewrite Hproj.
    + rewrite <- Hs1. symmetry. assumption.
    + rewrite <- Hs2. symmetry. assumption.
  - specialize (Hfr sj (stream_prefix lj n2) Hpref).
    destruct Hfr as [sx [trx [Htrx [Hsx Hproj]]]].
    assert (Hall : Forall from_projection
              (filter (fun a => bool_decide (from_projection a)) trx))
      by apply filter_Forall.
    specialize (finite_trace_projection_list_alt_iff trx Hall); intro Heq.
    rewrite <- Heq in Hproj.
    simpl in Hs1.
    simpl in Hs2.
    assert
      (Hs1' :
        Some (Str_nth n1 (Cons sj (map destination lj))) =
        nth_error (sj :: List.map destination (stream_prefix lj n2)) n1
      ).
    { destruct n1; try reflexivity. simpl.
      rewrite stream_prefix_map.
      rewrite stream_prefix_nth; try assumption.
      reflexivity.
    }
    assert
      (Hs2' :
      Some (Str_nth n2 (Cons sj (map destination lj))) =
        nth_error (sj :: List.map destination (stream_prefix lj n2)) n2
      ).
    { destruct n2; try reflexivity.
      rewrite stream_prefix_map.
      remember (S n2) as sn2. rewrite Heqsn2 at 3.
      simpl.
      rewrite stream_prefix_nth; subst; constructor.
    }
    apply projection_friendly_in_futures' with sx trx sj Hall n1 n2; try assumption
    ; rewrite Hproj; rewrite <- Hs1 || rewrite <- Hs2; symmetry; assumption.
Qed.

Lemma projection_valid_protocol
  (l : vlabel Xj)
  (som : vstate Xj * option message)
  (Hv : vvalid Xj l som)
  : protocol_valid Xj l som.
Proof.
  destruct som as (s, om).
  destruct (id Hv) as [sX [Hsi [Hps [Hopm _]]]].
  repeat split.
  - subst. apply protocol_state_projection. assumption.
  - apply protocol_message_projection. assumption.
  - assumption.
Qed.

End ProjectionTraces.

Section ProjectionTraces_membership.

Context
  {message : Type}
  {index : Type}
  {IndEqDec : EqDecision index}
  (IM : index -> VLSM message)
  {i0 : Inhabited index}
  (constraint : composite_label IM -> composite_state IM * option message -> Prop)
  (X := composite_vlsm IM constraint)
  .

Lemma finite_trace_projection_list_in
  (tr : list (vtransition_item X))
  (itemX : vtransition_item X)
  (HitemX : In itemX tr)
  (j := projT1 (l itemX))
  : In (@Build_transition_item _ (type (IM j)) (projT2 (l itemX)) (input itemX) (destination itemX j) (output itemX)) (finite_trace_projection_list IM j tr).
Proof.
  induction tr; [inversion HitemX|].
  destruct HitemX as [HitemX | HitemX].
  - simpl. subst a. unfold j in *. clear j.
    match goal with
    |- context [decide ?eq] => destruct (decide eq)
    end
    ; [| elim n; reflexivity].
    left.
    f_equal.
    replace e with (@eq_refl index (projT1 (l itemX))) by apply UIP.
    reflexivity.
  - spec IHtr HitemX.
    simpl.
    match goal with
    |- context [decide ?eq] => destruct (decide eq)
    end
    ;[|assumption].
    right. assumption.
Qed.

Lemma finite_trace_projection_list_in_rev
  (tr : list (composite_transition_item IM))
  (j : index)
  (itemj : vtransition_item (IM j))
  (Hitemj : In itemj  (finite_trace_projection_list IM j tr))
  : exists
    (itemX : composite_transition_item IM)
    (Houtput : output itemX = output itemj)
    (Hinput : input itemX = input itemj)
    (Hl1 : j = projT1 (l itemX))
    (Hl2 : eq_rect_r _ (projT2 (l itemX)) Hl1 = l itemj)
    (Hdestination : destination itemX j = destination itemj),
    In itemX tr.
Proof.
  induction tr; [contradict Hitemj|].
  simpl in Hitemj.
  match type of Hitemj with
  | context [decide ?eq] => destruct (decide eq)
  end.
  - destruct Hitemj as [Hitemj | Hitemj].
    + subst itemj. simpl. exists a. exists eq_refl. exists eq_refl. exists e.
      exists eq_refl. exists eq_refl. left. reflexivity.
    + spec IHtr Hitemj.
      destruct IHtr as [itemX [Houtput [Hinput [Hl1 [Hl2 [Hdestination HitemX]]]]]].
      exists itemX. repeat split; [assumption| assumption |].
      exists Hl1. exists Hl2. exists Hdestination. right. assumption.
  - spec IHtr Hitemj.
    destruct IHtr as [itemX [Houtput [Hinput [Hl1 [Hl2 [Hdestination HitemX]]]]]].
    exists itemX. repeat split; [assumption| assumption |].
    exists Hl1. exists Hl2. exists Hdestination. right. assumption.
Qed.

End ProjectionTraces_membership.


From isla Require Import opsem.

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