(**
_AUTHOR_

<<
Zhi Zhang
Department of Computer and Information Sciences
Kansas State University
zhangzhi@ksu.edu
>>
*)

Require Export rt.
Require Export ast_rt.
Require Export ast_util.
Require Export eval.

Import STACK.

(** * Run-Time Check Evaluation + RT *)
(** do run time checks according to the run-time check decorations  *)
(*
Inductive do_flagged_check_on_binop: check_flag -> binary_operator -> value -> value -> Ret value -> Prop :=
    | OverflowCheckBinop: forall op v1 v2 v v',
        op = Plus \/ op = Minus \/ op = Multiply \/ op = Divide ->
        Math.binary_operation op v1 v2 = Some (Int v) ->
        overflowCheck v v' ->
        do_flagged_check_on_binop OverflowCheck op v1 v2 v'
    | DivCheckBinop: forall op v1 v2 v,
        op = Divide \/ op = Modulus ->
        divCheck op v1 v2 v ->
        do_flagged_check_on_binop DivCheck op (Int v1) (Int v2) v.

Inductive do_flagged_check_on_unop: check_flag -> unary_operator -> value -> Ret value -> Prop :=
    | OverflowCheckUnop: forall v v' v'',
        Math.unary_minus v = Some (Int v') ->
        overflowCheck v' v'' ->
        do_flagged_check_on_unop OverflowCheck Unary_Minus v v''.

Inductive do_flagged_checks_on_binop: check_flags -> binary_operator -> value -> value -> Ret value -> Prop :=
    | Do_Check_Binop_Nil: forall op v1 v2 v,
        Math.binary_operation op v1 v2 = Some v ->
        do_flagged_checks_on_binop nil op v1 v2 (OK v)
    | Do_Checks_Binop_RTE: forall ck op v1 v2 msg cks,
        do_flagged_check_on_binop ck op v1 v2 (RTE msg) ->
        do_flagged_checks_on_binop (ck :: cks) op v1 v2 (RTE msg)
    | Do_Checks_Binop: forall ck op v1 v2 v cks v',
        do_flagged_check_on_binop ck op v1 v2 (OK v) ->
        do_flagged_checks_on_binop cks op v1 v2 v' ->
        do_flagged_checks_on_binop (ck :: cks) op v1 v2 v'.

Inductive do_flagged_checks_on_unop: check_flags -> unary_operator -> value -> Ret value -> Prop :=
    | Do_Check_Unop_Nil: forall op v v',
        Math.unary_operation op v = Some v' ->
        do_flagged_checks_on_unop nil op v (OK v')
    | Do_Checks_Unop_RTE: forall ck op v msg cks,
        do_flagged_check_on_unop ck op v (RTE msg) ->
        do_flagged_checks_on_unop (ck :: cks) op v (RTE msg)
    | Do_Checks_Unop: forall ck op v v' cks v'',
        do_flagged_check_on_unop ck op v (OK v') ->
        do_flagged_checks_on_unop cks op v v'' ->
        do_flagged_checks_on_unop (ck :: cks) op v v''.
*)
Inductive evalBinOpRT: check_flag -> binary_operator -> value -> value -> Ret value -> Prop :=
    | OverflowCheckBinop: forall op v1 v2 v v',
        op = Plus \/ op = Minus \/ op = Multiply \/ op = Divide ->
        Math.binary_operation op v1 v2 = Some (Int v) ->
        overflowCheck v v' ->
        evalBinOpRT OverflowCheck op v1 v2 v'
    | DivCheckBinop: forall op v1 v2 v,
        op = Divide \/ op = Modulus ->
        divCheck op v1 v2 v ->
        evalBinOpRT DivCheck op (Int v1) (Int v2) v.

Inductive evalUnOpRT: check_flag -> unary_operator -> value -> Ret value -> Prop :=
    | OverflowCheckUnop: forall v v' v'',
        Math.unary_minus v = Some (Int v') ->
        overflowCheck v' v'' ->
        evalUnOpRT OverflowCheck Unary_Minus v v''.

(** ** Run-Time Check for Binary Operator + RT *)
Inductive evalBinOpRTS: check_flags -> binary_operator -> value -> value -> Ret value -> Prop :=
    | CheckBinOpNil: forall op v1 v2 v,
        Math.binary_operation op v1 v2 = Some v ->
        evalBinOpRTS nil op v1 v2 (OK v)
    | ChecksBinOpRTE: forall ck op v1 v2 msg cks,
        evalBinOpRT ck op v1 v2 (RTE msg) ->
        evalBinOpRTS (ck :: cks) op v1 v2 (RTE msg)
    | ChecksBinOp: forall ck op v1 v2 v cks v',
        evalBinOpRT ck op v1 v2 (OK v) ->
        evalBinOpRTS cks op v1 v2 v' ->
        evalBinOpRTS (ck :: cks) op v1 v2 v'.

(** ** Run-Time Check for Unary Operator + RT *)
Inductive evalUnOpRTS: check_flags -> unary_operator -> value -> Ret value -> Prop :=
    | Do_Check_Unop_Nil: forall op v v',
        Math.unary_operation op v = Some v' ->
        evalUnOpRTS nil op v (OK v')
    | Do_Checks_Unop_RTE: forall ck op v msg cks,
        evalUnOpRT ck op v (RTE msg) ->
        evalUnOpRTS (ck :: cks) op v (RTE msg)
    | Do_Checks_Unop: forall ck op v v' cks v'',
        evalUnOpRT ck op v (OK v') ->
        evalUnOpRTS cks op v v'' ->
        evalUnOpRTS (ck :: cks) op v v''.

Inductive overflowChecks: check_flags -> Z -> Ret value -> Prop :=
    | OverflowCheck_Nil: forall v,
        overflowChecks nil v (OK (Int v))
    | OverflowCheck_List: forall v v',
        overflowCheck v v' ->
        overflowChecks (OverflowCheck :: nil) v v'.

Inductive rangeChecks: check_flags -> Z -> Z -> Z -> Ret value -> Prop :=
    | RangeCheck_Nil: forall v l u,
        rangeChecks nil v l u (OK (Int v))
    | RangeCheck_List: forall v l u v',
        rangeCheck v l u v' ->
        rangeChecks (RangeCheck :: nil) v l u v'.

(** * Relational Semantics *)

(** ** Evaluation of Literal + RT *)

Inductive evalLiteralRT: check_flags -> literal -> Ret value -> Prop :=
    | EvalLiteralRT_Bool: forall cks v,
        evalLiteralRT cks (Boolean_Literal v) (OK (Bool v))
    | EvalLiteralRT_Int: forall cks v v',
        overflowChecks cks v v' ->
        evalLiteralRT cks (Integer_Literal v) v'.

(** ** Evaluation of Expression + RT *)
(**
    for binary expression and unary expression, if a run-time error
    is detected in any of its child expressions, then Ret a run-time
    error; for binary expression (e1 op e2), if both e1 and e2
    are evaluated to some OK value, then run-time checks are
    performed according to the checking rules specified for the
    operator 'op', whenever the check fails, a run-time error is
    detected and the program is terminated, otherwise, OK binary
    operation result is Reted;

   - in name evaluation evalNameRT, the check flags for name are all nil, e.g.
     (IndexedComponentRT n x_n x e nil), because if there is a
     RangeCheck on the name expression, this range check should be enforced
     by the context where the name expression appears, that's why it's invisible
     during the evaluation of name expression;

     take the assignment (y := x) as an example, if y is a variable of integer
     subtype, and x is a variable of integer, then there should be a RangeCheck
     flag on the right side (x) of the assignment; during the evaluation of the
     assignment, first evaluate the value of x, and then do the range check on the
     value of x against the target subtype range of y, but the RangeCheck should
     be invisible when evaluate the value of x even though the RangeCheck is set
     on the variable x, this range check should be enforced at the assignment level;
     that's why in name evaluation evalNameRT, the check flags for name are all nil;
*)

Inductive evalExpRT: symTabRT -> state -> expRT -> Ret value -> Prop :=
    | EvalLiteralRT: forall l v st s n in_cks ex_cks,
        evalLiteralRT in_cks l v ->
        evalExpRT st s (LiteralRT n l in_cks ex_cks) v
    | EvalNameRT: forall st s nm v n,
        evalNameRT st s nm v ->
        evalExpRT st s (NameRT n nm) v
    | EvalBinOpRTE1_RTE: forall st s e1 msg n op e2 in_cks ex_cks,
        evalExpRT st s e1 (RTE msg) ->
        evalExpRT st s (BinOpRT n op e1 e2 in_cks ex_cks) (RTE msg)
    | EvalBinOpRTE2_RTE: forall st s e1 v1 e2 msg n op in_cks ex_cks,
        evalExpRT st s e1 (OK v1) ->
        evalExpRT st s e2 (RTE msg) ->
        evalExpRT st s (BinOpRT n op e1 e2 in_cks ex_cks) (RTE msg)
    | EvalBinOpRT: forall st s e1 v1 e2 v2 in_cks op v n ex_cks,
        evalExpRT st s e1 (OK v1) ->
        evalExpRT st s e2 (OK v2) ->
        evalBinOpRTS in_cks op v1 v2 v ->
        evalExpRT st s (BinOpRT n op e1 e2 in_cks ex_cks) v
    | EvalUnOpRT_RTE: forall st s e msg n op in_cks ex_cks,
        evalExpRT st s e (RTE msg) ->
        evalExpRT st s (UnOpRT n op e in_cks ex_cks) (RTE msg)
    | EvalUnOpRT: forall st s e v in_cks op v' n ex_cks,
        evalExpRT st s e (OK v) ->
        evalUnOpRTS in_cks op v v' ->
        evalExpRT st s (UnOpRT n op e in_cks ex_cks) v'

(** ** Evaluation of Name + RT *)
with evalNameRT: symTabRT -> state -> nameRT -> Ret value -> Prop :=
    | EvalIdentifierRT: forall x s v st n ex_cks,
        fetchG x s = Some v ->
        evalNameRT st s (IdentifierRT n x ex_cks) (OK v)
    | EvalIndexedComponentRTX_RTE: forall st s x msg n e ex_cks,
        evalNameRT st s x (RTE msg) ->
        evalNameRT st s (IndexedComponentRT n x e ex_cks) (RTE msg)
    | EvalIndexedComponentRTE_RTE: forall st s x a e msg n ex_cks,
        evalNameRT st s x (OK (ArrayV a)) ->
        evalExpRT st s e (RTE msg) ->
        evalNameRT st s (IndexedComponentRT n x e ex_cks) (RTE msg)
    | EvalIndexedComponentRT_Range_RTE: forall st s x a e i t l u n ex_cks,
        evalNameRT st s x (OK (ArrayV a)) ->
        evalExpRT st s e (OK (Int i)) ->
        fetch_exp_type_rt (name_astnum_rt x) st = Some (Array_Type t) ->
        extract_array_index_range_rt st t (RangeRT l u) ->
        rangeChecks (exp_exterior_checks e) i l u (RTE RangeError) ->
        evalNameRT st s (IndexedComponentRT n x e ex_cks) (RTE RangeError)
    | EvalIndexedComponentRT: forall st s x a e i t l u v n ex_cks,
        evalNameRT st s x (OK (ArrayV a)) ->
        evalExpRT st s e (OK (Int i)) ->
        fetch_exp_type_rt (name_astnum_rt x) st = Some (Array_Type t) ->
        extract_array_index_range_rt st t (RangeRT l u) ->
        rangeChecks (exp_exterior_checks e) i l u (OK (Int i)) ->
        array_select a i = Some v ->
        evalNameRT st s (IndexedComponentRT n x e ex_cks) (OK v)
    | EvalSelectedComponentRTX_RTE: forall st s x msg n f ex_cks,
        evalNameRT st s x (RTE msg) ->
        evalNameRT st s (SelectedComponentRT n x f ex_cks) (RTE msg)
    | EvalSelectedComponentRT: forall st s x r f v n ex_cks,
        evalNameRT st s x (OK (RecordV r)) ->
        record_select r f = Some v ->
        evalNameRT st s (SelectedComponentRT n x f ex_cks) (OK v).

(** Inductive semantic of declarations. [eval_decl_x st s f decl f']
    means that [f'] is the frame to be pushed on s after evaluating decl,
    [f] is used as an accumulator for building the frame.
*)

(** ** Evaluation of Declaration + RT *)

Inductive evalDeclRT: symTabRT -> state -> frame -> declRT -> Ret frame -> Prop :=
    | EvalDeclRT_Null: forall st s f,
        evalDeclRT st s f NullDeclRT (OK f)
    | EvalDeclRT_Var_None: forall d st s f n,
        d.(initialization_expRT) = None ->
        evalDeclRT st s f (ObjDeclRT n d) (OK (push f d.(object_nameRT) Undefined))
    | EvalDeclRT_Var_RTE: forall d e st f s msg n,
        d.(initialization_expRT) = Some e ->
        evalExpRT st (f :: s) e (RTE msg) ->
        evalDeclRT st s f (ObjDeclRT n d) (RTE msg)
    | EvalDeclRT_Var_NoCheck: forall d e st f s v n,
        d.(initialization_expRT) = Some e ->
        evalExpRT st (f :: s) e (OK v) ->
        v <> Undefined ->
        exp_exterior_checks e = nil ->
        evalDeclRT st s f (ObjDeclRT n d) (OK (push f d.(object_nameRT) v))
    | EvalDeclRT_Var_Range_RTE: forall d e st f s v l u n,
        d.(initialization_expRT) = Some e ->
        evalExpRT st (f :: s) e (OK (Int v)) ->
        exp_exterior_checks e = RangeCheck :: nil ->
        extract_subtype_range_rt st (d.(object_nominal_subtype_rt)) (RangeRT l u) ->
        rangeCheck v l u (RTE RangeError) ->
        evalDeclRT st s f (ObjDeclRT n d) (RTE RangeError)
    | EvalDeclRT_Var: forall d e st f s v l u n,
        d.(initialization_expRT) = Some e ->
        evalExpRT st (f :: s) e (OK (Int v)) ->
        exp_exterior_checks e = RangeCheck :: nil ->
        extract_subtype_range_rt st (d.(object_nominal_subtype_rt)) (RangeRT l u) ->
        rangeCheck v l u (OK (Int v)) ->
        evalDeclRT st s f (ObjDeclRT n d) (OK (push f d.(object_nameRT) (Int v)))
    | EvalDeclRT_Type: forall st s f n t,
        evalDeclRT st s f (TypeDeclRT n t) (OK f)
    | EvalDeclRT_Proc: forall st s f n p,
        evalDeclRT st s f (ProcBodyDeclRT n p) (OK f)
    | EvalDeclRT_Seq_E: forall st s f d1 msg n d2,
        evalDeclRT st s f d1 (RTE msg) ->
        evalDeclRT st s f (SeqDeclRT n d1 d2) (RTE msg)
    | EvalDeclRT_Seq: forall st s f d1 f' d2 f'' n,
        evalDeclRT st s f d1 (OK f') ->
        evalDeclRT st s f' d2 f'' ->
        evalDeclRT st s f (SeqDeclRT n d1 d2) f''.

(** update name with new value in the state and Ret newly updated state

    the run-time check flags on the name expression will not affect the store update,
    they are only used when the expression is used on the right hand side of assignment;
*)

Inductive storeUpdateRT: symTabRT -> state -> nameRT -> value -> Ret state -> Prop :=
    | SU_Identifier_X: forall s x v s1 st n cks,
        updateG s x v = Some s1 ->
        storeUpdateRT st s (IdentifierRT n x cks) v (OK s1)
    | SU_Indexed_Component_xRTE_X: forall st s x msg n e cks v,
        evalNameRT st s x (RTE msg) ->
        storeUpdateRT st s (IndexedComponentRT n x e cks) v (RTE msg)
    | SU_Indexed_Component_eRTE_X: forall st s x a e msg n cks v,
        evalNameRT st s x (OK (ArrayV a)) \/ evalNameRT st s x (OK Undefined) ->
        evalExpRT st s e (RTE msg) ->
        storeUpdateRT st s (IndexedComponentRT n x e cks) v (RTE msg)
    | SU_Indexed_Component_Range_RTE_X: forall st s x a e i t l u n cks v,
        evalNameRT st s x (OK (ArrayV a)) \/ evalNameRT st s x (OK Undefined) ->
        evalExpRT st s e (OK (Int i)) ->
        fetch_exp_type_rt (name_astnum_rt x) st = Some (Array_Type t) ->
        extract_array_index_range_rt st t (RangeRT l u) ->
        rangeChecks (exp_exterior_checks e) i l u (RTE RangeError) ->
        storeUpdateRT st s (IndexedComponentRT n x e cks) v (RTE RangeError)
    | SU_Indexed_Component_X: forall st s x arrObj a e i t l u v a1 s1 n cks,
        evalNameRT st s x (OK arrObj) ->
        arrObj = (ArrayV a) \/ arrObj = Undefined ->
        evalExpRT st s e (OK (Int i)) ->
        fetch_exp_type_rt (name_astnum_rt x) st = Some (Array_Type t) ->
        extract_array_index_range_rt st t (RangeRT l u) ->
        rangeChecks (exp_exterior_checks e) i l u (OK (Int i)) ->
        arrayUpdate arrObj i v = (Some (ArrayV a1)) ->
        storeUpdateRT st s x (ArrayV a1) s1 ->
        storeUpdateRT st s (IndexedComponentRT n x e cks) v s1
    | SU_Selected_Component_xRTE_X: forall st s x msg n f cks v,
        evalNameRT st s x (RTE msg) ->
        storeUpdateRT st s (SelectedComponentRT n x f cks) v (RTE msg)
    | SU_Selected_Component_X: forall st s x recObj r f v r1 s1 n cks,
        evalNameRT st s x (OK recObj) ->
        recObj = (RecordV r) \/ recObj = Undefined ->
        recordUpdate recObj f v = Some (RecordV r1) ->
        storeUpdateRT st s x (RecordV r1) s1 ->
        storeUpdateRT st s (SelectedComponentRT n x f cks) v s1.

(** ** Evaluation of Statement + RT *)

(** State manipulation for procedure calls and Ret *)

(** *** Copy In + RT *)

Inductive copyInRT: symTabRT -> state -> frame -> list paramSpecRT -> list expRT -> Ret frame -> Prop :=
    | CopyIn_Nil_X : forall st s f,
        copyInRT st s f nil nil (OK f)
    | CopyIn_Mode_In_eRTE_X: forall param st s e msg f lparam le,
        param.(parameter_mode_rt) = In ->
        evalExpRT st s e (RTE msg) ->
        copyInRT st s f (param :: lparam) (e :: le) (RTE msg)
    | CopyIn_Mode_In_NoRangeCheck_X: forall param st s e v f f' lparam le f'',
        param.(parameter_mode_rt) = In ->
        evalExpRT st s e (OK v) ->
        v <> Undefined ->
        exp_exterior_checks e = nil ->
        push f param.(parameter_nameRT) v = f' ->
        copyInRT st s f' lparam le f'' ->
        copyInRT st s f (param :: lparam) (e :: le) f''
    | CopyIn_Mode_In_Range_RTE_X: forall param st s e v l u f lparam le,
        param.(parameter_mode_rt) = In ->
        evalExpRT st s e (OK (Int v)) ->
        exp_exterior_checks e = RangeCheck :: nil ->
        extract_subtype_range_rt st (param.(parameter_subtype_mark_rt)) (RangeRT l u) ->
        rangeCheck v l u (RTE RangeError) ->
        copyInRT st s f (param :: lparam) (e :: le) (RTE RangeError)
    | CopyIn_Mode_In_Range_X: forall param st s e v l u f f' lparam le f'',
        param.(parameter_mode_rt) = In ->
        evalExpRT st s e (OK (Int v)) ->
        exp_exterior_checks e = RangeCheck :: nil ->
        extract_subtype_range_rt st (param.(parameter_subtype_mark_rt)) (RangeRT l u) ->
        rangeCheck v l u (OK (Int v)) ->
        push f param.(parameter_nameRT) (Int v) = f' ->
        copyInRT st s f' lparam le f'' ->
        copyInRT st s f (param :: lparam) (e :: le) f''
    | CopyIn_Mode_InOut_eRTE_X: forall param st s nm msg f lparam n le,
        param.(parameter_mode_rt) = In_Out ->
        evalNameRT st s nm (RTE msg) ->
        copyInRT st s f (param :: lparam) ((NameRT n nm) :: le) (RTE msg)
    | CopyIn_Mode_InOut_NoRange_X: forall param st s nm v f f' lparam le f'' n,
        param.(parameter_mode_rt) = In_Out ->
        evalNameRT st s nm (OK v) ->
        v <> Undefined ->
        ~(List.In RangeCheck (name_exterior_checks nm)) ->
        push f param.(parameter_nameRT) v = f' ->
        copyInRT st s f' lparam le f'' ->
        copyInRT st s f (param :: lparam) ((NameRT n nm) :: le) f''
    | CopyIn_Mode_InOut_Range_RTE_X: forall param st s nm v l u f lparam le n,
        param.(parameter_mode_rt) = In_Out ->
        evalNameRT st s nm (OK (Int v)) ->
        List.In RangeCheck (name_exterior_checks nm) -> (*n may have both RangeCheck and RangeCheck_On_CopyOut*)
        extract_subtype_range_rt st (param.(parameter_subtype_mark_rt)) (RangeRT l u) ->
        rangeCheck v l u (RTE RangeError) ->
        copyInRT st s f (param :: lparam) ((NameRT n nm) :: le) (RTE RangeError)
    | CopyIn_Mode_InOut_Range_X: forall param st s nm v l u f f' lparam le f'' n,
        param.(parameter_mode_rt) = In_Out ->
        evalNameRT st s nm (OK (Int v)) ->
        List.In RangeCheck (name_exterior_checks nm) ->
        extract_subtype_range_rt st (param.(parameter_subtype_mark_rt)) (RangeRT l u) ->
        rangeCheck v l u (OK (Int v)) ->
        push f param.(parameter_nameRT) (Int v) = f' ->
        copyInRT st s f' lparam le f'' ->
        copyInRT st s f (param :: lparam) ((NameRT n nm) :: le) f''
    | CopyIn_Mode_Out_X: forall param f f' st s lparam le f'' n nm,
        param.(parameter_mode_rt) = Out ->
        push f param.(parameter_nameRT) Undefined = f' ->
        copyInRT st s f' lparam le f'' ->
        copyInRT st s f (param :: lparam) ((NameRT n nm) :: le) f''.

(** *** Copy Out + RT *)

Inductive copyOutRT: symTabRT -> state -> frame -> list paramSpecRT -> list expRT -> Ret state -> Prop :=
    | CopyOut_Nil_X : forall st s f,
        copyOutRT st s f nil nil (OK s)
    | CopyOut_Mode_Out_nRTE_X: forall param f v nm st s msg lparam lexp n,
        param.(parameter_mode_rt) = Out \/ param.(parameter_mode_rt) = In_Out ->
        fetch param.(parameter_nameRT) f = Some v ->
        v <> Undefined ->
        ~(List.In RangeCheckOnReturn (name_exterior_checks nm)) ->
        storeUpdateRT st s nm v (RTE msg) ->
        copyOutRT st s f (param :: lparam) ((NameRT n nm) :: lexp) (RTE msg)
    | CopyOut_Mode_Out_NoRange_X: forall param f v nm st s s' lparam lexp s'' n,
        param.(parameter_mode_rt) = Out \/ param.(parameter_mode_rt) = In_Out ->
        fetch param.(parameter_nameRT) f = Some v ->
        v <> Undefined ->
        ~(List.In RangeCheckOnReturn (name_exterior_checks nm)) ->
        storeUpdateRT st s nm v (OK s') ->
        copyOutRT st s' f lparam lexp s'' ->
        copyOutRT st s f (param :: lparam) ((NameRT n nm) :: lexp) s''
    | CopyOut_Mode_Out_Range_RTE_X: forall param f v nm n st t l u s lparam lexp,
        param.(parameter_mode_rt) = Out \/ param.(parameter_mode_rt) = In_Out ->
        fetch param.(parameter_nameRT) f = Some (Int v) ->
        List.In RangeCheckOnReturn (name_exterior_checks nm) ->
        fetch_exp_type_rt n st = Some t ->
        extract_subtype_range_rt st t (RangeRT l u) ->
        rangeCheck v l u (RTE RangeError) ->
        copyOutRT st s f (param :: lparam) ((NameRT n nm) :: lexp) (RTE RangeError)
    | CopyOut_Mode_Out_Range_nRTE_X: forall param f v nm n st t l u s msg lparam lexp,
        param.(parameter_mode_rt) = Out \/ param.(parameter_mode_rt) = In_Out ->
        fetch param.(parameter_nameRT) f = Some (Int v) ->
        List.In RangeCheckOnReturn (name_exterior_checks nm) ->
        fetch_exp_type_rt n st = Some t ->
        extract_subtype_range_rt st t (RangeRT l u) ->
        rangeCheck v l u (OK (Int v)) ->
        storeUpdateRT st s nm (Int v) (RTE msg) ->
        copyOutRT st s f (param :: lparam) ((NameRT n nm) :: lexp) (RTE msg)
    | CopyOut_Mode_Out_Range_X: forall param f v nm n st t l u s s' lparam lexp s'',
        param.(parameter_mode_rt) = Out \/ param.(parameter_mode_rt) = In_Out ->
        fetch param.(parameter_nameRT) f = Some (Int v) ->
        List.In RangeCheckOnReturn (name_exterior_checks nm) ->
        fetch_exp_type_rt n st = Some t ->
        extract_subtype_range_rt st t (RangeRT l u) ->
        rangeCheck v l u (OK (Int v)) ->
        storeUpdateRT st s nm (Int v) (OK s') ->
        copyOutRT st s' f lparam lexp s'' ->
        copyOutRT st s f (param :: lparam) ((NameRT n nm) :: lexp) s''
    | CopyOut_Mode_In_X: forall param st s f lparam lexp s' e,
        param.(parameter_mode_rt) = In ->
        copyOutRT st s f lparam lexp s' ->
        copyOutRT st s f (param :: lparam) (e :: lexp) s'.

(** Inductive semantic of statement and declaration

   in a statement evaluation, whenever a run time error is detected in
   the evaluation of its sub-statements or sub-component, the
   evaluation is terminated and Ret a run-time error; otherwise,
   evaluate the statement into a OK state.

   - in the evaluation for assignment statement (AssignRT n x e),

     first, check if there is a RangeCheck flag on the right side (e) of
     the assignment,
     case 1: ~(List.In RangeCheck (exp_check_flags e)) means
     no range check needed for the value of expression e,
     case 2: (exp_check_flags e = cks1 ++ RangeCheck :: cks2) means
     a range check required on the value of expression e;

     second, if there is no range check required for e, then do expression
     evaluation directly on e and update the value of x if there is no run-time
     errors during their evaluation;
     if there is a range check required for e, then a range check should be
     performed on the evaluation value of e before it's assigned to the left side
     (x) of the assignment;

     please note that the range check for the value of expression e is verified
     against the target type taken from the left side (x) of the assignment, that's
     why the range check for expression e is enforced at the level of assignment
     statement even though the RangeCheck flag is set on the expression e, and
     that's also why we remove the RangeCheck flag from e's run-time check flag
     set before the evaluation of e;

   - in the store update storeUpdateRT for indexed component (e.g. a(i):=v) or selected
     component (e.g. r.f := v),

     if the value of array a (or value of record r) is Undefined, then create a new
     aggregate array value with its ith element having value v (or create a new record
     value with its field f having value v), and assign this new aggregate value to array
     variable a (or record variable r);

     if the value of array a (or value of record r) is already defined, then update the
     ith element of its array value (or update the filed f of its record value), and assign
     the updated aggregate value to array variable a (or record variable r);

   - in the store update storeUpdateRT for indexed component (e.g. a(i):=v), a
     range check may be required on the value of index expression i if RangeCheck
     is set for it, and the range check should be performed for the value of i before
     it's used to update the array value;
 *)

(** *** evalStmtRT *)
Inductive evalStmtRT: symTabRT -> state -> stmtRT -> Ret state -> Prop :=
    | EvalNullRT: forall st s,
        evalStmtRT st s NullRT (OK s)
    | EvalAssignRT_RTE: forall st s e msg n x,
        evalExpRT st s e (RTE msg) ->
        evalStmtRT st s (AssignRT n x e) (RTE msg)
    | EvalAssignRT: forall st s e v x s1 n,
        evalExpRT st s e (OK v) ->
        v <> Undefined ->
        exp_exterior_checks e = nil ->
        storeUpdateRT st s x v s1 ->
        evalStmtRT st s (AssignRT n x e) s1
    | EvalAssignRT_Range_RTE: forall st s e v x t l u n,
        evalExpRT st s e (OK (Int v)) ->
        exp_exterior_checks e = RangeCheck :: nil ->
        fetch_exp_type_rt (name_astnum_rt x) st = Some t ->
        extract_subtype_range_rt st t (RangeRT l u) ->
        rangeCheck v l u (RTE RangeError) ->
        evalStmtRT st s (AssignRT n x e) (RTE RangeError)
    | EvalAssignRT_Range: forall st s e v x t l u s1 n,
        evalExpRT st s e (OK (Int v)) ->
        exp_exterior_checks e = RangeCheck :: nil ->
        fetch_exp_type_rt (name_astnum_rt x) st = Some t ->
        extract_subtype_range_rt st t (RangeRT l u) ->
        rangeCheck v l u (OK (Int v)) ->
        storeUpdateRT st s x (Int v) s1 ->
        evalStmtRT st s (AssignRT n x e) s1
    | EvalIfRT_RTE: forall st s b msg n c1 c2,
        evalExpRT st s b (RTE msg) ->
        evalStmtRT st s (IfRT n b c1 c2) (RTE msg)
    | EvalIfRT_True: forall st s b c1 s1 n c2,
        evalExpRT st s b (OK (Bool true)) ->
        evalStmtRT st s c1 s1 ->
        evalStmtRT st s (IfRT n b c1 c2) s1
    | EvalIfRT_False: forall st s b c2 s1 n c1,
        evalExpRT st s b (OK (Bool false)) ->
        evalStmtRT st s c2 s1 ->
        evalStmtRT st s (IfRT n b c1 c2) s1
    | EvalWhileRT_RTE: forall st s b msg n c,
        evalExpRT st s b (RTE msg) ->
        evalStmtRT st s (WhileRT n b c) (RTE msg)
    | EvalWhileRT_True_RTE: forall st s b c msg n,
        evalExpRT st s b (OK (Bool true)) ->
        evalStmtRT st s c (RTE msg) ->
        evalStmtRT st s (WhileRT n b c) (RTE msg)
    | EvalWhileRT_True: forall st s b c s1 n s2,
        evalExpRT st s b (OK (Bool true)) ->
        evalStmtRT st s c (OK s1) ->
        evalStmtRT st s1 (WhileRT n b c) s2 ->
        evalStmtRT st s (WhileRT n b c) s2
    | EvalWhileRT_False: forall st s b n c,
        evalExpRT st s b (OK (Bool false)) ->
        evalStmtRT st s (WhileRT n b c) (OK s)
    | EvalCallRT_Args_RTE: forall p st n0 pb s args msg n pn,
        fetch_proc_rt p st = Some (n, pb) ->
        copyInRT st s (newFrame n) (procedure_parameter_profile_rt pb) args (RTE msg) ->
        evalStmtRT st s (CallRT n0 pn p args) (RTE msg)
    | EvalCallRT_Decl_RTE: forall p st n0 pb s args f intact_s s1 msg n pn,
        fetch_proc_rt p st = Some (n, pb) ->
        copyInRT st s (newFrame n) (procedure_parameter_profile_rt pb) args (OK f) ->
        cut_until s n intact_s s1 -> (* s = intact_s ++ s1 *)
        evalDeclRT st s1 f (procedure_declarative_part_rt pb) (RTE msg) ->
        evalStmtRT st s (CallRT n0 pn p args) (RTE msg)
    | EvalCallRT_Body_RTE: forall p st n0 pb s args f intact_s s1 f1 msg n pn,
        fetch_proc_rt p st = Some (n, pb) ->
        copyInRT st s (newFrame n) (procedure_parameter_profile_rt pb) args (OK f) ->
        cut_until s n intact_s s1 -> (* s = intact_s ++ s1 *)
        evalDeclRT st s1 f (procedure_declarative_part_rt pb) (OK f1) ->
        evalStmtRT st (f1 :: s1) (procedure_statements_rt pb) (RTE msg) ->
        evalStmtRT st s (CallRT n0 pn p args) (RTE msg)
    | EvalCallRT: forall p st n0 pb s args f intact_s s1 f1 s2 locals_section params_section s3 s4 n pn,
        fetch_proc_rt p st = Some (n, pb) ->
        copyInRT st s (newFrame n) (procedure_parameter_profile_rt pb) args (OK f) ->
        cut_until s n intact_s s1 -> (* s = intact_s ++ s1 *)
        evalDeclRT st s1 f (procedure_declarative_part_rt pb) (OK f1) ->
        evalStmtRT st (f1 :: s1) (procedure_statements_rt pb) (OK s2) ->
        s2 = (n, locals_section ++ params_section) :: s3 -> (* extract parameters from local frame *)
        List.length (store_of f) = List.length params_section ->
        copyOutRT st (intact_s ++ s3) (n, params_section) (procedure_parameter_profile_rt pb) args s4 ->
        evalStmtRT st s (CallRT n0 pn p args) s4
    | EvalSeqRT_RTE: forall st s c1 msg n c2,
        evalStmtRT st s c1 (RTE msg) ->
        evalStmtRT st s (SeqRT n c1 c2) (RTE msg)
    | EvalSeqRT: forall st s c1 s1 c2 s2 n,
        evalStmtRT st s c1 (OK s1) ->
        evalStmtRT st s1 c2 s2 ->
        evalStmtRT st s (SeqRT n c1 c2) s2.

(** ** evalProgramRT *)
(** the main procedure (with empty parameters) is working as the entry point of the whole program
    - p: is the program
    - p.(mainRT): the main procedure of the program
    - mainProc: the declaration of the main procedure
    - the arguments of the main procedure is nil
*)

Inductive evalProgramRT: symTabRT -> state -> programRT -> Ret state -> Prop :=
    | EvalProgramRT: forall st s p n pn,
        evalStmtRT st nil (CallRT n pn p.(mainRT) nil) s ->
        evalProgramRT st nil p s.

(** * Help Lemmas *)

Lemma eval_exp_ex_cks_added: forall st s e v cks,
  evalExpRT st s e v ->
    evalExpRT st s (update_exterior_checks_exp e cks) v.
Proof.
  intros; destruct e;
  inversion H; smack;
  match goal with
  | [H: evalLiteralRT _ _ _ |- _] => constructor; smack
  | _ => idtac
  end;
  [ |
    apply EvalBinOpRTE1_RTE; auto |
    apply EvalBinOpRTE2_RTE with (v1:=v1); auto |
    apply EvalBinOpRT with (v1:=v1) (v2:=v2); auto |
    apply EvalUnOpRT_RTE; auto |
    apply EvalUnOpRT with (v := v0); auto
  ];
  match goal with
  | [H: evalNameRT _ _ ?n _ |- _] => inversion H; smack; constructor
  end;
  [ apply EvalIdentifierRT; auto |
    apply EvalIndexedComponentRTX_RTE; auto |
    apply EvalIndexedComponentRTE_RTE with (a := a0); auto |
    apply EvalIndexedComponentRT_Range_RTE with (a:=a0) (i:=i) (t:=t) (l:=l) (u:=u); auto |
    apply EvalIndexedComponentRT with (a:=a0) (i:=i) (t:=t) (l:=l) (u:=u); auto |
    apply EvalSelectedComponentRTX_RTE; auto |
    apply EvalSelectedComponentRT with (r:=r); auto
  ].
Qed.

Lemma eval_name_ex_cks_added: forall st s n v cks,
  evalNameRT st s n v ->
    evalNameRT st s (update_exterior_checks_name n cks) v.
Proof.
  intros; destruct n;
  inversion H; smack;
  [ apply EvalIdentifierRT; auto |
    apply EvalIndexedComponentRTX_RTE; auto |
    apply EvalIndexedComponentRTE_RTE with (a:=a0); auto |
    apply EvalIndexedComponentRT_Range_RTE with (a:=a0) (i:=i) (t:=t) (l:=l) (u:=u); auto |
    apply EvalIndexedComponentRT with (a:=a0) (i:=i) (t:=t) (l:=l) (u:=u); auto |
    apply EvalSelectedComponentRTX_RTE; auto |
    apply EvalSelectedComponentRT with (r:=r); auto
  ].
Qed.

Scheme expression_ind := Induction for exp Sort Prop
                         with name_ind := Induction for name Sort Prop.

Scheme expression_x_ind := Induction for expRT Sort Prop
                         with name_x_ind := Induction for nameRT Sort Prop.

Lemma eval_exp_ex_cks_stripped: forall e st s cks v,
  evalExpRT st s (update_exterior_checks_exp e cks) v ->
    evalExpRT st s e v.
Proof.
  apply (expression_x_ind
    (fun e: expRT =>
       forall (st : symTabRT) (s : STACK.state) (cks : exterior_checks) (v : Ret value),
      evalExpRT st s (update_exterior_checks_exp e cks) v ->
      evalExpRT st s e v)
    (fun n: nameRT =>
       forall (st : symTabRT) (s : STACK.state) (cks : exterior_checks) (v : Ret value),
      evalNameRT st s (update_exterior_checks_name n cks) v ->
      evalNameRT st s n v)
    ); intros;
  match goal with
  | [H: evalExpRT _ _ _ _ |- _] => inversion H; subst
  | [H: evalNameRT _ _ _ _ |- _] => inversion H; subst
  end.
- constructor; auto.
- constructor; auto.
  specialize (H _ _ _ _ H6); auto.
- apply EvalBinOpRTE1_RTE.
  rewrite <- (exp_exterior_checks_refl e) in H11.
  specialize (H _ _ _ _ H11); auto.
- apply EvalBinOpRTE2_RTE with (v1 := v1);
  rewrite <- (exp_exterior_checks_refl e) in H11;
  rewrite <- (exp_exterior_checks_refl e0) in H12;
  specialize (H _ _ _ _ H11); auto;
  specialize (H0 _ _ _ _ H12); auto.
- apply EvalBinOpRT with (v1 := v1) (v2 := v2); auto.
- apply EvalUnOpRT_RTE; auto.
- apply EvalUnOpRT with (v := v0); auto.
- constructor; auto.
- apply EvalIndexedComponentRTX_RTE.
  rewrite <- (name_exterior_checks_refl n) in H9;
  specialize (H _ _ _ _ H9); auto.
- apply EvalIndexedComponentRTE_RTE with (a := a0); auto.
- apply EvalIndexedComponentRT_Range_RTE with (a := a0) (i := i) (t := t) (l := l) (u := u); auto.
- apply EvalIndexedComponentRT with (a := a0) (i := i) (t := t) (l := l) (u := u); auto.
- apply EvalSelectedComponentRTX_RTE; auto.
- apply EvalSelectedComponentRT with (r := r); auto.
Qed.

Ltac apply_eval_exp_ex_cks_stripped :=
  match goal with
  | [H: evalExpRT ?st ?s (update_exterior_checks_exp ?e ?cks) ?v |- _] =>
      specialize (eval_exp_ex_cks_stripped _ _ _ _ _ H); let HZ := fresh "HZ" in intro HZ
  end.

Lemma eval_name_ex_cks_stripped: forall n st s cks v,
  evalNameRT st s (update_exterior_checks_name n cks) v ->
      evalNameRT st s n v.
Proof.
  induction n; intros;
  inversion H; subst.
- constructor; auto.
- apply EvalIndexedComponentRTX_RTE; auto.
- apply EvalIndexedComponentRTE_RTE with (a := a0); auto.
- apply EvalIndexedComponentRT_Range_RTE with (a := a0) (i := i) (t := t) (l := l) (u := u); auto.
- apply EvalIndexedComponentRT with (a := a0) (i := i) (t := t) (l := l) (u := u); auto.
- apply EvalSelectedComponentRTX_RTE; auto.
- apply EvalSelectedComponentRT with (r := r); auto.
Qed.

Ltac apply_eval_name_ex_cks_stripped :=
  match goal with
  | [H: evalNameRT ?st ?s (update_exterior_checks_name ?n ?cks) ?v |- _] =>
      specialize (eval_name_ex_cks_stripped _ _ _ _ _ H); let HZ := fresh "HZ" in intro HZ
  end.

(** when the name expression is used as an address to update the store, then its exterior run-time
    check flags will not affect the store update; the run-time check flags are only used when the
    name expression is to be evaluated as a value on the right hand side of assignment;
*)

Lemma store_update_ex_cks_added: forall st s n cks v s',
  storeUpdateRT st s n v s' ->
    storeUpdateRT st s (update_exterior_checks_name n cks) v s'.
Proof.
  induction n; intros;
  inversion H; subst.
- apply SU_Identifier_X; auto.
- apply SU_Indexed_Component_xRTE_X; auto.
- apply SU_Indexed_Component_eRTE_X with (a := a0); auto.
- apply SU_Indexed_Component_Range_RTE_X with (a := a0) (i := i) (t := t) (l := l) (u := u); auto.
- apply SU_Indexed_Component_X with (arrObj := arrObj) (a := a0)
                                    (i := i) (t := t) (l := l) (u := u) (a1 := a1); auto.
- apply SU_Selected_Component_xRTE_X; auto.
- apply SU_Selected_Component_X with (recObj := recObj) (r := r) (r1 :=r1); auto.
Qed.

Ltac apply_store_update_ex_cks_added :=
  match goal with
  | [|- storeUpdateRT _ _ (update_exterior_checks_name _ _) _ _] =>
      apply store_update_ex_cks_added; auto
  end.

Lemma store_update_ex_cks_stripped: forall st s n cks v s',
  storeUpdateRT st s (update_exterior_checks_name n cks) v s' ->
    storeUpdateRT st s n v s'.
Proof.
  induction n; intros;
  inversion H; subst.
- apply SU_Identifier_X; auto.
- apply SU_Indexed_Component_xRTE_X; auto.
- apply SU_Indexed_Component_eRTE_X with (a := a0); auto.
- apply SU_Indexed_Component_Range_RTE_X with (a := a0) (i := i) (t := t) (l := l) (u := u); auto.
- apply SU_Indexed_Component_X with (arrObj := arrObj) (a := a0)
                                    (i := i) (t := t) (l := l) (u := u) (a1 := a1); auto.
- apply SU_Selected_Component_xRTE_X; auto.
- apply SU_Selected_Component_X with (recObj := recObj) (r := r) (r1 :=r1); auto.
Qed.

Ltac apply_store_update_ex_cks_stripped :=
  match goal with
  | [H: storeUpdateRT _ _ (update_exterior_checks_name _ _) _ _ |- _] =>
      specialize (store_update_ex_cks_stripped _ _ _ _ _ _ H);
      let HZ := fresh "HZ" in intro HZ
  end.

(***********************************************************)

Lemma binop_arithm_operand_format: forall cks op v1 v2 v,
  evalBinOpRTS cks op v1 v2 (OK (Int v)) ->
    exists n1 n2, v1 = Int n1 /\ v2 = Int n2.
Proof.
  intros.
  inversion H; subst.
  clear H.
  destruct op; smack;
  destruct v1, v2; smack.
  clear H H1.
  inversion H0; subst.
  destruct op; smack;
  destruct v1, v2; smack.
  destruct v0; destruct v3; inversion H; smack.
Qed.

Ltac apply_binop_arithm_operand_format :=
  match goal with
  | [H: evalBinOpRTS _ _ _ _ (OK (Int _)) |- _] =>
      specialize (binop_arithm_operand_format _ _ _ _ _ H);
      let HZ := fresh "HZ" in
      let HZ1 := fresh "HZ" in
      let HZ2 := fresh "HZ" in
      let n1 := fresh "n" in
      let n2 := fresh "n" in
      intros HZ;
      destruct HZ as [n1 [n2 [HZ1 HZ2]]]
  end.

Lemma unop_arithm_operand_format: forall cks op v v',
  evalUnOpRTS cks op v (OK (Int v')) ->
    exists n, v = Int n.
Proof.
  intros.
  inversion H; subst.
  clear H.
  destruct op; destruct v; smack.
  clear H H1.
  inversion H0; subst.
  destruct v; inversion H; smack.
Qed.

Ltac apply_unop_arithm_operand_format :=
  match goal with
  | [H: evalUnOpRTS _ _ _ (OK (Int _)) |- _] =>
      specialize (unop_arithm_operand_format _ _ _ _ H);
      let HZ := fresh "HZ" in
      let HZ1 := fresh "HZ" in
      let n := fresh "n" in
      intros HZ; destruct HZ as [n HZ1]
  end.


Require Import Verdi.

Section Linearizability.
  Variable K : Type.
  Variable K_eq_dec : forall x y : K, {x = y} + {x <> y}.

  Inductive op : Type :=
  | I : K -> op
  | O : K -> op.

  Definition op_eq_dec :
    forall x y : op, {x = y} + {x <> y}.
  Proof using K_eq_dec.
    decide equality.
  Qed.

  Inductive IR : Type :=
  | IRI : K -> IR
  | IRO : K -> IR
  | IRU : K -> IR.

  Definition IR_eq_dec :
    forall x y : IR, {x = y} + {x <> y}.
  Proof using K_eq_dec.
    decide equality.
  Qed.

  (* Hypothesis trace_NoDup : NoDup trace. *)
  (* also maybe: no Us *)
  (* alse maybe: every O has corresponding I before it *)

  Definition acknowledged_op (k : K) (trace : list op) :=
    In (O k) trace.

  Definition acknowledged_op_dec (k : K) (tr : list op) : {acknowledged_op k tr} + {~acknowledged_op k tr} :=
    in_dec op_eq_dec (O k) tr.

  Inductive acknowledge_all_ops : list op ->  list IR -> Prop :=
  | AAO_nil : acknowledge_all_ops [] []
  | AAO_IU : forall k tr out,
               ~ acknowledged_op k tr ->
               acknowledge_all_ops tr out ->
               acknowledge_all_ops (I k :: tr) (IRI k :: IRU k :: out)
  | AAO_I_dorp : forall k tr out,
                   ~ acknowledged_op k tr ->
                   acknowledge_all_ops tr out ->
                   acknowledge_all_ops (I k :: tr) out
  | AAO_IO : forall k tr out,
               acknowledged_op k tr ->
               acknowledge_all_ops tr out ->
               acknowledge_all_ops (I k :: tr) (IRI k :: out)
  | AAO_O : forall k tr out,
              acknowledge_all_ops tr out ->
              acknowledge_all_ops (O k :: tr) (IRO k :: out).

  Lemma acknowledge_all_ops_was_in :
    forall l ir,
      acknowledge_all_ops l ir ->
      forall k,
        In (IRI k) ir ->
        In (I k) l.
  Proof using.
    induction 1; intros; simpl in *; intuition (auto; congruence).
  Qed.

  Fixpoint acknowledge_all_ops_func (l : list op) (target : list IR) : list IR :=
    match l with
      | [] => []
      | x :: xs => match x with
                     | I k => if acknowledged_op_dec k xs
                              then IRI k :: acknowledge_all_ops_func xs target
                              else if in_dec IR_eq_dec (IRU k) target
                                   then IRI k :: IRU k :: acknowledge_all_ops_func xs target
                                   else acknowledge_all_ops_func xs target
                     | O k => IRO k :: acknowledge_all_ops_func xs target
                   end
    end.

  Hint Constructors acknowledge_all_ops.

  Lemma acknowledge_all_ops_func_defn :
    forall x l target,
      acknowledge_all_ops_func (x :: l) target =
      match x with
        | I k => if acknowledged_op_dec k l
                 then IRI k :: acknowledge_all_ops_func l target
                 else if in_dec IR_eq_dec (IRU k) target
                      then IRI k :: IRU k :: acknowledge_all_ops_func l target
                      else acknowledge_all_ops_func l target
        | O k => IRO k :: acknowledge_all_ops_func l target
      end.
  Proof using.
    intros.
    unfold acknowledge_all_ops_func. repeat break_match; auto.
  Qed.

  Lemma acknowledge_all_ops_func_correct :
    forall l target,
      acknowledge_all_ops l (acknowledge_all_ops_func l target).
  Proof using.
    induction l; intros; simpl; repeat break_match; subst; eauto.
  Qed.

  Lemma acknowledge_all_ops_func_target_ext :
    forall l t t',
      (forall k, In (IRU k) t -> In (IRU k) t') ->
      (forall k, In (IRU k) t' -> In (IRU k) t) ->
      acknowledge_all_ops_func l t = acknowledge_all_ops_func l t'.
  Proof using.
    induction l; simpl in *; repeat break_match; subst; intuition eauto using f_equal.
    repeat break_match; eauto using f_equal; solve [exfalso; eauto].
  Qed.

  Definition good_move (x y : IR) : Prop :=
    (forall k k', ~ (x = IRO k /\ y = IRI k')) /\
    (forall k, ~ (x = IRI k /\ y = IRO k)) /\
    (forall k, ~ (x = IRI k /\ y = IRU k)).

  Inductive IR_equivalent : list IR -> list IR -> Prop :=
  | IR_equiv_nil : IR_equivalent [] []
  | IR_equiv_cons : forall x xs ys,
                   IR_equivalent xs ys ->
                   IR_equivalent (x :: xs) (x :: ys)
  | IR_equiv_move : forall x y xs ys,
                   IR_equivalent xs ys ->
                   good_move x y ->
                   IR_equivalent (x :: y :: xs) (y :: x :: ys)
  | IR_equiv_trans : forall l1 l2 l3,
                    IR_equivalent l1 l2 ->
                    IR_equivalent l2 l3 ->
                    IR_equivalent l1 l3.
  Hint Constructors IR_equivalent.

  Lemma IR_equivalent_refl :
    forall l,
      IR_equivalent l l.
  Proof using.
    induction l; eauto.
  Qed.

  Lemma IR_equiv_in_l_r :
    forall ir1 ir2,
      IR_equivalent ir1 ir2 ->
      forall o,
        In o ir1 -> In o ir2.
  Proof using.
    induction 1; intros; simpl in *; intuition.
  Qed.

  Lemma IR_equiv_in_r_l :
    forall ir1 ir2,
      IR_equivalent ir1 ir2 ->
      forall o,
        In o ir2 -> In o ir1.
  Proof using.
    induction 1; intros; simpl in *; intuition.
  Qed.

  Hint Constructors Permutation.
  Lemma IR_equiv_Permutation :
    forall ir1 ir2,
      IR_equivalent ir1 ir2 ->
      Permutation ir1 ir2.
  Proof using.
    induction 1; eauto.
  Qed.

  Lemma IR_equiv_app_head :
    forall l xs ys,
      IR_equivalent xs ys ->
      IR_equivalent (l ++ xs) (l ++ ys).
  Proof using.
    induction l; intros; simpl; auto.
  Qed.

  Lemma IR_equiv_snoc :
    forall xs ys x,
      IR_equivalent xs ys ->
      IR_equivalent (xs ++ [x]) (ys ++ [x]).
  Proof using.
    induction 1; simpl; eauto.
  Qed.

  Lemma IR_equiv_app_tail :
    forall l xs ys,
      IR_equivalent xs ys ->
      IR_equivalent (xs ++ l) (ys ++ l).
  Proof using.
    induction 1; intros; simpl in *; eauto using IR_equivalent_refl.
  Qed.

  Section Examples.
    Example IR_equiv_eg1 :
      forall k k',
        k <> k' ->
        IR_equivalent [IRI k; IRI k'; IRO k; IRO k'] [IRI k; IRO k; IRI k'; IRO k'].
    Proof using.
      intros.
      constructor.
      econstructor; auto.
      red.
      intuition (auto; congruence).
    Qed.

    Example IR_equiv_eg2 :
      forall k k',
        k <> k' ->
        IR_equivalent [IRI k; IRI k'; IRO k; IRO k'] [IRI k'; IRO k'; IRI k; IRO k].
    Proof using.
      intros.
      eapply IR_equiv_trans with (l2 := [IRI k; IRI k'; IRO k'; IRO k]).
      - repeat constructor; unfold good_move; intuition (try congruence).
      - eapply IR_equiv_trans with (l2 := [IRI k'; IRI k; IRO k'; IRO k]).
        + apply IR_equiv_move; auto using IR_equivalent_refl.
          red. intuition congruence.
        + constructor. apply IR_equiv_move; auto.
          red. intuition congruence.
    Qed.

    Example IR_equiv_eg3 :
      forall k k',
        k <> k' ->
        IR_equivalent [IRI k; IRI k'; IRO k'; IRO k] [IRI k'; IRO k'; IRI k; IRO k].
    Proof using.
      intros.
      eapply IR_equiv_trans with (l2 := [IRI k'; IRI k; IRO k'; IRO k]).
      - constructor.
        + apply IR_equivalent_refl.
        + red. intuition congruence.
      - constructor. constructor.
        + apply IR_equivalent_refl.
        + red. intuition congruence.
    Qed.

    Example IR_equiv_eg4 :
      forall k k',
        k <> k' ->
        IR_equivalent [IRI k; IRI k'; IRO k'; IRO k] [IRI k; IRO k; IRI k'; IRO k'].
    Proof using.
      intros.
      constructor.
      eapply IR_equiv_trans with (l2 := [IRI k'; IRO k; IRO k']).
      - repeat constructor; unfold good_move; intuition congruence.
      - eapply IR_equiv_move; auto.
        red. intuition congruence.
    Qed.
  End Examples.

  Fixpoint good_trace (l : list IR) : Prop :=
    match l with
      | [] => True
      | IRI k :: IRO k' :: l' => k = k' /\ good_trace l'
      | IRI k :: IRU k' :: l' => k = k' /\ good_trace l'
      | _ => False
    end.

  Definition equivalent (l : list op) (ir : list IR) : Prop :=
    good_trace ir /\
    exists ir',
      acknowledge_all_ops l ir' /\
      IR_equivalent ir' ir.

  Lemma acknowledge_all_ops_func_IRU_In :
    forall l ir k,
      In (IRU k) (acknowledge_all_ops_func l ir) ->
      In (I k) l.
  Proof using.
    induction l; intros; simpl in *; repeat break_match; subst; simpl in *;
    intuition (eauto; congruence).
  Qed.

  Definition get_op_input_keys (l : list op) : list K :=
    filterMap (fun x => match x with
                          | I k => Some k
                          | _ => None
                        end) l.

  Lemma get_op_input_keys_defn :
    forall x l,
      get_op_input_keys (x :: l) = match x with
                               | I k => k :: get_op_input_keys l
                               | _ => get_op_input_keys l
                                   end.
  Proof using.
    unfold get_op_input_keys.
    intros.
    simpl. repeat break_match; congruence.
  Qed.

  Definition get_IR_input_keys (l : list IR) : list K :=
    filterMap (fun x => match x with
                          | IRI k => Some k
                          | _ => None
                        end) l.

  Lemma get_IR_input_keys_defn :
    forall x l,
      get_IR_input_keys (x :: l) = match x with
                               | IRI k => k :: get_IR_input_keys l
                               | _ => get_IR_input_keys l
                             end.
  Proof using.
    unfold get_IR_input_keys.
    intros.
    simpl. repeat break_match; congruence.
  Qed.

  Definition get_op_output_keys (l : list op) : list K :=
    filterMap (fun x => match x with
                          | O k => Some k
                          | _ => None
                        end) l.

  Lemma get_op_output_keys_defn :
    forall x l,
      get_op_output_keys (x :: l) = match x with
                                      | O k => k :: get_op_output_keys l
                                      | _ => get_op_output_keys l
                                    end.
  Proof using.
    unfold get_op_output_keys.
    intros.
    simpl.
    repeat break_match; congruence.
  Qed.

  Definition get_IR_output_keys (l : list IR) : list K :=
    filterMap (fun x => match x with
                          | IRO k => Some k
                          | IRU k => Some k
                          | _ => None
                        end) l.

  Lemma get_IR_output_keys_defn :
    forall x l,
      get_IR_output_keys (x :: l) = match x with
                                      | IRO k => k :: get_IR_output_keys l
                                      | IRU k => k :: get_IR_output_keys l
                                      | _ => get_IR_output_keys l
                                    end.
  Proof using.
    unfold get_IR_output_keys.
    intros. simpl. repeat break_match; congruence.
  Qed.

  (* this is cleaner than the auto-generated functional induction scheme *)
  Fixpoint good_trace_ind'
    (P : list IR -> Prop -> Prop)
    (l : list IR) :
      P [] True ->
      (forall k, P [IRI k] False) ->
      (forall k k' l, P (IRI k :: IRI k' :: l) False) ->
      (forall k k' l, P l (good_trace l) -> P (IRI k :: IRO k' :: l) (k = k' /\ good_trace l)) ->
      (forall k k' l, P l (good_trace l) -> P (IRI k :: IRU k' :: l) (k = k' /\ good_trace l)) ->
      (forall k l, P (IRO k :: l) False) ->
      (forall k l, P (IRU k :: l) False) ->
      P l (good_trace l).
  Proof using.
    intros.
    destruct l; simpl; repeat break_match; auto; subst.
    - match goal with
        | [ H : context [IRI _ :: IRO _ :: _ ] |- _ ] => apply H
      end.
      apply good_trace_ind'; auto.
    - match goal with
        | [ H : context [IRI _ :: IRU _ :: _ ] |- _ ] => apply H
      end.
      apply good_trace_ind'; auto.
  Qed.

  Lemma good_trace_ind :
    forall P : list IR -> Prop -> Prop,
      P [] True ->
      (forall k, P [IRI k] False) ->
      (forall k k' ir, P (IRI k :: IRI k' :: ir) False) ->
      (forall k k' ir, P ir (good_trace ir) -> P (IRI k :: IRO k' :: ir) (k = k' /\ good_trace ir)) ->
      (forall k k' ir, P ir (good_trace ir) -> P (IRI k :: IRU k' :: ir) (k = k' /\ good_trace ir)) ->
      (forall k ir, P (IRO k :: ir) False) ->
      (forall k ir, P (IRU k :: ir) False) ->
      forall ir, P ir (good_trace ir).
  Proof using.
    intros.
    apply good_trace_ind'; auto.
  Qed.

  Lemma good_trace_IRI_in :
    forall ir,
      good_trace ir ->
      forall k,
        In (IRI k) ir ->
        In (IRO k) ir \/ In (IRU k) ir.
  Proof using.
    intros ir.
    induction ir, good_trace using good_trace_ind; intros; simpl in *; intuition (auto; try congruence).
    - subst. find_apply_hyp_hyp. intuition.
    - subst. find_apply_hyp_hyp. intuition.
  Qed.

  Lemma acknowledge_all_ops_func_target_nil :
    forall l,
      (forall k, ~ In (O k) l) ->
      acknowledge_all_ops_func l [] = [].
  Proof using.
    induction l; intros; simpl in *.
    - auto.
    - repeat break_match; subst; unfold acknowledged_op in *;
      (exfalso + idtac); solve [intuition eauto].
  Qed.

  Lemma before_head_op :
    forall l h ir,
      (forall k1 k2,
         In (I k2) l ->
         before (O k1) (I k2) l ->
         before (IRO k1) (IRI k2) (IRI h :: ir)) ->
      forall x,
        In (I h) l ->
        before x (I h) l ->
        exists k,
          x = I k.
  Proof using.
    intros. destruct x. eauto.
    eapply_prop_hyp In In; eauto.
    simpl in *. intuition congruence.
  Qed.

  Lemma good_move_II :
    forall k k',
      good_move (IRI k) (IRI k').
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma good_move_OO :
    forall k k',
      good_move (IRO k) (IRO k').
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma IR_equivalent_all_Is_I :
    forall l k,
      (forall x, In x l -> exists k, x = IRI k) ->
      IR_equivalent (l ++ [IRI k]) (IRI k :: l).
  Proof using.
    induction l; intros; simpl in *; intuition.
    apply IR_equiv_trans with (l2 := (a :: IRI k :: l)).
    - auto.
    - specialize (H a). concludes. break_exists. subst.
      auto using IR_equivalent_refl, good_move_II.
  Qed.

  Definition good_op_move (x y : op) : Prop :=
    (forall k k', ~ (x = O k /\ y = I k')) /\
    (forall k, ~ (x = I k /\ y = O k)).

  Inductive op_equivalent : list op -> list op -> Prop :=
  | op_equiv_nil : op_equivalent [] []
  | op_equiv_cons : forall x xs ys, op_equivalent xs ys -> op_equivalent (x :: xs) (x :: ys)
  | op_equiv_move : forall x y xs ys, good_op_move x y ->
                                      op_equivalent xs ys -> op_equivalent (x :: y :: xs) (y :: x :: ys)
  | op_equiv_trans : forall l1 l2 l3, op_equivalent l1 l2 -> op_equivalent l2 l3 -> op_equivalent l1 l3.

  Lemma op_equiv_Permutation :
    forall xs ys,
      op_equivalent xs ys ->
      Permutation xs ys.
  Proof using.
    induction 1; eauto.
  Qed.

  Lemma op_equiv_ack_op_lr :
    forall xs ys,
      op_equivalent xs ys ->
      forall k,
        acknowledged_op k xs ->
        acknowledged_op k ys.
  Proof using.
    unfold acknowledged_op.
    intros.
    eauto using Permutation_in, op_equiv_Permutation.
  Qed.

  Lemma op_equiv_ack_op_rl :
    forall xs ys,
      op_equivalent xs ys ->
      forall k,
        acknowledged_op k ys ->
        acknowledged_op k xs.
  Proof using.
    unfold acknowledged_op.
    intros.
    eauto using Permutation_sym, Permutation_in, op_equiv_Permutation.
  Qed.

  Lemma acknowledged_op_defn :
    forall k xs,
      acknowledged_op k xs ->
      In (O k) xs.
  Proof using.
    auto.
  Qed.

  Lemma good_move_U_l :
    forall k x,
      good_move (IRU k) x.
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma good_move_IU_neq :
    forall k k',
      k <> k' ->
      good_move (IRI k) (IRU k').
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma good_move_IO_neq :
    forall k k',
      k <> k' ->
      good_move (IRI k) (IRO k').
  Proof using.
    red. intuition congruence.
  Qed.

  Hint Resolve IR_equivalent_refl.
  Hint Resolve good_move_II.
  Hint Resolve good_move_U_l.

  Lemma not_good_op_move_IO :
    forall k,
      good_op_move (I k) (O k) -> False.
  Proof using.
    unfold good_op_move.
    intuition eauto.
  Qed.

  Lemma not_good_op_move_OI :
    forall k k',
      good_op_move (O k) (I k') -> False.
  Proof using.
    unfold good_op_move.
    intuition eauto.
  Qed.

  Lemma good_op_move_good_move_IO :
    forall k k',
      good_op_move (I k) (O k') ->
      good_move (IRI k) (IRO k').
  Proof using.
    unfold good_op_move, good_move.
    intuition (try congruence). repeat find_inversion. eauto.
  Qed.

  Lemma good_op_move_cases :
    forall x y,
      good_op_move x y ->
      exists k k',
        (x = I k /\ y = I k') \/
        (x = O k /\ y = O k') \/
        (k <> k' /\ x = I k /\ y = O k').
  Proof using.
    unfold good_op_move. intros.
    destruct x as [k|k], y as [k'|k']; exists k, k'; intuition.
    - right. right. intuition. subst. eauto.
    - exfalso. eauto.
  Qed.

  Lemma acknowledged_op_I_cons_reduce :
    forall k k' l,
      acknowledged_op k (I k' :: l) ->
      acknowledged_op k l.
  Proof using.
    unfold acknowledged_op.
    simpl. intuition congruence.
  Qed.

  Lemma acknowledged_op_I_cons_expand :
    forall k k' l,
      acknowledged_op k l ->
      acknowledged_op k (I k' :: l).
  Proof using.
    unfold acknowledged_op.
    simpl. intuition congruence.
  Qed.

  Hint Constructors op_equivalent.

  Lemma IR_equiv_AAOF_I :
    forall k xs ys target,
      op_equivalent xs ys ->
      IR_equivalent (acknowledge_all_ops_func xs target)
                    (acknowledge_all_ops_func ys target) ->
      IR_equivalent (acknowledge_all_ops_func (I k :: xs) target)
                    (acknowledge_all_ops_func (I k :: ys) target).
  Proof using.
    intros.
    simpl.
    repeat break_match; auto;
    exfalso; eauto using op_equiv_ack_op_lr, op_equiv_ack_op_rl.
  Qed.

  Lemma IR_equiv_AAOF_II_neq :
    forall xs ys target k k',
      k <> k' ->
      op_equivalent xs ys ->
      IR_equivalent (acknowledge_all_ops_func xs target)
                    (acknowledge_all_ops_func ys target) ->
      IR_equivalent (acknowledge_all_ops_func (I k :: I k' :: xs) target)
                    (acknowledge_all_ops_func (I k' :: I k :: ys) target).
  Proof using.
    intros.
    rewrite acknowledge_all_ops_func_defn.
    break_if.
    - rewrite acknowledge_all_ops_func_defn.
      break_if; rewrite acknowledge_all_ops_func_defn with (l := _ :: _).
      + rewrite if_decider_true by
                  eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                              acknowledged_op_I_cons_reduce.
        rewrite acknowledge_all_ops_func_defn.
        rewrite if_decider_true by
            eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                        acknowledged_op_I_cons_reduce.
        auto.
      + rewrite if_decider_false with (dec := acknowledged_op_dec _) by
        intuition eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                              acknowledged_op_I_cons_reduce.
        rewrite acknowledge_all_ops_func_defn.
        rewrite if_decider_true with (dec := acknowledged_op_dec _) by
            eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                              acknowledged_op_I_cons_reduce.
        break_if.
        * eauto 6 using good_move_IU_neq.
        * auto.
    - break_if; rewrite acknowledge_all_ops_func_defn.
      + break_if; rewrite acknowledge_all_ops_func_defn.
        * rewrite if_decider_true by
              eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                            acknowledged_op_I_cons_reduce.
          rewrite acknowledge_all_ops_func_defn.
          rewrite if_decider_false by
              intuition eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                            acknowledged_op_I_cons_reduce.
          rewrite if_decider_true by auto.
          eauto.
        * rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
              acknowledged_op_I_cons_reduce.
          rewrite acknowledge_all_ops_func_defn.
          rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
              acknowledged_op_I_cons_reduce.
          rewrite if_decider_true with (dec := in_dec _ (IRU k)) by auto.
          { break_if.
            - eapply IR_equiv_trans; [apply IR_equiv_cons; apply IR_equiv_move; auto|].
              eapply IR_equiv_trans; [apply IR_equiv_move; auto|]. constructor.
              eapply IR_equiv_trans; [apply IR_equiv_cons; apply IR_equiv_move; auto|].
              auto using good_move_IU_neq.
            - auto.
          }
      + break_if; rewrite acknowledge_all_ops_func_defn.
        * rewrite if_decider_true with (dec := acknowledged_op_dec _) by
              eauto 3 using acknowledged_op_I_cons_expand, op_equiv_ack_op_lr,
                  acknowledged_op_I_cons_reduce.
          rewrite acknowledge_all_ops_func_defn.
          rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                  acknowledged_op_I_cons_reduce.
          rewrite if_decider_false by auto.
          auto.
        * rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                  acknowledged_op_I_cons_reduce.
           rewrite acknowledge_all_ops_func_defn.
           rewrite if_decider_false with (dec := acknowledged_op_dec _) by
              eauto using acknowledged_op_I_cons_expand, op_equiv_ack_op_rl,
                  acknowledged_op_I_cons_reduce.
           rewrite if_decider_false with (dec := in_dec _ (IRU k)) by auto.
           break_if; auto.
  Qed.

  Lemma op_equiv_AAOF_IR_equiv :
    forall xs ys,
      op_equivalent xs ys ->
      forall l,
        IR_equivalent (acknowledge_all_ops_func xs l) (acknowledge_all_ops_func ys l).
  Proof using.
    induction 1; intros.
    - auto.
    - simpl.
      repeat break_match; subst; auto;
      exfalso; eauto using op_equiv_ack_op_lr, op_equiv_ack_op_rl.
    - find_copy_apply_lem_hyp good_op_move_cases. break_exists. intuition; subst.
      + destruct (K_eq_dec x0 x1).
        * subst. auto using IR_equiv_AAOF_I.
        * auto using IR_equiv_AAOF_II_neq.
      + simpl. eauto using good_move_OO.
      + simpl. repeat break_match; intuition; try congruence.
        * eauto using good_move_IO_neq.
        * exfalso. eauto using op_equiv_ack_op_lr.
        * exfalso. eauto using op_equiv_ack_op_lr.
        * exfalso; eauto using Permutation_in, op_equiv_Permutation, acknowledged_op_defn, Permutation_sym.
        * eapply IR_equiv_trans; [apply IR_equiv_cons; apply IR_equiv_move; auto|].
          eapply IR_equiv_trans; [apply IR_equiv_move; auto|]. apply good_move_IO_neq. congruence.
          auto.
        * exfalso.
          match goal with
            | [ H : In (O _) _ -> False |- _ ] => apply H
          end.
          eapply Permutation_in; [apply Permutation_sym; eapply op_equiv_Permutation; eauto|].
          auto using acknowledged_op_defn.
    - eauto.
  Qed.

  Lemma op_equivalent_refl :
    forall xs,
      op_equivalent xs xs.
  Proof using.
    induction xs; auto.
  Qed.

  Lemma good_op_move_II :
    forall k k',
      good_op_move (I k) (I k').
  Proof using.
    red. intuition congruence.
  Qed.

  Lemma op_equivalent_all_Is_I :
    forall l k,
      (forall x, In x l -> exists k, x = I k) ->
      op_equivalent (l ++ [I k]) (I k :: l).
  Proof using.
    induction l; intros; simpl in *; intuition.
    apply op_equiv_trans with (l2 := (a :: I k :: l)).
    - auto.
    - specialize (H a). concludes. break_exists. subst.
      auto using op_equivalent_refl, good_op_move_II.
  Qed.

  Lemma good_op_move_neq_IO :
    forall k k',
      k <> k' ->
      good_op_move (I k) (O k').
  Proof using.
    unfold good_op_move.
    intuition congruence.
  Qed.

  Lemma good_op_move_OO :
    forall k k',
      good_op_move (O k) (O k').
  Proof using.
    unfold good_op_move.
    intuition congruence.
  Qed.

  Lemma op_equivalent_all_Is_O :
    forall l k,
      (forall k', In (I k') l -> k <> k') ->
      op_equivalent (l ++ [O k]) (O k :: l).
  Proof using.
    induction l; intros; simpl in *; intuition.
    apply op_equiv_trans with (l2 := (a :: O k :: l)).
    - eauto 10.
    - destruct a.
      + eauto 6 using good_op_move_neq_IO, op_equivalent_refl.
      + eauto 6 using good_op_move_OO, op_equivalent_refl.
  Qed.

  Lemma op_equiv_app_tail :
    forall l xs ys,
      op_equivalent xs ys ->
      op_equivalent (xs ++ l) (ys ++ l).
  Proof using.
    induction 1; intros; simpl in *; intuition.
    - auto using op_equivalent_refl.
    - eauto.
  Qed.

  Lemma op_equivalent_all_Is_I_middle :
    forall xs ys k,
      (forall x, In x xs -> exists k, x = I k) ->
      op_equivalent (xs ++ I k :: ys) (I k :: xs ++ ys).
  Proof using.
    intros.
    rewrite app_comm_cons.
    replace (xs ++ I k :: ys) with ((xs ++ [I k]) ++ ys) by now rewrite app_ass.
    auto using op_equiv_app_tail, op_equivalent_all_Is_I.
  Qed.

  Lemma get_op_input_keys_app :
    forall xs ys,
      get_op_input_keys (xs ++ ys) = get_op_input_keys xs ++ get_op_input_keys ys.
  Proof using.
    intros.
    apply filterMap_app.
  Qed.

  Lemma get_op_output_keys_app :
    forall xs ys,
      get_op_output_keys (xs ++ ys) = get_op_output_keys xs ++ get_op_output_keys ys.
  Proof using.
    intros.
    apply filterMap_app.
  Qed.

  Lemma get_op_input_keys_complete :
    forall xs k,
      In (I k) xs ->
      In k (get_op_input_keys xs).
  Proof using.
    unfold get_op_input_keys.
    intros.
    eapply filterMap_In; eauto.
    auto.
  Qed.

  Lemma get_op_input_keys_sound :
    forall k l,
      In k (get_op_input_keys l) ->
      In (I k) l.
  Proof using.
    induction l; intros.
    - auto.
    - simpl in *. rewrite get_op_input_keys_defn in *. break_match; simpl in *.
      + subst. intuition congruence.
      + intuition.
  Qed.

  Lemma get_op_output_keys_sound :
    forall k l,
      In k (get_op_output_keys l) ->
      In (O k) l.
  Proof using.
    induction l; intros.
    - auto.
    - simpl in *. rewrite get_op_output_keys_defn in *. break_match; simpl in *.
      + subst. auto.
      + intuition congruence.
  Qed.

  Lemma get_op_input_keys_on_Os_nil :
    forall l,
      (forall o, In o l -> exists k, o = O k) ->
      get_op_input_keys l = [].
  Proof using.
    induction l; intros; simpl in *; intuition.
    rewrite get_op_input_keys_defn.
    pose proof H a. concludes. break_exists. subst.
    auto.
  Qed.

  Lemma get_op_input_keys_preserves_NoDup :
    forall l,
      NoDup l ->
      NoDup (get_op_input_keys l).
  Proof using.
    intros.
    unfold get_op_input_keys.
    apply filterMap_NoDup_inj; auto.
    intros.
    repeat break_match; try discriminate.
    subst. congruence.
  Qed.

  Lemma get_op_output_keys_preserves_NoDup :
    forall l,
      NoDup l ->
      NoDup (get_op_output_keys l).
  Proof using.
    intros.
    unfold get_op_output_keys.
    apply filterMap_NoDup_inj; auto.
    intros.
    repeat break_match; try discriminate.
    subst. congruence.
  Qed.

  Lemma get_op_output_keys_complete :
    forall xs k,
      In (O k) xs ->
      In k (get_op_output_keys xs).
  Proof using.
    unfold get_op_input_keys.
    intros.
    eapply filterMap_In; eauto.
    auto.
  Qed.

  Lemma get_IR_output_keys_complete_U :
    forall xs k,
      In (IRU k) xs ->
      In k (get_IR_output_keys xs).
  Proof using.
    unfold get_IR_output_keys.
    intros.
    eapply filterMap_In; eauto. auto.
  Qed.

  Lemma get_IR_output_keys_complete_O :
    forall xs k,
      In (IRO k) xs ->
      In k (get_IR_output_keys xs).
  Proof using.
    unfold get_IR_output_keys.
    intros.
    eapply filterMap_In; eauto. auto.
  Qed.

  Lemma get_IR_input_keys_complete :
    forall xs k,
      In (IRI k) xs ->
      In k (get_IR_input_keys xs).
  Proof using.
    unfold get_IR_input_keys.
    intros.
    eapply filterMap_In; eauto. auto.
  Qed.

  Lemma op_equivalent_all_Is_O_middle :
    forall xs ys k,
      (forall k', In (I k') xs -> k <> k') ->
      op_equivalent (xs ++ O k :: ys) (O k :: xs ++ ys).
  Proof using.
    intros.
    rewrite app_comm_cons.
    replace (xs ++ O k :: ys) with ((xs ++ [O k]) ++ ys) by now rewrite app_ass.
    auto using op_equiv_app_tail, op_equivalent_all_Is_O.
  Qed.

  Lemma NoDup_get_op_output_keys_In_O :
    forall xs ys k,
      NoDup (get_op_output_keys (xs ++ O k :: ys)) ->
      In (O k) (xs ++ ys) ->
      False.
  Proof using.
    intros.
    rewrite get_op_output_keys_app in *.
    rewrite get_op_output_keys_defn in *.
    do_in_app.
    intuition; eapply NoDup_remove_2; eauto using get_op_output_keys_complete, in_or_app.
  Qed.

  Lemma NoDup_get_op_output_keys_In_2_3 :
    forall xs ys zs k,
      NoDup (get_op_output_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      In (O k) (xs ++ ys ++ zs) ->
      False.
  Proof using.
    intros.
    rewrite get_op_output_keys_app in *.
    rewrite get_op_output_keys_defn in *.
    rewrite get_op_output_keys_app in *.
    rewrite get_op_output_keys_defn in *.
    repeat
      (do_in_app; intuition
                    eauto using NoDup_app3_not_in_1, NoDup_app3_not_in_2,
                  NoDup_app3_not_in_3, get_op_output_keys_complete).
  Qed.

  Lemma NoDup_get_op_input_keys_In_2_3 :
    forall xs ys zs k,
      NoDup (get_op_input_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      In (I k) (xs ++ ys ++ zs) ->
      False.
  Proof using.
    intros.
    rewrite get_op_input_keys_app in *.
    rewrite get_op_input_keys_defn in *.
    rewrite get_op_input_keys_app in *.
    rewrite get_op_input_keys_defn in *.
    match goal with
      | [ H : NoDup _ |- _ ] =>
        apply NoDup_remove_2 in H
    end.
    repeat (do_in_app; intuition); eauto 10 using get_op_input_keys_complete with *.
  Qed.

  Lemma O_IRO_preserved_IU :
    forall xs ys k' ir,

      (forall k, In (O k) (xs ++ I k' :: ys) ->
                 In (IRO k) (IRI k' :: IRU k' :: ir)) ->
      forall k, In (O k) (xs ++ ys) ->
                In (IRO k) ir.
  Proof using.
    intros.
    eapply In_cons_neq.
    - eapply In_cons_neq.
      + eauto.
      + discriminate.
    - discriminate.
  Qed.

  Lemma O_IRO_preserved :
    forall xs ys zs k' ir,
      NoDup (get_op_output_keys (xs ++ I k' :: ys ++ O k' :: zs)) ->
      (forall k, In (O k) (xs ++ I k' :: ys ++ O k' :: zs) ->
                 In (IRO k) (IRI k' :: IRO k' :: ir)) ->
      forall k, In (O k) (xs ++ ys ++ zs) ->
                In (IRO k) ir.
  Proof using.
    intros.
    eapply In_cons_neq.
    - eapply In_cons_neq.
      + eauto using In_cons_2_3.
      + discriminate.
    - intro. find_inversion. eauto using NoDup_get_op_output_keys_In_2_3.
  Qed.

  Lemma no_Ik_in_first2 :
    forall xs ys zs k,
      NoDup (get_op_input_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      forall k',
        In (I k') (xs ++ ys) -> k <> k'.
  Proof using.
    intros.
    rewrite get_op_input_keys_app in *. rewrite get_op_input_keys_defn in *.
    match goal with
      | [ H : NoDup (_ ++ _ :: _) |- _ ] =>
        apply NoDup_remove_2 in H
    end.
    rewrite get_op_input_keys_app in *.
    intro. subst.

    repeat do_in_app; intuition auto 10 using get_op_input_keys_complete, in_or_app.
  Qed.

  Lemma IRO_O_preserved_IU :
    forall xs ys k' ir,
      (forall k, In (IRO k) (IRI k' :: IRU k' :: ir) ->
                 In (O k) (xs ++ I k' :: ys)) ->
      forall k, In (IRO k) ir ->
                In (O k) (xs ++ ys).
  Proof using.
    intros.
    apply in_middle_reduce with (y := I k'); intuition (auto with *; congruence).
  Qed.

  Lemma IRO_O_preserved :
    forall xs ys zs k' ir,
      (~ In k' (get_IR_output_keys ir)) ->
      (forall k, In (IRO k) (IRI k' :: IRO k' :: ir) ->
                 In (O k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k, In (IRO k) ir ->
                In (O k) (xs ++ ys ++ zs).
  Proof using.
    intros.

    eapply In_cons_2_3_neq; eauto using in_cons; try congruence.
    intro. find_inversion. eauto using get_IR_output_keys_complete_O.
  Qed.

  Lemma IRU_I_preserved_IU :
    forall xs ys k' ir,
      (~ In k' (get_IR_output_keys ir)) ->
      (forall k, In (IRU k) (IRI k' :: IRU k' :: ir) ->
                 In (I k) (xs ++ I k' :: ys)) ->
      forall k, In (IRU k) ir ->
                In (I k) (xs ++ ys).
  Proof using.
    intros.
    apply in_middle_reduce with (y := I k'); intuition.
    find_inversion.
    auto using get_IR_output_keys_complete_U.
  Qed.

  Lemma IRU_I_preserved :
    forall xs ys zs k' ir,
      (~ In k' (get_IR_output_keys ir)) ->
      (forall k, In (IRU k) (IRI k' :: IRO k' :: ir) ->
                 In (I k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k, In (IRU k) ir ->
                In (I k) (xs ++ ys ++ zs).
  Proof using.
    intros.
    eapply In_cons_2_3_neq; eauto using in_cons; try congruence.
    intro. find_inversion. eauto using get_IR_output_keys_complete_U.
  Qed.

  Lemma NoDup_get_op_input_keys_In_I :
    forall xs ys k,
      NoDup (get_op_input_keys (xs ++ I k :: ys)) ->
      In (I k) (xs ++ ys) -> False.
  Proof using.
    intros.
    rewrite get_op_input_keys_app in *.
    rewrite get_op_input_keys_defn in *.
    do_in_app.
    intuition; eapply NoDup_remove_2; eauto using get_op_input_keys_complete, in_or_app.
  Qed.

  Lemma in_before_before_preserved_IU :
    forall xs ys k ir,
      NoDup (get_op_input_keys (xs ++ I k :: ys)) ->
      (forall k1 k2,
         In (I k2) (xs ++ I k :: ys) ->
         before (O k1) (I k2) (xs ++ I k :: ys) ->
         before (IRO k1) (IRI k2) (IRI k :: IRU k :: ir)) ->
      forall k1 k2,
        In (I k2) (xs ++ ys) ->
        before (O k1) (I k2) (xs ++ ys) ->
        before (IRO k1) (IRI k2) ir.
  Proof using.
    intros.
    simpl in *.
    find_eapply_lem_hyp before_middle_insert.
    - find_eapply_lem_hyp in_middle_insert.
      eapply_prop_hyp In (O k1); eauto.
      intuition; try congruence.
    - intro. find_inversion. eauto using NoDup_get_op_input_keys_In_I.
  Qed.

  Lemma in_before_before_preserved :
    forall xs ys zs k ir,
      NoDup (get_op_input_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      NoDup (get_op_output_keys (xs ++ I k :: ys ++ O k :: zs)) ->
      (forall k1 k2,
         In (I k2) (xs ++ I k :: ys ++ O k :: zs) ->
         before (O k1) (I k2) (xs ++ I k :: ys ++ O k :: zs) ->
         before (IRO k1) (IRI k2) (IRI k :: IRO k :: ir)) ->
      forall k1 k2,
        In (I k2) (xs ++ ys ++ zs) ->
        before (O k1) (I k2) (xs ++ ys ++ zs) ->
        before (IRO k1) (IRI k2) ir.
  Proof using.
    intros.
    simpl in *.
    find_copy_eapply_lem_hyp before_2_3_insert.
    - find_eapply_lem_hyp In_cons_2_3.
      eapply_prop_hyp In (O k1); eauto.
      intuition; try congruence.
      find_inversion.
      find_copy_eapply_lem_hyp before_In.
      exfalso.
      eauto using NoDup_get_op_output_keys_In_2_3.
    - intro. find_inversion. eauto using NoDup_get_op_input_keys_In_2_3.
    - discriminate.
  Qed.

  Lemma in_before_preserved_IU :
    forall xs ys k',
      ~ acknowledged_op k' (xs ++ ys) ->
      (forall k, In (O k) (xs ++ I k' :: ys) ->
                 before (I k) (O k) (xs ++ I k' :: ys)) ->
      forall k, In (O k) (xs ++ ys) ->
                before (I k) (O k) (xs ++ ys).
  Proof using.
    intros.
    eapply before_middle_reduce.
    - eauto using in_middle_insert.
    - intro. find_inversion. intuition eauto using acknowledged_op_defn.
  Qed.

  Lemma in_before_preserved :
    forall xs ys zs k',
      NoDup (get_op_output_keys (xs ++ I k' :: ys ++ O k' :: zs)) ->
      (forall k, In (O k) (xs ++ I k' :: ys ++ O k' :: zs) ->
                 before (I k) (O k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k, In (O k) (xs ++ ys ++ zs) ->
                before (I k) (O k) (xs ++ ys ++ zs).
  Proof using.
    intros.
    eapply before_2_3_reduce.
    - eauto using In_cons_2_3.
    - intro. find_inversion. eauto using NoDup_get_op_output_keys_In_2_3.
    - discriminate.
  Qed.

  Lemma IRI_I_preserved_IU :
    forall xs ys k' ir,
      (~ In k' (get_IR_input_keys ir)) ->
      (forall k, In (IRI k) (IRI k' :: IRU k' :: ir) -> In (I k) (xs ++ I k' :: ys)) ->
      forall k, In (IRI k) ir -> In (I k) (xs ++ ys).
  Proof using.
    intros.
    eapply in_middle_reduce.
    - auto with *.
    - intro. find_inversion.  eauto using get_IR_input_keys_complete.
  Qed.

  Lemma IRI_I_preserved :
    forall xs ys zs k' ir,
      (~ In k' (get_IR_input_keys ir)) ->
      (forall k, In (IRI k) (IRI k' :: IRO k' :: ir) -> In (I k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k, In (IRI k) ir -> In (I k) (xs ++ ys ++ zs).
  Proof using.
    intros.
    eapply In_cons_2_3_neq.
    - auto with *.
    - intro. find_inversion. eauto using get_IR_input_keys_complete.
    - discriminate.
  Qed.

  Lemma subseq_get_op_input_keys :
    forall xs ys,
      subseq xs ys ->
      subseq (get_op_input_keys xs) (get_op_input_keys ys).
  Proof using.
    eauto using subseq_filterMap.
  Qed.

  Lemma subseq_get_op_output_keys :
    forall xs ys,
      subseq xs ys ->
      subseq (get_op_output_keys xs) (get_op_output_keys ys).
  Proof using.
    eauto using subseq_filterMap.
  Qed.

  Ltac start :=
    match goal with
      | [ H : good_trace (_ :: _) |- _ ] => simpl in H
    end;
    break_and; subst;
    match goal with
      | [ H : context [In (?c _) (_ :: ?c ?k' :: _) -> In _ ?l] |- _ ] =>
        assert (In (O k') l) by firstorder;
          assert (before (I k') (O k') l) by auto;
          repeat rewrite get_IR_input_keys_defn in *;
          repeat rewrite get_IR_output_keys_defn in *;
          repeat match goal with
                   | [ H : NoDup (_ :: _) |- _ ] => invc H
                 end;
          assert (In (I k') l) by eauto using before_In;
          assert (forall x, before x (I k') l -> exists k, x = I k) by eauto using before_head_op;
          find_copy_apply_lem_hyp before_split; auto; try congruence; break_exists; subst
    end;
    repeat match goal with
             | [ H : In ?x (_ ++ ?x :: _) |- _ ] => clear H
             | [ H : In ?x (_ ++ _ :: _ ++ ?x :: _) |- _ ] => clear H
           end.

  Lemma acknowledge_all_ops_func_target_ext_strong :
    forall (l : list op) (t t' : list IR),
      (forall k : K, In (I k) l -> In (IRU k) t -> In (IRU k) t') ->
      (forall k : K, In (I k) l -> In (IRU k) t' -> In (IRU k) t) ->
      acknowledge_all_ops_func l t = acknowledge_all_ops_func l t'.
  Proof using.
    induction l; intros.
    - auto.
    - simpl. repeat break_match; subst; simpl in *; intuition auto 10 using f_equal with *.
      + exfalso. eauto.
      + exfalso. eauto.
  Qed.

  Lemma IRU_not_O_preserved_IU :
    forall xs ys k' ir,
      (forall k,
         In (IRU k) (IRI k' :: IRU k' :: ir) ->
         ~ In (O k) (xs ++ I k' :: ys)) ->
      forall k,
        In (IRU k) (ir) ->
        ~ In (O k) (xs ++ ys).
  Proof using.
    intuition.
    eapply H.
    - apply in_cons. apply in_cons. eauto.
    - auto using in_middle_insert.
  Qed.

  Lemma IRU_not_O_preserved :
    forall xs ys zs k' ir,
      (forall k,
         In (IRU k) (IRI k' :: IRO k' :: ir) ->
         ~ In (O k) (xs ++ I k' :: ys ++ O k' :: zs)) ->
      forall k,
        In (IRU k) (ir) ->
        ~ In (O k) (xs ++ ys ++ zs).
  Proof using.
    intuition.
    eapply H.
    - eauto with *.
    - auto using In_cons_2_3.
  Qed.

  Lemma IR_equivalent_acknowledge_all_ops_func :
    forall ir,
      good_trace ir ->
      forall l,
        (forall k, In (O k) l -> In (IRO k) ir) ->
        (forall k, In (IRO k) ir -> In (O k) l) ->
        (forall k, In (IRU k) ir -> In (I k) l) ->
        (forall k, In (IRU k) ir -> ~ In (O k) l) ->
        (forall k k', In (I k') l ->
                      before (O k) (I k') l ->
                      before (IRO k) (IRI k') ir) ->
        (forall k, In (O k) l -> before (I k) (O k) l) ->
        (forall k, In (IRI k) ir -> In (I k) l) ->
        NoDup (get_op_input_keys l) ->
        NoDup (get_IR_input_keys ir) ->
        NoDup (get_op_output_keys l) ->
        NoDup (get_IR_output_keys ir) ->
        IR_equivalent (acknowledge_all_ops_func l ir) ir.
  Proof using.
    intros ir.
    induction ir, good_trace using good_trace_ind; intros; try solve [simpl in *; intuition].
    - rewrite acknowledge_all_ops_func_target_nil; auto.
    - start.
      eapply IR_equiv_trans.
      + apply op_equiv_AAOF_IR_equiv.
        apply op_equivalent_all_Is_I_middle.
        intros.
        match goal with
          | [ H : context [before] |- _ ] => apply H
        end.
        apply In_app_before; auto using op_eq_dec.
        find_rewrite_lem get_op_input_keys_app. rewrite get_op_input_keys_defn in *.
        intro. eapply NoDup_remove_2; eauto using in_or_app, get_op_input_keys_complete.
      + repeat rewrite app_ass.
        rewrite acknowledge_all_ops_func_defn.
        break_if.
        * constructor.
          { eapply IR_equiv_trans.
            - apply op_equiv_AAOF_IR_equiv.
              rewrite <- app_ass.
              eauto using op_equivalent_all_Is_O_middle, no_Ik_in_first2.
            - simpl. constructor.
              rewrite acknowledge_all_ops_func_target_ext with (t' := ir).
              + rewrite app_ass.
                apply IHP; auto.
                * eauto using O_IRO_preserved.
                * eauto using IRO_O_preserved.
                * eauto using IRU_I_preserved.
                * eauto using IRU_not_O_preserved.
                * eauto using in_before_before_preserved.
                * eauto using in_before_preserved.
                * eauto using IRI_I_preserved.
                * eauto using subseq_NoDup, subseq_get_op_input_keys, subseq_2_3.
                * eauto using subseq_NoDup, subseq_get_op_output_keys, subseq_2_3.
              + simpl. intuition congruence.
              + intuition.
          }
        * { break_if.
            - simpl in *. intuition (try congruence).
              exfalso. eauto using get_IR_output_keys_complete_U.
            - exfalso. apply n. red. intuition.
          }
    - (* IRU case. *)
      match goal with
        | [ H : good_trace (_ :: _) |- _ ] => simpl in H
      end.
      break_and; subst.
      match goal with
        | [ H : context [In (?c _) (_ :: ?c ?k' :: _) -> In _ ?l] |- _ ] =>
          assert (In (I k') l) by firstorder;
            assert (forall x, before x (I k') l -> exists k, x = I k) by eauto using before_head_op
      end;
        repeat rewrite get_IR_input_keys_defn in *;
        repeat rewrite get_IR_output_keys_defn in *;
        repeat match goal with
                 | [ H : NoDup (_ :: _) |- _ ] => invc H
               end.
      find_copy_apply_lem_hyp in_split.
      break_exists. subst.
      eapply IR_equiv_trans.
      + apply op_equiv_AAOF_IR_equiv.
        apply op_equivalent_all_Is_I_middle.
        intros.
        match goal with
          | [ H : context [before] |- _ ] => apply H
        end.
        apply In_app_before; auto using op_eq_dec.
        find_rewrite_lem get_op_input_keys_app. rewrite get_op_input_keys_defn in *.
        intro. eapply NoDup_remove_2; eauto using in_or_app, get_op_input_keys_complete.
      + rewrite acknowledge_all_ops_func_defn.
        break_if.
        * exfalso.
          intuition eauto using in_middle_insert, in_cons, in_eq, acknowledged_op_defn.
        * rewrite if_decider_true by intuition.
          { constructor. constructor.
            rewrite acknowledge_all_ops_func_target_ext_strong with (t' := ir).
            - apply IHP; auto.
              + eauto using O_IRO_preserved_IU.
              + eauto using IRO_O_preserved_IU.
              + eauto using IRU_I_preserved_IU.
              + eauto using IRU_not_O_preserved_IU.
              + eauto using in_before_before_preserved_IU.
              + eauto using in_before_preserved_IU.
              + eauto using IRI_I_preserved_IU.
              + eauto using subseq_NoDup, subseq_get_op_input_keys, subseq_middle.
              + eauto using subseq_NoDup, subseq_get_op_output_keys, subseq_middle.
            - simpl. intuition (try congruence ). find_inversion.
              rewrite get_op_input_keys_app in *. rewrite get_op_input_keys_defn in *.
              exfalso.
              repeat match goal with
                       | [ H : In ?x (_ ++ ?x :: _) |- _ ] => clear H
                       | [ H : In ?x (_ ++ _ :: _ ++ ?x :: _) |- _ ] => clear H
                     end.
              do_in_app.
              eapply NoDup_remove_2; intuition eauto using in_or_app, get_op_input_keys_complete.
            - intros. simpl. intuition.
          }
  Qed.

  Theorem equivalent_intro :
    forall l ir,
      good_trace ir ->
      (forall k, In (O k) l -> In (IRO k) ir) ->
      (forall k, In (IRO k) ir -> In (O k) l) ->
      (forall k, In (IRU k) ir -> In (I k) l) ->
      (forall k k', In (I k') l ->
                    before (O k) (I k') l ->
                    before (IRO k) (IRI k') ir) ->
      (forall k, In (O k) l -> before (I k) (O k) l) ->
      (forall k, In (IRU k) ir -> ~ In (O k) l) ->
      NoDup (get_op_input_keys l) ->
      NoDup (get_IR_input_keys ir) ->
      NoDup (get_op_output_keys l) ->
      NoDup (get_IR_output_keys ir) ->
      equivalent l ir.
  Proof using K_eq_dec.
    intros.
    red.
    intuition.
    exists (acknowledge_all_ops_func l ir).
    intuition.
    - apply acknowledge_all_ops_func_correct.
    - apply IR_equivalent_acknowledge_all_ops_func; auto.
      intros.
      find_apply_lem_hyp good_trace_IRI_in; auto.
      intuition eauto using before_In.
  Qed.

End Linearizability.
Arguments I {_} _.
Arguments O {_} _.

Arguments IRI {_} _.
Arguments IRO {_} _.
Arguments IRU {_} _.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               Typing
               Subtyping_inversion.

(* TypedReduce *)
Lemma TypedReduce_ord_toplike_normal : forall (v v': exp) (A : typ),
    ord A -> topLike A -> TypedReduce v A v' -> v' = e_top.
Proof.
  introv H1 H2 Red.
  induction~ Red; try solve_false.
Qed.

Lemma TypedReduce_toplike :
  forall A, topLike A ->
            forall (v1 v2 v1' v2' : exp), TypedReduce v1 A v1' -> TypedReduce v2 A v2' -> v1' = v2'.
Proof.
  intros A Typ.
  induction Typ;
    introv Red1 Red2.
  - forwards~: TypedReduce_ord_toplike_normal Red1.
    forwards~: TypedReduce_ord_toplike_normal Red2.
    subst*.
  - inverts~ Red1; try solve_false;
      inverts~ Red2; try solve_false.
    forwards: IHTyp1 H2 H3.
    forwards: IHTyp2 H4 H6.
    subst*.
  - assert (topLike (t_arrow A B)) by constructor*.
    forwards~: TypedReduce_ord_toplike_normal Red1.
    forwards~: TypedReduce_ord_toplike_normal Red2.
    subst*.
Qed.

Lemma TypedReduce_sub: forall v v' A B,
    value v -> TypedReduce v A v' -> Typing nil v Inf B -> sub B A.
Proof.
  introv Val Red Pt. gen B.
  induction Red; intros;
    try solve [auto_sub];
    try solve [inverts~ Pt; auto_sub];
    (* merge *)
    inverts~ Val; inverts~ Pt.
Qed.

Lemma disjoint_val_consistent: forall A B v1 v2,
    disjointSpec A B -> value v1 -> value v2 -> Typing nil v1 Inf A -> Typing nil v2 Inf B -> consistencySpec v1 v2.
Proof.
  intros A B v1 v2 Dis Val1 Val2 Typ1 Typ2.
  unfold consistencySpec.
  introv Red1 Red2.
  forwards* Sub1': TypedReduce_sub Red1.
  forwards* Sub2': TypedReduce_sub Red2.
  subst.
  assert (Top: topLike A0). {
    unfold disjointSpec in Dis.
    apply~ Dis.
  }
  forwards*: TypedReduce_toplike Top Red1 Red2.
Qed.


Unset Strict Universe Declaration.
Require Import TestSuite.admit.
Set Universe Polymorphism.
Notation Type0 := Set.

Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}.

Notation compose := (fun g f x => g (f x)).

Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
Open Scope function_scope.

Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x)
  := forall x:A, f x = g x.

Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.

Class Contr_internal (A : Type) := BuildContr {
  center : A ;
  contr : (forall y : A, center = y)
}.

Inductive trunc_index : Type :=
| minus_two : trunc_index
| trunc_S : trunc_index -> trunc_index.

Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope.
Local Open Scope trunc_scope.
Notation "-2" := minus_two (at level 0) : trunc_scope.
Notation "-1" := (-2.+1) (at level 0) : trunc_scope.

Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type :=
  match n with
    | -2 => Contr_internal A
    | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y)
  end.

Class IsTrunc (n : trunc_index) (A : Type) : Type :=
  Trunc_is_trunc : IsTrunc_internal n A.

Notation Contr := (IsTrunc -2).
Notation IsHProp := (IsTrunc -1).

Monomorphic Axiom dummy_funext_type : Type0.
Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }.

Inductive Unit : Set :=
    tt : Unit.

Record TruncType (n : trunc_index) := BuildTruncType {
  trunctype_type : Type ;
  istrunc_trunctype_type : IsTrunc n trunctype_type
}.

Arguments BuildTruncType _ _ {_}.

Coercion trunctype_type : TruncType >-> Sortclass.

Notation "n -Type" := (TruncType n) (at level 1) : type_scope.
Notation hProp := (-1)-Type.

Notation BuildhProp := (BuildTruncType -1).

Private Inductive Trunc (n : trunc_index) (A :Type) : Type :=
  tr : A -> Trunc n A.
Arguments tr {n A} a.

Global Instance istrunc_truncation (n : trunc_index) (A : Type@{i})
: IsTrunc@{j} n (Trunc@{i} n A).
Admitted.

Definition Trunc_ind {n A}
  (P : Trunc n A -> Type) {Pt : forall aa, IsTrunc n (P aa)}
  : (forall a, P (tr a)) -> (forall aa, P aa)
:= (fun f aa => match aa with tr a => fun _ => f a end Pt).
Definition merely (A : Type@{i}) : hProp := BuildhProp (Trunc -1 A).
Definition cconst_factors_contr `{Funext}  {X Y : Type} (f : X -> Y)
           (P : Type) `{Pc : X -> Contr P}
           (g : X -> P) (h : P -> Y) (p : h o g == f)
: Unit.
Proof.
  assert (merely X -> IsHProp P) by admit.
  refine (let g' := Trunc_ind (fun _ => P) g : merely X -> P in _);
    [ assumption.. | ].
  pose (g'' := Trunc_ind (fun _ => P) g : merely X -> P).


Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import SubstSystems.UnicodeNotations.
Require Import UniMath.RezkCompletion.whiskering.
Require Import UniMath.RezkCompletion.Monads.
Require Import SubstSystems.Auxiliary.
Require Import SubstSystems.PointedFunctors.
Require Import SubstSystems.ProductPrecategory.
Require Import SubstSystems.HorizontalComposition.
Require Import SubstSystems.PointedFunctorsComposition.
Require Import SubstSystems.EndofunctorsMonoidal.
Require Import SubstSystems.Signatures.
Require Import SubstSystems.FunctorAlgebraViews.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
Local Notation "α ∙∙ β" := (hor_comp β α) (at level 20).
Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "α 'ø' Z" := (pre_whisker Z α)  (at level 25).
Local Notation "Z ∘ α" := (post_whisker _ _ _ _ α Z) (at level 35).

Section def_hss.

(** ** Some variables and assumptions *)

(** Assume having a precategory [C] whose hom-types are sets *)
Variable C : precategory.
Variable hs : has_homsets C.

Variable H : Signature C hs.

Let θ := theta H.

Let θ_strength1_int := Sig_strength_law1 _ _ H.
Let θ_strength2_int := Sig_strength_law2 _ _ H.

(*
(** [H] is a rank-2 endofunctor on endofunctors *)
Variable H : functor [C, C, hs] [C, C, hs].
*)
(** The forgetful functor from pointed endofunctors to endofunctors *)
Local Notation "'U'" := (functor_ptd_forget C hs).
(** The precategory of pointed endofunctors on [C] *)
Local Notation "'Ptd'" := (precategory_Ptd C hs).
(** The category of endofunctors on [C] *)
Local Notation "'EndC'":= ([C, C, hs]) .
(** The product of two precategories *)
Local Notation "A 'XX' B" := (product_precategory A B) (at level 2).
(** Pre-whiskering defined as morphism part of the functor given by precomposition
    with a fixed functor *)
Local Notation "α 'øø' Z" :=  (# (pre_composition_functor_data _ _ _ hs _  Z) α) (at level 25).

Local Notation "A ⊗ B" := (prodcatpair _ _ A B) (at level 10).
Local Notation "'τ'" := (tau).

(** ** Definition of algebra structure [τ] of a pointed functor *)
(*
Definition AlgStruct (T : Ptd) : UU := pr1 (H(U T)) ⟶ pr1 (U T).

Definition Alg : UU := Σ T : Ptd, AlgStruct T.

Coercion PtdFromAlg (T : Alg) : Ptd := pr1 T.

Definition τ (T : Alg) : pr1 (H (U T)) ⟶ pr1 (U T) := pr2 T.
*)

Definition bracket (T : ALG H) : UU :=
  ∀ (Z : Ptd) (f : Z ⇒ T), iscontr
   (Σ h : (U T) ∙ (U Z)  ⇒ U T,
     (#U f = (ptd_pt _ (pr1 T)) øø (U Z) ;; h) ×
     (θ (U T ⊗ Z) ;; #H h ;; τ _  = τ _ øø ((U Z)) ;;  h )).

Definition hss : UU := Σ T : ALG H, bracket T.

Coercion ALG_from_hss (T : hss) : ALG H := pr1 T.

Coercion AlgFromhss (T : hss) : ALG H := pr1 T.

Definition fbracket (T : hss) {Z : Ptd} (f : Z ⇒ T)
  : (U T) ∙ (U Z) ⇒ U T
  := pr1 (pr1 (pr2 T Z f)).

(** The bracket operation [fbracket] is unique *)

Definition fbracket_unique_pointwise (T : hss) {Z : Ptd} (f : Z ⇒ T)
  : ∀ (α : functor_composite (U Z)(U T) ⟶ pr1 (U T)),
     (∀ c : C, pr1 (#U f) c = ptd_pt _ (pr1 (pr1 T)) (pr1 (U Z) c) ;; α c) →
     (∀ c : C, pr1 (θ (U T ⊗ Z))  c ;; pr1 (#H α) c ;; τ _ c =
        τ _ (pr1 (U Z) c) ;; α c) → α = fbracket T f.
Proof.
  intros α H1 H2.
  apply path_to_ctr.
  split; apply nat_trans_eq; assumption.
Qed.

Definition fbracket_unique (T : hss) {Z : Ptd} (f : Z ⇒ T)
  : ∀ α : functor_composite (U Z)(U T) ⟶ pr1 (U T),
     (#U f = ptd_pt _ (pr1 (pr1 T)) øø ((U Z)) ;; α) →
     (θ (U T ⊗ Z) ;; #H α ;; τ _ = τ _ øø (U Z) ;; α)
   → α = fbracket T f.
Proof.
  intros α H1 H2.
  apply path_to_ctr.
  split;  assumption.
Qed.

Definition fbracket_unique_target_pointwise (T : hss) {Z : Ptd} (f : Z ⇒ T)
  : ∀ α : functor_composite (U Z)(U T) ⟶ pr1 (U T),
     (#U f =  (ptd_pt _ ((pr1 (pr1 T)))) øø U Z ;; α) →
     (θ (U T ⊗ Z) ;; #H α ;; τ _ = τ _ øø U Z ;; α)
   → ∀ c, α c = pr1 (fbracket T f) c.
Proof.
  intros α H1 H2.
  set (t:= fbracket_unique _ _ α H1 H2).
  apply (nat_trans_eq_weq _ _ hs _ _ _ _ t).
Qed.

(** Properties of [fbracket] by definition: commutative diagrams *)

Lemma fbracket_η (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ T),
   #U f = (ptd_pt _  (pr1 (pr1 T))) øø U Z ;; fbracket T f.
Proof.
  intros Z f.
  exact (pr1 (pr2 (pr1 (pr2 T Z f)))).
Qed.

Lemma fbracket_τ (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ T),
    θ (U T ⊗ Z) ;; #H (fbracket T f) ;; τ _
    =
    τ _ øø U Z ;; (fbracket T f).
Proof.
  intros Z f.
  exact (pr2 (pr2 (pr1 (pr2 T Z f)))).
Qed.

(** [fbracket] is also natural *)

Lemma fbracket_natural (T : hss) {Z Z' : Ptd} (f : Z ⇒ Z') (g : Z' ⇒ T)
  : post_whisker _ _ _ _ (#U f)(U T) ;; fbracket T g = fbracket T (f ;; g).
Proof.
  apply fbracket_unique_pointwise.
  - simpl. intro c.
    rewrite assoc.
    set (H':=nat_trans_ax (ptd_pt _ (pr1 (pr1 T)) )).
    simpl in H'.
    rewrite <- H'; clear H'.
    rewrite <- assoc.
    apply maponpaths.
    set (X:= nat_trans_eq_weq _ _ hs _ _ _ _  (fbracket_η T g)).
    simpl in X. exact (X _ ).
  - intro c; simpl.
    set (H':=nat_trans_ax (τ T)).
    simpl in H'.
    rewrite assoc.
    rewrite <- H'; clear H'.
    set (H':=fbracket_τ T g).
    simpl in H'.
    assert (X:= nat_trans_eq_pointwise _ _  _ _ _ _ H' c).
    simpl in X.
    rewrite  <- assoc.
    rewrite  <- assoc.
    transitivity (  # (pr1 (H ((U T)))) (pr1 (pr1 f) c) ;;
                     (pr1 (θ ((U T) ⊗ Z')) c);; pr1 (# H (fbracket T g)) c;; (τ T) c).
    Focus 2.
      rewrite <- assoc.
      rewrite <- assoc.
      apply maponpaths.
      repeat rewrite assoc.
      apply X.
    clear X.
    set (A:=θ_nat_2_pointwise).
    simpl in *.
    set (A':= A _ hs H θ (U T) Z Z').
    simpl in A'.
    set (A2:= A' f).
    clearbody A2; clear A'; clear A.
    rewrite A2; clear A2.
    repeat rewrite <- assoc.
    apply maponpaths.
    simpl.
    repeat rewrite assoc.
    apply cancel_postcomposition.
    set (A := functor_comp H).
    simpl in A.
    rewrite A.
    apply cancel_postcomposition.
    clear A. clear H'.
    set (A:=horcomp_id_postwhisker C _ _ hs hs).
    rewrite A.
    apply idpath.
Qed.

(** As a consequence of naturality, we can compute [fbracket f] from [fbracket identity] *)

Lemma compute_fbracket (T : hss) : ∀ {Z : Ptd} (f : Z ⇒ T),
  fbracket T f = post_whisker _ _ _ _ (#U f)(U T) ;; fbracket T (identity _ ).
Proof.
  intros Z f.
  assert (A : f = f ;; identity _ ).
  { rewrite id_right; apply idpath. }
  rewrite A.
  rewrite <- fbracket_natural.
  rewrite id_right.
  apply idpath.
Qed.

(** ** Morphisms of heterogeneous substitution systems *)

(** A morphism [f] of pointed functors is an algebra morphism when... *)
(*
Definition isAlgMor {T T' : Alg} (f : T ⇒ T') : UU :=
  #H (# U f) ;; τ T' = compose (C:=EndC) (τ T) (#U f).

Lemma isaprop_isAlgMor (T T' : Alg) (f : T ⇒ T') : isaprop (isAlgMor f).
Proof.
  apply isaset_nat_trans.
  apply hs.
Qed.
*)
(** A morphism [β] of pointed functors is a bracket morphism when... *)

Definition isbracketMor {T T' : hss} (β : T ⇒ T') : UU :=
    ∀ (Z : Ptd) (f : Z ⇒ T),
       fbracket _ f ;; #U β
       =
       (#U β)øø (U Z) ;; fbracket _ (f ;; β ).

Lemma isaprop_isbracketMor (T T':hss) (β : T ⇒ T') : isaprop (isbracketMor β).
Proof.
  do 2 (apply impred; intro).
  apply isaset_nat_trans.
  apply hs.
Qed.

(** A morphism of hss is a pointed morphism that is compatible with both
    [τ] and [fbracket] *)

Definition ishssMor {T T' : hss} (β : T ⇒ T') : UU
  :=  isALGMor β × isbracketMor β.

Definition hssMor (T T' : hss) : UU
  := Σ β : T ⇒ T', ishssMor β.

Coercion ptd_mor_from_hssMor (T T' : hss) (β : hssMor T T') : T ⇒ T' := pr1 β.

Definition isAlgMor_hssMor {T T' : hss} (β : hssMor T T')
  : isALGMor β := pr1 (pr2 β).
Definition isbracketMor_hssMor {T T' : hss} (β : hssMor T T')
  : isbracketMor β := pr2 (pr2 β).

(** **** Equality of morphisms of hss *)

Section hssMor_equality.

(** Show that equality of hssMor is equality of underlying nat. transformations *)

Variables T T' : hss.
Variables β β' : hssMor T T'.
Definition hssMor_eq1 : β = β' ≃ (pr1 β = pr1 β').
Proof.
  apply total2_paths_isaprop_equiv.
  intro γ.
  apply isapropdirprod.
  - apply isaprop_isALGMor.
  - apply isaprop_isbracketMor.
Defined.

Definition hssMor_eq : β = β' ≃ #U β = #U β'.
Proof.
  eapply weqcomp.
  - apply hssMor_eq1.
  - apply eq_ptd_mor.
    apply hs.
Defined.

End hssMor_equality.

Lemma isaset_hssMor (T T' : hss) : isaset (hssMor T T').
Proof.
  intros β β'.
  apply (isofhlevelweqb _ (hssMor_eq _ _ β β')).
  apply isaset_nat_trans.
  apply hs.
Qed.

(** ** The precategory of hss *)

(** *** Identity morphism of hss *)

Lemma ishssMor_id (T : hss) : ishssMor (identity T).
Proof.
  split.
  - unfold isALGMor.
    rewrite functor_id.
    rewrite functor_id.
    rewrite id_left.
    set (H2 := id_right ([C,C,hs])).
    apply pathsinv0, H2.
  - unfold isbracketMor.
    intros Z f.
    rewrite functor_id.
    rewrite id_right.
    rewrite id_right.
    set (H2:=pre_composition_functor _ _ C _ hs (U Z)).
    set (H2' := functor_id H2). simpl in H2'.
    simpl.
    rewrite H2'.
    rewrite (id_left EndC).
    apply idpath.
Qed.

Definition hssMor_id (T : hss) : hssMor _ _ := tpair _ _ (ishssMor_id T).

(** *** Composition of morphisms of hss *)

Lemma ishssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'')
  : ishssMor (β ;; γ).
Proof.
  split.
  - unfold isALGMor.
    rewrite functor_comp.
    rewrite functor_comp.
    rewrite <- assoc.
    rewrite isAlgMor_hssMor.
    rewrite assoc.
    rewrite isAlgMor_hssMor.
    apply pathsinv0, assoc.
  - unfold isbracketMor.
    intros Z f.
    rewrite functor_comp.
    rewrite assoc.
    rewrite isbracketMor_hssMor.
    rewrite <- assoc.
    set (H2:=functor_comp (pre_composition_functor _ _ C _ hs (U Z)) ).
    simpl in H2.
    simpl.
    rewrite H2; clear H2.
    rewrite <- (assoc EndC).
    apply maponpaths.
    rewrite (assoc Ptd).
    apply isbracketMor_hssMor.
Qed.

Definition hssMor_comp {T T' T'' : hss} (β : hssMor T T') (γ : hssMor T' T'')
  : hssMor T T'' := tpair _ _ (ishssMor_comp β γ).

Definition hss_obmor : precategory_ob_mor.
Proof.
  exists hss.
  exact hssMor.
Defined.

Definition hss_precategory_data : precategory_data.
Proof.
  exists hss_obmor.
  split.
  - exact hssMor_id.
  - exact @hssMor_comp.
Defined.

Lemma is_precategory_hss : is_precategory hss_precategory_data.
Proof.
  repeat split; intros.
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (id_left EndC).
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (id_right EndC).
  - apply (invmap (hssMor_eq _ _ _ _ )).
    apply (assoc EndC).
Qed.

Definition hss_precategory : precategory := tpair _ _ is_precategory_hss.

End def_hss.

Arguments hss {_ _} _ .
Arguments hssMor {_ _ _} _ _ .
Arguments fbracket {_ _ _} _ {_} _ .
Arguments tau {_ _ _} _ .
Arguments fbracket_η {_ _ _} _ {_} _ .
Arguments fbracket_τ {_ _ _} _ {_} _ .
Arguments fbracket_unique_target_pointwise {_ _ _} _ {_ _ _} _ _ _ .
Arguments fbracket_unique {_ _ _} _ {_} _ _ _ _ .
(* Arguments Alg {_ _} _. *)
Arguments hss_precategory {_ _} _ .