Require Import DataTypes StoreAtomicity Case NamedTrans Useful AtomicRegIfc.

Set Implicit Arguments.

Ltac destructAll :=
  match goal with
    | [|- context [match ?P with _ => _ end] ] => destruct P
    | [_:context [match ?P with _ => _ end] |- _] => destruct P
  end.

Section ForAddr.
  Variable reqFn: Addr -> Cache -> Index -> Req.
  Variable respFn: Time -> option Resp.

  Variable sa: StoreAtomicity reqFn respFn.

  Definition AtomicList := TransList (AtomicTrans reqFn) (Build_State initData (fun a t => 0)).

  Definition getTransNext n s (al: AtomicList n s) :=
    match respFn n with
      | Some r => Build_NextTrans _ _ _ (AReq reqFn s (addrR r) (procR r))
      | None => Build_NextTrans _ _ _ (Idle reqFn s)
    end.

  Lemma nextLe a t c: next (getTransSt getTransNext t) a c <=
                      next (getTransSt getTransNext (S t)) a c.
  Proof.
    pose (getTrans getTransNext t) as trans;
    unfold getTransSt;
    unfold getTransList;
    fold (getTransList getTransNext t); simpl.
    destruct trans; [simpl; destruct (decTree c c0); destruct (decAddr a0 a) | ]; omega.
  Qed.

  Lemma nextStarLe a t1 t2 c (cond: t1 <= t2): next (getTransSt getTransNext t1) a c <=
                                               next (getTransSt getTransNext t2) a c.
  Proof.
    remember (t2-t1) as td; assert (H: t2 = t1 + td) by omega;
    rewrite H in *; clear t2 cond H Heqtd.
    induction td.
    assert (H: t1 + 0 = t1) by omega; rewrite H; omega.
    assert (H: t1 + S td = S (t1 + td)) by omega; rewrite H; clear H;
    pose proof (nextLe a (t1 + td) c) as sth.
    omega.
  Qed.

  Lemma reqImpGt t: match getTrans getTransNext t with
                      | AReq a c => S (next (getTransSt getTransNext t) a c) =
                                 next (getTransSt getTransNext (S t)) a c /\
                                 forall a' c', (a' <> a \/ c' <> c) ->
                                            next (getTransSt getTransNext t ) a' c' =
                                            next (getTransSt getTransNext (S t)) a' c'
                      | Idle => forall a c, next (getTransSt getTransNext t ) a c =
                                            next (getTransSt getTransNext (S t)) a c
                    end.
  Proof.
    unfold getTransSt.
    unfold getTransList; fold (getTransList getTransNext t); simpl.
    destruct (getTrans getTransNext t).
    simpl.
    destruct (decTree c c); destruct (decAddr a a).
    constructor. omega.
    intros a' c' c'_neq.
    destruct (decTree c' c); destruct (decAddr a a').
    assert (a' = a) by auto; intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
    intuition.
  Qed.

  Theorem uniqAtomLabels:
    forall t1 t2,
      match getTrans getTransNext t1, getTrans getTransNext t2 with
        | AReq a1 c1, AReq a2 c2 =>
          a1 = a2 ->
          c1 = c2 ->
          next (getTransSt getTransNext t1) a1 c1 =
          next (getTransSt getTransNext t2) a2 c2 ->
          t1 = t2
        | _, _ => True
      end.
  Proof.
    intros t1 t2.
    pose proof (reqImpGt t1) as sth1.
    pose proof (reqImpGt t2) as sth2.
    destruct (getTrans getTransNext t1).
    destruct (getTrans getTransNext t2).
    intros a_eq c_eq n_eq.
    rewrite <- c_eq, <- a_eq in *.
    assert (opts: t1 = t2 \/ t1 < t2 \/ t2 < t1) by omega.

    destruct sth1 as [u1 _];
      destruct sth2 as [u2 _].
    destruct opts as [eq | [lt | gt]].
    assumption.

    Ltac finish a c cond :=
      pose proof (nextStarLe a c cond) as use;
      assert False by omega; intuition.
    finish a c lt.
    finish a c gt.

    intuition.
    intuition.
  Qed.

  Theorem localAtomOrdering:
    forall t1 t2, match getTrans getTransNext t1, getTrans getTransNext t2 with
                    | AReq a1 c1, AReq a2 c2 =>
                      a1 = a2 ->
                      c1 = c2 ->
                      next (getTransSt getTransNext t1) a1 c1 <
                      next (getTransSt getTransNext t2) a2 c2 ->
                        t1 < t2
                    | _, _ => True
                  end.
  Proof.
    intros t1 t2.
    pose proof (reqImpGt t1) as sth1.
    pose proof (reqImpGt t2) as sth2.
    destruct (getTrans getTransNext t1).
    destruct (getTrans getTransNext t2).
    intros a_eq c_eq n_lt.
    rewrite <- c_eq, <- a_eq in *.
    destruct sth1 as [u1 _]; destruct sth2 as [u2 _].
    assert (opts: t1 = t2 \/ t1 < t2 \/ t2 < t1) by omega.
    destruct opts as [eq | [lt | gt]].
    rewrite eq in *; assert False by omega; intuition.
    intuition.
    pose proof (nextStarLe a c gt) as use;
      assert False by omega; intuition.

    intuition.
    intuition.
  Qed.

  Theorem allAtomPrev a t c i:
    next (getTransSt getTransNext t) a c > i ->
    exists t', t' < t /\ match getTrans getTransNext t' with
                           | AReq a' c' => a = a' /\ c = c' /\
                                       next (getTransSt getTransNext t') a' c' = i
                           | Idle => False
                         end.
  Proof.
    intros gt.
    induction t.
    simpl in gt.
    assert False by omega; intuition.
    pose proof (nextLe a t c) as sth.
    assert (opts: next (getTransSt getTransNext (S t)) a c =
                  next (getTransSt getTransNext t) a c \/
                  next (getTransSt getTransNext (S t)) a c >
                  next (getTransSt getTransNext t) a c) by (unfold Index; omega).
    destruct opts as [e|n].
    rewrite e in gt; destruct (IHt gt) as [t' [cond rest]]; exists t'; constructor;
    [ omega | intuition].
    assert (opts: next (getTransSt getTransNext t) a c = i \/
                  next (getTransSt getTransNext t) a c > i \/
                  next (getTransSt getTransNext t) a c < i) by (unfold Index; omega).
    destruct opts as [eq | [lt | gtt]].
    exists t; constructor.
    omega.
    pose proof (reqImpGt t) as sth2.
    destruct (getTrans getTransNext t).
    destruct sth2 as [u1 u2].
    destruct (decTree c c0).
    destruct (decAddr a a0).
    rewrite e, e0 in *; intuition.
    assert (H: a <> a0 \/ c <> c0) by intuition.
    specialize (u2 a c H).
    assert False by omega; intuition.
    assert (H: a <> a0 \/ c <> c0) by intuition.
    specialize (u2 a c H).
    assert False by omega; intuition.
    specialize (sth2 a c);
      assert False by omega; intuition.

    destruct (IHt lt) as [t' cond].
    exists t'; constructor; [omega | intuition].

    pose proof (reqImpGt t) as sth2.
    destruct (getTrans getTransNext t).
    destruct sth2 as [u1 u2].
    specialize (u2 a c).
    destruct (decAddr a a0).
    destruct (decTree c c0).
    rewrite <- e, <- e0 in *.
    assert False by omega; intuition.
    assert (H: a <> a0 \/ c <> c0) by intuition;
      rewrite e in *;
      specialize (u2 H); assert False by omega; intuition.
    assert (H: a <> a0 \/ c <> c0) by intuition;
      specialize (u2 H); assert False by omega; intuition.
    specialize (sth2 a c).
    assert False by omega; intuition.
  Qed.

  Definition noCurrAtomStore a t :=
    match getTrans getTransNext t with
      | AReq a' c' =>
        a = a' ->
        let (descQ', dtQ') :=
            reqFn a' c' (next (getTransSt getTransNext t) a' c') in
          descQ' = St -> False
      | _ => True
    end.

  Definition noAtomStore a tl t:=
    forall t', tl <= t' < t -> noCurrAtomStore a t'.

  Definition matchAtomStore a cm tm t :=
    let (descQm, dtQm) :=
        reqFn a cm (next (getTransSt getTransNext tm) a cm) in
    mem (getTransSt getTransNext t) a = dtQm /\
    descQm = St.

  Definition lastMatchAtomStore a tm t :=
    match getTrans getTransNext tm with
      | AReq am cm => a = am /\ matchAtomStore a cm tm t /\
                      noAtomStore a (S tm) t
      | _ => False
    end.

  Definition latestAtomValue a t :=
    (mem (getTransSt getTransNext t) a = initData a /\
     noAtomStore a 0 t) \/
    (exists tm,
       tm < t /\ lastMatchAtomStore a tm t).

  Definition atomNoPrevNonSt a t :=
    noAtomStore a 0 t /\
    mem (getTransSt getTransNext (S t)) a = initData a /\
    noCurrAtomStore a t.

  Definition atomPrevNonSt a t :=
    (exists tm,
       tm < t /\
       match getTrans getTransNext tm with
         | AReq am cm => a = am /\ matchAtomStore a cm tm (S t) /\
                     noAtomStore a (S tm) t
         | _ => False
       end) /\
    noCurrAtomStore a t.

  Definition atomSt a t :=
    lastMatchAtomStore a t (S t).

  Lemma latestAtomInd a t (now: atomNoPrevNonSt a t \/ atomPrevNonSt a t \/ atomSt a t):
    latestAtomValue a (S t).
  Proof.
    unfold latestAtomValue.
    destruct now as [noPrevNonSt | [prevNonSt | st]].

    Case "noPrevNonSt".
    unfold atomNoPrevNonSt in *.
    left.
    constructor.
    intuition.
    unfold noAtomStore in *.
    intros t' cond.
    assert (opts: 0 <= t' < t \/ t' = t) by omega.
    destruct opts as [done | eq]; [| rewrite eq]; intuition.

    Case "prevNonSt".
    right.
    unfold atomPrevNonSt in *.
    destruct prevNonSt as [[tm [cond lm]] noCurr].
    exists tm.
    constructor.
    omega.
    unfold lastMatchAtomStore in *.
    destruct (getTrans getTransNext tm).
    constructor.
    intuition.
    unfold noAtomStore.
    constructor.
    intuition.
    intros t' cond2.
    assert (opts: S tm <= t' < t \/ t' = t) by omega.
    destruct opts as [ez|ez2].
    intuition.
    rewrite ez2 in *; intuition.
    intuition.

    Case "st".
    right.
    unfold atomSt in st.
    exists t.
    constructor.
    omega.
    intuition.
  Qed.

  Lemma latestAtomValueHolds a t: latestAtomValue a t.
  Proof.
    induction t.

    Case "0".
    left; constructor; [| intros t' contra; assert False by omega]; intuition.

    Case "S t".
    apply latestAtomInd.

    unfold atomNoPrevNonSt.
    unfold atomPrevNonSt.

    unfold latestAtomValue in IHt.
    unfold lastMatchAtomStore in IHt.
    unfold atomNoPrevNonSt.
    unfold noCurrAtomStore.
    unfold atomPrevNonSt.
    unfold matchAtomStore in *.
    unfold noCurrAtomStore.

    unfold atomSt.
    unfold lastMatchAtomStore.
    unfold matchAtomStore.
    unfold noAtomStore.

    unfold getTransSt at 1 3 in IHt.
    unfold getTransSt at 1 2 4 5 6 7.
    unfold getTrans at 1 3 4.
    unfold getTransList;
      fold (getTransList getTransNext t); simpl.
    destruct (trans (getTransNext (lTrans (getTransList getTransNext t))));
      simpl in *.

    SCase "AReq".
    destruct (decAddr a a0).
    rewrite <- e in *; clear e.

    SSCase "a = a0".
    case_eq (reqFn a c (next (lSt (getTransList getTransNext t)) a c)); simpl;
    intros desc dataQ reqF.
    destruct desc.

    SSSCase "Ld".
    simpl in *.
    destruct IHt.

    SSSSCase "NoPrev".
    left.
    intuition.
    discriminate.

    SSSSCase "Prev".
    right; left.
    intuition.
    discriminate.

    SSSCase "St".
    right; right.
    destruct (decAddr a a).
    constructor. intuition.
    constructor.
    constructor.
    rewrite reqF; simpl.
    intuition.
    intuition.
    intuition omega.

    intuition.

    simpl in *.
    destruct IHt.
    left.
    constructor.
    intuition.
    destruct (desc (reqFn a0 c (next (lSt (getTransList getTransNext t)) a0 c))).
    intuition.
    destruct (decAddr a0 a).
    assert False by auto.
    intuition.
    intuition.

    right.
    left.
    constructor.
    destruct (desc (reqFn a0 c (next (lSt (getTransList getTransNext t)) a0 c))).
    intuition.
    destruct (decAddr a0 a).
    assert False by auto.
    intuition.
    intuition.
    intuition.

    SSCase "Idle".
    destruct IHt; intuition.
  Qed.

  Theorem storeAtomicityAtom:
    forall t,
      match getTrans getTransNext t with
        | AReq a c =>
          let (descQ, dtQ) := reqFn a c (next (getTransSt getTransNext t) a c) in
          match descQ with
            | Ld => latestAtomValue a t
            | St => True
          end
        | _ => True
      end.
  Proof.
    intros t.
    pose proof (fun a => latestAtomValueHolds a t).
    destruct (getTrans getTransNext t).
    destruct (reqFn a c (next (getTransSt getTransNext t) a c)) as [desc _].
    destruct desc.
    intuition.
    intuition.
    intuition.
  Qed.

  Definition atomicResp s s' (t: AtomicTrans reqFn s s') :=
    match t with
      | AReq a c => Some (Build_Resp a c (next s a c)
                                  match desc (reqFn a c (next s a c)) with
                                    | Ld => mem s a
                                    | St => initData zero
                                  end)
      | Idle => None
    end.

  Definition sameResp r1 r2 :=
    match r1, r2 with
      | Some (Build_Resp a1 p1 i1 d1), Some (Build_Resp a2 p2 i2 d2) =>
        a1 = a2 /\ p1 = p2 /\ i1 = i2 /\ d1 = d2
      | Some _, None => False
      | None, Some _ => False
      | None, None => True
    end.

  Theorem sameRespIsEq: forall r1 r2, sameResp r1 r2 <-> r1 = r2.
  Proof.
    intros r1 r2.
    constructor; unfold sameResp.
    intros.
    repeat destructAll.
    destruct H as [x [y [z w]]].
    rewrite x, y, z, w.
    reflexivity.

    intuition.
    intuition.
    intuition.
    intuition.
    rewrite H in *.
    repeat destructAll.
    intuition.
    intuition.
  Qed.

  Section PrevMatch.
    Variable t: nat.
    Variable prevEq: forall ti : nat,
                       ti < t -> sameResp (respFn ti) (atomicResp (getTrans getTransNext ti)).

    Definition nextTransList := getTransList getTransNext.

    Ltac assocResp :=
      unfold getTrans in *;
      unfold getTransSt in *;
      fold nextTransList in *;
      unfold getTransNext in *.

    Lemma bothSomeOrNone:
      match atomicResp (getTrans getTransNext t), respFn t with
        | Some _, Some _ => True
        | None, None => True
        | _, _ => False
      end.
    Proof.
      assocResp.
      destruct (respFn t); simpl; intuition.
    Qed.

    Lemma addrSame:
      match atomicResp (getTrans getTransNext t), respFn t with
        | Some (Build_Resp a1 c1 _ _), Some (Build_Resp a2 c2 _ _) => a1 = a2
        | _, _ => True
      end.
    Proof.
      assocResp.
      destruct (respFn t); simpl.
      destruct r; intuition.
      intuition.
    Qed.

    Lemma procSame:
      match atomicResp (getTrans getTransNext t), respFn t with
        | Some (Build_Resp a1 c1 _ _), Some (Build_Resp a2 c2 _ _) => c1 = c2
        | _, _ => True
      end.
    Proof.
      assocResp.
      destruct (respFn t); simpl.
      destruct r; intuition.
      intuition.
    Qed.

    Lemma nextGtFalse:
      match atomicResp (getTrans getTransNext t), respFn t with
        | Some (Build_Resp _ _ i1 _), Some (Build_Resp _ _ i2 _) => i1 > i2 -> False
        | _, _ => True
      end.
    Proof.
      assocResp.
      case_eq (respFn t).
      intros r caseR; destruct r; simpl in *.
      intros nextGt.
      pose proof (allAtomPrev _ _ _ nextGt) as [t' [t'_lt_t allPrev]].
      specialize (prevEq t'_lt_t).
      assocResp.
      case_eq (respFn t').
      intros r caseR'; destruct r; rewrite caseR' in *; simpl in *.
      pose proof (uniqRespLabels sa t t') as uniq.
      rewrite caseR, caseR' in uniq.
      destruct prevEq as [_ [_ [idEq _]]].
      rewrite <- idEq in allPrev.
      assert (tEq: t = t') by (generalize allPrev uniq; clear; intuition).
      assert False by omega; intuition.
      intros caseR'; rewrite caseR' in *; intuition.
      intros caseR; simpl in *; intuition.
    Qed.

    Lemma nextLtFalse:
      match atomicResp (getTrans getTransNext t), respFn t with
        | Some (Build_Resp _ _ i1 _), Some (Build_Resp _ _ i2 _) => i1 < i2 -> False
        | _, _ => True
      end.
    Proof.
      assocResp.
      case_eq (respFn t).
      intros r caseR; destruct r; simpl in *.
      intros nextLt.
      pose proof (allPrevious sa t) as allPrev.
      rewrite caseR in *.
      specialize (allPrev _ nextLt).
      destruct allPrev as [t' [t'_lt_t allPrev]].
      specialize (prevEq t'_lt_t).
      assocResp.
      case_eq (respFn t').
      intros r caseR'; destruct r; rewrite caseR' in *; simpl in *.
      pose proof (uniqAtomLabels t t') as uniq.
      assocResp.
      rewrite caseR, caseR' in uniq; simpl in *.
      destruct prevEq as [_ [_ [idEq _]]].
      assert (tEq: t = t') by (generalize allPrev idEq uniq; clear;
                               unfold Index; intuition).
      assert False by omega; intuition.
      intros caseR'; rewrite caseR' in *; intuition.
      intros caseR; simpl in *; intuition.
    Qed.

    Lemma nextEq:
      match atomicResp (getTrans getTransNext t), respFn t with
        | Some (Build_Resp _ _ i1 _), Some (Build_Resp _ _ i2 _) => i1 = i2
        | _, _ => True
      end.
    Proof.
      pose proof nextLtFalse;
      pose proof nextGtFalse;
      repeat destructAll; try (omega); unfold Index; intuition.
    Qed.

    Lemma loadMatch:
      match atomicResp (getTrans getTransNext t), respFn t with
        | Some (Build_Resp _ _ _ d1), Some (Build_Resp _ _ _ d2) =>
          d1 = d2
        | _, _ => True
      end.
    Proof.
      assocResp.
      case_eq (respFn t).
      intros r respEq; destruct r; simpl in *.
      case_eq (desc (reqFn addrR procR (next (lSt (nextTransList t)) addrR procR))).
      intros isLd.
      pose proof nextEq as nextEq.
      pose proof (storeAtomicity sa t) as atom1.
      pose proof (storeAtomicityAtom t) as atom2.
      assocResp.
      rewrite respEq in *.
      simpl in *.
      rewrite nextEq in *.
      destruct (reqFn addrR procR idx).
      simpl in *.
      rewrite isLd in *.
      unfold latestAtomValue in atom2.

      destruct atom1 as [no1|yes1]; destruct atom2 as [no2|yes2].

      Case "noBefore1, noBefore 2".
      destruct no1 as [u1 _]; destruct no2 as [u2 _].
      rewrite <- u1 in u2; assumption.

      Case "noBefore1, before 2".
      destruct yes2 as [tm [tm_lt_t stMatch]].
      unfold lastMatchAtomStore in stMatch.
      specialize (prevEq tm_lt_t).
      assocResp.
      destruct no1 as [_ no1].
      unfold noStore in *.
      specialize (no1 tm tm_lt_t).

      case_eq (respFn tm).
      intros r respmEq; destruct r; rewrite respmEq in *; simpl in *.
      unfold matchAtomStore in stMatch.
      assocResp.
      destruct prevEq as [_ [_ [idEq _]]].
      destruct stMatch as [u0 rest].
      rewrite <- idEq, u0 in *.
      rewrite <- idEq in rest.
      destruct (reqFn addrR0 procR0 idx0).
      destruct rest as [[u1 u2] _].

      intuition.

      intros respmEq; rewrite respmEq in *; simpl in *; intuition.

      Case "before1, noBefore 2".
      destruct yes1 as [tm [tm_lt_t' stMatch]].
      specialize (prevEq tm_lt_t').
      assert (tm_lt_t: 0 <= tm < t) by omega.
      destruct no2 as [_ no2].
      unfold noAtomStore in no2.
      unfold noCurrAtomStore in no2.
      assocResp.
      specialize (no2 tm tm_lt_t).

      case_eq (respFn tm).
      intros r respmEq; destruct r; rewrite respmEq in *; simpl in *.
      destruct prevEq as [_ [_ [idEq _]]].
      rewrite <- idEq in *.
      destruct (reqFn addrR0 procR0 idx0).
      destruct stMatch as [u0 [u1 [u2 _]]].
      intuition.

      intros respmEq; rewrite respmEq in *; simpl in *; intuition.

      Case "before1, before 2".
      destruct yes1 as [tm1 [tm1_lt_t stMatch1]].
      destruct yes2 as [tm2 [tm2_lt_t stMatch2]].
      unfold lastMatchAtomStore in stMatch2.
      assocResp.
      pose proof (prevEq tm1_lt_t) as prev1.
      pose proof (prevEq tm2_lt_t) as prev2.
      clear prevEq.
      unfold matchAtomStore, noAtomStore, noCurrAtomStore in *;
        assocResp.

      unfold noStore in *.

      case_eq (respFn tm1); case_eq (respFn tm2).

      SCase "some tm1, some tm2".
      intros r r2Eq; destruct r; rewrite r2Eq in *;
      intros r r1Eq; destruct r; rewrite r1Eq in *; simpl in *.

      destruct stMatch2 as [u3 stMatch2].
      rewrite u3 in *.

      destruct prev1 as [_ [_ [i1Eq d1Eq]]].
      rewrite <- i1Eq in *;
      rewrite d1Eq in *; clear d1Eq.
      destruct prev2 as [_ [_ [i2Eq d2Eq]]].
      rewrite <- i2Eq in *;
      rewrite d2Eq in *; clear d2Eq.

      simpl in *.

      assert (opts: tm1 = tm2 \/ tm1 < tm2 \/ tm1 > tm2) by omega.
      destruct opts.

      SSCase "tm1 = tm2".
      rewrite H in *.
      rewrite r1Eq in r2Eq.
      injection r2Eq as dEq iEq pEq aEq.
      rewrite dEq in *;
        rewrite iEq in *;
        rewrite pEq, aEq in *.
      destruct (reqFn addrR0 procR0 idx0).
      destruct stMatch1 as [u0 [u1 _]].
      destruct stMatch2 as [[u2 _] _].
      rewrite <- u1 in u2;
        assumption.

      destruct H.

      SSCase "tm1 < tm2".
      destruct (reqFn addrR1 procR1 idx1).
      destruct stMatch1 as [u0 stMatch1].
      rewrite u0 in *.
      destruct stMatch1 as [_ [_ noLater]].
      assert (c1: tm1 < tm2 < t) by omega.
      specialize (noLater _ c1); clear c1.
      rewrite r2Eq in noLater.
      destruct (reqFn addrR1 procR0 idx0).
      generalize stMatch2 noLater; clear; intuition.

      SSCase "tm2 < tm1".
      destruct (reqFn addrR0 procR0 idx0).
      destruct stMatch2 as [_ noLater].
      assert (c1: S tm2 <= tm1 < t) by omega.
      specialize (noLater _ c1); clear c1.
      rewrite r1Eq in noLater.
      simpl in *.
      rewrite <- i1Eq in *.
      destruct (reqFn addrR1 procR1 idx1).
      generalize stMatch1 noLater; clear; intuition.

      SCase "some tm1, none tm2".
      intros r2Eq r r1Eq; destruct r; rewrite r2Eq in *; rewrite r1Eq in *;
      simpl in *; intuition.

      SCase "none tm1, some tm2".
      intros r r2Eq r1Eq; destruct r; rewrite r2Eq, r1Eq in *.
      simpl in *; intuition.

      SCase "none tm1, none tm2".
      intros r2Eq r1Eq; rewrite r2Eq, r1Eq in *.
      simpl in *; intuition.

      intros r.
      simpl in *.
      pose proof nextEq as nextEq.
      assocResp.
      pose proof (storeAtomicity sa t).
      rewrite respEq in *.
      simpl in *.
      rewrite nextEq in r.
      destruct (reqFn addrR procR idx).
      simpl in *.
      rewrite r in *.
      auto.

      intros.
      repeat destructAll; intuition.
    Qed.

    Lemma allMatch:
      match atomicResp (getTrans getTransNext t), respFn t with
        | Some (Build_Resp a1 c1 i1 d1), Some (Build_Resp a2 c2 i2 d2) =>
          a1 = a2 /\ i1 = i2 /\ c1 = c2 /\ d1 = d2
        | None, Some _ => False
        | Some _, None => False
        | None, None => True
      end.
    Proof.
      pose proof addrSame.
      pose proof bothSomeOrNone.
      pose proof procSame.
      pose proof nextEq.
      pose proof loadMatch.

      repeat destructAll; intuition.
    Qed.
  End PrevMatch.

  Theorem obeysP: forall n,
                    sameResp (respFn n) (atomicResp (getTrans getTransNext n)).
  Proof.
    apply strong_ind.
    intros t prevEq.
    pose proof (allMatch prevEq) as sth.
    unfold sameResp.
    repeat destructAll;
    repeat f_equal; intuition.
  Qed.

  Definition getAtomicResp n := atomicResp (getTrans getTransNext n).

  Lemma respEq' n: sameResp (respFn n) (getAtomicResp n).
  Proof.
    apply (obeysP n).
  Qed.

  Lemma respEq n: respFn n = getAtomicResp n.
  Proof.
    apply sameRespIsEq.
    apply respEq'.
  Qed.

  Fixpoint getResp n s (al: AtomicTransList reqFn s) :=
    match n with
      | 0 => match al with
               | Cons _ _ atss' als' => atomicResp atss'
             end
      | S m => match al with
                 | Cons _ _ _ als' => getResp m als'
               end
    end.

  CoFixpoint buildAl n: AtomicTransList reqFn (lSt (getTransList getTransNext n))
                                         := Cons (getTrans getTransNext n) (buildAl (S n)).

  Lemma getRespEq' n: forall m, getResp n (buildAl m) = getAtomicResp (n + m).
  Proof.
    unfold getAtomicResp.
    induction n.
    simpl.
    reflexivity.
    intros.
    simpl.
    specialize (IHn (S m)).

    assert (eq: n + S m = S (n + m)) by omega.
    rewrite eq in *.
    intuition.
  Qed.

  Lemma getRespEq n: getResp n (buildAl 0) = getAtomicResp n.
  Proof.
    pose proof (getRespEq' n 0) as sth.
    assert (eq: n+0 = n) by omega.
    rewrite eq in *.
    intuition.
  Qed.

End ForAddr.


Add LoadPath "/home/user/0my/GITHUB/VerifiedMathFoundations/library".
Require Coq.Lists.List.
Require Import Coq.Structures.Equalities.
Require Formulas.
Export Formulas.
Export Coq.Lists.List.

Module Provability_mod (SetVars FuncSymb PredSymb: UsualDecidableTypeFull).
Module PRE := Formulas.Formulas_mod SetVars FuncSymb PredSymb.
Export PRE.

Import PredFormulasNotationsASCII.
Local Open Scope pretxtnot.

Definition InL { A : Type } :=
fix InL (a : A) (l : list A) {struct l} : Type :=
  match l with
  | Datatypes.nil => False
  | b :: m => (sum (b = a) (InL a m))
  end.

(* intuitionistic "PROpositional" Calculus Axioms *)
Inductive PROCA : Fo -> Type :=
| Ha1  : forall A B, PROCA (A-->(B-->A))
| Ha2  : forall A B C, PROCA ((A-->(B-->C))-->((A-->B)-->(A-->C)))
| Ha3  : forall A B, PROCA (Conj A B --> A)
| Ha4  : forall A B, PROCA (Conj A B --> B)
| Ha5  : forall A B, PROCA (A --> (B --> Conj A B))
| Ha6  : forall A B, PROCA (A --> Disj A B)
| Ha7  : forall A B, PROCA (B --> Disj A B)
| Ha8  : forall A B C, PROCA ((A --> C) --> ((B --> C) --> (Disj A B --> C)))
| Ha9  : forall A B, PROCA (Neg A --> (A --> B))
| Ha10  : forall A B, PROCA ((A --> B) --> ((A --> Neg B) --> Neg A))
.

(* intuitionistic PREdicate Calculus Axioms *)
Inductive PRECA : Fo -> Type :=
| PRO  :> forall A, (PROCA A) -> (PRECA A)
| Ha12 : forall (ph: Fo) (t:Terms) (xi:SetVars.t)
 (r:Fo) (s:(substF t xi ph)=Some r), PRECA ((Fora xi ph) --> r)
(*| Ha12 : forall (ph: Fo) (t:Terms) (xi:SetVars.t)
 (r:Fo) (s:(substF t xi ph)=Some r), PRECA ((Fora xi ph) --> r)*)
| Hb1  : forall (ps ph: Fo) (xi:SetVars.t) (H:isParamF xi ps = false),
PRECA (Impl (Fora xi (Impl ps ph)) (Impl ps (Fora xi ph)) )
.

(***** MISLEADING THING! Do NOT use! *****)
(* IT WORKS:
Section PROPR.
(*Context (axs : Fo -> Type).*)
Context (ctx:list Fo).
Inductive PROPR : Fo -> Type :=
| hyp_O (A : Fo): (InL A ctx)-> PROPR A
| Hax_O :> forall (A : Fo), (PROCA A) -> PROPR A
| MP_O (A B: Fo) : (PROPR A)->(PROPR (Impl A B))
                 ->(PROPR B)
.
End PROPR.
*)

Section PREPR.
(*Context (axs : Fo -> Type).*)
Context (ctx:list Fo).
Inductive PREPR : Fo -> Type :=
| hyp_E (A : Fo): (InL A ctx)-> PREPR A
| Hax_E :> forall (A : Fo), (PRECA A) -> PREPR A
| MP_E (A B: Fo) : (PREPR A)->(PREPR (Impl A B))
                 ->(PREPR B)
| GEN_E (A : Fo) (xi:SetVars.t): (PREPR A)->(PREPR (Fora xi A))
.
(*Instance cMPe : (cMP PREPR) := MP_E.*)
End PREPR.
(* IT WORKS:
Definition a1 ctx A B : @PROPR ctx (Impl A (Impl B A)).
Proof. apply Hax_O.
(*
Check Ha1 A B : PROCA (A --> (B --> A)).
Check Ha1 A B : PRECA (A --> (B --> A)).
(*Check (Ha1 A B: PRECA (A --> (B --> A))) : @PR axi (A --> (B --> A)).*)
*)
refine (Ha1 _ _). Defined.
*)
Definition a1 ctx A B : @PREPR ctx (Impl A (Impl B A)).
Proof. apply Hax_E.
refine (Ha1 _ _).
Defined.

Definition a2 axi A B C : @PREPR axi ((A-->(B-->C))-->((A-->B)-->(A-->C))).
Proof. apply Hax_E, PRO, Ha2. Defined.
Definition b1 axi (ps ph: Fo) (xi:SetVars.t) (H:isParamF xi ps = false):
@PREPR axi (Impl (Fora xi (Impl ps ph)) (Impl ps (Fora xi ph)) ).
Proof. apply Hax_E, Hb1, H. Defined.

(* IT WORKS:
Theorem subcalc {ctx} (A:Fo) : PROPR ctx A -> PREPR ctx A.
Proof.
intro p.
try apply PRO.
induction p.
apply hyp_E, i.
apply Hax_E, PRO, p.
apply @MP_E with (A:=A).
(* unfold cMP. exact (MP_E ctx). intros. *)
apply IHp1. apply IHp2.
Defined.

Coercion subcalc : PROPR >-> PREPR.
*)

(*Arguments GPR {axs}.*)
(*Notation newMP := (MP (1:=I)).*)
(* IT WORKS:
Definition AtoA {ctx} (A:Fo) : PROPR ctx (A-->A).
Proof.
apply MP_O with (A:=(A-->(A-->A))).  (*(MP ctx (A-->(A-->A)) _).*)
apply Hax_O, Ha1. (* apply (Hax _ _ (Ha1 _ _)).*)
apply MP_O with (A:= A-->((A-->A)-->A)).
apply Hax_O, Ha1.
apply Hax_O, Ha2.
Defined.
*)

(* IT WORKS:
Definition a12 axi ph t xi : @PREPR axi (match (substF t xi ph) with
      | Some q => (Impl (Fora xi ph) q)
      | None => Top
      end).
Proof. induction (substF t xi ph) eqn:g. eapply Hax_E, Ha12, g.
unfold Top.
exact (AtoA  Bot).
Defined.
*)

Definition AtoA {ctx} (A:Fo) : PREPR ctx (A-->A).
Proof.
apply MP_E with (A:=(A-->(A-->A))).  (*(MP ctx (A-->(A-->A)) _).*)
apply Hax_E, PRO, Ha1. (* apply (Hax _ _ (Ha1 _ _)).*)
apply MP_E with (A:= A-->((A-->A)-->A)).
apply Hax_E, PRO, Ha1.
apply Hax_E, PRO, Ha2.
Defined.

(* page 155 *)
Theorem reverse_subst (xi eta:SetVars.t) (ph ps:Fo)
(H: (substF eta xi ph) = Some ps) : (substF xi eta ps) = Some ph.
Proof.
unfold substF in H.
Abort.

End Provability_mod.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import Arith ZArith.
Require Import Vector.
Require Import String.
Require Import JMeq.
Require Import List. Import ListNotations.

Require Import Integers.

Require Import lang.

Inductive fld : Type := OpCode | JField | EffAddr | EffTag
  | SpecialCode | RegImmCode
  | Reg_rsAddr | Reg_rtAddr | Reg_rdAddr | ImmediateV (* r-type instructions *)
  | TaintBit : Int64.int -> fld.

(* SIGNATURE: i:<n/a><instr>  r:<exeout><instr> *)
(* Instr r-t:  i{6} rs{5} rt{5} rd{5} 0* sp{6} *)
Definition offset (f : fld) : Int64.int :=
  match f with
  | OpCode  => Int64.repr 26
  | JField  => Int64.repr  0 (* Jump field offset, of instr *)
  | EffAddr => Int64.repr 32 (* Technically EXE output, of res *)
  | EffTag  => Int64.repr 56 (* Tag is top 8 bits *)  (* Assume it's the top 8bits of the top word *)
  | SpecialCode => Int64.repr  0 (* Last 6b of an instr *)
  | RegImmCode  => Int64.repr 16 (* like special, but more confusing.  eq to rt *)
  | Reg_rsAddr  => Int64.repr 21
  | Reg_rtAddr  => Int64.repr 16
  | Reg_rdAddr  => Int64.repr 11
  | ImmediateV  => Int64.repr  0 (* r-type instr immediate *)
  | TaintBit off => off
  end.

Definition size (f : fld) : Int64.int :=
  match f with
  | OpCode  => Int64.repr  6
  | JField  => Int64.repr 26 (* Jump field size, of instr *)
  | EffAddr => Int64.repr 32 (* Exe output, of res *)
  | EffTag  => Int64.repr  8 (* Tag is top 8 bits *)
  | SpecialCode => Int64.repr  6 (* Last 6b of an instr *)
  | RegImmCode  => Int64.repr  5 (* like special, but more confusing.  eq to rt *)
  | Reg_rsAddr  => Int64.repr  5
  | Reg_rtAddr  => Int64.repr  5
  | Reg_rdAddr  => Int64.repr  5
  | ImmediateV  => Int64.repr 16 (* r-type instr immediate *)
  | TaintBit _ => Int64.one  (* Taint bits are always size-1 *)
  end.

Inductive pred : Type :=
| BPred : binop -> pred -> pred -> pred
| BZero : pred
| BNeg : pred -> pred
| BField : fld -> bvec64 -> pred.

Inductive pol : Type :=
| PTest : pred -> pol -> pol
| PUpd : (exp TVec64 -> exp TVec64) -> pol
| PChoice : pol -> pol -> pol
| PConcat : pol -> pol -> pol
| PSkip : pol
| PFail : pol
| PId : pol.

Fixpoint pred_interp (e : pred) : bvec64 -> Prop :=
  match e with
  | BPred OAnd e1 e2 => fun v => pred_interp e1 v /\ pred_interp e2 v
  | BPred OOr e1 e2 => fun v => pred_interp e1 v \/ pred_interp e2 v
  | BPred _ _ _ => fun _ => False (*other binops are nonboolean*)
  | BZero => fun _ => False
  | BNeg e2 => fun v => not (pred_interp e2 v)
  | BField f i => fun v =>
      (Int64.eq
         (Int64.and (Int64.shru v (offset f))
                    (Int64.shru (Int64.repr 18446744073709551615) (size f)))
         i) = true
  end.

Fixpoint pol_interp (p : pol) : bvec64 -> bvec64 -> Prop :=
  match p with
  | PTest e p2 => fun v_in v_out => pred_interp e v_in /\ pol_interp p2 v_in v_out
  | PUpd f => fun v_in v_out => forall s, exp_interp s (f (EVal v_in)) = v_out
  | PChoice p1 p2 => fun v_in v_out => pol_interp p1 v_in v_out \/ pol_interp p2 v_in v_out
  | PConcat p1 p2 => fun v_in v_out =>
      exists v_int,
      pol_interp p1 v_in v_int /\ pol_interp p2 v_int v_out
  | PSkip => fun v_in v_out => True
  | PFail => fun v_in v_out => False
  | PId => fun v_in v_out => v_in = v_out
end.

Definition pol_eq (p1 p2 : pol) :=
  forall v_in v_out,
    pol_interp p1 v_in v_out <-> pol_interp p2 v_in v_out.

Infix "===" := (pol_eq) (at level 70).

Lemma concat_idl : forall p, PConcat PId p === p.
Proof.
  intros p; split; simpl.
  { intros [v [-> H]]; auto. }
  intros H; exists v_in; split; auto.
Qed.

Lemma pol_eq_sym : forall p1 p2, p1 === p2 -> p2 === p1.
Proof.
  intros p1 p2; unfold pol_eq; intros H v1 v2.
  rewrite (H v1 v2); split; auto.
Qed.

Lemma choice_failr : forall p, PChoice p PFail === p.
Proof.
  intros p v1 v2; split.
  { intros [H|H]; [auto|inversion H]. }
  intros; left; auto.
Qed.

(* Compile Predicates *)
Fixpoint compile_pred (x : id TVec64) (p : pred) : exp TVec64 :=
  match p with
  | BPred op pl pr => EBinop op (compile_pred x pl) (compile_pred x pr)
  | BZero => EVal (Int64.repr 0)
  | BNeg p' => ENot (compile_pred x p')
  | BField f i =>
    let field_val :=
        EBinop
          OAnd
          (EBinop OShru (EVar x) (EVal (offset f)))
          (EBinop OShru (EVal (Int64.repr 18446744073709551615))
                  (EVal (Int64.sub (Int64.repr 64) (size f))))
    in (EBinop OEq field_val (EVal i))
  end.

(* Monad *)
Section M.
  Variable state : Type.

  Definition M (A : Type) := state -> state * A.

  Definition ret (A : Type) (a : A) : M A := fun s => (s, a).

  Definition bind (A B : Type) (m : M A) (f : A -> M B) : M B :=
    fun s =>
      match m s with
      | (s', a) => f a s'
      end.
End M.

(* Variables using decimal integers *)
Inductive digit : Type :=
  Zero | One | Two | Three | Four | Five | Six | Seven | Eight | Nine.

Definition digit2string (d : digit) : string :=
  match d with
  | Zero => "0"
  | One => "1"
  | Two => "2"
  | Three => "3"
  | Four => "4"
  | Five => "5"
  | Six => "6"
  | Seven => "7"
  | Eight => "8"
  | Nine => "9"
  end.

Definition decimal := list digit.

Fixpoint decimal2string (d : decimal) : string :=
  match d with
  | nil => ""
  | x :: d' => append (digit2string x) (decimal2string d')
  end.

Fixpoint nat2decimal_aux (fuel n : nat) (acc : decimal) : decimal :=
  match fuel with
  | O => Zero :: acc
  | S fuel' =>
      match n with
      | 0 => Zero :: acc
      | 1 => One :: acc
      | 2 => Two :: acc
      | 3 => Three :: acc
      | 4 => Four :: acc
      | 5 => Five :: acc
      | 6 => Six :: acc
      | 7 => Seven :: acc
      | 8 => Eight :: acc
      | 9 => Nine :: acc
      | _ =>
        let d := Nat.div n 10 in
        let r := Nat.modulo n 10 in
        nat2decimal_aux fuel' d (nat2decimal_aux fuel' r acc)
      end
  end.

 Definition nat2decimal (n : nat) : decimal :=
   nat2decimal_aux n n nil.

 Definition nat2string (n : nat) : string := decimal2string (nat2decimal n).

 Definition state := (nat * list string)%type.

 Definition new_buf : M state string :=
   fun p =>
     match p with
     | (n, l) =>
       let new_buf := append "internal" (nat2string n) in
       ((S n, new_buf::l), new_buf)
     end.

 (* Compile Policies *)
 Fixpoint compile_pol (i o : id TVec64) (p : pol) : M state stmt :=
  match p with
  | PTest test p_cont =>
    let e_test := compile_pred i test
    in bind (compile_pol i o p_cont) (fun s_cont =>
       ret (SITE e_test s_cont SSkip))

  | PUpd f => ret (SAssign Nonblocking o (f (EVar i)))

  | PChoice p1 p2 =>
    bind new_buf (fun o_new1 =>
    bind new_buf (fun o_new2 =>
    bind (compile_pol i o_new1 p1) (fun s1 =>
    bind (compile_pol i o_new2 p2) (fun s2 =>
    ret (SSeq s1
        (SSeq s2
        (SAssign Nonblocking o
          (EBinop OOr (EVar o_new1) (EVar o_new2)))))))))

  | PConcat p1 p2 =>
    bind new_buf (fun m_new_buf =>
    bind (compile_pol i m_new_buf p1) (fun s1 =>
    bind (compile_pol m_new_buf o p2) (fun s2 =>
    ret (SSeq s1 s2))))

  | PSkip => ret SSkip

  | PFail => ret (SAssign Nonblocking o (EVal Int64.zero))

  | PId => ret (SAssign Nonblocking o (EVar i))
  end.

 Fixpoint compile_bufs (bufs : list string) (p : prog) : prog :=
   match bufs with
   | nil => p
   | x::bufs' => VDecl Local x (Int64.repr 0) (compile_bufs bufs' p)
   end.

Section compile.
  Variables i o : id TVec64.

  Definition compile (p : pol) : prog :=
    let (state, s) := compile_pol i o p (O, nil) in
    let output_p := VDecl Input i (Int64.repr 0) (VDecl Output o (Int64.repr 0) (PStmt s))
    in match state with
       | (_, bufs) => compile_bufs bufs output_p
       end.
End compile.

Infix "`orpred`" := (BPred OOr) (at level 60).

Section opcodes.
  Definition reg_imm   := Int64.repr  1. (* These will cause problems, probably *)
  Definition op_reg_imm:= BField OpCode reg_imm.
    (* Control Flow *)
    Definition reg_imm_BGEZ   := Int64.repr  1.
    Definition reg_imm_BGEZAL := Int64.repr 17.
    Definition reg_imm_BLTZ   := Int64.repr  0.
    Definition reg_imm_BLTZAL := Int64.repr 16.
      Definition op_reg_imm_branch :=
        BField RegImmCode reg_imm_BGEZ `orpred`
        BField RegImmCode reg_imm_BGEZAL `orpred`
        BField RegImmCode reg_imm_BLTZ `orpred`
        BField RegImmCode reg_imm_BLTZAL.
  Definition special   := Int64.repr 0. (* These will cause problems, probably *)
  Definition op_special:= BField OpCode special.
      (* Control Flow: *)
    Definition special_JALR   := Int64.repr 9.
    Definition special_JR     := Int64.repr 8.
      Definition op_special_j :=
        BField SpecialCode special_JALR `orpred`
        BField SpecialCode special_JR.
    (* ALU *)
    (* Skipping special2 (CLO, CLZ, DCLO, DCLZ, MADD, MADDU, MSUB, MSUBU, MUL) *)
      (* Arith: *)
    Definition special_ADD  := Int64.repr 32.
    Definition special_ADDU := Int64.repr 33.
    Definition special_DADD := Int64.repr 44.
    Definition special_DADDU:= Int64.repr 45.
    Definition special_DDIV := Int64.repr 30.
    Definition special_DDIVU:= Int64.repr 31.
    Definition special_DIV  := Int64.repr 26.
    Definition special_DIVU := Int64.repr 27.
    Definition special_DMULT:= Int64.repr 28.
    Definition special_DMULTU:=Int64.repr 29.
    Definition special_DSUB := Int64.repr 46.
    Definition special_DSUBU:= Int64.repr 47.
    Definition special_MULT := Int64.repr 24.
    Definition special_MULTU:= Int64.repr 25.
    Definition special_SLT  := Int64.repr 42.
    Definition special_SLTU := Int64.repr 43.
    Definition special_SUB  := Int64.repr 34.
    Definition special_SUBU := Int64.repr 35.
      Definition op_special_arithmetic :=
        BField SpecialCode special_ADD `orpred`
        BField SpecialCode special_ADDU `orpred`
        BField SpecialCode special_DADD `orpred`
        BField SpecialCode special_DADDU `orpred`
        BField SpecialCode special_DDIV `orpred`
        BField SpecialCode special_DDIVU `orpred`
        BField SpecialCode special_DIV `orpred`
        BField SpecialCode special_DIVU `orpred`
        BField SpecialCode special_DMULT `orpred`
        BField SpecialCode special_DMULTU `orpred`
        BField SpecialCode special_DSUB `orpred`
        BField SpecialCode special_DSUBU `orpred`
        BField SpecialCode special_MULT `orpred`
        BField SpecialCode special_MULTU `orpred`
        BField SpecialCode special_SLT `orpred`
        BField SpecialCode special_SLTU `orpred`
        BField SpecialCode special_SUB `orpred`
        BField SpecialCode special_SUBU.
      (* Logical: *)
    Definition special_AND  := Int64.repr 36.
    Definition special_NOR  := Int64.repr 39.
    Definition special_OR   := Int64.repr 37.
    Definition special_XOR  := Int64.repr 38.
      Definition op_special_logical :=
        BField SpecialCode special_AND `orpred`
        BField SpecialCode special_NOR `orpred`
        BField SpecialCode special_OR `orpred`
        BField SpecialCode special_XOR.

  (* Branch-type instructions: *)
  Definition instr_BEQ := Int64.repr 4.
  Definition instr_BGTZ:= Int64.repr 7.
  Definition instr_BLEZ:= Int64.repr 6.
  Definition instr_BNE := Int64.repr 5.
  Definition instr_J   := Int64.repr 2.
  Definition instr_JAL := Int64.repr 3.
  Definition op_branch :=
    BField OpCode instr_BEQ `orpred`
    BField OpCode instr_BGTZ `orpred`
    BField OpCode instr_BLEZ `orpred`
    BField OpCode instr_BNE. (* does not support special and regimm *)
    (* Does branch addr. get calculated before exe? *)
  Definition op_j :=
    BField OpCode instr_J `orpred`
           BField OpCode instr_JAL.
  Definition op_branch_or_j := op_branch `orpred` op_j.

  (* Store-type instructions: *)
  Definition instr_SB  := Int64.repr 40.
  Definition instr_SC  := Int64.repr 56.
  Definition instr_SCD := Int64.repr 60.
  Definition instr_SD  := Int64.repr 63.
  Definition instr_SDL := Int64.repr 44.
  Definition instr_SDR := Int64.repr 45.
  Definition instr_SH  := Int64.repr 41.
  Definition instr_SW  := Int64.repr 43.
  Definition instr_SWL := Int64.repr 42.
  Definition instr_SWR := Int64.repr 46.
  Definition op_store  :=
    BField OpCode instr_SB `orpred`
    BField OpCode instr_SC `orpred`
    BField OpCode instr_SCD `orpred`
    BField OpCode instr_SD `orpred`
    BField OpCode instr_SDL `orpred`
    BField OpCode instr_SDR `orpred`
    BField OpCode instr_SH `orpred`
    BField OpCode instr_SW `orpred`
    BField OpCode instr_SWL `orpred`
    BField OpCode instr_SWR.
  (* Load-type instructions: *)
    (* SKIP *)
  (* ALU-type instructions: *)
  (* dont forget special type ALUs *)
    (* Ariths: *)
  Definition instr_ADDI  := Int64.repr  8.
  Definition instr_ADDIU := Int64.repr  9.
  Definition instr_DADDI := Int64.repr 24.
  Definition instr_DADDIU:= Int64.repr 25.
  Definition instr_SLTI  := Int64.repr 10.
  Definition instr_SLTIU := Int64.repr 11.
  Definition op_arithmetic :=
    BField OpCode instr_ADDI `orpred`
    BField OpCode instr_ADDIU `orpred`
    BField OpCode instr_DADDI `orpred`
    BField OpCode instr_DADDIU `orpred`
    BField OpCode instr_SLTI `orpred`
    BField OpCode instr_SLTIU.
    (* Logical: *)
  Definition instr_ANDI := Int64.repr 12.
  Definition instr_LUI  := Int64.repr 15.
  Definition instr_ORI  := Int64.repr 13.
  Definition instr_XORI := Int64.repr 14.
  Definition op_logical :=
    BField OpCode instr_ANDI `orpred`
    BField OpCode instr_LUI `orpred`
    BField OpCode instr_ORI `orpred`
    BField OpCode instr_XORI.
End opcodes.

Section test_secjmp.
  Variables i o : id TVec64.

  Definition sec_addr := BField JField (Int64.repr 0). (*FIXME*)

  Definition sec_jmp : pol :=
    PChoice
      (PTest op_j (PTest (BNeg sec_addr) PId))
      (PTest (BNeg op_j) PId).

  Require Import syntax.

  Local Open Scope hdl_stmt_scope.
  Local Open Scope hdl_exp_scope.

  Eval vm_compute in compile i o sec_jmp.
End test_secjmp.

Notation "'`IF`' e '`THEN`' p1 '`ELSE`' p2" :=
  (PChoice (PTest e p1) (PTest (BNeg e) p2)) (at level 101).

Section sec_ctrlflow. (*SCF*)
  (* assumes that the branch addr. is pre-calculated in the top 32b *)
  Variables i o : id TVec64.

  Definition sec_addr_j := BField JField (Int64.repr 0). (*FIXME*)
  Definition sec_addr32 := BField EffAddr (Int64.repr 0). (*FIXME*)

  Definition scf : pol :=
    `IF` op_branch `THEN` PTest (BNeg sec_addr32) PId
    `ELSE` (`IF` op_j `THEN` PTest (BNeg sec_addr_j) PId
    `ELSE` (`IF` op_special `THEN` PTest op_special_j (PTest (BNeg sec_addr32) PId)
    `ELSE` (`IF` op_reg_imm `THEN` PTest op_reg_imm_branch (PTest (BNeg sec_addr32) PId)
    `ELSE` PId))).

  Require Import syntax.

  Local Open Scope hdl_stmt_scope.
  Local Open Scope hdl_exp_scope.

  Eval vm_compute in compile i o scf.
End sec_ctrlflow.

Section SFI.
  Variables ri ro : id TVec64.

  Definition lfd_start := Int64.repr 11673330234144325632. (*162<<56*)
  Definition lfd_mask := Int64.repr 72057594037927935. (*0^8 1^56*)

  Definition mask e := EBinop OAnd (EVal lfd_mask) e.
  Definition force_range e := EBinop OOr (EVal lfd_start) e.

  Definition sfi : pol :=
    PChoice
      (PTest op_store
        (PConcat (PUpd mask)
                 (PUpd force_range)))
      (PTest (BNeg op_store) PId).
End SFI.

Module Taint. Section taint.
  Variables i o : id TVec64.

  (* inputs:
       - i[63-32]: arg0
       - i[31-0]: arg1
     outputs:
       - o[63-32]: taint(arg0)
       - o[31-0]: taint(arg1)
   *)

  Definition tainted : pred :=
    BPred OOr (BField (TaintBit (Int64.repr 63)) Int64.one)
              (BField (TaintBit (Int64.repr 31)) Int64.one).

  Definition taint_mask := Int64.repr 9223372034707292159. (*0 1^31 0 1^31*)
  Definition taint_bits := Int64.repr 9223372039002259456. (*1 0^31 1 0^31*)

  Definition mask e := EBinop OAnd (EVal taint_mask) e.
  Definition apply_taint e := EBinop OOr (EVal taint_bits) e.

  Definition taint : pol :=
    PChoice
      (PTest tainted
             (PConcat (PUpd mask)
                      (PUpd apply_taint)))
      (PTest (BNeg tainted) PId).
End taint. End Taint.

Require Import Extractions.

(* print the program *)

Definition i : id TVec64 := "i".
Definition o : id TVec64 := "o".
Definition ri : id TVec64 := "ri".
Definition ro : id TVec64 := "ro".

Definition sec_jmp_compiled : prog := compile i o sec_jmp.
Definition SFI_compiled : prog := compile ri ro sfi.
Definition taint_compiled : prog := compile i o Taint.taint.

Definition pretty_print_sec_jmp :=
  pretty_print_tb "secjmp" sec_jmp_compiled.
Definition pretty_print_SFI :=
  pretty_print_tb "SFI" SFI_compiled.
Definition pretty_print_taint :=
  pretty_print_tb "taint" taint_compiled.

Eval vm_compute in pretty_print_sec_jmp.
Eval vm_compute in pretty_print_SFI.

(* Not sure how this works. *)
Extract Constant main => "Prelude.putStrLn pretty_print_sec_jmp".
Extract Constant main => "Prelude.putStrLn pretty_print_SFI".

(* run the program 'secjmp.hs' and pipe to a file to get verilog *)
Extraction "secjmp.hs" pretty_print_sec_jmp.
Extraction "SFI.hs" pretty_print_SFI.
Extraction "taint.hs" pretty_print_taint.


(* We formulate the main theorem, which states that all HITs exist, provided that several
   kinds of HITs do. *)

Require Import HoTT.
Require Import HoTT.Pointed.
Require Import polynomial.
Require Import hit_structure.

(* An auxiliary definition of finite set. *)
Definition fin (n : nat) := {i : nat & i <= n}.

(* Suppose we have a finite sequence

   [X 0 -> X 1 -> ... -> X m]

   with transitions [ι_k : X k -> X (k + 1)], approximating the hit for [Σ].
   We call such a sequence a *finite telescope*.

   We may then extend the sequence by one more level of approximation

   [X m -> X (m+1)]

   by constructing [X (m+1)] as the HIT:

   - point constructors:
     * inclusion [ι_m : X m -> X (m+1)]
     * point constructors from [Σ], taking arguments in
       [X m] and giving values in [X (m+1)]

   - path constructors:
     * paths from [Σ], with endpoints of paths interpreted suitably in the previous stages [X i].
     * 2D-paths expressing the fact that the path constructors commute with the inclusions [ι_m].

  We formalize this idea here.
*)

Section TelescopeStage.
(* Construction of [X (m+1)] from the diagram [X 0 -> ... -> X m], see above. *)

Variable Σ : hit_signature.

(* The type of a finite telescope. We will actually always start a telescope with the [Empty] type.
 *)
(*
Record FiniteTelescope : Type := {
  tele_tip : Type ;
  tele_rec : option { t : FiniteTelescope & tele_tip -> tele_tip }
}.

Inductive FiniteTelescope : Type := {
}.
  | ocular : Type -> FiniteTelescope
  | tip :

with Stage : Type :=
  |

  tele_length : nat ;
  tele_type :> fin tele_length -> Type ;
  tele_incl : forall i, tele_type i -> tele_type (S i)
}.
  match n with
  | 0 => Empty
  | S n => { T : FiniteTelescope n & { X : Type
  end.
*)

(*
Variable X : nat -> Type.
Variable ι : forall n, Y (S n) -> Y n.
*)

(* Let us explain the next construction via an example. Suppose we have a binary
   point constructor [c] and a path constructor expressing associativity:

   [ assoc x y z : c (c (x, y), z) = c (x, c (y, z)) ]

   The new stage [Z 0] is constructed as a HIT as follows. There are two kinds of points:

     * inclusion of previous stage: for every [a : Y 0] there is [ ι a : Z 0]

     * new points: for all [a b : Y 0] there is a point [c (a, b) : Z 0].

   The path constructors are:

     * various coherence equations expressing commutativity of inclusions [ι] and [c]

     * associativity equations (read this carefully): for all [a : Y 0

Fixpoint endpoint_stage_act {P Q} (e : endpoint (sig_point Σ) P Q) :
  forall k, poly_act Q (X k).
Proof.
  simple refine (
           match e in endpoint _ P Q return poly_act Q (X k) with
           | endpoint_var _ => _
           | endpoint_const _ _ t => _
           | endpoint_constr _ i u => _
           | endpoint_fst _ _ _ u => _
           | endpoint_snd _ _ _ u => _
           | endpoint_pair _ _ _ u v => _
           | endpoint_inl _ _ _ e => _
           | endpoint_inr _ _ _ e => _
           end).

  (* endpoint_var *)
  - { apply (endpoint_stage_act (sig_point Σ)).

  (* endpoint_const *)
  - { exact (stage_ty Σ X ι). }

  (* endpoint_constr *)
  - {
    }

  (* endpoint_fst *)
  - { admit. }

  (* endpoint_snd *)
  - { admit. }

  (* endpoint_pair *)
  - { admit. }

  (* endpoint_inl *)
  - { admit. }

  (* endpoint_inr *)
  - { admit. }

(* The underlying type of the next level. *)
Inductive stage_ty : Type :=
  (* the inclusion into the next stage *)
  | stage_incl : X 0 -> stage_ty
  (* one extra level of point constructors *)
  | stage_constr : forall i, poly_act (sig_point Σ i) (X 0) -> stage_ty.

(* The path constructors are quite a bit trickier.
   We being by defining how to interpret their endpoints. *)

Fixpoint endpoint_stage_ty
         (Σ : hit_signature)
         (X : nat -> Type)
         (ι : forall n, X n -> X (S n))
         (k : nat)
         {P Q} (e : endpoint (sig_point Σ) P Q)
         {struct e}
  : X k.
Proof.
  simple refine (
           match e return X k with
           | endpoint_var _ => _
           | endpoint_const _ _ t => _
           | endpoint_constr _ i u => _
           | endpoint_fst _ _ _ u => _
           | endpoint_snd _ _ _ u => _
           | endpoint_pair _ _ _ u v => _
           | endpoint_inl _ _ _ e => _
           | endpoint_inr _ _ _ e => _
           end).

  (* endpoint_var *)
  - { exact (stage_ty Σ X ι). }

  (* endpoint_const *)
  - { exact (stage_ty Σ X ι). }

  (* endpoint_constr *)
  - {
    }

  (* endpoint_fst *)
  - { admit. }

  (* endpoint_snd *)
  - { admit. }

  (* endpoint_pair *)
  - { admit. }

  (* endpoint_inl *)
  - { admit. }

  (* endpoint_inr *)
  - { admit. }

(* The action of an endpoint on a telescope [X]. *)
Fixpoint stage_endpoint
         (Σ : hit_signature)
         (X : nat -> Type)
         (ι : forall n, X n -> X (S n))
         {P Q} (e : endpoint (sig_point Σ) P Q) (n : nat)
  : poly_act P (stage_point Σ X ι) -> poly_act Q (stage_point Σ X ι).
Proof.
  simple refine (
           match e as z in endpoint _ P Q
                 return poly_act P (stage_point Σ X ι) -> poly_act Q (stage_point Σ X ι)
           with
           | endpoint_var _ => _
           | endpoint_const _ _ t => _
           | endpoint_constr _ i u => _
           | endpoint_fst _ _ _ u => _
           | endpoint_snd _ _ _ u => _
           | endpoint_pair _ _ _ u v => _
           | endpoint_inl _ _ _ e => _
           | endpoint_inr _ _ _ e => _
           end).

  (* endpoint_var *)
  - { exact (fun x => x). }

  (* endpoint_const *)
  - { exact (fun _ => t). }

  (* endpoint_constr *)
  - {
    }

  (* endpoint_fst *)
  - { admit. }

  (* endpoint_snd *)
  - { admit. }

  (* endpoint_pair *)
  - { admit. }

  (* endpoint_inl *)
  - { admit. }

  (* endpoint_inr *)
  - { admit. }

(* TODO: define the rest of the structure. *)

End TelescopeStage.

Section HitTelescope.

Variable (Σ : hit_signature).

(* The existing sequence and transitions between them. *)
Variable (X : nat -> Type).
Variable (ι : forall n, X (S n) -> X n).

Definition extend_telescope : { Y : Type & κ : X 0 -> Y }.

End HitTelescope.

(* A HIT exists for any signtature with a rank. *)
Theorem HIT_existence (Σ : hit_signature) :
  { n : nat & hit_rank Σ n } -> HIT Σ.
  (* NOTE: it ought to be the case that we could assume a *mere* existence of [n] here,
           because if [n] merely exists, then it exists. For that to be the case, we need
           two lemmas:

           1. If [rank Σ n] and [n <= m] then [rank Σ m].
           2. rank is decidable in [n], i.e., [forall n, rank Σ n + ~ (rank Σ n)]
   *)
Proof.
  intros [n has_rank].
  (* here we should construct the hit in question using only the "three" hits. These we
     will take from the HoTT library, so that we get judgmental computation rules for
     points. The alternative would be to assume that the theorem holds for certain
     specific instances of [Σ] and prove that all the others follow. But that would likely
     be quite a bit more technically involved. *)
  admit.
Admitted.
 *)
End TelescopeStage.


Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype ssrnum ssralg.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Lib.TupleLems Lib.Dist Ipdl.Big Pars Lib.Set Ipdl.Big.
Require Import FunctionalExtensionality.

Definition is_encodable (T : Type) := exists (ft : finType), ((ft : Type) = T).

Class Encodable (T : Type) := { is_enc : is_encodable T }.
(* every finType is encodable *)
#[global]
Instance Encodable_finType (T : finType) : Encodable T.
    constructor.
    exists T.
    done.
Qed.

Fixpoint rxn_encodable {chan} {t} (r : @rxn chan t) :=
  match r with
    | @Read _ t _ => is_encodable t
    | @Bind _ _ _ c k => rxn_encodable c /\ (forall x, rxn_encodable (k x))
    | _ => True end.
Class EncodableRxn chan {t} (r : @rxn chan t) := { enc_rxn : rxn_encodable r }.
#[global]
Instance EncodableRet chan {t} (x : t) : EncodableRxn chan (Ret x).
   done.
Qed.

#[global]
Instance EncodableSamp chan {t} (x : Dist t) : EncodableRxn chan (Samp x).
   done.
Qed.

#[global]
Instance EncodableRead {chan} {t} `{Encodable t} (c : chan t) : EncodableRxn chan (Read c).
   constructor.
   simpl.
   destruct H; done.
Qed.

#[global]
Instance EncodableBind {chan} {t1 t2} (c : rxn t1) (k : t1 -> rxn t2)
          `{EncodableRxn chan _ c} `{forall x, EncodableRxn _ (k x)} : EncodableRxn _ (Bind c k).
  constructor.
  simpl; split.
  destruct H; done.
  intro; destruct (H0 x); done.
Qed.

#[global]
Instance EncodableRxnIf chan {t} b (r1 r2 : rxn t) `{EncodableRxn chan _ r1} `{EncodableRxn _ _ r2} : EncodableRxn _ (if b then r1 else r2).
destruct b; done.
Qed.

Fixpoint ipdl_encodable {chan} (i : @ipdl chan) :=
  match i with
    | Zero => True
    | @Out _ t _ r => is_encodable t /\ rxn_encodable r
    | Par p1 p2 => ipdl_encodable p1 /\ ipdl_encodable p2
    | New t k => forall c, ipdl_encodable (k c) end.

Class EncodableIPDL chan (i : @ipdl chan) := { enc_ipdl : ipdl_encodable i }.

#[global]
Instance EncodableZero chan : EncodableIPDL chan Zero.
    constructor; done.
Qed.

#[global]
Instance EncodableOut {chan} t c r `{Encodable t} `{EncodableRxn chan _ r} : EncodableIPDL _ (@Out chan t c r).
constructor.
destruct H.
split.
done.
destruct H0; done.
Qed.

#[global]
Instance EncodablePar chan p1 p2 `{EncodableIPDL _ p1} `{EncodableIPDL _ p2} : EncodableIPDL chan (Par p1 p2).
 constructor; simpl.
 split; destruct H, H0; done.
Qed.

#[global]
Instance EncodableNew chan t k `{forall c, EncodableIPDL chan (k c)} : EncodableIPDL _ (New t k).
constructor; simpl; intro.
 destruct (H c).
 done.
Qed.

#[global]
Instance EncodableFoldr chan {A} (xs : seq A) (P : A -> ipdl) (p : pred A) `{forall x, EncodableIPDL chan (P x)} :
EncodableIPDL _
    (foldr (fun (x : A) (x0 : ipdl) => if p x then P x ||| x0 else x0) prot0
       (xs)).
induction xs.
simpl.
apply _.
simpl.
destruct (p a).
apply _.
apply IHxs.
Qed.

#[global]
Instance EncodableBigOrd {chan} n p P `{forall i, EncodableIPDL chan (P i)} :
  EncodableIPDL _ (\||_(i < n | p i) P i).
    rewrite BigOp.bigopE.
    apply EncodableFoldr.
    done.
Qed.

#[global]
Instance EncodableNewvec {chan} {n} {t} (k : n.-tuple (chan t) -> ipdl) `{forall v, EncodableIPDL chan (k v)} : EncodableIPDL _ (v <- newvec n @ t ;; k v).
induction n.
simpl.
apply H.
simpl.
apply EncodableNew; intro.
apply IHn.
intros; apply H.
Qed.