Require Import Coq.Bool.Bool.

Require Import extraInv.
Require Import verif_cond_7.
Local Open Scope Z.

Theorem extra7: (commonStartnewloop hands0 hands1 dryer0 dryer1 ctrlState0 ctrlState1 ctrlTimer0 ctrlTimer1 timer0 timer1) /\
 cond7 -> (extraInv hands1 dryer1 ctrlState1 ctrlTimer1 timer1).

Proof.
intros.
inversion_clear H.
inversion_clear H1.
inversion_clear H2.
inversion_clear H3.
inversion_clear H0.
inversion_clear H5.
inversion_clear H6.
inversion_clear H7.
inversion_clear H8.
(*ctrlState0[i]=ctrlState1[i]*)
assert (HctrlState0_ctrlState1_same : (forall i, (0<=i /\ i<=timer0  -> ctrlState0.[of_Z i]=ctrlState1.[of_Z i]))).
intros.
apply arr_same_before_upd  with ctrlState0.[of_Z (timer1-1)] timer1.
split.
auto with zarith.
assumption.
(*split extraInv in the hypothesis*)
inversion_clear H3.
inversion_clear H10.
inversion_clear H11.
inversion_clear H12.
inversion_clear H13.
inversion_clear H14.
inversion_clear H15.
inversion_clear H16.
inversion_clear H17.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
reflexivity.
split.
auto with zarith.
split.
auto with zarith.
split.
(*ctrlState[i]=ctrlWaiting \/ ctrlState[i]=ctrlDrying*)
intros.
elim Zle_lt_or_eq with i timer1.
(*case i<timer1*)
intros.
rewrite <- HctrlState0_ctrlState1_same.
apply H16.
auto with zarith.
auto with zarith.
(*case i=timer1*)
intros.
rewrite H19.
right.
assumption.
inversion_clear H17.
assumption.
(*ctrlState[timer]=ctrlDrying -> ...*)
intros.
split.
assumption.  (*ctrlTimer<10*)
rewrite H6 in H1.
rewrite get_set_same in H1.
assert (Htimer0_timer1_1 : timer0=timer1-1).
apply Zeq_plus_swap.
rewrite H0.
reflexivity.
rewrite <- Htimer0_timer1_1 in H1.
apply H18 in H1.
inversion_clear H1.
inversion_clear H20.
inversion_clear H21.
assert (Hsub_timer_ctrlTimer_const : timer1 - ctrlTimer1=timer0 - ctrlTimer0).
auto with zarith.
(*hands[timer-ctrlTimer]=ON*)
split.
rewrite Hsub_timer_ctrlTimer_const.
replace hands1.[of_Z (timer0 - ctrlTimer0)] with hands0.[of_Z (timer0 - ctrlTimer0)].
assumption.
apply arr_same_before_upd with logvar  timer1.
split.
auto with zarith.
assumption.
(*dryer[timer-ctrlTimer]=ON*)
split.
rewrite Hsub_timer_ctrlTimer_const.
replace dryer1.[of_Z (timer0 - ctrlTimer0)] with dryer0.[of_Z (timer0 - ctrlTimer0)].
assumption.
apply arr_same_before_upd with dryer0.[of_Z (timer1-1)]  timer1.
split.
auto with zarith.
assumption.
(*hands[i]=OFF /\ dryer[i]=ON*)
intros.
elim Zle_lt_or_eq with i timer1.
intros.
replace hands1.[of_Z i] with hands0.[of_Z i].
replace dryer1.[of_Z i] with dryer0.[of_Z i].
apply H22.
auto with zarith.
apply arr_same_before_upd with dryer0.[of_Z (timer1-1)] timer1.
split; assumption.
apply arr_same_before_upd with logvar timer1.
split; assumption.
intros.
rewrite H23.
split.
(*hands [timer]=OFF*)
apply not_true_is_false.
assumption.
(*dryer [timer]=ON*)
rewrite H7.
rewrite get_set_same.
rewrite <- Htimer0_timer1_1.
apply Zcase_sign with ctrlTimer0.
intros.
rewrite H24 in H20.
rewrite Z.sub_0_r in H20.
assumption.
intros.
apply H22.
auto with zarith.
intros.
elimtype False.
auto with zarith.
apply dryer_inf.
inversion_clear H21.
assumption.
apply ctrlState_inf.
Qed.


(*
    b -> a  : Msg | msg
    a       : event(Msg | msg)
    a -> b  : ChallengeRequest | n0 | msg
    b       : event(ChallengeRequest | n0 | msg)
    b -> a  : ChallengeReply | n0
    a       : event(ChallengeReply | n0 | msg)
    a       : accept(msg)
*)

(*
    Protocol example : Light version of Babel-Mac Protocol (version 1)
        b       : Log(Msg(a, b, msg))
        b -> a  : Msg(a, b, msg)
        a       : assert(Msg(a, b, msg))
        a       : Log(ChallengeRequest(a, b, n0, msg))
        a -> b  : ChallengeRequest(a, b, n0, msg)
        b       : assert(ChallengeRequest(a, b, n0, msg))
        b       : Log(ChallengeReply(a, b, n0))
        b -> a  : ChallengeReply(a, b, n0)
        a       : assert(ChallengeReply(a, b, n0, msg))
*)

(*
    Protocol example: Light version of Babel-Mac Protocol (version 2)
        b       : Log(Msg(a, b, msg))
        b -> a  : Literal([TagMsg]) | msg
        a       : assert(Msg(a, b, msg))
        a       : Log(ChallengeRequest(a, b, n0, msg))
        a -> b  : Literal([TagChallengeRequest]) | msg | n0
                        | hmac(k, Literal([TagChallengeRequest]) | msg | n0)
        b       : assert(ChallengeRequest(a, b, n0, msg))
        b       : Log(ChallengeReply(a, b, n0))
        b -> a  : Literal([TagChallengeReply]) | n0
                        | hmac(k, Literal([TagChallengeReply]) | n0)
        a       : assert(ChallengeReply(a, b, msg, n0))
*)

Require Import String.
Require Import Ascii.
Require Import ListSet.

Inductive term: Type :=
    | Literal (b: string)
    | Pair (a: term) (b: term)
    | HMac (k: term) (p: term).

Module Type ProtocolDefs.
    Parameter nonce_usage: Type.
    Parameter hmac_usage: Type.
    Parameter pEvent: Type.
End ProtocolDefs.

Module BabelLightDefs <: ProtocolDefs.
    (*Parameter TagMsg: ascii.*)
    Parameter TagChallengeRequest: ascii.
    Parameter TagChallengeReply: ascii.
    Parameter TagsDistinct: (TagChallengeRequest <> TagChallengeReply)
                            (*/\ (TagChallengeRequest <> TagMsg)
                            /\ (TagChallengeReply <> TagMsg)*).

    Inductive nonce_usage' :=
        | ChallengeRequest (a b msg: term)
        | ChallengeReply (a b msg: term).
    Definition nonce_usage := nonce_usage'.

    Inductive hmac_usage' :=
        | U_KeyAB (a b: term).
    Definition hmac_usage := hmac_usage'.

    Inductive pEvent' :=
        | Msg (a b msg : term)
        | Request (a b n0 msg: term)
        | Reply (a b n0 msg: term)
        | Bad (p: term).
    Definition pEvent := pEvent'.
End BabelLightDefs.

