From Paco Require Import paco.
From ITree Require Import ITree.
From Ordinal Require Import Ordinal Arithmetic.

Require Import IndefiniteDescription.
Require Import ZArith Streams List Lia.

Require Import sflib.
Require Import StdlibExt.
Require Import SysSem.
Require Import MSteps.

Require Import GMSim.

Set Nested Proofs Allowed.

(* fixed-length multistep simulation *)

(* Definition tes_equiv {sysE: Type -> Type} *)
(*            (ftr1 ftr2: list (nat * events sysE)): Prop := *)
(*   flatten_tes ftr1 = flatten_tes ftr2. *)

Section SIM.
  Variable sysE: Type -> Type.
  Variable sys_src sys_tgt: @DSys.t sysE.

  Inductive _fmsim_states
            (sim: sys_src.(DSys.state) ->
                  sys_tgt.(DSys.state) -> Prop)
            (st_src: sys_src.(DSys.state))
            (st_tgt: sys_tgt.(DSys.state)): Prop :=
    FMSimStates
      (n_tgt: nat)
      (N_TGT_POS: 0 < n_tgt)
      (STEPS_SIM:
         forall tr_tgt st_tgt'
           (STEPS: msteps sys_tgt n_tgt st_tgt tr_tgt st_tgt')
         ,
         exists n_src tr_src st_src',
           <<N_SRC_POS: 0 < n_src>> /\
           <<STEPS_SRC: msteps sys_src n_src st_src tr_src st_src'>> /\
           <<TRACE_EQUIV: Forall2 tes_equiv tr_src tr_tgt>> /\
           <<SIM_NXT: sim st_src' st_tgt'>>)
  .

  Hint Constructors _fmsim_states: paco.

  Lemma fmsim_states_monotone: monotone2 _fmsim_states.
  Proof.
    ii. inv IN. econs; eauto.
    i. hexploit STEPS_SIM; eauto. i. des.
    esplits; eauto.
  Qed.

  Hint Resolve fmsim_states_monotone: paco.

  Definition fmsim_states
    : sys_src.(DSys.state) -> sys_tgt.(DSys.state) -> Prop :=
    paco2 _fmsim_states bot2.

  Inductive fmsim: Prop :=
    FMSim
      (* (TGT_INIT_OK: exists st_tgt_i1, sys_tgt.(DSys.initial_state) st_tgt_i1) *)
      (SIM_INIT_STATES:
         forall st_tgt_i
           (INIT_TGT: sys_tgt.(DSys.initial_state) st_tgt_i),
         exists st_src_i,
           <<INIT_SRC: sys_src.(DSys.initial_state) st_src_i>> /\
           <<SIM_STATES: fmsim_states st_src_i st_tgt_i>>)
  .

  Lemma fmsim_gmsim_states_aux
        (r: _ -> _ -> _ -> _ -> Prop)
        (CIH : forall (st_src : DSys.state sys_src) (st_tgt : DSys.state sys_tgt),
            DSys.safe_state st_tgt -> fmsim_states st_src st_tgt ->
            r Ord.omega None st_src st_tgt)
        n_tgt2'
    : forall st_src st_tgt
        n_tgt1
        tr_tgt1 st_tgt1
        (SAFE1: DSys.safe_state st_tgt1)
        (MSTEPS1: msteps sys_tgt n_tgt1 st_tgt tr_tgt1 st_tgt1)
        (STEPS_SIM: forall tr_tgt2 st_tgt' tr_tgt
                      (MSTEPS2: msteps sys_tgt (S n_tgt2') st_tgt1 tr_tgt2 st_tgt')
                      (TR_TGT: app_each_rel tr_tgt1 tr_tgt2 tr_tgt)
          ,
            exists n_src tr_src st_src',
              0 < n_src /\
              msteps sys_src n_src st_src tr_src st_src' /\
              Forall2 tes_equiv tr_src tr_tgt /\
              paco2 _fmsim_states bot2 st_src' st_tgt')
    ,
      paco4 (_gmsim_states sys_src sys_tgt) r (S n_tgt2') (Some tr_tgt1)
             st_src st_tgt1.
  Proof.
    induction n_tgt2' as [| n_tgt2'' IH]; i; ss.
    { pfold.
      punfold SAFE1. inv SAFE1.
      econs.
      { eauto. }

      i. right.

      hexploit STEPS_SIM; eauto.
      { econs 2; eauto.
        { econs 1; eauto. }
        apply cons_each_to_nils.
        apply DSys.step_prsv_num_sites in STEP_TGT. des.
        apply Forall3_length in APP_EVENTS. des.

        apply DSys_filter_nb_sysstep_inv in FILTER_NB.
        apply Forall2_length in FILTER_NB.
        nia.
      }
      { instantiate (1:= tr_accum').
        apply snoc_each_tolist2 in APP_EVENTS. ss.
      }

      i. des.
      esplits; eauto.
      right. apply CIH; eauto.
      hexploit SAFE_NXT; eauto.
      { congruence. }
      i. pclearbot. ss.
    }

    punfold SAFE1. inv SAFE1.
    pfold. econs; eauto.
    i. left.
    exists (S n_tgt2'').
    esplits.
    { apply OrdArith.lt_from_nat. nia. }
    left.

    assert (MSTEPS_CC: msteps _ (n_tgt1 + 1) st_tgt tr_accum' st_tgt').
    { hexploit msteps_concat.
      { eauto. }
      { econs 2; eauto.
        { econs 1; eauto. }
        apply cons_each_impl_rel.
        rewrite repeat_length.

        apply DSys_filter_nb_sysstep_inv in FILTER_NB.
        apply Forall2_length in FILTER_NB.
        apply Forall3_length in APP_EVENTS.
        apply DSys.step_prsv_num_sites in STEP_TGT. des.
        nia.
      }
      i. des.

      rewrite cons_each_nil_eq_tolist_each in ES_CONCAT.
      2: {
        apply DSys_filter_nb_sysstep_inv in FILTER_NB.
        apply Forall2_length in FILTER_NB.
        apply Forall3_length in APP_EVENTS.
        apply DSys.step_prsv_num_sites in STEP_TGT. des.
        nia.
      }

      replace tr_accum' with es.
      { eauto. }

      eapply app_each_rel_det; eauto.
      apply snoc_each_tolist2 in APP_EVENTS.
      ss.
    }

    eapply IH.
    { hexploit SAFE_NXT; eauto.
      { congruence. }
      i. pclearbot. ss.
    }
    { eauto. }

    i.
    hexploit STEPS_SIM.
    { econs 2; try apply MSTEPS2; eauto.
      eapply cons_each_impl_rel.
      apply Forall3_length in APP_EVENTS.
      apply Forall3_length in TR_TGT.
      des; ss. nia. }
    { instantiate (1:= tr_tgt0).
      apply Forall3_nth'.

      hexploit Forall3_length; try apply TR_TGT.
      hexploit Forall3_length; try apply APP_EVENTS.
      i. des.

      hexploit (cons_each_impl_rel _ tr_tgt tr_tgt2).
      { nia. }
      intro CONS_EACH.
      hexploit Forall3_length; try apply CONS_EACH.
      i. des.

      splits.
      { nia. }
      { nia. }

      i.
      eapply Forall3_nth1 in APP_EVENTS; eauto. i. des.
      subst.
      renames e2 NTH2 NTH3 into tr_tgt_n TR_TGT_N TR_ACC_N.
      eapply Forall3_nth3 in CONS_EACH; eauto. i. des.
      clarify.
      renames e2 NTH1 NTH2 into tr_tgt2_n TR_TGT_N TR_TGT2_N.
      eapply Forall3_nth3 in TR_TGT; eauto. i. des.
      clarify.
      rewrite <- app_assoc. ss.
    }

    i. des.
    esplits; eauto.
  Qed.

  Lemma fmsim_states_impl_gmsim_states
    : forall st_src st_tgt
        (SAFE: DSys.safe_state st_tgt)
        (FMSIM: fmsim_states st_src st_tgt),
      gmsim_states _ _ Ord.omega None st_src st_tgt.
  Proof.
    pcofix CIH. i.
    punfold FMSIM.
    inv FMSIM.

    pfold. econs.
    { r in SAFE. punfold SAFE.
      inv SAFE.
      eauto. }

    i.
    destruct n_tgt as [| [ |n_tgt]].
    { nia. }
    { right.
      hexploit STEPS_SIM; eauto.
      { econs 2; eauto.
        { econs 1; eauto. }
        apply cons_each_to_nils.
        apply DSys_filter_nb_sysstep_inv in FILTER_NB.
        apply Forall2_length in FILTER_NB.
        apply DSys.step_prsv_num_sites in STEP_TGT. des.
        nia.
      }
      i. des.
      esplits; eauto.
      { subst tr_accum'.
        eauto. }
      right.
      apply CIH.
      - punfold SAFE.
        inv SAFE.
        hexploit SAFE_NXT; eauto.
        { congruence. }
        i. pclearbot. ss.
      - pclearbot. ss.
    }

    left. exists (S n_tgt).
    esplits.
    { apply Ord.omega_upperbound. }

    left.
    punfold SAFE. inv SAFE.
    hexploit SAFE_NXT; eauto.
    { congruence. }
    i. pclearbot.

    eapply fmsim_gmsim_states_aux; eauto.
    { econs 2; eauto.
      { econs 1; eauto. }
      apply cons_each_to_nils.

      apply DSys.step_prsv_num_sites in STEP_TGT. des.
      apply DSys_filter_nb_sysstep_inv in FILTER_NB.
      apply Forall2_length in FILTER_NB. nia.
    }

    i.
    hexploit msteps_concat.
    2: { eauto. }
    { econs 2; eauto.
      { econs 1; eauto. }
      apply cons_each_to_nils.
      apply DSys.step_prsv_num_sites in STEP_TGT. des.
      apply DSys_filter_nb_sysstep_inv in FILTER_NB.
      apply Forall2_length in FILTER_NB. nia.
    }

    replace (1 + S n_tgt) with (S (S n_tgt)) by nia. i. des.

    hexploit STEPS_SIM; eauto.
    i. des.
    esplits; eauto.
    - fold (tolist_each tr_tgt) in TR_TGT.
      apply cons_each_hd_tolist in TR_TGT.
      apply cons_each_hd_tolist in ES_CONCAT.
      apply cons_each_rel_det in TR_TGT.
      apply cons_each_rel_det in ES_CONCAT.
      clarify.
    - r in SIM_NXT. inv SIM_NXT; ss.
  Qed.

  Lemma fmsim_impl_gmsim
        (SAFE_SYS: DSys.safe sys_tgt)
        (FMSIM: fmsim)
    : gmsim sys_src sys_tgt.
  Proof.
    inv FMSIM.
    econs.
    { inv SAFE_SYS. eauto. }
    i.
    hexploit SIM_INIT_STATES; eauto. i. des.
    esplits; eauto.
    apply fmsim_states_impl_gmsim_states; eauto.
    inv SAFE_SYS. eauto.
  Qed.

  Lemma fmsim_num_sites_eq
        st_src st_tgt exec_tgt
        (SAFE: DSys.safe_state st_tgt)
        (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt)
        (FMSIM: fmsim_states st_src st_tgt)
    : DSys.num_sites _ st_src = DSys.num_sites _ st_tgt.
  Proof.
    punfold FMSIM. inv FMSIM.
    hexploit safe_exec_impl_msteps; eauto. i. des.
    hexploit msteps_num_sites_eq; eauto. i. des.

    hexploit STEPS_SIM; eauto. i. des.
    hexploit msteps_num_sites_eq; eauto. i. des.
    apply Forall2_length in TRACE_EQUIV; eauto. nia.
  Qed.

  (* Record _fmsim_auxdata : Type := *)
  (*   FMSimAuxdata { *)
  (*       aux_tr_h_src : list (tsp * events sysE) ; *)
  (*       aux_tr_t_src : list (list (tsp * events sysE)) ; *)
  (*       aux_st_src_nxt : DSys.state sys_src ; *)

  (*       aux_tr_h_tgt : list (tsp * events sysE) ; *)
  (*       aux_tr_t_tgt : list (list (tsp * events sysE)) ; *)
  (*       aux_st_tgt_nxt : DSys.state sys_tgt ; *)
  (*       aux_exec_tgt_nxt: @exec_t sysE; *)

  (*       AUX_SAFE_NXT: DSys.safe_state aux_st_tgt_nxt ; *)
  (*       AUX_EXEC_TGT_NXT: DSys.exec_state _ aux_st_tgt_nxt aux_exec_tgt_nxt ; *)
  (*       AUX_FMSIM_NXT: fmsim_states aux_st_src_nxt aux_st_tgt_nxt ; *)
  (*     }. *)

  (* Lemma fmsim_states_ex_src *)
  (*       st_src st_tgt exec_tgt *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*   : exists n_src tr_h_src_raw tr_h_src st_src1 *)
  (*       tr_t_src tr_src st_src' *)
  (*       n_tgt tr_h_tgt_raw tr_h_tgt st_tgt1 *)
  (*       tr_t_tgt tr_tgt st_tgt' exec_tgt', *)
  (*     DSys.step _ st_src tr_h_src_raw st_src1 /\ *)
  (*     DSys.filter_nb_sysstep tr_h_src_raw = Some tr_h_src /\ *)
  (*     msteps _ n_src st_src1 tr_t_src st_src' /\ *)

  (*     DSys.step _ st_tgt tr_h_tgt_raw st_tgt1 /\ *)
  (*     DSys.filter_nb_sysstep tr_h_tgt_raw = Some tr_h_tgt /\ *)
  (*     msteps _ n_tgt st_tgt1 tr_t_tgt st_tgt' /\ *)

  (*     cons_each_rel tr_h_src tr_t_src tr_src /\ *)
  (*     cons_each_rel tr_h_tgt tr_t_tgt tr_tgt /\ *)
  (*     Forall2 tes_equiv tr_src tr_tgt /\ *)
  (*     Forall3 (fun a b c => stream_app a b = c) *)
  (*             tr_tgt exec_tgt' exec_tgt /\ *)

  (*     DSys.safe_state st_tgt' /\ *)
  (*     DSys.exec_state _ st_tgt' exec_tgt' /\ *)
  (*     fmsim_states st_src' st_tgt' *)
  (* . *)
  (* Proof. *)
  (*   punfold FMSIM. inv FMSIM. *)
  (*   hexploit safe_exec_impl_msteps; eauto. *)
  (*   instantiate (1:= n_tgt). *)
  (*   i. des. *)
  (*   hexploit STEPS_SIM; eauto. *)
  (*   i. des. *)
  (*   pclearbot. *)

  (*   destruct n_src as [| n_src']; ss. *)
  (*   { exfalso. nia. } *)
  (*   destruct n_tgt as [| n_tgt']; ss. *)
  (*   { exfalso. nia. } *)
  (*   inv MSTEPS. *)
  (*   inv STEPS_SRC. *)

  (*   esplits; eauto. *)

  (*   (* punfold SAFE. inv SAFE. *) *)
  (*   (* hexploit SAFE_NXT; eauto. *) *)
  (*   (* { congruence. } *) *)
  (*   (* i. pclearbot. *) *)

  (*   (* eapply safe_state_mstep; eauto. *) *)
  (* Qed. *)

  (* Definition fmsim_states_constr_src1 *)
  (*       st_src st_tgt exec_tgt *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*   : { aux: _fmsim_auxdata | *)
  (*       exists n_src tr_h_src_raw st_src1 tr_src *)
  (*         n_tgt tr_h_tgt_raw st_tgt1 tr_tgt, *)
  (*     <<AUX_STEP1_SRC: DSys.step _ st_src tr_h_src_raw st_src1>> /\ *)
  (*     <<AUX_FLT1_SRC: DSys.filter_nb_sysstep tr_h_src_raw = Some (aux_tr_h_src aux)>> /\ *)
  (*     <<AUX_STEPS_SRC: msteps _ n_src st_src1 (aux_tr_t_src aux) (aux_st_src_nxt aux)>> /\ *)

  (*     <<AUX_STEP1_TGT: DSys.step _ st_tgt tr_h_tgt_raw st_tgt1>> /\ *)
  (*     <<AUX_FLT1_TGT: DSys.filter_nb_sysstep tr_h_tgt_raw = Some (aux_tr_h_tgt aux)>> /\ *)
  (*     <<AUX_STEPS_TGT: msteps _ n_tgt st_tgt1 (aux_tr_t_tgt aux) (aux_st_tgt_nxt aux)>> /\ *)

  (*     <<TR_SRC: cons_each_rel (aux_tr_h_src aux) (aux_tr_t_src aux) tr_src>> /\ *)
  (*     <<TR_TGT: cons_each_rel (aux_tr_h_tgt aux) (aux_tr_t_tgt aux) tr_tgt>> /\ *)
  (*     <<TRC_EQV: Forall2 tes_equiv tr_src tr_tgt>> /\ *)
  (*     <<EXEC_TGT_NXT: *)
  (*       Forall3 (fun a b c => stream_app a b = c) *)
  (*               tr_tgt (aux_exec_tgt_nxt aux) exec_tgt>> *)
  (*     }. *)
  (* Proof. *)
  (*   hexploit fmsim_states_ex_src; eauto. *)
  (*   intro EX. *)

  (*   pose (CID := constructive_indefinite_description). *)
  (*   eapply CID in EX. destruct EX as [ns_src EX]. *)
  (*   eapply CID in EX. destruct EX as [tr_h_src_raw EX]. *)
  (*   eapply CID in EX. destruct EX as [tr_h_src EX]. *)
  (*   eapply CID in EX. destruct EX as [st_src1 EX]. *)
  (*   eapply CID in EX. destruct EX as [tr_t_src EX]. *)
  (*   eapply CID in EX. destruct EX as [tr_src EX]. *)
  (*   eapply CID in EX. destruct EX as [st_src' EX]. *)
  (*   eapply CID in EX. destruct EX as [n_tgt EX]. *)
  (*   eapply CID in EX. destruct EX as [tr_h_tgt_raw EX]. *)
  (*   eapply CID in EX. destruct EX as [tr_h_tgt EX]. *)
  (*   eapply CID in EX. destruct EX as [st_tgt1 EX]. *)
  (*   eapply CID in EX. destruct EX as [tr_t_tgt EX]. *)
  (*   eapply CID in EX. destruct EX as [tr_tgt EX]. *)
  (*   eapply CID in EX. destruct EX as [st_tgt' EX]. *)
  (*   eapply CID in EX. destruct EX as [exec_tgt' EX]. *)
  (*   des. *)

  (*   eexists (FMSimAuxdata _ _ _ _ _ _ _ _ _ _). *)
  (*   esplits; eauto. *)
  (*   Unshelve. *)
  (*   - eauto. *)
  (*   - eauto. *)
  (*   - eauto. *)
  (* Qed. *)

  (* CoFixpoint constr_local_exec_src *)
  (*       st_src st_tgt exec_tgt *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*       (n: nat) (cont: list (tsp * events sysE)) *)
  (*   : @lexec_t sysE. *)
  (* Proof. *)
  (*   destruct cont as [| h t]. *)
  (*   2: { exact (Cons h (constr_local_exec_src *)
  (*                         _ _ _ SAFE EXEC_TGT FMSIM n t)). } *)

  (*   pose (C := proj1_sig (fmsim_states_constr_src1 *)
  (*                           _ _ _ SAFE EXEC_TGT FMSIM)). *)
  (*   econs. *)
  (*   { exact (nth n (aux_tr_h_src C) (0%Z, [])). } *)
  (*   { exact (constr_local_exec_src *)
  (*              _ _ _ *)
  (*              (AUX_SAFE_NXT C) (AUX_EXEC_TGT_NXT C) *)
  (*              (AUX_FMSIM_NXT C) n *)
  (*              (nth n (aux_tr_t_src C) [])). *)
  (*   } *)
  (* Defined. *)

  (* Definition constr_exec_src *)
  (*       st_src st_tgt exec_tgt *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*   : @exec_t sysE := *)
  (*   imap (fun n _ => constr_local_exec_src *)
  (*                   _ _ _ SAFE EXEC_TGT FMSIM n []) *)
  (*        0 (List.repeat tt (DSys.num_sites _ st_src)). *)

  (* Lemma constr_exec_src_length *)
  (*       st_src st_tgt exec_tgt *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*   : length (constr_exec_src _ _ _ SAFE EXEC_TGT FMSIM) = *)
  (*     DSys.num_sites _ st_src. *)
  (* Proof. *)
  (*   unfold constr_exec_src. *)
  (*   rewrite imap_length. *)
  (*   rewrite repeat_length. ss. *)
  (* Qed. *)

  (* Lemma constr_local_exec_src_app_cont *)
  (*       n es st_src st_tgt exec_tgt *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*   : constr_local_exec_src *)
  (*       _ _ _ SAFE EXEC_TGT FMSIM n es = *)
  (*     stream_app es *)
  (*                (constr_local_exec_src *)
  (*                   _ _ _ SAFE EXEC_TGT FMSIM n []). *)
  (* Proof. *)
  (*   induction es as [| h t IH]; ss. *)
  (*   match goal with *)
  (*   | |- ?c = _ => rewrite (unfold_Stream c) *)
  (*   end. *)
  (*   ss. f_equal. ss. *)
  (* Qed. *)

  (* Lemma constr_exec_src_des *)
  (*       st_src st_tgt exec_tgt *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*   : exists n_src tr_h_src_raw tr_h_src st_src1 *)
  (*       tr_t_src tr_src st_src' *)
  (*       n_tgt tr_h_tgt_raw tr_h_tgt st_tgt1 *)
  (*       tr_t_tgt tr_tgt st_tgt' exec_tgt' *)
  (*       (SAFE': DSys.safe_state st_tgt') *)
  (*       (EXEC_TGT': DSys.exec_state _ st_tgt' exec_tgt') *)
  (*       (FMSIM': fmsim_states st_src' st_tgt') *)
  (*   , *)
  (*     <<STEP1_SRC: DSys.step _ st_src tr_h_src_raw st_src1>> /\ *)
  (*     <<FLT1_SRC: DSys.filter_nb_sysstep tr_h_src_raw = Some tr_h_src>> /\ *)
  (*     <<STEPS_SRC: msteps _ n_src st_src1 tr_t_src st_src'>> /\ *)

  (*     <<STEP1_TGT: DSys.step _ st_tgt tr_h_tgt_raw st_tgt1>> /\ *)
  (*     <<FLT1_TGT: DSys.filter_nb_sysstep tr_h_tgt_raw = Some tr_h_tgt>> /\ *)
  (*     <<STEPS_TGT: msteps _ n_tgt st_tgt1 tr_t_tgt st_tgt'>> /\ *)

  (*     <<TR_SRC_DIV: cons_each_rel tr_h_src tr_t_src tr_src>> /\ *)
  (*     <<TR_TGT_DIV: cons_each_rel tr_h_tgt tr_t_tgt tr_tgt>> /\ *)
  (*     <<TES_EQUIV: Forall2 tes_equiv tr_src tr_tgt>> /\ *)
  (*     <<EXEC_TGT_DIV: Forall3 (fun a b c => stream_app a b = c) *)
  (*                             tr_tgt exec_tgt' exec_tgt>> /\ *)

  (*     <<CONSTR_SRC_DIV: *)
  (*       Forall3 (fun a b c => stream_app a b = c) *)
  (*               tr_src *)
  (*               (constr_exec_src _ _ _ SAFE' EXEC_TGT' FMSIM') *)
  (*               (constr_exec_src _ _ _ SAFE EXEC_TGT FMSIM)>> *)
  (* . *)
  (* Proof. *)
  (*   destruct (fmsim_states_constr_src1 *)
  (*               _ _ _ SAFE EXEC_TGT FMSIM) as [aux P] eqn: CONSTR. *)
  (*   des. *)
  (*   assert (AUX: proj1_sig (fmsim_states_constr_src1 *)
  (*                             _ _ _ SAFE EXEC_TGT FMSIM) = aux). *)
  (*   { rewrite CONSTR. ss. } *)
  (*   clear CONSTR. *)

  (*   esplits; eauto. *)
  (*   instantiate (1:= AUX_FMSIM_NXT aux). *)
  (*   instantiate (1:= AUX_EXEC_TGT_NXT aux). *)
  (*   instantiate (1:= AUX_SAFE_NXT aux). *)

  (*   match goal with *)
  (*   | |- Forall3 _ _ ?c' ?c => *)
  (*     pose (cstr' := c'); pose (cstr := c) *)
  (*   end. *)
  (*   fold cstr' cstr. *)

  (*   apply Forall3_nth. i. *)

  (*   (* for lengths *) *)
  (*   assert (LEN_C': length cstr' = DSys.num_sites _ (aux_st_src_nxt aux)). *)
  (*   { subst cstr'. *)
  (*     apply constr_exec_src_length. } *)
  (*   assert (LEN_C: length cstr = DSys.num_sites _ st_src). *)
  (*   { subst cstr. *)
  (*     apply constr_exec_src_length. } *)
  (*   hexploit msteps_num_sites_eq; try apply AUX_STEPS_SRC. *)
  (*   i. des. *)
  (*   hexploit (DSys.step_prsv_num_sites sys_src). *)
  (*   { apply AUX_STEP1_SRC. } *)
  (*   i. des. *)
  (*   hexploit Forall3_length; try apply TR_SRC. i. des. *)

  (*   destruct (lt_ge_dec n (length tr_src)). *)
  (*   2: { *)
  (*     rewrite nth_error_None2 by ss. *)
  (*     rewrite nth_error_None2. *)
  (*     2: { unfold lexec_t in *. nia. } *)
  (*     rewrite nth_error_None2. *)
  (*     2: { unfold lexec_t in *. nia. } *)
  (*     econs. *)
  (*   } *)

  (*   hexploit (nth_error_Some2 _ tr_src n); ss. i. des. *)
  (*   renames e1 NTH_EX into src_n SRC_N. *)
  (*   unfold constr_exec_src in *. *)
  (*   rewrite SRC_N. *)

  (*   subst cstr'. *)
  (*   rewrite imap_nth_error_iff. ss. *)
  (*   rewrite repeat_nth_error_Some. *)
  (*   2: { unfold lexec_t in *. nia. } *)
  (*   ss. *)
  (*   subst cstr. *)
  (*   rewrite imap_nth_error_iff. ss. *)
  (*   rewrite repeat_nth_error_Some. *)
  (*   2: { unfold lexec_t in *. nia. } *)
  (*   ss. *)

  (*   eapply Forall3_nth3 in TR_SRC; eauto. des. subst. *)
  (*   econs. ss. *)
  (*   match goal with *)
  (*   | |- _ = ?c => rewrite (unfold_Stream c) *)
  (*   end. *)
  (*   ss. *)
  (*   f_equal. *)
  (*   - erewrite nth_error_nth; eauto. *)
  (*   - erewrite nth_error_nth; eauto. *)
  (*     symmetry. *)
  (*     apply constr_local_exec_src_app_cont. *)
  (* Qed. *)

  (* Lemma exec_state_src *)
  (*   : forall st_src st_tgt *)
  (*       exec_tgt *)
  (*       (SAFE : DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT : DSys.exec_state sys_tgt st_tgt exec_tgt) *)
  (*       (FMSIM : fmsim_states st_src st_tgt) *)
  (*       (* (BEH_TGT : exec_behav exec_tgt beh) *), *)
  (*     DSys.exec_state _ st_src *)
  (*                     (constr_exec_src *)
  (*                        _ _ _ SAFE EXEC_TGT FMSIM). *)
  (* Proof. *)
  (*   pcofix CIH. i. pfold. *)
  (*   hexploit (constr_exec_src_des _ _ _ SAFE EXEC_TGT FMSIM). *)
  (*   i. des. *)

  (*   pose (cstr := constr_exec_src _ _ _ SAFE EXEC_TGT FMSIM). *)
  (*   pose (cstr' := constr_exec_src _ _ _ SAFE' EXEC_TGT' FMSIM'). *)
  (*   fold cstr. *)

  (*   assert (AUX: forall n (N_UB: n < length cstr'), *)
  (*              exists lexec', *)
  (*                (fun n lexec' => *)
  (*                   exists tr_t_src_n cstr'_n, *)
  (*                     <<TR_T_SRC: nth_error tr_t_src n = Some tr_t_src_n>> /\ *)
  (*                     <<CSTR'_N: nth_error cstr' n = Some cstr'_n>> /\ *)
  (*                     <<LEXEC'_EQ: lexec' = stream_app tr_t_src_n cstr'_n>>) *)
  (*                  n lexec'). *)
  (*   { fold cstr cstr' in CONSTR_SRC_DIV. *)
  (*     i. hexploit (nth_error_Some2 _ cstr' n); ss. i. des. *)
  (*     renames e1 NTH_EX into c'_n C'_N. *)

  (*     eapply Forall3_nth2 in CONSTR_SRC_DIV; eauto. i. des. *)
  (*     eapply Forall3_nth3 in TR_SRC_DIV; eauto. i. des. *)
  (*     clarify. *)
  (*     esplits; eauto. *)
  (*   } *)

  (*   apply exists_list in AUX. des. *)
  (*   renames l LIST_LEN NTH_PROP into *)
  (*           cstr_tl CSTR_TL_LEN CSTR_TL_PROP. *)

  (*   econs 2. *)
  (*   { eauto. } *)
  (*   { eauto. } *)
  (*   { instantiate (1:= cstr_tl). *)
  (*     r. apply Forall3_nth. i. *)
  (*     destruct (lt_ge_dec n (length cstr_tl)). *)
  (*     2: { *)
  (*       assert (length cstr' = DSys.num_sites _ st_src'). *)
  (*       { subst cstr'. *)
  (*         apply constr_exec_src_length. } *)
  (*       assert (length cstr = DSys.num_sites _ st_src). *)
  (*       { subst cstr. *)
  (*         apply constr_exec_src_length. } *)

  (*       hexploit msteps_num_sites_eq; try apply STEPS_SRC. *)
  (*       i. des. *)
  (*       apply Forall3_length in TR_SRC_DIV. des. *)
  (*       eapply DSys.step_prsv_num_sites in STEP1_SRC. des. *)

  (*       rewrite nth_error_None2 by nia. *)
  (*       rewrite nth_error_None2 by ss. *)
  (*       rewrite nth_error_None2. *)
  (*       2: { fold (@lexec_t sysE) in *. nia. } *)
  (*       econs. } *)

  (*     hexploit (nth_error_Some2 _ cstr_tl n). *)
  (*     { ss. } *)
  (*     i. des. renames e1 NTH_EX into cstr_tl_n CSTR_TL_N. *)
  (*     rewrite CSTR_TL_N. *)
  (*     hexploit CSTR_TL_PROP; eauto. i. des. *)
  (*     r in TR_SRC_DIV. *)
  (*     hexploit Forall3_nth2; try apply TR_SRC_DIV; eauto. *)
  (*     i. des. *)
  (*     renames e1 e3 into tr_h_src_n tr_src_n. *)
  (*     renames NTH1 NTH3 P_FA into TR_HS_N TR_N TR_CONS. *)

  (*     rewrite TR_HS_N. *)

  (*     fold cstr cstr' in CONSTR_SRC_DIV. *)
  (*     eapply Forall3_nth1 in CONSTR_SRC_DIV; eauto. *)
  (*     des. *)
  (*     renames e2 e3 into cstr'_n_tmp cstr_n. *)
  (*     renames NTH2 NTH3 P_FA into CSTR'_N_TMP CSTR_N CSTR_N_DIV. *)

  (*     fold (lexec_t sysE) in *. *)
  (*     rewrite CSTR'_N in CSTR'_N_TMP. *)
  (*     symmetry in CSTR'_N_TMP. inv CSTR'_N_TMP. *)
  (*     rewrite CSTR_N. *)

  (*     econs. ss. *)
  (*   } *)

  (*   eapply (msteps_src_tl_aux sys_src) with (cstr':= cstr'); eauto. *)
  (*   subst cstr'. *)
  (*   rewrite constr_exec_src_length. *)
  (*   apply msteps_num_sites_eq in STEPS_SRC. des. ss. *)
  (* Qed. *)

  (* Lemma fmsim_merged_inv *)
  (*       st_src st_tgt exec_tgt *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*   : forall n_min, *)
  (*     exists n_tgt tr_tgt exec_tgt' st_tgt' *)
  (*       tr_src st_src' *)
  (*       (SAFE': DSys.safe_state st_tgt') *)
  (*       (EXEC': DSys.exec_state _ st_tgt' exec_tgt') *)
  (*       (FMSIM': fmsim_states st_src' st_tgt') *)
  (*     , *)
  (*       <<N_TGT_GE: n_min <= n_tgt>> /\ *)
  (*       <<EXEC_TGT_DIV: Forall3 (fun a b c => stream_app a b = c) *)
  (*                               tr_tgt exec_tgt' exec_tgt>> /\ *)
  (*       <<TR_TGT_ROW_LEN: Forall (fun r => length r = n_tgt) tr_tgt>> /\ *)
  (*       (* <<STEPS_TGT: msteps _ n_tgt st_tgt tr_tgt st_tgt'>> /\ *) *)

  (*       <<TRACE_EQUIV: Forall2 tes_equiv tr_src tr_tgt>> /\ *)

  (*       <<CONSTR_SRC_DIV: *)
  (*         Forall3 (fun a b c => stream_app a b = c) *)
  (*                 tr_src *)
  (*                 (constr_exec_src _ _ _ SAFE' EXEC' FMSIM') *)
  (*                 (constr_exec_src _ _ _ SAFE EXEC FMSIM)>> *)
  (* . *)
  (* Proof. *)
  (*   i. revert st_src st_tgt exec_tgt SAFE EXEC FMSIM. *)
  (*   induction n_min as [| n_min' IH]; i; ss. *)
  (*   { exists 0. *)
  (*     exists (repeat [] (length exec_tgt)). *)
  (*     exists exec_tgt, st_tgt. *)
  (*     exists (repeat [] (length exec_tgt)). *)
  (*     exists st_src, SAFE, EXEC, FMSIM. *)
  (*     hexploit fmsim_num_sites_eq; eauto. intro NUM_SITES_EQ. *)
  (*     hexploit exec_state_len; eauto. intro EXEC_TGT_LEN. *)

  (*     splits; ss. *)
  (*     - apply Forall3_nth. i. *)
  (*       destruct (lt_ge_dec n (length exec_tgt)). *)
  (*       2: { *)
  (*         rewrite nth_error_None2. *)
  (*         2: { rewrite repeat_length. ss. } *)
  (*         rewrite nth_error_None2 by ss. *)
  (*         econs. *)
  (*       } *)
  (*       rewrite repeat_nth_error_Some by ss. *)
  (*       hexploit (nth_error_Some2 _ exec_tgt n); ss. *)
  (*       i. des. *)
  (*       unfold lexec_t in *. rewrite NTH_EX. *)
  (*       econs. ss. *)
  (*     - apply Forall_forall. *)
  (*       intros x IN. *)
  (*       apply repeat_spec in IN. subst. ss. *)
  (*     - apply Forall2_tes_equiv_refl. *)
  (*     - remember (constr_exec_src _ _ _ SAFE EXEC FMSIM) as cstr. *)

  (*       assert (CSTR_LEN: length cstr = DSys.num_sites _ st_src). *)
  (*       { subst cstr. *)
  (*         apply constr_exec_src_length. } *)

  (*       clear Heqcstr. *)
  (*       apply Forall3_nth. i. *)

  (*       destruct (lt_ge_dec n (length exec_tgt)). *)
  (*       2: { *)
  (*         rewrite nth_error_None2. *)
  (*         2: { rewrite repeat_length. ss. } *)
  (*         unfold lexec_t in *. *)
  (*         rewrite nth_error_None2 by nia. *)
  (*         econs. *)
  (*       } *)

  (*       rewrite repeat_nth_error_Some by ss. *)
  (*       hexploit (nth_error_Some2 _ cstr n). *)
  (*       { unfold lexec_t in *. nia. } *)
  (*       i. des. *)

  (*       unfold lexec_t in *. *)
  (*       rewrite NTH_EX. econs. ss. *)
  (*   } *)

  (*   generalize (constr_exec_src_des _ _ _ SAFE EXEC FMSIM). *)
  (*   i. des. *)

  (*   remember (constr_exec_src _ _ _ SAFE EXEC FMSIM) *)
  (*     as cstr eqn: CSTR. *)
  (*   clear CSTR. *)
  (*   clear SAFE EXEC FMSIM. *)
  (*   renames SAFE' EXEC_TGT' FMSIM' into SAFE1 EXEC1 FMSIM1. *)

  (*   hexploit (IH _ _ _ SAFE1 EXEC1 FMSIM1); eauto. *)
  (*   i. des. *)
  (*   exists (S n_tgt + n_tgt0). *)

  (*   assert (exists tr_tgt_tot, *)
  (*              <<TR_TGT_TOT: Forall3 (fun a b c => app a b = c) *)
  (*                                    tr_tgt tr_tgt0 tr_tgt_tot>>). *)
  (*   { cut (forall n (RANGE_N: n < length tr_tgt), *)
  (*             exists (tot_n: list (tsp * events sysE)), *)
  (*               (fun n tot_n => *)
  (*                  exists tgt_n tgt0_n, *)
  (*                    nth_error tr_tgt n = Some tgt_n /\ *)
  (*                    nth_error tr_tgt0 n = Some tgt0_n /\ *)
  (*                    tgt_n ++ tgt0_n = tot_n) *)
  (*                 n tot_n). *)
  (*     { intro AUX. *)
  (*       apply exists_list in AUX. des. *)
  (*       exists l. *)
  (*       apply Forall3_nth. i. *)
  (*       destruct (lt_ge_dec n (length l)). *)
  (*       2: { *)
  (*         apply Forall3_length in EXEC_TGT_DIV. *)
  (*         apply Forall3_length in EXEC_TGT_DIV0. des. *)
  (*         rewrite nth_error_None2 by nia. *)
  (*         rewrite nth_error_None2 by nia. *)
  (*         rewrite nth_error_None2 by ss. *)
  (*         econs. *)
  (*       } *)

  (*       hexploit (nth_error_Some2 _ l n); ss. *)
  (*       i. des. renames e1 NTH_EX into l_n L_N. *)
  (*       hexploit NTH_PROP; eauto. *)
  (*       intros (tgt_n & tgt0_n & NTH & NTH0 & APP_EQ). *)
  (*       subst. *)
  (*       rewrite L_N, NTH, NTH0. econs. ss. *)
  (*     } *)

  (*     i. *)
  (*     hexploit (nth_error_Some2 _ tr_tgt n); ss. i. des. *)
  (*     renames e1 NTH_EX into tgt_n TGT_N. *)

  (*     eapply Forall3_nth1 in EXEC_TGT_DIV; eauto. i. des. *)
  (*     renames e2 e3 into e'_n e_n. *)
  (*     renames NTH2 NTH3 into E'_N E_N. subst. *)

  (*     eapply Forall3_nth3 in EXEC_TGT_DIV0; eauto. i. des. *)
  (*     renames e1 e2 into tgt0_n e'0_n. *)
  (*     renames NTH1 NTH2 into TGT0_N E'0_N. subst. *)
  (*     esplits; eauto. *)
  (*   } *)

  (*   remember (constr_exec_src *)
  (*               _ _ _ SAFE' EXEC' FMSIM') as cstr'. *)
  (*   remember (constr_exec_src *)
  (*               _ _ _ SAFE1 EXEC1 FMSIM1) as cstr1. *)
  (*   guardH Heqcstr'. guardH Heqcstr1. *)

  (*   assert (exists tr_src_tot, *)
  (*              <<TR_SRC_TOT: Forall3 (fun a b c => app a b = c) *)
  (*                                    tr_src tr_src0 tr_src_tot>>). *)
  (*   { cut (forall n (RANGE_N: n < length tr_src), *)
  (*             exists (tot_n: list (tsp * events sysE)), *)
  (*               (fun n tot_n => *)
  (*                  exists src_n src0_n, *)
  (*                    nth_error tr_src n = Some src_n /\ *)
  (*                    nth_error tr_src0 n = Some src0_n /\ *)
  (*                    src_n ++ src0_n = tot_n) *)
  (*                 n tot_n). *)
  (*     { intro AUX. *)
  (*       apply exists_list in AUX. des. *)
  (*       exists l. *)
  (*       apply Forall3_nth. i. *)
  (*       destruct (lt_ge_dec n (length l)). *)
  (*       2: { *)
  (*         apply Forall3_length in CONSTR_SRC_DIV. *)
  (*         apply Forall3_length in CONSTR_SRC_DIV0. des. *)
  (*         rewrite nth_error_None2 by nia. *)
  (*         rewrite nth_error_None2 by nia. *)
  (*         rewrite nth_error_None2 by ss. *)
  (*         econs. *)
  (*       } *)

  (*       hexploit (nth_error_Some2 _ l n); ss. *)
  (*       i. des. renames e1 NTH_EX into l_n L_N. *)
  (*       hexploit NTH_PROP; eauto. *)
  (*       intros (src_n & src0_n & NTH & NTH0 & APP_EQ). *)
  (*       subst. *)
  (*       rewrite L_N, NTH, NTH0. econs. ss. *)
  (*     } *)

  (*     i. *)
  (*     hexploit (nth_error_Some2 _ tr_src n); ss. i. des. *)
  (*     renames e1 NTH_EX into src_n SRC_N. *)

  (*     eapply Forall3_nth1 in CONSTR_SRC_DIV; eauto. i. des. *)
  (*     renames e2 e3 into e'_n e_n. *)
  (*     renames NTH2 NTH3 into E'_N E_N. subst. *)

  (*     eapply Forall3_nth3 in CONSTR_SRC_DIV0; eauto. i. des. *)
  (*     renames e1 e2 into src0_n e'0_n. *)
  (*     renames NTH1 NTH2 into SRC0_N E'0_N. subst. *)
  (*     esplits; eauto. *)
  (*   } *)
  (*   des. *)

  (*   eexists tr_tgt_tot, _, _, tr_src_tot, _, *)
  (*   SAFE', EXEC', FMSIM'. *)
  (*   esplits; ss. *)
  (*   - nia. *)
  (*   - apply Forall3_nth. i. *)
  (*     destruct (lt_ge_dec n (length tr_tgt_tot)). *)
  (*     2: { *)
  (*       apply Forall3_length in TR_TGT_TOT. des. *)
  (*       apply Forall3_length in EXEC_TGT_DIV. des. *)
  (*       apply Forall3_length in EXEC_TGT_DIV0. des. *)
  (*       rewrite nth_error_None2 by ss. *)
  (*       rewrite nth_error_None2 by nia. *)
  (*       rewrite nth_error_None2 by nia. *)
  (*       econs. *)
  (*     } *)
  (*     hexploit (nth_error_Some2 _ tr_tgt_tot n); ss. i. des. *)
  (*     renames e1 NTH_EX into tr_tgt_tot_n TR_TGT_TOT_N. *)
  (*     eapply Forall3_nth3 in TR_TGT_TOT; eauto. i. des. *)
  (*     renames e1 e2 into tr_tgt_n tr_tgt0_n. *)
  (*     renames NTH1 NTH2 into TR_TGT_N TR_TGT0_N. *)
  (*     subst tr_tgt_tot_n. *)
  (*     eapply Forall3_nth1 in EXEC_TGT_DIV; eauto. i. des. *)
  (*     renames e2 e3 into exec_tgt'_n exec_tgt_n. *)
  (*     renames NTH2 NTH3 into EXEC_TGT'_N EXEC_TGT_N. *)
  (*     subst exec_tgt_n. *)
  (*     eapply Forall3_nth1 in EXEC_TGT_DIV0; eauto. i. des. *)
  (*     renames e2 e3 into exec_tgt'0_n exec_tgt'_n_tmp. *)
  (*     renames NTH2 NTH3 into EXEC_TGT'0_N EXEC_TGT'_N_TMP. *)
  (*     clarify. *)
  (*     rename EXEC_TGT'_N_TMP into EXEC_TGT'_N. *)

  (*     rewrite TR_TGT_TOT_N, EXEC_TGT'0_N, EXEC_TGT_N. *)
  (*     econs. apply stream_app_assoc. *)

  (*   - apply Forall_forall. *)
  (*     intros tr_tgt_tot_n TOT_N. *)
  (*     eapply In_nth_error in TOT_N. des. *)
  (*     eapply Forall3_nth3 in TR_TGT_TOT; eauto. i. des. *)
  (*     renames e1 e2 into tr_tgt_n tr_tgt0_n. *)
  (*     renames NTH1 NTH2 into TR_TGT_N TR_TGT0_N. subst. *)
  (*     rewrite app_length. *)

  (*     cut (length tr_tgt_n = S n_tgt). *)
  (*     { i. rewrite Forall_forall in TR_TGT_ROW_LEN. *)
  (*       hexploit TR_TGT_ROW_LEN. *)
  (*       { eapply nth_error_In. eauto. } *)
  (*       i. nia. *)
  (*     } *)

  (*     eapply Forall3_nth3 in TR_TGT_DIV; eauto. i. des. *)
  (*     renames e1 e2 into h_n t_n. *)
  (*     renames NTH1 NTH2 into H_N T_N. subst. ss. *)
  (*     hexploit msteps_trace_row_length; eauto. *)
  (*     rewrite Forall_forall. intro A. *)
  (*     hexploit A. *)
  (*     { eapply nth_error_In. eauto. } *)
  (*     i. nia. *)

  (*   - apply Forall2_nth. i. *)
  (*     destruct (lt_ge_dec n (length tr_src_tot)). *)
  (*     2: { *)
  (*       apply Forall3_length in TR_SRC_TOT. des. *)
  (*       apply Forall3_length in TR_TGT_TOT. des. *)
  (*       apply Forall2_length in TES_EQUIV. *)
  (*       rewrite nth_error_None2 by ss. *)
  (*       rewrite nth_error_None2 by nia. *)
  (*       econs. *)
  (*     } *)

  (*     hexploit (nth_error_Some2 _ tr_src_tot n); ss. i. des. *)
  (*     renames e1 NTH_EX into src_tot_n SRC_TOT_N. *)
  (*     eapply Forall3_nth3 in TR_SRC_TOT; eauto. i. des. *)
  (*     renames e1 e2 into src_n src0_n. *)
  (*     renames NTH1 NTH2 into SRC_N SRC0_N. subst. *)
  (*     eapply Forall2_nth1 in TES_EQUIV; eauto. i. des. *)
  (*     renames e2 NTH2 P_FA into tgt_n TGT_N EQV1. *)
  (*     eapply Forall3_nth1 in TR_TGT_TOT; eauto. i. des. *)
  (*     renames e2 NTH2 NTH3 into tgt0_n TGT0_N TGT_TOT_N. subst. *)
  (*     rewrite Forall2_nth in TRACE_EQUIV. *)
  (*     specialize (TRACE_EQUIV n). *)

  (*     assert (EQV2: tes_equiv src0_n tgt0_n). *)
  (*     { rewrite SRC0_N, TGT0_N in TRACE_EQUIV. *)
  (*       inv TRACE_EQUIV. ss. } *)

  (*     rewrite SRC_TOT_N, TGT_TOT_N. econs. *)
  (*     unfold tes_equiv, flatten_tes in *. *)
  (*     repeat rewrite map_app. repeat rewrite concat_app. *)
  (*     congruence. *)

  (*   - rewrite <- Heqcstr'. *)
  (*     clear Heqcstr1 Heqcstr'. *)
  (*     apply Forall3_nth. i. *)
  (*     destruct (lt_ge_dec n (length tr_src_tot)). *)
  (*     2: { *)
  (*       rewrite nth_error_None2 by ss. *)
  (*       apply Forall3_length in TR_SRC_TOT. *)
  (*       apply Forall3_length in CONSTR_SRC_DIV0. des. *)
  (*       apply Forall3_length in CONSTR_SRC_DIV. des. *)
  (*       rewrite nth_error_None2 by nia. *)
  (*       rewrite nth_error_None2 by nia. *)
  (*       econs. *)
  (*     } *)

  (*     hexploit (nth_error_Some2 _ tr_src_tot n); ss. i. des. *)
  (*     renames e1 NTH_EX into src_tot_n SRC_TOT_N. *)
  (*     eapply Forall3_nth3 in TR_SRC_TOT; eauto. i. des. *)
  (*     renames e1 e2 into src_n src0_n. *)
  (*     renames NTH1 NTH2 into SRC_N SRC0_N. subst. *)
  (*     eapply Forall3_nth1 in CONSTR_SRC_DIV0; eauto. i. des. *)
  (*     renames e2 e3 into c'_n c_n. *)
  (*     renames NTH2 NTH3 into C'_N C_N. subst. *)
  (*     eapply Forall3_nth1 in CONSTR_SRC_DIV; eauto. i. des. *)
  (*     renames e2 e3 into c1_n c_n_tmp. *)
  (*     renames NTH2 NTH3 into C1_N C_N_TMP. *)
  (*     clarify. rename C_N_TMP into C_N. *)
  (*     rewrite SRC_TOT_N, C'_N, C_N. *)
  (*     econs. apply stream_app_assoc. *)
  (* Qed. *)

  (* (* Lemma inftau_lexec_Cons *) *)
  (* (*       (lexec: @lexec_t sysE) ts *) *)
  (* (*   : inftau_lexec lexec <-> *) *)
  (* (*     inftau_lexec (Cons (ts, []) lexec). *) *)
  (* (* Proof. *) *)
  (* (*   split. *) *)
  (* (*   - i. pfold. econs; ss. *) *)
  (* (*     left. ss. *) *)
  (* (*   - intro CONS. punfold CONS. inv CONS. ss. pclearbot. ss. *) *)
  (* (* Qed. *) *)

  (* Lemma constr_local_src_exec_inftau *)
  (*   : forall st_src st_tgt exec_tgt *)
  (*       n exec_tgt_n *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*       (EXEC_TGT_N: nth_error exec_tgt n = Some exec_tgt_n) *)
  (*       (EXBEH_N: inftau_lexec exec_tgt_n) *)
  (*   , *)
  (*     inftau_lexec *)
  (*       (constr_local_exec_src *)
  (*          _ _ _ SAFE EXEC_TGT FMSIM n []). *)
  (* Proof. *)
  (*   pcofix CIH. i. *)
  (*   match goal with *)
  (*   | |- _ _ _ ?c => rewrite (unfold_Stream c) *)
  (*   end. *)
  (*   ss. *)

  (*   pose (CSTR1:= fmsim_states_constr_src1 *)
  (*                   st_src st_tgt exec_tgt SAFE EXEC_TGT FMSIM). *)
  (*   fold CSTR1. *)
  (*   destruct CSTR1. ss. des. *)
  (*   destruct x. ss. *)
  (*   pfold. *)

  (*   eapply Forall3_nth3 in EXEC_TGT_NXT; eauto. i. des. *)
  (*   renames e1 e2 into tr_tgt_n exec_tgt'_n. *)
  (*   renames NTH1 NTH2 into TR_TGT_N EXEC_TGT'_N. *)
  (*   subst exec_tgt_n. *)
  (*   apply inftau_lexec_pref_iff in EXBEH_N. des. *)

  (*   eapply Forall2_nth2 in TRC_EQV; eauto. i. des. *)
  (*   renames e1 NTH1 P_FA into tr_src_n TR_SRC_N EQV_N. *)
  (*   eapply silent_tes_equiv in EQV_N; eauto. *)

  (*   eapply Forall3_nth3 in TR_SRC; eauto. i. des. *)
  (*   renames e1 e2 into tr_h_src_n tr_t_src_n. *)
  (*   renames NTH1 NTH2 into TR_H_SRC_N TR_T_SRC_N. *)
  (*   subst tr_src_n. *)
  (*   erewrite nth_error_nth; eauto. *)
  (*   erewrite nth_error_nth; eauto. *)

  (*   econs; ss. *)
  (*   { inv EQV_N. ss. } *)
  (*   { assert (SILENT: silent_local_trace _ tr_t_src_n). *)
  (*     { inv EQV_N. ss. } *)

  (*     clear - CIH SILENT EXEC_TGT'_N INFTAU. *)
  (*     (* depgen aux_tr_t_src0. *) *)

  (*     induction tr_t_src_n as [| h t IH]; i; ss. *)
  (*     { eauto. } *)
  (*     left. *)
  (*     match goal with *)
  (*     | |- _ _ _ ?c => rewrite (unfold_Stream c) *)
  (*     end. *)
  (*     ss. *)
  (*     pfold. econs. *)
  (*     { inv SILENT. ss. } *)
  (*     eapply IH; eauto. *)
  (*     inv SILENT. ss. *)
  (*   } *)
  (* Qed. *)

  (* Lemma constr_local_src_exec_behav *)
  (*   : forall st_src st_tgt exec_tgt *)
  (*       n exec_tgt_n beh_n (* tes *) *)
  (*       pref_src beh_pref *)
  (*       (SAFE: DSys.safe_state st_tgt) *)
  (*       (EXEC_TGT: DSys.exec_state _ st_tgt exec_tgt) *)
  (*       (FMSIM: fmsim_states st_src st_tgt) *)
  (*       (EXEC_TGT_N: nth_error exec_tgt n = Some exec_tgt_n) *)
  (*       (EXBEH_N: local_exec_behav exec_tgt_n beh_n) *)
  (*       (PREF_EQUIV: flatten_tes pref_src = beh_pref) *)
  (*   , *)
  (*     local_exec_behav *)
  (*       (stream_app pref_src *)
  (*                   (constr_local_exec_src *)
  (*                      _ _ _ SAFE EXEC_TGT FMSIM n [])) *)
  (*       (colist_app beh_pref beh_n). *)
  (* Proof. *)
  (*   pcofix CIH. i. subst. *)

  (*   induction pref_src as [| h_pref t_pref IH]. *)
  (*   - ss. *)
  (*     punfold EXBEH_N. inv EXBEH_N. *)
  (*     + pfold. econs 1. *)
  (*       eapply constr_local_src_exec_inftau; eauto. *)
  (*     + pclearbot. *)
  (*       hexploit (fmsim_merged_inv _ _ _ SAFE EXEC_TGT FMSIM *)
  (*                                  (S (length tr_tau))). *)
  (*       i. des. *)
  (*       eapply Forall3_nth3 in EXEC_TGT_DIV; eauto. des. *)
  (*       renames e1 e2 into tr_tgt_n exec_tgt'_n. *)
  (*       renames NTH1 NTH2 P_FA into TR_TGT_N EXEC_TGT'_N SAPP_EQ. *)
  (*       eapply Forall_nth with (n:=n) in TR_TGT_ROW_LEN. *)
  (*       rewrite TR_TGT_N in TR_TGT_ROW_LEN. ss. *)
  (*       guardH TR_TGT_ROW_LEN. *)
  (*       eapply Forall2_nth2 in TRACE_EQUIV; eauto. des. *)
  (*       renames e1 NTH1 P_FA into tr_src_n TR_SRC_N EQV_N. *)
  (*       eapply Forall3_nth1 in CONSTR_SRC_DIV; eauto. des. *)
  (*       renames e2 e3 into cstr' cstr. *)
  (*       renames NTH2 NTH3 P_FA into CSTR' CSTR CSTR_DIV. *)
  (*       guardH CSTR_DIV. *)

  (*       unfold constr_exec_src in CSTR', CSTR. *)
  (*       rewrite imap_nth_error_iff in CSTR', CSTR. *)
  (*       rewrite repeat_nth_error_Some in CSTR'. *)
  (*       2: { *)
  (*         cut (nth_error (repeat tt (DSys.num_sites sys_src st_src')) n <> None). *)
  (*         { intro AUX. *)
  (*           apply nth_error_Some in AUX. *)
  (*           rewrite repeat_length in AUX. ss. } *)
  (*         intro NONE. rewrite NONE in CSTR'. ss. *)
  (*       } *)
  (*       rewrite repeat_nth_error_Some in CSTR. *)
  (*       2: { *)
  (*         cut (nth_error (repeat tt (DSys.num_sites sys_src st_src)) n <> None). *)
  (*         { intro AUX. *)
  (*           apply nth_error_Some in AUX. *)
  (*           rewrite repeat_length in AUX. ss. } *)
  (*         intro NONE. rewrite NONE in CSTR. ss. *)
  (*       } *)
  (*       ss. clarify. *)
  (*       rewrite <- CSTR_DIV. *)

  (*       assert (exists pref_tgt', *)
  (*                  <<TR_TGT_N_DIV: tr_tgt_n = tr_tau ++ [(ts, es)] ++ pref_tgt'>> /\ *)
  (*                  <<LEXEC'_DIV: lexec' = stream_app pref_tgt' exec_tgt'_n>>). *)
  (*       { clear - TRACE_TAU SAPP_EQ N_TGT_GE TR_TGT_ROW_LEN. *)
  (*         destruct tr_tgt_n as [| h_tr t_tr]; ss. *)
  (*         { unguardH TR_TGT_ROW_LEN. subst n_tgt. *)
  (*           exfalso. inv N_TGT_GE. } *)
  (*         assert (LEN_CMP: length tr_tau <= length t_tr). *)
  (*         { unguard. *)
  (*           subst n_tgt. *)
  (*           clear - N_TGT_GE. *)
  (*           apply Le.le_S_n. ss. *)
  (*         } *)

  (*         clear N_TGT_GE TR_TGT_ROW_LEN n_tgt. *)
  (*         depgen t_tr. revert h_tr. *)

  (*         induction tr_tau as [| h t IH]; i; ss. *)
  (*         - clarify. *)
  (*           esplits; eauto. *)
  (*         - assert (h = h_tr /\ *)
  (*                   <<STR_EQ: stream_app t_tr exec_tgt'_n = *)
  (*                             stream_app t (Cons (ts, es) lexec')>>). *)
  (*           { clarify. } *)
  (*           des. subst h. *)

  (*           inv TRACE_TAU. *)
  (*           destruct h_tr as [ts_h []]; ss. *)
  (*           destruct t_tr; ss. *)
  (*           { inv LEN_CMP. } *)

  (*           hexploit IH; eauto. *)
  (*           { apply Le.le_S_n. ss. } *)
  (*           i. des. *)
  (*           esplits; eauto. *)
  (*           rewrite <- TR_TGT_N_DIV. ss. *)
  (*       } *)

  (*       des. *)
  (*       guardH TR_TGT_N_DIV. guardH LEXEC'_DIV. *)

  (*       eapply local_exec_beh_div in LOCAL_EXEC_BEHAV_REST; eauto. *)
  (*       des. renames beh'0 EBEH' into beh_nxt EBEH_NXT. *)
  (*       guardH BEH_DIV. *)

  (*       rewrite BEH_DIV. *)
  (*       rewrite <- colist_app_assoc. *)

  (*       assert (exists tr_tau_src es_src pref_src', *)
  (*                  <<TR_SRC_N_DIV: tr_src_n = tr_tau_src ++ [(ts, es_src)] ++ pref_src'>> /\ *)
  (*                  <<TAU_SRC: silent_local_trace sysE tr_tau_src>> /\ *)
  (*                  <<ES_SRC_NONNIL: es_src <> []>>). *)
  (*       { clear - EQV_N TR_TGT_N_DIV EVENTS_NONNIL TRACE_TAU. *)
  (*         rewrite TR_TGT_N_DIV in EQV_N. clear TR_TGT_N_DIV. *)
  (*         unfold tes_equiv in EQV_N. ss. *)
  (*         depgen tr_tau. *)
  (*         clear tr_tgt_n. *)

  (*         induction tr_src_n as [| h t IH]; i; ss. *)
  (*         { exfalso. *)
  (*           unfold flatten_tes in EQV_N. ss. *)
  (*           rewrite map_app in EQV_N. ss. *)
  (*           rewrite concat_app in EQV_N. *)
  (*           fold (flatten_tes tr_tau) in EQV_N. *)

  (*           assert (AUX: flatten_tes tr_tau = []). *)
  (*           { apply flatten_silent_local_trace_iff. ss. } *)
  (*           rewrite AUX in EQV_N. ss. *)
  (*           destruct es; ss. *)
  (*         } *)

  (*         destruct h as [tstamp [|e_h e_t]]; ss. *)
  (*         { unfold flatten_tes at 1 in EQV_N. ss. *)
  (*           hexploit IH; eauto. i. des. *)
  (*           exists ((tstamp, [])::tr_tau_src). *)
  (*           esplits; eauto; ss. *)
  (*           - f_equal. eauto. *)
  (*           - econs; ss. *)
  (*         } *)
  (*         assert (tstamp = ts). *)
  (*         { clear - EQV_N EVENTS_NONNIL TRACE_TAU. *)
  (*           depgen tr_tau. *)
  (*           induction tr_tau; i; ss. *)
  (*           { unfold flatten_tes in EQV_N. ss. *)
  (*             destruct es; ss. clarify. } *)
  (*           inv TRACE_TAU. *)
  (*           destruct a; ss. clarify. *)
  (*           eapply IHtr_tau; ss. *)
  (*         } *)
  (*         subst tstamp. *)

  (*         exists []. esplits; ss. *)
  (*       } *)
  (*       des. guardH TR_SRC_N_DIV. *)
  (*       rewrite TR_SRC_N_DIV. *)

  (*       rewrite stream_app_assoc. ss. *)
  (*       rewrite colist_app_assoc. *)

  (*       pfold. econs 2; try reflexivity; ss. *)
  (*       2: { instantiate (1:= colist_app *)
  (*                               (flatten_tes pref_src') beh_nxt). *)
  (*            rewrite <- colist_app_assoc. *)
  (*            rewrite <- colist_app_assoc. *)

  (*            rewrite TR_SRC_N_DIV in EQV_N. *)
  (*            rewrite TR_TGT_N_DIV in EQV_N. *)
  (*            unfold tes_equiv, flatten_tes in EQV_N. *)
  (*            repeat rewrite map_app in EQV_N. *)
  (*            do 2 rewrite concat_app in EQV_N. *)

  (*            replace (concat (map flatten_te tr_tau_src)) *)
  (*              with (@nil (tsp * event sysE)) in EQV_N. *)
  (*            2: { symmetry. *)
  (*                 apply flatten_silent_local_trace_iff. ss. } *)
  (*            replace (concat (map flatten_te tr_tau)) *)
  (*              with (@nil (tsp * event sysE)) in EQV_N. *)
  (*            2: { symmetry. *)
  (*                 apply flatten_silent_local_trace_iff. ss. } *)
  (*            ss. *)
  (*            unfold flatten_tes. *)
  (*            rewrite EQV_N. ss. *)
  (*       } *)
  (*       { eauto. } *)

  (*   - i. *)
  (*     match goal with *)
  (*     | |- paco2 _ _ ?c1 _ => *)
  (*       rewrite (unfold_Stream c1) *)
  (*     end. ss. *)
  (*     unfold flatten_tes. ss. *)

  (*     rewrite colist_app_assoc. *)
  (*     destruct h_pref as [ts_h es_h]. *)

  (*     destruct es_h as [| h_e t_e]; ss. *)
  (*     + punfold IH. inv IH. *)
  (*       * fold (flatten_tes t_pref). *)
  (*         match goal with *)
  (*         | H: cnil = _ |- _ => rewrite <- H *)
  (*         end. *)
  (*         pfold. econs 1. *)
  (*         apply inftau_lexec_Cons. ss. *)
  (*       * rewrite LOCAL_EXEC_PREFIX. *)
  (*         match goal with *)
  (*         | |- _ _ _ (Cons ?a (stream_app ?l ?c)) _ => *)
  (*           replace (Cons a (stream_app l c)) with *)
  (*               (stream_app (a::l) c) by ss *)
  (*         end. *)
  (*         pfold. econs 2; try reflexivity; eauto. *)
  (*         r. econs; ss. *)

  (*     + pfold. *)
  (*       match goal with *)
  (*       | |- _ _ _ ?c _ => *)
  (*         replace c with (stream_app [] c) by ss *)
  (*       end. *)
  (*       econs 2; try reflexivity; ss. *)
  (*       left. eauto. *)
  (* Qed. *)

  Lemma fmsim_state_adequacy
        st_src st_tgt
        (SAFE: DSys.safe_state st_tgt)
        (FMSIM: fmsim_states st_src st_tgt)
    : DSys.behav_state _ st_tgt <1= DSys.behav_state _ st_src.
  Proof.
    eapply fmsim_states_impl_gmsim_states in FMSIM; eauto.
    eapply gmsim_state_adequacy. eauto.
  Qed.
  (*   intros beh BEH_TGT. *)
  (*   r in BEH_TGT. des. *)
  (*   renames exec EXEC_ST EXEC_BEH into exec_tgt EXEC_TGT BEH_TGT. *)
  (*   r. exists (constr_exec_src _ _ _ SAFE EXEC_TGT FMSIM). *)
  (*   splits. *)
  (*   - eapply exec_state_src. *)
  (*   - r. *)
  (*     apply Forall2_nth. *)
  (*     i. destruct (lt_ge_dec n (DSys.num_sites _ st_src)). *)
  (*     2: { *)
  (*       rewrite nth_error_None2. *)
  (*       2: { rewrite constr_exec_src_length. ss. } *)
  (*       rewrite nth_error_None2. *)
  (*       2: { *)
  (*         eapply fmsim_num_sites_eq in FMSIM; eauto. *)
  (*         eapply exec_state_len in EXEC_TGT. *)
  (*         r in BEH_TGT. apply Forall2_length in BEH_TGT. *)
  (*         nia. *)
  (*       } *)
  (*       econs. *)
  (*     } *)

  (*     r in BEH_TGT. *)
  (*     hexploit (nth_error_Some2 _ beh n). *)
  (*     { apply Forall2_length in BEH_TGT. *)
  (*       eapply fmsim_num_sites_eq in FMSIM; eauto. *)
  (*       apply exec_state_len in EXEC_TGT. *)
  (*       nia. } *)
  (*     i. des. renames e1 NTH_EX into beh_n BEH_N. *)
  (*     eapply Forall2_nth2 in BEH_TGT; eauto. *)
  (*     i. des. *)
  (*     renames e1 NTH1 P_FA into exec_tgt_n EXEC_TGT_N EXBEH_N. *)
  (*     rewrite BEH_N. *)

  (*     unfold constr_exec_src. *)
  (*     rewrite imap_nth_error_iff. ss. *)
  (*     rewrite repeat_nth_error_Some. *)
  (*     2: { eapply fmsim_num_sites_eq in FMSIM; eauto. } *)
  (*     ss. econs. *)
  (*     replace beh_n with (colist_app [] beh_n) by ss. *)
  (*     match goal with *)
  (*     | |- _ ?c _ => *)
  (*       replace c with (stream_app [] c) by ss *)
  (*     end. *)
  (*     eapply constr_local_src_exec_behav; eauto. *)
  (* Qed. *)

  Lemma fmsim_adequacy
        (SAFE_SYS: DSys.safe sys_tgt)
        (FMSIM: fmsim)
    : DSys.behav_sys sys_tgt <1= DSys.behav_sys sys_src.
  Proof.
    eapply fmsim_impl_gmsim in FMSIM; eauto.
    apply gmsim_adequacy. ss.
  Qed.
  (*   intros beh BEH_SYS_TGT. *)
  (*   inv FMSIM. inv SAFE_SYS. *)

  (*   red in BEH_SYS_TGT. des. *)
  (*   { exfalso. eauto. } *)
  (*   clear dependent st_i. *)

  (*   econs 2. *)
  (*   hexploit SIM_INIT_STATES; eauto. i. des. *)
  (*   hexploit fmsim_state_adequacy; eauto. *)
  (* Qed. *)

End SIM.


Require Import GMuAnnot.Prelude.
Require Import GMuAnnot.Infrastructure.
Require Import GMuAnnot.Regularity.
Require Import GMuAnnot.CanonicalForms.
Require Import GMuAnnot.Equations.

#[export] Hint Resolve binds_empty_inv.

Ltac empty_binding :=
  match goal with
  | H: binds ?x ?v empty |- _ => apply binds_empty_inv in H; contradiction
  | _ => fail "no empty bindings found"
  end.

Ltac IHT e :=
  match goal with
  | Ht: {?Σ, ?D, ?E} ⊢(?TT) e ∈ ?T |- _ =>
    match goal with
    | IH: forall T, ?P0 -> {Σ, D, E} ⊢(?TT2) e ∈ T -> ?P |- _ =>
      let H := fresh "IHt" in
      assert P as H; eauto
    end
  end.

Ltac generalize_typings :=
  match goal with
  | [ H: {?Σ, ?D, ?E} ⊢(?TT) ?e ∈ ?T |- _ ] =>
    match TT with
    | Tgen => fail 1
    | Treg => fail 1
    | _ => apply Tgen_from_any in H
    end
  end.

(* TODO: move to Equations *)
Lemma empty_eq_is_equivalent : forall Σ T1 T2,
  entails_semantic Σ emptyΔ (T1 ≡ T2) ->
  T1 = T2.
  introv Sem.
  cbn in *.
  lets M: Sem (@nil (var * typ)).
  forwards * : M.
  constructor.
Qed.

#[export] Hint Constructors value red.
Theorem progress_thm : progress.
  unfold progress.
  introv Typ.
  assert (Hterm: term e).
  1: {
    eapply typing_implies_term; eauto.
  }
  apply Tgen_from_any in Typ. clear TT.

  gen T Hterm.
  induction e using trm_ind;
    introv TypGen Hterm;
    lets [T2 [TypReg EQ]]: inversion_typing_eq TypGen;
    inversion TypReg;
    inversion Hterm;
    subst;
    try solve [
          left*
        | repeat generalize_typings;
          forwards* [Hv1 | [e1' Hred1]]: IHe1;
          forwards* [Hv2 | [e2' Hred2]]: IHe2
        ]; clear TypGen EQ T; try rename T2 into T.
  - empty_binding.
  - repeat generalize_typings.
    forwards * [Hval | [? ?]]: IHe.
  - generalize_typings.
    forwards * [Hval | [? ?]]: IHe.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H0.
    apply empty_eq_is_equivalent in EQ. subst.
    lets* [v1 [v2 ?]]: CanonicalFormTuple Typ2; subst.
    right*.
  - generalize_typings.
    forwards * [Hval | [? ?]]: IHe.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H0.
    apply empty_eq_is_equivalent in EQ. subst.
    lets* [v1 [v2 ?]]: CanonicalFormTuple Typ2; subst.
    right*.
  - repeat generalize_typings.
    forwards * [Hval1 | [? ?]]: IHe1.
    forwards * [Hval2 | [? ?]]: IHe2.
    right.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H5.
    apply empty_eq_is_equivalent in EQ. subst.
    lets* [v1 ?]: CanonicalFormAbs Typ2; subst.
    eexists.
    apply* red_beta.
  - repeat generalize_typings.
    forwards * [Hval1 | [? ?]]: IHe.
    right.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H1.
    apply empty_eq_is_equivalent in EQ. subst.
    lets* [v1 ?]: CanonicalFormTAbs Typ2; subst.
    eexists.
    apply* red_tbeta.
  - repeat generalize_typings.
    right.
    eexists.
    eauto.
  - right.
    rename l into branches.
    repeat generalize_typings.
    forwards * [Hval1 | [? ?]]: IHe.
    lets [T' [Typ2 EQ]]: inversion_typing_eq H3.
    apply empty_eq_is_equivalent in EQ; subst.
    lets* [GCargs [cid [ctor_e ?]]]: CanonicalFormGadt Typ2; subst.
    inversions Typ2.
    match goal with
    | [ H1: binds ?g ?A Σ, H2: binds ?g ?B Σ |- _ ] =>
      let H := fresh "H" in
      lets H: binds_ext H1 H2;
        inversions H
    end.
    match goal with
    | [ Hnth: List.nth_error ?As ?i = Some ?A |- _ ] =>
      match goal with
      | [ Hlen: length As = length ?Bs |- _ ] =>
        lets* [[clA clT] [nth_cl inzip]]: nth_error_implies_zip Hnth Hlen
      end
    end.
    assert (clA = length GCargs).
    * match goal with
      | [ H: forall def clause, List.In (def, clause) ?A -> clauseArity clause = Carity def |- _ ] =>
        lets*: H inzip
      end.
    * subst.
      eexists.
      eauto.
Qed.


Require Import QuantumLib.Permutations.
Require Export UnitaryListRepresentation.
Require Export ConnectivityGraph.
Require Export Layouts.
Require Export MappingConstraints.
Require Import FullGateSet MappingGateSet.

(** Simple strategy for mapping a program to a CNOT connectivity graph.
   When a CNOT occurs between non-adjacent qubits: (1) insert SWAPs to
   make the qubits adjacent, (2) perform the CNOT, (3) update the
   correspondence between logical (program) qubits and physical (machine)
   qubits. In cases where a CNOT is between adjacent qubits but in the wrong
   orientation, insert H gates on the target and control.

   Inputs:
     - a program over logical qubits
     - an initial mapping between logical and physical qubits
     - CNOT connectivity graph information
   Outputs:
     - a program over physical qubits
     - a final mapping between logical and physical qubits

   The proofs all assume that the number of logical and physical qubits ("dim")
   are the same. In practice, we expect that the number of physical qubits
   will be >= the number of logical qubits. For this case, simply "cast" the input
   program to a type with the appropriate dimension.
*)

(** Mapping function definition. *)
Fixpoint path_to_swaps {U dim} p m : (map_ucom_l U dim * layout) :=
  match p with
  | n1 :: n2 :: [] => ([], m)
  | n1 :: ((n2 :: _) as t) =>
      let (l, m') := path_to_swaps t (swap_log m n1 n2) in
      (SWAP n1 n2 :: l, m')
  | _ => ([], m) (* bad input - invaid path *)
  end.

(** The input program references *logical* qubits, and the returned program
   references _physical_ qubits. get_path and is_in_graph_b also reference
   physical qubits. The output of this is a program with SWAPs that respects
   _undirected_ connectivity constraints. *)
Fixpoint swap_route {U dim} (l : map_ucom_l U dim) (m : layout) (get_path : nat -> nat -> list nat) : (map_ucom_l U dim * layout) :=
  match l with
  | [] => ([],m)
  | App1 u n :: t =>
      let (t',m') := swap_route t m get_path in
      (App1 u (get_phys m n) :: t', m')
  | App2 u n1 n2 :: t =>
      let p := get_path (get_phys m n1) (get_phys m n2) in
      let (swaps, m') := path_to_swaps p m in
      let mapped_cnot :=
        swaps ++ [App2 u (get_phys m' n1) (get_phys m' n2)] in
      let (t',m'') := swap_route t m' get_path in
      (mapped_cnot ++ t', m'')
  | _ => ([], m) (* unreachable due to the gate set *)
  end.

Definition H {dim} a : gate_app (Map_Unitary (Full_Unitary 1)) dim :=
  App1 (UMap_U FullGateSet.U_H) a.

(** Decompose SWAPs when they allow cancelling CNOTs. *)
Fixpoint cancel_cnots_with_swaps' {U dim} (l : map_ucom_l U dim) fuel acc :=
  match fuel with
  | O => rev_append acc l
  | S fuel =>
      match l with
      | [] => rev_append acc []
      | App2 UMap_CNOT m n :: t =>
          match (next_two_qubit_gate t m) with
          | Some (t1, UMap_SWAP, m', n', t2) =>
              if (m =? m') && (n =? n') && (does_not_reference t1 n)
              then cancel_cnots_with_swaps' (t1 ++ [CNOT n m] ++ [CNOT m n] ++ t2) fuel acc
              else if (m =? n') && (n =? m') && (does_not_reference t1 n)
                   then cancel_cnots_with_swaps' (t1 ++ [CNOT m' n'] ++ [CNOT n' m'] ++ t2) fuel acc
                   else cancel_cnots_with_swaps' t fuel (CNOT m n :: acc)
          | _ => cancel_cnots_with_swaps' t fuel (CNOT m n :: acc)
          end
      | App2 UMap_SWAP m n :: t =>
          match (next_two_qubit_gate t m) with
          | Some (t1, UMap_CNOT, m', n', t2) =>
              if (m =? m') && (n =? n') && (does_not_reference t1 n)
              then cancel_cnots_with_swaps' ([CNOT m n] ++ [CNOT n m] ++ t1 ++ t2) fuel acc
              else if (m =? n') && (n =? m') && (does_not_reference t1 n)
                   then cancel_cnots_with_swaps' ([CNOT n m] ++ [CNOT m n] ++ t1 ++ t2) fuel acc
                   else cancel_cnots_with_swaps' t fuel (SWAP m n :: acc)
          | _ => cancel_cnots_with_swaps' t fuel (SWAP m n :: acc)
          end
      | u :: t => cancel_cnots_with_swaps' t fuel (u :: acc)
      end
  end.

(* For the fuel, we need to account for the fact that decomposing SWAPs add new gates
   into the list used in the recursive call *)
Fixpoint fuel_aux {U dim} (l : map_ucom_l U dim) acc :=
  match l with
  | [] => acc
  | App2 UMap_SWAP m n :: t => fuel_aux t (acc + 3)%nat
  | _ :: t => fuel_aux t (S acc)
  end.

Definition cancel_cnots_with_swaps {U dim} (l : map_ucom_l U dim) :=
  cancel_cnots_with_swaps' l (fuel_aux l O) [].

(** Finally, decompose all SWAP gates and ensures that the output satisfies
   directed connectivity contraints. This function is specialized to the Full
   gate set where we have access to a Hadamard gate. *)
Definition decompose_swaps_and_cnots_aux {dim} (is_in_graph : nat -> nat -> bool) (g : gate_app (Map_Unitary (Full_Unitary 1)) dim) : map_ucom_l (Full_Unitary 1) dim :=
  match g with
  | App2 UMap_CNOT m n =>
      if is_in_graph m n
      then [CNOT m n]
      else H m :: H n :: CNOT n m :: H m :: H n :: []
  | App2 UMap_SWAP m n =>
      if is_in_graph m n
      then if is_in_graph n m
           then CNOT m n :: CNOT n m :: CNOT m n :: []
           else CNOT m n :: H n :: H m :: CNOT m n :: H n :: H m :: CNOT m n :: []
      else CNOT n m :: H m :: H n :: CNOT n m :: H m :: H n :: CNOT n m :: []
  | g => [g]
  end.

Definition decompose_swaps_and_cnots {dim} (l : map_ucom_l (Full_Unitary 1) dim) (is_in_graph : nat -> nat -> bool) :=
  change_gate_set
    (decompose_swaps_and_cnots_aux is_in_graph) (cancel_cnots_with_swaps l).

(** * Proofs *)

Local Close Scope C_scope.
Local Close Scope R_scope.
Local Close Scope Q_scope.

Definition perm_pair dim p1 p2 :=
  permutation dim p1 /\
  permutation dim p2 /\
  (forall x, x < dim -> p1 (p2 x) = x) /\
  (forall x, x < dim -> p2 (p1 x) = x).

Lemma perm_pair_get_log_phys: forall dim m,
  layout_bijective dim m ->
  perm_pair dim (get_log m) (get_phys m).
Proof.
  intros dim m.
  repeat split.
  apply get_log_perm. auto.
  apply get_phys_perm. auto.
  intros. apply get_log_phys_inv with (n:=dim); auto.
  intros. apply get_phys_log_inv with (n:=dim); auto.
Qed.

Lemma perm_pair_get_phys_log: forall dim m,
  layout_bijective dim m ->
  perm_pair dim (get_phys m) (get_log m).
Proof.
  intros dim m.
  repeat split.
  apply get_phys_perm. auto.
  apply get_log_perm. auto.
  intros. apply get_phys_log_inv with (n:=dim); auto.
  intros. apply get_log_phys_inv with (n:=dim); auto.
Qed.

Lemma permute_commutes_with_map_qubits : forall dim (u : base_ucom dim) p1 p2,
  perm_pair dim p1 p2 ->
  uc_well_typed u ->
  perm_to_matrix dim p1 × uc_eval u =
    uc_eval (map_qubits p2 u) × perm_to_matrix dim p1.
Proof.
  intros dim u p1 p2 [? [? [? ?]]] WT.
  induction u; try dependent destruction u;
  inversion WT; subst; simpl.
  - rewrite <- Mmult_assoc.
    rewrite IHu2 by assumption.
    rewrite Mmult_assoc.
    rewrite IHu1 by assumption.
    rewrite <- Mmult_assoc.
    reflexivity.
  - apply equal_on_basis_states_implies_equal; auto with wf_db.
    intro f.
    repeat rewrite Mmult_assoc.
    rewrite perm_to_matrix_permutes_qubits by assumption.
    assert (p2 n < dim).
    { destruct H1 as [? H1].
      specialize (H1 n H5).
      destruct H1. auto. }
    unfold pad_u, pad.
    bdestruct_all.
    rewrite (f_to_vec_split 0 dim n) by assumption.
    rewrite (f_to_vec_split 0 dim (p2 n)) by assumption.
    restore_dims.
    replace (dim - 1 - n) with (dim - (n + 1)) by lia.
    replace (dim - 1 - p2 n) with (dim - (p2 n + 1)) by lia.
    Msimpl.
    rewrite H2; auto.
    rewrite (ket_decomposition (rotation r r0 r1 × ∣ Nat.b2n (f n) ⟩));
      auto with wf_db.
    distribute_plus.
    distribute_scale.
    apply f_equal2; apply f_equal2; try reflexivity.
    + remember (update f n false) as f0.
      replace (f_to_vec n f) with (f_to_vec n f0).
      replace ∣ 0 ⟩ with  ∣ Nat.b2n (f0 n) ⟩.
      replace (f_to_vec (dim - (n + 1)) (shift f (n + 1)))
        with (f_to_vec (dim - (n + 1)) (shift f0 (n + 1))).
      replace (dim - (n + 1)) with (dim - 1 - n) by lia.
      rewrite <- f_to_vec_split by auto.
      rewrite perm_to_matrix_permutes_qubits by assumption.
      remember (update (fun x : nat => f (p1 x)) (p2 n) false) as f0'.
      replace (f_to_vec dim (fun x : nat => f0 (p1 x))) with (f_to_vec dim f0').
      rewrite (f_to_vec_split 0 dim (p2 n)) by auto.
      replace (dim - 1 - p2 n) with (dim - (p2 n + 1)) by lia.
      apply f_equal2; [apply f_equal2 |].
      all: subst.
      1,7: apply f_to_vec_update_oob; lia.
      1,5: repeat rewrite update_index_eq; reflexivity.
      1,3: apply f_to_vec_shift_update_oob; right; lia.
      apply f_to_vec_eq.
      intros x Hx.
      unfold update.
      bdestruct (x =? p2 n); subst.
      rewrite H2 by auto.
      bdestruct_all; trivial.
      bdestruct_all; trivial.
      rewrite <- H9 in H8.
      rewrite H3 in H8 by auto.
      contradiction.
    + remember (update f n true) as f1.
      replace (f_to_vec n f) with (f_to_vec n f1).
      replace ∣ 1 ⟩ with  ∣ Nat.b2n (f1 n) ⟩.
      replace (f_to_vec (dim - (n + 1)) (shift f (n + 1)))
        with (f_to_vec (dim - (n + 1)) (shift f1 (n + 1))).
      replace (dim - (n + 1)) with (dim - 1 - n) by lia.
      rewrite <- f_to_vec_split by auto.
      rewrite perm_to_matrix_permutes_qubits by assumption.
      remember (update (fun x : nat => f (p1 x)) (p2 n) true) as f1'.
      replace (f_to_vec dim (fun x : nat => f1 (p1 x))) with (f_to_vec dim f1').
      rewrite (f_to_vec_split 0 dim (p2 n)) by auto.
      replace (dim - 1 - p2 n) with (dim - (p2 n + 1)) by lia.
      apply f_equal2; [apply f_equal2 |].
      all: subst.
      1,7: apply f_to_vec_update_oob; lia.
      1,5: repeat rewrite update_index_eq; reflexivity.
      1,3: apply f_to_vec_shift_update_oob; right; lia.
      apply f_to_vec_eq.
      intros x Hx.
      unfold update.
      bdestruct (x =? p2 n); subst.
      rewrite H2 by auto.
      bdestruct_all; trivial.
      bdestruct_all; trivial.
      rewrite <- H9 in H8.
      rewrite H3 in H8 by auto.
      contradiction.
  - apply equal_on_basis_states_implies_equal; auto with wf_db.
    intro f.
    repeat rewrite Mmult_assoc.
    rewrite perm_to_matrix_permutes_qubits by assumption.
    replace (ueval_cnot dim n n0) with (uc_eval (@SQIR.CNOT dim n n0)) by reflexivity.
    rewrite f_to_vec_CNOT by assumption.
    rewrite perm_to_matrix_permutes_qubits by assumption.
    replace (ueval_cnot dim (p2 n) (p2 n0))
      with (uc_eval (@SQIR.CNOT dim (p2 n) (p2 n0))) by reflexivity.
    assert (p2 n < dim).
    { destruct H1 as [? H1].
      specialize (H1 n H7).
      destruct H1. auto. }
    assert (p2 n0 < dim).
    { destruct H1 as [? H1].
      specialize (H1 n0 H8).
      destruct H1. auto. }
    rewrite f_to_vec_CNOT; auto.
    apply f_to_vec_eq.
    intros x Hx.
    unfold update.
    rewrite 2 H2 by auto.
    bdestruct_all; try reflexivity.
    rewrite <- H6 in H10.
    rewrite H3 in H10 by auto.
    contradiction.
    rewrite H10 in H6.
    rewrite H2 in H6 by auto.
    contradiction.
    intro contra.
    assert (p1 (p2 n) = p1 (p2 n0)) by auto.
    rewrite 2 H2 in H6 by auto.
    contradiction.
Qed.

(** Proofs for any gate set. *)

Module SwapRouteProofs (G : GateSet).

Definition ucom_l dim := map_ucom_l (G.U 1) dim.

Module MapG := MappingGateSet G.
Module MapList := UListProofs MapG.
Import MapList.

(** Equivalence up to qubit reordering w/ explicit input and output permutations **)
Definition uc_equiv_perm_ex {dim} (l1 l2 : ucom_l dim) pin pout :=
  eval l1 = perm_to_matrix dim pout × eval l2 × perm_to_matrix dim pin.
Notation "c1 ≡ c2 'with' p1 'and' p2" := (uc_equiv_perm_ex c1 c2 p1 p2) (at level 20).

Lemma uc_equiv_perm_ex_nil : forall {dim} p1 p2,
  dim > 0 ->
  perm_pair dim p1 p2 ->
  @uc_equiv_perm_ex dim [] [] p1 p2.
Proof.
  intros dim p1 p2 Hdim [? [? [? ?]]].
  unfold uc_equiv_perm_ex.
  unfold eval; simpl.
  rewrite denote_SKIP by assumption.
  Msimpl.
  rewrite perm_to_matrix_Mmult, perm_to_matrix_I; auto.
  apply permutation_compose; auto.
Qed.

Lemma SWAP_well_typed : forall dim a b,
  a < dim -> b < dim -> a <> b ->
  uc_well_typed (list_to_ucom ([@SWAP _ dim a b])).
Proof.
  intros.
  simpl.
  constructor.
  apply uc_well_typed_SWAP; lia.
  apply uc_well_typed_ID.
  lia.
Qed.

Lemma SWAP_semantics : forall dim a b,
  dim > 0 -> eval ([@SWAP _ dim a b]) = uc_eval (SQIR.SWAP a b).
Proof.
  intros.
  unfold eval.
  simpl.
  rewrite denote_SKIP by auto.
  Msimpl.
  reflexivity.
Qed.

Lemma path_to_swaps_bijective : forall {dim} p m (l : ucom_l dim) m',
  path_well_typed p dim ->
  layout_bijective dim m ->
  path_to_swaps p m = (l, m') ->
  layout_bijective dim m'.
Proof.
  intros.
  generalize dependent l.
  generalize dependent m.
  induction p; intros m WFm c res; simpl in res.
  inversion res; subst. assumption.
  destruct p. inversion res; subst. assumption.
  destruct p. inversion res; subst. assumption.
  destruct (path_to_swaps (n :: n0 :: p) (swap_log m a n)) eqn:res'.
  inversion res; subst.
  inversion H0; subst.
  eapply IHp; try apply res'; auto.
  apply swap_log_preserves_bij; auto.
Qed.

Lemma fswap_swap_log : forall dim m (f : nat -> bool) a b x,
  a < dim -> b < dim -> x < dim -> a <> b ->
  layout_bijective dim m ->
  fswap f a b (get_phys (swap_log m a b) x) = f (get_phys m x).
Proof.
  intros dim m f a b x Ha Hb Hx Hab H.
  bdestruct (x =? get_log m a); bdestruct (x =? get_log m b); subst.
  - assert (get_phys m (get_log m a) = get_phys m (get_log m b)) by auto.
    erewrite 2 get_phys_log_inv in H0.
    contradiction.
    apply H. apply Hb.
    apply H. apply Ha.
  - unfold get_phys at 1.
    rewrite find_phys_swap_log_1 with (n:=dim) by auto.
    rewrite fswap_simpl2.
    erewrite get_phys_log_inv.
    reflexivity. apply H. apply Ha.
  - unfold get_phys at 1.
    rewrite find_phys_swap_log_2 with (n:=dim) by auto.
    rewrite fswap_simpl1.
    erewrite get_phys_log_inv.
    reflexivity. apply H. apply Hb.
  - unfold get_phys at 1.
    rewrite find_phys_swap_log_3 with (n:=dim); auto.
    replace (match find_phys m x with
             | Some p => p
             | None => 0
             end) with (get_phys m x) by reflexivity.
    rewrite fswap_neq.
    reflexivity.
    intro contra.
    rewrite contra in H0.
    erewrite get_log_phys_inv in H0.
    contradiction.
    apply H. apply Hx.
    intro contra.
    rewrite contra in H1.
    erewrite get_log_phys_inv in H1.
    contradiction.
    apply H. apply Hx.
    intro contra.
    unfold get_log in H0.
    rewrite contra in H0.
    contradiction.
    intro contra.
    unfold get_log in H1.
    rewrite contra in H1.
    contradiction.
Qed.

Lemma path_to_swaps_sound : forall dim p m l m',
  dim > 0 ->
  path_well_typed p dim ->
  layout_bijective dim m ->
  path_to_swaps p m = (l, m') ->
  @uc_equiv_perm_ex dim l [] (get_phys m) (get_log m').
Proof.
  intros dim p m l m' Hdim WTp.
  generalize dependent l.
  generalize dependent m.
  induction p; intros m l WFm res; simpl in res.
  inversion res; subst.
  apply uc_equiv_perm_ex_nil; auto.
  apply perm_pair_get_phys_log; auto.
  destruct p.
  inversion res; subst.
  apply uc_equiv_perm_ex_nil; auto.
  apply perm_pair_get_phys_log; auto.
  destruct p.
  inversion res; subst.
  apply uc_equiv_perm_ex_nil; auto.
  apply perm_pair_get_phys_log; auto.
  inversion WTp; subst.
  - (* inductive case *)
    destruct (path_to_swaps (n :: n0 :: p) (swap_log m a n)) eqn:res'.
    inversion res; subst.
    assert (WFm':=res').
    eapply path_to_swaps_bijective in WFm'; auto.
    eapply IHp in res'; auto.
    unfold uc_equiv_perm_ex in *.
    rewrite cons_to_app.
    rewrite eval_append, res'.
    repeat rewrite Mmult_assoc.
    apply f_equal2; try reflexivity.
    apply f_equal2; try reflexivity.
    apply equal_on_basis_states_implies_equal; auto with wf_db.
    unfold eval; auto with wf_db.
    intro f.
    rewrite Mmult_assoc.
    rewrite SWAP_semantics by assumption.
    rewrite f_to_vec_SWAP by assumption.
    rewrite perm_to_matrix_permutes_qubits.
    rewrite perm_to_matrix_permutes_qubits.
    apply f_to_vec_eq.
    intros x Hx.
    apply fswap_swap_log with (dim:=dim); auto.
    apply get_phys_perm; assumption.
    apply get_phys_perm.
    apply swap_log_preserves_bij; assumption.
    apply swap_log_preserves_bij; assumption.
    apply swap_log_preserves_bij; assumption.
Qed.

(* These uc_eq_perm_* lemmas are specific to swap_route_sound -- they help
   keep the main proof a little cleaner *)

Lemma uc_equiv_perm_ex_cons_cong : forall {dim} (g : gate_app (Map_Unitary (G.U 1)) dim) (l1 l2 : ucom_l dim) p p1 p2,
  perm_pair dim p1 p2 ->
  uc_well_typed_l [g] ->
  l1 ≡ l2 with p1 and p ->
  (g :: l1) ≡ ((map_qubits_app p2 g) :: l2) with p1 and p.
Proof.
  intros dim g l1 l2 p p1 p2 Hperm WT H.
  unfold uc_equiv_perm_ex in *.
  rewrite (cons_to_app _ l1).
  rewrite (cons_to_app _ l2).
  rewrite 2 eval_append.
  rewrite H.
  repeat rewrite Mmult_assoc.
  apply f_equal2; try reflexivity.
  apply f_equal2; try reflexivity.
  unfold eval.
  rewrite map_qubits_app_equiv_map_qubits.
  apply permute_commutes_with_map_qubits.
  assumption.
  subst.
  apply list_to_ucom_WT.
  assumption.
  apply uc_well_typed_l_implies_dim_nonzero in WT.
  assumption.
  destruct Hperm as [_ [? _]].
  assumption.
Qed.

Lemma uc_equiv_perm_ex_uc_equiv_l_app : forall {dim} (l l1 l1' l2 : ucom_l dim) p_in p_out,
  uc_equiv_l l1 l1' ->
  l ≡ l1 ++ l2 with p_in and p_out ->
  l ≡ l1' ++ l2 with p_in and p_out.
Proof.
  intros dim l l1 l1' l2 p_in p_out H1 H2.
  unfold uc_equiv_l, uc_equiv, uc_equiv_perm_ex in *.
  rewrite eval_append in *.
  unfold eval in *.
  rewrite H2, H1.
  reflexivity.
Qed.

Lemma uc_equiv_perm_ex_app1 : forall {dim} (l1 l1' l2 l2' : ucom_l dim) p1 p1inv p2 p3,
  perm_pair dim p1 p1inv ->
  l1 ≡ l1' with p1 and p2 ->
  l2 ≡ l2' with p2 and p3 ->
  (l1' ++ l2) ≡ l1 ++ l2' with p1inv and p3.
Proof.
  intros dim l1 l1' l2 l2' p1 p1inv p2 p3 [H1 [H2 [_ H3]]] H4 H5.
  unfold uc_equiv_perm_ex in *.
  rewrite 2 eval_append.
  rewrite H4, H5.
  repeat rewrite Mmult_assoc.
  rewrite perm_to_matrix_Mmult by auto.
  rewrite (perm_to_matrix_I _ (p1inv ∘ p1)%prg).
  Msimpl.
  reflexivity.
  unfold eval; auto with wf_db.
  apply permutation_compose; auto.
  intros x Hx.
  apply H3. auto.
Qed.

Lemma uc_equiv_perm_ex_app2 : forall {dim} (l1 l2 : ucom_l dim) (g : gate_app (Map_Unitary (G.U 1)) dim) p1 p2 p3,
  perm_pair dim p2 p3 ->
  uc_well_typed_l [g] ->
  l1 ≡ l2 with p1 and p2 ->
  (l1 ++ [map_qubits_app p3 g]) ≡ l2 ++ [g] with p1 and p2.
Proof.
  intros dim l1 l2 g p1 p2 p3 Hperm WT H.
  unfold uc_equiv_perm_ex in *.
  rewrite 2 eval_append.
  rewrite H.
  repeat rewrite <- Mmult_assoc.
  apply f_equal2; try reflexivity.
  apply f_equal2; try reflexivity.
  unfold eval.
  rewrite map_qubits_app_equiv_map_qubits.
  symmetry.
  apply permute_commutes_with_map_qubits.
  assumption.
  apply list_to_ucom_WT.
  assumption.
  apply uc_well_typed_l_implies_dim_nonzero in WT.
  assumption.
  destruct Hperm as [_ [? _]].
  assumption.
Qed.

Lemma uc_equiv_perm_ex_trans_r : forall {dim} (l1 l2 l3 : ucom_l dim) p_in p_out,
  uc_equiv_l l2 l3 ->
  l1 ≡ l2 with p_in and p_out ->
  l1 ≡ l3 with p_in and p_out.
Proof.
  intros dim l1 l2 l3 p_in p_out H1 H2.
  unfold uc_equiv_l, uc_equiv, uc_equiv_perm_ex, eval in *.
  rewrite H2, H1.
  reflexivity.
Qed.

Lemma uc_equiv_perm_ex_trans_l : forall {dim} (l1 l2 l3 : ucom_l dim) p_in p_out,
  uc_equiv_l l1 l2 ->
  l2 ≡ l3 with p_in and p_out ->
  l1 ≡ l3 with p_in and p_out.
Proof.
  intros dim l1 l2 l3 p_in p_out H1 H2.
  unfold uc_equiv_l, uc_equiv, uc_equiv_perm_ex, eval in *.
  rewrite H1, H2.
  reflexivity.
Qed.

(* Example: Consider an architecture with 3 qubits and LNN connectivity:
       0 <-> 1 <-> 2.
   Say we want to map the following program with input layout
   m_in={0->1, 1->2, 2->0} (where l->p means that logical qubit l is bound
   to physical qubit p):
       P1  :=  H 1; CNOT 1 2; H 1.
   The output of mapping will be the program
       P2  :=  H 2; SWAP 1 2; CNOT 1 0; H 1
   and the map m_out={0->2, 1->1, 2->0}.

   Running program P1 on input state ∣abc⟩, measuring all qubits, and obtaining
   result ∣def⟩ (a,b,c,d,e,f ∈ {0,1}) is equivalent to running program P2 on input
   state ∣cab⟩ and obtaining the result ∣fed⟩.

   We express this relationship as "P1 ≡ P2 with p_in and p_out", which says that
   uc_eval P1 = p_in × uc_eval P2 × p_out where permutation p_in=(get_log m)
   is the inverse of the input logical->physical qubit map and permutation
   p_out=(get_phys m') is the output logical->physical qubit map.
*)
Lemma swap_route_sound : forall {dim} (l l' : ucom_l dim) (m m' : layout) get_path,
  uc_well_typed_l l ->
  layout_bijective dim m ->
  (forall n1 n2, n1 < dim -> n2 < dim -> n1 <> n2 -> path_well_typed (get_path n1 n2) dim) ->
  swap_route l m get_path = (l', m') ->
  l ≡ l' with (get_log m) and (get_phys m').
Proof.
  intros dim l l' m m' get_path WT WFm WTp H.
  generalize dependent m'.
  generalize dependent m.
  generalize dependent l'.
  induction l; intros l' m WFm m' res; simpl in res.
  - inversion res; subst.
    apply uc_equiv_perm_ex_nil; auto.
    apply uc_well_typed_l_implies_dim_nonzero in WT.
    assumption.
    apply perm_pair_get_log_phys.
    assumption.
  - destruct a; inversion WT; subst.
    + destruct (swap_route l m) eqn:res'.
      inversion res; subst.
      apply IHl in res'; auto.
      replace (App1 m0 (get_phys m n)) with (@map_qubits_app _ dim (get_phys m) (App1 m0 n)) by reflexivity.
      apply uc_equiv_perm_ex_cons_cong; auto.
      apply perm_pair_get_log_phys.
      assumption.
      constructor.
      assumption.
      constructor.
      apply uc_well_typed_l_implies_dim_nonzero in WT.
      assumption.
    + destruct (path_to_swaps (get_path (get_phys m n) (get_phys m n0)) m) eqn:pth.
      destruct (swap_route l l0) eqn:res'.
      inversion res; subst.
      assert (pth':=pth).
      assert (get_phys m n < dim).
      { apply get_phys_lt; assumption. }
      assert (get_phys m n0 < dim).
      { apply get_phys_lt; assumption. }
      assert (get_phys m n <> get_phys m n0).
      { apply get_phys_neq with (dim:=dim); assumption. }
      eapply path_to_swaps_bijective in pth'; auto.
      eapply path_to_swaps_sound in pth; auto.
      apply IHl in res'; auto.
      rewrite (cons_to_app _ l).
      eapply uc_equiv_perm_ex_app1.
      apply perm_pair_get_phys_log.
      assumption.
      2: apply res'.
      replace (App2 m0 (get_phys l0 n) (get_phys l0 n0)) with (@map_qubits_app _ dim (get_phys l0) (App2 m0 n n0)) by reflexivity.
      rewrite <- (app_nil_l [App2 m0 _ _]).
      apply uc_equiv_perm_ex_app2.
      apply perm_pair_get_log_phys.
      assumption.
      constructor; try assumption.
      constructor.
      lia.
      apply pth.
      lia.
    + dependent destruction m0.
Qed.

Lemma swap_route_WT : forall {dim} (l : ucom_l dim) (m : layout) l' m' get_path,
  uc_well_typed_l l ->
  layout_bijective dim m ->
  (forall n1 n2, n1 < dim -> n2 < dim -> n1 <> n2 -> path_well_typed (get_path n1 n2) dim) ->
  swap_route l m get_path = (l', m') ->
  uc_well_typed_l l'.
Proof.
  intros dim l m l' m' get_path WT WF WTp res.
  apply swap_route_sound in res; auto.
  unfold uc_equiv_perm_ex, eval in res.
  apply list_to_ucom_WT.
  apply uc_eval_nonzero_iff.
  apply list_to_ucom_WT in WT.
  apply uc_eval_nonzero_iff in WT.
  intro contra.
  rewrite contra in res.
  rewrite Mmult_0_r, Mmult_0_l in res.
  contradiction.
Qed.

Lemma swap_route_WF : forall {dim} (l l' : ucom_l dim) (m m' : layout) get_path,
  uc_well_typed_l l ->
  layout_bijective dim m ->
  (forall n1 n2, n1 < dim -> n2 < dim -> n1 <> n2 -> path_well_typed (get_path n1 n2) dim) ->
  swap_route l m get_path = (l', m') ->
  layout_bijective dim m'.
Proof.
  intros dim l l' m m' get_path WT WF WTp H.
  generalize dependent m'.
  generalize dependent m.
  generalize dependent l'.
  induction l; intros l' m WF m' res; simpl in res.
  - inversion res; subst. auto.
  - destruct a; inversion WT; subst.
    + destruct (swap_route l m) eqn:res'.
      inversion res; subst.
      apply IHl in res'; auto.
    + destruct (path_to_swaps (get_path (get_phys m n) (get_phys m n0)) m) eqn:pth.
      destruct (swap_route l l0 get_path) eqn:res'.
      inversion res; subst.
      apply IHl in res'; auto.
      apply path_to_swaps_bijective in pth; auto.
      apply WTp.
      apply get_phys_lt; assumption.
      apply get_phys_lt; assumption.
      apply get_phys_neq with (dim:=dim); assumption.
    + dependent destruction m0.
Qed.

Lemma path_to_swaps_respects_undirected : forall {dim} n1 n2 p m (l : ucom_l dim) m' is_in_graph u,
  n1 < dim -> n2 < dim ->
  valid_path (get_phys m n1) (get_phys m n2) is_in_graph dim p ->
  layout_bijective dim m ->
  path_to_swaps p m = (l, m') ->
  respects_constraints_undirected is_in_graph (l ++ [App2 u (get_phys m' n1) (get_phys m' n2)]).
Proof.
  intros dim n1 n2 p m l m' is_in_graph u Hn1 Hn2 Hpath WF res.
  generalize dependent l.
  generalize dependent m.
  generalize dependent n1.
  induction p; intros n1 Hn1 m Hpath WF l res; simpl in res.
  destruct Hpath as [H _].
  inversion H.
  destruct p.
  destruct Hpath as [_ [_ [H _]]].
  inversion H.
  destruct p.
  inversion res; subst.
  constructor; [| constructor].
  destruct Hpath as [H1 [H2 [H3 [H4 H5]]]].
  inversion H1; subst.
  inversion H2; subst.
  inversion H3; subst.
  inversion H7; subst.
  assumption.
  inversion H8.
  inversion H7; subst.
  assumption.
  inversion H8.
  destruct (path_to_swaps (n :: n0 :: p) (swap_log m a n)) eqn:res'.
  inversion res; subst.
  apply IHp with (n1:=n1) in res'; auto; clear IHp.
  rewrite <- app_comm_cons.
  constructor; auto.
  destruct Hpath as [_ [_ [H _]]].
  inversion H; auto.
  replace a with (get_phys m n1) in *.
  replace (get_phys (swap_log m (get_phys m n1) n) n1) with n.
  replace (get_phys (swap_log m (get_phys m n1) n) n2) with (get_phys m n2).
  apply valid_path_subpath in Hpath.
  assumption.
  unfold get_phys at 2.
  rewrite find_phys_swap_log_3 with (n:=dim); auto.
  apply get_phys_lt; auto.
  destruct Hpath as [_ [_ [_ [H _]]]].
  inversion H; auto.
  intro contra.
  assert (H : get_log m (get_phys m n1) = n2).
  unfold get_log.
  rewrite contra; auto.
  rewrite get_log_phys_inv with (n:=dim) in H; auto.
  subst.
  destruct Hpath as [_ [_ [_ [_ H]]]].
  inversion H.
  contradiction.
  intro contra.
  destruct WF as [WF _].
  apply WF in contra.
  assert (H : get_phys m n2 = n).
  unfold get_phys.
  rewrite contra; auto.
  destruct Hpath as [_ [_ [_ [_ H1]]]].
  inversion H1.
  inversion H6; subst.
  contradiction.
  contradiction.
  unfold get_phys at 1.
  rewrite <- (get_log_phys_inv dim m n1) at 2; auto.
  rewrite find_phys_swap_log_1 with (n:=dim); auto.
  apply get_phys_lt; auto.
  destruct Hpath as [_ [_ [_ [H _]]]].
  inversion H; auto.
  destruct Hpath as [H _].
  inversion H; auto.
  destruct Hpath as [_ [_ [_ [H _]]]].
  inversion H; auto.
  apply swap_log_preserves_bij; auto.
Qed.

Lemma swap_route_respects_undirected : forall {dim} l m (l' : ucom_l dim) m' get_path is_in_graph,
  uc_well_typed_l l ->
  layout_bijective dim m ->
  get_path_valid dim get_path is_in_graph ->
  swap_route l m get_path = (l', m') ->
  respects_constraints_undirected is_in_graph l'.
Proof.
  intros dim l m l' m' get_path is_in_graph WT WFm Hpath H.
  generalize dependent m'.
  generalize dependent m.
  generalize dependent l'.
  induction l; intros l' m WFm m' res; simpl in res.
  - inversion res; subst. constructor.
  - destruct a; inversion WT; subst.
    + destruct (swap_route l m) eqn:res'.
      inversion res; subst.
      constructor.
      eapply IHl. assumption. apply WFm. apply res'.
    + destruct (path_to_swaps (get_path (get_phys m n) (get_phys m n0)) m) eqn:pth.
      destruct (swap_route l l0) eqn:res'.
      inversion res; subst.
      apply respects_constraints_undirected_app.
      eapply path_to_swaps_respects_undirected; auto.
      2: apply WFm.
      2: apply pth.
      apply Hpath.
      apply get_phys_lt; auto.
      apply get_phys_lt; auto.
      apply get_phys_neq with (dim:=dim); auto.
      eapply IHl; auto.
      2: apply res'.
      eapply path_to_swaps_bijective.
      2: apply WFm.
      2: apply pth.
      apply Hpath.
      apply get_phys_lt; auto.
      apply get_phys_lt; auto.
      apply get_phys_neq with (dim:=dim); auto.
    + dependent destruction m0.
Qed.

Ltac easy_case IH := rewrite IH; simpl; rewrite <- app_assoc; reflexivity.

Local Transparent SQIR.CNOT SQIR.SWAP.
Lemma cancel_cnots_with_swaps'_sound : forall {dim} (l : ucom_l dim) fuel acc,
  (cancel_cnots_with_swaps' l fuel acc =l= rev acc ++ l)%ucom.
Proof.
  intros dim l fuel acc.
  gen l acc.
  induction fuel; intros l acc; simpl.
  rewrite rev_append_rev. reflexivity.
  destruct l.
  rewrite rev_append_rev. reflexivity.
  destruct g; dependent destruction m.
  easy_case IHfuel.
  - destruct (next_two_qubit_gate l n) eqn:ntqg.
    2: easy_case IHfuel.
    repeat destruct p.
    dependent destruction m.
    easy_case IHfuel.
    destruct ((n =? n2) && (n0 =? n1) && does_not_reference g0 n0) eqn:cond;
      [| destruct ((n =? n1) && (n0 =? n2) && does_not_reference g0 n0) eqn:cond'];
      try easy_case IHfuel.
    + apply andb_prop in cond as [cond dnr].
      apply andb_prop in cond as [cond1 cond2].
      apply Nat.eqb_eq in cond1; apply Nat.eqb_eq in cond2; subst.
      assert ([CNOT n2 n1] ++ g0 =l= g0 ++ [CNOT n2 n1])%ucom.
      apply does_not_reference_commutes_app2.
      eapply ntqg_l1_does_not_reference. apply ntqg.
      assumption.
      rewrite IHfuel.
      apply ntqg_preserves_structure in ntqg.
      rewrite ntqg.
      rewrite cons_to_app.
      rewrite (cons_to_app _ g).
      rewrite (cons_to_app _ (_ ++ _)).
      apply_app_congruence.
      rewrite 2 app_assoc.
      rewrite H0.
      apply_app_congruence.
      unfold uc_equiv_l; simpl.
      destruct (uc_well_typed_b (@SQIR.CNOT dim n2 n1)) eqn:WTb.
      apply uc_well_typed_b_equiv in WTb.
      inversion WTb; subst.
      unfold SQIR.SWAP.
      repeat rewrite <- useq_assoc.
      rewrite CNOT_CNOT_id by assumption.
      rewrite SKIP_id_l.
      reflexivity.
      apply not_true_iff_false in WTb.
      rewrite uc_well_typed_b_equiv in WTb.
      apply uc_eval_zero_iff in WTb.
      unfold uc_equiv; simpl in *.
      rewrite WTb. Msimpl_light. reflexivity.
    + clear cond.
      apply andb_prop in cond' as [cond' dnr].
      apply andb_prop in cond' as [cond1 cond2].
      apply Nat.eqb_eq in cond1; apply Nat.eqb_eq in cond2; subst.
      assert ([CNOT n1 n2] ++ g0 =l= g0 ++ [CNOT n1 n2])%ucom.
      apply does_not_reference_commutes_app2.
      eapply ntqg_l1_does_not_reference. apply ntqg.
      assumption.
      rewrite IHfuel.
      apply ntqg_preserves_structure in ntqg.
      rewrite ntqg.
      rewrite cons_to_app.
      rewrite (cons_to_app _ g).
      rewrite (cons_to_app _ (_ ++ _)).
      apply_app_congruence.
      rewrite 2 app_assoc.
      rewrite H0.
      apply_app_congruence.
      unfold uc_equiv_l; simpl.
      destruct (uc_well_typed_b (@SQIR.CNOT dim n2 n1)) eqn:WTb.
      apply uc_well_typed_b_equiv in WTb.
      inversion WTb; subst.
      rewrite SWAP_symmetric.
      unfold SQIR.SWAP.
      repeat rewrite <- useq_assoc.
      rewrite CNOT_CNOT_id by auto.
      rewrite SKIP_id_l.
      reflexivity.
      apply not_true_iff_false in WTb.
      rewrite uc_well_typed_b_equiv in WTb.
      apply uc_eval_zero_iff in WTb.
      unfold uc_equiv; simpl in *.
      rewrite WTb. Msimpl_light. reflexivity.
  - destruct (next_two_qubit_gate l n) eqn:ntqg.
    2: easy_case IHfuel.
    repeat destruct p.
    dependent destruction m.
    2: easy_case IHfuel.
    destruct ((n =? n2) && (n0 =? n1) && does_not_reference g0 n0) eqn:cond;
      [| destruct ((n =? n1) && (n0 =? n2) && does_not_reference g0 n0) eqn:cond'];
      try easy_case IHfuel.
    + apply andb_prop in cond as [cond dnr].
      apply andb_prop in cond as [cond1 cond2].
      apply Nat.eqb_eq in cond1; apply Nat.eqb_eq in cond2; subst.
      assert ([CNOT n2 n1] ++ g0 =l= g0 ++ [CNOT n2 n1])%ucom.
      apply does_not_reference_commutes_app2.
      eapply ntqg_l1_does_not_reference. apply ntqg.
      assumption.
      rewrite IHfuel.
      apply ntqg_preserves_structure in ntqg.
      rewrite ntqg.
      rewrite cons_to_app.
      rewrite 2 (cons_to_app _ (_ ++ _)).
      apply_app_congruence.
      rewrite <- H0.
      apply_app_congruence.
      unfold uc_equiv_l; simpl.
      destruct (uc_well_typed_b (@SQIR.CNOT dim n2 n1)) eqn:WTb.
      apply uc_well_typed_b_equiv in WTb.
      inversion WTb; subst.
      unfold SQIR.SWAP.
      repeat rewrite useq_assoc.
      rewrite <- (useq_assoc _ (SQIR.CNOT n2 n1) SKIP).
      rewrite CNOT_CNOT_id by assumption.
      rewrite SKIP_id_l.
      reflexivity.
      apply not_true_iff_false in WTb.
      rewrite uc_well_typed_b_equiv in WTb.
      apply uc_eval_zero_iff in WTb.
      unfold uc_equiv; simpl in *.
      rewrite WTb. Msimpl_light. reflexivity.
    + clear cond.
      apply andb_prop in cond' as [cond' dnr].
      apply andb_prop in cond' as [cond1 cond2].
      apply Nat.eqb_eq in cond1; apply Nat.eqb_eq in cond2; subst.
      assert ([CNOT n2 n1] ++ g0 =l= g0 ++ [CNOT n2 n1])%ucom.
      apply does_not_reference_commutes_app2.
      assumption.
      eapply ntqg_l1_does_not_reference. apply ntqg.
      rewrite IHfuel.
      apply ntqg_preserves_structure in ntqg.
      rewrite ntqg.
      rewrite cons_to_app.
      rewrite 2 (cons_to_app _ (_ ++ _)).
      apply_app_congruence.
      rewrite <- H0.
      apply_app_congruence.
      unfold uc_equiv_l; simpl.
      destruct (uc_well_typed_b (@SQIR.CNOT dim n2 n1)) eqn:WTb.
      apply uc_well_typed_b_equiv in WTb.
      inversion WTb; subst.
      rewrite SWAP_symmetric.
      unfold SQIR.SWAP.
      repeat rewrite useq_assoc.
      rewrite <- (useq_assoc _ (SQIR.CNOT n2 n1) SKIP).
      rewrite CNOT_CNOT_id by auto.
      rewrite SKIP_id_l.
      reflexivity.
      apply not_true_iff_false in WTb.
      rewrite uc_well_typed_b_equiv in WTb.
      apply uc_eval_zero_iff in WTb.
      unfold uc_equiv; simpl in *.
      rewrite WTb. Msimpl_light. reflexivity.
Qed.
Local Opaque SQIR.CNOT SQIR.SWAP.

Lemma cancel_cnots_with_swaps_sound : forall {dim} (l : ucom_l dim),
  (cancel_cnots_with_swaps l =l= l)%ucom.
Proof.
  intros dim l.
  unfold cancel_cnots_with_swaps.
  rewrite cancel_cnots_with_swaps'_sound.
  reflexivity.
Qed.

Ltac easy_case2 IH := apply IH; auto; constructor; auto.

Lemma cancel_cnots_with_swaps'_respects_undirected : forall {dim} (l : ucom_l dim) is_in_graph fuel acc,
  respects_constraints_undirected is_in_graph acc ->
  respects_constraints_undirected is_in_graph l ->
  respects_constraints_undirected is_in_graph (cancel_cnots_with_swaps' l fuel acc).
Proof.
  intros dim l is_in_graph fuel.
  gen l.
  induction fuel; intros l acc Hacc Hl; simpl.
  apply rev_append_respects_constraints_undirected; auto.
  destruct l.
  apply rev_append_respects_constraints_undirected; auto.
  destruct g; dependent destruction m; inversion Hl; subst.
  easy_case2 IHfuel.
  - destruct (next_two_qubit_gate l n) eqn:ntqg.
    2: easy_case2 IHfuel.
    repeat destruct p.
    dependent destruction m.
    easy_case2 IHfuel.
    destruct ((n =? n2) && (n0 =? n1) && does_not_reference g0 n0).
    eapply next_two_qubit_gate_respects_constraints_undirected
      in ntqg as [? [? _]]; auto.
    apply IHfuel; auto.
    apply respects_constraints_undirected_app; auto.
    apply H0.
    constructor; auto.
    apply or_comm. auto.
    constructor; auto.
    auto.
    destruct ((n =? n1) && (n0 =? n2) && does_not_reference g0 n0) eqn:cond.
    apply andb_prop in cond as [cond _].
    apply andb_prop in cond as [cond1 cond2].
    apply Nat.eqb_eq in cond1; apply Nat.eqb_eq in cond2; subst.
    eapply next_two_qubit_gate_respects_constraints_undirected
      in ntqg as [? [? _]]; auto.
    apply IHfuel; auto.
    apply respects_constraints_undirected_app; auto.
    apply H0.
    constructor; auto.
    apply or_comm. auto.
    constructor; auto.
    apply H6.
    easy_case2 IHfuel.
  - destruct (next_two_qubit_gate l n) eqn:ntqg.
    2: easy_case2 IHfuel.
    repeat destruct p.
    dependent destruction m.
    2: easy_case2 IHfuel.
    destruct ((n =? n2) && (n0 =? n1) && does_not_reference g0 n0).
    eapply next_two_qubit_gate_respects_constraints_undirected
      in ntqg as [? [? _]]; auto.
    apply IHfuel; auto.
    constructor; auto.
    constructor.
    apply or_comm. auto.
    apply respects_constraints_undirected_app; auto.
    apply H0. apply H1. auto.
    destruct ((n =? n1) && (n0 =? n2) && does_not_reference g0 n0).
    eapply next_two_qubit_gate_respects_constraints_undirected
      in ntqg as [? [? _]]; auto.
    apply IHfuel; auto.
    constructor.
    apply or_comm. auto.
    constructor; auto.
    apply respects_constraints_undirected_app; auto.
    apply H0. apply H1. auto.
    easy_case2 IHfuel.
Qed.

Lemma cancel_cnots_with_swaps_respects_undirected : forall {dim} (l : ucom_l dim) is_in_graph,
  respects_constraints_undirected is_in_graph l ->
  respects_constraints_undirected is_in_graph (cancel_cnots_with_swaps l).
Proof.
  intros dim l is_in_graph H.
  apply cancel_cnots_with_swaps'_respects_undirected.
  constructor. assumption.
Qed.

End SwapRouteProofs.

(** Proofs specialized to the Full gate set. *)

Module MapFull := MappingGateSet FullGateSet.
Module MapList := UListProofs MapFull.
Import MapList.

Module SRPFull := SwapRouteProofs FullGateSet.
Import SRPFull.

Lemma decompose_swaps_and_cnots_sound : forall {dim} (l : map_ucom_l (Full_Unitary 1) dim) is_in_graph,
  (decompose_swaps_and_cnots l is_in_graph =l= l)%ucom.
Proof.
  intros dim l is_in_graph.
  unfold decompose_swaps_and_cnots.
  assert (l =l= cancel_cnots_with_swaps l)%ucom.
  symmetry.
  apply cancel_cnots_with_swaps_sound.
  unfold uc_equiv_l in *.
  rewrite H0.
  remember (cancel_cnots_with_swaps l) as l'.
  clear.
  induction l'.
  - rewrite change_gate_set_nil.
    reflexivity.
  - rewrite change_gate_set_cons.
    simpl.
    rewrite list_to_ucom_append.
    destruct a; apply useq_congruence; try apply IHl';
      dependent destruction m; simpl.
    + rewrite SKIP_id_r. reflexivity.
    + destruct (is_in_graph n n0); simpl.
      rewrite SKIP_id_r. reflexivity.
      repeat rewrite <- useq_assoc.
      rewrite SKIP_id_r.
      apply H_swaps_CNOT.
    + destruct (is_in_graph n n0); simpl.
      destruct (is_in_graph n0 n); simpl.
      repeat rewrite <- useq_assoc.
      rewrite SKIP_id_r. reflexivity.
      repeat rewrite <- useq_assoc.
      rewrite SKIP_id_r.
      apply useq_congruence; try reflexivity.
      repeat rewrite useq_assoc.
      apply useq_congruence; try reflexivity.
      repeat rewrite <- useq_assoc.
      apply H_swaps_CNOT.
      rewrite SWAP_symmetric.
      repeat rewrite <- useq_assoc.
      rewrite SKIP_id_r.
      apply useq_congruence; try reflexivity.
      repeat rewrite useq_assoc.
      apply useq_congruence; try reflexivity.
      repeat rewrite <- useq_assoc.
      apply H_swaps_CNOT.
Qed.

Lemma decompose_swaps_and_cnots_respects_directed : forall {dim} (l : map_ucom_l (Full_Unitary 1) dim) is_in_graph,
  respects_constraints_undirected is_in_graph l ->
  respects_constraints_directed is_in_graph UMap_CNOT (decompose_swaps_and_cnots l is_in_graph).
Proof.
  intros dim l is_in_graph H.
  unfold decompose_swaps_and_cnots.
  assert (respects_constraints_undirected is_in_graph (cancel_cnots_with_swaps l)).
  apply cancel_cnots_with_swaps_respects_undirected. auto.
  remember (cancel_cnots_with_swaps l) as l'.
  clear - H0.
  induction l'.
  rewrite change_gate_set_nil.
  constructor.
  rewrite change_gate_set_cons.
  inversion H0; subst.
  simpl. constructor.
  apply IHl'. assumption.
  apply respects_constraints_directed_app.
  dependent destruction u; simpl.
  destruct (is_in_graph n1 n2) eqn:?.
  constructor. assumption. constructor.
  destruct H4; try easy.
  repeat constructor.
  assumption.
  destruct (is_in_graph n1 n2) eqn:?.
  destruct (is_in_graph n2 n1) eqn:?.
  repeat constructor; assumption.
  repeat constructor; assumption.
  destruct H4; try easy.
  repeat constructor; assumption.
  apply IHl'. assumption.
Qed.