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 {_ _} _ .


(***************************************************************************
* Formalization of SN for the lambda_ex calculus			   *
*									   *
* General rewriting definitions	for explicit substitutions		   *
*									   *
* Fabien Renaud & Stephane Zimmerman, 2011				   *
* Flavio L. C. de Moura & Daniel L. Ventura & Washington R. Segundo, 2016  *
***************************************************************************)

Require Import Metatheory.
Require Import LambdaES_Defs.
Require Import List.

(** Given a relation Red, constructs its contextual closure. The contextual closure of a reduction is build in such a way that regularity is preserved. In particular, note the condition requiring that only terms can be introduced by the constructors for applications and explicit substitutions. *)
Inductive L_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | L_redex : forall t s, Lterm t -> Lterm s -> Red t s -> L_contextual_closure Red t s
  | L_app_left : forall t t' u, L_contextual_closure Red t t' -> Lterm u ->
	  		      L_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | L_app_right : forall t u u', L_contextual_closure Red u u' -> Lterm t ->
	  		       L_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | L_abs_in : forall t t' L, (forall x, x \notin L -> L_contextual_closure Red (t^x) (t'^x)) ->
                            L_contextual_closure Red (pterm_abs t) (pterm_abs t').

Inductive ES_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ES_redex : forall t s, Red t s -> ES_contextual_closure Red t s
  | ES_app_left : forall t t' u, ES_contextual_closure Red t t' -> term u ->
	  		      ES_contextual_closure Red (pterm_app t u) (pterm_app t' u)
  | ES_app_right : forall t u u', ES_contextual_closure Red u u' -> term t ->
	  		       ES_contextual_closure Red (pterm_app t u) (pterm_app t u')
  | ES_abs_in : forall t t' L, (forall x, x \notin L -> ES_contextual_closure Red (t^x) (t'^x)) ->
                            ES_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ES_subst_left : forall t t' u L, (forall x, x \notin L -> ES_contextual_closure Red (t^x) (t'^x)) ->
	        term u -> ES_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u)
  | ES_subst_right : forall t u u', ES_contextual_closure Red u u' -> term t ->
	  	ES_contextual_closure Red  (pterm_sub t u) (pterm_sub t u').
(*
Inductive ESlab_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
| ESlab_redex : forall t s, Red t s -> ESlab_contextual_closure Red t s
| ESlab_app_left : forall t t' u, ESlab_contextual_closure Red t t' -> term u ->
	  		          ESlab_contextual_closure Red (pterm_app t u) (pterm_app t' u)
| ESlab_app_right : forall t u u', ESlab_contextual_closure Red u u' -> term t ->
	  		           ESlab_contextual_closure Red (pterm_app t u) (pterm_app t u')
| ESlab_abs_in : forall t t' L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
                                ESlab_contextual_closure Red (pterm_abs t) (pterm_abs t')
| ESlab_sub_left : forall t t' u L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
	                              term u -> ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u)
| ESlab_sub_right : forall t u u', ESlab_contextual_closure Red u u' -> term t ->
	  	                     ESlab_contextual_closure Red  (pterm_sub t u) (pterm_sub t u')
| ESlab_lsub_left : forall t t' u L, (forall x, x \notin L -> ESlab_contextual_closure Red (t^x) (t'^x)) ->
	                               term u -> ESlab_contextual_closure Red  (pterm_lsub t u) (pterm_lsub t' u)
| ESlab_lsub_right : forall t u u', ESlab_contextual_closure Red u u' -> term t ->
	  	                      ESlab_contextual_closure Red  (pterm_lsub t u) (pterm_lsub t u').
*)
(** Given a relation Red, constructs its parallel contextual closure *)
Inductive L_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
| L_p_redex : forall t s, Lterm t -> Lterm s -> Red t s -> L_p_contextual_closure Red t s
| L_p_app : forall t t' u u', L_p_contextual_closure Red t t' -> L_p_contextual_closure Red u u' ->
	  		      L_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
| L_p_abs_in : forall t t' L, (forall x, x \notin L -> L_p_contextual_closure Red (t^x) (t'^x)) ->
                              L_p_contextual_closure Red (pterm_abs t) (pterm_abs t').

Inductive ES_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ES_p_redex : forall t s, term t -> term s -> Red t s -> ES_p_contextual_closure Red t s
  | ES_p_app : forall t t' u u', ES_p_contextual_closure Red t t' -> ES_p_contextual_closure Red u u' ->
	  		ES_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | ES_p_abs_in : forall t t' L, (forall x, x \notin L -> ES_p_contextual_closure Red (t^x) (t'^x)) ->
               ES_p_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ES_p_sub : forall t t' u u' L, (forall x, x \notin L -> ES_p_contextual_closure Red (t^x) (t'^x)) ->
              ES_p_contextual_closure Red u u' ->
	      ES_p_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u').
(*
Inductive ESlab_p_contextual_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | ESlab_p_redex : forall t s, Red t s -> ESlab_p_contextual_closure Red t s
  | ESlab_p_app : forall t t' u u', ESlab_p_contextual_closure Red t t' -> ESlab_p_contextual_closure Red u u' ->
	  		          ESlab_p_contextual_closure Red (pterm_app t u) (pterm_app t' u')
  | ESlab_p_abs_in : forall t t' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                  ESlab_p_contextual_closure Red (pterm_abs t) (pterm_abs t')
  | ESlab_p_subst : forall t t' u u' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                      ESlab_p_contextual_closure Red u u' ->
	                              ESlab_p_contextual_closure Red  (pterm_sub t u) (pterm_sub t' u')
  | ESlab_p_lsubst : forall t t' u u' L, (forall x, x \notin L -> ESlab_p_contextual_closure Red (t^x) (t'^x)) ->
                                       ESlab_p_contextual_closure Red u u' ->
	                               ESlab_p_contextual_closure Red (t[[u]]) (t'[[u']]).
*)
Hint Constructors L_contextual_closure ES_contextual_closure L_p_contextual_closure ES_p_contextual_closure.
(* ESlab_contextual_closure ESlab_p_contextual_closure. *)

(** Given a relation Red, constructs its transitive closure *)
Inductive trans_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | one_step_reduction : forall t u, Red t u -> trans_closure Red t u
  | transitive_reduction : forall t u v, trans_closure Red t u -> trans_closure Red u v -> trans_closure Red t v.

(** Given a relation Red, constructs its transitive reflexive closure *)
Inductive star_closure (Red : pterm -> pterm -> Prop) : pterm -> pterm -> Prop :=
  | reflexive_reduction : forall t, star_closure Red t t
  | star_trans_reduction : forall t u, trans_closure Red t u -> star_closure Red t u.

(** Given a reduction, the composition of two star closure is still a star closure
Lemma star_transitive_closure:
    forall (Red: pterm -> pterm -> Prop) (t u v : pterm),
     Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
 intros Red t u v H0 H1.
 forwards~ H: (one_step_reduction t u).
 induction H1. apply star_trans_reduction.
 apply one_step_reduction; assumption.
 apply star_trans_reduction.
 apply transitive_reduction with (u := t0); trivial.
Qed.
*)
Lemma transitive_closure_composition :
    forall Red t u v, trans_closure Red t u -> trans_closure Red u v -> trans_closure Red t v.
Proof.
  intros_all. induction H.
  apply transitive_reduction with (u := u); trivial. constructor 1; auto.
  apply transitive_reduction with (u := u) ; auto.
Qed.

Lemma star_transitive_closure_composition_1 :
    forall Red t u v, trans_closure Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
  intros_all. induction H0.
  apply star_trans_reduction; trivial.
  apply star_trans_reduction.
  apply transitive_reduction with t0; trivial.
Qed.

Lemma star_transitive_closure_composition_2 :
    forall Red t u v, star_closure Red t u -> trans_closure Red u v -> star_closure Red t v.
Proof.
  intros_all. induction H.
  apply star_trans_reduction; trivial.
  apply star_trans_reduction.
  apply transitive_reduction with u; trivial.
Qed.

Lemma star_closure_composition:
    forall Red t u v, star_closure Red t u -> star_closure Red u v -> star_closure Red t v.
Proof.
  intros_all. induction H. assumption.
  apply star_transitive_closure_composition_1 with (u := u); assumption.
Qed.
(*
Lemma transitive_star_derivation:
    forall (Red : pterm -> pterm -> Prop) (t v: pterm),
    trans_closure Red t v -> exists u, Red t u /\  star_closure Red u v.
Proof.
  intros_all. induction H.
  exists u. split; trivial. apply reflexive_reduction.
  intros t' u' v' H0 H1. exists u'.
  split; trivial.
  apply star_trans_reduction; trivial.
Qed.

Lemma transitive_star_derivation':
    forall (Red : pterm -> pterm -> Prop) (t v: pterm),
    trans_closure Red t v <-> (Red t v \/ (exists u, Red t u /\  (exists u', star_closure Red u u' /\ Red u' v))).
Proof.
 intros. split. intros. destruct H.
 left; trivial. right. exists u. split; trivial.
 clear H. induction H0. exists t0. split; trivial.
 apply reflexive_reduction. destruct IHtrans_closure.
 exists x. split. apply star_transitive_closure with (u := u); trivial.
 apply H1. apply H1. intros. case H. intro.
 apply one_step_reduction; trivial. intro.
 destruct H0. destruct H0. destruct H1. destruct H1. destruct H1.
 apply transitive_reduction with (u := t0); trivial.
 apply one_step_reduction; trivial.
 apply transitive_reduction with (u := t0); trivial.
 apply transitive_closure_composition with (u := u); trivial.
 apply one_step_reduction; trivial.
Qed.

Lemma star_transitive_derivation: forall (Red : pterm -> pterm -> Prop) (t u: pterm),
      star_closure Red t u <-> (t = u \/ trans_closure Red t u).
Proof.
 intros. split. intro. destruct H.
 left. reflexivity. right; trivial.
 intro. case H.
 clear H. intro H. rewrite H. apply reflexive_reduction.
 clear H. intro H. apply star_trans_reduction; trivial.
Qed.
*)
Lemma trans_R1_R2 : forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', trans_closure R1 t t' -> trans_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply one_step_reduction. apply H; trivial.
 apply transitive_reduction with u; trivial.
Qed.
(*
Lemma star_R1_R2: forall (R1 R2: pterm -> pterm -> Prop),
                           (forall t t', R1 t t' -> R2 t t') ->
                           (forall t t', star_closure R1 t t' -> star_closure R2 t t').
Proof.
 intros R1 R2 H t t' H'. induction H'.
 apply reflexive_reduction.
 apply star_trans_reduction.
 apply trans_R1_R2 with (R1 := R1); trivial.
Qed.
*)


(*|
###########################
Equality on inductive types
###########################

:Link: https://stackoverflow.com/q/26246441
|*)

(*|
Question
********

How do I prove the following trivial lemma:
|*)

Require Import Vector.

Lemma t0_nil : forall A (x : t A 0), x = nil A.
Proof.
Abort.

(*|
FAQ recommends ``decide equality`` and ``discriminate`` tactics but I
could not find a way to apply either of them. For the reference, here
is inductive definition:
|*)

Print t. (* .unfold .messages *)

(*|
Answer
******

What you want to do is to invert on ``x``. Unfortunately, it turns out
that general inversion of dependently typed hypotheses is undecidable,
see Adam Chlipala's CPDT. You can pattern match on the structure
manually though, e.g. with:
|*)

Lemma t0_nil : forall A (x : t A 0), x = nil A.
Proof.
  intros.
  refine (match x with
          | nil _ => _
          | cons _ _ _ _ => _
          end).
  - reflexivity.
  - exact @id.
Qed.

(*|
In many cases you can also use `the tactic dep_destruct provided by
CPDT
<http://adam.chlipala.net/cpdt/repo/file/977b425331c3/src/CpdtTactics.v>`__.
In that case your proof simply becomes:

.. code-block:: coq

    Require Import CpdtTactics.

    Lemma t0_nil : forall A (x : t A 0), x = nil A.
      intros. dep_destruct x. reflexivity.
    Qed.

----

**A:** An elegant solution by Pierre Boutillier, taken from this
`Coq-club post
<http://coq-club.inria.narkive.com/wrDwvaNY/how-to-prove-that-all-vectors-of-0-length-are-equal-to-vector-nil#post2>`__:
|*)

Reset t0_nil. (* .none *)
Definition t0_nil A (x : t A 0) : x = nil A := match x with nil _ => eq_refl end.


Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Contextual Implicit.
Set Universe Polymorphism.

From Coq Require Import
  Relation_Definitions
  RelationClasses
  Psatz
  Morphisms
  FunctionalExtensionality
.

From ClassesOfFunctors Require Import
  DictDerive
  FunctorPlus
  AppKleenePlus
  Laws
.

Require Export Transformers.PowerSet.

Require Import Tactics.Tactics.

Require Import GHC.Base.

(** * The [Applicative] transformer based on [PowerSet] *)

Section ParTransformer.

  (** [I] is the applicative functor that [PowerSet] transforms. *)
  Variable I : Type -> Type.
  Variable FI : Functor I.
  Variable AI : Applicative I.

  (** The equivalence relation on [I] and theorems that [I] satisfy
      certain laws. *)
  Variable EqI : forall (A : Type), relation (I A).
  Variable EqIEq : forall (A : Type), Equivalence (@EqI A).
  Variable ALI : @ApplicativeLaws I (@EqI) (@FI) (@AI).
  Variable ACI : @ApplicativeCongruenceLaws I (@EqI) (@FI) (@AI).

  (** The refinement relation on [I]. *)
  Variable RefinesI : forall (A : Type), relation (I A).
  Variable RefinesIPreOrder : forall (A : Type), PreOrder (@RefinesI A).

  Global Instance liftA2Proper :
    forall A B C, Proper (eq ==> @EqI A ==> @EqI B ==> @EqI C) liftA2.
  Proof.
    intros A B C f g -> a1 a2 HEqa b1 b2 HEqb.
    apply liftA2_cong; assumption.
  Qed.

  (** The equivalence relation on [PowerSet I]. *)
  Definition EqPowerSet {A} : relation (PowerSet I A) :=
    fun p q => forall a, p a <-> q a.

  (** An invariance that all [PowerSet I A] satisfies as long as they
      are constructed using functions that maintain the invariance. We
      also show in this section that all functions we define on this
      data type maintain the invariance. *)
  Definition Invariance {A} (p : PowerSet I A) :=
    forall a b, EqI a b -> p a <-> p b.

  (** The refinement relation on [PowerSet I]. *)
  Definition RefinesPowerSet {A} : relation (PowerSet I A) :=
    fun p q =>  forall a, p a -> q a.

  Global Instance Equiv__EqPowerSet {A} : Equivalence (@EqPowerSet A).
  constructor.
  - intros a. unfold EqPowerSet. tauto.
  - intros a b. unfold EqPowerSet. intros. split; apply H.
  - intros a b c. unfold EqPowerSet.
    intros; split.
    + intros. apply H0. apply H. assumption.
    + intros. apply H. apply H0. assumption.
  Qed.

  Global Instance PreOrder__RefinesPowerSet {A} : PreOrder (@RefinesPowerSet A).
  constructor.
  - intros a p q. assumption.
  - intros a b c Hab Hbc.
    unfold RefinesPowerSet in *. intros i Hi.
    specialize (Hab i Hi).  specialize (Hbc i Hab).
    assumption.
  Qed.

  Definition embedPowerSet {A} (a : I A) : PowerSet I A :=
    fun r => EqI r a.

  (** [embedPowerSet] maintains the invariance. *)
  Theorem embedInvariance {A} (a : I A) :
    Invariance (embedPowerSet a).
  Proof.
    intros x y Hxy. unfold embedPowerSet. split.
    - intros <-. symmetry. assumption.
    - intros <-. assumption.
  Qed.

  Definition purePowerSet {A} (a : A) : PowerSet I A :=
    fun r => EqI r (pure a).

  (** [purePowerSet] maintains the invariance. *)
  Theorem pureInvariance {A} (a : A) :
    Invariance (purePowerSet a).
  Proof.
    intros x y Hxy. unfold purePowerSet. split.
    - intros <-. symmetry. assumption.
    - intros <-. assumption.
  Qed.

  Definition liftA2Par {A B C}
    (f : A -> B -> C) (a : PowerSet I A) (b : PowerSet I B) : PowerSet I C :=
    fun r => exists a', a a' /\
                  exists b', b b' /\
                          (EqI (liftA2 f a' b') r \/ EqI (liftA2 (flip f) b' a') r).

  (** [liftA2Par] maintains the invariance. *)
  Theorem liftA2ParInvariance {A B C}
    (f : A -> B -> C) (a : PowerSet I A) (b : PowerSet I B) :
    Invariance (liftA2Par f a b).
  Proof.
    intros x y Hxy. unfold liftA2Par. split.
    - intros H0. destruct H0 as (a' & Ha & b' & Hb & HEq). destruct HEq.
      + exists a'. intuition. exists b'. intuition.
        left. transitivity x; assumption.
      + exists a'. intuition. exists b'. intuition.
        right. transitivity x; assumption.
    - intros H0. destruct H0 as (a' & Ha & b' & Hb & HEq). destruct HEq.
      + exists a'. intuition. exists b'. intuition.
        left. transitivity y; try assumption.
        symmetry; assumption.
      + exists a'. intuition. exists b'. intuition.
        right. transitivity y; try assumption.
        symmetry; assumption.
  Qed.

  (** [liftA2Par] is commutative. *)
  Lemma liftA2Par_comm : forall {A B C} (f : A -> B -> C)
                           (a : PowerSet I A) (b : PowerSet I B),
      EqPowerSet (liftA2Par f a b) (liftA2Par (flip f) b a).
  Proof.
    intros. unfold EqPowerSet, liftA2Par; intros.
    split; intros.
    - repeat destructs; subst.
      + exists x0. intuition. exists x. intuition.
      + exists x0. intuition. exists x. intuition.
    - repeat destructs; subst.
      + exists x0. intuition. exists x. intuition.
      + exists x0. intuition. exists x. intuition.
  Qed.

  Definition PowerSetApplicative__AppDict : Applicative__Dict (PowerSet I) :=
    {| liftA2__ := fun _ _ _ => liftA2Par ;
       op_zlztzg____ := fun _ _ => liftA2Par id ;
       op_ztzg____ := fun _ _ => liftA2Par (fun _ => id) ;
       pure__ := fun _ => @purePowerSet _
    |}.

  Instance Functor__PowerSetApplicative : Functor (PowerSet I) :=
    apdict_functor _ PowerSetApplicative__AppDict.

  Instance Applicative__PowerSetApplicative : Applicative (PowerSet I) :=
    apdict_applicative _ PowerSetApplicative__AppDict.

End ParTransformer.

(** We cannot show that all the [PowerSet I A] satisfy the laws we desire (like
    left identity law of applicative functors). This is because an arbitrary
    [PowerSet I A] might not maintain the invariance (the [Invariance] we
    defined in the previous section). Instead of proving that [PowerSet I A] are
    instances of [CommNonAsscoApplicativeLaws] and [ApplicativeCongruenceLaws],
    we show that all [PowerSet I A] that maintain the invariance are instances
    of them. We do that by using a subset type [PowerSetI] defined below. *)
Section CommNonAssocApplicativeLaws.

  (** [PowerSetI] is a subset of [PowerSet] where all elements satisfy the
      invariance defined by [Invariance]. *)
  Definition PowerSetI
    (I : Type -> Type) (EqI : forall A, relation (I A)) (A : Type) :=
    { p : PowerSet I A | Invariance EqI p }.

  Variable I : Type -> Type.
  Variable FI : Functor I.
  Variable AI : Applicative I.

  Variable EqI : forall (A : Type), relation (I A).
  Variable EqIEq : forall (A : Type), Equivalence (@EqI A).
  Variable ALI : @ApplicativeLaws I (@EqI) (@FI) (@AI).
  Variable ACI : @ApplicativeCongruenceLaws I (@EqI) (@FI) (@AI).

  Variable RefinesI : forall (A : Type), relation (I A).
  Variable RefinesIPreOrder : forall (A : Type), PreOrder (@RefinesI A).

  (* The rest are functions refined on [PowerSetI]. *)
  Program Definition EqPowerSetI {A} : relation (PowerSetI I (@EqI) A) :=
    EqPowerSet.

  Global Instance Equiv__EqPowerSetI {A} : Equivalence (@EqPowerSetI A).
  constructor.
  - intros a. unfold EqPowerSetI.
    destruct a. simpl. reflexivity.
  - intros a b. unfold EqPowerSetI. intros. split; apply H.
  - intros a b c. unfold EqPowerSet.
    intros; split.
    + intros. apply H0. apply H. assumption.
    + intros. apply H. apply H0. assumption.
  Qed.

  Program Definition embedPowerSetI {A} : I A -> PowerSetI I (@EqI) A :=
    (@embedPowerSet I (@EqI) A).
  Next Obligation.
    apply embedInvariance. apply (@EqIEq).
  Qed.

  Program Definition purePowerSetI {A} : A -> PowerSetI I (@EqI) A :=
    (@purePowerSet I (@FI) (@AI) (@EqI) A).
  Next Obligation.
    apply pureInvariance. apply (@EqIEq).
  Qed.

  Program Definition liftA2ParI {A B C} :
    (A -> B -> C) ->
    PowerSetI I (@EqI) A -> PowerSetI I (@EqI) B -> PowerSetI I (@EqI) C :=
    (@liftA2Par I (@FI) (@AI) (@EqI) A B C).
  Next Obligation.
    apply liftA2ParInvariance. apply (@EqIEq).
  Qed.

  Definition PowerSetIApplicative__AppDict :
    Applicative__Dict (PowerSetI I (@EqI)) :=
    {| liftA2__ := fun _ _ _ => liftA2ParI ;
       op_zlztzg____ := fun _ _ => liftA2ParI id ;
       op_ztzg____ := fun _ _ => liftA2ParI (fun _ => id) ;
       pure__ := fun _ => purePowerSetI
    |}.

  Global Instance Functor__PowerSetIApplicative : Functor (PowerSetI I (@EqI)) :=
    apdict_functor _ PowerSetIApplicative__AppDict.

  Global Instance Applicative__PowerSetIApplicative :
    Applicative (PowerSetI I (@EqI)) :=
    apdict_applicative _ PowerSetIApplicative__AppDict.

  (** * Core theorems. *)

  (** Lemma 3.7 *)
  Global Instance CommNonAssocApplicativeLaws__PowerSetApplicative :
    @CommNonAssocApplicativeLaws (PowerSetI I (@EqI)) (@EqPowerSetI) _ _.
  constructor.
  - (* liftA2_left_id *)
    intros. cbn. split.
    + cbn. unfold liftA2Par, purePowerSet.
      destruct b as (b & HIb).
      intros (a' & Eqa' & b' & Hb & HEq). destruct HEq.
      * rewrite Eqa' in H. rewrite (@liftA2_left_id _ _ _ _ ALI) in H.
        simpl. simpl in Hb. specialize (HIb b' a0 H).
        apply HIb. assumption.
      * rewrite Eqa' in H. rewrite (@liftA2_right_id _ _ _ _ ALI) in H.
        simpl. simpl in Hb. specialize (HIb b' a0 H).
        apply HIb. assumption.
    + cbn. unfold liftA2Par, purePowerSet.
      destruct b as (b & HIb). simpl. intros Hb.
      exists (pure a). split; [reflexivity|].
      exists a0. intuition. left. apply (@liftA2_left_id _ _ _ _ ALI).
  - (* liftA2_right_id *)
    intros. cbn. split.
    + cbn. unfold liftA2Par, purePowerSet.
      destruct a as (a & HIa).
      intros (a' & Ha & b' & Eqb' & HEq). destruct HEq.
      * rewrite Eqb' in H. rewrite (@liftA2_right_id _ _ _ _ ALI) in H.
        simpl. simpl in Ha. specialize (HIa a' a0 H).
        apply HIa. assumption.
      * rewrite Eqb' in H. rewrite (@liftA2_left_id _ _ _ _ ALI) in H.
        simpl. simpl in Ha. specialize (HIa a' a0 H).
        apply HIa. assumption.
    + cbn. unfold liftA2Par, purePowerSet.
      destruct a as (a & HIa). simpl. intros Ha.
      exists a0. intuition. exists (pure b). split; [reflexivity|].
      left. apply (@liftA2_right_id _ _ _ _ ALI).
  - (* commutativity *)
    intros. unfold EqPowerSetI.
    destruct a as [a HIa]. destruct b as [b HIb].
    simpl. apply (@liftA2Par_comm _ _ _ _).
  Qed.

  (** Lemma 3.7 *)
  Global Instance ApplicativeCongruenceLaws__PowerSetApplicative :
    @ApplicativeCongruenceLaws (PowerSetI I (@EqI)) (@EqPowerSetI) _ _.
  constructor. intros.
  destruct a1 as [a1 HIa1].
  destruct a2 as [a2 HIa2].
  destruct b1 as [b1 HIb1].
  destruct b2 as [b2 HIb2].
  unfold EqPowerSetI in *. simpl in *. split.
  - intros Hlift. destruct Hlift as (a' & Ha' & b' & Hb' & HEq).
    destruct HEq.
    + exists a'; split; [apply H; assumption|].
      exists b'; split; [apply H0; assumption|].
      tauto.
    + exists a'; split; [apply H; assumption|].
      exists b'; split; [apply H0; assumption|].
      tauto.
  - intros Hlift. destruct Hlift as (a' & Ha' & b' & Hb' & HEq).
    destruct HEq.
    + exists a'; split; [apply H; assumption|].
      exists b'; split; [apply H0; assumption|].
      tauto.
    + exists a'; split; [apply H; assumption|].
      exists b'; split; [apply H0; assumption|].
      tauto.
  Qed.
End CommNonAssocApplicativeLaws.


Require Import Coq.micromega.Psatz.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Strings.String.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Lists.List.
Import ListNotations.

Module Type NAME_SYSTEM.

Parameter t: Type.
Parameter eq_dec: forall v1 v2: t, {v1 = v2} + {v1 <> v2}.
Parameter max: t -> t -> t.
Parameter next_name: t -> t.
Parameter le: t -> t -> Prop.
Parameter le_trans: Transitive le.
Parameter default: t.

Axiom next_name_new: forall v v_max, le v v_max -> v <> next_name v_max.
Axiom le_max_r: forall v1 v2, le v1 (max v1 v2).
Axiom le_max_l: forall v1 v2, le v2 (max v1 v2).
Axiom max_sym: forall v1 v2, max v1 v2 = max v2 v1.
Axiom max_comm: forall v1 v2 v3, max v1 (max v2 v3) = max (max v1 v2) v3.

End NAME_SYSTEM.

Module NAME_SYSTEM_EXT (Name:NAME_SYSTEM).
Include Name.

(** Max name of a list **)
Fixpoint list_max (xs:list t):=
  match xs with
  | nil => default
  | (x::xs') => max x (list_max xs')
  end.

(** Find a new name for a list **)
Definition list_new_name (xs:list t):= next_name (list_max xs).

Lemma list_max_correct: forall s xs,
  In s xs -> le s (list_max xs).
Proof.
  intros. induction xs. inversion H. simpl.  destruct H.
  + subst a. apply le_max_r.
  + assert (le (list_max xs) (max a (list_max xs))) by apply le_max_l. apply IHxs in H.
     pose proof le_trans. transitivity (list_max xs); tauto.
Qed.

Lemma list_new_name_new: forall s xs,
  In s xs -> s <> list_new_name xs.
Proof.
  intros. apply list_max_correct in H. apply next_name_new. tauto.
Qed.

Lemma list_max_Permuatation: forall l1 l2,
  Permutation l1 l2 -> list_max l1 = list_max l2.
Proof.
  intros. induction H.
  + reflexivity.
  + simpl. congruence.
  + simpl. assert (max x (list_max l)=max (list_max l) x) by apply max_sym.
      rewrite H. rewrite max_comm. apply max_sym.
  + congruence.
Qed.

Corollary list_new_name_Permutation: forall l1 l2,
  Permutation l1 l2  -> list_new_name l1 = list_new_name l2.
Proof.
  intros. apply list_max_Permuatation in H. unfold list_new_name. congruence.
Qed.

Definition eqb (x y:t) :bool:=
  if eq_dec x y then true else false.

Lemma eqb_eq: forall v1 v2,
  eqb v1 v2 = true <-> v1=v2.
Proof.
  unfold eqb.
  split.
  + intros.
     destruct (eq_dec v1 v2) eqn:H1.
     ++ tauto.
     ++ easy.
  + intros.
     destruct (eq_dec v1 v2) eqn:H1.
     ++ tauto.
     ++ easy.
Qed.
(* unfold eqb; split; intros; destruct (eq_dec v1 v2); easy. Qed. *)

Lemma eqb_neq: forall v1 v2,
  eqb v1 v2 = false <-> v1 <> v2.
Proof.
  unfold eqb.
  split.
  + intros.
     destruct (eq_dec v1 v2) eqn:H1.
     ++ easy.
     ++ apply n.
  + intros.
     destruct (eq_dec v1 v2) eqn:H1.
     ++ easy.
     ++ reflexivity.
Qed.
(* Proof. unfold eqb; split; intros; destruct (eq_dec v1 v2); easy. Qed. *)

(** Key-value pairs**)
Fixpoint look_up {A: Type} (x: t) (KV: list (t * A)): option A :=
  match KV with
  | nil => None
  | (x0, v0) :: KV0 =>
      if eqb x0 x then Some v0 else look_up x KV0
  end.

Fixpoint remove {A: Type} (x: t) (KV: list (t * A)): list (t * A) :=
  match KV with
  | nil => nil
  | (x0, v0) :: KV0 =>
      if eqb x0 x
      then remove x KV0
      else (x0, v0) :: remove x KV0
  end.

End NAME_SYSTEM_EXT.

(** Instantiate NAME_SYSTEM with string **)
Module StringSystem <: NAME_SYSTEM.

Definition t := string.

Definition eq_dec: forall v1 v2: t, {v1 = v2} + {v1 <> v2} :=
  string_dec.

Definition max (v1 v2: t): t :=
  match String_as_OT.cmp v1 v2 with
  | Lt => v2
  | _ => v1
  end.

(** New name: add a suffix ' at the end **)
Definition next_name (v: t): t :=
  append v (String (Ascii.Ascii true true true false false true false false) EmptyString).

Definition le := fun t1 t2 => String_as_OT.lt t1 t2 \/ t1 = t2.

Instance le_trans: Transitive le.
Proof.
  unfold Transitive. intros.
  destruct H; destruct H0; unfold le.
  + left. apply String_as_OT.lt_trans with y; tauto.
  + left. congruence.
  + left. congruence.
  + right. congruence.
Qed.

Lemma next_name_new: forall v v_max,
  le v v_max ->
  v <> next_name v_max.
Proof.
  unfold le, next_name.
  intros.
  assert (String_as_OT.lt v_max  (append v_max (String (Ascii.Ascii true true true false false true false false) EmptyString))).
  { clear v H. apply String_as_OT.cmp_lt. induction v_max.
     + reflexivity.
     + simpl. assert (a=a) by reflexivity. apply Ascii_as_OT.cmp_eq in H. unfold Ascii_as_OT.cmp in H. rewrite H. tauto. }
  remember  (append v_max (String (Ascii.Ascii true true true false false true false false) EmptyString)) as z. destruct H.
  + assert (String_as_OT.lt v z). eapply String_as_OT.lt_trans. apply H. tauto.
      destruct (eq_dec v z);[|tauto]. apply String_as_OT.cmp_lt in H1. apply String_as_OT.cmp_eq in e. congruence.
  + subst v_max.  destruct (eq_dec v z);[|tauto].  apply String_as_OT.cmp_lt in H0. apply String_as_OT.cmp_eq in e. congruence.
Qed.

Local Lemma compare_helper_gt {a b : string} (G : String_as_OT.cmp a b = Gt):
   String_as_OT.lt b a.
Proof.
  rewrite String_as_OT.cmp_antisym in G.
  rewrite CompOpp_iff in G.
  now apply String_as_OT.cmp_lt.
Qed.

Local Lemma compare_helper_lt_gt {a b: string} (H:String_as_OT.cmp a b = Lt):
  String_as_OT.cmp b a = Gt.
Proof.
  rewrite String_as_OT.cmp_antisym in H.
  rewrite CompOpp_iff in H. tauto.
Qed.

Local Lemma compare_helper_gt_lt {a b: string} (H:String_as_OT.cmp a b = Gt):
  String_as_OT.cmp b a = Lt.
Proof.
  rewrite String_as_OT.cmp_antisym in H.
  rewrite CompOpp_iff in H. tauto.
Qed.

Lemma le_max_r: forall (v1 v2:t), le v1 (max v1 v2).
Proof.
  unfold le, max; intros. destruct (String_as_OT.cmp v1 v2) eqn:E;try tauto.
  left. apply String_as_OT.cmp_lt. tauto.
Qed.

Lemma le_max_l: forall (v1 v2:t), le v2 (max v1 v2).
Proof.
  unfold le, max; intros. destruct (String_as_OT.cmp v1 v2) eqn:E.
  + right. apply String_as_OT.cmp_eq in E. congruence.
  + tauto.
  + apply compare_helper_gt in E. tauto.
Qed.

Lemma max_sym: forall v1 v2, max v1 v2 = max v2 v1.
Proof.
  intros. unfold max. destruct (String_as_OT.cmp v1 v2) eqn: E1; destruct (String_as_OT.cmp v2 v1) eqn: E2; try tauto .
  + apply String_as_OT.cmp_eq in E1. apply String_as_OT.cmp_eq in E2. congruence.
  + apply String_as_OT.cmp_eq. tauto.
  + apply compare_helper_lt_gt in E2. congruence.
  + apply String_as_OT.cmp_eq in E2. congruence.
  + apply compare_helper_gt_lt in E2. congruence.
Qed.

Lemma max_comm:  forall v1 v2 v3, max v1 (max v2 v3) = max (max v1 v2) v3.
Proof.
  intros. unfold max. destruct (String_as_OT.cmp v1 v2) eqn:E1; destruct (String_as_OT.cmp v2 v3) eqn:E2.
  + rewrite E1. rewrite String_as_OT.cmp_eq in E1. rewrite String_as_OT.cmp_eq in E2.
      subst v2. apply String_as_OT.cmp_eq in E2. rewrite E2. reflexivity.
  + rewrite String_as_OT.cmp_eq in E1. subst v2. rewrite E2. reflexivity.
  + rewrite String_as_OT.cmp_eq in E1. assert (E3:=E1). apply String_as_OT.cmp_eq in E3.
      rewrite E3. subst v2. rewrite E2. reflexivity.
  + rewrite E1. reflexivity.
  + rewrite String_as_OT.cmp_lt in E1. rewrite String_as_OT.cmp_lt in E2.
      assert (String_as_OT.cmp v1 v3=Lt). apply String_as_OT.cmp_lt. eapply String_as_OT.lt_trans.
      apply E1. tauto. rewrite H. reflexivity.
  + rewrite E1. reflexivity.
  + rewrite String_as_OT.cmp_eq in E2. subst v3. rewrite E1. reflexivity.
  + reflexivity.
  + rewrite E1. assert (String_as_OT.cmp v1 v3=Gt). apply compare_helper_lt_gt. apply String_as_OT.cmp_lt.
      apply compare_helper_gt in E1. apply compare_helper_gt in E2. eapply String_as_OT.lt_trans.
      apply E2. tauto. rewrite H. reflexivity.
Qed.

Definition default: t := "x"%string.

End StringSystem.

Module StringName:= NAME_SYSTEM_EXT StringSystem.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimunLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Trivial.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Trivial.
Require Import Logic.PropositionalLogic.Complete.Truth_Trivial.
Require Import Logic.PropositionalLogic.Complete.Complete_Trivial.
Require Logic.PropositionalLogic.DeepEmbedded.PropositionalLanguage.
Require Logic.PropositionalLogic.DeepEmbedded.ProofTheories.
Require Logic.PropositionalLogic.DeepEmbedded.TrivialSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Local Open Scope kripke_model_class.
Import PropositionalLanguageNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.
Import KripkeModelClass.

Section Complete.

Context {Sigma: PropositionalLanguage.PropositionalVariables}
        {CV: Countable PropositionalLanguage.Var}.

Existing Instances PropositionalLanguage.L PropositionalLanguage.minL PropositionalLanguage.pL.

Existing Instances TrivialSemantics.MD TrivialSemantics.SM TrivialSemantics.tminSM TrivialSemantics.tpSM.

Existing Instances ProofTheories.ClassicalPropositionalLogic.G ProofTheories.ClassicalPropositionalLogic.AX ProofTheories.ClassicalPropositionalLogic.minAX ProofTheories.ClassicalPropositionalLogic.ipG  ProofTheories.ClassicalPropositionalLogic.cpG.

Existing Instances Axiomatization2SequentCalculus_SC Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_ipSC Axiomatization2SequentCalculus_cpSC.

Definition cP: context -> Prop := maximal consistent.

Lemma AL_MC: at_least (maximal consistent) cP.
Proof. solve_at_least. Qed.

Lemma LIN_CONSI: Lindenbaum_constructable consistent cP.
Proof.
  eapply Lindenbaum_constructable_Same_set.
  + rewrite Same_set_spec.
    intros Phi.
    apply consistent_spec.
  + apply Lindenbaum_constructable_suffice.
    - apply PropositionalLanguage.formula_countable; auto.
    - apply Lindenbaum_preserves_cannot_derive.
    - apply Lindenbaum_cannot_derive_ensures_max_consistent.
Qed.

Definition canonical_frame: Type := sig cP.

Definition canonical_eval: PropositionalLanguage.Var -> canonical_frame -> Prop :=
  fun p a => proj1_sig a (PropositionalLanguage.varp p).

Definition kMD: KripkeModel TrivialSemantics.MD :=
  Build_KripkeModel TrivialSemantics.MD
    unit (fun _ => canonical_frame) (fun u a v => canonical_eval v a).

Definition canonical_Kmodel: @Kmodel TrivialSemantics.MD kMD := tt.

Definition rel: bijection (Kworlds canonical_Kmodel) (sig cP) := bijection_refl.

Lemma TRUTH:
  forall x: expr, forall m Phi, rel m Phi ->
    (KRIPKE: canonical_Kmodel, m |= x <-> proj1_sig Phi x).
Proof.
  induction x.
  + exact (truth_lemma_andp cP rel AL_MC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_orp cP rel AL_MC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_impp cP rel AL_MC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_falsep cP rel AL_MC).
  + intros; change (m = Phi) in H; subst; reflexivity.
Qed.

Existing Instance kMD.

Theorem complete_Classical_Trivial:
  strongly_complete ProofTheories.ClassicalPropositionalLogic.G TrivialSemantics.SM (AllModel _).
Proof.
  assert (strongly_complete ProofTheories.ClassicalPropositionalLogic.G TrivialSemantics.SM
           (KripkeModelClass _ (fun _ => True))).
  Focus 2. {
    hnf; intros.
    apply (H Phi x).
    hnf; intros.
    apply H0; auto.
    hnf; auto.
  } Unfocus.
  apply (@general_completeness PropositionalLanguage.L _ _ ProofTheories.ClassicalPropositionalLogic.G _ _ _ _
           _ _ _ TrivialSemantics.SM _ _ _ _ rel LIN_CONSI TRUTH); auto.
Qed.

End Complete.