Module Defs (PD : ProtocolDefs).
    Include PD.

    Inductive usage: Type :=
        | AdversaryGuess
        | Nonce (nu: nonce_usage)
        | HMacKey (hu: hmac_usage).

    Inductive event: Type :=
        | New (t: term) (u: usage)
        | ProtEvent (pe: pEvent).

    Definition log: Type := set event.
    Definition Logged (e: event) (L: log): Prop := set_In e L.
    Definition LoggedP (e: pEvent) (L: log): Prop := Logged (ProtEvent e) L.
    Definition leq_log (L L': log): Prop := forall e, Logged e L -> Logged e L'.

    Definition Stable (P: log -> Prop) := forall L L',
        leq_log L L' -> P L ->
        P L'.
    Definition WF_Log (L: log): Prop :=
        (forall t u u',
            Logged (New t u) L ->
            Logged (New t u') L -> u = u').
End Defs.

(* Signature: Protocol Invariants *)
Module Type ProtocolInvariants (PD: ProtocolDefs).
    Include Defs PD.

    Parameter LogInvariant: log -> Prop.

    Parameter hmacComp : term -> log -> Prop.
    Parameter hmacComp_Stable: forall t, Stable (hmacComp t).

    Parameter canHmac : term -> term -> log -> Prop.
    Parameter canHmac_Stable: forall k n, Stable (canHmac k n).
End ProtocolInvariants.

Module BabelLightInvariants <: ProtocolInvariants BabelLightDefs.
    Import BabelLightDefs.
    Include Defs BabelLightDefs.

    Definition LogInvariant L :=
        forall t u, Logged (New t u) L -> (exists bs, t = Literal bs).

    Definition KeyAB a b k L :=
        Logged (New k (HMacKey (U_KeyAB a b))) L.

    (*Definition RequestN a b n L :=
        exists msg, Logged (New n (Nonce (ChallengeRequest a b msg))) L.*)

    Definition ResponseN a b n msg L :=
        Logged (New n (Nonce (ChallengeReply a b msg))) L.

    Definition KeyABComp a b L :=
        LoggedP (Bad a) L \/ LoggedP (Bad b) L.

    Definition hmacComp k L :=
        exists a, exists b, KeyAB a b k L /\ KeyABComp a b L.

    Theorem hmacComp_Stable:
        forall t, Stable (hmacComp t).
    Proof.
        intro t. unfold Stable. intros L L'.
        unfold leq_log. unfold hmacComp. unfold KeyAB. unfold KeyABComp. unfold LoggedP.
        firstorder.
    Qed.

    Definition KeyABPayload a b p L :=
        (exists n, exists msg,
            p = Pair (Literal (String TagChallengeRequest EmptyString)) (Pair msg n) /\
            LoggedP (Request a b n msg) L) \/
        (exists n, exists msg,
            p = Pair (Literal (String TagChallengeReply EmptyString)) n /\
            LoggedP (Reply a b n msg) L).

    Definition canHmac k p L :=
        exists a, exists b, KeyAB a b k L /\ KeyABPayload a b p L.

    Theorem canHmac_Stable:
        forall k n, Stable (canHmac k n).
    Proof.
        intros k p. unfold Stable. intros L L'. unfold leq_log. unfold canHmac.
        unfold KeyAB. unfold KeyABPayload. unfold LoggedP.
        intros Hleq_log HcanHmacL.
        destruct HcanHmacL as (a, HcanHmacL_a). destruct HcanHmacL_a as (b, HcanHmacL_ab).
        exists a. exists b. firstorder.
    Qed.
End BabelLightInvariants.

Module CryptographicInvariants (PD: ProtocolDefs) (PI: ProtocolInvariants PD).
    Include PI.

    Definition GoodLog (L: log): Prop :=
        WF_Log L /\ LogInvariant L.

    Inductive level := Low | High.
    Inductive Level: level -> term -> log -> Prop :=
        | Level_AdversaryGuess: forall l bs L,
            Logged (New (Literal bs) AdversaryGuess) L ->
            Level l (Literal bs) L

        | Level_HMacKey: forall l bs L hu,
            Logged (New (Literal bs) (HMacKey hu)) L ->
            (l = Low -> hmacComp (Literal bs) L) ->
            Level l (Literal bs) L

        | Level_Pair: forall l t1 t2 L,
            Level l t1 L ->
            Level l t2 L ->
            Level l (Pair t1 t2) L

        | Level_HMac: forall l k m L,
            canHmac k m L ->
            Level l m L ->
            Level l (HMac k m) L
        | Level_HMac_Low: forall l k m L,
            Level Low k L ->
            Level Low m L ->
            Level l (HMac k m) L.

    Theorem Low_High: forall t L,
        Level Low t L -> Level High t L.
    Proof.
        intros t L. intro Hlow.
        induction Hlow.
        - apply Level_AdversaryGuess. assumption.
        - apply Level_HMacKey with (hu:=hu) ; try assumption. easy.
        - apply Level_Pair ; assumption.
        - apply Level_HMac ; assumption.
        - apply Level_HMac_Low ; assumption.
    Qed.

    Theorem Level_Stable: forall l t L L',
        leq_log L L' -> Level l t L ->
        Level l t L'.
    Proof.
        intros l t L L'. intros Hleq_log HlevelL.
        induction HlevelL.
        - apply Level_AdversaryGuess. unfold leq_log in Hleq_log.
            specialize Hleq_log with (e:=(New (Literal bs) AdversaryGuess)). auto.
        - apply Level_HMacKey with (hu:=hu).
            * unfold leq_log in Hleq_log.
                specialize Hleq_log with (e:=(New (Literal bs) (HMacKey hu))). auto.
            * intro Hllow. apply H0 in Hllow.
                assert ( Hstable : Stable (hmacComp (Literal bs)) ). apply hmacComp_Stable. firstorder.
        - apply Level_Pair ; firstorder.
        - apply Level_HMac ; try auto.
            assert ( Hstable : Stable (canHmac k m) ). apply canHmac_Stable. firstorder.
        - apply Level_HMac_Low ; firstorder.
    Qed.

    Theorem AbsurdDistinctUsages : forall P L t u u',
        GoodLog L ->
        u <> u' ->
        Logged (New t u) L ->
        Logged (New t u') L ->
        P.
    Proof.
        intros P L t u u'. intros HGoodLog Hu_not_u' HlogU HlogU'.
        unfold GoodLog in HGoodLog. destruct HGoodLog as (HGL_WfLog & _).
        unfold WF_Log in HGL_WfLog.
        specialize HGL_WfLog with (t:=t) (u:=u) (u':=u').
        apply HGL_WfLog in HlogU ; try assumption.
        exfalso. tauto.
    Qed.

    Theorem LowHmacKeyLiteral_Inversion : forall L k hu,
        GoodLog L ->
        Logged (New (Literal k) (HMacKey hu)) L ->
        forall l t, l = Low -> t = Literal k -> Level l t L ->
        hmacComp (Literal k) L.
    Proof.
        intros L k hu. intros HGoodLog Hlog. intros l t. intros Hlow HLit Hlevel. symmetry in HLit.
        unfold GoodLog in HGoodLog. destruct HGoodLog as (HGL_WL_Usage & _).
        unfold WF_Log in HGL_WL_Usage.
        induction Hlevel ; try discriminate.
        - exfalso. specialize HGL_WL_Usage with (t:=Literal bs) (u:=HMacKey hu) (u':=AdversaryGuess).
            rewrite HLit in Hlog. apply HGL_WL_Usage in Hlog ; try assumption. discriminate.
        - apply H0 in Hlow. rewrite HLit. assumption.
    Qed.

    Theorem HMac_Inversion : forall L l k p,
        forall t, t = HMac k p -> Level l t L ->
        canHmac k p L \/ Level Low k L.
    Proof.
        intros L l k p. intro t. intros Hhmac Hlevel.
        induction Hlevel ; try discriminate.
        - injection Hhmac. intros Hm Hk0. rewrite Hm in H. rewrite Hk0 in H. auto.
        - injection Hhmac. intros _ Hk0. rewrite Hk0 in Hlevel1. auto.
    Qed.
End CryptographicInvariants.

Import BabelLightDefs.
Include CryptographicInvariants BabelLightDefs BabelLightInvariants.
Import BabelLightInvariants.

Theorem RequestCorrespondence: forall a b k n msg L,
    GoodLog L -> KeyAB a b k L ->
    forall l t, l = Low -> t = (HMac k (Pair (Literal (String TagChallengeRequest EmptyString)) (Pair msg n))) ->
    Level l t L ->
    LoggedP (Request a b n msg) L \/
    LoggedP (Bad a) L \/ LoggedP (Bad b) L.
Proof.
    intros a b k n msg L. unfold KeyAB.
    intros HGoodLog HKeyAB. intros l t. intros Hlow Hhmac Hlevel.
    assert ( HGoodLog_bis : GoodLog L ). assumption.
    unfold GoodLog in HGoodLog. destruct HGoodLog as (HGL_WL_Usage & HGL_LogInv).
    unfold WF_Log in HGL_WL_Usage.
    unfold LogInvariant in HGL_LogInv. induction Hlevel ; try discriminate.
    - left. injection Hhmac. intros Hm Hk0. rewrite Hk0 in H. unfold canHmac in H.
        destruct H as (a0, Ha). destruct Ha as (b0, Hab).
        destruct Hab as (Hkey & HkeyPayload).
        unfold KeyAB in Hkey. specialize HGL_WL_Usage with (t:=k) (u:=HMacKey (U_KeyAB a b)) (u':=HMacKey (U_KeyAB a0 b0)).
        apply HGL_WL_Usage in HKeyAB ; try assumption. injection HKeyAB. intros Hb Ha.
        unfold KeyABPayload in HkeyPayload. destruct HkeyPayload as [HKP_req | HKP_reply].
        + destruct HKP_req as (n0, HKP_req_n). destruct HKP_req_n as (msg0, HKP_req_nmsg).
            destruct HKP_req_nmsg as (HKP_req_m & HKP_req_log).
            symmetry in Hm. rewrite HKP_req_m in Hm. injection Hm. intros Hn Hmsg.
            rewrite <- Ha in HKP_req_log. rewrite <- Hb in HKP_req_log.
            rewrite <- Hn in HKP_req_log. rewrite <- Hmsg in HKP_req_log. assumption.
        + exfalso. destruct HKP_reply as (n0, HKP_reply_n). destruct HKP_reply_n as (msg0, HKP_reply_nmsg).
            destruct HKP_reply_nmsg as (HKP_reply & _). symmetry in Hm.
            rewrite HKP_reply in Hm. injection Hm. intros _ Htag.
            assert ( HTagDistinct : TagChallengeRequest <> TagChallengeReply ).
            apply TagsDistinct. tauto.
    - right. injection Hhmac. intros Hm Hk0. rewrite Hk0 in Hlevel1.
        specialize HGL_LogInv with (t:=k) (u:=HMacKey (U_KeyAB a b)).
        assert ( Hlog : Logged (New k (HMacKey (U_KeyAB a b))) L ). assumption.
        apply HGL_LogInv in HKeyAB. destruct HKeyAB as (bs, HLitk).
        assert ( HhmacComp : hmacComp (Literal bs) L ).
        + apply LowHmacKeyLiteral_Inversion with (hu:=U_KeyAB a b) (l:=Low) (t:=Literal bs) ; try easy.
            * rewrite HLitk in Hlog. assumption.
            * rewrite HLitk in Hlevel1. assumption.
        + unfold hmacComp in HhmacComp. destruct HhmacComp as (a0, HhmacComp_a).
            destruct HhmacComp_a as (b0, HhmacComp_ab).
            destruct HhmacComp_ab as (HHC_key & HHC_keyComp).
            unfold KeyAB in HHC_key. rewrite HLitk in Hlog.
            specialize HGL_WL_Usage with (t:=Literal bs) (u:=HMacKey (U_KeyAB a b)) (u':=HMacKey (U_KeyAB a0 b0)).
            apply HGL_WL_Usage in Hlog ; try assumption. injection Hlog. intros Hb Ha.
            rewrite <- Ha in HHC_keyComp. rewrite <- Hb in HHC_keyComp.
            unfold KeyABComp in HHC_keyComp. assumption.
Qed.

Theorem ResponseCorrespondence: forall a b k n msg L,
    GoodLog L -> KeyAB a b k L -> ResponseN a b n msg L ->
    forall l t, l = Low -> t = (HMac k (Pair (Literal (String TagChallengeReply EmptyString)) n)) ->
    Level l t L ->
    LoggedP (Reply a b n msg) L \/
    LoggedP (Bad a) L \/ LoggedP (Bad b) L.
Proof.
    intros a b k n msg L. unfold KeyAB. unfold ResponseN.
    intros HGoodLog HKeyAB HrespN. intros l t. intros Hlow Hhmac Hlevel.
    assert ( HGoodLog_bis : GoodLog L ). assumption.
    unfold GoodLog in HGoodLog. destruct HGoodLog as (HGL_WL_Usage & HGL_LogInv).
    unfold WF_Log in HGL_WL_Usage. unfold LogInvariant in HGL_LogInv.
    induction Hlevel ; try discriminate.
    - left. injection Hhmac. intros Hm Hk0. rewrite Hk0 in H. unfold canHmac in H.
        destruct H as (a0, Ha). destruct Ha as (b0, Hab).
        destruct Hab as (Hkey & HkeyPayload). unfold KeyAB in Hkey.
        specialize HGL_WL_Usage with (t:=k) (u:=HMacKey (U_KeyAB a b)) (u':=HMacKey (U_KeyAB a0 b0)).
        apply HGL_WL_Usage in HKeyAB ; try assumption. injection HKeyAB. intros Hb Ha.
        unfold KeyABPayload in HkeyPayload. destruct HkeyPayload as [HKP_req | HKP_reply].
        + exfalso. destruct HKP_req as (n0, HKP_req_n). destruct HKP_req_n as (msg0, HKP_req_nmsg).
            destruct HKP_req_nmsg as (HKP_req_m & _). symmetry in Hm. rewrite HKP_req_m in Hm.
            injection Hm. intros _ Htag.
            assert ( HtagDistinct : TagChallengeRequest <> TagChallengeReply ). apply TagsDistinct.
            firstorder.
        + destruct HKP_reply as (n0, HKP_reply_n). destruct HKP_reply_n as (msg0, HKP_reply_nmsg).
            destruct HKP_reply_nmsg as (HKP_reply_m & HKP_reply_log).
            symmetry in Hm. rewrite HKP_reply_m in Hm. injection Hm. intro Hn.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E Eprime T Eprimeprime Cprime Dprime : Universe, ((wd_ C D /\ (wd_ A B /\ (wd_ A C /\ (wd_ A D /\ (wd_ Eprime A /\ (wd_ A T /\ (wd_ Eprimeprime T /\ (wd_ D Eprimeprime /\ (wd_ C Eprimeprime /\ (wd_ A Eprimeprime /\ (wd_ Dprime B /\ (wd_ Cprime B /\ (wd_ Eprimeprime B /\ (wd_ B C /\ (wd_ B D /\ (wd_ D Dprime /\ (wd_ C Cprime /\ (wd_ A E /\ (wd_ D Eprime /\ (wd_ Cprime A /\ (wd_ Dprime A /\ (col_ C D E /\ (col_ T A B /\ (col_ T C D /\ (col_ B C Cprime /\ (col_ B D Dprime /\ (col_ Cprime Dprime B /\ (col_ D Eprimeprime C /\ col_ A Eprimeprime Eprime)))))))))))))))))))))))))))) -> col_ Cprime B D)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Bool Arith List Omega.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Sorting.Permutation.
Import ListNotations.
Module NatMap := FMapList.Make Nat_as_OT.

Definition address := nat.
Definition version := nat.
Definition value := nat.
Definition lock := bool.
Definition variable := nat.
Definition store := NatMap.t value.
Definition heap :=  address -> option (value * lock * version).
Definition tid := nat.

Ltac myauto :=
  repeat match goal with
  | |- context[_] =>
      auto 100; intuition; cbn in *; simpl in *; auto 100
  | |- context[_] =>
      try contradiction; try discriminate
end.

Inductive action:=
|dummy: action
|start_txn: action
|read_item: version -> action
|write_item: value -> action
|try_commit_txn: action
|lock_write_item: action
|validate_read_item: Prop -> action
|abort_txn: Prop -> action (*True means abort needs to unlock before abort, False means the transaction about to be aborted does not contain locks*)
(*|restart_txn: action*)
|complete_write_item: (*value -> action*)version -> action
(*|unlock_write_item: version -> action*)
(*|invalid_write_item: value -> action*)
|commit_txn: action
|seq_point: action.
(*|obtain_global_tid: action.*)
(*sp later than last lock, but must before the first commit*)
Definition trace := list (tid * action).

(*
Returns all tid*action with tid tid in the trace.
*)
Definition trace_filter_tid tid tr : trace :=
    filter (fun pr => fst pr =? tid) tr.

(*
Returns all commit actions in the trace.
*)
(*
Definition trace_filter_commit tr: trace :=
    filter (fun pr => match snd pr with
                      | commit_txn => true
                      | _ => false
                      end) tr.
*)
(*
Returns all write actions in the trace.
*)
Definition trace_filter_write tr: trace :=
    filter (fun pr => match snd pr with
                      | write_item _ => true
                      | _ => false
                      end) tr.

(*
Returns all read actions in the trace.
*)
Definition trace_filter_read tr: trace :=
    filter (fun pr => match snd pr with
                      | read_item _ => true
                      | _ => false
                      end) tr.

(*
Returns all complete_write actions in the trace for updating version number of reads
*)
Definition trace_filter_complete tr: trace :=
    filter (fun pr => match snd pr with
                      | complete_write_item _ => true
                      | _ => false
                      end) tr.

(*
Returns the last action of the transaction tid
Returns dummy if there is no transaction with id tid.
*)
Definition trace_tid_last tid t: action :=
    hd dummy (map snd (trace_filter_tid tid t)).

Ltac remove_unrelevant_last_txn :=
  repeat match goal with
  | [H: context[trace_tid_last ?tid ((?tid0, _) :: ?t) = _] |-_] =>
      unfold trace_tid_last in H; inversion H;
      destruct (Nat.eq_dec tid tid0); subst
  | [H: context[hd _
       (map snd
          (if ?tid0 =? ?tid0
           then (?tid0, ?x) :: trace_filter_tid ?tid0 ?t
           else trace_filter_tid ?tid0 ?t)) = ?y] |-_] =>
      rewrite <- beq_nat_refl in H; simpl in H; inversion H
  | [H: context[?tid <> ?tid0] |-_] =>
      apply not_eq_sym in H; apply Nat.eqb_neq in H
end.

(*
Returns the version number of the last commit
If there is no commit in the trace, returns 0.
*)
(*
Definition trace_commit_last t: version :=
  match hd dummy (map snd (trace_filter_commit t)) with
	| commit_txn n => n
	| _ => 0
  end.
*)
(*
Returns the value of the last write
If there is no write in the trace, returns 0.
*)
(*
PROBLEMATIC: last write cannot be 0 in this case.
SUGGESTION: Use "option"
*)
Definition trace_write_last t: value :=
  match hd dummy (map snd (trace_filter_write t)) with
	| write_item n => n
	| _ => 0
  end.

(*
Returns the version number of the last commit/complete_write
If there is no commit in the trace, returns 0.
*)
(*
Definition trace_commit_complete_last t: version :=
  match hd dummy (map snd (trace_filter_commit_complete t)) with
	| commit_txn n => n
  | complete_write_item n => n
	| _ => 0
  end.
*)

Definition trace_complete_last t: version :=
  match hd dummy (map snd (trace_filter_complete t)) with
  | complete_write_item n => n
	| _ => 0
  end.

(*
Returns all lock_write_item actions in the trace.
*)
Definition trace_filter_lock tr: trace :=
    filter (fun pr => match snd pr with
                      | lock_write_item => true
                      | _ => false
                      end) tr.

(*
All commit and abort have unlock_write_item.
If a transaction contains either of the actions, the transaction has unlock
*)
Definition trace_filter_unlock tr: trace :=
    filter (fun pr => match snd pr with
                      | complete_write_item _ => true
                      | abort_txn True => true
                      | _ => false
                      end) tr.

(*
Returns the length of a trace
*)
Function length (tr: trace) : nat :=
  match tr with
  | [] => 0
  | _ :: tr' => S (length tr')
  end.

(*
Returns True if there exists no lock_write_item
Returns False if there exists locks
*)
Definition check_lock_or_unlock tr: Prop :=
  match
    length (trace_filter_lock tr) <=? length (trace_filter_unlock tr)
  with
	| true => True
	| false => False
  end.

(*
Returns true if an action is not a write action
Returns false if an action is a write action.
*)
Definition action_no_write e : Prop :=
  match e with
  | write_item  _  => False
  | _ => True
  end.

Definition action_no_read e : Prop :=
  match e with
  | read_item _ => False
  | _ => True
  end.

(*
Returns true if an action is not a commit_txn action
Returns false if an action is a commit_txn action.
*)
Definition action_no_commit e : Prop :=
  match e with
  | commit_txn => False
  | _ => True
  end.

Definition action_no_seq_point e: Prop:=
    match e with
  | seq_point => False
  | _ => True
  end.

Definition action_is_lock e: Prop:=
    match e with
  | lock_write_item => True
  | _ => False
  end.
(*
Returns true if the transaction tid's trace has no writes
Returns false otherwise.
*)
Definition trace_no_writes tid t: Prop :=
  Forall action_no_write (map snd (trace_filter_tid tid t)).

Definition trace_no_reads tid t: Prop :=
  Forall action_no_read (map snd (trace_filter_tid tid t)).

(*
Returns true if the transaction tid's trace has no commits
Returns false otherwise.
*)
Definition trace_no_commits tid t: Prop :=
  Forall action_no_commit (map snd (trace_filter_tid tid t)).

Definition trace_no_seq_points tid t: Prop :=
  Forall action_no_seq_point (map snd (trace_filter_tid tid t)).

Definition trace_has_locks tid t: Prop :=
  Forall action_is_lock (map snd (trace_filter_tid tid t)).

(*
Returns all read_item versions in a trace of a particular transaction.
*)
Function read_versions tr: list version :=
  match tr with
   | [] => []
   | (read_item v) :: tail =>  v :: read_versions tail
   | _ :: tail => read_versions tail
  end.

(*
Returns all read_item versions of tid in a trace tr.
*)
Definition read_versions_tid tid tr: list version :=
  read_versions (map snd (trace_filter_tid tid tr)).

(*
Returns True if reads are valid
Returns False otherwise
*)
Function check_version (vs : list version) (v : version) : Prop :=
  match vs with
  | [] => True
  | hd :: tail => if hd =? v then check_version tail v
                  else False
  end.

(*
Returns all start/read/write actions in the trace.
*)
(*
Definition trace_filter_startreadwrite tid tr: trace :=
    filter (fun pr => (fst pr =? tid) &&
                      (match snd pr with
                      | read_item _ => true
                      | write_item _ => true
                      | start_txn => true
                      | _ => false
                      end)) tr.
*)
(*
Returns all newtid with start/read/write actions in the trace.
*)
(*
Function trace_rollback (newtid: nat) (newver: version) (tr:trace): trace :=
    match tr with
    | [] => []
    | (tid, read_item _) :: tr'
      => [(newtid, read_item newver)] ++ trace_rollback newtid newver tr'
    | (tid, write_item val) :: tr'
      => [(newtid, write_item val)] ++ trace_rollback newtid newver tr'
    | (tid, start_txn) :: tr'
      => [(newtid, start_txn)] ++ trace_rollback newtid newver tr'
    | _ :: tr' => trace_rollback newtid newver tr'
  end.
*)

Inductive sto_trace : trace -> Prop :=

| empty_step : sto_trace []

| start_txn_step: forall t tid,
    (*trace_tid_last tid t = dummy*)
    (* this tid doesn’t have start_txn*)
    trace_filter_tid tid t = []
    -> sto_trace t
    -> sto_trace ((tid, start_txn)::t)

| read_item_step: forall t tid val oldver,
    trace_tid_last tid t = start_txn (* start/read/write before read*)
		\/ trace_tid_last tid t = read_item oldver
    \/ trace_tid_last tid t = write_item val
    (*check locked or not*)
    -> check_lock_or_unlock t
    -> sto_trace t
    -> sto_trace ((tid, read_item (trace_complete_last t)) :: t)

| write_item_step: forall t tid oldval val ver,
    trace_tid_last tid t = start_txn
		\/ trace_tid_last tid t = read_item ver
    \/ trace_tid_last tid t = write_item oldval
    -> sto_trace t
    -> sto_trace ((tid, write_item val) :: t)

| try_commit_txn_step: forall t tid ver val,
			trace_tid_last tid t = read_item ver
			\/ trace_tid_last tid t = write_item val
			-> sto_trace t
			-> sto_trace ((tid, try_commit_txn)::t)

| lock_write_item_step: forall t tid,
      ~ trace_no_writes tid t
      -> check_lock_or_unlock t
			-> trace_tid_last tid t = try_commit_txn
			-> sto_trace t
			-> sto_trace ((tid, lock_write_item) :: t)

| validate_read_item_step: forall t tid,
      ~ trace_no_reads tid t
			-> (trace_tid_last tid t = try_commit_txn /\ trace_no_writes tid t ) (*read only*)
			\/ trace_tid_last tid t = lock_write_item (*/\ ~ trace_no_writes tid t*)(*lock write*)
			-> sto_trace t
			-> sto_trace ((tid, validate_read_item (check_version (read_versions_tid tid t)  (trace_complete_last t) ))::t)
(*
<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>
The other abort condition is not included here
If when trying to lock memory location to write (in lock_write_item_step), there already exists a lock on that location,
then the transaction should be aborted: lock_write_item -> abort
The other similar situation that is not encoded is: read_item -> abort

THIS MODEL IS NOT COMPLETE

*)
| abort_txn_step: forall t tid,
      trace_tid_last tid t = validate_read_item False
      -> sto_trace t
      -> sto_trace ((tid, abort_txn (trace_has_locks tid t)) :: t) (*abort will contain unlock....*)

(*sequential point*)
| seq_point_step: forall t tid,
      (trace_tid_last tid t = validate_read_item True (*/\ ~ trace_no_reads tid t*))
      \/ (trace_tid_last tid t = lock_write_item /\ trace_no_reads tid t)
      (*-> trace_no_commits tid t*)
      -> trace_no_seq_points tid t
      -> sto_trace t
      -> sto_trace ((tid, seq_point) :: t)
| complete_write_item_step: forall t tid,
      ~ trace_no_writes tid t
      -> trace_tid_last tid t = seq_point
      -> sto_trace t
      -> sto_trace ((tid, complete_write_item (S (trace_complete_last t))) :: t)
| commit_txn_step: forall t tid ver,
      (trace_tid_last tid t = seq_point /\ trace_no_writes tid t)
      \/ (trace_tid_last tid t = complete_write_item ver)
      -> sto_trace t
      -> sto_trace ((tid, commit_txn) :: t).

Hint Constructors sto_trace.

Definition example_txn:=
[(2, commit_txn); (2, complete_write_item 1); (2, seq_point); (2, validate_read_item True); (2, lock_write_item); (2, try_commit_txn); (2, write_item 4); (2, read_item 0); (2, start_txn); (1, commit_txn); (1, seq_point); (1, validate_read_item True); (1, try_commit_txn); (1, read_item 0); (1, start_txn)].

Definition example_txn2:=
[(3, commit_txn); (3, seq_point); (3, validate_read_item True); (3, try_commit_txn); (3, read_item 1); (3, start_txn); (1, abort_txn False); (1, validate_read_item False); (1, try_commit_txn); (2, commit_txn); (2, complete_write_item 1); (2, seq_point); (2, validate_read_item True); (2, lock_write_item); (2, try_commit_txn); (2, write_item 4); (1, read_item 0); (2, read_item 0);  (2, start_txn); (1, start_txn)].

(*
Returns the serialized sequence of transactions in the STO trace based on seq_point of each transaction
The first element (tid) of the sequence is the first transaction that completes in the serial trace
Note that STO-trace is constructed in a reverse order: the first (tid * action) pair is the last operation in the trace
*)

Function seq_list (sto_trace: trace): list nat:=
  match sto_trace with
  | [] => []
  | (tid, seq_point) :: tail => tid :: seq_list tail
  | (tid, dummy) :: tail => seq_list tail
  | (tid, start_txn) :: tail => seq_list tail
  | (tid, read_item n) :: tail => seq_list tail
  | (tid, write_item n) :: tail => seq_list tail
  | (tid, try_commit_txn) :: tail => seq_list tail
  | (tid, lock_write_item) :: tail => seq_list tail
  | (tid, validate_read_item b) :: tail => seq_list tail
  | (tid, abort_txn _) :: tail => seq_list tail
  | (tid, complete_write_item n) :: tail => seq_list tail
  | (tid, commit_txn) :: tail => seq_list tail
  end.

Eval compute in seq_list example_txn.

Eval compute in seq_list example_txn2.

Function create_serialized_trace (sto_trace: trace) (seqls : list nat): trace:=
  match seqls with
  | [] => []
  | head :: tail
    => trace_filter_tid head sto_trace ++ create_serialized_trace sto_trace tail
  end.

(*
Check whether an element a is in the list l
*)
Fixpoint In_bool (a:nat) (l:list nat) : bool :=
  match l with
    | [] => false
    | b :: m => (b =? a) || In_bool a m
  end.

Fixpoint does_not_contain_tid tid (tr:trace) : Prop :=
  match tr with
  | [] => True
  | (tid', _) :: rest => tid <> tid' /\ does_not_contain_tid tid rest
  end.

(*
The function checks if a trace is a serial trace by making sure that
tid is only increaing as we traverse the trace
In this function, we assume that the trace is in the correct order.
That is, the first (tid*action) in the trace is actually the first one that gets to be executed
*)
Function check_is_serial_trace (tr: trace) : Prop :=
  match tr with
  | [] => True
  | (tid, x) :: rest =>
    match rest with
    | [] => True
    | (tid', y) :: _ => (tid = tid' \/ trace_filter_tid tid rest = [])
                        /\ check_is_serial_trace rest
    end
  end.

(*
This function executes STO trace in the reverse order
The goal is to record all read and write actions of all *committed* transactions
*)
Function exec (sto_trace: trace) (commit_tid: list nat) : list (tid * action) :=
  match sto_trace with
  | [] => []
  | (tid, action) :: tail => if (In_bool tid commit_tid)
            then match action with
                | read_item _ => (tid, action) :: exec tail commit_tid
                | write_item _ => (tid, action) :: exec tail commit_tid
                | _ => exec tail commit_tid
                 end
            else exec tail commit_tid
  end.

Eval compute in exec example_txn (seq_list example_txn).

(*
This function returns all values that is written in a trace to a memory location
*)
Function tid_write_value (trace: trace) : list value :=
  match trace with
  | [] => []
  | (_, write_item val) :: tail => val :: tid_write_value tail
  | _ :: tail => tid_write_value tail
  end.

(*
This function returns a list of pair that records write values of each tids in the trace
the first element in a pair is tid
the second element is all the write values written by the transaction with the id tid
*)
Function get_write_value (trace: trace) (tids: list nat) : list (nat * (list value)):=
  match tids with
  | [] => []
  | head :: tail => (head, tid_write_value (trace_filter_tid head trace)) :: get_write_value trace tail
  end.

Definition get_write_value_out (sto_trace: trace) : list (nat * (list value)) :=
  get_write_value sto_trace (seq_list sto_trace).

Eval compute in get_write_value_out example_txn.

(*
This function compares values in two lists one by one
The value at each position in one list should be the same as that in the other list
*)
Function compare_value (ls1: list value) (ls2: list value): bool:=
  match ls1, ls2 with
  | [], [] => true
  | _ , [] => false
  | [], _ => false
  | h1::t1, h2::t2 => if h1=?h2 then compare_value t1 t2 else false
  end.

(*
We compare writes of two traces in this function
If they have the same write sequence, then the function will return True
****************************************************
We assume that two traces have the same tids in the same sequence
Should we actually add tid1 =? tid2 in the code to remove this assumption?
****************************************************
*)
Function compare_write_list (ls1: list (nat * (list value))) (ls2:list (nat * (list value))): Prop :=
  match ls1, ls2 with
  | [], [] => True
  | _ , [] => False
  | [], _ => False
  | (tid1, ver1)::t1, (tid2, ver2)::t2
        => if (tid1 =? tid2 ) && (compare_value ver1 ver2) then compare_write_list t1 t2
            else False
  end.

Definition write_synchronization trace1 trace2: Prop:=
  compare_write_list (get_write_value_out trace1) (get_write_value_out trace2).

(*
The function returns the last write value of a STO-trace
*)
Definition last_write_value trace: nat:=
  trace_write_last (exec trace (seq_list trace)).

Eval compute in last_write_value example_txn.
(*
Definition write_synchronization trace1 trace2: Prop:=
  if (last_write_value trace1) =? (last_write_value trace2)
  then True
  else False.
*)
Eval compute in write_synchronization example_txn (create_serialized_trace example_txn (seq_list example_txn)).

(*
This function returns the version numbers of all the reads in a trace
*)
Function tid_read_version (trace: trace) : list version :=
  match trace with
  | [] => []
  | (_, read_item ver) :: tail => ver :: tid_read_version tail
  | _ :: tail => tid_read_version tail
  end.

(*
This function groups all versions of reads of a transaction in a trace.
This returns a list of pairs
The first element of a pair is the tid
The second element is a list of all versions of the reads from the transaction tid
*)
Function get_read_version (trace: trace) (tids: list nat) : list (nat * (list version)):=
  match tids with
  | [] => []
  | head :: tail => (head, tid_read_version (trace_filter_tid head trace)) :: get_read_version trace tail
  end.

Definition get_read_version_out (trace: trace) : list (nat * (list version)) :=
  get_read_version trace (seq_list trace).

Eval compute in get_read_version_out example_txn.

Eval compute in get_read_version_out example_txn2.

(*
This function compares all read versions of two list
This is the same as compare all write in previous functions
*)
Function compare_version (ls1: list version) (ls2: list version): bool:=
  match ls1, ls2 with
  | [], [] => true
  | _ , [] => false
  | [], _ => false
  | h1::t1, h2::t2 => if h1=?h2 then compare_version t1 t2 else false
  end.

Function compare_read_list (ls1: list (nat * (list version))) (ls2:list (nat * (list version))): Prop :=
  match ls1, ls2 with
  | [], [] => True
  | _ , [] => False
  | [], _ => False
  | (tid1, ver1)::t1, (tid2, ver2)::t2
        => if (tid1 =? tid2 ) && (compare_version ver1 ver2) then compare_read_list t1 t2
            else False
  end.

Definition read_synchronization trace1 trace2: Prop:=
  compare_read_list (get_read_version_out trace1) (get_read_version_out trace2).

Eval compute in read_synchronization example_txn (create_serialized_trace example_txn (seq_list example_txn)).

Eval compute in compare_read_list [(1, [0;0]); (2, [1;1])] [(1, [0]);(2, [1;1])].

(*
Two traces can be considered equivalent in execution if they produce the same reads and writes
*)
Definition Exec_Equivalence trace1 trace2: Prop:=
  write_synchronization trace1 trace2 /\ read_synchronization trace1 trace2.

Eval compute in Exec_Equivalence example_txn (create_serialized_trace example_txn (seq_list example_txn)).

(*
Function create_serialized_trace (sto_trace: trace) (sto_trace_copy: trace): trace:=
  match sto_trace with
  | [] => []
  | (tid, seq_point) :: tail
    => trace_filter_tid tid sto_trace_copy ++ create_serialized_trace tail sto_trace_copy
  | _ :: tail => create_serialized_trace tail sto_trace_copy
  end.

Eval compute in create_serialized_trace example_txn example_txn.

Eval compute in create_serialized_trace example_txn2 example_txn2.

Lemma serial_action_remove tid action t:
  sto_trace ((tid, action) :: t) ->
  ~ In (tid, seq_point) t ->
  create_serialized_trace t ((tid, action) :: t) = create_serialized_trace t t.
Proof.
  intros.
  apply sto_trace_app in H.
  induction H.
  simpl. auto.
  simpl.
Admitted.

*)

Lemma sto_trace_app tid action t:
  sto_trace ((tid, action) :: t) -> sto_trace t.
Proof.
  intros.
  inversion H; subst; auto.
Qed.

Lemma sto_trace_app2 t1 t2:
  sto_trace (t1 ++ t2) -> sto_trace t2.
Proof.
  intros.
  induction t1. rewrite app_nil_l in H. auto.
  simpl in *. destruct a.
  apply sto_trace_app with (tid0 := t) (action0:= a) in H.
  apply IHt1 in H. auto.
Qed.
(* some error with this lemma
Lemma sto_trace_app2 tid tid0 action action0 t:
  tid <> tid0 -> sto_trace ((tid, action) :: (tid0, action0) :: t) -> sto_trace ((tid, action) :: t).
Proof.
  intros.
  inversion H0; subst.
  apply sto_trace_app in H5. unfold trace_tid_last in H3; simpl in H3.
  apply not_eq_sym in H. apply Nat.eqb_neq in H; rewrite H in H3.
  apply start_txn_step with (tid := tid) in H5; [ auto | unfold trace_tid_last; auto ].
  apply sto_trace_app in H6. unfold trace_tid_last in H4; simpl in H4.
  apply not_eq_sym in H. apply Nat.eqb_neq in H; rewrite H in H4.
  unfold check_lock_or_unlock in H5. unfold trace_filter_lock in H5.
  unfold trace_filter_unlock in H5.
  apply read_item_step with (tid := tid) (val := val) (oldver := oldver) in H6; [ auto | unfold trace_tid_last; auto | auto].
Qed.
*)

Lemma seq_list_not_seqpoint tid action t:
  sto_trace ((tid, action) :: t) ->
  action <> seq_point ->
  ~ In tid (seq_list ((tid, action) :: t))
  -> ~ In tid (seq_list t).
Proof.
  intros; destruct action; simpl in *; auto.
Qed.

Lemma seq_list_not_seqpoint2 tid action t:
  sto_trace ((tid, action) :: t) ->
  ~ In tid (seq_list ((tid, action) :: t))
  -> ~ In tid (seq_list t).
Proof.
  intros; destruct action; simpl in *; auto.
Qed.

Lemma seq_list_seqpoint tid action t:
  sto_trace ((tid, action) :: t) ->
  action = seq_point ->
  In tid (seq_list ((tid, action) :: t)).
Proof.
  intros; subst; simpl.
  left. auto.
Qed.

Lemma trace_seqlist_seqpoint t tid:
  In (tid, seq_point) t
  -> In tid (seq_list t).
Proof.
  intros.
  functional induction seq_list t.
  inversion H.
  destruct (Nat.eq_dec tid tid0); subst; simpl.
  left. auto.
  right. apply IHl. apply in_inv in H. destruct H.
  inversion H. apply Nat.eq_sym in H1. contradiction. auto.
  all: destruct (Nat.eq_dec tid tid0); subst; apply IHl; apply in_inv in H; destruct H; try inversion H; auto.
Qed.

Lemma trace_seqlist_seqpoint_rev t tid:
  In tid (seq_list t)
  -> In (tid, seq_point) t.
Proof.
  intros.
  functional induction seq_list t.
  inversion H.
  destruct (Nat.eq_dec tid tid0); subst; simpl; simpl in H. left. auto.
  destruct H. apply eq_sym in H. congruence. apply IHl in H. right. auto.
  all: destruct (Nat.eq_dec tid tid0); subst; apply in_cons; auto.
Qed.

Lemma filter_app (f: nat * action -> bool) l1 l2:
  filter f (l1 ++ l2) = filter f l1 ++ filter f l2.
Proof.
  induction l1.
  - simpl. auto.
  - Search (filter).
    simpl. remember (f a) as X. destruct X.
    simpl. rewrite IHl1. auto. auto.
Qed.
Lemma trace_filter_tid_app tid tr1 tr2:
  trace_filter_tid tid (tr1 ++ tr2) =
  trace_filter_tid tid tr1 ++ trace_filter_tid tid tr2.
Proof.
  unfold trace_filter_tid.
  apply filter_app.
Qed.
Lemma Forall_app (P: action -> Prop) l1 l2:
    Forall P (l1 ++ l2) <-> Forall P l1 /\ Forall P l2.
Proof.
  split.
  - intros. split;
    rewrite Forall_forall in *.
    intros. Search (In _ ( _ ++ _ )).
    assert (In x l1 \/ In x l2 -> In x (l1 ++ l2)). apply in_or_app.
    assert (In x l1 \/ In x l2). left. auto.
    apply H1 in H2. auto.
    intros.
    assert (In x l1 \/ In x l2 -> In x (l1 ++ l2)). apply in_or_app.
    assert (In x l1 \/ In x l2). right. auto.
    apply H1 in H2. auto.
  - intros. destruct_pairs.
    rewrite Forall_forall in *. Search (In _ ( _ ++ _ )).
    intros.
    apply in_app_or in H1.
    (* firstorder. solved here*)
    destruct H1.
    apply H in H1. auto. apply H0 in H1. auto.
Qed.

Lemma seq_list_no_two_seqpoint t tid:
  sto_trace ((tid, seq_point) :: t)
  -> ~ In (tid, seq_point) t.
Proof.
  intros.
  assert (sto_trace t). { apply sto_trace_app with (tid0 := tid) (action0 := seq_point). auto. }
  inversion H.
  intuition.
  unfold trace_no_seq_points in H4.
  apply in_split in H6.
  destruct H6. destruct H3.
  rewrite H3 in H4. simpl in H4.
  rewrite trace_filter_tid_app in H4.
  simpl in H4.
  rewrite <-beq_nat_refl in H4.
  rewrite map_app in H4.
  rewrite Forall_app in H4.
  destruct H4. simpl in H6.
  apply Forall_inv in H6. simpl in H6. auto.
  unfold trace_no_seq_points in H4.
  apply in_split in H6.
  destruct H6. destruct H6.
  rewrite H6 in H4. simpl in H4.
  rewrite trace_filter_tid_app in H4.
  simpl in H4.
  rewrite <-beq_nat_refl in H4.
  rewrite map_app in H4.
  rewrite Forall_app in H4.
  destruct H4. simpl in H7.
  apply Forall_inv in H7. simpl in H7. auto.
Qed.

Lemma seq_list_no_two_seqpoint2 t1 t2 tid:
  sto_trace (t1 ++ (tid, seq_point) :: t2)
  -> ~ In (tid, seq_point) t1.
Proof.
  intros.
  intuition.
  apply in_split in H0. destruct H0. destruct H0.
  rewrite H0 in H.
  rewrite <- app_assoc in H.
  apply sto_trace_app2 in H.
  inversion H; subst.
  unfold trace_no_seq_points in H4.
  rewrite trace_filter_tid_app in H4.
  rewrite map_app in H4. rewrite Forall_app in H4.
  destruct H4. simpl in H1. rewrite <- beq_nat_refl in H1.
  simpl in H1. apply Forall_inv in H1. simpl in H1. auto.
Qed.

Lemma seq_point_after t1 t2 tid action:
  sto_trace ((tid, action) :: t1 ++ (tid, seq_point) :: t2)
  -> action = commit_txn \/ action = complete_write_item (S (trace_complete_last (t1 ++ (tid, seq_point) :: t2))).
Proof.
  intros.
  induction t1.
  simpl in H.
  - inversion H; subst.
    -- simpl in H2. rewrite <- beq_nat_refl in H2. inversion H2.
    -- unfold trace_tid_last in H3. simpl in H3. rewrite <- beq_nat_refl in H3. repeat destruct or H3; inversion H3.
    -- unfold trace_tid_last in H2. simpl in H2. rewrite <- beq_nat_refl in H2. repeat destruct or H2; inversion H2.
    -- unfold trace_tid_last in H2. simpl in H2. rewrite <- beq_nat_refl in H2. repeat destruct or H2; inversion H2.
    -- unfold trace_tid_last in H5. simpl in H5. rewrite <- beq_nat_refl in H5. inversion H5.
    -- unfold trace_tid_last in H4. simpl in H4. rewrite <- beq_nat_refl in H4. destruct H4. destruct H0. simpl in H0. inversion H0. simpl in H0. inversion H0.
    -- unfold trace_tid_last in H2. simpl in H2. rewrite <- beq_nat_refl in H2. inversion H2.
    -- unfold trace_tid_last in H3. simpl in H3. rewrite <- beq_nat_refl in H3. destruct H3. inversion H0. inversion H0. inversion H1.
    -- unfold trace_tid_last in H4. simpl in H4. rewrite <- beq_nat_refl in H4. simpl in *. right. auto.
    -- auto.
  - destruct a. destruct a.
    -- destruct (Nat.eq_dec tid t); subst; apply sto_trace_app in H; inversion H.
    -- destruct (Nat.eq_dec tid t); subst.
  admit.
Admitted.

Lemma seq_list_last_tid_start_txn tid t:
  sto_trace t ->
  In tid (seq_list t) ->
  trace_tid_last tid t <> start_txn.
Proof.
  intros ST; induction ST; intros.
  all: cbn in *.
  contradiction.
  all: unfold trace_tid_last; simpl; destruct (Nat.eq_dec tid0 tid); [subst |].
  apply trace_seqlist_seqpoint_rev in H0.
  apply in_split in H0. destruct H0. destruct H0.
  rewrite H0 in H. rewrite trace_filter_tid_app in H. simpl in H.
  rewrite <- beq_nat_refl in H. apply app_eq_nil in H. destruct H.
  inversion H1.
  apply IHST in H0. unfold trace_tid_last in H0.
  apply Nat.eqb_neq in n; rewrite n. auto.

  all: try rewrite <- beq_nat_refl; simpl; try congruence.
  all: apply Nat.eqb_neq in n; rewrite n; try apply IHST in H1; auto.

  apply Nat.eqb_neq in n. destruct H1. congruence.
  apply IHST in H1; auto.
Qed.
(*
Lemma seq_list_last_tid_read_item tid t:
  sto_trace t ->
  In tid (seq_list t) ->
  exists ver, trace_tid_last tid t <> read_item ver.
Proof.
  intros ST; induction ST; intros.
  all: cbn in *.
  contradiction.
  all: unfold trace_tid_last; simpl; destruct (Nat.eq_dec tid0 tid); [subst |].
  apply trace_seqlist_seqpoint_rev in H0.
  apply in_split in H0. destruct H0. destruct H0.
  rewrite H0 in H. rewrite trace_filter_tid_app in H. simpl in H.
  rewrite <- beq_nat_refl in H. apply app_eq_nil in H. destruct H.
  inversion H1.
  apply IHST in H0. unfold trace_tid_last in H0.
  apply Nat.eqb_neq in n; rewrite n. auto.

  all: try rewrite <- beq_nat_refl; simpl; try congruence.
  all: apply Nat.eqb_neq in n; rewrite n; try apply IHST in H1; auto.

  apply Nat.eqb_neq in n. apply in_app_or in H1. destruct H1.
  apply IHST in H1; auto.
  simpl in H1. destruct H1. congruence. contradiction.
Qed.*)

Lemma seq_list_seq tid t:
  sto_trace t ->
  trace_tid_last tid t = seq_point
  -> In tid (seq_list t).
Proof.
  intros.
  induction H; simpl; try discriminate.
  1, 3-4, 7, 10 : remove_unrelevant_last_txn; rewrite n in H3; apply IHsto_trace in H3; auto.
  1, 3, 5: remove_unrelevant_last_txn; rewrite n in H4; apply IHsto_trace in H4; auto.
  1: remove_unrelevant_last_txn; rewrite n in H5; apply IHsto_trace in H5; auto.
  remove_unrelevant_last_txn.
  left. auto.
  rewrite n in H4.
  apply IHsto_trace in H4.
  right. auto.
Qed.

Lemma same_version v1 v2:
  complete_write_item v1 = complete_write_item v2
  -> v1 = v2.
Admitted.

Lemma seq_list_complete tid t ver:
  sto_trace t ->
  trace_tid_last tid t = complete_write_item ver
  -> In tid (seq_list t).
Proof.
  intros.
  induction H; simpl; try discriminate.
  1, 3-4, 7, 10 : remove_unrelevant_last_txn; rewrite n in H3; apply IHsto_trace in H3; auto.
  1, 3, 4: remove_unrelevant_last_txn; rewrite n in H4; apply IHsto_trace in H4; auto.
  1: remove_unrelevant_last_txn; rewrite n in H5; apply IHsto_trace in H5; auto.
  remove_unrelevant_last_txn.
  simpl in *. rewrite <- beq_nat_refl in H0; simpl in *.
  apply seq_list_seq in H1. auto. auto.
  rewrite n in H4.
  apply IHsto_trace in H4. myauto.
Qed.

Lemma seq_point_before_commit (t:trace) (tid: tid):
  sto_trace ((tid, commit_txn) :: t) ->
  In (tid, seq_point) t.
Proof.
  intros.
  inversion H.
  destruct H2.
  destruct H2.
  apply seq_list_seq in H2.
  apply trace_seqlist_seqpoint_rev in H2.
  auto. auto.
  apply seq_list_complete in H2.
  apply trace_seqlist_seqpoint_rev in H2.
  auto. auto.
Qed.

Lemma seq_point_before_complete (t:trace) (tid: tid):
  sto_trace ((tid, complete_write_item (S (trace_complete_last t))) :: t) ->
  In (tid, seq_point) t.
Proof.
  intros.
  inversion H.
  apply seq_list_seq in H4.
  apply trace_seqlist_seqpoint_rev in H4.
  auto. auto.
Qed.

Lemma seq_list_action tid action t:
  sto_trace ((tid, action) :: t) ->
  action = seq_point \/ action = commit_txn \/ action = complete_write_item (S (trace_complete_last t))
  <-> In tid (seq_list ((tid, action) :: t)).
Proof.
  split.
  intros. destruct H0.
  apply seq_list_seqpoint; auto.
  subst. inversion H; subst.
  simpl.
  1-8: destruct H0; inversion H0.
  simpl. apply seq_list_seq in H5. auto. auto.
  destruct H3. destruct H1. simpl.
  apply seq_list_seq in H1; auto.
  apply seq_list_complete in H1; auto.

  intros.
  apply trace_seqlist_seqpoint_rev in H0.
  apply in_inv in H0.
  destruct H0.
  inversion H0. left. auto.
  right.
  apply in_split in H0. destruct H0. destruct H0. rewrite H0 in *.
  apply seq_point_after in H. auto.
Qed.

Lemma seq_list_action_neg tid action t:
  sto_trace ((tid, action) :: t) ->
  action <> seq_point /\ action <> commit_txn /\ action <> complete_write_item (S (trace_complete_last t))
  <-> ~ In tid (seq_list ((tid, action) :: t)).
Proof.
  intros. split.
  intros.
  intuition.
  apply seq_list_action in H .
  destruct H. apply H3 in H1.
  destruct H1; auto. destruct H1; auto.

  intros.
  intuition.
  apply seq_list_action in H .
  destruct H.
  assert (action = seq_point \/ action = commit_txn \/ action = complete_write_item (S (trace_complete_last t))). { left. auto. }
  apply H in H3. auto.
  apply seq_list_action in H .
  destruct H.
  assert (action = seq_point \/ action = commit_txn \/ action = complete_write_item (S (trace_complete_last t))). { right. left.  auto. }
  apply H in H3. auto.
  apply seq_list_action in H .
  destruct H.
  assert (action = seq_point \/ action = commit_txn \/ action = complete_write_item (S (trace_complete_last t))). { right. right.  auto. }
  apply H in H3. auto.
Qed.

Lemma seqlist_filter t t' tid:
  sto_trace t
  -> ~ In (tid, seq_point) t
  -> seq_list (trace_filter_tid tid t ++ t') = seq_list t'.
Proof.
  intros.
  induction H; simpl; auto.
  all: destruct (Nat.eq_dec tid0 tid); subst.
  all: simpl in H0; apply not_or_and in H0; destruct H0; try apply IHsto_trace in H2.
  all: try rewrite <- beq_nat_refl; simpl; auto.
  all: try rewrite <- Nat.eqb_neq in n; try rewrite n; auto.
  intuition.
Qed.

Lemma seq_list_split_no_seqpoint t1 t2:
  seq_list (t1 ++ t2) = seq_list t1 ++ seq_list t2.
Proof.
  intros.
  induction t1.
  simpl. auto.
  simpl in *. destruct a. destruct a.
  all: simpl in *; auto.
  rewrite IHt1. auto.
Qed.

Lemma seq_list_split_with_seqpoint t1 tid t2:
  seq_list (t1 ++ (tid, seq_point) :: t2) = seq_list t1 ++ tid :: (seq_list t2).
Proof.
  intros.
  rewrite seq_list_split_no_seqpoint.
  simpl in *. auto.
Qed.
(*
This function creates a serialized trace.
Just like STO-trace, the order is reversed: that is, the first (tid*action) pair in the serial trace
constructed by this function is the last operation performed in this trace
*)

Lemma serial_action_remove tid action t:
  ~ In tid (seq_list t) ->
  create_serialized_trace ((tid, action) :: t) (seq_list t)= create_serialized_trace t (seq_list t).
Proof.
  intros.
  induction (seq_list t).
  simpl. auto.
  simpl.
  simpl in H.
  assert (a <> tid /\ ~ In tid l). { intuition. }
  destruct H0.
  apply not_eq_sym in H0. rewrite <- Nat.eqb_neq in H0. rewrite H0.
  apply IHl in H1. rewrite H1. auto.
Qed.

Lemma serial_action_helper tid action t:
  sto_trace ((tid, action) :: t) ->
  action <> seq_point /\ action <> commit_txn /\ action <> complete_write_item (S (trace_complete_last t))
  -> create_serialized_trace ((tid, action) :: t) (seq_list ((tid, action) :: t)) =
     create_serialized_trace t (seq_list t).
Proof.
  intros.
  assert (sto_trace ((tid, action) :: t)). { auto. }
  assert (sto_trace ((tid, action) :: t)). { auto. }
  inversion H; subst.
  apply seq_list_action_neg in H. destruct H. apply H in H0.
  apply seq_list_not_seqpoint2 in H1; [ | auto ].
  apply serial_action_remove with (action0 := start_txn) in H1. auto.

  apply seq_list_action_neg in H. destruct H. apply H in H0.
  apply seq_list_not_seqpoint2 in H1; [ | auto ].
  apply serial_action_remove with (action0 := read_item (trace_complete_last t)) in H1; auto.

  apply seq_list_action_neg in H. destruct H. apply H in H0.
  apply seq_list_not_seqpoint2 in H1; [ | auto ].
  apply serial_action_remove with (action0 := write_item val) in H1; auto.

  apply seq_list_action_neg in H. destruct H. apply H in H0.
  apply seq_list_not_seqpoint2 in H1; [ | auto ].
  apply serial_action_remove with (action0 := try_commit_txn) in H1; auto.

  apply seq_list_action_neg in H. destruct H. apply H in H0.
  apply seq_list_not_seqpoint2 in H1; [ | auto ].
  apply serial_action_remove with (action0 := lock_write_item) in H1; auto.

  apply seq_list_action_neg in H. destruct H. apply H in H0.
  apply seq_list_not_seqpoint2 in H1; [ | auto ].
  apply serial_action_remove with (action0 := validate_read_item
     (check_version (read_versions_tid tid t) (trace_complete_last t))) in H1; auto.

  apply seq_list_action_neg in H. destruct H. apply H in H0.
  apply seq_list_not_seqpoint2 in H1; [ | auto ].
  apply serial_action_remove with (action0 := abort_txn (trace_has_locks tid t)) in H1; auto.

  destruct H0. congruence.
  destruct H0. destruct H3. congruence.
  destruct H0. destruct H3. congruence.
Qed.

Lemma serial_action_helper2 tid t:
  sto_trace ((tid, seq_point)::t)
  -> create_serialized_trace ((tid, seq_point)::t) (seq_list ((tid, seq_point)::t)) = trace_filter_tid tid ((tid, seq_point)::t) ++ create_serialized_trace t (seq_list t).
Proof.
  intros. simpl.
  rewrite <- beq_nat_refl.
  assert (sto_trace ((tid, seq_point) :: t)). { auto. }
  apply seq_list_no_two_seqpoint in H.
  assert (~ In (tid, seq_point) t -> ~ In tid (seq_list t)). { intuition. apply trace_seqlist_seqpoint_rev in H2. auto. }
  apply H1 in H.
  apply serial_action_remove with (action0:= seq_point) in H.
  rewrite H. auto. auto.
Qed.

Lemma serial_action_seq_list tid action t:
  sto_trace ((tid, action) :: t) ->
  ~ In tid (seq_list ((tid, action) :: t))
  -> create_serialized_trace ((tid, action) :: t) (seq_list ((tid, action) :: t)) = create_serialized_trace t (seq_list t).
Proof.
  intros.
  assert (sto_trace ((tid, action):: t)). { auto. }
  assert (sto_trace ((tid, action):: t)). { auto. }
  assert (~ In tid (seq_list t)). { apply seq_list_not_seqpoint2 with (action0:= action); auto. }
  apply seq_list_action_neg in H. destruct H. apply H4 in H0.
  destruct action; simpl; try apply serial_action_helper; auto.
  destruct H0. congruence.
Qed.

(*
This lemma proves that the seq_point of each transaction in a STO-trace determines its serialized order in the serial trace
*)

Lemma serial_action_split tid t t1 t2:
  sto_trace t
  -> t = t1 ++ (tid, seq_point) :: t2
  -> create_serialized_trace t (seq_list t) =
  create_serialized_trace t (seq_list t1) ++ trace_filter_tid tid ((t1 ++ (tid, seq_point) :: t2)) ++ create_serialized_trace t (seq_list t2).
Proof.
  intros. rewrite H0 in *. rewrite seq_list_split_with_seqpoint.
  clear H H0.
  induction (seq_list t1).
  simpl in *. auto.
  simpl. rewrite IHl.
  apply app_assoc.
Qed.

Lemma serial_action_before_commit tid t1 t2 t:
  sto_trace ((tid, commit_txn) :: t)
  -> t = t1 ++ (tid, seq_point) :: t2
  -> create_serialized_trace ((tid, commit_txn) :: t) (seq_list ((tid, commit_txn) :: t)) =
  create_serialized_trace t (seq_list t1) ++ (tid, commit_txn) :: trace_filter_tid tid t ++ create_serialized_trace t (seq_list t2).
Proof.
  intros.
  remember ((tid, commit_txn) :: t) as tbig.
  assert (create_serialized_trace tbig (seq_list tbig) =
          create_serialized_trace tbig (seq_list ((tid, commit_txn) :: t1))
          ++ trace_filter_tid tid tbig
          ++ create_serialized_trace tbig (seq_list t2)). {
    repeat rewrite Heqtbig.
    repeat rewrite H0.
    rewrite app_comm_cons.
    apply serial_action_split.
    rewrite <- app_comm_cons.
    rewrite <- H0.
    rewrite <- Heqtbig.
    auto.
    auto.
  }
  rewrite Heqtbig in H1; simpl in H1.
  rewrite <- beq_nat_refl in H1.
  assert (~ In tid (seq_list t1)). {
  rewrite Heqtbig in H. rewrite H0 in H.
  apply sto_trace_app in H.
  apply seq_list_no_two_seqpoint2 in H.
  intuition. apply trace_seqlist_seqpoint_rev in H2. auto.
  }
  apply serial_action_remove with (action0:= commit_txn) in H2.

Admitted.

Lemma serial_action_before_complete tid t1 t2 t:
  sto_trace ((tid, complete_write_item (S (trace_complete_last t))) :: t)
  -> t = t1 ++ (tid, seq_point) :: t2
  -> create_serialized_trace ((tid, complete_write_item (S (trace_complete_last t))) :: t) (seq_list ((tid, complete_write_item (S (trace_complete_last t))) :: t)) =
  create_serialized_trace t (seq_list t1) ++ (tid, complete_write_item (S (trace_complete_last t))) :: trace_filter_tid tid t ++ create_serialized_trace t (seq_list t2).
Proof.
  intros.
  assert (~ In tid (seq_list t2)).

Admitted.

Lemma seq_list_equal trace:
  sto_trace trace ->
  seq_list (create_serialized_trace trace (seq_list trace)) = seq_list trace.
Proof.
  intros. simpl.
  induction H; simpl.
  auto.
  apply start_txn_step with (tid0 := tid0) in H0. apply serial_action_helper in H0. rewrite <- H0 in IHsto_trace. auto. split; intuition; inversion H1. auto.
  apply read_item_step with (tid := tid0) (val:= val) (oldver:= oldver) in H0. apply serial_action_helper in H0. rewrite <- H0 in IHsto_trace. auto. split; intuition; inversion H2; inversion H. auto. auto.
  apply write_item_step with (tid := tid0) (ver:= ver) (oldval:= oldval) (val := val) in H0. apply serial_action_helper in H0. rewrite <- H0 in IHsto_trace. auto. split; intuition; inversion H1; inversion H. auto.
  apply try_commit_txn_step with (tid := tid0) (ver:= ver) (val:= val) in H0. apply serial_action_helper in H0. rewrite <- H0 in IHsto_trace. auto. split; intuition; inversion H1; inversion H. auto.
  apply lock_write_item_step with (tid := tid0) in H0. apply serial_action_helper in H0. rewrite <- H0 in IHsto_trace. auto. split; intuition; inversion H3. auto. auto. auto.
  apply validate_read_item_step with (tid := tid0) in H0. apply serial_action_helper in H0. rewrite <- H0 in IHsto_trace. auto. split; intuition; inversion H2. auto. auto.
  apply abort_txn_step with (tid := tid0) in H0. apply serial_action_helper in H0. rewrite <- H0 in IHsto_trace. auto. split; intuition; inversion H1. auto.

  rewrite <- beq_nat_refl. simpl.
  apply seq_point_step with (tid:= tid0) in H1.
  assert (sto_trace ((tid0, seq_point) :: t)). { auto. }
  apply seq_list_no_two_seqpoint in H1.
  assert (~ In (tid0, seq_point) t -> ~ In tid0 (seq_list t)). { intuition; apply trace_seqlist_seqpoint_rev in H4; apply H3 in H4; auto. }
  apply H3 in H1.
  apply serial_action_remove with (action0 := seq_point) in H1.
  rewrite <- H1 in IHsto_trace.
  assert (seq_list (trace_filter_tid tid0 t ++ create_serialized_trace ((tid0, seq_point) :: t) (seq_list t)) = seq_list (create_serialized_trace ((tid0, seq_point) :: t) (seq_list t))). { apply seqlist_filter. assert (sto_trace ((tid0, seq_point) :: t)). { auto. } apply sto_trace_app in H2. auto. apply seq_list_no_two_seqpoint in H2. auto. }
  rewrite H4.
  remember  (seq_list (create_serialized_trace ((tid0, seq_point) :: t) (seq_list t))) as too_long. rewrite <- IHsto_trace. rewrite Heqtoo_long. auto.
  auto. auto. auto.

  apply complete_write_item_step with (tid := tid0) in H0; [ | auto | auto].
  assert (sto_trace t). { apply sto_trace_app in H0. auto. }
  assert (sto_trace ((tid0, complete_write_item (S (trace_complete_last t))) :: t)). { auto. }
  apply seq_point_before_complete in H0.
  apply in_split in H0. destruct H0. destruct H0.
  assert (t = x ++ (tid0, seq_point) :: x0). { auto. }
  assert (t = x ++ (tid0, seq_point) :: x0). { auto. }
  apply serial_action_before_complete in H0; [ | auto].
  simpl in H0.
  unfold tid in H0. rewrite H0.
  rewrite seq_list_split_no_seqpoint. simpl.
  apply serial_action_split in H4; [ | auto].
  rewrite <- IHsto_trace. rewrite H4. rewrite H5.
  rewrite <- seq_list_split_no_seqpoint. auto.

  apply commit_txn_step with (tid := tid0) (ver:= ver) in H0; [ | auto].
  assert (sto_trace t). { apply sto_trace_app in H0. auto. }
  assert (sto_trace ((tid0, commit_txn) :: t)). { auto. }
  apply seq_point_before_commit in H0.
  apply in_split in H0. destruct H0. destruct H0.
  assert (t = x ++ (tid0, seq_point) :: x0). { auto. }
  assert (t = x ++ (tid0, seq_point) :: x0). { auto. }
  apply serial_action_before_commit in H0; [ | auto].
  simpl in H0.
  unfold tid in H0. rewrite H0.
  rewrite seq_list_split_no_seqpoint. simpl.
  apply serial_action_split in H4; [ | auto].
  rewrite <- IHsto_trace. rewrite H4. rewrite H3.
  rewrite <- seq_list_split_no_seqpoint. auto.

Qed.

(*
Lemma serial_action_add tid t:
  sto_trace t
  -> sto_trace (create_serialized_trace t (seq_list t))
  -> ~ In tid (seq_list t)
  -> sto_trace (trace_filter_tid tid t ++ create_serialized_trace t (seq_list t)).
Proof.
  intros.
  assert (~ In (tid, seq_point) t).
  { intuition. apply trace_seqlist_seqpoint in H2. apply H1 in H2. auto. }
  assert (~ In (tid, seq_point) (trace_filter_tid tid t)).
  { unfold trace_filter_tid.
    intuition.
    apply filter_In in H3.
    destruct H3. apply H2 in H3. auto. }
  induction (trace_filter_tid tid t).
  simpl. auto.
  destruct a.
  simpl in H3. apply not_or_and in H3. destruct H3.
  apply IHt0 in H4.
Admitted.
 *)

Lemma sto_trace_single tid t:
  sto_trace ((tid, seq_point) :: t)
  -> sto_trace (create_serialized_trace t (seq_list t))
  -> sto_trace ((trace_filter_tid tid ((tid, seq_point) :: t)) ++ (create_serialized_trace t (seq_list t))).
Proof.
  intros; simpl.
  rewrite <- beq_nat_refl.
  inversion H.
  induction H.

Admitted.

Lemma is_sto_trace trace:
  sto_trace trace ->
  sto_trace (create_serialized_trace trace (seq_list trace)).
Proof.
  intros.
  induction H; simpl.
  auto.

  apply start_txn_step in H; [ | auto].
  apply serial_action_helper in H. simpl in H. rewrite <- H in IHsto_trace. auto. split; intuition; inversion H1.

  apply read_item_step in H; [ | auto | auto].
  apply serial_action_helper in H. simpl in H. rewrite <- H in IHsto_trace. auto. split; intuition; inversion H2.

  apply write_item_step with (val := val) in H; [ | auto].
  apply serial_action_helper in H. simpl in H. rewrite <- H in IHsto_trace. auto. split; intuition; inversion H1.

  apply try_commit_txn_step in H; [ | auto].
  apply serial_action_helper in H. simpl in H. rewrite <- H in IHsto_trace. auto. split; intuition; inversion H1.

  apply lock_write_item_step in H; [ | auto | auto | auto].
  apply serial_action_helper in H. simpl in H. rewrite <- H in IHsto_trace. auto. split; intuition; inversion H3.

  apply validate_read_item_step in H; [ | auto| auto].
  apply serial_action_helper in H. simpl in H. rewrite <- H in IHsto_trace. auto. split; intuition; inversion H2; inversion H0.

  apply abort_txn_step in H; [ | auto].
  apply serial_action_helper in H. simpl in H. rewrite <- H in IHsto_trace. auto. split; intuition; inversion H1.

  rewrite <- beq_nat_refl.
  apply seq_point_step in H; [ | auto | auto].
  apply sto_trace_single with (tid0 := tid0) in IHsto_trace.
  unfold trace_filter_tid in IHsto_trace. simpl in IHsto_trace.
  rewrite <- beq_nat_refl in IHsto_trace. unfold trace_filter_tid.
  assert (sto_trace ((tid0, seq_point) :: t)). { auto. }
  apply seq_list_no_two_seqpoint in H.
  assert (~ In (tid0, seq_point) t -> ~ In tid0 (seq_list t)).
  { intuition. apply trace_seqlist_seqpoint_rev in H4. apply H3 in H4. auto. }
  apply H3 in H.
  apply serial_action_remove with (action0 := seq_point) in H; [ | auto].
   rewrite <- H in IHsto_trace. auto. auto.

  apply complete_write_item_step in H; [ | auto | auto].
  admit.

  apply commit_txn_step in H; [ | auto].

  admit.
Admitted.

Lemma check_app a tr:
  check_is_serial_trace (a :: tr) -> check_is_serial_trace tr.
Proof.
  intros.
  destruct a. destruct tr.
  auto. destruct p. destruct tr.
  simpl. auto. simpl in H.
  destruct (Nat.eq_dec t0 t).
  subst. rewrite <- beq_nat_refl in H. simpl in *.
  destruct H. auto.
  rewrite <- Nat.eqb_neq in n. rewrite n in H. simpl in *.
  destruct H. auto.
Qed.

Lemma check_split_right tr1 tr2:
  check_is_serial_trace (tr1 ++ tr2)
  -> check_is_serial_trace tr2.
Proof.
  intros.
  induction tr1.
  rewrite app_nil_l in H. auto.
  simpl in H. apply check_app in H. apply IHtr1 in H. auto.
Qed.
(*
Eval compute in check_is_serial_trace [(2, commit_txn 1); (2, seq_point); (2, complete_write_item 1); (2, validate_read_item True); (2, lock_write_item); (2, try_commit_txn); (2, write_item 4); (2, read_item 0); (2, start_txn); (3, commit_txn 1); (3, seq_point); (3, validate_read_item True); (3, try_commit_txn); (3, read_item 1); (3, start_txn)].

Eval compute in check_is_serial_trace [(3, commit_txn 1); (3, seq_point); (3, validate_read_item True); (3, try_commit_txn); (3, read_item 1); (3, start_txn); (1, abort_txn); (1, validate_read_item False); (1, try_commit_txn); (2, commit_txn 1); (2, seq_point); (2, complete_write_item 1); (2, validate_read_item True); (2, lock_write_item); (2, try_commit_txn); (2, write_item 4); (1, read_item 0); (2, read_item 0);  (2, start_txn); (1, start_txn)].
*)
Eval compute in check_is_serial_trace example_txn.

(***************************************************)
Lemma is_serial trace:
  sto_trace trace ->
  check_is_serial_trace (create_serialized_trace trace (seq_list trace)).
Proof.
  intros.
  induction H.
  simpl. auto.
  simpl. apply start_txn_step with (tid0 := tid0) in H0. rewrite serial_action_helper; auto. split; intuition; inversion H1. auto.
  simpl. apply read_item_step with (tid := tid0) (val:= val) (oldver:= oldver) in H0. rewrite serial_action_helper; auto. split; intuition; inversion H2; inversion H. auto. auto.
  simpl. apply write_item_step with (tid := tid0) (oldval:= oldval) (ver:= ver) (val:= val) in H0. rewrite serial_action_helper; auto. split; intuition; inversion H1; inversion H. auto.
  simpl. apply try_commit_txn_step with (tid := tid0) (ver:= ver) (val:= val) in H0. rewrite serial_action_helper; auto. split; intuition; inversion H1; inversion H. auto.
  simpl. apply lock_write_item_step with (tid := tid0) in H0. rewrite serial_action_helper; auto. split; intuition; inversion H3; inversion H. auto. auto. auto.
  simpl. apply validate_read_item_step with (tid := tid0) in H0. rewrite serial_action_helper; auto. split; intuition; inversion H2; inversion H. auto. auto.
  simpl. apply abort_txn_step with (tid := tid0) in H0. rewrite serial_action_helper; auto. split; intuition; inversion H1. auto.
  simpl. rewrite <- beq_nat_refl.
  apply seq_point_step with (tid := tid0) in H1; [ | auto| auto].
  assert (sto_trace ((tid0, seq_point) :: t)). { auto. }
  apply seq_list_no_two_seqpoint in H1.
  assert (~ In (tid0, seq_point) t -> ~ In tid0 (seq_list t)).
  { intuition; apply trace_seqlist_seqpoint_rev in H4; apply H3 in H4; auto. }
  apply H3 in H1.
  apply serial_action_remove with (action0 := seq_point) in H1; [ | auto].
  admit.

  simpl. apply complete_write_item_step with (tid := tid0) in H0; [ | auto | auto].
  admit.

  simpl. apply commit_txn_step with (tid := tid0) (ver:= ver) in H0; [ | auto].
  admit.

Admitted.
(***************************************************)

Lemma write_sync_list_unchanged_noseq :
  forall t tid a, sto_trace ((tid, a)::t) ->
  a = start_txn ->
  get_write_value_out t = get_write_value_out ((tid, a)::t).
Proof.
  intros.
  unfold get_write_value_out.
  subst. simpl.
  induction (seq_list t).
  simpl. auto.
  simpl.
  destruct (Nat.eq_dec tid0 a).
  - subst. rewrite <- beq_nat_refl. rewrite IHl. intuition.
  - rewrite <- Nat.eqb_neq in n. rewrite n. rewrite IHl. auto.
Qed.

Lemma write_sync_list_unchanged_noseq2 :
  forall t tid a, sto_trace ((tid, a)::t) ->
  a <> seq_point ->
  get_write_value_out t = get_write_value_out ((tid, a)::t).
Proof.
  intros.
  unfold get_write_value_out.
  subst. destruct a. simpl.
  induction (seq_list t).
  simpl. auto.
  simpl.
  destruct (Nat.eq_dec tid0 a).
  - subst. rewrite <- beq_nat_refl. rewrite IHl. intuition.
  - rewrite <- Nat.eqb_neq in n. rewrite n. rewrite IHl. auto.
Admitted.

(*
A STO-trace and its serial trace should have the same writes.
**************************************************
Should we prove that create_serialized_trace function actually prove the correct serial trace of the
STO-trace
**************************************************
*)

(***************************************************)
Lemma write_consistency trace:
  sto_trace trace
  -> sto_trace (create_serialized_trace trace (seq_list trace))
  -> check_is_serial_trace (create_serialized_trace trace (seq_list trace))
  -> write_synchronization trace (create_serialized_trace trace (seq_list trace)).

Proof.
  intros.
  induction H.
  - unfold write_synchronization; unfold get_write_value_out; simpl; auto.
  - unfold write_synchronization. unfold get_write_value_out.
    apply start_txn_step in H; [ | auto].
    apply serial_action_helper in H; [ | split].
    unfold tid in H. rewrite H.
Admitted.
(***************************************************)

(*
Now we proceed to the read part of the proof.
*)

(*
A STO-trace and its serial trace should have the same reads.
*)

(***************************************************)
Lemma read_consistency trace:
  sto_trace trace
  -> read_synchronization trace (create_serialized_trace trace (seq_list trace)).
Admitted.
(***************************************************)

(*
The capstone theorem: prove serializability of a sto-trace
*)
Theorem txn_equal t:
  sto_trace t
  -> exists t', sto_trace t'
  -> check_is_serial_trace t'
  -> Exec_Equivalence t t'.
Proof.
  exists (create_serialized_trace t (seq_list t)).
  intros.
  unfold Exec_Equivalence. split.
  apply write_consistency; auto.
  apply read_consistency; auto.
Qed.


Require Coq.Classes.EquivDec.
Require Coq.Lists.List.
Import List.ListNotations.
Require Import Coq.Program.Program.

Require Import Leapfrog.Syntax.
Require Import Leapfrog.FinType.
Require Import Leapfrog.Sum.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.Notations.

Open Scope p4a.

Module BabyIP1.
  Inductive state : Type :=
  | Start
  | ParseUDP
  | ParseTCP.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | HdrIP
  | HdrUDP
  | HdrTCP.

  Definition sz (h: header) : nat :=
    match h with
    | HdrIP => 20
    | HdrUDP => 20
    | HdrTCP => 28
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) :=
    match s with
    | Start =>
      {| st_op := extract(HdrIP);
         st_trans := transition select (| (@EHdr header sz HdrIP)[19 -- 16] |) {{
          [| exact #b|0|0|0|1 |] ==> inl ParseUDP ;;;
          [| exact #b|0|0|0|0 |] ==> inl ParseTCP ;;;
          reject
         }}
      |}
    | ParseUDP =>
      {| st_op := extract(HdrUDP);
         st_trans := transition accept |}
    | ParseTCP =>
      {| st_op := extract(HdrTCP);
         st_trans := transition accept |}
    end.

  Program Definition aut: Syntax.t state _ :=
    {| t_states := states |}.
  Solve All Obligations with (destruct h || destruct s; cbv; Lia.lia).
End BabyIP1.

Module BabyIP2.
  Inductive state :=
  | Start
  | ParseSeq.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | HdrCombi: header
  | HdrSeq: header.
  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition sz (h: header) : nat :=
    match h with
    | HdrCombi => 40
    | HdrSeq => 8
    end.

  Definition states (s: state) :=
    match s with
    | Start =>
      {| st_op := extract(HdrCombi);
         st_trans := transition select (| (EHdr (Hdr_sz := sz) HdrCombi)[19 -- 16] |) {{
          [| exact #b|0|0|0|1 |] ==> accept ;;;
          [| exact #b|0|0|0|0 |] ==> inl ParseSeq ;;;
            reject
        }}
      |}
    | ParseSeq =>
      {| st_op := extract(HdrSeq);
         st_trans := transition accept |}
    end.

  Program Definition aut: Syntax.t state _ :=
    {| t_states := states |}.
  Solve Obligations with (destruct h || destruct s; cbv; Lia.lia).
End BabyIP2.

Module BabyIP.
  Definition aut := Sum.sum BabyIP1.aut BabyIP2.aut.
End BabyIP.


Require Import Hask.Control.Monad.
Require Import FunctionalExtensionality.

Generalizable All Variables.
Set Primitive Projections.

Notation Either := sum (only parsing).
Notation Left   := inl (only parsing).
Notation Right  := inr (only parsing).

Definition isLeft  `(x : a + b) : bool := if x then true else false.
Definition isRight `(x : a + b) : bool := if x then false else true.

Definition either `(f : a -> c) `(g : b -> c) (x : a + b) : c :=
  match x with
  | inl a => f a
  | inr b => g b
  end.

Definition mapLeft `(f : a -> c) `(x : a + b) : c + b :=
  match x with
  | inl l => inl (f l)
  | inr r => inr r
  end.

Definition Either_map {E X Y} (f : X -> Y) (x : Either E X) : Either E Y :=
  match x with
  | Left e   => Left e
  | Right x' => Right (f x')
  end.

Definition Either_ap {E X Y} (f : Either E (X -> Y)) (x : Either E X)
  : Either E Y :=
  match f with
  | Left e   => Left e
  | Right f' => match x with
    | Left e   => Left e
    | Right x' => Right (f' x')
    end
  end.

Definition Either_join {E X} (x : Either E (Either E X)) : Either E X :=
  match x with
  | Left e           => Left e
  | Right (Left e)   => Left e
  | Right (Right x') => Right x'
  end.

#[export]
Instance Either_Functor {E} : Functor (Either E) :=
{ fmap := @Either_map E
}.

#[export]
Instance Either_Applicative {E} : Applicative (Either E) :=
{ is_functor := Either_Functor
; pure := @Right E
; ap := @Either_ap E
}.

#[export]
Instance Either_Monad {E} : Monad (Either E) :=
{ is_applicative := Either_Applicative
; join := @Either_join E
}.

Module EitherLaws.

Include MonadLaws.

#[local] Hint Unfold Either_ap : core.
#[local] Hint Unfold Either_join : core.
#[local] Hint Unfold Either_map : core.

#[global]
Program Instance Either_FunctorLaws {e : Type} :
  FunctorLaws (Either e).
Next Obligation.
  extensionality x.
  now destruct x.
Qed.
Next Obligation.
  extensionality x.
  now destruct x.
Qed.

#[global]
Program Instance Either_ApplicativeLaws {e : Type} :
  ApplicativeLaws (Either e).
Next Obligation.
  extensionality x.
  now destruct x.
Qed.
Next Obligation.
  now destruct u, w, v.
Qed.

#[global]
Program Instance Either_MonadLaws {e : Type} :
  MonadLaws (Either e) := {|
    has_applicative_laws := Either_ApplicativeLaws
|}.
Next Obligation.
  extensionality x.
  destruct x; auto.
  destruct s; auto.
  now destruct s.
Qed.
Next Obligation.
  extensionality x.
  now destruct x.
Qed.
Next Obligation.
  extensionality x.
  now destruct x.
Qed.
Next Obligation.
  extensionality x.
  destruct x; auto.
  now destruct s.
Qed.

End EitherLaws.