Require Import Raft.

Require Import RaftMsgRefinementInterface.

Section GhostLogCorrectInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition ghost_log_correct net :=
    forall p l t leaderId prevLogIndex prevLogTerm entries leaderCommit,
      In p (nwPackets net) ->
      snd (pBody p) = AppendEntries t leaderId prevLogIndex prevLogTerm
                                    entries leaderCommit ->
      fst (pBody p) = l ->
      (prevLogIndex = 0 /\ prevLogTerm = 0 /\ entries = l) \/
      (exists e,
         eIndex e = prevLogIndex /\
         eTerm e = prevLogTerm /\
         In e l) /\
      entries = findGtIndex l prevLogIndex.

  Class ghost_log_correct_interface : Prop :=
    {
      ghost_log_correct_invariant :
        forall net,
          msg_refined_raft_intermediate_reachable net ->
          ghost_log_correct net
    }.

End GhostLogCorrectInterface.


(* searched for state_sm_on_event (PBFTreplicaSM good...) *)

  Definition event_triggered_by_message (e : Event) (m : msg) : Prop :=
    trigger e = Some m.

  Lemma commit_received_from_good_replica_was_in_log :
    forall (eo : EventOrdering) (e : Event) good c i,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> loc e = PBFTreplica i
      -> node_has_correct_trace_before e good
      -> commit2sender c = good
      -> verify_commit i (keys e) c = true
      -> event_triggered_by_message e (PBFTcommit c)
      ->
      exists e' st,
        e' ≺ e
        /\ loc e' = PBFTreplica good
        /\ state_sm_on_event (PBFTreplicaSM good) e' = Some st
        /\ commit_in_log c (log st) = true.

    (* used in PBFT_A_1_7 *)
    (* Invariant 1.7 pg 149 *)
    Lemma PBFT_A_1_7 :
      forall (eo : EventOrdering)
           (e  : Event)
           (i  : Rep)
           (rd : RequestData)
           (st : PBFTstate),
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> exists_at_most_f_faulty [e] F
      -> PBFTcorrect_keys eo
      -> loc e = PBFTreplica i
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> committed_log rd (log st) = true
      ->
      exists (R : list Rep),
        no_repeats R
        /\ F < length R
        /\ forall (k : Rep),
            In k R
            ->
            exists (e' : Event) (st' : PBFTstate),
              isCorrect e'
              /\ e' ≼ e
              /\ loc e' = PBFTreplica k
              /\ state_sm_on_event (PBFTreplicaSM k) e' = Some st'
              /\ prepared_log rd (log st') = true.

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

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

      (* this one is never used*)
    Lemma pbft_knows_prepare_like_propagates1 :
    forall (eo : EventOrdering) (e : Event) good pl i st,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> loc e = PBFTreplica i
      -> node_has_correct_trace_before e good
      -> prepare_like2sender pl = good
      -> prepare_like_in_log pl (log st)
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      ->
      exists e' st,
        e' ≼ e
        /\ loc e' = PBFTreplica good
        /\ state_sm_on_event (PBFTreplicaSM good) e' = Some st'
        /\ prepare_like_in_log pl (log st').

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

      Lemma pbft_knows_prepare_like_propagates :
    forall (eo : EventOrdering) (e : Event) pl,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> node_has_correct_trace_before e (prepare_like2sender pl)
      -> knows e pl
      ->
      exists e',
        e' ≼ e
        /\ loc e' = PBFTreplica (prepare_like2sender pl)
        /\ knows e' pl.
  Proof.
    introv auth ckeys ctrace kn.
    apply knows_propagates in kn; eauto 3 with pbft.
  Qed.

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

  Definition pbft_cp_vc_nv_data := Checkpoint.

  Definition pbft_cp_vc_nv_info := StateInfo.

  Definition pbft_cp_vc_nv_knows (d : pbft_cp_vc_nv_data) (s : PBFTstate) : Prop :=
    exists nv vc,
      new_view_in_log nv (view_change_state s)
      /\ In vc (new_view2cert nv)
      /\ In d (view_change2cert vc).

  Definition checkpoint2main_auth_data (cp : Checkpoint) : AuthenticatedData :=
    match cp with
    | checkpoint cp a => MkAuthData (PBFTmsg_bare_checkpoint cp) a
    end.

  Definition pbft_cp_vc_nv_data2main_auth_data (d : pbft_cp_vc_nv_data) : AuthenticatedData :=
    checkpoint2main_auth_data d.

  Definition pbft_cp_vc_nv_verify (eo : EventOrdering) (e : Event) (d : pbft_cp_vc_nv_data) : bool :=
    verify_one_auth_data (loc e) (keys e) (checkpoint2auth_data d).

  Definition pbft_cp_vc_nv_data2loc (d : pbft_cp_vc_nv_data) : Rep :=
    checkpoint2sender d.

  Lemma pbft_cp_vc_nv_no_initial_memory :
    forall n d, ~ pbft_cp_vc_nv_knows d (Process.sm_state (PBFTreplicaSM n)).
  Proof.
    introv h.
    unfold pbft_cp_vc_nv_knows in h; exrepnd; simpl in *; auto.
  Qed.

  Instance PBFT_I_LearnAndKnow_cp_vc_nv : LearnAndKnow 4.
  Proof.
    exact (MkLearnAndKnow
             4
             pbft_cp_vc_nv_data
             pbft_cp_vc_nv_info
             checkpoint2state_info
             PBFTstate
             pbft_cp_vc_nv_knows
             pbft_cp_vc_nv_data2loc
             pbft_cp_vc_nv_data2main_auth_data
             pbft_cp_vc_nv_verify
             _ _ pbft_cp_vc_nv_no_initial_memory).
  Defined.

      (* this one is used below *)
  Lemma knows4_received_from_good_replica_was_logged :
    forall (eo : EventOrdering) (e : Event) good cp i,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e] F
      -> loc e = PBFTreplica i
      -> node_has_correct_trace_before e good
      -> checkpoint2sender cp = good
      -> knows4 e cp
      ->
      exists e' good' st2,
        e' ≺ e
        /\ loc e' = PBFTreplica good'
        /\ state_sm_on_event (PBFTreplicaSM good') e' = Some st2
        /\ next_to_execute st2 = next_seq (checkpoint2seq cp)
        /\ checkpoint2digest cp = create_hash_state_last_reply (PBFT.sm_state st2) (last_reply_state st2).

    (* but this one is used newer *)
      Lemma view_change_of_new_view_received_from_good_replica_was_logged_xxx :
    forall (eo : EventOrdering) (e : Event) vc nv i st,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e] F
      -> loc e = PBFTreplica i
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> new_view_in_log nv (view_change_state st)
      -> In vc (new_view2cert nv)
      ->
      exists e' good' st2,
        e' ≺ e
        /\ loc e' = PBFTreplica good'
        /\ state_sm_on_event (PBFTreplicaSM good') e' = Some st2
        /\ next_to_execute st2 = next_seq (view_change2seq vc)
        /\ view_change2digest vc = create_hash_state_last_reply (sm_state st2) (last_reply_state st2).
      Proof.

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

   Record StateInfo :=
    MkStateInfo
      {
        si_digest : PBFTdigest;
        si_seq    : SeqNum;
      }.

  Definition view_change2state_info (vc : ViewChange) : StateInfo :=
    MkStateInfo (view_change2digest vc) (view_change2seq vc).

  Definition checkpoint2state_info (cp : Checkpoint) : StateInfo :=
    MkStateInfo (checkpoint2digest cp) (checkpoint2seq cp).

  Definition pbft_vc_nv_data := ViewChange.

  Definition pbft_vc_nv_info := StateInfo.

  Definition pbft_vc_nv_knows (vc : pbft_vc_nv_data) (s : PBFTstate) : Prop :=
    exists nv,
      new_view_in_log nv (view_change_state s)
      /\ In vc (new_view2cert nv).

  Definition view_change2main_auth_data (vc : ViewChange) : AuthenticatedData :=
    match vc with
    | view_change vc a => MkAuthData (PBFTmsg_bare_view_change vc) a
    end.

  Definition pbft_vc_nv_data2main_auth_data (d : pbft_vc_nv_data) : AuthenticatedData :=
    view_change2main_auth_data d.

  Definition pbft_vc_nv_verify (eo : EventOrdering) (e : Event) (d : pbft_vc_nv_data) : bool :=
    verify_list_auth_data (loc e) (keys e) (view_change2auth_data d).

  Definition pbft_vc_nv_data2loc (d : pbft_vc_nv_data) : Rep :=
    view_change2sender d.

  Lemma pbft_vc_nv_no_initial_memory :
    forall n d, ~ pbft_vc_nv_knows d (Process.sm_state (PBFTreplicaSM n)).
  Proof.
    introv h.
    unfold pbft_vc_nv_knows in h; exrepnd; simpl in *; auto.
  Qed.

  Instance PBFT_I_LearnAndKnow_vc_nv : LearnAndKnow 3.
  Proof.
    exact (MkLearnAndKnow
             3
             pbft_vc_nv_data
             pbft_vc_nv_info
             view_change2state_info
             PBFTstate
             pbft_vc_nv_knows
             pbft_vc_nv_data2loc
             pbft_vc_nv_data2main_auth_data
             pbft_vc_nv_verify
             _ _ pbft_vc_nv_no_initial_memory).
  Defined.

      Lemma view_change_of_new_view_received_from_good_replica_was_logged :
    forall (eo : EventOrdering) (e : Event) vc i,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e] F
      -> loc e = PBFTreplica i
      -> knows3 e vc
      ->
      exists e' good' st2,
        e' ≺ e
        /\ loc e' = PBFTreplica good'
        /\ state_sm_on_event (PBFTreplicaSM good') e' = Some st2
        /\ next_to_execute st2 = next_seq (view_change2seq vc)
        /\ view_change2digest vc = create_hash_state_last_reply (sm_state st2) (last_reply_state st2).
  Proof.

    (* this one is used in *)
      Lemma same_states_if_same_next_to_execute :
    forall (eo : EventOrdering) (ei ej : Event) i j sti stj,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [ei,ej] F
      -> loc ei = PBFTreplica i
      -> loc ej = PBFTreplica j
      -> state_sm_on_event (PBFTreplicaSM i) ei = Some sti
      -> state_sm_on_event (PBFTreplicaSM j) ej = Some stj
      -> next_to_execute sti = next_to_execute stj
      -> PBFT.sm_state sti = PBFT.sm_state stj /\ last_reply_state sti = last_reply_state stj.

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

      Lemma prepare_like_received_from_correct_replica_was_in_log :
    forall (eo : EventOrdering) (e : Event) good pl i,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> loc e = PBFTreplica i
      -> node_has_correct_trace_before e good
      -> prepare_like2sender pl = good
      -> verify_main_prepare_like i (keys e) pl = true
      -> auth_data_in_trigger (prepare_like2main_auth_data pl) e
      ->
      exists e' st,
        e' ≺ e
        /\ loc e' = PBFTreplica good
        /\ state_sm_on_event (PBFTreplicaSM good) e' = Some st
        /\ prepare_like_in_log pl (log st).

        (*************************************************************************)
        (* knows0 *)

 Inductive Prepare_like :=
  | prepare_like_pre_prepare (pp : Pre_prepare)
  | prepare_like_prepare (p : Prepare).

  Definition pbft_pl_data := Prepare_like.

  Definition pbft_pl_info := RequestData.

  Definition pbft_pl_knows (d : pbft_pl_data) (s : PBFTstate) : Prop :=
    prepare_like_in_log d (log s).

  Definition pbft_pl_data2main_auth_data (d : pbft_pl_data) : AuthenticatedData :=
    prepare_like2main_auth_data d.

  Definition pbft_pl_data2loc (d : pbft_pl_data) : Rep :=
    prepare_like2sender d.

  Lemma pbft_pl_no_initial_memory :
    forall n d, ~ pbft_pl_knows d (Process.sm_state (PBFTreplicaSM n)).
  Proof.
    introv h; simpl in h; auto.
  Qed.

  Definition pbft_pl_verify (eo : EventOrdering) (e : Event) (d : pbft_pl_data) : bool :=
    verify_authenticated_data (loc e) (pbft_pl_data2main_auth_data d) (keys e).

  Global Instance PBFT_I_LearnAndKnow_pl : LearnAndKnow 0.
  Proof.
    exact (MkLearnAndKnow
             0
             pbft_pl_data
             pbft_pl_info
             prepare_like2request_data
             PBFTstate
             pbft_pl_knows
             pbft_pl_data2loc
             pbft_pl_data2main_auth_data
             pbft_pl_verify
             _ _ pbft_pl_no_initial_memory).
  Defined.

  (* knows1 *)
  Definition pbft_pl_nv_knows (d : pbft_pl_data) (s : PBFTstate) : Prop :=
    exists nv pi,
      new_view_in_log nv (view_change_state s)
      /\ In pi (mergeP (new_view2cert nv))
      /\ prepare_like_in_prepared_info d pi.

  Lemma pbft_pl_nv_no_initial_memory :
    forall n d, ~ pbft_pl_nv_knows d (Process.sm_state (PBFTreplicaSM n)).
  Proof.
    introv h; simpl in h.
    unfold pbft_pl_nv_knows in h; exrepnd; simpl in *; auto.
  Qed.

  Instance PBFT_I_LearnAndKnow_pl_nv : LearnAndKnow 1.
  Proof.
  Defined.

  (* this one is used in one below *)
  Lemma prepares_like_of_new_views_are_received0 :
    forall (eo : EventOrdering) (e : Event) pl good,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> replica_has_correct_trace_before eo e good
      -> PBFTcorrect_keys eo
      -> knows1 e pl
      -> prepare_like2sender pl = good
      ->
      exists e',
        e' ≺ e
        /\ loc e' = PBFTreplica good
        /\ knows0 e' pl.

    Lemma prepares_like_of_new_views_are_received :
    forall (eo : EventOrdering) (e : Event) nv i st pi pl good,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> replica_has_correct_trace_before eo e good
      -> PBFTcorrect_keys eo
      -> loc e = PBFTreplica i
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> new_view_in_log nv (view_change_state st)
      -> In pi (mergeP (new_view2cert nv))
      -> prepare_like_in_prepared_info pl pi
      -> prepare_like2sender pl = good
      ->
      exists e' st',
        e' ≺ e
        /\ loc e' = PBFTreplica good
        /\ state_sm_on_event (PBFTreplicaSM good) e' = Some st'
        /\ prepare_like_in_log pl (log st').

      (******************CHECKPOINTS****************************************)

    Definition similar_checkpoint_in_new_view (cp : Checkpoint) (nv : NewView) :=
    exists cp' vc,
      In vc (new_view2cert nv)
      /\ checkpoint2digest cp' = checkpoint2digest cp
      /\ checkpoint2seq cp' = checkpoint2seq cp
      /\ In cp' (view_change2cert vc).

    (* used in checkpoint_somewhere_in_log_received_from_good_replica_was_logged *) (*???*)
      Lemma similar_checkpoint_in_new_view_implies :
    forall (eo : EventOrdering) (e : Event) nv cp,
      exists_at_most_f_faulty [e] F
      -> correct_new_view nv = true
      -> similar_checkpoint_in_new_view cp nv
      ->
      exists cp' vc,
        In vc (new_view2cert nv)
        /\ checkpoint2digest cp' = checkpoint2digest cp
        /\ checkpoint2seq cp' = checkpoint2seq cp
        /\ In cp' (view_change2cert vc)
        /\ node_has_correct_trace_before e (checkpoint2sender cp').
  Proof.
    introv atmost cor sim.
    unfold similar_checkpoint_in_new_view in sim; exrepnd.

    dup sim0 as corvc.
    apply correct_new_view_implies_correct_view_change in corvc; auto;[].
    applydup correct_view_change_implies_length in corvc.
    applydup correct_view_change_implies_no_repeats in corvc.
    pose proof (there_is_one_good_guy_before eo (map checkpoint2sender (view_change2cert vc)) [e]) as q.
    repeat (autodimp q hyp); exrepnd.
    allrw in_map_iff; exrepnd; subst.
    rewrite <- sim2, <- sim3.
    exists x vc; dands; auto; eauto 3 with pbft;[].
    introv w z; apply (q0 e); simpl; tcsp.
  Qed.

  (* used in  checkpoint_somewhere_in_log_received_from_good_replica_was_logged *)(*???*)
    Lemma similar_checkpoint_in_stable_implies :
    forall (eo : EventOrdering) (e : Event) cp s,
      exists_at_most_f_faulty [e] F
      -> wf_checkpoint_state (cp_state s) = true
      -> similar_checkpoint_in_stable cp s
      ->
      exists cp',
        In cp' (checkpoint_certificate_of_last_stable_checkpoint s)
        /\ checkpoint2digest cp' = checkpoint2digest cp
        /\ checkpoint2seq cp' = checkpoint2seq cp
        /\ node_has_correct_trace_before e (checkpoint2sender cp').
  Proof.
    introv atmost wf sim.
    unfold similar_checkpoint_in_stable in sim; exrepnd.

    unfold wf_checkpoint_state in *; smash_pbft.
    unfold wf_stable_checkpoint in *; smash_pbft.
    unfold wf_stable_checkpoint_entry in *; smash_pbft.
    unfold wf_stable_checkpoint_entry_no_repeats in *.
    unfold wf_stable_checkpoint_entry_same_seq_and_digest in *.

    allrw forallb_forall.
    allrw @norepeatsb_as_no_repeats.

    fold (checkpoint_certificate_of_last_stable_checkpoint s) in *.

    repndors;
      [destruct (checkpoint_certificate_of_last_stable_checkpoint s);
       simpl in *; tcsp|];[].

    pose proof (there_is_one_good_guy_before eo (map checkpoint2sender (checkpoint_certificate_of_last_stable_checkpoint s)) [e]) as q.
    repeat (autodimp q hyp); autorewrite with list; auto;[].
    exrepnd.
    allrw in_map_iff; exrepnd; subst.

    applydup wf in q2; smash_pbft.
    applydup wf in sim0; smash_pbft.
    unfold same_seq_nums, same_digests in *; smash_pbft.

    exists x; dands; auto; try congruence.
  Qed.

  (* used in checkpoint_somewhere_in_log_received_from_good_replica_was_logged *)(*???!!!*) (* I need this one *)
  Lemma sent_checkpoint_contains_state :
    forall (eo : EventOrdering) (e : Event) cp dst i st,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e] F
      -> (forall e' i good vc nv cp st,
             e' ≼ e
             -> loc e' = PBFTreplica i
             -> node_has_correct_trace_before e good
             -> checkpoint2sender cp = good
             -> state_sm_on_event (PBFTreplicaSM i) e' = Some st
             -> new_view_in_log nv (view_change_state st)
             -> In vc (new_view2cert nv)
             -> In cp (view_change2cert vc)
             ->
             exists e'' good' st2,
               e'' ≼ e'
               /\ loc e'' = PBFTreplica good'
               /\ state_sm_on_event (PBFTreplicaSM good') e'' = Some st2
               /\ next_to_execute st2 = next_seq (checkpoint2seq cp)
               /\ checkpoint2digest cp = state2hash st2)
      -> loc e = PBFTreplica i
      -> In (send_checkpoint cp dst) (output_system_on_event_ldata PBFTsys e)
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> exists e' good st2,
          e' ≼ e
          /\ loc e' = PBFTreplica good
          /\ state_sm_on_event (PBFTreplicaSM good) e' = Some st2
          /\ next_to_execute st2 = next_seq (checkpoint2seq cp)
          /\ checkpoint2digest cp = create_hash_state_last_reply (PBFT.sm_state st2) (last_reply_state st2).
  Proof.

    (* used in checkpoint_of_new_view_received_from_good_replica_was_logged *)
      Lemma checkpoint_somewhere_in_log_received_from_good_replica_was_logged :
    forall (eo : EventOrdering) (e : Event) good cp i st,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e] F
      -> loc e = PBFTreplica i
      -> node_has_correct_trace_before e good
      -> checkpoint2sender cp = good
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> checkpoint_somewhere_in_log cp st
      ->
      exists e' good' st2,
        e' ≼ e
        /\ loc e' = PBFTreplica good'
        /\ state_sm_on_event (PBFTreplicaSM good') e' = Some st2
        (* cp is created when sequence number of the executed requests is divisible by some predefined constant k *)
        (* checkpoint contains digest of the state at event e' *)
        /\ next_to_execute st2 = next_seq (checkpoint2seq cp)
        /\ checkpoint2digest cp = create_hash_state_last_reply (PBFT.sm_state st2) (last_reply_state st2).

          Lemma checkpoint_of_new_view_received_from_good_replica_was_logged :
    forall (eo : EventOrdering) (e : Event) good vc nv cp i st,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e] F
      -> loc e = PBFTreplica i
      -> node_has_correct_trace_before e good
      -> checkpoint2sender cp = good
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> new_view_in_log nv (view_change_state st)
      -> In vc (new_view2cert nv)
      -> In cp (view_change2cert vc)
      ->
      exists e' good' st2,
        e' ≺ e
        /\ loc e' = PBFTreplica good'
        /\ state_sm_on_event (PBFTreplicaSM good') e' = Some st2
        /\ next_to_execute st2 = next_seq (checkpoint2seq cp)
        /\ checkpoint2digest cp = create_hash_state_last_reply (PBFT.sm_state st2) (last_reply_state st2).
  Proof.

    (***********************************************************************************)
      Lemma view_change_of_new_view_received_from_good_replica_was_logged :
    forall (eo : EventOrdering) (e : Event) good vc nv i st,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> loc e = PBFTreplica i
      -> node_has_correct_trace_before e good
      -> view_change2sender vc = good
      -> state_sm_on_event (PBFTreplicaSM i) e = Some st
      -> new_view_in_log nv (view_change_state st)
      -> In vc (new_view2cert nv)
      ->
      exists e' st1 st2 v,
        e' ≼ e
        /\ loc e' = PBFTreplica good
        /\ state_sm_before_event (PBFTreplicaSM good) e' = Some st1
        /\ state_sm_on_event (PBFTreplicaSM good) e' = Some st2
        /\ own_view_change_in_log vc (view_change_state st2)
        /\ vc = mk_current_view_change good v st1
        /\ current_view st1 <= v <= current_view st2.
  Proof.

    (***********************************************************************************)
        (* knows0 *)

 Inductive Prepare_like :=
  | prepare_like_pre_prepare (pp : Pre_prepare)
  | prepare_like_prepare (p : Prepare).

  Definition pbft_pl_data := Prepare_like.

  Definition pbft_pl_info := RequestData.

  Definition pbft_pl_knows (d : pbft_pl_data) (s : PBFTstate) : Prop :=
    prepare_like_in_log d (log s).

  Definition pbft_pl_data2main_auth_data (d : pbft_pl_data) : AuthenticatedData :=
    prepare_like2main_auth_data d.

  Definition pbft_pl_data2loc (d : pbft_pl_data) : Rep :=
    prepare_like2sender d.

  Lemma pbft_pl_no_initial_memory :
    forall n d, ~ pbft_pl_knows d (Process.sm_state (PBFTreplicaSM n)).
  Proof.
    introv h; simpl in h; auto.
  Qed.

  Definition pbft_pl_verify (eo : EventOrdering) (e : Event) (d : pbft_pl_data) : bool :=
    verify_authenticated_data (loc e) (pbft_pl_data2main_auth_data d) (keys e).

  Global Instance PBFT_I_LearnAndKnow_pl : LearnAndKnow 0.
  Proof.
    exact (MkLearnAndKnow
             0
             pbft_pl_data
             pbft_pl_info
             prepare_like2request_data
             PBFTstate
             pbft_pl_knows
             pbft_pl_data2loc
             pbft_pl_data2main_auth_data
             pbft_pl_verify
             _ _ pbft_pl_no_initial_memory).
  Defined.

    Lemma prepares_like_of_new_views_are_received0 :
    forall (eo : EventOrdering) (e : Event) pl good,
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> node_has_correct_trace_before e good
      -> PBFTcorrect_keys eo
      -> knows1 e pl
      -> prepare_like2sender pl = good
      ->
      exists e',
        e' ≺ e
        /\ loc e' = PBFTreplica good
        /\ knows0 e' pl.
    Proof.

      (* used in PBFT_A_1_5 *)

    Lemma PBFT_A_1_5 :
    forall (eo : EventOrdering) (e : Event),
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e] F
      ->
      forall (nv      : NewView)
             (p_info1 : PreparedInfo)
             (p_info2 : PreparedInfo)
             (slf     : Rep)
             (state   : PBFTstate),
        loc e = PBFTreplica slf
        -> state_sm_on_event (PBFTreplicaSM slf) e = Some state
        -> new_view_in_log nv (view_change_state state)
        -> In p_info1 (mergeP (new_view2cert nv))
        -> In p_info2 (mergeP (new_view2cert nv))
        -> info_is_prepared p_info1 = true
        -> info_is_prepared p_info2 = true
        -> prepared_info2view p_info1 = prepared_info2view p_info2
        -> prepared_info2seq p_info1 = prepared_info2seq p_info2
        -> prepared_info2digest p_info1 = prepared_info2digest p_info2.


Require Import Bedrock.Word.

Definition B := word 8.
Definition W := word 32.

Section mem_ops.
  Variable addr mem : Type.
  Variable footprint_w : addr -> addr * addr * addr * addr.

  Variable mem_get : mem -> addr -> option B.

  Definition mem_get_word (implode : B * B * B * B -> W) (p : addr) (m : mem)
    : option W :=
    let '(a,b,c,d) := footprint_w p in
    match mem_get m a , mem_get m b , mem_get m c , mem_get m d with
      | Some a , Some b , Some c , Some d =>
        Some (implode (a,b,c,d))
      | _ , _ , _ , _ => None
    end.

  Variable mem_set : mem -> addr -> B -> option mem.

  Definition mem_set_word (explode : W -> B * B * B * B) (p : addr) (v : W)
    (m : mem) : option mem :=
    let '(a,b,c,d) := footprint_w p in
    let '(av,bv,cv,dv) := explode v in
    match mem_set m d dv with
      | Some m => match mem_set m c cv with
                    | Some m => match mem_set m b bv with
                                  | Some m => mem_set m a av
                                  | None => None
                                end
                    | None => None
                  end
      | None => None
    end.

End mem_ops.


Require Export functor.

(** The identity functor. *)
Instance Fmap_id : Fmap id := fun _ _ => id.

Instance Functor_id : Functor id.
Proof. firstorder. Qed.

Instance Fmap_id' : Fmap (fun X => X) := Fmap_id.
Instance Functor_id' : Functor (fun X => X) := Functor_id.

(** The identity monad is defined at the bottom of monad.v because of
dependency order (the definition of adjunctions uses the identity
functor). *)


From Pony Require Import Language.

Require Import Coq.FSets.FMapInterface.
Require Import Coq.FSets.FMapFacts.

Module LocalMap (Map : WSfun).

Module VarMap := Map DecidableVar.
Module VarMapFacts := WFacts_fun DecidableVar VarMap.

Module TempMap := Map DecidableTemp.
Module TempMapFacts := WFacts_fun DecidableTemp TempMap.

Definition t (X Y : Type) : Type := ((VarMap.t X) * (TempMap.t Y)).

Definition VarMapsTo { E F : Type } (var : Syntax.var) (e : E) (m : t E F) : Prop :=
  VarMap.MapsTo var e (fst m).

Definition TempMapsTo { E F : Type } (temp : Syntax.temp) (f : F) (m : t E F) : Prop :=
  TempMap.MapsTo temp f (snd m).

Definition VarIn { E F : Type } (var : Syntax.var) (m : t E F) : Prop :=
  VarMap.In var (fst m).

Definition addVar { E F : Type } (var : Syntax.var) (e : E) (m : t E F) : t E F :=
  (VarMap.add var e (fst m), snd m).

Definition addTemp { E F : Type } (temp : Syntax.temp) (f : F) (m : t E F) : t E F :=
  (fst m, TempMap.add temp f (snd m)).

Definition removeVar { E F : Type } (var : Syntax.var) (m : t E F) : t E F :=
  (VarMap.remove var (fst m), snd m).

Definition removeTemp { E F : Type } (temp : Syntax.temp) (m : t E F) : t E F :=
  (fst m, TempMap.remove temp (snd m)).

Definition empty (E F : Type) : t E F := (VarMap.empty E, TempMap.empty F).

Definition fold_var { E F B : Type } (f : Syntax.var -> E -> B -> B) (m : t E F) (init : B) : B
  := VarMap.fold f (fst m) init.

Lemma VarMapsTo_func { E F : Type } :
  forall m : t E F,
  forall var : Syntax.var,
  forall e1 e2 : E,
  VarMapsTo var e1 m
    -> VarMapsTo var e2 m
    -> e1 = e2.
Proof.
  intros m var e1 e2.
  unfold VarMapsTo.
  intros; apply VarMapFacts.MapsTo_fun with (m:=fst m) (x:=var); assumption.
  Qed.

Lemma TempMapsTo_func { E F : Type } :
  forall m : t E F,
  forall temp : Syntax.temp,
  forall f1 f2 : F,
  TempMapsTo temp f1 m
    -> TempMapsTo temp f2 m
    -> f1 = f2.
Proof.
  intros m temp f1 f2.
  unfold TempMapsTo.
  intros; apply TempMapFacts.MapsTo_fun with (m:=snd m) (x:=temp); assumption.
  Qed.

End LocalMap.


Require Import VST.floyd.proofauto.
Require Import VST.progs.append.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep (sh: share)
            (contents: list val) (x: val) : mpred :=
 match contents with
 | h::hs =>
              EX y:val,
                data_at sh t_struct_list (h,y) x * listrep sh hs y
 | nil => !! (x = nullval) && emp
 end.

Arguments listrep sh contents x : simpl never.

Lemma listrep_local_facts:
  forall sh contents p,
     listrep sh contents p |--
     !! (is_pointer_or_null p /\ (p=nullval <-> contents=nil)).
Proof.
intros.
revert p; induction contents;
  unfold listrep; fold listrep; intros. entailer!. intuition.
Intros y. entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

#[export] Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sh contents p,
   sepalg.nonidentity sh ->
   listrep sh contents p |-- valid_pointer p.
Proof.
 destruct contents; unfold listrep; fold listrep; intros; Intros; subst.
 auto with valid_pointer.
 Intros y.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

#[export] Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma listrep_null: forall sh contents,
    listrep sh contents nullval = !! (contents=nil) && emp.
Proof.
destruct contents; unfold listrep; fold listrep.
autorewrite with norm. auto.
apply pred_ext.
Intros y. entailer. destruct H; contradiction.
Intros. discriminate.
Qed.

Lemma is_pointer_or_null_not_null:
 forall x, is_pointer_or_null x -> x <> nullval -> isptr x.
Proof.
intros.
 destruct x; try contradiction. hnf in H; subst i. contradiction H0; reflexivity.
 apply I.
Qed.

Definition append_spec :=
 DECLARE _append
  WITH sh : share, x: val, y: val, s1: list val, s2: list val
  PRE [ tptr t_struct_list , tptr t_struct_list]
     PROP(writable_share sh)
     PARAMS (x; y) GLOBALS()
     SEP (listrep sh s1 x; listrep sh s2 y)
  POST [ tptr t_struct_list ]
    EX r: val,
     PROP()
     RETURN (r)
     SEP (listrep sh (s1++s2) r).

Definition Gprog : funspecs :=   ltac:(with_library prog [ append_spec ]).

Module Proof1.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null.  Intros.  subst.
 forward.
 Exists y.
 entailer!!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep at 1; fold listrep.
 Intros.  contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      ( EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP ()
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (listrep sh (a::s1b++s2) t -* listrep sh (s1++s2) x;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists v s1' x u.
   subst s1. entailer!!. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!!.
+ (* loop body preserves invariant *)
   clear v Heqs1.
   destruct s1b; unfold listrep at 3; fold listrep. Intros. contradiction.
   Intros z.
   forward.
   forward.
   Exists (v,s1b,u0,z). unfold fst, snd.
   simpl app.
   entailer!!.
   rewrite sepcon_comm.
   apply RAMIF_PLAIN.trans''.
   apply wand_sepcon_adjoint.
   forget (v::s1b++s2) as s3.
   unfold listrep; fold listrep; Exists u0; auto.
+ (* after the loop *)
   clear v s1' Heqs1.
   forward.
   forward.
   rewrite (proj1 H2 (eq_refl _)).
   Exists x.
   simpl app.
   clear.
   entailer!!.
   unfold listrep at 3; fold listrep. Intros.
   pull_right (listrep sh (a :: s2) t -* listrep sh (s1 ++ s2) x).
   apply modus_ponens_wand'.
   unfold listrep at 2; fold listrep. Exists y; cancel.
Qed.

End Proof1.

Module Proof2.

Definition lseg (sh: share) (contents: list val) (x z: val) : mpred :=
  ALL cts2:list val, listrep sh cts2 z -* listrep sh (contents++cts2) x.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
forward_if.
*
 subst x. rewrite listrep_null. Intros; subst.
 forward.
 Exists y.
 entailer!!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold listrep; fold listrep. Intros; contradiction.
 Intros u.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val,  EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   listrep sh s1b u;
                   listrep sh s2 y))%assert.
+ (* current assertion implies loop invariant *)
   Exists (@nil val) v s1' x u.  entailer!!.
   unfold lseg. apply allp_right; intro. simpl. cancel_wand.
+ (* loop test is safe to execute *)
   entailer!!.
+ (* loop body preserves invariant *)
   clear v Heqs1. subst s1.
   destruct s1b; unfold listrep; fold listrep. Intros; contradiction.
   Intros z.
   forward.
   forward.
   Exists (s1a++[a],v,s1b,u0,z). unfold fst, snd.
   rewrite !app_ass. simpl app.
   entailer!!.
   unfold lseg.
   rewrite sepcon_comm.
   clear.
   apply RAMIF_Q.trans'' with (cons a).
   extensionality cts; simpl; rewrite app_ass; reflexivity.
   apply allp_right; intro. apply wand_sepcon_adjoint.
   unfold listrep at 2; fold listrep; Exists u0.  apply derives_refl.
 + (* after the loop *)
   forward. forward.
   Exists x. entailer!!.
   destruct H3 as [? _]. specialize (H3 (eq_refl _)). subst s1b.
   unfold listrep at 1.  Intros. autorewrite with norm.  rewrite H0. rewrite app_ass. simpl app.
   unfold lseg.
   rewrite sepcon_assoc.
   eapply derives_trans; [apply allp_sepcon1 | ]. apply allp_left with (a::s2).
   rewrite sepcon_comm.
   eapply derives_trans; [ | apply modus_ponens_wand].
   apply sepcon_derives; [ | apply derives_refl].
   unfold listrep at 2; fold listrep. Exists y; auto.
Qed.

End Proof2.

Module Proof3.  (*************** inductive lseg *******************)

Fixpoint lseg (sh: share)
            (contents: list val) (x z: val) : mpred :=
 match contents with
 | h::hs => !! (x<>z) &&
              EX y:val,
                data_at sh t_struct_list (h,y) x * lseg sh hs y z
 | nil => !! (x = z /\ is_pointer_or_null x) && emp
 end.

Arguments lseg sh contents x z : simpl never.

Lemma lseg_local_facts:
  forall sh contents p q,
     lseg sh contents p q |--
     !! (is_pointer_or_null p /\ is_pointer_or_null q /\ (p=q <-> contents=nil)).
Proof.
intros.
apply derives_trans with (lseg sh contents p q && !! (is_pointer_or_null p /\
        is_pointer_or_null q /\ (p = q <-> contents = []))).
2: entailer!.
revert p; induction contents; intros; simpl; unfold lseg; fold lseg.
entailer!.
intuition.
Intros y. Exists y.
eapply derives_trans.
apply sepcon_derives.
apply derives_refl.
apply IHcontents.
entailer!.
intuition congruence.
Qed.

#[export] Hint Resolve lseg_local_facts : saturate_local.

Lemma lseg_valid_pointer:
  forall sh contents p ,
   sepalg.nonidentity sh ->
   lseg sh contents p nullval |-- valid_pointer p.
Proof.
 destruct contents; unfold lseg; fold lseg; intros. entailer!.
 Intros *.
 auto with valid_pointer.
Qed.

#[export] Hint Resolve lseg_valid_pointer : valid_pointer.

Lemma lseg_eq: forall sh contents x,
    lseg sh contents x x = !! (contents=nil /\ is_pointer_or_null x) && emp.
Proof.
intros.
destruct contents; unfold lseg; fold lseg.
f_equal. f_equal. f_equal. apply prop_ext; intuition.
apply pred_ext.
Intros y. contradiction.
Intros. discriminate.
Qed.

Lemma lseg_null: forall sh contents,
    lseg sh contents nullval nullval = !! (contents=nil) && emp.
Proof.
intros.
 rewrite lseg_eq.
 apply pred_ext.
 entailer!.
 entailer!.
Qed.

Lemma lseg_cons: forall sh (v u x: val) s,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * lseg sh s u nullval
 |-- lseg sh [v] x u * lseg sh s u nullval.
Proof.
intros.
     unfold lseg at 2. Exists u.
     entailer.
     destruct s; unfold lseg at 1; fold lseg; entailer.
Qed.

Lemma lseg_cons': forall sh (v u x a b: val) ,
   readable_share sh ->
 data_at sh t_struct_list (v, u) x * data_at sh t_struct_list (a,b) u
 |-- lseg sh [v] x u * data_at sh t_struct_list (a,b) u.
Proof.
intros.
     unfold lseg. Exists u.
     entailer!.
Qed.

Lemma lseg_app': forall sh s1 s2 (a w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * data_at sh t_struct_list (a,z) y |--
   lseg sh (s1++s2) w y * data_at sh t_struct_list (a,z) y.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app_null: forall sh s1 s2 (w x: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x nullval |--
   lseg sh (s1++s2) w nullval.
Proof.
 intros.
 revert w; induction s1; intro; simpl.
 unfold lseg at 1. entailer!.
 unfold lseg at 1 3; fold lseg. Intros j; Exists j.
 entailer.
 sep_apply (IHs1 j).
 cancel.
Qed.

Lemma lseg_app: forall sh s1 s2 a s3 (w x y z: val),
   readable_share sh ->
   lseg sh s1 w x * lseg sh s2 x y * lseg sh (a::s3) y z |--
   lseg sh (s1++s2) w y * lseg sh (a::s3) y z.
Proof.
 intros.
 unfold lseg at 3 5; fold lseg.
 Intros u; Exists u. rewrite prop_true_andp by auto.
 sep_apply (lseg_app' sh s1 s2 a w x y u); auto.
 cancel.
Qed.

Lemma listrep_lseg_null :
 listrep = fun sh s p => lseg sh s p nullval.
Proof.
extensionality sh s p.
revert p.
induction s; intros.
unfold lseg, listrep; apply pred_ext; entailer!.
unfold lseg, listrep; fold lseg; fold listrep.
apply pred_ext; Intros y; Exists y; rewrite IHs; entailer!.
Qed.

Lemma body_append: semax_body Vprog Gprog f_append append_spec.
Proof.
start_function.
revert POSTCONDITION; rewrite listrep_lseg_null; intro.
forward_if.
*
 subst x. rewrite lseg_null. Intros. subst.
 forward.
 Exists y.
 entailer!!.
 simpl; auto.
*
 forward.
 destruct s1 as [ | v s1']; unfold lseg at 1; fold lseg.
 Intros. contradiction H.
 Intros u.
 clear - SH.
 remember (v::s1') as s1.
 forward.
 forward_while
      (EX s1a: list val, EX a: val, EX s1b: list val, EX t: val, EX u: val,
            PROP (s1 = s1a ++ a :: s1b)
            LOCAL (temp _x x; temp _t t; temp _u u; temp _y y)
            SEP (lseg sh s1a x t;
                   data_at sh t_struct_list (a,u) t;
                   lseg sh s1b u nullval;
                   lseg sh s2 y nullval))%assert.
 + (* current assertion implies loop invariant *)
     Exists (@nil val) v s1' x u.
     subst s1. rewrite lseg_eq.
     entailer.
(*     sep_apply (lseg_cons sh v u x s1'); auto. *)
 + (* loop test is safe to execute *)
     entailer!!.
 + (* loop body preserves invariant *)
    destruct s1b; unfold lseg at 2; fold lseg.
    Intros. contradiction.
    Intros z.
    forward.
    forward.
    Exists (s1a++a::nil, v0, s1b,u0,z). unfold fst, snd.
    simpl app; rewrite app_ass.
    entailer.
    sep_apply (lseg_cons' sh a u0 t v0 z); auto.
    sep_apply (lseg_app' sh s1a [a] v0 x t u0 z); auto.
    cancel.
 + (* after the loop *)
    clear v s1' Heqs1.
    subst. rewrite lseg_eq. Intros. subst.
    forward.
    forward.
    Exists x.
    entailer!!.
    sep_apply (lseg_cons sh a y t s2); auto.
    sep_apply (lseg_app_null sh [a] s2 t y); auto.
    rewrite app_ass.
    sep_apply (lseg_app_null sh s1a ([a]++s2) x t); auto.
Qed.

End Proof3.


Require Import Equations.

Derive NoConfusion for vector.

Inductive foo (A : Type) : nat -> bool -> Set :=
| fool n : foo A n true
| foor : foo A 0 false.

Derive NoConfusion for foo.

Inductive foolet (A : Type) (B := A) : nat -> bool -> Set :=
| fooletl n : foolet A n true
| fooletr : foolet A 0 false.

Derive NoConfusion for foolet.

(** elim vs destruct bug on foolet *)

(* Next Obligation. *)
(*   intros. destruct_sigma b. elim b. *)
(*   destruct b. solve_ *)
(*                 destruct pr1. simpl. simpl in *. *)
(*   (* Bug in Coq: destruct pr2 *) *)
(*   elim pr2. simpl. intros; auto. *)
(*   simpl. auto. *)
(* Defined. *)


(*
MacBook-Air:shpotify billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_15.

Coq < Goal forall e b u c:Prop, ((e -> ~b) /\ (u -> ~c) /\ ~(~e /\ ~u)) -> ~(b /\ c).
1 subgoal

  ============================
   forall e b u c : Prop,
   (e -> ~ b) /\ (u -> ~ c) /\ ~ (~ e /\ ~ u) -> ~ (b /\ c)

Unnamed_thm < intros.
1 subgoal

  e : Prop
  b : Prop
  u : Prop
  c : Prop
  H : (e -> ~ b) /\ (u -> ~ c) /\ ~ (~ e /\ ~ u)
  ============================
   ~ (b /\ c)

Unnamed_thm < elim H.
1 subgoal

  e : Prop
  b : Prop
  u : Prop
  c : Prop
  H : (e -> ~ b) /\ (u -> ~ c) /\ ~ (~ e /\ ~ u)
  ============================
   (e -> ~ b) -> (u -> ~ c) /\ ~ (~ e /\ ~ u) -> ~ (b /\ c)

Unnamed_thm < intro.
1 subgoal

  e : Prop
  b : Prop
  u : Prop
  c : Prop
  H : (e -> ~ b) /\ (u -> ~ c) /\ ~ (~ e /\ ~ u)
  H0 : e -> ~ b
  ============================
   (u -> ~ c) /\ ~ (~ e /\ ~ u) -> ~ (b /\ c)

Unnamed_thm < intro.
1 subgoal

  e : Prop
  b : Prop
  u : Prop
  c : Prop
  H : (e -> ~ b) /\ (u -> ~ c) /\ ~ (~ e /\ ~ u)
  H0 : e -> ~ b
  H1 : (u -> ~ c) /\ ~ (~ e /\ ~ u)
  ============================
   ~ (b /\ c)

Unnamed_thm < intro.
1 subgoal

  e : Prop
  b : Prop
  u : Prop
  c : Prop
  H : (e -> ~ b) /\ (u -> ~ c) /\ ~ (~ e /\ ~ u)
  H0 : e -> ~ b
  H1 : (u -> ~ c) /\ ~ (~ e /\ ~ u)
  H2 : b /\ c
  ============================
   False

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <

*)

Require Import Classical.
Section Exercise_15.
Goal forall e b u c:Prop, ((e -> ~b) /\ (u -> ~c) /\ ~(~e /\ ~u)) -> ~(b /\ c).
intros.
elim H.
intro.
intro.
intro.
 firstorder .
 Qed.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * Typeclass-based morphism definition and standard, minimal instances

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.
Require Import Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.

Generalizable All Variables.
Local Obligation Tactic := simpl_relation.

Local Notation "'λ'  x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity).

Local Notation "'Π'  x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity) : type_scope.

(** * Morphisms.

   We now turn to the definition of [Proper] and declare standard instances.
   These will be used by the [setoid_rewrite] tactic later. *)

(** A morphism for a relation [R] is a proper element of the relation.
   The relation [R] will be instantiated by [respectful] and [A] by an arrow
   type for usual morphisms. *)

Class Proper {A} (R : relation A) (m : A) : Prop :=
  proper_prf : R m m.

(** Respectful morphisms. *)

(** The fully dependent version, not used yet. *)

Definition respectful_hetero
  (A B : Type)
  (C : A -> Type) (D : B -> Type)
  (R : A -> B -> Prop)
  (R' : forall (x : A) (y : B), C x -> D y -> Prop) :
    (forall x : A, C x) -> (forall x : B, D x) -> Prop :=
    fun f g => forall x y, R x y -> R' x y (f x) (g y).

(** The non-dependent version is an instance where we forget dependencies. *)

Definition respectful {A B : Type}
  (R : relation A) (R' : relation B) : relation (A -> B) :=
  Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R').

(** Notations reminiscent of the old syntax for declaring morphisms. *)

Delimit Scope signature_scope with signature.

Arguments Scope Proper [type_scope signature_scope].
Arguments Scope respectful [type_scope type_scope signature_scope signature_scope].

Module ProperNotations.

  Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature))
    (right associativity, at level 55) : signature_scope.

  Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature))
    (right associativity, at level 55) : signature_scope.

  Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature))
    (right associativity, at level 55) : signature_scope.

End ProperNotations.

Export ProperNotations.

Open Local Scope signature_scope.

(** [solve_proper] try to solve the goal [Proper (?==> ... ==>?) f]
    by repeated introductions and setoid rewrites. It should work
    fine when [f] is a combination of already known morphisms and
    quantifiers. *)

Ltac solve_respectful t :=
 match goal with
   | |- respectful _ _ _ _ =>
     let H := fresh "H" in
     intros ? ? H; solve_respectful ltac:(setoid_rewrite H; t)
   | _ => t; reflexivity
 end.

Ltac solve_proper := unfold Proper; solve_respectful ltac:(idtac).

(** [f_equiv] is a clone of [f_equal] that handles setoid equivalences.
    For example, if we know that [f] is a morphism for [E1==>E2==>E],
    then the goal [E (f x y) (f x' y')] will be transformed by [f_equiv]
    into the subgoals [E1 x x'] and [E2 y y'].
*)

Ltac f_equiv :=
 match goal with
  | |- ?R (?f ?x) (?f' _) =>
    let T := type of x in
    let Rx := fresh "R" in
    evar (Rx : relation T);
    let H := fresh in
    assert (H : (Rx==>R)%signature f f');
    unfold Rx in *; clear Rx; [ f_equiv | apply H; clear H; try reflexivity ]
  | |- ?R ?f ?f' =>
    try reflexivity;
    change (Proper R f); eauto with typeclass_instances; fail
  | _ => idtac
 end.

(** [forall_def] reifies the dependent product as a definition. *)

Definition forall_def {A : Type} (B : A -> Type) : Type := forall x : A, B x.

(** Dependent pointwise lifting of a relation on the range. *)

Definition forall_relation {A : Type} {B : A -> Type} (sig : Π a : A, relation (B a)) : relation (Π x : A, B x) :=
  λ f g, Π a : A, sig a (f a) (g a).

Arguments Scope forall_relation [type_scope type_scope signature_scope].

(** Non-dependent pointwise lifting *)

Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) :=
  Eval compute in forall_relation (B:=λ _, B) (λ _, R).

Lemma pointwise_pointwise A B (R : relation B) :
  relation_equivalence (pointwise_relation A R) (@eq A ==> R).
Proof. intros. split. simpl_relation. firstorder. Qed.

(** We can build a PER on the Coq function space if we have PERs on the domain and
   codomain. *)

Hint Unfold Reflexive : core.
Hint Unfold Symmetric : core.
Hint Unfold Transitive : core.

Typeclasses Opaque respectful pointwise_relation forall_relation.

Program Instance respectful_per `(PER A R, PER B R') : PER (R ==> R').

  Next Obligation.
  Proof with auto.
    assert(R x0 x0).
    transitivity y0... symmetry...
    transitivity (y x0)...
  Qed.

(** Subrelations induce a morphism on the identity. *)

Instance subrelation_id_proper `(subrelation A R₁ R₂) : Proper (R₁ ==> R₂) id.
Proof. firstorder. Qed.

(** The subrelation property goes through products as usual. *)

Lemma subrelation_respectful `(subl : subrelation A R₂ R₁, subr : subrelation B S₁ S₂) :
  subrelation (R₁ ==> S₁) (R₂ ==> S₂).
Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed.

(** And of course it is reflexive. *)

Lemma subrelation_refl A R : @subrelation A R R.
Proof. simpl_relation. Qed.

Ltac subrelation_tac T U :=
  (is_ground T ; is_ground U ; class_apply @subrelation_refl) ||
    class_apply @subrelation_respectful || class_apply @subrelation_refl.

Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances.

(** [Proper] is itself a covariant morphism for [subrelation]. *)

Lemma subrelation_proper `(mor : Proper A R₁ m, unc : Unconvertible (relation A) R₁ R₂,
  sub : subrelation A R₁ R₂) : Proper R₂ m.
Proof.
  intros. apply sub. apply mor.
Qed.

CoInductive apply_subrelation : Prop := do_subrelation.

Ltac proper_subrelation :=
  match goal with
    [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper
  end.

Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances.

Instance proper_subrelation_proper :
  Proper (subrelation ++> eq ==> impl) (@Proper A).
Proof. reduce. subst. firstorder. Qed.

(** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *)

Instance iff_impl_subrelation : subrelation iff impl | 2.
Proof. firstorder. Qed.

Instance iff_inverse_impl_subrelation : subrelation iff (inverse impl) | 2.
Proof. firstorder. Qed.

Instance pointwise_subrelation {A} `(sub : subrelation B R R') :
  subrelation (pointwise_relation A R) (pointwise_relation A R') | 4.
Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed.

(** For dependent function types. *)
Lemma forall_subrelation A (B : A -> Type) (R S : forall x : A, relation (B x)) :
  (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S).
Proof. reduce. apply H. apply H0. Qed.

(** We use an extern hint to help unification. *)

Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) =>
  apply (@forall_subrelation A B R S) ; intro : typeclass_instances.

(** Any symmetric relation is equal to its inverse. *)

Lemma subrelation_symmetric A R `(Symmetric A R) : subrelation (inverse R) R.
Proof. reduce. red in H0. symmetry. assumption. Qed.

Hint Extern 4 (subrelation (inverse _) _) =>
  class_apply @subrelation_symmetric : typeclass_instances.

(** The complement of a relation conserves its proper elements. *)

Program Instance complement_proper
  `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) :
  Proper (RA ==> RA ==> iff) (complement R).

  Next Obligation.
  Proof.
    unfold complement.
    pose (mR x y H x0 y0 H0).
    intuition.
  Qed.

(** The [inverse] too, actually the [flip] instance is a bit more general. *)

Program Instance flip_proper
  `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) :
  Proper (RB ==> RA ==> RC) (flip f).

  Next Obligation.
  Proof.
    apply mor ; auto.
  Qed.

(** Every Transitive relation gives rise to a binary morphism on [impl],
   contravariant in the first argument, covariant in the second. *)

Program Instance trans_contra_co_morphism
  `(Transitive A R) : Proper (R --> R ++> impl) R.

  Next Obligation.
  Proof with auto.
    transitivity x...
    transitivity x0...
  Qed.

(** Proper declarations for partial applications. *)

Program Instance trans_contra_inv_impl_morphism
  `(Transitive A R) : Proper (R --> inverse impl) (R x) | 3.

  Next Obligation.
  Proof with auto.
    transitivity y...
  Qed.

Program Instance trans_co_impl_morphism
  `(Transitive A R) : Proper (R ++> impl) (R x) | 3.

  Next Obligation.
  Proof with auto.
    transitivity x0...
  Qed.

Program Instance trans_sym_co_inv_impl_morphism
  `(PER A R) : Proper (R ++> inverse impl) (R x) | 3.

  Next Obligation.
  Proof with auto.
    transitivity y... symmetry...
  Qed.

Program Instance trans_sym_contra_impl_morphism
  `(PER A R) : Proper (R --> impl) (R x) | 3.

  Next Obligation.
  Proof with auto.
    transitivity x0... symmetry...
  Qed.

Program Instance per_partial_app_morphism
  `(PER A R) : Proper (R ==> iff) (R x) | 2.

  Next Obligation.
  Proof with auto.
    split. intros ; transitivity x0...
    intros.
    transitivity y...
    symmetry...
  Qed.

(** Every Transitive relation induces a morphism by "pushing" an [R x y] on the left of an [R x z] proof
   to get an [R y z] goal. *)

Program Instance trans_co_eq_inv_impl_morphism
  `(Transitive A R) : Proper (R ==> (@eq A) ==> inverse impl) R | 2.

  Next Obligation.
  Proof with auto.
    transitivity y...
  Qed.

(** Every Symmetric and Transitive relation gives rise to an equivariant morphism. *)

Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1.

  Next Obligation.
  Proof with auto.
    split ; intros.
    transitivity x0... transitivity x... symmetry...

    transitivity y... transitivity y0... symmetry...
  Qed.

Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R).
Proof. firstorder. Qed.

Program Instance compose_proper A B C R₀ R₁ R₂ :
  Proper ((R₁ ==> R₂) ==> (R₀ ==> R₁) ==> (R₀ ==> R₂)) (@compose A B C).

  Next Obligation.
  Proof.
    simpl_relation.
    unfold compose. apply H. apply H0. apply H1.
  Qed.

(** Coq functions are morphisms for Leibniz equality,
   applied only if really needed. *)

Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') :
  Reflexive (@Logic.eq A ==> R').
Proof. simpl_relation. Qed.

(** [respectful] is a morphism for relation equivalence. *)

Instance respectful_morphism :
  Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B).
Proof.
  reduce.
  unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *.
  split ; intros.

    rewrite <- H0.
    apply H1.
    rewrite H.
    assumption.

    rewrite H0.
    apply H1.
    rewrite <- H.
    assumption.
Qed.

(** Every element in the carrier of a reflexive relation is a morphism for this relation.
   We use a proxy class for this case which is used internally to discharge reflexivity constraints.
   The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of
   [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able
   to set different priorities in different hint bases and select a particular hint database for
   resolution of a type class constraint.*)

Class ProperProxy {A} (R : relation A) (m : A) : Prop :=
  proper_proxy : R m m.

Lemma eq_proper_proxy A (x : A) : ProperProxy (@eq A) x.
Proof. firstorder. Qed.

Lemma reflexive_proper_proxy `(Reflexive A R) (x : A) : ProperProxy R x.
Proof. firstorder. Qed.

Lemma proper_proper_proxy `(Proper A R x) : ProperProxy R x.
Proof. firstorder. Qed.

Hint Extern 1 (ProperProxy _ _) =>
  class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances.
Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances.

(** [R] is Reflexive, hence we can build the needed proof. *)

Lemma Reflexive_partial_app_morphism `(Proper (A -> B) (R ==> R') m, ProperProxy A R x) :
   Proper R' (m x).
Proof. simpl_relation. Qed.

Class Params {A : Type} (of : A) (arity : nat).

Class PartialApplication.

CoInductive normalization_done : Prop := did_normalization.

Ltac partial_application_tactic :=
  let rec do_partial_apps H m :=
    match m with
      | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; [do_partial_apps H m'|clear H]
      | _ => idtac
    end
  in
  let rec do_partial H ar m :=
    match ar with
      | 0 => do_partial_apps H m
      | S ?n' =>
        match m with
          ?m' ?x => do_partial H n' m'
        end
    end
  in
  let on_morphism m :=
    let m' := fresh in head_of_constr m' m ;
    let n := fresh in evar (n:nat) ;
    let v := eval compute in n in clear n ;
    let H := fresh in
      assert(H:Params m' v) by typeclasses eauto ;
      let v' := eval compute in v in subst m';
      do_partial H v' m
 in
  match goal with
    | [ _ : normalization_done |- _ ] => fail 1
    | [ _ : @Params _ _ _ |- _ ] => fail 1
    | [ |- @Proper ?T _ (?m ?x) ] =>
      match goal with
        | [ _ : PartialApplication |- _ ] =>
          class_apply @Reflexive_partial_app_morphism
        | _ =>
          on_morphism (m x) ||
            (class_apply @Reflexive_partial_app_morphism ;
              [ pose Build_PartialApplication | idtac ])
      end
  end.

Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances.

Lemma inverse_respectful : forall (A : Type) (R : relation A) (B : Type) (R' : relation B),
  relation_equivalence (inverse (R ==> R')) (inverse R ==> inverse R').
Proof.
  intros.
  unfold flip, respectful.
  split ; intros ; intuition.
Qed.

(** Special-purpose class to do normalization of signatures w.r.t. inverse. *)

Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop :=
  normalizes : relation_equivalence m m'.

(** Current strategy: add [inverse] everywhere and reduce using [subrelation]
   afterwards. *)

Lemma inverse_atom A R : Normalizes A R (inverse (inverse R)).
Proof.
  firstorder.
Qed.

Lemma inverse_arrow `(NA : Normalizes A R (inverse R'''), NB : Normalizes B R' (inverse R'')) :
  Normalizes (A -> B) (R ==> R') (inverse (R''' ==> R'')%signature).
Proof. unfold Normalizes in *. intros.
  rewrite NA, NB. firstorder.
Qed.

Ltac inverse :=
  match goal with
    | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @inverse_arrow
    | _ => class_apply @inverse_atom
  end.

Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances.

(** Treating inverse: can't make them direct instances as we
   need at least a [flip] present in the goal. *)

Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R.
Proof. firstorder. Qed.

Lemma inverse2 `(subrelation A R R') : subrelation R (inverse (inverse R')).
Proof. firstorder. Qed.

Hint Extern 1 (subrelation (flip _) _) => class_apply @inverse1 : typeclass_instances.
Hint Extern 1 (subrelation _ (flip _)) => class_apply @inverse2 : typeclass_instances.

(** That's if and only if *)

Lemma eq_subrelation `(Reflexive A R) : subrelation (@eq A) R.
Proof. simpl_relation. Qed.

(* Hint Extern 3 (subrelation eq ?R) => not_evar R ; class_apply eq_subrelation : typeclass_instances. *)

(** Once we have normalized, we will apply this instance to simplify the problem. *)

Definition proper_inverse_proper `(mor : Proper A R m) : Proper (inverse R) m := mor.

Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_inverse_proper : typeclass_instances.

(** Bootstrap !!! *)

Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A).
Proof.
  simpl_relation.
  reduce in H.
  split ; red ; intros.
  setoid_rewrite <- H.
  apply H0.
  setoid_rewrite H.
  apply H0.
Qed.

Lemma proper_normalizes_proper `(Normalizes A R0 R1, Proper A R1 m) : Proper R0 m.
Proof.
  red in H, H0.
  setoid_rewrite H.
  assumption.
Qed.

Ltac proper_normalization :=
  match goal with
    | [ _ : normalization_done |- _ ] => fail 1
    | [ _ : apply_subrelation |- @Proper _ ?R _ ] => let H := fresh "H" in
      set(H:=did_normalization) ; class_apply @proper_normalizes_proper
  end.

Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances.

(** Every reflexive relation gives rise to a morphism, only for immediately solving goals without variables. *)

Lemma reflexive_proper `{Reflexive A R} (x : A)
   : Proper R x.
Proof. firstorder. Qed.

Lemma proper_eq A (x : A) : Proper (@eq A) x.
Proof. intros. apply reflexive_proper. Qed.

Ltac proper_reflexive :=
  match goal with
    | [ _ : normalization_done |- _ ] => fail 1
    | _ => class_apply proper_eq || class_apply @reflexive_proper
  end.

Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances.

(** When the relation on the domain is symmetric, we can
    inverse the relation on the codomain. Same for binary functions. *)

Lemma proper_sym_flip :
 forall `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f),
 Proper (R1==>inverse R2) f.
Proof.
intros A R1 Sym B R2 f Hf.
intros x x' Hxx'. apply Hf, Sym, Hxx'.
Qed.

Lemma proper_sym_flip_2 :
 forall `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f),
 Proper (R1==>R2==>inverse R3) f.
Proof.
intros A R1 Sym1 B R2 Sym2 C R3 f Hf.
intros x x' Hxx' y y' Hyy'. apply Hf; auto.
Qed.

(** When the relation on the domain is symmetric, a predicate is
  compatible with [iff] as soon as it is compatible with [impl].
  Same with a binary relation. *)

Lemma proper_sym_impl_iff : forall `(Symmetric A R)`(Proper _ (R==>impl) f),
 Proper (R==>iff) f.
Proof.
intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto.
Qed.

Lemma proper_sym_impl_iff_2 :
 forall `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f),
 Proper (R==>R'==>iff) f.
Proof.
intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'.
repeat red in Hf. split; eauto.
Qed.

(** A [PartialOrder] is compatible with its underlying equivalence. *)

Instance PartialOrder_proper `(PartialOrder A eqA R) :
  Proper (eqA==>eqA==>iff) R.
Proof.
intros.
apply proper_sym_impl_iff_2; auto with *.
intros x x' Hx y y' Hy Hr.
transitivity x.
generalize (partial_order_equivalence x x'); compute; intuition.
transitivity y; auto.
generalize (partial_order_equivalence y y'); compute; intuition.
Qed.

(** From a [PartialOrder] to the corresponding [StrictOrder]:
     [lt = le /\ ~eq].
    If the order is total, we could also say [gt = ~le]. *)

Lemma PartialOrder_StrictOrder `(PartialOrder A eqA R) :
  StrictOrder (relation_conjunction R (complement eqA)).
Proof.
split; compute.
intros x (_,Hx). apply Hx, Equivalence_Reflexive.
intros x y z (Hxy,Hxy') (Hyz,Hyz'). split.
apply PreOrder_Transitive with y; assumption.
intro Hxz.
apply Hxy'.
apply partial_order_antisym; auto.
rewrite Hxz; auto.
Qed.

Hint Extern 4 (StrictOrder (relation_conjunction _ _)) =>
  class_apply PartialOrder_StrictOrder : typeclass_instances.

(** From a [StrictOrder] to the corresponding [PartialOrder]:
     [le = lt \/ eq].
    If the order is total, we could also say [ge = ~lt]. *)

Lemma StrictOrder_PreOrder
 `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) :
 PreOrder (relation_disjunction R eqA).
Proof.
split.
intros x. right. reflexivity.
intros x y z [Hxy|Hxy] [Hyz|Hyz].
left. transitivity y; auto.
left. rewrite <- Hyz; auto.
left. rewrite Hxy; auto.
right. transitivity y; auto.
Qed.

Hint Extern 4 (PreOrder (relation_disjunction _ _)) =>
  class_apply StrictOrder_PreOrder : typeclass_instances.

Lemma StrictOrder_PartialOrder
  `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) :
  PartialOrder eqA (relation_disjunction R eqA).
Proof.
intros. intros x y. compute. intuition.
elim (StrictOrder_Irreflexive x).
transitivity y; auto.
Qed.

Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) =>
  class_apply StrictOrder_PartialOrder : typeclass_instances.


(*
Copyright © 2009 Valentin Blot

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype.
Require Import finfun paths perm.

Require Import CPoly_Degree Setoid Morphisms Ring CRingClass CPoly_Euclid.
Require Import bigopsClass matrixClass.

Set Implicit Arguments.
Unset Strict Implicit.

Opaque csg_op.
Opaque cm_unit.
Opaque cr_mult.
Opaque polyconst.
Opaque cr_one.
Opaque cpoly_apply_fun.
Opaque cg_inv.

Section Cayley_Hamilton.

Variable CR : CRing.
Add Ring cr_r : (RingClass.r_rt (Ring:=CRing_is_Ring CR)).
Add Ring cpoly_r : (RingClass.r_rt (Ring:=CRing_is_Ring (cpoly_cring CR))).

Section degree_le.

Global Instance degree_le_morph : Morphisms.Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (@degree_le CR).
Proof. by move=> p q -> x y eqxy; split;[|symmetry in eqxy]; apply degree_le_wd. Qed.

Lemma bigsum_degree_le : forall n (I : finType) (F : I -> cpoly_cring CR),
  (forall i : I, degree_le n (F i)) -> degree_le n (\big[csg_op/Zero]_i (F i)).
Proof.
move=> n I F H.
have Hz : degree_le n (Zero : cpoly_cring CR) by move=> m Hlt; reflexivity.
have Hplus : forall p q : cpoly_cring CR, degree_le n p -> degree_le n q -> degree_le n (p[+]q).
  by move=> p q; apply degree_le_plus.
by apply (big_prop Hz Hplus _ (P:=predT)).
Qed.

Lemma bigprod_degree_le : forall (I : finType) (P : pred I) (F : I -> cpoly_cring CR) (deg : I -> nat),
  (forall i : I, P i -> degree_le (deg i) (F i)) -> degree_le (\big[addn/0]_(i|P i) (deg i)) (\big[cr_mult/One]_(i|P i) (F i)).
Proof.
move=> I P F deg Hdeg.
generalize (index_enum I).
elim=>[|i r Hrec].
  case; [case/lt_irrefl|reflexivity].
simpl; have{Hdeg}:=Hdeg i.
case: (P i)=> Hi; last by apply Hrec.
by apply degree_le_mult; [apply Hi|apply Hrec].
Qed.

Global Instance nth_coeff_morph : Morphisms.Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (@nth_coeff CR).
Proof. by move=> p q -> x y eqxy; apply nth_coeff_wd. Qed.

Lemma nth_coeff_bigsum : forall n (I : finType) (F : I -> cpoly_cring CR),
  nth_coeff n (\big[csg_op/Zero]_i (F i)) [=] \big[csg_op/Zero]_i (nth_coeff n (F i)).
Proof.
move=> n I F.
have Hz : nth_coeff n Zero [=] (Zero : CR) by reflexivity.
have Hplus : forall p q : cpoly_cring CR, nth_coeff n (p[+]q) [=] nth_coeff n p [+] nth_coeff n q.
  by move=> p q; apply nth_coeff_plus.
by apply (big_morph Hplus Hz _ predT).
Qed.

Global Instance monic_morphism : Morphisms.Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (@monic CR).
Proof. by move=> p q -> x y eqxy; split; [|symmetry in eqxy]; apply monic_wd. Qed.

Lemma monic_bigsum : forall n (I : finType) (F : I -> cpoly_cring CR) (i : I),
  monic n.+1 (F i) -> (forall j : I, j != i -> degree_le n (F j)) ->
    monic n.+1 (\big[csg_op/Zero]_i F i).
Proof.
move=> n I F i Hmon Hdeg.
split; last first.
  apply bigsum_degree_le=> j.
  case_eq (i==j).
    by move/eqP=> <-; apply Hmon.
  rewrite eq_sym.
  move/negbT=> Heq.
  apply (degree_le_mon _ _ n); first by apply le_S; apply le_n.
  by apply (Hdeg j).
rewrite nth_coeff_bigsum.
setoid_rewrite (bigD1 (P:=predT) (j:=i) (fun i0 => nth_coeff n.+1 (F i0))); last by done.
transitivity ((One : CR)[+]Zero); last by ring.
apply csbf_wd; first by apply Hmon.
apply big1=> j'.
case/andP=> Pj' neqj'.
by apply Hdeg.
Qed.

Lemma monic_bigprod : forall (I : finType) (F : I -> cpoly_cring CR) (deg : I -> nat),
  (forall i : I, monic (deg i) (F i)) -> monic (\big[addn/0]_i deg i) (\big[cr_mult/One]_i F i).
Proof.
move=> I F deg Hdeg.
elim:(index_enum I)=>[|i r Hrec].
  by apply monic_c_one.
simpl.
by apply monic_mult.
Qed.

Global Instance cpoly_apply_morph : Morphisms.Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (cpoly_apply CR).
Proof. by move=> a b eqab x y eqxy; apply cpoly_apply_wd. Qed.

Lemma apply_bigsum : forall (I : finType) (F : I -> cpoly_cring CR) (x : CR),
    (\big[csg_op/Zero]_i F i) ! x [=] \big[csg_op/Zero]_i (F i) ! x.
Proof.
move=> I F x.
elim:(index_enum I)=>[|j r Hrec] /=.
  by apply poly_eq_zero; reflexivity.
rewrite (plus_apply _ (F j)).
by rewrite Hrec; reflexivity.
Qed.

Lemma apply_big_prod : forall (I : finType) (F : I -> cpoly_cring CR) (x : CR),
    (\big[cr_mult/One]_i F i) ! x [=] \big[cr_mult/One]_i (F i) ! x.
Proof.
move=> I F x.
elim:(index_enum I)=>[|j r Hrec] /=.
  by apply one_apply.
rewrite (mult_apply _ (F j)).
by rewrite Hrec; reflexivity.
Qed.

End degree_le.

Open Scope matrix_scope.

Section char_poly.

Variable n : nat.
Local Notation "R [ 'X' ]" := (cpoly_cring R)
  (at level 0, format "R [ 'X' ]").
Local Notation "'M' ( R )" := (matrix R n n)
  (at level 0, format "'M' ( R )").

Variable A : M(CR).
Definition matrixC : M(CR[X]) := \matrix_(i,j < n) _C_ (A i j).
Definition char_poly : CR[X] := \det (_X_%:M -m matrixC).

Lemma char_poly_monic : monic n char_poly.
Proof.
rewrite /char_poly /determinant /matrixC.
move: n A.
clear n A.
case=>[|n]=>A.
  have -> : index_enum (perm_for_finType (ordinal_finType 0)) = [::perm_one (ordinal_finType 0)]; last first.
    rewrite /= odd_perm1 /=.
    apply (monic_wd _ One); last by apply monic_c_one.
    rewrite /index_enum -enumT.
    have <- : [::] = enum (ordinal_finType 0); last first.
      by change ((One : CR[X])[=]One[*]One[+]Zero); ring.
    rewrite <- enum0.
    by apply eq_enum; case.
  rewrite /index_enum -enumT.
  have := (enum1 (perm_one (ordinal_finType 0)))=> /= <-.
  apply (@eq_enum _ 'S_0)=> s /=.
  symmetry.
  apply/eqP.
  apply/permP=> x.
  by case:x.
apply (monic_bigsum (i:=perm_one (ordinal_finType n.+1)) (F:=fun s => _)).
  rewrite odd_perm1 /=.
  change (n.+1) with (0 + n.+1).
  apply monic_mult; first by apply monic_c_one.
  have : n.+1 = \big[addn/0]_(i<n.+1) 1.
    symmetry.
    setoid_rewrite big_const_ord.
    clear A; revert n.
    elim; first by done.
    by move=> n /= ->.
  move => Heq.
  rewrite -> Heq at 1.
  apply monic_bigprod=> i.
  rewrite /scalar_mx /addmx /oppmx perm1 eq_refl.
  split; first by rewrite -> nth_coeff_plus; reflexivity.
  apply degree_le_plus; first by apply degree_le_x_.
  change (degree_le 1 [--](_C_(A i i))).
  apply degree_le_inv.
  apply (degree_le_mon _ _ 0); first by apply le_S; apply le_n.
  by apply degree_le_c_.
move=> s neq.
change n with (0 + n).
apply degree_le_mult.
  change (One : CR[X]) with (_C_ (One : CR)).
  case: (odd_perm s)=> /=; last by apply degree_le_c_.
    change (degree_le 0 ([--](_C_ One)[*](_C_ (One : CR)))).
    change 0 with (0 + 0).
    by apply degree_le_mult; [apply degree_le_inv|]; apply degree_le_c_.
have: existsb i : ordinal_finType n.+1, s i != i.
  apply/forallP=> Heq.
  case: (negP neq)=> {neq}.
  apply/eqP.
  apply/permP=> x.
  rewrite perm1.
  apply/eqP.
  by apply Heq.
case/existsP=> j Hj.
setoid_rewrite (bigD1 (j:=j)); last by done.
change n with (0 + n).
apply degree_le_mult=> [|/=].
  rewrite /scalar_mx /addmx /oppmx eq_sym (negbTE Hj).
  setoid_rewrite cm_lft_unit.
  apply degree_le_inv.
  by apply degree_le_c_.
change (0 + n) with n.
have Heq : n = \big[addn/0]_(i|i!=j) 1.
  setoid_rewrite big_const_seq; clear.
  have -> : count (predC (pred1 j)) (index_enum (ordinal_finType n.+1)) = n; last first.
    move=> {j}; revert n.
    by elim; [|move=> n /= <-].
  have := (count_predC (pred1 j) (index_enum (ordinal_finType n.+1))).
  rewrite enumP /index_enum -enumT size_enum_ord /= add1n.
  by move/eqP; rewrite eqSS; move/eqP.
rewrite {1}Heq=> {Heq}.
apply bigprod_degree_le=> i Hneq.
rewrite /scalar_mx /addmx /oppmx.
apply degree_le_plus.
  case: (i == s i); first by apply degree_le_x_.
  apply (degree_le_mon _ _ 0); first by apply le_S; apply le_n.
  by move=> n' _; apply nth_coeff_zero.
change (degree_le 1 ([--](_C_(A i (s i))))).
apply degree_le_inv.
apply (degree_le_mon _ _ 0); first by apply le_S; apply le_n.
by apply degree_le_c_.
Qed.

Lemma char_poly_apply : forall a : CR, char_poly ! a === \det (a%:M -m A).
Proof.
rewrite /char_poly /determinant=> a.
rewrite apply_bigsum.
apply eq_bigr=> s _.
rewrite -> mult_apply.
apply csbf_wd.
  case: (odd_perm s)=> /=; last by apply one_apply.
  rewrite /Equivalence.equiv.
  rewrite (mult_apply CR).
  apply csbf_wd; last by apply one_apply.
  rewrite -> inv_apply.
  rewrite -> one_apply.
  by reflexivity.
rewrite apply_big_prod.
apply eq_bigr=> i _.
rewrite /scalar_mx /addmx /oppmx /matrixC.
rewrite -> plus_apply.
rewrite -> inv_apply.
rewrite ->  c_apply.
apply csbf_wd; last by reflexivity.
case: (i == s i); first by apply x_apply.
by apply poly_eq_zero; reflexivity.
Qed.

Lemma Cayley_Hamilton : forall (a : CR) (X : matrix CR n 1),
  A *m X === a%:M *m X -> (char_poly ! a)%:M *m X === '0m.
Proof.
move=> a X Heq.
rewrite char_poly_apply.
rewrite <- mulmx_adjl.
rewrite <- (mulmx0 (\adj (a%:M -m A))).
rewrite <- mulmxA.
apply mulmx_morph; first by reflexivity.
rewrite -> mulmx_addl.
Existing Instance addmx_morph.
rewrite <- Heq=> i j {Heq}.
rewrite /addmx /oppmx /mulmx /null_mx.
have Heq : forall k, xpredT k -> [--](A i k)[*]X k j [=] [--](A i k[*]X k j) by move=> k _; ring.
setoid_rewrite (eq_bigr _ Heq)=> {Heq}.
setoid_rewrite <- (big_morph (op1:=csg_op) (idx1:=Zero) (phi:=fun x => [--]x))=> /=[|x y| |]; [by ring|by ring|by ring|].
move=> x x' eqx y y' eqy.
by rewrite eqx eqy; reflexivity.
Qed.

End char_poly.

End Cayley_Hamilton.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Return Preservation

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Dynamic_Semantics.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_WFC_Lemmas.
Require Export Cyclone_WFU_Lemmas.
Require Export Cyclone_Context_Weakening_Proof.
Require Export Cyclone_Substitutions_Proof.
Require Export Cyclone_LN_Types_Lemmas.
Require Export Cyclone_Get_Lemmas.
Require Export Cyclone_Admit_Environment.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma open_term_preserves_ret:
  forall s x,
    ret s ->
    forall n,
      ret (TM.open_rec_st n x s).
Proof.
  introv Rd.
  induction Rd; simpl; auto.
Qed.
Hint Resolve open_term_preserves_ret.

Lemma open_type_preserves_ret:
  forall s x,
    ret s ->
    ret (TTM.open_rec_st 0 x s).
Proof.
  introv Rd.
  induction Rd; simpl; auto.
Qed.
Hint Resolve open_type_preserves_ret.

Ltac inversion_complex_ret :=
 match goal with
  | H : ret (_ _) |- _ => inversions* H
  | H : ret (_ _ _) |- _ => inversions* H
  end.

Lemma A_8_Return_Preservation:
  forall s H H' s',
    ret s ->
    S H s H' s' ->
    ret s'.
Proof.
  introv Rs Sd.
  induction Sd; try solve[auto];
    try solve[inversion_complex_ret ; try inversion_complex_ret];
    try solve[inversion_complex_ret;
              try constructor*].
Qed.


(*******************************************************************

 The comprehension bicategory of opfibrations

 Contents
 1. The comprehension pseudofunctor
 2. Preservation of cartesian 1-cells
 3. Preservation of opcartesian 2-cells
 4. The comprehension bicategory

 *******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.StreetFibration.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.CartesianPseudoFunctor.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispBicatOfDispCats.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.CodomainCleaving.
Require Import UniMath.Bicategories.DisplayedBicats.ExamplesOfCleavings.OpFibrationCleaving.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits.
Require Import UniMath.Bicategories.Limits.Examples.OpCellBicatLimits.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.Logic.ComprehensionBicat.

Local Open Scope cat.

(**
 1. The comprehension pseudofunctor
 *)
Definition opcleaving_comprehension_data
  : disp_psfunctor_data
      disp_bicat_of_opcleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats).
Proof.
  simple refine (_ ,, _ ,, _ ,, _ ,, _).
  - exact (λ C D, total_univalent_category (pr1 D) ,, pr1_category _).
  - intros C₁ C₂ F D₁ D₂ FF.
    use make_disp_1cell_cod.
    + exact (total_functor (pr1 FF)).
    + use nat_z_iso_to_invertible_2cell.
      exact (total_functor_commute_z_iso (pr1 FF)).
  - intros C₁ C₂ F G α D₁ D₂ FF GG αα.
    use make_disp_2cell_cod.
    + exact (total_nat_trans (pr1 αα)).
    + abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ; cbn ;
         rewrite id_left, id_right ;
         apply idpath).
  - intros C D.
    simple refine (_ ,, _).
    + use make_disp_2cell_cod.
      * exact (total_functor_identity (pr11 D)).
      * abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           intros x ;
           cbn ;
           rewrite !id_left ;
           apply idpath).
    + use is_disp_invertible_2cell_cod.
      use is_nat_z_iso_to_is_invertible_2cell.
      intro x.
      apply identity_is_z_iso.
  - intros C₁ C₂ C₃ F G D₁ D₂ D₃ FF GG.
    simple refine (_ ,, _).
    + use make_disp_2cell_cod.
      * exact (total_functor_comp (pr1 FF) (pr1 GG)).
      * abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           intros x ;
           cbn ;
           rewrite !id_left, !id_right ;
           apply functor_id).
    + use is_disp_invertible_2cell_cod.
      use is_nat_z_iso_to_is_invertible_2cell.
      intro x.
      apply identity_is_z_iso.
Defined.

Definition opcleaving_comprehension_is_disp_psfunctor
  : is_disp_psfunctor
      disp_bicat_of_opcleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats)
      opcleaving_comprehension_data.
Proof.
  repeat split ; intro ; intros ;
    (use subtypePath ; [ intro ; apply cellset_property | ]).
  - refine (_ @ !(transportb_cell_of_cod_over _ _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    apply idpath.
  - refine (_ @ !(transportb_cell_of_cod_over _ _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    apply idpath.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_lunitor _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite functor_id, !id_right ;
         apply idpath).
    + rewrite !id_right_disp.
      rewrite disp_functor_id.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over (psfunctor_runitor _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right ;
         apply idpath).
    + rewrite !id_right_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_lassociator _ _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite functor_id, !id_right ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      rewrite disp_functor_id.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_lwhisker _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right, !id_left ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  - refine (_ @ !(transportb_cell_of_cod_over
                    (psfunctor_rwhisker _ _ _) _)).
    apply nat_trans_eq ; [ intro ; apply homset_property | ].
    intro x ; cbn.
    use total2_paths_f ; cbn.
    + abstract
        (rewrite !id_right, !id_left ;
         apply idpath).
    + rewrite !id_right_disp, !id_left_disp.
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
Qed.

Definition opcleaving_comprehension
  : disp_psfunctor
      disp_bicat_of_opcleaving
      (cod_disp_bicat bicat_of_univ_cats)
      (id_psfunctor bicat_of_univ_cats).
Proof.
  simple refine (_ ,, _).
  - exact opcleaving_comprehension_data.
  - exact opcleaving_comprehension_is_disp_psfunctor.
Defined.

(**
 2. Preservation of cartesian 1-cells
 *)
Definition global_cartesian_opcleaving_comprehension
  : global_cartesian_disp_psfunctor opcleaving_comprehension.
Proof.
  use preserves_global_lifts_to_cartesian.
  - exact univalent_cat_is_univalent_2.
  - exact (cod_disp_univalent_2 _ univalent_cat_is_univalent_2).
  - exact opcleaving_global_cleaving.
  - intros C₁ C₂ F D₁.
    use is_pb_to_cartesian_1cell.
    apply reindexing_has_pb_ump.
    apply iso_cleaving_from_opcleaving.
    exact (pr2 D₁).
Defined.

(**
 3. Preservation of opcartesian 2-cells
 *)
Section LocalOpCartesianOpFibration.
  Context {C₁ C₂ : bicat_of_univ_cats}
          {F₁ F₂ : C₁ --> C₂}
          (α : F₁ ==> F₂)
          {D₁ : disp_bicat_of_opcleaving C₁}
          {D₂ : disp_bicat_of_opcleaving C₂}
          {FF₁ : D₁ -->[ F₁ ] D₂}
          {FF₂ : D₁ -->[ F₂ ] D₂}
          (αα : disp_2cells α FF₁ FF₂)
          (Hαα : ∏ (x : C₁ : univalent_category)
                   (xx : (pr1 D₁ : disp_univalent_category _) x),
                 is_opcartesian ((pr11 αα) x xx))
          (G : bicat_of_univ_cats
                 ⟦ total_univalent_category (pr1 D₁)
                   ,
                   total_univalent_category (pr1 D₂) ⟧)
          (tot_FF₁ := (total_functor (pr1 FF₁)
                       : bicat_of_univ_cats
                           ⟦ total_univalent_category (pr1 D₁)
                             ,
                             total_univalent_category (pr1 D₂) ⟧))
          (tot_FF₂ := (total_functor (pr1 FF₂)
                       : bicat_of_univ_cats
                           ⟦ total_univalent_category (pr1 D₁)
                             ,
                             total_univalent_category (pr1 D₂) ⟧))
          (tot_αα := total_nat_trans (pr1 αα) : tot_FF₁ ==> tot_FF₂)
          (γ : tot_FF₁ ==> G)
          (δp : tot_FF₂ · pr1_category _ ==> G · pr1_category _)
          (q : post_whisker γ (pr1_category (pr11 D₂))
               =
               nat_trans_comp
                 _ _ _
                 (post_whisker (total_nat_trans (pr1 αα)) (pr1_category _))
                 δp).

  Definition local_opcartesian_opcleaving_lift_data
    : nat_trans_data (pr1 tot_FF₂) (pr1 G).
  Proof.
    refine (λ x, pr1 δp x ,, _) ; cbn.
    refine (opcartesian_factorisation (Hαα (pr1 x) (pr2 x)) _ _).
    exact (transportf
             (λ z, _ -->[ z ] _)
             (nat_trans_eq_pointwise q x)
             (pr2 (pr1 γ x))).
  Defined.

  Definition local_opcartesian_opcleaving_lift_is_nat_trans
    : is_nat_trans _ _ local_opcartesian_opcleaving_lift_data.
  Proof.
    intros x y f ; cbn.
    use total2_paths_f.
    - exact (nat_trans_ax δp x y f).
    - use (opcartesian_factorisation_unique (Hαα (pr1 x) (pr2 x))).
      cbn.
      rewrite assoc_disp.
      rewrite mor_disp_transportf_prewhisker.
      rewrite assoc_disp.
      unfold transportb.
      rewrite transport_f_f.
      rewrite opcartesian_factorisation_commutes.
      rewrite mor_disp_transportf_postwhisker.
      rewrite transport_f_f.
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        refine (!_).
        exact (transportf_transpose_left (disp_nat_trans_ax (pr1 αα) (pr2 f))).
      }
      rewrite mor_disp_transportf_postwhisker.
      rewrite transport_f_f.
      rewrite assoc_disp_var.
      rewrite opcartesian_factorisation_commutes.
      rewrite mor_disp_transportf_prewhisker.
      rewrite !transport_f_f.
      etrans.
      {
        apply maponpaths.
        exact (transportb_transpose_right (fiber_paths (nat_trans_ax γ _ _ f))).
      }
      unfold transportb.
      rewrite transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  Qed.

  Definition local_opcartesian_opcleaving_lift
    : tot_FF₂ ==> G.
  Proof.
    use make_nat_trans.
    - exact local_opcartesian_opcleaving_lift_data.
    - exact local_opcartesian_opcleaving_lift_is_nat_trans.
  Defined.

  Definition local_opcartesian_opcleaving_lift_over
    : local_opcartesian_opcleaving_lift ▹ _ = δp.
  Proof.
    use nat_trans_eq ; [ apply homset_property | ].
    intro x.
    apply idpath.
  Qed.

  Definition local_opcartesian_opcleaving_lift_comm
    : tot_αα • local_opcartesian_opcleaving_lift
      =
      γ.
  Proof.
    use nat_trans_eq ; [ apply homset_property | ].
    intro x.
    cbn.
    use total2_paths_f.
    - exact (!(nat_trans_eq_pointwise q x)).
    - cbn.
      rewrite opcartesian_factorisation_commutes.
      rewrite transport_f_f.
      apply transportf_set.
      apply homset_property.
  Qed.

  Definition local_opcartesian_opcleaving_lift_unique
    : isaprop
        (∑ δ,
         δ ▹ _ = δp
         ×
         tot_αα • δ = γ).
  Proof.
    use invproofirrelevance.
    intros φ₁ φ₂.
    use subtypePath.
    {
      intro.
      apply isapropdirprod ; apply cellset_property.
    }
    use nat_trans_eq.
    {
      apply homset_property.
    }
    intro x.
    use total2_paths_f.
    - exact (nat_trans_eq_pointwise (pr12 φ₁) x
             @ !(nat_trans_eq_pointwise (pr12 φ₂) x)).
    - use (opcartesian_factorisation_unique (Hαα (pr1 x) (pr2 x))).
      rewrite mor_disp_transportf_prewhisker.
      etrans.
      {
        apply maponpaths.
        exact (transportb_transpose_right
                 (fiber_paths (nat_trans_eq_pointwise (pr22 φ₁) x))).
      }
      refine (!_).
      etrans.
      {
        exact (transportb_transpose_right
                 (fiber_paths (nat_trans_eq_pointwise (pr22 φ₂) x))).
      }
      unfold transportb.
      rewrite !transport_f_f.
      apply maponpaths_2.
      apply homset_property.
  Qed.
End LocalOpCartesianOpFibration.

Definition local_opcartesian_opcleaving_comprehension
  : local_opcartesian_disp_psfunctor opcleaving_comprehension.
Proof.
  intros C₁ C₂ F₁ F₂ α D₁ D₂ FF₁ FF₂ αα Hαα.
  apply is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell ; cbn.
  pose (opcleaving_of_opcleaving_opcartesian_2cell_is_pointwise_opcartesian _ Hαα) as p.
  intros G γ δp q.
  use iscontraprop1.
  - exact (local_opcartesian_opcleaving_lift_unique α αα p G γ δp).
  - simple refine (_ ,, _ ,, _).
    + exact (local_opcartesian_opcleaving_lift α αα p G γ δp q).
    + exact (local_opcartesian_opcleaving_lift_over α αα p G γ δp q).
    + exact (local_opcartesian_opcleaving_lift_comm α αα p G γ δp q).
Defined.

(**
 4. The comprehension bicategory
 *)
Definition opcleaving_comprehension_bicat_structure
  : comprehension_bicat_structure bicat_of_univ_cats.
Proof.
  use make_comprehension_bicat_structure.
  - exact disp_bicat_of_opcleaving.
  - exact opcleaving_comprehension.
  - exact opcleaving_global_cleaving.
  - exact global_cartesian_opcleaving_comprehension.
Defined.

Definition opcleaving_comprehension_is_covariant
  : is_covariant opcleaving_comprehension_bicat_structure.
Proof.
  repeat split.
  - exact cleaving_of_opcleaving_local_opcleaving.
  - exact cleaving_of_opcleaving_lwhisker_opcartesian.
  - exact cleaving_of_opcleaving_rwhisker_opcartesian.
  - exact local_opcartesian_opcleaving_comprehension.
Defined.

Definition opcleaving_comprehension_bicat
  : comprehension_bicat
  := _ ,, _ ,, opcleaving_comprehension_is_covariant.


(** * Simulation up to taus *)

(** A preorder [sutt t1 t2], where every visible step
  ([RetF] or [VisF]) on the left must be matched with a corresponding
  step on the right, ignoring [TauF].

  In particular, [spin := Tau spin] is less than everything.

  The induced equivalence relation is [eutt].
[[
  Theorem sutt_eutt : sutt eq t u -> sutt eq u t -> eutt eq t u.
]]
  Various lemmas about [eutt] may be more easily proved as
  [Proper] lemmas about [sutt] first, and then symmetrizing using
  [eutt_sutt] and [sutt_eutt].
 *)

Require Import Paco.paco.

From Coq Require Import
     Classes.RelationClasses
     Classes.Morphisms
     Setoids.Setoid
     Program
     Relations.Relations.

From ITree Require Import
     Core.ITreeDefinition
     Eq.Eq
     Eq.UpToTaus
     Eq.Shallow
     Eq.Paco2.

Section SUTT.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Inductive suttF (sutt: itree' E R1 -> itree' E R2 -> Prop) :
  itree' E R1 -> itree' E R2 -> Prop :=
| suttF_ret r1 r2 : RR r1 r2 -> suttF sutt (RetF r1) (RetF r2)
| suttF_vis u (e : E u) k1 k2
      (SUTTK: forall x, sutt (observe (k1 x)) (observe (k2 x))):
    suttF sutt (VisF e k1) (VisF e k2)
| suttF_tau_right ot1 t2
      (EQTAUS: suttF sutt ot1 (observe t2)):
    suttF sutt ot1 (TauF t2)
| suttF_tau_left t1 ot2
      (EQTAUS: sutt (observe t1) ot2):
    suttF sutt (TauF t1) ot2
.
Hint Constructors suttF: core.

Definition sutt (t1 : itree E R1) (t2 : itree E R2) :=
  paco2 suttF bot2 (observe t1) (observe t2).
Hint Unfold sutt: core.

End SUTT.

Global Hint Constructors suttF: core.
Global Hint Unfold sutt: core.

Section SUTT_rel.

Context {E : Type -> Type} {R : Type} (RR : R -> R -> Prop).

Lemma reflexive_suttF `{Reflexive _ RR} sutt (r1:Reflexive sutt) : Reflexive (@suttF E _ _ RR sutt).
Proof.
  unfold Reflexive. intros x.
  destruct x; eauto.
Qed.

End SUTT_rel.

Section SUTT_facts.

Context {E : Type -> Type} {R1 R2 : Type} (RR : R1 -> R2 -> Prop).

Lemma monotone_suttF : monotone2 (@suttF E _ _ RR).
Proof. repeat red; intros. induction IN; eauto. Qed.
Hint Resolve monotone_suttF : paco.

End SUTT_facts.

Global Hint Resolve monotone_suttF : paco.

Lemma suttF_inv_vis {E R1 R2} (RR : R1 -> R2 -> Prop) sutt :
  forall X e (k1 : X -> itree E R1) (k2 : X -> itree E R2),
    suttF RR sutt (VisF e k1) (VisF e k2) ->
    forall x, sutt (observe (k1 x)) (observe (k2 x)).
Proof.
  intros. inv H. apply inj_pair2 in H3; apply inj_pair2 in H5. subst. auto.
Qed.

Lemma sutt_inv_vis {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall X e (k1 : X -> itree E R1) (k2 : X -> itree E R2),
  sutt RR (Vis e k1) (Vis e k2) ->
  forall x, sutt RR (k1 x) (k2 x).
Proof.
  intros. pstep. punfold H. simpl in *.
  eapply suttF_inv_vis in H; pclearbot; punfold H.
Qed.

Lemma sutt_tau_right {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 ->
    sutt RR t1 (Tau t2).
Proof.
  intros. punfold H. pstep.
  repeat red. repeat red in H. constructor.
  auto.
Qed.

Lemma sutt_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 ->
    sutt RR (Tau t1) t2.
Proof.
  intros. punfold H. pstep.
  repeat red. repeat red in H. constructor.
  eauto with paco.
Qed.

Lemma sutt_elim_tau_right {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) (t2: itree E R2),
    sutt RR t1 (Tau t2) ->
    sutt RR t1 t2.
Proof.
  pcofix CIH. pstep. intros.
  punfold H0. repeat red in H0.
  inv H0.
  - eapply monotone_suttF; eauto using upaco2_mon_bot with paco.
  - constructor. pclearbot. eauto with paco.
Qed.

Lemma suttF_inv_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) ot2,
    suttF RR (upaco2 (suttF RR) bot2) (TauF t1) ot2 ->
    suttF RR (upaco2 (suttF RR) bot2) (observe t1) ot2.
Proof.
  intros.
  remember (TauF t1) as ott1.
  induction H; intros; subst; try dependent destruction Heqott1; eauto.
  pclearbot. punfold EQTAUS.
Qed.

Lemma sutt_inv_tau_left {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1: itree E R1) (t2: itree E R2),
    sutt RR (Tau t1) t2 ->
    sutt RR t1 t2.
Proof.
  intros.
  punfold H. pstep. repeat red in H |- *.
  apply suttF_inv_tau_left; auto.
Qed.

Theorem sutt_eutt {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    sutt RR t1 t2 -> sutt (flip RR) t2 t1 -> eutt RR t1 t2.
Proof.
  pcofix CIH. intros.
  punfold H0. punfold H. pstep. red.
  induction H0; intros; subst; auto.
  - constructor. intro. right. eapply suttF_inv_vis in H. pclearbot. eauto with paco.
  - constructor; eauto. eapply IHsuttF; auto. eapply suttF_inv_tau_left; auto.
  - (* doing induction when one of the trees is a tau doesn't work well *)
    inv H; pclearbot.
    + clear t1 t2. genobs t0 ot0.
      hinduction EQTAUS0 before CIH; intros; subst; pclearbot.
      * constructor; eauto. simpobs. constructor. eauto.
      * constructor; eauto. simpobs. constructor. intros.
        right. apply CIH; auto. eapply sutt_inv_vis in EQTAUS; eauto.
      * constructor; eauto. simpobs. eapply IHEQTAUS0; eauto.
        rewrite (itree_eta' ot1). apply sutt_inv_tau_left; auto.
      * constructor. right. apply CIH; auto. apply sutt_elim_tau_right; auto.
    + constructor. right. apply CIH; apply sutt_elim_tau_right; auto.
Qed.

Theorem eutt_sutt {E R1 R2} (RR : R1 -> R2 -> Prop) :
  forall (t1 : itree E R1) (t2 : itree E R2),
    eutt RR t1 t2 -> sutt RR t1 t2.
Proof.
  pcofix CIH. pstep. intros.
  punfold H0. red in H0.
  induction H0; constructor; pclearbot; eauto 7 with paco.
Qed.

(** Generalized heterogeneous version of [eutt_bind] *)
Lemma sutt_bind' {E R1 R2 S1 S2} {RR: R1 -> R2 -> Prop} {SS: S1 -> S2 -> Prop}:
  forall t1 t2,
    sutt RR t1 t2 ->
    forall s1 s2, (forall r1 r2, RR r1 r2 -> sutt SS (s1 r1) (s2 r2)) ->
                  @sutt E _ _ SS (ITree.bind t1 s1) (ITree.bind t2 s2).
Proof.
  pcofix self. pstep. intros.
  punfold H0. unfold observe; cbn.
  induction H0; intros.
  - simpl. apply H1 in H. punfold H. eapply monotone_suttF; eauto using upaco2_mon_bot.
  - simpl. pclearbot. econstructor. eauto.
  - constructor. eauto with paco.
  - constructor. pclearbot.
    right. specialize (self t0 (go ot2) EQTAUS _ _ H1).
    apply self.
Qed.

Require Import Coq.Relations.Relations.

(* todo: this could be made stronger with eutt rather than eq_itree
 *)
#[global]
 Instance Proper_sutt {E : Type -> Type} {R1 R2 : Type} r
: Proper (eq_itree eq ==> eq_itree eq ==> flip impl)
       (@sutt E R1 R2 r).
Proof.
  repeat red. pcofix CIH; pstep. intros.
  punfold H0; punfold H1; punfold H2. red in H0, H1.
  (* rename H1 into H2, Hxy into H1.  *)
  hinduction H2 before CIH; subst; intros.
  - inv H0; try discriminate. inv H1; try discriminate. econstructor. eauto.
  - dependent destruction H0; try discriminate.
    dependent destruction H1; try discriminate.
    simpobs. pclearbot.
    constructor. intros. right. eauto 7 with paco.
  - dependent destruction H1; try discriminate.
    simpobs. pclearbot. punfold REL.
  - dependent destruction H0; try discriminate.
    simpobs. pclearbot. constructor.
    right. rewrite (itree_eta' ot2) in *. eauto.
Qed.