Require Import Verdi.Verdi.
Require Import Verdi.HandlerMonad.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Class PrimaryBackupParams (base_params : BaseParams) :=
  {
    input_eq_dec : forall x y : input, {x = y} + {x <> y}
  }.

Section PrimaryBackup.
  Context {base_params : BaseParams}.
  Context {one_node_params : OneNodeParams base_params}.
  Context {pb_params : PrimaryBackupParams base_params}.

  Inductive name := Primary | Backup.

  Lemma name_eq_dec : forall x y : name, {x = y} + {x <> y}.
  Proof using.
    decide equality.
  Qed.

  Inductive msg :=
  | BackItUp : input -> msg
  | Ack : msg.

  Lemma msg_eq_dec : forall x y : msg, {x = y} + {x <> y}.
  Proof using pb_params.
    decide equality.
    apply input_eq_dec.
  Qed.

  Inductive PB_input :=
  | Request : input -> PB_input
  | Read : PB_input.

  Inductive PB_output :=
  | RequestResponse : input -> output -> PB_output
  | ReadResponse : data -> PB_output.

  Record PB_data :=
    {
      queue : list input;
      state : data
    }.

  Definition all_nodes : list name := [Primary; Backup].

  Lemma all_nodes_all :
    forall x,
      In x all_nodes.
  Proof using.
    unfold all_nodes.
    destruct x; intuition.
  Qed.

  Lemma NoDup_all_nodes :
    NoDup all_nodes.
  Proof using.
    unfold all_nodes.
    repeat constructor; intuition. simpl in *. intuition. congruence.
  Qed.

  Definition PB_init (n : name) :=
    Build_PB_data [] init.

  Definition set_queue {W O} (l : list input) :=
    modify (W := W)(O := O) (fun d => Build_PB_data l (state d)).

  Definition set_state {W O} (st : data) :=
    modify (W := W)(O := O) (fun d => Build_PB_data (queue d) st).

  Ltac pb_unfold := unfold set_queue, set_state in *; monad_unfold.

  Definition PB_input_handler (h : name) (i : PB_input) (d : PB_data) :
    list PB_output * PB_data * list (name * msg) :=
    runGenHandler_ignore d (
      match h, i with
        | Primary, Request r =>
          d <- get ;;
          when (null (queue d)) (send (Backup, BackItUp r)) ;;
          set_queue (queue d ++ [r])
        | _, Read =>
          d <- get ;;
          write_output (ReadResponse (state d))
        | _, _ => nop
      end).

  Lemma PB_input_handler_defn :
    forall h i d os d' ms,
      PB_input_handler h i d = (os, d', ms) ->
      (h = Primary /\
       state d' = state d /\
       os = [] /\
       exists r,
         i = Request r /\
         queue d' = queue d ++ [r] /\
         (ms = [] \/ (ms = [(Backup, BackItUp r)] /\ queue d = []))) \/
      (i = Read /\
       d = d' /\
       os = [ReadResponse (state d)] /\
       ms = []) \/
      (h = Backup /\
       d = d' /\
       ms = [] /\
       os = []).
  Proof using.
    unfold PB_input_handler. intros.
    pb_unfold.
    repeat break_match; repeat find_inversion; intuition eauto.
    rewrite app_nil_r. simpl. find_apply_lem_hyp null_sound. find_rewrite.
    simpl. left. intuition. eexists. eauto.
  Qed.

  Definition PB_net (dst src : name) (m : msg) : PB_data ->
    list PB_output * PB_data * list (name * msg) :=
    fun x => runGenHandler_ignore x (
        match dst, m with
          | Primary, Ack => d <- get ;;
                            match queue d with
                              | [] => nop
                              | x :: xs => match xs with
                                             | [] => nop
                                             | y :: ys =>
                                               send (Backup, BackItUp y)
                                           end ;;
                                               let (os, st') := handler x (state d) in
                                               write_output (RequestResponse x os) ;;
                                               set_state st' ;;
                                               set_queue xs
                            end
          | Backup, BackItUp i => d <- get ;;
                                  set_state (snd (handler i (state d))) ;;
                                  send (Primary, Ack)
          | _, _ => nop
        end).

  Lemma PB_net_defn :
    forall dst src m d os d' ms,
      PB_net dst src m d = (os, d', ms) ->
      (os = [] /\ d' = d /\ ms = []) \/
      (dst = Primary /\ m = Ack /\ (
         (queue d = [] /\ os = [] /\ ms = [] /\ d' = d) \/
         (exists h t, queue d = h :: t /\
                      queue d' = t /\
                      ((t = [] /\ ms = []) \/
                       (exists y ys,
                          t = y :: ys /\
                          ms = [(Backup, BackItUp y)])) /\
                      let (us, st') := handler h (state d) in
                      os = [RequestResponse h us] /\
                      state d' = st'))) \/
      (dst = Backup /\ ms = [(Primary, Ack)] /\ queue d' = queue d /\ os = [] /\
       (exists i, m = BackItUp i /\
                  state d' = snd (handler i (state d)))).
  Proof using.
    unfold PB_net. intros.
    pb_unfold. repeat (first [break_let | break_match]); repeat find_inversion; auto.
    - right. left. intuition. right. eexists. eexists. intuition eauto.
      find_rewrite. auto.
    - right. left. intuition. right. eexists. eexists. intuition eauto.
      find_rewrite. auto.
    - right. right. intuition. eexists. eauto.
  Qed.

  Lemma PB_net_defn' :
    forall dst src m d os d' ms,
      PB_net dst src m d = (os, d', ms) ->
      (os = [] /\ d' = d /\ ms = [] /\
       ((dst = Primary /\ exists i, m = BackItUp i) \/
        (dst = Backup /\ m = Ack))) \/
      (dst = Primary /\ m = Ack /\ (
         (queue d = [] /\ os = [] /\ ms = [] /\ d' = d) \/
         (exists h t, queue d = h :: t /\
                      queue d' = t /\
                      ((t = [] /\ ms = []) \/
                       (exists y ys,
                          t = y :: ys /\
                          ms = [(Backup, BackItUp y)])) /\
                      let (us, st') := handler h (state d) in
                      os = [RequestResponse h us] /\
                      state d' = st'))) \/
      (dst = Backup /\ ms = [(Primary, Ack)] /\ queue d' = queue d /\ os = [] /\
       (exists i, m = BackItUp i /\
                  state d' = snd (handler i (state d)))).
  Proof using.
    unfold PB_net. intros.
    pb_unfold. repeat (first [break_let | break_match]); repeat find_inversion; auto; simpl.
    - left. intuition. left. eauto.
    - right. left. intuition.
    - right. left. intuition. right. eexists. eexists. intuition eauto.
      find_rewrite. auto.
    - right. left. intuition. right. eexists. eexists. intuition eauto.
      find_rewrite. auto.
    - right. right. intuition. eauto.
    - left. intuition.
  Qed.

  Instance PB_base_params : BaseParams :=
    Build_BaseParams
      PB_data
      PB_input
      PB_output.

  Instance PB_multi_params : MultiParams PB_base_params :=
    Build_MultiParams
      PB_base_params
      msg_eq_dec
      name_eq_dec
      all_nodes_all
      NoDup_all_nodes
      PB_init
      PB_net
      PB_input_handler.

  Definition inputs_1 (tr : list ((@input base_params) * (@output base_params))) :
      list (@input base_params) :=
    map (@fst _ _) tr.

  Definition inputs_m (tr : list (name * (@input PB_base_params + list (@output PB_base_params)))) :
    list (@input base_params) :=
    filterMap (fun x => match x with
                          | (Primary, inl (Request i)) => Some i
                          | _ => None
                        end)
              tr.

  Definition outputs_1 (tr : list ((@input base_params) * (@output base_params))) :
    list (@output base_params) :=
    map (@snd _ _) tr.

  Fixpoint outputs_m (tr : list (name * (@input PB_base_params + list (@output PB_base_params)))) :
    list (@output base_params) :=
    match tr with
      | [] => []
      | (Primary, inr l) :: tr' => filterMap (fun x => match x with
                                                         | RequestResponse i os => Some os
                                                         | _ => None
                                                       end) l ++ outputs_m tr'
      | _ :: tr' => outputs_m tr'
    end.

  Fixpoint processInputs (d : @data base_params) (l : list (@input base_params)) :
      (@data base_params * list (@output base_params)) :=
    match l with
      | [] => (d, [])
      | i :: l' => let (os, d') := @handler _ one_node_params i d in
                   let (d'', os') := processInputs d' l' in
                   (d'', os :: os')
    end.

  Definition correspond (st : @data base_params) (sigma : name -> @data PB_base_params) tr_1 tr_m :=
    let (d, os) := processInputs (state (sigma Primary)) (queue (sigma Primary)) in
    outputs_m tr_m ++ os = outputs_1 tr_1 /\
    d = st.

  Lemma inputs_1_nil_outputs_1_nil :
    forall tr,
      inputs_1 tr = [] ->
      outputs_1 tr = [].
  Proof using.
    destruct tr; auto.
    intros. simpl in *. discriminate.
  Qed.

  Lemma inputs_m_app :
    forall l1 l2,
      inputs_m (l1 ++ l2) = inputs_m l1 ++ inputs_m l2.
  Proof using.
    unfold inputs_m.
    intros.
    induction l1; simpl; repeat break_match; subst; simpl in *; auto using f_equal.
  Qed.

  Lemma inputs_m_inr :
    forall h t tr,
      inputs_m ((h, inr t) :: tr) = inputs_m tr.
  Proof using.
    unfold inputs_m.
    intros.
    simpl.
    repeat break_match; auto; discriminate.
  Qed.

  Lemma PB_net_out_case :
    forall dst src m d os d' ms,
      PB_net dst src m d = (os, d', ms) ->
      (dst = Backup /\ os = [] /\ queue d' = queue d) \/
      (dst = Primary /\ os = [] /\ d' = d) \/
      (dst = Primary /\ exists h t, queue d = h :: t /\ queue d' = t /\
                                    (let (us, st') := handler h (state d) in
                                     os = [RequestResponse h us] /\ state d' = st')).
  Proof using.
    intros.
    find_apply_lem_hyp PB_net_defn.
    intuition.
    - destruct dst; subst; intuition.
    - subst. right. right.
      intuition. break_exists. intuition eauto.
  Qed.

  Lemma outputs_m_app :
    forall tr1 tr2,
      outputs_m (tr1 ++ tr2) = outputs_m tr1 ++ outputs_m tr2.
  Proof using.
    intros. induction tr1; simpl.
    - auto.
    - repeat break_match; subst; auto.
      rewrite app_ass. auto using f_equal.
  Qed.

  Lemma correspond_preserved_primary_same_no_outputs :
    forall sigma sigma' st tr_1 tr_m tr_m',
      correspond st sigma tr_1 tr_m ->
      sigma' Primary = sigma Primary ->
      outputs_m tr_m' = [] ->
      correspond st sigma' tr_1 (tr_m ++ tr_m').
  Proof using.
    unfold correspond.
    intros.
    rewrite outputs_m_app.
    repeat find_rewrite.
    rewrite app_nil_r.
    auto.
  Qed.

  Lemma outputs_m_inr_nil :
    forall h l,
      outputs_m ((h,inr []) :: l) = outputs_m l.
  Proof using.
    destruct h; auto.
  Qed.

  Lemma outputs_m_inr_nil_singleton :
    forall h,
      outputs_m [(h,inr [])] = [].
  Proof using.
    intros.
    apply outputs_m_inr_nil.
  Qed.

  Lemma outputs_m_inl_read_singleton :
    forall h,
      outputs_m [(h, inl Read)] = [].
  Proof using.
    destruct h; auto.
  Qed.

  Lemma outputs_m_inr_primary_singleton :
    forall h i l,
      h = Primary ->
      outputs_m [(h, inr [RequestResponse i l])] = [l].
  Proof using.
    unfold outputs_m.
    intros.
    break_match; auto; congruence.
  Qed.

  Hint Extern 4 => congruence.

  Lemma correspond_preserved_primary_apply_entry :
    forall sigma sigma' st tr_1 tr_m tr_m' i l d h,
      correspond st sigma tr_1 tr_m ->
      handler i (state (sigma h)) = (l, state d) ->
      sigma' Primary = d ->
      outputs_m tr_m' = [l] ->
      h = Primary ->
      queue (sigma h) = i :: queue d ->
      correspond st sigma' tr_1 (tr_m ++ tr_m').
  Proof using.
    unfold correspond.
    intros.
    subst.
    rewrite outputs_m_app.
    repeat find_rewrite.
    simpl in *.
    repeat break_match. repeat find_inversion.
    find_rewrite. find_inversion.
    rewrite app_ass. auto.
  Qed.

  Lemma inputs_m_inr_singleton :
    forall h l,
      inputs_m [(h, inr l)] = [].
  Proof using.
    intros.
    rewrite inputs_m_inr.
    auto.
  Qed.

  Lemma inputs_m_app_inr_singleton :
    forall tr h l,
      inputs_m (tr ++ [(h, inr l)]) = inputs_m tr.
  Proof using.
    intros.
    rewrite inputs_m_app in *.
    rewrite inputs_m_inr_singleton in *.
    rewrite app_nil_r in *.
    auto.
  Qed.

  Lemma inputs_m_primary_inl :
    forall i l,
      inputs_m ((Primary, inl (Request i)) :: l) = i :: inputs_m l.
  Proof using.
    auto.
  Qed.

  Lemma inputs_m_primary_inl_request_singleton :
    forall i,
      inputs_m [(Primary, inl (Request i))] = [i].
  Proof using.
    auto.
  Qed.

  Lemma inputs_m_inl_read_singleton :
    forall h,
      inputs_m [(h, inl Read)] = [].
  Proof using.
    intros. destruct h; auto.
  Qed.

  Lemma inputs_m_inl_read :
    forall h l,
      inputs_m ((h, inl Read) :: l) = inputs_m l.
  Proof using.
    intros. destruct h; auto.
  Qed.

  Lemma list_destruct_last :
    forall A (l : list A),
      l = [] \/ exists l' x, l = l' ++ [x].
  Proof using.
    induction l; intuition.
    - subst. right. exists nil. simpl. eauto.
    - break_exists. subst. right. eexists. eexists.
      rewrite app_comm_cons. eauto.
  Qed.

  Lemma inputs_1_app :
    forall tr1 tr2,
      inputs_1 (tr1 ++ tr2) = inputs_1 tr1 ++ inputs_1 tr2.
  Proof using.
    unfold inputs_1. auto using map_app.
  Qed.

  Lemma outputs_1_app :
    forall tr1 tr2,
      outputs_1 (tr1 ++ tr2) = outputs_1 tr1 ++ outputs_1 tr2.
  Proof using.
    unfold outputs_1. auto using map_app.
  Qed.

  Lemma processInputs_app :
    forall l1 l2 d,
      processInputs d (l1 ++ l2) = let (d', os) := processInputs d l1 in
                                   let (d'', os') := processInputs d' l2 in
                                   (d'', os ++ os').
  Proof using.
    induction l1; intros; simpl in *; repeat break_match.
    - auto.
    - find_inversion. find_higher_order_rewrite.
      repeat break_match. repeat find_inversion.
      repeat find_rewrite. find_inversion.
      auto.
  Qed.

  Lemma correspond_preserved_snoc :
    forall sigma tr_1 tr_m st sigma' st' i l,
      correspond st sigma tr_1 tr_m ->
      handler i st = (l, st') ->
      state (sigma' Primary) = state (sigma Primary) ->
      queue (sigma' Primary) = queue (sigma Primary) ++ [i] ->
      correspond st' sigma' (tr_1 ++ [(i,l)]) (tr_m ++ [(Primary, inl (Request i))]).
  Proof using.
    unfold correspond.
    intros.
    rewrite outputs_m_app, outputs_1_app in *.
    repeat break_match.
    rewrite app_ass.
    simpl.
    repeat find_rewrite.
    rewrite processInputs_app in *.
    repeat break_match.
    repeat tuple_inversion.
    simpl in *. break_match. tuple_inversion.
    break_and. subst.
    find_rewrite. tuple_inversion.
    rewrite <- app_ass.
    find_rewrite.
    auto.
  Qed.

  Lemma inputs_m_backup_singleton :
    forall i,
      inputs_m [(Backup, inl i)] = [].
  Proof using.
    auto.
  Qed.

  Lemma inputs_m_backup :
    forall i l,
      inputs_m ((Backup, inl i) :: l) = inputs_m l.
  Proof using.
    auto.
  Qed.

  Lemma step_1_star_no_trace_no_step :
    forall st st' tr,
      step_1_star st st' tr ->
      tr = [] ->
      st = st'.
  Proof using.
    intros.
    invc H; auto.
    invc H1. discriminate.
  Qed.

  Lemma inputs_1_nil_is_nil :
    forall tr,
      inputs_1 tr = nil ->
      tr = nil.
  Proof using.
    intros.
    destruct tr; auto.
    discriminate.
  Qed.

  Lemma outputs_m_on_nil :
    outputs_m [] = [].
  Proof using.
    auto.
  Qed.

  Lemma outputs_1_on_nil :
    outputs_1 (@nil ((@input base_params) * ((@output base_params)))) = [].
  Proof using.
    auto.
  Qed.

  Lemma inputs_m_on_nil :
    inputs_m [] = [].
  Proof using.
    auto.
  Qed.

  Lemma processInputs_cons_defn :
    forall (st : @data base_params) (x : @input base_params) l,
      processInputs st (x :: l) = let (os, d') := handler x st in
                                  let (d'', os') := processInputs d' l in
                                  (d'', os :: os').
  Proof using.
    auto.
  Qed.

  Lemma processInputs_nil_defn :
    forall st,
      processInputs st [] = (st, []).
  Proof using.
    auto.
  Qed.

  Lemma outputs_m_inl_singleton :
    forall h i,
      outputs_m [(h, inl i)] = [].
  Proof using.
    destruct h; auto.
  Qed.

  Lemma inputs_1_singleton :
    forall l i,
      inputs_1 l = [i] ->
      exists os,
        l = [(i, os)].
  Proof using.
    intros.
    destruct l; simpl in *.
    - discriminate.
    - find_inversion. find_apply_lem_hyp inputs_1_nil_is_nil. subst.
      destruct p. eauto.
  Qed.

  Lemma step_1_star_singleton_trace :
    forall st st' i os,
      step_1_star st st' [(i, os)] ->
      step_1 st st' [(i, os)].
  Proof using.
    intros.
    invc H.
    invc H4.
    - rewrite app_nil_r in *. subst. auto.
    - invc H1. invc H. discriminate.
  Qed.

  Lemma step_1_singleton_inversion :
    forall st st' i os,
      step_1 st st' [(i, os)] ->
      handler i st = (os, st').
  Proof using.
    intros.
    invc H.
    auto.
  Qed.

  Lemma inputs_m_on_nil' :
    inputs_m (@nil (name * (PB_input + (list PB_output)))) = [].
  Proof using.
    unfold inputs_m. auto.
  Qed.

  Lemma correspond_init :
    correspond init PB_init [] [].
  Proof using.
    unfold correspond.
    break_let.
    simpl in *. tuple_inversion. auto.
  Qed.

  Lemma inputs_1_invert_app :
    forall tr tr' x,
      inputs_1 tr = tr' ++ [x] ->
      exists y z,
        tr = y ++ [z] /\
        inputs_1 y = tr' /\
        inputs_1 [z] = [x].
  Proof using.
    intros tr.
    pose proof list_destruct_last _ tr.
    intuition.
    - subst. destruct tr'; discriminate.
    - break_exists. subst.
      rewrite inputs_1_app in *.
      simpl in *.
      find_apply_lem_hyp app_inj_tail. intuition eauto.
  Qed.

  Lemma step_1_snoc_inv :
    forall st st' tr t,
      step_1_star st st' (tr ++ [t]) ->
      exists st2,
        step_1_star st st2 tr /\
        step_1 st2 st' [t].
  Proof using.
    intros.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    invc H.
    - destruct tr; discriminate.
    - invc H4. exists x'.
      find_apply_lem_hyp app_inj_tail.
      intuition. subst.
      + apply refl_trans_n1_1n_trace. auto.
      + subst. constructor. auto.
  Qed.

  Lemma outputs_m_read_response_singleton  :
    forall h o,
      outputs_m [(h, inr [ReadResponse o])] = [].
  Proof using.
    intros.
    simpl in *.
    break_match; auto.
  Qed.

  Lemma correspond_reachable :
    forall net tr_m,
      step_async_star step_async_init net tr_m ->
      forall st tr_1,
        step_1_star init st tr_1 ->
        inputs_1 tr_1 = inputs_m tr_m ->
        correspond st (nwState net) tr_1 tr_m.
  Proof using.
    intros net tr_m H.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    prep_induction H.
    induction H; intros; subst.
    - simpl in *. rewrite inputs_m_on_nil' in H3.
      destruct tr_1; try discriminate.
      invc H.
      + simpl. apply correspond_init.
      + invc H1. discriminate.
    - repeat concludes.
      invc H1; simpl in *.
      + find_apply_lem_hyp PB_net_defn.
        intuition; subst;
        try rewrite inputs_m_app in *;
        try rewrite inputs_m_inr_singleton in *;
        try rewrite app_nil_r in *;
        try break_exists;
        try break_let;
        try break_and;
        subst; repeat find_rewrite;
        eauto using
              correspond_preserved_primary_same_no_outputs,
        correspond_preserved_primary_apply_entry,
        update_nop,
        update_eq,
        update_diff,
        outputs_m_inr_nil_singleton.
      + find_apply_lem_hyp PB_input_handler_defn.
        intuition; subst;
        repeat rewrite snoc_assoc in *;
        repeat rewrite inputs_m_app in *.
        * break_exists. break_and. subst.
          rewrite inputs_m_inr_singleton in *. rewrite app_nil_r in *.
          rewrite inputs_m_primary_inl_request_singleton in *.
          find_apply_lem_hyp inputs_1_invert_app. break_exists. break_and.
          subst. simpl in *. find_inversion. destruct x1.
          find_apply_lem_hyp step_1_snoc_inv. break_exists. break_and.
          { eapply correspond_preserved_primary_same_no_outputs; eauto.
            eapply correspond_preserved_snoc; eauto.
            - eauto using step_1_singleton_inversion.
            - rewrite update_eq by auto. auto.
            - rewrite update_eq by auto. auto.
          }
        * rewrite inputs_m_inr_singleton in *. rewrite app_nil_r in *.
          rewrite inputs_m_inl_read_singleton in *. rewrite app_nil_r in *.
          eauto using
                correspond_preserved_primary_same_no_outputs,
          update_nop,
          outputs_m_inl_read_singleton,
          outputs_m_read_response_singleton.
        * rewrite inputs_m_inr_singleton in *.
          rewrite inputs_m_backup_singleton in *. repeat rewrite app_nil_r in *.
          eauto using correspond_preserved_primary_same_no_outputs, update_diff.
  Qed.

  Lemma correspond_inductive :
    forall net net' tr_m',
      step_async net net' tr_m' ->
      forall st st' tr_m tr_1 tr_1',
        correspond st (nwState net) tr_1 tr_m ->
        step_1_star st st' tr_1' ->
        inputs_1 tr_1' = inputs_m tr_m' ->
        correspond st' (nwState net') (tr_1 ++ tr_1') (tr_m ++ tr_m').
  Proof using.
    intros.
    invc H; repeat break_let; simpl in *;
    repeat match goal with
          | [ H : context [ inputs_m [(_, inr _)] ] |- _ ] =>
            rewrite inputs_m_inr_singleton in H
          | [ H : context [ inputs_m [(Primary, inl (Request _))] ] |- _ ] =>
            rewrite inputs_m_primary_inl_request_singleton in H
          | [ H : context [ inputs_m ((Primary, inl (Request _)) :: _) ] |- _ ] =>
            rewrite inputs_m_primary_inl in H
          | [ H : context [ inputs_m [(_, inl Read)] ] |- _ ] =>
            rewrite inputs_m_inl_read_singleton in H
          | [ H : context [ inputs_m ((_, inl Read) :: _) ] |- _ ] =>
            rewrite inputs_m_inl_read in H
          | [ H : context [ inputs_1 _ = [] ] |- _ ] =>
            apply inputs_1_nil_is_nil in H; subst
          | [ H : context [ inputs_m [_] ] |- _ ] =>
            rewrite inputs_m_backup_singleton in H
          | [ H : context [ inputs_m (_ :: _) ] |- _ ] =>
            rewrite inputs_m_backup in H
          | [ H : step_1_star _ _ [] |- _ ] =>
            apply step_1_star_no_trace_no_step in H; [|solve [auto]]; subst
          | [ H : step_1_star _ _ [_] |- _ ] =>
            apply step_1_star_singleton_trace in H
          | [ H : step_1 _ _ [_] |- _ ] =>
            apply step_1_singleton_inversion in H
          | [ |- context [ _ ++ [] ] ] =>
            repeat rewrite app_nil_r
          | [ H : context [ _ ++ [] ] |- _ ] =>
            repeat rewrite app_nil_r in *
          | [ H : context [ [] ++ _ ] |- _ ] =>
            repeat rewrite app_nil_l in *
          | [ H : context [PB_net _ _ _ _] |- _ ] => apply PB_net_defn in H
          | [ H : context [PB_input_handler _ _ _] |- _ ] => apply PB_input_handler_defn in H
          | [ H : context [inputs_1 _ = [_]] |- _ ] => apply inputs_1_singleton in H

          | [ H : _ /\ _ |- _ ] => break_and
          | [ H : exists _, _ |- _ ] => break_exists
          | [ H : _ \/ _ |- _ ] => break_or_hyp
          | _ => repeat break_let; repeat find_rewrite; repeat tuple_inversion; subst; auto
        end; repeat rewrite snoc_assoc;
      eauto using
              correspond_preserved_primary_same_no_outputs,
              update_nop,
              update_diff,
              outputs_m_inr_nil_singleton,
              outputs_m_inl_read_singleton,
              outputs_m_read_response_singleton.
    - eapply correspond_preserved_primary_apply_entry; eauto using update_eq.
    - eapply correspond_preserved_primary_apply_entry; eauto using update_eq.
    - eapply correspond_preserved_primary_same_no_outputs; eauto.
      eapply correspond_preserved_snoc; eauto; rewrite update_eq by auto; repeat find_rewrite; auto.
    - eapply correspond_preserved_primary_same_no_outputs; eauto.
      eapply correspond_preserved_snoc; eauto; rewrite update_eq by auto; repeat find_rewrite; auto.
  Qed.

  Lemma step_async_outputs_m :
    forall net net' tr,
      step_async net net' tr ->
      (inputs_m tr = [] /\ (outputs_m tr = [] /\ nwState net Primary = nwState net' Primary)) \/
      (inputs_m tr = [] /\ exists os, outputs_m tr = [os]) \/
      (exists i, inputs_m tr = [i]).
  Proof using.
    intros.
    invc H; simpl; break_match; auto;
    repeat rewrite app_nil_r in *;
    simpl in *;
    try find_apply_lem_hyp PB_net_defn;
    try find_apply_lem_hyp PB_input_handler_defn;
    intuition; subst.
    - rewrite inputs_m_inr_singleton.
      rewrite update_eq by auto.
      auto.
    - rewrite inputs_m_inr_singleton.
      rewrite update_eq by auto.
      auto.
    - break_exists. intuition; break_match.
      + intuition. subst.
        rewrite inputs_m_inr_singleton. simpl. eauto.
      + break_exists.  intuition. subst.
        rewrite inputs_m_inr_singleton. simpl. eauto.
    - rewrite inputs_m_inr_singleton.
      rewrite update_diff by auto. auto.
    - rewrite inputs_m_inr_singleton.
      rewrite update_diff by auto. auto.
    - break_exists. intuition; subst; rewrite inputs_m_primary_inl; eauto.
    - rewrite inputs_m_inl_read. rewrite update_eq by auto. auto.
    - rewrite inputs_m_inl_read. rewrite update_diff by auto. auto.
    - rewrite inputs_m_backup.
      rewrite update_diff by auto. auto.
  Qed.

  Definition network_invariant (net : @network _ PB_multi_params) : Prop :=
    (nwPackets net = [] /\ state (nwState net Primary) = state (nwState net Backup)) \/
    (exists i is, nwPackets net = [mkPacket Primary Backup (BackItUp i)] /\
               queue (nwState net Primary) = i :: is /\
               state (nwState net Primary) = state (nwState net Backup)) \/
    (nwPackets net = [mkPacket Backup Primary Ack] /\
     exists i is, queue (nwState net Primary) = i :: is /\
                  snd (handler i (state (nwState net Primary))) = state (nwState net Backup)).

  Ltac prep := subst; simpl in *; try find_inversion; repeat find_rewrite; simpl in *.

  Ltac workhorse :=
    repeat (prep;
            match goal with
             | [ H : _ /\ _ |- _ ] => break_and
             | [ H : exists _, _ |- _ ] => break_exists
             | [ H : _ ++ _ :: _ = [] |- _ ] => solve [exfalso; eapply app_cons_not_nil; eauto]
             | [ H : _ ++ _ :: _ = [ _ ] |- _ ] => apply app_cons_singleton_inv in H
             | [ H : context [ let (_,_) := ?X in _ ] |- _ ] => destruct X eqn:?
             | [ |- context [ let (_,_) := ?X in _ ] ] => destruct X eqn:?
             | [ |- context [ update _ (nwState ?net) ?x (nwState ?net ?x) _ ] ] => rewrite update_nop
             | [ |- context [ update _ _ ?x _ ?x ] ] => rewrite update_eq by auto
             | [ |- context [ update _ _ ?x _ ?y ] ] => rewrite update_diff by auto

             | [ H : _ \/ _ |- _ ] => invc H
           end); prep.

  Lemma network_invariant_inductive :
    forall net net' tr,
      step_async net net' tr ->
      network_invariant net ->
      network_invariant net'.
  Proof using.
    intros.
    invc H; simpl in *.
    - unfold network_invariant in *. simpl.
      find_apply_lem_hyp PB_net_defn'.
      workhorse; auto; intuition eauto.
    - unfold network_invariant in *. simpl.
      find_apply_lem_hyp PB_input_handler_defn.
      workhorse; auto; intuition eauto.
  Qed.

  Lemma network_invariant_init :
    network_invariant step_async_init.
  Proof using.
    unfold network_invariant. simpl. auto.
  Qed.

  Lemma correspond_Prefix :
    forall st net tr_1 tr_m,
      correspond st (nwState net) tr_1 tr_m ->
      Prefix (outputs_m tr_m) (outputs_1 tr_1).
  Proof using.
    unfold correspond.
    intros. break_let. intuition. subst.
    eauto using app_Prefix.
  Qed.

  Fixpoint revert_trace (tr : list (name * ((@input PB_base_params) + list (@output PB_base_params)))) :
    list (@input base_params * (@output base_params)) :=
    match tr with
      | [] => []
      | (h, t) :: tr' => match t with
                           | inr l => filterMap (fun x => match x with
                                                            | RequestResponse i os => Some (i, os)
                                                            | _ => None
                                                          end) l
                           | _ => []
                         end ++ revert_trace tr'
    end.

  Definition revert_state (net : network) : @data base_params := state (nwState net Primary).

  Lemma revert_state_defn :
    forall net,
      revert_state net = state (nwState net Primary).
  Proof using.
    unfold revert_state. auto.
  Qed.

  Lemma inductive_simulation :
    forall net net' tr,
      step_async net net' tr ->
      step_1_star (revert_state net) (revert_state net') (revert_trace tr).
  Proof using.
    intros.
    invc H.
    - repeat rewrite revert_state_defn. simpl. rewrite app_nil_r.
      simpl in *.
      find_apply_lem_hyp PB_net_defn.
      intuition; subst.
      + rewrite update_nop. constructor.
      + rewrite update_nop. constructor.
      + break_exists. intuition; break_let.
        * intuition. subst.
          rewrite <- app_nil_r. econstructor; constructor. repeat find_rewrite.
          rewrite update_eq by auto. auto.
        * break_exists. intuition. subst. simpl in *.
          rewrite <- app_nil_r. econstructor; constructor. repeat find_rewrite.
          rewrite update_eq by auto. auto.
      + repeat find_rewrite.
        rewrite update_diff by auto. constructor.
    - repeat rewrite revert_state_defn. simpl in *.
      find_apply_lem_hyp PB_input_handler_defn.
      intuition; subst.
      + rewrite update_eq by auto. repeat find_rewrite. constructor.
      + rewrite update_nop. constructor.
      + rewrite update_diff by auto. constructor.
  Qed.

  Lemma revert_trace_app :
    forall tr1 tr2,
      revert_trace (tr1 ++ tr2) = revert_trace tr1 ++ revert_trace tr2.
  Proof using.
    induction tr1; intros; simpl.
    - auto.
    - rewrite IHtr1.
      repeat break_match; subst.
      + auto.
      + rewrite app_ass. auto.
  Qed.

  Lemma simulation :
    forall net tr,
      step_async_star step_async_init net tr ->
      step_1_star init (revert_state net) (revert_trace tr).
  Proof using.
    intros.
    apply refl_trans_1n_n1_trace in H.
    prep_induction H.
    induction H; intros; subst.
    - unfold step_async_init, revert_state. constructor.
    - repeat concludes. rewrite revert_trace_app.
      unfold step_1_star.
      find_apply_lem_hyp inductive_simulation.
      simpl in *.
      unfold step_1_star in *.
      eauto using refl_trans_1n_trace_trans.
  Qed.

  Theorem transformer :
    forall (P : list (input * output) -> Prop),
      (forall st tr,
         step_1_star init st tr ->
         P tr) ->
      (forall net tr,
         step_async_star step_async_init net tr ->
         P (revert_trace tr)).
  Proof using.
    intros.
    find_apply_lem_hyp simulation.
    eauto.
  Qed.

  Lemma inputs_m_on_cons :
    forall t tr,
      inputs_m (t :: tr) = match t with
                             | (Primary, inl (Request i)) => i :: inputs_m tr
                             | _ => inputs_m tr
                           end.
  Proof using.
    unfold inputs_m.
    intros. simpl.
    repeat break_match; repeat find_inversion; auto; try discriminate.
  Qed.

  Definition no_output_at_backup {A} x := forall y, snd x = @inr A _ y ->
                                                      fst x = Primary \/
                                                      match y with
                                                        | [] => True
                                                        | [ReadResponse _] => True
                                                        | _ => False
                                                      end.

  Definition no_output_at_backup_trace {A} tr := (forall x, In x tr -> @no_output_at_backup A x).

  Lemma NOABT_tail :
    forall A x y,
      @no_output_at_backup_trace A (x :: y) ->
      no_output_at_backup_trace y.
  Proof using.
    unfold no_output_at_backup_trace.
    intros. simpl in *. eauto.
  Qed.

  Lemma NOABT_contra :
    forall A l tr,
      @no_output_at_backup_trace A ((Backup, inr l) :: tr) ->
      l = [] \/
      exists d,
        l = [ReadResponse d].
  Proof using.
    unfold no_output_at_backup_trace, no_output_at_backup.
    intros. simpl in *.
    find_insterU.
    econcludes.
    find_insterU.
    simpl in *.
    econcludes.
    intuition.
    repeat break_match; intuition eauto.
  Qed.

  Lemma outputs_m_revert_trace :
    forall tr,
      no_output_at_backup_trace tr ->
      outputs_m tr = outputs_1 (revert_trace tr).
  Proof using.
    unfold outputs_1.
    induction tr; simpl; intros.
    - auto.
    - repeat break_match; subst.
      + eauto using NOABT_tail.
      + rewrite IHtr by eauto using NOABT_tail.
        rewrite map_app. rewrite map_of_filterMap.
        f_equal. apply filterMap_ext. intros.
        repeat break_match; auto.
      + rewrite IHtr by eauto using NOABT_tail. auto.
      + find_copy_apply_lem_hyp NOABT_tail.
        find_apply_lem_hyp NOABT_contra. intuition; break_exists;
        subst; simpl; auto.
  Qed.

  Lemma NOABT_nil :
    forall A,
      @no_output_at_backup_trace A [].
  Proof using.
    unfold no_output_at_backup_trace.
    simpl. intuition.
  Qed.

  Lemma NOABT_cons :
    forall A x y,
      no_output_at_backup x ->
      @no_output_at_backup_trace A y ->
      no_output_at_backup_trace (x :: y).
  Proof using.
    unfold no_output_at_backup_trace, no_output_at_backup.
    simpl. intros. intuition; subst; eauto.
  Qed.

  Lemma NOABT_head :
    forall A x y,
      @no_output_at_backup_trace A (x :: y) ->
      no_output_at_backup x.
  Proof using.
    unfold no_output_at_backup_trace, no_output_at_backup.
    simpl. intuition.
  Qed.

  Lemma NOABT_app :
    forall A xs ys,
      @no_output_at_backup_trace A xs ->
      no_output_at_backup_trace ys ->
      no_output_at_backup_trace (xs ++ ys).
  Proof using.
    induction xs; intros; simpl in *; auto.
    eauto using NOABT_cons,
    NOABT_head,
    NOABT_tail.
  Qed.

  Lemma NOABT_singleton_inr_nil :
    forall A h,
      @no_output_at_backup_trace A [(h, inr [])].
  Proof using.
    unfold no_output_at_backup_trace, no_output_at_backup.
    simpl. intros. intuition. subst. simpl in *. find_inversion. auto.
  Qed.

  Lemma NOABT_singleton_inr_read_response :
    forall A h d,
      @no_output_at_backup_trace A [(h, inr [ReadResponse d])].
  Proof using.
    unfold no_output_at_backup_trace, no_output_at_backup.
    simpl. intros. intuition. subst. simpl in *. find_inversion. auto.
  Qed.

  Lemma NOABT_singleton_primary :
    forall A out,
      no_output_at_backup_trace [(Primary, @inr A _ out)].
  Proof using.
    unfold no_output_at_backup_trace, no_output_at_backup.
    simpl.
    intuition.  subst. simpl in *. find_inversion. auto.
  Qed.

  Lemma NOABT_singleton_inl :
    forall A h r,
      @no_output_at_backup_trace A [(h, inl r)].
  Proof using.
    unfold no_output_at_backup_trace, no_output_at_backup.
    simpl. intuition. subst. simpl in *. discriminate.
  Qed.

  Theorem pbj_NOABT :
    forall net tr,
      step_async_star (params:=PB_multi_params) step_async_init net tr ->
      no_output_at_backup_trace tr.
  Proof using.
    intros.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    prep_induction H.
    induction H; intros.
    - auto using NOABT_nil.
    - subst. repeat concludes.
      apply NOABT_app; auto.
      invc H1; simpl in *.
      + find_apply_lem_hyp PB_net_defn'.
        intuition; subst; repeat find_rewrite;
        auto using NOABT_singleton_inr_nil, NOABT_singleton_primary.
      + rewrite cons_cons_app. apply NOABT_app.
        * auto using NOABT_singleton_inl.
        * find_apply_lem_hyp PB_input_handler_defn.
          intuition; break_exists; intuition; subst;
          auto using NOABT_singleton_inr_nil, NOABT_singleton_inr_read_response.
  Qed.

  Definition zero_or_one_outputs_per_step {A B C} t :=
    forall y, @snd A _  t = @inr B _ y -> y = [] \/ exists z : C, y = [z].

  Definition zero_or_one_outputs_per_step_trace {A B C} tr :=
    forall x, In x tr -> @zero_or_one_outputs_per_step A B C x.

  Lemma ZOOOPST_nil :
    forall A B C,
      @zero_or_one_outputs_per_step_trace A B C [].
  Proof using.
    unfold zero_or_one_outputs_per_step_trace, zero_or_one_outputs_per_step.
    simpl. intuition.
  Qed.

  Lemma ZOOOPST_head :
    forall A B C x y,
      @zero_or_one_outputs_per_step_trace A B C (x :: y) ->
      zero_or_one_outputs_per_step x.
  Proof using.
    unfold zero_or_one_outputs_per_step_trace, zero_or_one_outputs_per_step.
    simpl.
    eauto.
  Qed.

  Lemma ZOOOPST_tail :
    forall A B C x y,
      @zero_or_one_outputs_per_step_trace A B C (x :: y) ->
      zero_or_one_outputs_per_step_trace y.
  Proof using.
    unfold zero_or_one_outputs_per_step_trace, zero_or_one_outputs_per_step.
    simpl.
    eauto.
  Qed.

  Lemma ZOOOPST_cons_elim :
    forall A B C x y,
      @zero_or_one_outputs_per_step_trace A B C (x :: y) ->
      zero_or_one_outputs_per_step x /\
      zero_or_one_outputs_per_step_trace y.
  Proof using.
    intuition eauto using ZOOOPST_head, ZOOOPST_tail.
  Qed.

  Lemma ZOOOPST_cons_intro :
    forall A B C x y,
      @zero_or_one_outputs_per_step A B C x ->
      zero_or_one_outputs_per_step_trace y ->
      zero_or_one_outputs_per_step_trace (x :: y).
  Proof using.
    unfold zero_or_one_outputs_per_step_trace, zero_or_one_outputs_per_step.
    simpl.
    intuition; subst; simpl in *; try discriminate; eauto.
  Qed.

  Lemma ZOOOPST_app :
    forall A B C xs ys,
      @zero_or_one_outputs_per_step_trace A B C xs ->
      zero_or_one_outputs_per_step_trace ys ->
      zero_or_one_outputs_per_step_trace (xs ++ ys).
  Proof using.
    induction xs; intros.
    - auto.
    - eauto using ZOOOPST_cons_intro, ZOOOPST_head, ZOOOPST_tail.
  Qed.

  Lemma ZOOOPST_singleton_nil :
    forall A B C h,
      @zero_or_one_outputs_per_step_trace A B C [(h, inr [])].
  Proof using.
    unfold zero_or_one_outputs_per_step_trace, zero_or_one_outputs_per_step.
    simpl in *.
    intuition. subst. simpl in *. find_inversion. auto.
  Qed.

  Lemma ZOOOPST_singleton_singleton :
    forall A B C h x,
      @zero_or_one_outputs_per_step_trace A B C [(h, inr [x])].
  Proof using.
    unfold zero_or_one_outputs_per_step_trace, zero_or_one_outputs_per_step.
    simpl. intuition. subst. simpl in *. find_inversion. eauto.
  Qed.

  Lemma ZOOOPST_singleton_inl :
    forall A B C h i,
      @zero_or_one_outputs_per_step_trace A B C [(h, inl i)].
  Proof using.
    unfold zero_or_one_outputs_per_step_trace, zero_or_one_outputs_per_step.
    simpl. intuition. subst. discriminate.
  Qed.

  Theorem pbj_0_or_1 :
    forall net tr,
      step_async_star (params:=PB_multi_params) step_async_init net tr ->
      zero_or_one_outputs_per_step_trace tr.
  Proof using.
    intros.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    prep_induction H.
    induction H; intros; subst.
    - auto using ZOOOPST_nil.
    - repeat concludes.
      apply ZOOOPST_app; auto.
      invc H1; simpl in *.
      + find_apply_lem_hyp PB_net_defn.
        intuition; subst; auto using ZOOOPST_singleton_nil.
        break_exists. break_and. break_match.
        intuition; subst; auto using ZOOOPST_singleton_singleton.
      + rewrite cons_cons_app.
        apply ZOOOPST_app.
        * auto using ZOOOPST_singleton_inl.
        * find_apply_lem_hyp PB_input_handler_defn; intuition; subst;
          auto using ZOOOPST_singleton_nil, ZOOOPST_singleton_singleton.
  Qed.

  Lemma inputs_1_m_revert :
    forall net tr,
      step_async_star (params := PB_multi_params) step_async_init net tr ->
      inputs_m tr = inputs_1 (revert_trace tr) ++ queue (nwState net Primary).
  Proof using.
    intros.
    find_apply_lem_hyp refl_trans_1n_n1_trace.
    prep_induction H.
    induction H; intros; subst.
    - simpl. auto.
    - repeat concludes.
      rewrite inputs_m_app.
      rewrite revert_trace_app.
      rewrite inputs_1_app.
      rewrite IHrefl_trans_n1_trace.
      repeat rewrite app_ass.
      f_equal.
      invc H1; simpl in *.
      + find_apply_lem_hyp PB_net_defn.
        intuition; subst; simpl in *; rewrite (inputs_m_inr_singleton);
        rewrite app_nil_r.
        * rewrite update_nop. auto.
        * repeat find_rewrite. rewrite update_nop. auto.
        * break_exists. break_let.
          { intuition; subst.
            - repeat find_rewrite. rewrite app_nil_r. simpl. rewrite update_eq by auto. auto.
            - break_exists. intuition. subst. repeat find_rewrite.
              simpl. rewrite update_eq by auto. auto.
          }
        * break_exists.  intuition. repeat find_rewrite. rewrite update_diff by auto. auto.
      + find_apply_lem_hyp PB_input_handler_defn.
        intuition; subst; simpl in *.
        * break_exists.
          intuition; subst;
          rewrite (inputs_m_primary_inl); rewrite update_eq; auto.
        * rewrite (inputs_m_inl_read).
          rewrite inputs_m_inr_singleton.
          rewrite app_nil_r. rewrite update_nop. auto.
        * rewrite (inputs_m_backup).
          rewrite inputs_m_inr_singleton.
          rewrite app_nil_r. rewrite update_nop. auto.
  Qed.
End PrimaryBackup.


(* Sanity theorems for ptt. *)

Require config.
Require Import config_tactics.

Require Import syntax.
Require Import tt.
Require Import checking_tactics ptt_admissible.

Section PttSanity.

Local Instance havePrecondition : config.Precondition := {| config.flagPrecondition := config.Yes |}.
Context `{configReflection : config.Reflection}.
Context `{configBinaryProdType : config.BinaryProdType}.
Context `{configProdEta : config.ProdEta}.
Context `{configUniverses : config.Universes}.
Context `{configPropType : config.PropType}.
Context `{configIdType : config.IdType}.
Context `{configIdEliminator : config.IdEliminator}.
Context `{configEmptyType : config.EmptyType}.
Context `{configUnitType : config.UnitType}.
Context `{configBoolType : config.BoolType}.
Context `{configProdType : config.ProdType}.
Context `{configSyntax : syntax.Syntax}.

Axiom cheating : forall A, A.

Definition sane_issubst sbs G D :
  issubst sbs G D -> isctx G * isctx D.
Proof.
  intro H ; destruct H ; doConfig.

  (* SubstZero *)
  { split.

    - assumption.
    - now capply CtxExtend.
  }

  (* SubstWeak *)
  { split.

    - now capply CtxExtend.
    - assumption.
  }

  (* SubstShift *)
  { split.

    - magic.
    - magic.
  }

  (* SubstId *)
  { split.
    - assumption.
    - assumption.
  }

  (* SubstComp *)
  { split.
    - assumption.
    - assumption.
  }

  (* SubstTerminal *)
  { split.
    - assumption.
    - magic.
  }

  (* SubstCtxConv *)
  { split.
    - assumption.
    - assumption.
  }
Qed.

Definition sane_istype G A :
  istype G A -> isctx G.
Proof.
  intro H; destruct H ; config assumption.
Qed.

Definition sane_isterm' G u A :
  isterm G u A -> istype G A.
Proof.
  intro H ; destruct H.

  (* TermTyConv *)
  { config assumption. }

  (* TermCtxConv *)
  { magic. }

  (* TermSubst *)
  { magic. }

  (* TermVarZero *)
  { ceapply TySubst.
    - now ceapply SubstWeak.
    - assumption.
    - magic.
    - eassumption.
  }

  (* TermVarSucc *)
  { magic. }

  (* TermAbs *)
  { now capply (@TyProd). }

  (* TermApp *)
  { magic. }

  (* TermRefl *)
  { now capply TyId. }

  (* TermJ *)
  { magic. Unshelve. all:strictmagic. }

  (* TermExfalso *)
  { assumption. }

  (* TermUnit *)
  { now capply TyUnit. }

  (* TermTrue *)
  { now capply TyBool. }

  (* TermFalse *)
  { now capply TyBool. }

  (* TermCond *)
  { magic. }

  (* TermPair *)
  { magic. }

  (* TermProjOne *)
  { magic. }

  (* TermProjTwo *)
  { magic. }

  (* TermUniProd *)
  { magic. }

  (* TermUniProdProp *)
  { magic. }

  (* TermUniId *)
  { magic. }

  (* TermUniEmpty *)
  { magic. }

  (* TermUniUnit *)
  { magic. }

  (* TermUniBool *)
  { magic. }

  (* TermUniBinaryProd *)
  { magic. }

  (* TermUniBinaryProdProp *)
  { magic. }

  (* TermUniUni *)
  { magic. }

  (* TermUniProp *)
  { magic. }
Qed.

Definition sane_isterm G u A :
  isterm G u A -> isctx G * istype G A.
Proof.
  intro H.
  pose (K := sane_isterm' G u A H).
  split ; [now apply (@sane_istype G A) | assumption].
Qed.

Definition sane_eqtype' G A B :
  eqtype G A B -> istype G A * istype G B.
Proof.
  intro H ; destruct H ; doConfig.

  (* EqTyCtxConv *)
  { split.
    - magic.
    - magic.
  }

  (* EqTyRefl*)
  { split ; assumption. }

  (* EqTySym *)
  { split ; assumption. }

  (* EqTyTrans *)
  { split ; assumption. }

  (* EqTyIdSubst *)
  { split.
    - ceapply TySubst.
      + now capply SubstId.
      + assumption.
      + assumption.
      + eassumption.
    - assumption.
  }

  (* EqTySubstComp *)
  { split.
    - magic.
    - magic.
  }

  (* EqTySubstProd *)
  { split.
    - magic.
    - magic.
  }

  (* EqTySubstId *)
  { split.
    - magic.
    - magic.
  }

  (* EqTySubstEmpty *)
  { split.
    - magic.
    - magic.
  }

  (* EqTySubstUnit *)
  { split.
    - magic.
    - magic.
  }

  (* EqTySubstBool *)
  { split.
    - magic.
    - magic.
  }

  (* EqTyExfalso *)
  { split ; assumption. }

  (* CongProd *)
  { split.
    - { now capply TyProd. }
    - magic.
  }

  (* CongId *)
  { split.
    - { now capply TyId. }
    - magic.
  }

  (* CongTySubst *)
  { split.
    - magic.
    - magic.
  }

  (* CongBinaryProd *)
  { split.
    - magic.
    - magic.
  }

  (* EqTySubstBinaryProd *)
  { split.
    - magic.
    - magic.
  }

  (* EqTySubstUni *)
  { split.
    - magic.
    - magic.
  }

  (* ElProd *)
  { split.
    - magic.
    - magic.
  }

  (* ElProdProp *)
  { split.
    - magic.
    - magic.
  }

  (* ElId *)
  { split.
    - magic.
    - magic.
  }

  (* ElSubst *)
  { split.
    - magic.
    - magic.
  }

  (* ElEmpty *)
  { split.
    - magic.
    - magic.
  }

  (* ElUnit *)
  { split.
    - magic.
    - magic.
  }

  (* ElBool *)
  { split.
    - magic.
    - magic.
  }

  (* ElBinaryProd *)
  { split.
    - magic.
    - magic.
  }

  (* ElBinaryProdProp *)
  { split.
    - magic.
    - magic.
  }

  (* ElUni *)
  { split.
    - magic.
    - magic.
  }

  (* ElProp *)
  { split.
    - magic.
    - magic.
  }

  (* CongEl *)
  { split.
    - magic.
    - magic.
  }

Qed.

Theorem sane_eqctx G D :
  eqctx G D -> isctx G * isctx D.
Proof.
  intro H ; destruct H ; doConfig.

  (* CtxRefl *)
  { split.
    - assumption.
    - assumption.
  }

  (* CtxSym *)
  { split.
    - assumption.
    - assumption.
  }

  (* CtxTrans *)
  { split.
    - assumption.
    - assumption.
  }

  (* EqCtxEmpty *)
  { split.
    - now capply CtxEmpty.
    - now capply CtxEmpty.
  }

  (* EqCtxExtend *)
  { split.
    - now capply CtxExtend.
    - magic.
  }

Qed.

Theorem sane_eqtype G A B :
  eqtype G A B -> isctx G * istype G A * istype G B.
Proof.
  intro H.
  destruct (sane_eqtype' G A B H).
  auto using (sane_istype G A).
Qed.

Theorem sane_eqsubst' sbs sbt G D :
  eqsubst sbs sbt G D -> issubst sbs G D * issubst sbt G D.
Proof.
  intro H ; destruct H ; doConfig.

  (* SubstRefl *)
  - { split.
      - assumption.
      - assumption.
    }

  (* SubstSym *)
  - { split.
      - assumption.
      - assumption.
    }

  (* SubstTrans *)
  - { split.
      - assumption.
      - assumption.
    }

  (* CongSubstZero *)
  - { split.
      - now capply SubstZero.
      - magic.
    }

  (* CongSubstWeak *)
  - { split ; magic. }

  (* CongSubstShift *)
  - { split ; magic. }

  (* CongSubstComp *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstCtxConv *)
  - { split.
      - magic.
      - magic.
    }

  (* CompAssoc *)
  - { split.
      - magic.
      - magic.
    }

  (* WeakNat *)
  - { split.
      - magic.
      - magic.
    }

  (* WeakZero *)
  - { split.
      - magic.
      - magic.
    }

  (* ShiftZero *)
  - { split.
      - magic.
      - magic.
    }

  (* CompShift *)
  - { split.
      - magic. Unshelve. all:magic. Unshelve. all:strictmagic.
      - magic.
    }

  (* CompIdRight *)
  - { split.
      - magic.
      - assumption.
    }

  (* CompIdLeft *)
  - { split.
      - magic.
      - assumption.
    }
Qed.

Theorem sane_eqsubst sbs sbt G D :
  eqsubst sbs sbt G D -> isctx G * isctx D * issubst sbs G D * issubst sbt G D.
Proof.
  intro H.
  destruct (sane_eqsubst' sbs sbt G D H).
  auto using (sane_issubst sbs G D).
Qed.

Theorem sane_eqterm' G u v A :
  eqterm G u v A -> isterm G u A * isterm G v A.
Proof.
  intro H ; destruct H ; doConfig.

  (* EqTyConv *)
  - { split.
      - magic.
      - magic.
    }

  (* EqCtxConv *)
  - { split.
      - magic.
      - magic.
    }

  (* EqRefl *)
  - { split.
      - { assumption. }
      - { assumption. }
    }

  (* EqSym *)
  - { split.
      - { assumption. }
      - { assumption. }
    }

  (* EqTrans *)
  - { split.
      - { assumption. }
      - { assumption. }
    }

  (* EqIdSubst *)
  - { split.
      - magic.
      - { assumption. }
    }

  (* EqSubstComp *)
  - { split.
      - magic. Unshelve. all:strictmagic.
      - magic.
    }

  (* EqSubstWeak *)
  - { split.
      - magic.
      - { now capply TermVarSucc. }
    }

  (* EqSubstZeroZero *)
  - { split.
      - magic.
      - { assumption. }
    }

  (* EqSubstZeroSucc *)
  - { split.
      - magic.
        Unshelve. all:strictmagic.
      - { assumption. }
    }

  (* EqSubstShiftZero *)
  - { split.
      - { ceapply TermTyConv.
          - ceapply TermSubst.
            + ceapply SubstShift ; eassumption.
            + magic.
            + config constructor.
              * assumption.
              * ceapply TySubst ; eassumption.
            + ceapply TySubst ; try eassumption ; magic.
            + magic.
          - magic.
          - config constructor.
            + assumption.
            + ceapply TySubst ; eassumption.
          - ceapply TySubst.
            + ceapply SubstShift ; eassumption.
            + ceapply TySubst ; magic.
            + config constructor.
              * assumption.
              * ceapply TySubst ; eassumption.
            + magic.
          - ceapply TySubst.
            + ceapply SubstWeak.
              * ceapply TySubst ; eassumption.
              * assumption.
            + ceapply TySubst ; eassumption.
            + config constructor. (* There may be room for maigc improvement here *)
              * assumption.
              * ceapply TySubst ; eassumption.
            + magic.
        }
      - { magic. }
    }

  (* EqSubstShiftSucc *)
  - { split.
      - { magic. Unshelve. all:strictmagic. }
      - { magic. }
    }

  (* EqSubstAbs *)
  - { split.
      - { magic. Unshelve. all:strictmagic. }
      - { magic. }
    }

  (* EqSubstApp *)
  - { split.
      - { magic. }
      - { magic. Unshelve. all:strictmagic. }
    }

  (* EqSubstRefl *)
  - { split.
      - { magic. Unshelve. all:strictmagic. }
      - { magic. }
    }

  (* EqSubstJ *)
  - { split.
      - { magic. Unshelve. all:strictmagic. }
      - { apply cheating.
          (* SLOW:
             magic.
             Unshelve. all:try okmagic.
             Unshelve. all:strictmagic.
         *)
        }
    }

  (* EqSubstExfalso *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* EqSubstUnit *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* EqSubstTrue *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* EqSubstFalse *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* EqSubstCond *)
  - { split.
      - { magic. }
      - { magic.
          Unshelve. all:strictmagic.
        }
    }

  (* EqTermExfalso *)
  - { split.
      - { assumption. }
      - { assumption. }
    }

  (* UnitEta *)
  - { split.
      - { assumption. }
      - { magic. }
    }

  (* EqReflection *)
  - { split.
      - { assumption. }
      - { magic. }
    }

  (* ProdBeta *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* CondTrue *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* CondFalse *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* ProdEta *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* JRefl *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* CongAbs *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* CongApp *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* CongRefl *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* CongJ *)
  - { split.
      - { magic. }
      - { apply cheating.
          (* SLOW:
          magic.
          Unshelve. all:magic.
          Unshelve. all:strictmagic.
          *)
        }
    }

  (* CongCond *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* CongTermSubst *)
  - { split.
      - { magic. }
      - { magic. }
    }

  (* CongPair *)
  - { split.
      - magic.
      - magic.
    }

  (* CongProjOne *)
  - { split.
      - magic.
      - magic.
    }

  (* CongProjTwo *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstPair *)
  - { split.
      - magic. Unshelve. all:strictmagic.
      - magic.
    }

  (* EqSubstProjOne *)
  - { split.
      - magic.
      - magic. Unshelve. all:strictmagic.
    }

  (* EqSubstProjTwo *)
  - { split.
      - magic.
      - magic. Unshelve. all:strictmagic.
    }

  (* ProjOnePair *)
  - { split.
      - magic.
      - magic.
    }

  (* ProjTwoPair *)
  - { split.
      - magic.
      - magic.
    }

  (* PairEta *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstUniProd *)
  - { split.
      - magic.
      - magic.
        Unshelve. all: try apply CtxRefl. all:strictmagic.
    }

  (* EqSubstUniProdProp *)
  - { split.
      - magic.
      - magic.
        Unshelve. all: try apply CtxRefl. all:strictmagic.
    }

  (* EqSubstUniId *)
  - { split.
      - magic.
      - magic.
        Unshelve. all:strictmagic.
    }

  (* EqSubstUniEmpty *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstUniUnit *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstUniBool *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstUniBinaryProd *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstUniBinaryProdProp *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstUniUni *)
  - { split.
      - magic.
      - magic.
    }

  (* EqSubstUniProp *)
  - { split.
      - magic.
      - magic.
    }

  (* CongUniProd *)
  - { split.
      - magic.
      - magic.
    }

  (* CongUniProdProp *)
  - { split.
      - magic.
      - magic.
    }

  (* CongUniId *)
  - { split.
      - magic.
      - magic.
    }

  (* CongUniBinaryProd *)
  - { split.
      - magic.
      - magic.
    }

  (* CongUniBinaryProdProp *)
  - { split.
      - magic.
      - magic.
    }
Qed.

Theorem sane_eqterm G u v A :
  eqterm G u v A -> isctx G * istype G A * isterm G u A * isterm G v A.
Proof.
  intro H.
  destruct (sane_eqterm' G u v A H).
  auto using (@sane_isterm G u A).
Qed.

End PttSanity.


From iris_logrel.F_mu_ref_conc Require Export fundamental_unary.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import adequacy.
From iris.base_logic Require Import auth.

Theorem soundness Σ `{irisPreG lang Σ, authG Σ heapUR} e τ e' thp σ σ' :
  (∀ `{heapIG Σ}, log_typed [] e τ) →
  rtc step ([e], σ) (thp, σ') → e' ∈ thp →
  is_Some (to_val e') ∨ reducible e' σ'.
Proof.
  intros Hlog ??. cut (adequate e σ (λ _, True)); first (intros [_ ?]; eauto).
  eapply (wp_adequacy Σ); iIntros (?) "Hσ". rewrite -(empty_env_subst e).
  iMod (auth_alloc to_heap ownP heapN _ σ with "[Hσ]") as (γ) "[??]"; auto.
  - auto using to_heap_valid.
  - iApply wp_wand_l; iSplitR; [|iApply (Hlog (HeapIG _ _ _ γ))]; eauto.
    iSplit. by rewrite /heapI_ctx. iApply (@interp_env_nil _ (HeapIG _ _ _ γ)).
Qed.

Corollary type_soundness e τ e' thp σ σ' :
  [] ⊢ₜ e : τ →
  rtc step ([e], σ) (thp, σ') → e' ∈ thp →
  is_Some (to_val e') ∨ reducible e' σ'.
Proof.
  intros ??. set (Σ := #[irisΣ state ; authΣ heapUR ]).
  eapply (soundness Σ); eauto using fundamental.
Qed.


(* Using the construction to derive state *)

From Coq Require Import Utf8 RelationClasses FunctionalExtensionality.
From PDM Require Import util structures guarded PURE PDM DM4Free.

Set Default Goal Selector "!".
Set Printing Projections.
Set Universe Polymorphism.
Unset Universe Minimization ToSet.

Section State.

  Context (state : Type).

  Definition StT (M : Type → Type) (A : Type) :=
    state → M (state * A)%type.

  Instance MonadTransformer_StT : MonadTransformer StT := {|
    liftᵀ M hM A c := λ s₀, bind c (λ x, ret (s₀, x)) ;
    mapᵀ M N f hM hN hf A c := λ s₀, f _ (c s₀)
  |}.

  Instance MonadTransformerLaws_StT : MonadTransformerLaws StT.
  Proof.
    unshelve econstructor.
    - intros M hM.
      refine {|
        ret A x := λ s₀, ret (s₀, x) ;
        bind A B c f := λ s₀, bind (c s₀) (λ '(s₁, x), f x s₁)
      |}.
    - intros M hM lM A x.
      simpl. extensionality s₀.
      rewrite structures.left_id. reflexivity.
    - intros M hM lM A B c f.
      simpl. extensionality s₀.
      rewrite !structures.assoc. f_equal.
      extensionality x. rewrite structures.left_id. reflexivity.
    - intros M N f hM hN hf.
      constructor.
      + intros A x. simpl.
        extensionality s₀.
        apply morph_ret.
      + intros A B c k.
        simpl. extensionality s₀.
        rewrite morph_bind. apply (f_equal (bind _)).
        apply functional_extensionality. intros [s₁ x].
        reflexivity.
    - intros M N f hM hN hf A c.
      simpl. extensionality s₀.
      rewrite morph_bind. apply (f_equal (bind _)).
      extensionality x. apply morph_ret.
  Defined.

  #[refine] Instance Order_W : Order (W StT) := {|
    wle A (w w' : W StT A) := ∀ post s, val (w' s) post → val (w s) post
  |}.
  Proof.
    intros A x y z h1 h2.
    intros post s h.
    apply h1. apply h2. assumption.
  Defined.

  Instance MonoSpec_W : MonoSpec (W StT).
  Proof.
    constructor.
    intros A B w w' wf wf' hw hwf.
    intros post s h.
    simpl. apply hw.
    simpl in h.
    destruct w' as [w'' hm].
    eapply hm. 2: exact h.
    intros [s₁ x]. apply hwf.
  Qed.

  Lemma wle_liftᵀ :
    ∀ A (w w' : pure_wp A), w ≤ᵂ w' → liftᵀ w ≤ᵂ liftᵀ w'.
  Proof.
    intros A w w' hw.
    simpl. intros post s h.
    apply hw. assumption.
  Qed.

  Instance Reflexive_wle : ∀ A, Reflexive (wle (W := W StT) (A := A)).
  Proof.
    intros A x. intros post s. auto.
  Qed.

  Definition D A w : Type :=
    DM4Free.D StT Order_W A w.

  Instance DijkstraMonad_D : DijkstraMonad (Word := Order_W) D := _.

  Definition liftᴾ [A w] (f : PURE A w) : D A (liftᵂ StT _ w) :=
    DM4Free.liftᴾ StT _ _ wle_liftᵀ _ w f.

End State.


From iris.base_logic.lib Require Export invariants.
From iris.algebra Require Export auth.
From iris.algebra Require Import gmap.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".
Import uPred.

(* The CMRA we need. *)
Class authG Σ (A : ucmraT) := AuthG {
  auth_inG :> inG Σ (authR A);
  auth_cmra_discrete :> CmraDiscrete A;
}.
Definition authΣ (A : ucmraT) : gFunctors := #[ GFunctor (authR A) ].

Instance subG_authΣ Σ A : subG (authΣ A) Σ → CmraDiscrete A → authG Σ A.
Proof. solve_inG. Qed.

Section definitions.
  Context `{invG Σ, authG Σ A} {T : Type} (γ : gname).

  Definition auth_own (a : A) : iProp Σ :=
    own γ (◯ a).
  Definition auth_inv (f : T → A) (φ : T → iProp Σ) : iProp Σ :=
    (∃ t, own γ (● f t) ∗ φ t)%I.
  Definition auth_ctx (N : namespace) (f : T → A) (φ : T → iProp Σ) : iProp Σ :=
    inv N (auth_inv f φ).

  Global Instance auth_own_ne : NonExpansive auth_own.
  Proof. solve_proper. Qed.
  Global Instance auth_own_proper : Proper ((≡) ==> (⊣⊢)) auth_own.
  Proof. solve_proper. Qed.
  Global Instance auth_own_timeless a : Timeless (auth_own a).
  Proof. apply _. Qed.
  Global Instance auth_own_core_id a : CoreId a → Persistent (auth_own a).
  Proof. apply _. Qed.

  Global Instance auth_inv_ne n :
    Proper (pointwise_relation T (dist n) ==>
            pointwise_relation T (dist n) ==> dist n) auth_inv.
  Proof. solve_proper. Qed.
  Global Instance auth_inv_proper :
    Proper (pointwise_relation T (≡) ==>
            pointwise_relation T (⊣⊢) ==> (⊣⊢)) auth_inv.
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_ne N n :
    Proper (pointwise_relation T (dist n) ==>
            pointwise_relation T (dist n) ==> dist n) (auth_ctx N).
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_proper N :
    Proper (pointwise_relation T (≡) ==>
            pointwise_relation T (⊣⊢) ==> (⊣⊢)) (auth_ctx N).
  Proof. solve_proper. Qed.
  Global Instance auth_ctx_persistent N f φ : Persistent (auth_ctx N f φ).
  Proof. apply _. Qed.
End definitions.

Typeclasses Opaque auth_own auth_inv auth_ctx.
Instance: Params (@auth_own) 4.
Instance: Params (@auth_inv) 5.
Instance: Params (@auth_ctx) 7.

Section auth.
  Context `{invG Σ, authG Σ A}.
  Context {T : Type} `{!Inhabited T}.
  Context (f : T → A) (φ : T → iProp Σ).
  Implicit Types N : namespace.
  Implicit Types P Q R : iProp Σ.
  Implicit Types a b : A.
  Implicit Types t u : T.
  Implicit Types γ : gname.

  Lemma auth_own_op γ a b : auth_own γ (a ⋅ b) ⊣⊢ auth_own γ a ∗ auth_own γ b.
  Proof. by rewrite /auth_own -own_op auth_frag_op. Qed.

(*
  Global Instance from_and_auth_own γ a b1 b2 :
    IsOp a b1 b2 →
    FromAnd false (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 90.
  Proof. rewrite /IsOp /FromAnd=> ->. by rewrite auth_own_op. Qed.
  Global Instance from_and_auth_own_persistent γ a b1 b2 :
    IsOp a b1 b2 → Or (CoreId b1) (CoreId b2) →
    FromAnd true (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 91.
  Proof.
    intros ? Hper; apply mk_from_and_persistent; [destruct Hper; apply _|].
    by rewrite -auth_own_op -is_op.
  Qed.

  Global Instance into_and_auth_own p γ a b1 b2 :
    IsOp a b1 b2 →
    IntoAnd p (auth_own γ a) (auth_own γ b1) (auth_own γ b2) | 90.
  Proof. intros. apply mk_into_and_sep. by rewrite (is_op a) auth_own_op. Qed.
*)

  Lemma auth_own_mono γ a b : a ≼ b → auth_own γ b ⊢ auth_own γ a.
  Proof. intros [? ->]. by rewrite auth_own_op sep_elim_l. Qed.
  Lemma auth_own_valid γ a : auth_own γ a ⊢ ✓ a.
  Proof. by rewrite /auth_own own_valid auth_validI. Qed.
  Global Instance auth_own_sep_homomorphism γ :
    WeakMonoidHomomorphism op uPred_sep (≡) (auth_own γ).
  Proof. split; try apply _. apply auth_own_op. Qed.

  Global Instance own_mono' γ : Proper (flip (≼) ==> (⊢)) (auth_own γ).
  Proof. intros a1 a2. apply auth_own_mono. Qed.

  Lemma auth_alloc_strong N E t (G : gset gname) :
    ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, ⌜γ ∉ G⌝ ∧ auth_ctx γ N f φ ∧ auth_own γ (f t).
  Proof.
    iIntros (?) "Hφ". rewrite /auth_own /auth_ctx.
    iMod (own_alloc_strong (Auth (Excl' (f t)) (f t)) G) as (γ) "[% Hγ]"; first done.
    iRevert "Hγ"; rewrite auth_both_op; iIntros "[Hγ Hγ']".
    iMod (inv_alloc N _ (auth_inv γ f φ) with "[-Hγ']") as "#?".
    { iNext. rewrite /auth_inv. iExists t. by iFrame. }
    eauto.
  Qed.

  Lemma auth_alloc N E t :
    ✓ (f t) → ▷ φ t ={E}=∗ ∃ γ, auth_ctx γ N f φ ∧ auth_own γ (f t).
  Proof.
    iIntros (?) "Hφ".
    iMod (auth_alloc_strong N E t ∅ with "Hφ") as (γ) "[_ ?]"; eauto.
  Qed.

  Lemma auth_empty γ : (|==> auth_own γ ε)%I.
  Proof. by rewrite /auth_own -own_unit. Qed.

  Lemma auth_acc E γ a :
    ▷ auth_inv γ f φ ∗ auth_own γ a ={E}=∗ ∃ t,
      ⌜a ≼ f t⌝ ∗ ▷ φ t ∗ ∀ u b,
      ⌜(f t, a) ~l~> (f u, b)⌝ ∗ ▷ φ u ={E}=∗ ▷ auth_inv γ f φ ∗ auth_own γ b.
  Proof using Type*.
    iIntros "[Hinv Hγf]". rewrite /auth_inv /auth_own.
    iDestruct "Hinv" as (t) "[>Hγa Hφ]".
    iModIntro. iExists t.
    iDestruct (own_valid_2 with "Hγa Hγf") as % [? ?]%auth_valid_discrete_2.
    iSplit; first done. iFrame. iIntros (u b) "[% Hφ]".
    iMod (own_update_2 with "Hγa Hγf") as "[Hγa Hγf]".
    { eapply auth_update; eassumption. }
    iModIntro. iFrame. iExists u. iFrame.
  Qed.

  Lemma auth_open E N γ a :
    ↑N ⊆ E →
    auth_ctx γ N f φ ∗ auth_own γ a ={E,E∖↑N}=∗ ∃ t,
      ⌜a ≼ f t⌝ ∗ ▷ φ t ∗ ∀ u b,
      ⌜(f t, a) ~l~> (f u, b)⌝ ∗ ▷ φ u ={E∖↑N,E}=∗ auth_own γ b.
  Proof using Type*.
    iIntros (?) "[#? Hγf]". rewrite /auth_ctx. iInv N as "Hinv" "Hclose".
    (* The following is essentially a very trivial composition of the accessors
       [auth_acc] and [inv_open] -- but since we don't have any good support
       for that currently, this gets more tedious than it should, with us having
       to unpack and repack various proofs.
       TODO: Make this mostly automatic, by supporting "opening accessors
       around accessors". *)
    iMod (auth_acc with "[$Hinv $Hγf]") as (t) "(?&?&HclAuth)".
    iModIntro. iExists t. iFrame. iIntros (u b) "H".
    iMod ("HclAuth" $! u b with "H") as "(Hinv & ?)". by iMod ("Hclose" with "Hinv").
  Qed.
End auth.

Arguments auth_open {_ _ _} [_] {_} [_] _ _ _ _ _ _ _.


Require Export Iron.Language.SystemF2Effect.Step.Frame.
Require Export Iron.Language.SystemF2Effect.Store.Bind.

(********************************************************************)
(* All region handles in this effect have corresponding
   FUse frames in the frame stack. *)
Definition LiveEs (fs : stack) (es : list ty)
 := Forall (fun e1 => forall p2,  handleOfEffect e1 = Some p2
                   -> (exists m1, In (FPriv m1 p2) fs))
           es.

Definition LiveE  (fs : stack) (e : ty)
 := LiveEs fs (flattenT e).

(*******************************************************************)
Lemma liveEs_equivTs
 :  forall  ke sp es1 es2 fs
 ,  EquivTs ke sp es1 es2 KEffect
 -> LiveEs  fs es1
 -> LiveEs  fs es2.
Proof.
 intros. inverts H.
 unfold LiveEs in *.
 snorm.
 apply  H4 in H.
 eapply H0 in H; eauto.
Qed.

Lemma liveE_equivT_left
 :  forall ke sp e1 e2 fs
 ,  EquivT ke sp e1 e2 KEffect
 -> LiveE  fs e2
 -> LiveE  fs e1.
Proof.
 intros.
 unfold LiveE in *.
 eapply liveEs_equivTs.
 - eapply equivT_equivTs; auto.
   eapply EqSym.
   + eauto.
   + have (KindT ke sp e2 KEffect).
     eauto.
   + auto.
 - auto.
Qed.

Lemma liveE_equivT_right
 :  forall ke sp e1 e2 fs
 ,  EquivT ke sp e1 e2 KEffect
 -> LiveE  fs e1
 -> LiveE  fs e2.
Proof.
 intros.
 unfold LiveE in *.
 eapply liveEs_equivTs.
 - eapply equivT_equivTs; eauto.
 - auto.
Qed.

(*******************************************************************)
Lemma liveEs_subsTs
 :  forall ke sp es1 es2 fs
 ,  SubsTs ke sp es1 es2 KEffect
 -> LiveEs fs es1
 -> LiveEs fs es2.
Proof.
 intros. inverts H.
 unfold LiveEs in *.
 snorm.
 eapply H0; eauto.
Qed.

Lemma liveE_subsT
 :  forall ke sp e1 e2 fs
 ,  SubsT ke sp e1 e2 KEffect
 -> LiveE fs e1
 -> LiveE fs e2.
Proof.
 intros.
 unfold LiveE in *.
 eapply liveEs_subsTs.
 - eapply subsT_subsTs in H; eauto.
 - auto.
Qed.
Hint Resolve liveE_subsT.

(********************************************************************)
Lemma liveE_sum_above
 :  forall e1 e2 fs
 ,  LiveE  fs e1 -> LiveE fs e2
 -> LiveE  fs (TSum e1 e2).
Proof.
 intros.
 unfold LiveE. simpl.
 unfold LiveEs.
 eapply Forall_app; eauto.
Qed.
Hint Resolve liveE_sum_above.

Lemma liveE_sum_above_left
 :  forall fs e1 e2
 ,  LiveE fs (TSum e1 e2)
 -> LiveE fs e1.
Proof.
 intros.
 unfold LiveE  in *.
 unfold LiveEs in *.
 snorm. eauto.
Qed.
Hint Resolve liveE_sum_above_left.

Lemma liveE_sum_above_right
 :  forall fs e1 e2
 ,  LiveE fs (TSum e1 e2)
 -> LiveE fs e2.
Proof.
 intros.
 unfold LiveE  in *.
 unfold LiveEs in *.
 snorm. eauto.
Qed.

(********************************************************************)
Lemma liveE_frame_cons
 :  forall fs f e
 ,  LiveE  fs        e
 -> LiveE  (fs :> f) e.
Proof.
 intros.
 unfold LiveE in *.
 unfold LiveEs in *.
 snorm. firstorder.
Qed.
Hint Resolve liveE_frame_cons.

Lemma liveE_pop_flet
 :  forall fs t x e
 ,  LiveE  (fs :> FLet t x) e
 -> LiveE  fs e.
Proof.
 intros.
 unfold LiveE in *.
 unfold LiveEs in *.
 snorm.
 spec H x0. rip.
 spec H p2. rip.
 firstorder. nope.
Qed.

Lemma liveE_maskOnVarT
 :  forall fs e n
 ,  LiveE  fs (maskOnVarT n e)
 -> LiveE  fs e.
Proof.
 intros.
 unfold LiveE in *.
 unfold LiveEs in *.
 snorm.
 spec H x.
 apply handleOfEffect_form_some in H1.
 destruct H1 as [tc]. rip.
 eapply maskOnVar_effect_remains in H0.
 - eapply H in H0; eauto.
   snorm. nope.
 - eauto.
Qed.

Lemma liveE_phase_change
 :  forall fs m1 p e
 ,  LiveE (fs :> FPriv m1 p) e
 -> LiveE (fs :> FPriv m1 p) (substTT 0 (TRgn p) e).
Proof.
 intros.
 induction e; snorm;
  try (solve [unfold LiveE in *;
              unfold LiveEs in *;
              snorm; inverts H0; nope]).

 - Case "TSum".
   eapply liveE_sum_above.
   + eapply liveE_sum_above_left  in H; eauto.
   + eapply liveE_sum_above_right in H; eauto.

 - Case "TCon1".
   destruct e;
    unfold LiveE; unfold LiveEs; snorm;
    try (solve [inverts H0; snorm; nope]).
   exists m1.
   inverts H0.
   + snorm.
   + nope.
Qed.

Lemma liveE_fpriv_in
 :  forall e p2 fs
 ,  LiveE fs e
 -> handleOfEffect e = Some p2
 -> (exists m1, In (FPriv m1 p2) fs).
Proof.
 intros.
 unfold LiveE  in *.
 unfold LiveEs in *.
 snorm.
 eapply handleOfEffect_form_some in H0.
 destruct H0 as [tc]. rip.
 snorm.
 lets D: H (TCon1 tc (TRgn p2)). clear H.
 eapply D. snorm. snorm. nope.
Qed.

Global Opaque LiveE.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export rules_useful.
Require Export per_props_equality.
Require Export per_props_union.
Require Export subst_tacs.

(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)

Definition rule_equality_to_extract {o}
           (T t : @NTerm o)
           (H : barehypotheses) :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_member t T)))
      [ mk_baresequent H (mk_concl T t) ]
      [].

Lemma rule_equality_to_extract_true {p} :
  forall lib
         (T t : NTerm)
         (H : @barehypotheses p),
    rule_true lib (rule_equality_to_extract T t H).
Proof.
  unfold rule_equality_to_extract, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  rename Hyp into hyp1.
  destruct hyp1 as [wc1 hyp1].
  destseq; allsimpl; proof_irr; GC.
  unfold closed_extract; simpl.

  exists (@covered_axiom p (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as h; exrepnd; clear hyp1.

  lsubst_tac.

  allrw @tequality_mkc_member_sp.
  allrw @equality_in_member.

  dands; auto; spcast;
  try (apply computes_to_valc_refl; eauto 3 with slow).
  apply equality_refl in h1; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Require Import Filter.
Require Extraction.

Module BDdL := VariableAlphabet <+ Types.

Extract Inductive prod => "(,)" [ "(,)" ].
Extract Constant fst => "Prelude.fst".
Extract Constant snd => "Prelude.snd".
Extract Inductive sumbool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].
Extract Inductive sig => "" [ "" ].
Extract Constant BDdL.t => "Prelude.Int".
Extract Constant BDdL.eq_dec => "(Prelude.==)".
Extraction Inline BDdL.eq_dec.

Extraction Language Haskell.
Extraction "BDdL.hs" BDdL.SubtypeRelation.


Require Import Prog.
Require Import Pred.
Require Import Hoare.
Require Import Word.
Require Import SepAuto.
Require Import BasicProg.
Require Import Log.
Require Import Bool.
Require Import GenSep.
Require Import Idempotent.
Require Import FSLayout.
Require Import Cache.
Require Import FS.

Set Implicit Arguments.

Definition inc_two T s0 s1 rx : prog T :=
  v0 <- Read s0 ;
  Write s0 (v0 ^+ $1) ;;
  v1 <- Read s1 ;
  Write s1 (v1 ^+ $1) ;;
  rx tt.

Theorem inc_two_ok: forall s0 s1,
  {< v0 v1,
  PRE    s0 |~> v0 * s1 |~> v1
  POST RET:r
         s0 |~> (v0 ^+ $1) * s1 |~> (v1 ^+ $1)
  CRASH  s0 |~> v0 * s1 |~> v1 \/
         s0 |~> (v0 ^+ $1) * s1 |~> v1 \/
         s0 |~> (v0 ^+ $1) * s1 |~> (v1 ^+ $1)
  >} inc_two s0 s1.
Proof.
  unfold inc_two.
  hoare.
Qed.

Definition log_inc_two_body T xp s0 s1 mscs rx : prog T :=
  let^ (mscs, v0) <- LOG.read xp s0 mscs;
  mscs <- LOG.write xp s0 (v0 ^+ $1) mscs;
  let^ (mscs, v1) <- LOG.read xp s1 mscs;
  mscs <- LOG.write xp s1 (v1 ^+ $1) mscs;
  rx mscs.

Theorem log_inc_two_body_ok: forall xp s0 s1 mscs,
  {< mbase m v0 v1 F Fm,
  PRE             LOG.rep xp Fm (ActiveTxn mbase m) mscs *
                  [[ (s0 |-> v0 * s1 |-> v1 * F)%pred (list2mem m)]]
  POST RET:mscs   exists m', LOG.rep xp Fm (ActiveTxn mbase m') mscs *
                  [[ (s0 |-> (v0 ^+ $1) * s1 |-> (v1 ^+ $1) * F)%pred (list2mem m') ]]
  CRASH           LOG.would_recover_old xp Fm mbase
  >} log_inc_two_body xp s0 s1 mscs.
Proof.
  unfold log_inc_two_body.
  hoare; apply LOG.activetxn_would_recover_old.
Qed.

Hint Extern 1 ({{_}} progseq (log_inc_two_body _ _ _ _) _) => apply log_inc_two_body_ok : prog.

Definition log_inc_two T xp s0 s1 cs rx : prog T :=
  mscs <- LOG.begin xp cs;
  mscs <- log_inc_two_body xp s0 s1 mscs;
  let^ (mscs, ok) <- LOG.commit xp mscs;
  If (bool_dec ok true) {
    rx ^(mscs, ok)
  } else {
    rx ^(mscs, false)
  }.

Theorem log_inc_two_ok: forall xp s0 s1 mscs,
  {< mbase v0 v1 F Fm,
  PRE             LOG.rep xp Fm (NoTransaction mbase) mscs *
                  [[ (s0 |-> v0 * s1 |-> v1 * F)%pred (list2mem mbase)]]
  POST RET:^(mscs, r)
                  [[ r = false ]] * LOG.rep xp Fm (NoTransaction mbase) mscs \/
                  [[ r = true ]] * exists m', LOG.rep xp Fm (NoTransaction m') mscs *
                  [[ (s0 |-> (v0 ^+ $1) * s1 |-> (v1 ^+ $1) * F)%pred (list2mem m') ]]
  CRASH           LOG.would_recover_old xp Fm mbase \/
                  exists m', LOG.would_recover_either xp Fm mbase m' *
                  [[ (s0 |-> (v0 ^+ $1) * s1 |-> (v1 ^+ $1) * F)%pred (list2mem m') ]]
  >} log_inc_two xp s0 s1 mscs.
Proof.
  unfold log_inc_two.
  hoare.
  rewrite LOG.notxn_would_recover_old.
  cancel.
  rewrite LOG.activetxn_would_recover_old.
  cancel.
Qed.

Hint Extern 1 ({{_}} progseq (log_inc_two _ _ _ _) _) => apply log_inc_two_ok : prog.

Hint Rewrite crash_xform_sep_star_dist crash_xform_or_dist crash_xform_exists_comm : crash_xform.

Definition i2 xp s0 s1 T := @log_inc_two T xp s0 s1.

Theorem log_inc_two_recover_ok: forall xp s0 s1 mscs,
  {<< v0 v1 F Fm mbase,
  PRE
    LOG.rep xp Fm (NoTransaction mbase) mscs *
    [[ (s0 |-> v0 * s1 |-> v1 * F)%pred (list2mem mbase)]]
  POST RET:^(mscs, r)
    [[ r = false ]] * LOG.rep xp Fm (NoTransaction mbase) mscs \/
    [[ r = true ]] * exists m', LOG.rep xp Fm (NoTransaction m') mscs *
    [[ (s0 |-> (v0 ^+ $1) * s1 |-> (v1 ^+ $1) * F)%pred (list2mem m') ]]
  REC RET:^(mscs, xp)
    LOG.rep xp Fm (NoTransaction mbase) mscs \/
    exists m', LOG.rep xp Fm (NoTransaction m') mscs *
               [[ (s0 |-> (v0 ^+ $1) * s1 |-> (v1 ^+ $1) * F)%pred (list2mem m') ]]
  >>} log_inc_two xp s0 s1 mscs >> LOG.recover.
Proof.
  intros.
  unfold forall_helper at 1 2; intros v0 v1 F.

  eapply pimpl_ok3.
  eapply corr3_from_corr2_rx; eauto with prog.

  eapply (LOG.recover_corr2_to_corr3 (i2 xp s0 s1)).
  unfold i2.
  intros.
  eapply pimpl_ok2.
  eapply log_inc_two_ok.
  cancel.
Qed.


From Classes Require Import Classes.

Module DefaultTests.
  Definition test1 : nat := default.
  Definition test2 : nat * nat := default.

  Inductive unit' := tt'.
  Definition test3 : unit' := default.

  Record many_things :=
    { a: nat;
      b: unit;
      c: nat * list nat; }.

  Definition test4 : many_things := default.
End DefaultTests.

Module TestUnitEq.
  Import EqualDecNotation.

  (* unit EqualDec instance should always reduce to [left pf] *)
  Definition test1 (x y:unit) :
    (if x == y then true else false) = true := eq_refl.
End TestUnitEq.


Lemma LP4P13 : forall P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13 P14 P15 ,
rk(P3 :: P8 :: P10 ::  nil) = 2 -> rk(P6 :: P11 :: P12 ::  nil) = 2 -> rk(P1 :: P2 :: P3 :: P13 ::  nil) = 2 ->
rk(P4 :: P5 :: P6 :: P13 ::  nil) = 2 -> rk(P3 :: P4 :: P5 :: P6 :: P8 :: P10 :: P13 ::  nil) = 4 -> rk(P1 :: P2 :: P3 :: P6 :: P11 :: P12 :: P13 ::  nil) = 4 ->
rk(P4 :: P7 :: P8 :: P14 ::  nil) = 2 -> rk(P1 :: P9 :: P11 :: P14 ::  nil) = 2 -> rk(P1 :: P3 :: P8 :: P9 :: P10 :: P11 :: P14 ::  nil) = 4 ->
rk(P4 :: P6 :: P7 :: P8 :: P11 :: P12 :: P14 ::  nil) = 4 -> rk(P1 :: P2 :: P3 :: P4 :: P7 :: P8 :: P13 :: P14 ::  nil) = 4 -> rk(P1 :: P4 :: P5 :: P6 :: P9 :: P11 :: P13 :: P14 ::  nil) = 4 ->
rk(P5 :: P9 :: P10 :: P15 ::  nil) = 2 -> rk(P2 :: P7 :: P12 :: P15 ::  nil) = 2 -> rk(P2 :: P3 :: P7 :: P8 :: P10 :: P12 :: P15 ::  nil) = 4 ->
rk(P5 :: P6 :: P9 :: P10 :: P11 :: P12 :: P15 ::  nil) = 4 -> rk(P1 :: P2 :: P3 :: P5 :: P9 :: P10 :: P13 :: P15 ::  nil) = 4 -> rk(P2 :: P4 :: P5 :: P6 :: P7 :: P12 :: P13 :: P15 ::  nil) = 4 ->
rk(P4 :: P5 :: P7 :: P8 :: P9 :: P10 :: P14 :: P15 ::  nil) = 4 -> rk(P1 :: P2 :: P7 :: P9 :: P11 :: P12 :: P14 :: P15 ::  nil) = 4 -> rk(P4 :: P13 ::  nil) = 2.
Proof.

intros P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13 P14 P15
HP3P8P10eq HP6P11P12eq HP1P2P3P13eq HP4P5P6P13eq HP3P4P5P6P8P10P13eq HP1P2P3P6P11P12P13eq HP4P7P8P14eq HP1P9P11P14eq HP1P3P8P9P10P11P14eq HP4P6P7P8P11P12P14eq
HP1P2P3P4P7P8P13P14eq HP1P4P5P6P9P11P13P14eq HP5P9P10P15eq HP2P7P12P15eq HP2P3P7P8P10P12P15eq HP5P6P9P10P11P12P15eq HP1P2P3P5P9P10P13P15eq HP2P4P5P6P7P12P13P15eq HP4P5P7P8P9P10P14P15eq HP1P2P7P9P11P12P14P15eq
.

assert(HP4P7P8P13P14M3 : rk(P4 :: P7 :: P8 :: P13 :: P14 :: nil) <= 3).
{
	try assert(HP13eq : rk(P13 :: nil) = 1) by (apply LP13 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) (P7 := P7) (P8 := P8) (P9 := P9) (P10 := P10) (P11 := P11) (P12 := P12) (P13 := P13) (P14 := P14) (P15 := P15) ;try assumption).
	assert(HP13Mtmp : rk(P13 :: nil) <= 1) by (solve_hyps_max HP13eq HP13M1).
	try assert(HP4P7P8P14eq : rk(P4 :: P7 :: P8 :: P14 :: nil) = 2) by (apply LP4P7P8P14 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) (P7 := P7) (P8 := P8) (P9 := P9) (P10 := P10) (P11 := P11) (P12 := P12) (P13 := P13) (P14 := P14) (P15 := P15) ;try assumption).
	assert(HP4P7P8P14Mtmp : rk(P4 :: P7 :: P8 :: P14 :: nil) <= 2) by (solve_hyps_max HP4P7P8P14eq HP4P7P8P14M2).
	assert(Hmtmp : rk(nil) >= 0) by (solve_hyps_min Hnuleq Hm).
	assert(Hincl : incl (nil) (list_inter (P13 :: nil) (P4 :: P7 :: P8 :: P14 :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (P4 :: P7 :: P8 :: P13 :: P14 :: nil) (P13 :: P4 :: P7 :: P8 :: P14 :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (P13 :: P4 :: P7 :: P8 :: P14 :: nil) ((P13 :: nil) ++ (P4 :: P7 :: P8 :: P14 :: nil))) by (clear_all_rk;my_inO).
	assert(HT := rule_1 (P13 :: nil) (P4 :: P7 :: P8 :: P14 :: nil) (nil) 1 2 0 HP13Mtmp HP4P7P8P14Mtmp Hmtmp Hincl);
	rewrite <-HT2 in HT;try rewrite <-HT1 in HT;apply HT.
}

assert(HP4P7P8P13P14m3 : rk(P4 :: P7 :: P8 :: P13 :: P14 :: nil) >= 3).
{
	try assert(HP1P2P3P13eq : rk(P1 :: P2 :: P3 :: P13 :: nil) = 2) by (apply LP1P2P3P13 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) (P7 := P7) (P8 := P8) (P9 := P9) (P10 := P10) (P11 := P11) (P12 := P12) (P13 := P13) (P14 := P14) (P15 := P15) ;try assumption).
	assert(HP1P2P3P13Mtmp : rk(P1 :: P2 :: P3 :: P13 :: nil) <= 2) by (solve_hyps_max HP1P2P3P13eq HP1P2P3P13M2).
	try assert(HP1P2P3P4P7P8P13P14eq : rk(P1 :: P2 :: P3 :: P4 :: P7 :: P8 :: P13 :: P14 :: nil) = 4) by (apply LP1P2P3P4P7P8P13P14 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) (P7 := P7) (P8 := P8) (P9 := P9) (P10 := P10) (P11 := P11) (P12 := P12) (P13 := P13) (P14 := P14) (P15 := P15) ;try assumption).
	assert(HP1P2P3P4P7P8P13P14mtmp : rk(P1 :: P2 :: P3 :: P4 :: P7 :: P8 :: P13 :: P14 :: nil) >= 4) by (solve_hyps_min HP1P2P3P4P7P8P13P14eq HP1P2P3P4P7P8P13P14m4).
	try assert(HP13eq : rk(P13 :: nil) = 1) by (apply LP13 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) (P7 := P7) (P8 := P8) (P9 := P9) (P10 := P10) (P11 := P11) (P12 := P12) (P13 := P13) (P14 := P14) (P15 := P15) ;try assumption).
	assert(HP13mtmp : rk(P13 :: nil) >= 1) by (solve_hyps_min HP13eq HP13m1).
	assert(Hincl : incl (P13 :: nil) (list_inter (P1 :: P2 :: P3 :: P13 :: nil) (P4 :: P7 :: P8 :: P13 :: P14 :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (P1 :: P2 :: P3 :: P4 :: P7 :: P8 :: P13 :: P14 :: nil) (P1 :: P2 :: P3 :: P13 :: P4 :: P7 :: P8 :: P13 :: P14 :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (P1 :: P2 :: P3 :: P13 :: P4 :: P7 :: P8 :: P13 :: P14 :: nil) ((P1 :: P2 :: P3 :: P13 :: nil) ++ (P4 :: P7 :: P8 :: P13 :: P14 :: nil))) by (clear_all_rk;my_inO).
	try rewrite HT1 in HP1P2P3P4P7P8P13P14mtmp;try rewrite HT2 in HP1P2P3P4P7P8P13P14mtmp.
	assert(HT := rule_4 (P1 :: P2 :: P3 :: P13 :: nil) (P4 :: P7 :: P8 :: P13 :: P14 :: nil) (P13 :: nil) 4 1 2 HP1P2P3P4P7P8P13P14mtmp HP13mtmp HP1P2P3P13Mtmp Hincl); apply HT.
}
try clear HP1P2P3P13M1. try clear HP1P2P3P13M2. try clear HP1P2P3P13M3. try clear HP1P2P3P13m4. try clear HP1P2P3P13m3. try clear HP1P2P3P13m2. try clear HP1P2P3P13m1. try clear HP13M1. try clear HP13M2. try clear HP13M3. try clear HP13m4. try clear HP13m3. try clear HP13m2. try clear HP13m1. try clear HP1P2P3P4P7P8P13P14M1. try clear HP1P2P3P4P7P8P13P14M2. try clear HP1P2P3P4P7P8P13P14M3. try clear HP1P2P3P4P7P8P13P14m4. try clear HP1P2P3P4P7P8P13P14m3. try clear HP1P2P3P4P7P8P13P14m2. try clear HP1P2P3P4P7P8P13P14m1.

assert(HP4P13m2 : rk(P4 :: P13 :: nil) >= 2).
{
	try assert(HP4P7P8P14eq : rk(P4 :: P7 :: P8 :: P14 :: nil) = 2) by (apply LP4P7P8P14 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) (P7 := P7) (P8 := P8) (P9 := P9) (P10 := P10) (P11 := P11) (P12 := P12) (P13 := P13) (P14 := P14) (P15 := P15) ;try assumption).
	assert(HP4P7P8P14Mtmp : rk(P4 :: P7 :: P8 :: P14 :: nil) <= 2) by (solve_hyps_max HP4P7P8P14eq HP4P7P8P14M2).
	try assert(HP4P7P8P13P14eq : rk(P4 :: P7 :: P8 :: P13 :: P14 :: nil) = 3) by (apply LP4P7P8P13P14 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) (P7 := P7) (P8 := P8) (P9 := P9) (P10 := P10) (P11 := P11) (P12 := P12) (P13 := P13) (P14 := P14) (P15 := P15) ;try assumption).
	assert(HP4P7P8P13P14mtmp : rk(P4 :: P7 :: P8 :: P13 :: P14 :: nil) >= 3) by (solve_hyps_min HP4P7P8P13P14eq HP4P7P8P13P14m3).
	try assert(HP4eq : rk(P4 :: nil) = 1) by (apply LP4 with (P1 := P1) (P2 := P2) (P3 := P3) (P4 := P4) (P5 := P5) (P6 := P6) (P7 := P7) (P8 := P8) (P9 := P9) (P10 := P10) (P11 := P11) (P12 := P12) (P13 := P13) (P14 := P14) (P15 := P15) ;try assumption).
	assert(HP4mtmp : rk(P4 :: nil) >= 1) by (solve_hyps_min HP4eq HP4m1).
	assert(Hincl : incl (P4 :: nil) (list_inter (P4 :: P13 :: nil) (P4 :: P7 :: P8 :: P14 :: nil))) by (repeat clear_all_rk;my_inO).
	assert(HT1 : equivlist (P4 :: P7 :: P8 :: P13 :: P14 :: nil) (P4 :: P13 :: P4 :: P7 :: P8 :: P14 :: nil)) by (clear_all_rk;my_inO).
	assert(HT2 : equivlist (P4 :: P13 :: P4 :: P7 :: P8 :: P14 :: nil) ((P4 :: P13 :: nil) ++ (P4 :: P7 :: P8 :: P14 :: nil))) by (clear_all_rk;my_inO).
	try rewrite HT1 in HP4P7P8P13P14mtmp;try rewrite HT2 in HP4P7P8P13P14mtmp.
	assert(HT := rule_2 (P4 :: P13 :: nil) (P4 :: P7 :: P8 :: P14 :: nil) (P4 :: nil) 3 1 2 HP4P7P8P13P14mtmp HP4mtmp HP4P7P8P14Mtmp Hincl);apply HT.
}
try clear HP4P7P8P14M1. try clear HP4P7P8P14M2. try clear HP4P7P8P14M3. try clear HP4P7P8P14m4. try clear HP4P7P8P14m3. try clear HP4P7P8P14m2. try clear HP4P7P8P14m1. try clear HP4M1. try clear HP4M2. try clear HP4M3. try clear HP4m4. try clear HP4m3. try clear HP4m2. try clear HP4m1. try clear HP4P7P8P13P14M1. try clear HP4P7P8P13P14M2. try clear HP4P7P8P13P14M3. try clear HP4P7P8P13P14m4. try clear HP4P7P8P13P14m3. try clear HP4P7P8P13P14m2. try clear HP4P7P8P13P14m1.

assert(HP4P13M : rk(P4 :: P13 ::  nil) <= 2) by (solve_hyps_max HP4P13eq HP4P13M2).
assert(HP4P13m : rk(P4 :: P13 ::  nil) >= 1) by (solve_hyps_min HP4P13eq HP4P13m1).
intuition.
Qed.