From Undecidability.L.Datatypes Require Import LNat Lists LProd LFinType LVector .
From Undecidability.L Require Import Functions.FinTypeLookup Functions.EqBool.

From Undecidability.L Require Import TM.TapeFuns.

From Undecidability.TM Require Import TM_facts.

Set Default Proof Using "Type".
Local Notation L := TM.Lmove.
Local Notation R := TM.Rmove.
Local Notation N := TM.Nmove.

Section loopM.
  Context (sig : finType).
  Let reg_sig := @encodable_finType sig.
  Existing Instance reg_sig.

  Let eqb_sig := eqbFinType_inst (X:=sig).
  Existing Instance eqb_sig.
  Variable n : nat.
  Variable M : TM sig n.

  Let reg_state := @encodable_finType (state M).
  Existing Instance reg_state.

  Let eqb_state := eqbFinType_inst (X:=state M).
  Existing Instance eqb_state.
  Import Vector.

  Local Definition c__trans :=
       (length ( elem (state M) ) * 4 + (n * (4 * length ( elem sig ) + 10) + 4) + 4) *
       c__eqbComp (finType_CS (state M * VectorDef.t (option sig) n)).
  Definition transTime := (| funTable (trans (m:=M)) |) * (c__trans + 24) + 4 + 9.
  (* *** Computability of transition relation *)
  Global Instance term_trans : computableTime' (trans (m:=M)) (fun _ _ => (transTime,tt)).
  Proof.
    pose (t:= (funTable (trans (m:=M)))).
    apply computableTimeExt with (x:= (fun c => lookup c t (start M,Vector.const (None , N) _ ) )).
    2:{ remember t as lock__t .
         extract. solverec. subst lock__t .
        rewrite lookupTime_leq.
                                        setoid_rewrite size_prod;cbn [fst snd].
         unfold reg_state;rewrite (size_finType_le a).

         rewrite enc_vector_eq. evar (c__elem' : nat).
         evar (c__elem : nat).
         rewrite size_list,sumn_le_bound with (c:=c__elem).
         2:{
           intros ? (?&<-&?)%in_map_iff.
           rewrite LOptions.size_option.
           [c__elem]: exact( c__elem' + 10). subst c__elem.
           destruct x. 2: { unfold c__listsizeCons. lia. }
           unfold reg_sig;rewrite (size_finType_le e).
           ring_simplify.
           [c__elem']: exact (4 * (| elem sig |)). subst c__elem'. unfold c__listsizeCons. lia.
         }
         rewrite map_length,to_list_length.
         unfold c__elem',transTime,c__trans,t,c__elem. reflexivity.
    }

    cbn -[t] ;intro. subst t.  setoid_rewrite lookup_funTable. reflexivity.
  Qed.

  Definition step' (c :  mconfig sig (state M) n) : mconfig sig (state M) n :=
    let (news, actions) := trans (cstate c, current_chars (ctapes c)) in
    mk_mconfig news (doAct_multi (ctapes c) actions).

  Global Instance term_doAct_multi: computableTime' (doAct_multi (n:=n) (sig:=sig)) (fun _ _ => (1,fun _ _ =>(n * 108 + 123,tt))).
  Proof.
    extract.
    solverec.
    rewrite time_map2_leq with (k:=90).
    2:now solverec.
    solverec. now rewrite to_list_length.
  Qed.

  Global Instance term_step' : computableTime' (step (M:=M)) (fun _ _ => (n* 130+ transTime + 172,tt)).
  Proof.
    extract.
    solverec.
  Qed.

  Local Definition cHalt := ((| elem (state M) |) * 4 * c__eqbComp (state M) + 24).

  Definition haltTime := length (funTable (halt (m:=M))) * cHalt + 12.

  Global Instance term_halt : computableTime' (halt (m:=M)) (fun _ _ => (haltTime,tt)).
  Proof.
    pose (t:= (funTable (halt (m:=M)))).
    apply computableTimeExt with (x:= fun c => lookup c t false).
    2:{extract.
       solverec.
       rewrite lookupTime_leq.
       unfold reg_state at 1;rewrite size_finType_le.
       unfold haltTime. subst t. unfold cHalt. nia.
    }
    cbn;intro. subst t. setoid_rewrite lookup_funTable. reflexivity.
  Qed.

  Global Instance term_haltConf : computableTime' (haltConf (M:=M)) (fun _ _ => (haltTime+8,tt)).
  Proof.
    extract.
    solverec.
  Qed.

  (* *** Computability of step-ndexed interpreter *)
  Global Instance term_loopM :
  let c1 := (haltTime + n*130 + transTime + 85 + 108) in
    let c2 := 15 + haltTime in
    computableTime' (loopM (M:=M)) (fun _ _ => (5,fun k _ => (c1 * k + c2,tt))).
  Proof.
    unfold loopM. (* as loop is already an encodable instance, this here is a bit out of the scope. Therefore, we unfold manually here. *)
    extract.
    solverec.
  Qed.

  Instance term_test cfg :
    computable (fun k => LOptions.isSome (loopM (M := M) cfg k)).
  Proof.
    extract.
  Qed.

End loopM.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

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

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

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

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFTreceived_prepare_like.
Require Export PBFTknows_prepared.

Section PBFT_A_1_4.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Definition node0 : Rep := bij_inv node_bij nat_n_2Fp1_0.

  Definition nat2node (n : nat) : node_type.
  Proof.
    destruct node_bij as [f a b].
    destruct (lt_dec n num_nodes) as [d|d].
    - exact (f (mk_nat_n d)). (* here we now that n < num_replicas so we can use our bijection *)
    - exact node0. (* here num_replicas <= n, so we return a default value: replica0 *)
  Defined.

  Lemma A_1_4 :
    forall (eo : EventOrdering)
           (e1  : Event)
           (e2  : Event)
           (i   : Rep)
           (j   : Rep)
           (n   : SeqNum)
           (v   : View)
           (d1  : PBFTdigest)
           (d2  : PBFTdigest)
           (st1 : PBFTstate)
           (st2 : PBFTstate),
      authenticated_messages_were_sent_or_byz_usys eo PBFTsys
      -> PBFTcorrect_keys eo
      -> exists_at_most_f_faulty [e1, e2] F
      -> loc e1 = PBFTreplica i                               (* e1 happened at location i *)
      -> loc e2 = PBFTreplica j                               (* e2 happened at location j *)
      -> state_sm_on_event (PBFTreplicaSM i) e1 = Some st1 (* state of i at e1 *)
      -> state_sm_on_event (PBFTreplicaSM j) e2 = Some st2 (* state of j at e2 *)
      -> prepared (request_data v n d1) st1 = true            (* the entry for <v,n,d1> is prepared at e1 *)
      -> prepared (request_data v n d2) st2 = true            (* the entry for <v,n,d2> is prepared at e2 *)
      -> d1 = d2.
  Proof.
    introv sendbyz corkeys fbyz eqloc1 eqloc2 eqst1 eqst2; introv prep1 prep2.

    destruct (PBFTdigestdeq d1 d2) as [d|d]; auto.
    assert False; tcsp.

    assert (well_formed_log (log st1)) as wf1 by eauto 2 with pbft.
    assert (well_formed_log (log st2)) as wf2 by eauto 2 with pbft.

    eapply prepared_as_pbft_knows_rd in prep1;[| |eauto|];auto;[].
    eapply prepared_as_pbft_knows_rd in prep2;[| |eauto|];auto;[].

    pose proof (knows_in_intersection
                  e1 e2
                  (2 * F + 1)
                  (request_data v n d1)
                  (request_data v n d2)
                  one_pre_prepare
                  [e1,e2]
                  F) as q.
    repeat (autodimp q hyp); simpl; eauto 3 with pbft;
      try (complete (unfold num_replicas; try omega));[].
    destruct q as [e1' [e2' [pl1 [pl2 q]]]]; repnd.

    pose proof (two_know_own_prepare_like eo e1' e2' pl1 pl2) as z.
    repeat (autodimp z hyp); eauto 2 with pbft; try congruence;[].
    eapply implies_prepare_like_have_same_digests in z;[|eauto|eauto]; tcsp.
  Qed.

End PBFT_A_1_4.


From Coq Require Import ssreflect.
From stdpp Require Import base gmap.
From iris.proofmode Require Import tactics.
From aneris.prelude Require Import gset_map.
From aneris.aneris_lang.lib Require Import list_proof.
From aneris.aneris_lang.lib.serialization Require Import serialization_proof.
From aneris.aneris_lang Require Import aneris_lifting proofmode.
From aneris.examples.crdt.spec Require Import crdt_base crdt_time crdt_events crdt_denot crdt_resources.
From aneris.examples.crdt.oplib Require Import oplib_code.
From aneris.examples.crdt.oplib.spec Require Import model spec.
From aneris.examples.crdt.oplib.examples.add_wins_set Require Import add_wins_set_code.

Section awsCrdt.
  Context `{!Log_Time} `{!EqDecision vl} `{!Countable vl}.

  Inductive awsOp : Type :=
  | Add : vl → awsOp
  | Remove : vl → awsOp.

  Definition awsSt : Type := gset (vl * Time).

  Global Instance awsOp_eqdec : EqDecision awsOp.
  Proof. solve_decision. Qed.

  Global Instance awsOp_countable : Countable awsOp.
  Proof.
    apply (inj_countable'
             (λ op, match op with Add v => inl v | Remove v => inr v end)
             (λ x, match x with inl v => Add v | inr v => Remove v end));
    intros []; done.
  Qed.

  Definition aws_denot (s : gset (Event awsOp)) (state : awsSt) : Prop :=
    ∀ v tm,
      (v, tm) ∈ state ↔
      ∃ add_ev, add_ev ∈ s ∧ EV_Op add_ev = Add v ∧ EV_Time add_ev = tm ∧
        ∀ rm_ev, rm_ev ∈ s → EV_Op rm_ev = Remove v → ¬ TM_le tm (EV_Time rm_ev).

  Global Instance aws_denot_fun : Rel2__Fun aws_denot.
  Proof.
    constructor; intros s st1 st2 Hst1 Hst2.
    apply set_eq; intros [v tm].
    rewrite Hst1 Hst2; done.
  Qed.

  Global Instance aws_denot_instance : CrdtDenot awsOp awsSt := {
    crdt_denot := aws_denot;
  }.
End awsCrdt.

Global Arguments awsOp _ : clear implicits.
Global Arguments awsSt {_} _ {_ _}.

(* TODO: Move to the right place. *)
Global Instance TM_le_dec `{!Log_Time} tm1 tm2 : Decision (TM_le tm1 tm2).
Proof.
  destruct (decide (TM_lt tm1 tm2)).
  { left; apply TM_lt_TM_le; done. }
  destruct (decide (tm1 = tm2)) as [->|].
  { left; reflexivity. }
  right; intros []%TM_le_eq_or_lt; done.
Qed.

Section OpAws.
  Context `{!Log_Time}
          `{!EqDecision vl} `{!Countable vl}.

  Definition update_state (ev : Event (awsOp vl)) (st : awsSt vl) : awsSt vl :=
    match EV_Op ev with
    | Add v => {[(v, EV_Time ev)]} ∪ st
    | Remove v =>  filter (λ '(w, tm), v ≠ w ∨ ¬ TM_le tm (EV_Time ev)) st
    end.

  Definition op_aws_effect (st : awsSt vl) (ev : Event (awsOp vl)) (st' : awsSt vl) : Prop :=
    st' = update_state ev st.

  Lemma op_aws_effect_fun st : Rel2__Fun (op_aws_effect st).
  Proof. constructor; intros ??? -> ->; done. Qed.

  Instance op_aws_effect_coh : OpCrdtEffectCoh op_aws_effect.
  Proof.
    intros s ev st st' Hst Hevs Hmax Hext Hto.
    rewrite /op_aws_effect /crdt_denot /= /aws_denot /update_state.
    split.
    - intros ->.
      intros v tm; split.
      + intros Hup.
        destruct ev as [[add_vl|rm_vl] evorig evtm]; simpl in *.
        * rewrite elem_of_union elem_of_singleton in Hup.
          destruct Hup as [|Hup]; simplify_eq.
          -- exists {| EV_Op := Add add_vl; EV_Orig := evorig; EV_Time := evtm |}; simpl.
             split_and!; [set_solver|done|done|].
             intros [[|rm_val] rm_orig rm_tm] Hrmvs ?; simpl in *; first done.
             destruct Hmax as [? Hmax].
             specialize (Hmax _ Hrmvs).
             rewrite /time /= in Hmax.
             intros [->|Hle]%TM_le_eq_or_lt; last done.
             simplify_eq.
             assert ({| EV_Op := Add add_vl; EV_Orig := evorig; EV_Time := rm_tm |} =
                       {| EV_Op := Remove add_vl; EV_Orig := rm_orig; EV_Time := rm_tm |});
                  last by simplify_eq.
             apply Hext; set_solver.
          -- apply Hst in Hup as (add_ev&?&?&?&?).
             exists add_ev; split_and!; [set_solver|done|done|set_solver].
        * apply elem_of_filter in Hup as [Hupin Hup].
          apply Hst in Hup as (add_ev&?&?&?&Hno_rm); simplify_eq.
          exists add_ev; split_and!; [set_solver|done|done|].
          intros rm_ev Hrm_ev ?.
          pose proof Hrm_ev as Hrm_ev'.
          rewrite elem_of_union elem_of_singleton in Hrm_ev'.
          destruct Hrm_ev' as [|]; first by apply Hno_rm.
          simplify_eq/=; simpl.
          destruct Hupin; done.
      + intros (add_ev & Hadd_ev_in & Hadd_ev_val & Hadd_ev_tm & Hadd_ev_no_rm).
        destruct ev as [[add_vl|rm_vl] evorig evtm]; simpl in *.
        * rewrite elem_of_union elem_of_singleton in Hadd_ev_in.
          destruct Hadd_ev_in as [Hadd_ev_in|]; simplify_eq/=; last set_solver.
          apply elem_of_union; right.
          apply Hst.
          exists add_ev; split_and!; [done|done|done|set_solver].
        * apply elem_of_filter.
          split.
          -- destruct (decide (rm_vl = v)); last tauto.
             right;
               apply (Hadd_ev_no_rm {| EV_Op := Remove rm_vl; EV_Orig := evorig; EV_Time := evtm |});
               [set_solver|simpl; congruence].
          -- apply Hst; exists add_ev; split_and!; [set_solver|done|done|set_solver].
    - intros Hst'.
      apply set_eq; intros [v tm]; split.
      + intros (add_ev & Hadd_ev_in & Hadd_ev_val & Hadd_ev_tm & Hadd_ev_no_rm)%Hst'.
        destruct ev as [[add_vl|rm_vl] evorig evtm]; simpl in *.
        * rewrite elem_of_union elem_of_singleton in Hadd_ev_in.
          destruct Hadd_ev_in as [Hadd_ev_in|]; simplify_eq/=; last set_solver.
          apply elem_of_union; right.
          apply Hst.
          exists add_ev; split_and!; [done|done|done|set_solver].
        * apply elem_of_filter.
          split.
          -- destruct (decide (rm_vl = v)); last tauto.
             right;
               apply (Hadd_ev_no_rm {| EV_Op := Remove rm_vl; EV_Orig := evorig; EV_Time := evtm |});
               [set_solver|simpl; congruence].
          -- apply Hst; exists add_ev; split_and!; [set_solver|done|done|set_solver].
      + intros Hup.
        destruct ev as [[add_vl|rm_vl] evorig evtm]; simpl in *.
        * rewrite elem_of_union elem_of_singleton in Hup.
          destruct Hup as [|Hup]; simplify_eq.
          -- apply Hst'.
             exists {| EV_Op := Add add_vl; EV_Orig := evorig; EV_Time := evtm |}; simpl.
             split_and!; [set_solver|done|done|].
             intros [[|rm_val] rm_orig rm_tm] Hrmvs ?; simpl in *; first done.
             destruct Hmax as [? Hmax].
             specialize (Hmax _ Hrmvs).
             rewrite /time /= in Hmax.
             intros [->|Hle]%TM_le_eq_or_lt; last done.
             simplify_eq.
             assert ({| EV_Op := Add add_vl; EV_Orig := evorig; EV_Time := rm_tm |} =
                       {| EV_Op := Remove add_vl; EV_Orig := rm_orig; EV_Time := rm_tm |});
                  last by simplify_eq.
             apply Hext; set_solver.
          -- apply Hst'.
             apply Hst in Hup as (add_ev&?&?&?&?).
             exists add_ev; split_and!; [set_solver|done|done|set_solver].
        * apply Hst'.
          apply elem_of_filter in Hup as [Hupin Hup].
          apply Hst in Hup as (add_ev&?&?&?&Hno_rm); simplify_eq.
          exists add_ev; split_and!; [set_solver|done|done|].
          intros rm_ev Hrm_ev ?.
          pose proof Hrm_ev as Hrm_ev'.
          rewrite elem_of_union elem_of_singleton in Hrm_ev'.
          destruct Hrm_ev' as [|]; first by apply Hno_rm.
          simplify_eq/=; simpl.
          destruct Hupin; done.
  Qed.

  Definition op_aws_init_st : awsSt vl := ∅.

  Lemma op_aws_init_st_coh : ⟦ (∅ : gset (Event (awsOp vl))) ⟧ ⇝ op_aws_init_st.
  Proof.
    intros ? ?; split; first set_solver.
    intros (?&?&?); set_solver.
  Qed.

  Global Instance op_aws_model_instance : OpCrdtModel (awsOp vl) (awsSt vl) := {
    op_crdtM_effect := op_aws_effect;
    op_crdtM_effect_fun := op_aws_effect_fun;
    op_crdtM_effect_coh := op_aws_effect_coh;
    op_crdtM_init_st := op_aws_init_st;
    op_crdtM_init_st_coh := op_aws_init_st_coh
  }.

End OpAws.

From aneris.prelude Require Import time.
From aneris.aneris_lang.lib Require Import list_code list_proof.
From aneris.aneris_lang.lib.vector_clock Require Import vector_clock_code vector_clock_proof.
From aneris.aneris_lang.lib Require Import inject.
From aneris.examples.crdt.oplib.proof Require Import time.

(* TODO: move to the right place. *)
Global Instance vector_clock_inject : Inject vector_clock val :=
  { inject := vector_clock_to_val }.

Section aws_proof.
  Context `{!EqDecision vl} `{!Countable vl}
          `{!Inject vl val} `{!∀ (a : vl), Serializable vl_serialization $a}.

  Context `{!anerisG M Σ}.

  Context `{!CRDT_Params} `{!OpLib_Res (awsOp vl)}.

  Global Program Instance awsOp_inj : Inject (awsOp vl) val :=
    {| inject w := match w with add_wins_set_proof.Add v => InjLV $v | Remove v => InjRV $v end |}.
  Next Obligation.
  Proof. intros [] []; simpl; intros ?; simplify_eq; done. Qed.

  Definition aws_OpLib_Op_Coh := λ (op : awsOp vl) (v : val), v = $op.

  Lemma aws_OpLib_Op_Coh_Inj (o1 o2 : awsOp vl) (v : val) :
    aws_OpLib_Op_Coh o1 v → aws_OpLib_Op_Coh o2 v → o1 = o2.
  Proof. rewrite /aws_OpLib_Op_Coh; intros ? ?; simplify_eq; done. Qed.

  Lemma aws_OpLib_Coh_Ser (op : awsOp vl) (v : val) :
    aws_OpLib_Op_Coh op v → Serializable (sum_serialization vl_serialization vl_serialization) v.
  Proof. intros Heq. rewrite Heq; destruct op; apply _. Qed.

  Definition aws_OpLib_State_Coh :=
    λ (st : awsSt vl) v, ∃ (l : list (vl * vector_clock)), is_list l v ∧ ∀ vtm, vtm ∈ st ↔ vtm ∈ l.

  Global Instance aws_OpLib_Params : OpLib_Params (awsOp vl) (awsSt vl) :=
  {|
    OpLib_Serialization := (sum_serialization vl_serialization vl_serialization);
    OpLib_State_Coh := aws_OpLib_State_Coh;
    OpLib_Op_Coh := aws_OpLib_Op_Coh;
    OpLib_Op_Coh_Inj := aws_OpLib_Op_Coh_Inj;
    OpLib_Coh_Ser := aws_OpLib_Coh_Ser
  |}.

  Lemma aws_init_st_fn_spec : ⊢ init_st_fn_spec init_st.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /init_st.
    wp_pures.
    iApply "HΦ".
    iPureIntro; eexists []; split_and!; [done|set_solver].
  Qed.

  (* TODO: moe to the right place; this strengthenes the existing proof. *)
  (* This also changes the API to use filter instead of list.filter. Why whas that choice made!?*)
  Lemma wp_list_filter `{!Inject A val} (l : list A) (P : A -> bool) (f lv : val) ip :
    {{{ (∀ (x : A),
            {{{ ⌜x ∈ l⌝ }}}
              f $x @[ip]
            {{{ w, RET w; ⌜w = $(P x)⌝ }}} ) ∗
        ⌜is_list l lv⌝ }}}
       list_code.list_filter f lv @[ip]
     {{{ rv, RET rv; ⌜is_list (filter P l) rv⌝ }}}.
  Proof.
    iIntros (Φ) "[#Hf %Hil] HΦ".
    iInduction l as [ | h t] "IH" forall (lv Hil Φ); simpl in Hil.
    - subst.
      rewrite /list_code.list_filter; wp_pures.
      iApply "HΦ"; done.
    - destruct Hil as (lv' & -> & Hil).
      rewrite /list_code.list_filter.
      do 7 (wp_pure _).
      fold list_code.list_filter.
      wp_apply ("IH" $! lv'); [done| |].
      { iIntros "!#" (? ?) "!# %"; iApply "Hf"; iPureIntro; apply elem_of_cons; auto. }
      iIntros (rv) "%Hilp"; wp_pures.
      wp_apply "Hf"; [by iPureIntro; apply elem_of_cons; auto|].
      iIntros (w) "->".
      destruct (P h) eqn:HP; wp_pures.
      + wp_apply wp_list_cons; [by eauto |].
        iIntros (v) "%Hil'".
        iApply "HΦ"; iPureIntro.
        rewrite filter_cons.
        rewrite HP; simpl.
        simpl in Hil'; done.
      + iApply "HΦ"; iPureIntro.
        rewrite filter_cons.
        rewrite HP. done.
  Qed.

  Lemma aws_effect_spec : ⊢ effect_spec effect.
  Proof.
    iIntros (addr ev st s log_ev log_st).
    iIntros "!#" (Φ) "(%Hev & %Hst & %Hs & %Hevs) HΦ".
    rewrite /effect.
    destruct log_ev as [log_ev orig vc].
    destruct Hev as (evpl&evvc&evorig& ?&Hopcoh&?&?).
    destruct Hevs as (Hnin & Hmax & Hext).
    destruct Hst as (l&?&Hstl).
    simplify_eq/=.
    rewrite Hopcoh /=.
    wp_pures.
    destruct log_ev; wp_pures.
    - replace ($ v, evvc)%V with ($ (v, vc) : val); last first.
      { simpl; erewrite is_vc_vector_clock_to_val; done. }
      wp_apply wp_list_cons; first by iPureIntro.
      iIntros (w Hw).
      iApply "HΦ".
      iExists _; iSplit; last by eauto.
      simpl; iPureIntro; eexists _; split_and!; first done.
      intros []; rewrite /update_state /=; set_solver.
    - wp_apply
        (wp_list_filter
           _ (λ '(w, wvc), (bool_decide (w ≠ v)) || (negb (bool_decide (vector_clock_le wvc vc))))).
      + iSplit; last done.
        iIntros ([w wvc]) "!#".
        iIntros (Ψ) "_ HΨ".
        wp_pures.
        destruct (decide (w = v)) as [->|Hneq].
        * wp_op; [rewrite bin_op_eval_eq_val bool_decide_eq_true_2; done|].
          wp_pures.
          wp_apply wp_vect_leq; first by iPureIntro; split; [apply vector_clock_to_val_is_vc|done].
          iIntros (? ->); simpl.
          wp_pures.
          iApply "HΨ".
          rewrite (bool_decide_eq_false_2 (v ≠ v)); by auto.
        * wp_op.
          { rewrite bin_op_eval_eq_val bool_decide_eq_false_2; first done.
            intros ?; apply Hneq; eapply inj; eauto with typeclass_instances. }
          wp_pures.
          iApply "HΨ".
          rewrite (bool_decide_eq_true_2 (w ≠ v)); by auto.
      + iIntros (w Hw).
        iApply "HΦ".
        iExists _; iSplit; last by eauto.
        simpl; iPureIntro; eexists _; split_and!; first done.
        intros [u uvc].
        rewrite /update_state /=.
        rewrite elem_of_filter elem_of_list_filter Hstl.
        rewrite -bool_decide_not -bool_decide_or bool_decide_spec.
        clear; firstorder.
  Qed.

  Lemma aws_crdt_fun_spec : ⊢ crdt_fun_spec aws_crdt.
  Proof.
    iIntros (addr).
    iIntros "!#" (Φ) "_ HΦ".
    rewrite /aws_crdt.
    wp_pures.
    iApply "HΦ".
    iExists _, _; iSplit; first done.
    iSplit.
    - iApply aws_init_st_fn_spec; done.
    - iApply aws_effect_spec; done.
  Qed.

  Lemma aws_init_spec :
    init_spec
      (oplib_init
         (s_ser (s_serializer (sum_serialization vl_serialization vl_serialization)))
         (s_deser (s_serializer (sum_serialization vl_serialization vl_serialization)))) -∗
      init_spec_for_specific_crdt
        (aws_init (s_ser (s_serializer vl_serialization)) (s_deser (s_serializer vl_serialization))).
  Proof.
    iIntros "#Hinit" (repId addr addrs_val).
    iIntros (Φ) "!# (%Haddrs & %Hrepid & Hprotos & Hskt & Hfr & Htoken) HΦ".
    rewrite /aws_init.
    wp_pures.
    wp_apply ("Hinit" with "[$Hprotos $Htoken $Hskt $Hfr]").
    { do 2 (iSplit; first done). iApply aws_crdt_fun_spec; done. }
    iIntros (get update) "(HLS & #Hget & #Hupdate)".
    wp_pures.
    iApply "HΦ"; eauto.
  Qed.

End aws_proof.


Require Export UnitaryListRepresentation.
Require Export QArith.

(* Other gate sets *)
Require Import IBMGateSet.
Require Import MappingGateSet.
Require Import RzQGateSet.
Require Import MappingConstraints.

Import Qreals. (* Coq version < 8.13.0 has Q2R defined in Qreals *)

(** This gate set is intended to be the "full" gate set that contains every gate
   we could ever want. Optimizations are not defined directly over this set.
   Instead, we define optimizations over specialized sets (e.g. RzQ, IBM) and
   provide translations from this set to those sets.

   The value of having a gate set that contains everything is that it removes
   some opportunities for error in the OpenQASM -> SQIR parser. For instance,
   the parser can directly translate "T" to the T gate in the full gate set
   rather than the Rz(PI/4) gate in the RzQ gate set. This is even more important
   for gates like CCX that have complicated translations to other gate sets.

   To extend this gate set with new gates, you will need to modify the definitions
   in this file and any optimizations defined over the full gate set (at
   present, these only include definitions in Main.v). **)

Local Open Scope R_scope.
Local Open Scope Q_scope.

Ltac invert_WT :=
  repeat match goal with
  | H: uc_well_typed _ |- _ => inversion H; subst; clear H
  end.

Ltac simpl_Reqb_and_Qeqb :=
  repeat match goal with
  | H : Reqb _ _ = true |- _ => apply Reqb_eq in H; rewrite H
  | H : _ && _ = true |- _ => apply andb_prop in H as [? ?]
  | H : Qeq_bool _ _ = true |- _ => apply Qeq_bool_iff in H;
      apply RMicromega.Q2R_m in H; rewrite H
  end.

Module FullGateSet <: GateSet.

Inductive Full_Unitary : nat -> Set :=
  | U_I                           : Full_Unitary 1
  | U_X                           : Full_Unitary 1
  | U_Y                           : Full_Unitary 1
  | U_Z                           : Full_Unitary 1
  | U_H                           : Full_Unitary 1
  | U_S                           : Full_Unitary 1
  | U_T                           : Full_Unitary 1
  | U_Sdg                         : Full_Unitary 1
  | U_Tdg                         : Full_Unitary 1
  | U_Rx (r : R)                  : Full_Unitary 1
  | U_Ry (r : R)                  : Full_Unitary 1
  | U_Rz (r : R)                  : Full_Unitary 1
  | U_Rzq (q : Q)                 : Full_Unitary 1
  | U_U1 (r : R)                  : Full_Unitary 1
  | U_U2 (r : R) (r : R)          : Full_Unitary 1
  | U_U3 (r : R) (r : R) (r : R)  : Full_Unitary 1
  | U_CX                          : Full_Unitary 2
  | U_CZ                          : Full_Unitary 2
  | U_SWAP                        : Full_Unitary 2
  | U_CCX                         : Full_Unitary 3
  | U_CCZ                         : Full_Unitary 3.
Definition U := Full_Unitary.

(* Used for proofs -- not extracted to OCaml, so efficiency isn't a concern *)
Definition to_base {n dim} (u : U n) (qs : list nat) (pf : List.length qs = n) :=
  match u with
  | U_I            => @SQIR.ID dim (List.nth O qs O)
  | U_X            => @SQIR.X dim (List.nth O qs O)
  | U_Y            => @SQIR.Y dim (List.nth O qs O)
  | U_Z            => @SQIR.Z dim (List.nth O qs O)
  | U_H            => @SQIR.H dim (List.nth O qs O)
  | U_S            => @SQIR.P dim (List.nth O qs O)
  | U_T            => @SQIR.T dim (List.nth O qs O)
  | U_Sdg          => @SQIR.PDAG dim (List.nth O qs O)
  | U_Tdg          => @SQIR.TDAG dim (List.nth O qs O)
  | U_Rx r         => @SQIR.Rx dim r (List.nth O qs O)
  | U_Ry r         => @SQIR.Ry dim r (List.nth O qs O)
  | U_Rz r         => @SQIR.Rz dim r (List.nth O qs O)
  | U_Rzq q        => @SQIR.Rz dim (Q2R q * PI)%R (List.nth O qs O)
  | U_U1 r         => @SQIR.U1 dim r (List.nth O qs O)
  | U_U2 r1 r2     => @SQIR.U2 dim r1 r2 (List.nth O qs O)
  | U_U3 r1 r2 r3  => @SQIR.U3 dim r1 r2 r3 (List.nth O qs O)
  | U_CX           => @SQIR.CNOT dim (List.nth O qs O) (List.nth (S O) qs O)
  | U_CZ           => @SQIR.CZ dim (List.nth O qs O) (List.nth (S O) qs O)
  | U_SWAP         => @SQIR.SWAP dim (List.nth O qs O) (List.nth (S O) qs O)
  | U_CCX          => @SQIR.CCX dim (List.nth O qs O) (List.nth (S O) qs O) (List.nth (S (S O)) qs O)
  | U_CCZ          => @SQIR.CCZ dim (List.nth O qs O) (List.nth (S O) qs O) (List.nth (S (S O)) qs O)
  end.

Local Transparent SQIR.ID SQIR.X SQIR.Y SQIR.Z SQIR.H SQIR.Rx
                  SQIR.Ry SQIR.Rz SQIR.CNOT SQIR.SWAP.
Lemma to_base_only_uses_qs : forall {n} (dim : nat) (u : U n) (qs : list nat) (pf : List.length qs = n),
    @only_uses _ dim (to_base u qs pf) qs.
Proof.
  intros.
  destruct u; simpl;
  repeat constructor; apply nth_In; lia.
Qed.

Lemma to_base_WT : forall {n} (dim : nat) (u : U n) (qs : list nat) (pf : List.length qs = n),
  @uc_well_typed _ dim (to_base u qs pf) <-> (bounded_list qs dim /\ List.NoDup qs).
Proof.
  intros n dim u s pf.
  unfold bounded_list.
  split.
  - intro H.
    destruct u; invert_WT.
    all: repeat (destruct s; simpl in *; try lia).
    all: split.
    all: repeat constructor; auto.
    all: try (intros x [Hx | Hx]; subst; easy).
    all: try (intros x [Hx | [Hx | Hx]]; subst; easy).
    all: try (intros x [Hx | [Hx | [Hx | Hx]]]; subst; easy).
    all: try (intro contra; destruct_In; auto).
  - intros [H1 H2].
    assert (aux1: (length s >= 2)%nat -> nth 0 s O <> nth 1 s O).
    { intro H. clear pf.
      destruct s; [|destruct s; [|destruct s]]; simpl in H; try lia.
      inversion H2; subst.
      simpl.
      intro contra.
      contradict H4.
      subst; constructor; auto.
      inversion H2; subst.
      simpl.
      intro contra.
      contradict H4.
      subst; constructor; auto. }
    assert (aux2: length s = 3%nat -> nth 0 s O <> nth 2 s O).
    { intro H. clear pf.
      destruct s; [|destruct s; [|destruct s; [|destruct s]]]; simpl in H; try lia.
      inversion H2; subst.
      simpl.
      intro contra.
      contradict H4.
      subst; right; constructor; auto. }
    assert (aux3: length s = 3%nat -> nth 1 s O <> nth 2 s O).
    { intro H. clear pf.
      destruct s; [|destruct s; [|destruct s; [|destruct s]]]; simpl in H; try lia.
      inversion H2; subst.
      simpl.
      inversion H5; subst.
      intro contra.
      contradict H6.
      subst; constructor; auto. }
    destruct u; repeat constructor.
    all: try apply H1.
    all: try (apply nth_In; lia).
    all: try (apply aux1; lia).
    all: try (apply aux2; assumption).
    all: try (apply aux3; assumption).
    apply Nat.neq_sym.
    apply aux1; lia.
Qed.

Lemma to_base_map_commutes : forall {n} (dim : nat) (u : U n) (qs : list nat) (pf : List.length qs = n) (f : nat -> nat) (pfm : List.length (map f qs) = n),
  @to_base _ dim u (map f qs) pfm = map_qubits f (to_base u qs pf).
Proof.
  intros n dim u qs pf f pfm.
  destruct u; simpl.
  all: repeat erewrite map_nth_In; try reflexivity; lia.
Qed.
Local Opaque SQIR.ID SQIR.X SQIR.Y SQIR.Z SQIR.H SQIR.Rx
             SQIR.Ry SQIR.Rz SQIR.CNOT SQIR.SWAP.

Definition match_gate {n} (u u' : U n) : bool :=
  match u, u' with
  | U_I, U_I
  | U_X, U_X
  | U_Y, U_Y
  | U_Z, U_Z
  | U_H, U_H
  | U_S, U_S
  | U_T, U_T
  | U_Sdg, U_Sdg
  | U_Tdg, U_Tdg
  | U_CX, U_CX
  | U_CZ, U_CZ
  | U_SWAP, U_SWAP
  | U_CCX, U_CCX
  | U_CCZ, U_CCZ => true
  (* All rz gates are u1 gates, some u2 gates are H gates, etc.
     We will not bother to check for these cases. If desired, you could
     write an optimization pass that replaces gates with their equivalents. *)
  | U_Rx r, U_Rx r'
  | U_Ry r, U_Ry r'
  | U_Rz r, U_Rz r'
  | U_U1 r, U_U1 r' => Reqb r r'
  | U_Rzq q, U_Rzq q' => Qeq_bool q q'
  | U_U2 r1 r2, U_U2 r1' r2' => Reqb r1 r1' && Reqb r2 r2'
  | U_U3 r1 r2 r3, U_U3 r1' r2' r3' => Reqb r1 r1' && Reqb r2 r2' && Reqb r3 r3'
  | _, _ => false
  end.

Lemma match_gate_refl : forall {n} (u : U n), match_gate u u = true.
Proof.
  intros.
  dependent destruction u; simpl; auto.
  apply Reqb_eq; auto.
  apply Reqb_eq; auto.
  apply Reqb_eq; auto.
  apply Qeq_bool_iff; reflexivity.
  apply Reqb_eq; auto.
  apply andb_true_iff.
  split; apply Reqb_eq; auto.
  apply andb_true_iff.
  split; [apply andb_true_iff; split |]; apply Reqb_eq; auto.
Qed.

Lemma match_gate_implies_equiv : forall {n} dim (u u' : U n) (qs : list nat) (pf : List.length qs = n),
  match_gate u u' = true -> uc_equiv (@to_base n dim u qs pf) (to_base u' qs pf).
Proof.
  intros.
  dependent destruction u; dependent destruction u'.
  all: inversion H; simpl; simpl_Reqb_and_Qeqb; reflexivity.
Qed.

End FullGateSet.
Export FullGateSet.

Module FullList := UListProofs FullGateSet.

Definition full_ucom dim := ucom Full_Unitary dim.
Definition full_ucom_l dim := gate_list Full_Unitary dim.

(** Some useful gate decompositions **)

Lemma Cexp_plus_PI2 : forall x, Cexp (x + PI/2) = (Ci * Cexp x)%C.
Proof. intros. autorewrite with Cexp_db. lca. Qed.

Lemma Cexp_minus_PI2 : forall x, Cexp (x - PI/2) = (- Ci * Cexp x)%C.
Proof.
  intros.
  unfold Cexp.
  replace (x - PI / 2)%R with (- (PI / 2 - x))%R by lra.
  rewrite cos_neg, sin_neg.
  rewrite cos_shift, sin_shift.
  lca.
Qed.

(* All 4 cases in u3_to_rz can be solved by the same commands. *)
Ltac u3_to_rz_aux a :=
  try rewrite Cexp_add;
  try rewrite Cexp_plus_PI2;
  try rewrite Cexp_minus_PI2;
  unfold Cexp;
  autorewrite with trig_db;
  replace (sin a) with (sin (2 * (a/2))) by (apply f_equal; lra);
  rewrite sin_2a;
  apply c_proj_eq; simpl; field_simplify_eq; try nonzero;
  change_to_sqr;
  try rewrite sin_half_squared;
  try rewrite cos_half_squared;
  rewrite Rsqr_sqrt by lra;
  lra.

Local Open Scope ucom_scope.
Local Close Scope Q_scope.
Local Open Scope R_scope.
Lemma u3_to_rz : forall dim a b c q,
  @SQIR.U3 dim a b c q ≅ SQIR.Rz (c - (PI/2)) q ; SQIR.H q ; SQIR.Rz a q ; SQIR.H q ; SQIR.Rz (b + (PI/2)) q.
Proof.
  intros.
  unfold uc_cong; simpl.
  exists (- (a / 2)).
  autorewrite with eval_db.
  bdestruct_all.
  gridify.
  rewrite <- Mscale_kron_dist_l.
  rewrite <- Mscale_kron_dist_r.
  apply f_equal2; try reflexivity.
  apply f_equal2; try reflexivity.
  unfold phase_shift, rotation, hadamard.
  solve_matrix; u3_to_rz_aux a. (* all goals solved by ltac above *)
  (* final case is ill-typed *)
  Msimpl.
  reflexivity.
Qed.

Lemma u2_to_rz : forall dim a b q,
  @SQIR.U2 dim a b q ≡ SQIR.Rz (b - PI) q ; SQIR.H q ; SQIR.Rz a q.
Proof.
  intros.
  unfold uc_equiv; simpl.
  autorewrite with eval_db.
  gridify.
  apply f_equal2; try reflexivity.
  apply f_equal2; try reflexivity.
  unfold phase_shift, rotation, hadamard.
  solve_matrix;
  try rewrite Cexp_add;
  try rewrite Cexp_minus_PI;
  replace (PI / 2 / 2) with (PI / 4) by lra;
  autorewrite with trig_db RtoC_db;
  lca.
Qed.

Lemma rx_to_rz : forall dim a q,
  @SQIR.Rx dim a q ≅ SQIR.H q ; SQIR.Rz a q ; SQIR.H q.
Proof.
  intros dim a q.
  assert (H: @Rx dim a q ≅ U3 a (- (PI / 2)) (PI / 2) q).
  reflexivity.
  rewrite H.
  rewrite u3_to_rz.
  replace (PI / 2 - PI / 2) with 0 by lra.
  replace (- (PI / 2) + PI / 2) with 0 by lra.
  apply uc_equiv_cong.
  rewrite Rz_0_id.
  bdestruct (q <? dim)%nat.
  rewrite ID_equiv_SKIP by assumption.
  rewrite SKIP_id_l, SKIP_id_r by assumption.
  reflexivity.
  unfold uc_equiv; simpl.
  autorewrite with eval_db.
  gridify.
Qed.

Lemma ry_to_rz : forall dim a q,
  @SQIR.Ry dim a q ≅ SQIR.PDAG q ; SQIR.H q ; SQIR.Rz a q ; SQIR.H q ; SQIR.P q.
Proof.
  intros dim a q.
  assert (H: @Ry dim a q ≅ U3 a 0 0 q).
  reflexivity.
  rewrite H.
  rewrite u3_to_rz.
  replace (0 - PI / 2) with (- (PI / 2)) by lra.
  replace (0 + PI / 2) with (PI / 2) by lra.
  reflexivity.
Qed.

(** * Function to convert between gate sets **)

Local Open Scope Z_scope.

(* Effectively List.map, but tail recursive *)
Fixpoint change_gate_set' {dim : nat} {U1 U2 : nat -> Set}
      (f : gate_app U1 dim -> gate_list U2 dim) (l : gate_list U1 dim)
      (acc : gate_list U2 dim) : gate_list U2 dim :=
  match l with
  | [] => List.rev acc
  (* technically ++ isn't tail recursive, but when the first argument (i.e. f g)
     is small it shouldn't matter *)
  | g :: t => change_gate_set' f t (List.rev (f g) ++ acc)
  end.

Definition change_gate_set {dim : nat} {U1 U2 : nat -> Set}
      (f : gate_app U1 dim -> gate_list U2 dim) (l : gate_list U1 dim)
      : gate_list U2 dim :=
  change_gate_set' f l [].

Lemma change_gate_set_nil : forall {dim U1 U2} f,
  @change_gate_set dim U1 U2 f [] = [].
Proof. intros. reflexivity. Qed.

Lemma change_gate_set_cons : forall {dim U1 U2} f h t,
  @change_gate_set dim U1 U2 f (h :: t) = f h ++ change_gate_set f t.
Proof.
  intros.
  assert (forall l acc, change_gate_set' f l acc = rev acc ++ change_gate_set' f l []).
  { induction l; intro acc; simpl.
    rewrite app_nil_r.
    reflexivity.
    rewrite IHl.
    rewrite (IHl (_ ++ _)).
    repeat rewrite rev_app_distr.
    repeat rewrite rev_involutive.
    simpl.
    rewrite app_assoc.
    reflexivity. }
  unfold change_gate_set.
  simpl.
  rewrite H.
  rewrite rev_app_distr.
  rewrite rev_involutive.
  simpl.
  reflexivity.
Qed.

Lemma change_gate_set_app : forall {dim U1 U2} f l1 l2,
  @change_gate_set dim U1 U2 f (l1 ++ l2) = change_gate_set f l1 ++ change_gate_set f l2.
Proof.
  intros.
  induction l1.
  reflexivity.
  rewrite <- app_comm_cons.
  rewrite 2 change_gate_set_cons.
  rewrite IHl1.
  rewrite app_assoc.
  reflexivity.
Qed.

(** * IBM gate set **)

Definition full_to_IBM_u {dim} (g : gate_app Full_Unitary dim) : IBM_ucom_l dim :=
  match g with
  | App1 U_I m              => [IBMGateSet.Rz 0 m]
  | App1 U_X m              => [IBMGateSet.X m]
  | App1 U_Y m              => [IBMGateSet.Y m]
  | App1 U_Z m              => [IBMGateSet.Z m]
  | App1 U_H m              => [IBMGateSet.H m]
  | App1 U_S m              => [IBMGateSet.P m]
  | App1 U_T m              => [IBMGateSet.T m]
  | App1 U_Sdg m            => [IBMGateSet.PDAG m]
  | App1 U_Tdg m            => [IBMGateSet.TDAG m]
  | App1 (U_Rx r) m         => [IBMGateSet.Rx r m]
  | App1 (U_Ry r) m         => [IBMGateSet.Ry r m]
  | App1 (U_Rz r) m         => [IBMGateSet.Rz r m]
  | App1 (U_Rzq q) m        => [IBMGateSet.Rz (Q2R q * PI) m]
  | App1 (U_U1 r) m         => [IBMGateSet.U1 r m]
  | App1 (U_U2 r1 r2) m     => [IBMGateSet.U2 r1 r2 m]
  | App1 (U_U3 r1 r2 r3) m  => [IBMGateSet.U3 r1 r2 r3 m]
  | App2 U_CX m n           => [IBMGateSet.CNOT m n]
  | App2 U_CZ m n           => IBMGateSet.CZ m n
  | App2 U_SWAP m n         => IBMGateSet.SWAP m n
  | App3 U_CCX m n p        => IBMGateSet.CCX m n p
  | App3 U_CCZ m n p        => IBMGateSet.CCZ m n p
  | _ => [] (* unreachable *)
  end.

Definition IBM_to_full_u {dim} (g : gate_app IBM_Unitary dim) : full_ucom_l dim :=
  match g with
  | App1 (UIBM_U1 a) m      => [App1 (U_U1 a) m]
  | App1 (UIBM_U2 a b) m    => [App1 (U_U2 a b) m]
  | App1 (UIBM_U3 a b c) m  => [App1 (U_U3 a b c) m]
  | App2 UIBM_CNOT m n      => [App2 U_CX m n]
  | _ => [] (* unreachable *)
  end.

Definition full_to_IBM {dim} (l : full_ucom_l dim) : IBM_ucom_l dim :=
  change_gate_set full_to_IBM_u l.

Definition IBM_to_full {dim} (l : IBM_ucom_l dim) : full_ucom_l dim :=
  change_gate_set IBM_to_full_u l.

Lemma IBM_to_base1 : forall {dim} (u : IBM_Unitary 1) n,
  IBMGateSet.to_base u [n] (one_elem_list n) ≡
    FullList.list_to_ucom (IBM_to_full_u (@App1 _ dim u n)).
Proof.
  intros dim u n.
  dependent destruction u; simpl; rewrite SKIP_id_r; reflexivity.
Qed.

Lemma IBM_to_base2 : forall {dim} (u : IBM_Unitary 2) m n,
  IBMGateSet.to_base u (m :: n :: []) (two_elem_list m n) ≡
    FullList.list_to_ucom (IBM_to_full_u (@App2 _ dim u m n)).
Proof.
  intros dim u m n.
  dependent destruction u; simpl; rewrite SKIP_id_r; reflexivity.
Qed.

Lemma IBM_list_to_ucom : forall {dim} (l : IBM_ucom_l dim),
  IBMList.list_to_ucom l ≡ FullList.list_to_ucom (IBM_to_full l).
Proof.
  intros.
  induction l.
  reflexivity.
  simpl.
  unfold IBM_to_full.
  rewrite change_gate_set_cons.
  rewrite FullList.list_to_ucom_append.
  destruct a.
  rewrite IBM_to_base1, IHl.
  reflexivity.
  rewrite IBM_to_base2, IHl.
  reflexivity.
  dependent destruction i.
Qed.

Lemma IBM_to_full_equiv : forall {dim} (l l' : IBM_ucom_l dim),
  IBMGateSet.IBMList.uc_equiv_l l l' ->
  FullList.uc_equiv_l (IBM_to_full l) (IBM_to_full l').
Proof.
  intros dim l l' H.
  unfold FullList.uc_equiv_l.
  unfold IBMGateSet.IBMList.uc_equiv_l in H.
  rewrite 2 IBM_list_to_ucom in H.
  assumption.
Qed.

Lemma IBM_to_full_cong : forall {dim} (l l' : IBM_ucom_l dim),
  IBMGateSet.IBMList.uc_cong_l l l' ->
  FullList.uc_cong_l (IBM_to_full l) (IBM_to_full l').
Proof.
  intros dim l l' H.
  unfold FullList.uc_equiv_l.
  unfold IBMGateSet.IBMList.uc_cong_l in H.
  unfold uc_cong in H.
  rewrite 2 IBM_list_to_ucom in H.
  assumption.
Qed.

Lemma IBM_to_full_inv : forall {dim} (l : full_ucom_l dim),
  FullList.uc_equiv_l (IBM_to_full (full_to_IBM l)) l.
Proof.
  intros dim l.
  induction l.
  reflexivity.
  unfold full_to_IBM, IBM_to_full.
  rewrite change_gate_set_cons.
  rewrite change_gate_set_app.
  rewrite IHl.
  rewrite cons_to_app.
  FullList.apply_app_congruence.
  destruct a; dependent destruction f;
  unfold change_gate_set; simpl; try reflexivity.
  all: unfold FullList.uc_equiv_l; simpl;
       repeat rewrite <- useq_assoc; reflexivity.
Qed.

Lemma full_to_IBM_WT : forall {dim} (l : full_ucom_l dim),
  uc_well_typed_l l ->
  uc_well_typed_l (full_to_IBM l).
Proof.
  intros dim l WT.
  unfold full_to_IBM.
  induction WT.
  - constructor. assumption.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; try constructor; assumption.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; repeat constructor; try assumption. lia.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; repeat constructor; assumption.
Qed.

Lemma full_to_IBM_preserves_mapping : forall {dim} (l : full_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph U_CX l ->
  respects_constraints_directed is_in_graph UIBM_CNOT (full_to_IBM l).
Proof.
  intros dim l is_in_graph H.
  unfold full_to_IBM.
  induction l.
  constructor.
  rewrite change_gate_set_cons.
  inversion H; subst.
  apply respects_constraints_directed_app; auto.
  dependent destruction u; repeat constructor.
  apply respects_constraints_directed_app; auto.
  repeat constructor.
  assumption.
Qed.

Lemma IBM_to_full_preserves_mapping : forall {dim} (l : IBM_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph UIBM_CNOT l ->
  respects_constraints_directed is_in_graph U_CX (IBM_to_full l).
Proof.
  intros dim l is_in_graph H.
  unfold IBM_to_full.
  induction l.
  constructor.
  rewrite change_gate_set_cons.
  inversion H; subst.
  apply respects_constraints_directed_app; auto.
  dependent destruction u; repeat constructor.
  apply respects_constraints_directed_app; auto.
  repeat constructor.
  assumption.
Qed.

(** * RzQ gate set **)

(* A perfect real -> rational function DOES NOT exist because some real
   numbers are irrational. However, I am going to assert such a function
   as an axiom until we come up with a better solution. This is BAD and
   maybe be a source of troubles in the future. We extract this as a function
   that converts from floats to rationals (which is ok). -KH *)
Axiom R2Q : R -> Q.
Definition R2Q_PI x := R2Q (x / PI).
Axiom Q2R_R2Q_PI : forall r, (Q2R (R2Q_PI r) * PI)%R = r.
Definition Rx {dim} a q : RzQ_ucom_l dim := H q :: Rzq (R2Q_PI a) q :: H q :: [].
Definition Rz {dim} a q := @App1 _ dim (URzQ_Rz (R2Q_PI a)) q.
Definition Ry {dim} a q : RzQ_ucom_l dim :=
  PDAG q :: H q :: Rzq (R2Q_PI a) q :: H q :: P q :: [].
Definition U1 {dim} a q := @Rz dim a q.
Definition U2 {dim} a b q : RzQ_ucom_l dim :=
  Rzq (R2Q_PI (b - PI)) q :: H q :: Rzq (R2Q_PI a) q :: [].
Definition U3 {dim} a b c q : RzQ_ucom_l dim :=
  Rzq (R2Q_PI (c - (PI/2))) q :: H q :: Rzq (R2Q_PI a) q ::
  H q :: Rzq (R2Q_PI (b + (PI/2))) q :: [].

Definition full_to_RzQ_u {dim} (g : gate_app Full_Unitary dim) : RzQ_ucom_l dim :=
  match g with
  | App1 U_I m              => [Rzq zero_Q m]
  | App1 U_X m              => [RzQGateSet.X m]
  | App1 U_Y m              => RzQGateSet.Y m
  | App1 U_Z m              => [RzQGateSet.Z m]
  | App1 U_H m              => [RzQGateSet.H m]
  | App1 U_S m              => [RzQGateSet.P m]
  | App1 U_T m              => [RzQGateSet.T m]
  | App1 U_Sdg m            => [RzQGateSet.PDAG m]
  | App1 U_Tdg m            => [RzQGateSet.TDAG m]
  | App1 (U_Rx r) m         => Rx r m
  | App1 (U_Ry r) m         => Ry r m
  | App1 (U_Rz r) m         => [Rz r m]
  | App1 (U_Rzq q) m        => [RzQGateSet.Rzq q m]
  | App1 (U_U1 r) m         => [U1 r m]
  | App1 (U_U2 r1 r2) m     => U2 r1 r2 m
  | App1 (U_U3 r1 r2 r3) m  => U3 r1 r2 r3 m
  | App2 U_CX m n           => [RzQGateSet.CNOT m n]
  | App2 U_CZ m n           => RzQGateSet.CZ m n
  | App2 U_SWAP m n         => RzQGateSet.SWAP m n
  | App3 U_CCX m n p        => RzQGateSet.CCX m n p
  | App3 U_CCZ m n p        => RzQGateSet.CCZ m n p
  | _ => [] (* unreachable *)
  end.

Definition RzQ_to_full_u {dim} (g : gate_app RzQ_Unitary dim) : full_ucom_l dim :=
  match g with
  | App1 URzQ_H m       => [App1 U_H m]
  | App1 URzQ_X m       => [App1 U_X m]
  | App1 (URzQ_Rz q) m  => [App1 (U_Rzq q) m]
  | App2 URzQ_CNOT m n  => [App2 U_CX m n]
  | _ => [] (* unreachable *)
  end.

Definition full_to_RzQ {dim} (l : full_ucom_l dim) : RzQ_ucom_l dim :=
  change_gate_set full_to_RzQ_u l.

Definition RzQ_to_full {dim} (l : RzQ_ucom_l dim) : full_ucom_l dim :=
  change_gate_set RzQ_to_full_u l.

Lemma RzQ_to_base1 : forall {dim} (u : RzQ_Unitary 1) n,
  RzQGateSet.to_base u [n] (one_elem_list n) ≡
    FullList.list_to_ucom (RzQ_to_full_u (@App1 _ dim u n)).
Proof.
  intros dim u n.
  dependent destruction u; simpl; rewrite SKIP_id_r; reflexivity.
Qed.

Lemma RzQ_to_base2 : forall {dim} (u : RzQ_Unitary 2) m n,
  RzQGateSet.to_base u (m :: n :: []) (two_elem_list m n) ≡
    FullList.list_to_ucom (RzQ_to_full_u (@App2 _ dim u m n)).
Proof.
  intros dim u m n.
  dependent destruction u; simpl; rewrite SKIP_id_r; reflexivity.
Qed.

Lemma RzQ_list_to_ucom : forall {dim} (l : RzQ_ucom_l dim),
  RzQList.list_to_ucom l ≡ FullList.list_to_ucom (RzQ_to_full l).
Proof.
  intros.
  induction l.
  reflexivity.
  simpl.
  unfold RzQ_to_full.
  rewrite change_gate_set_cons.
  rewrite FullList.list_to_ucom_append.
  destruct a.
  rewrite RzQ_to_base1, IHl.
  reflexivity.
  rewrite RzQ_to_base2, IHl.
  reflexivity.
  dependent destruction r.
Qed.

Lemma RzQ_to_full_equiv : forall {dim} (l l' : RzQ_ucom_l dim),
  RzQGateSet.RzQList.uc_equiv_l l l' ->
  FullList.uc_equiv_l (RzQ_to_full l) (RzQ_to_full l').
Proof.
  intros dim l l' H.
  unfold FullList.uc_equiv_l.
  unfold RzQGateSet.RzQList.uc_equiv_l in H.
  rewrite 2 RzQ_list_to_ucom in H.
  assumption.
Qed.

Lemma RzQ_to_full_cong : forall {dim} (l l' : RzQ_ucom_l dim),
  RzQGateSet.RzQList.uc_cong_l l l' ->
  FullList.uc_cong_l (RzQ_to_full l) (RzQ_to_full l').
Proof.
  intros dim l l' H.
  unfold FullList.uc_equiv_l.
  unfold RzQGateSet.RzQList.uc_cong_l in H.
  unfold uc_cong in H.
  rewrite 2 RzQ_list_to_ucom in H.
  assumption.
Qed.

Local Open Scope R.
Lemma Q2R_1_4_PI : forall {dim} q,
  @SQIR.Rz dim (Q2R (1 / 4) * PI) q ≡ SQIR.Rz (PI / 4) q.
Proof.
  intros dim q.
  unfold Q2R; simpl.
  autorewrite with R_db.
  rewrite Rmult_comm.
  reflexivity.
Qed.

Lemma Q2R_7_4_PI : forall {dim} q,
  @SQIR.Rz dim (Q2R (7 / 4) * PI) q ≡ SQIR.Rz (- (PI / 4)) q.
Proof.
  intros dim q.
  unfold Q2R; simpl.
  unfold uc_equiv; autorewrite with eval_db; try lia.
  gridify.
  replace (7 * / 4 * PI) with (2 * PI + - (PI / 4)) by lra.
  rewrite <- phase_mul.
  rewrite phase_2pi.
  Msimpl.
  reflexivity.
Qed.

Lemma Q2R_1_2_PI : forall {dim} q,
  @SQIR.Rz dim (Q2R (1 / 2) * PI) q ≡ SQIR.Rz (PI / 2) q.
Proof.
  intros dim q.
  unfold Q2R; simpl.
  autorewrite with R_db.
  rewrite Rmult_comm.
  reflexivity.
Qed.

Lemma Q2R_3_2_PI : forall {dim} q,
  @SQIR.Rz dim (Q2R (3 / 2) * PI) q ≡ SQIR.Rz (- (PI / 2)) q.
Proof.
  intros dim q.
  unfold Q2R; simpl.
  unfold uc_equiv; autorewrite with eval_db; try lia.
  gridify.
  replace (3 * / 2 * PI) with (2 * PI + - (PI / 2)) by lra.
  rewrite <- phase_mul.
  rewrite phase_2pi.
  Msimpl.
  reflexivity.
Qed.

Lemma Q2R_1_PI : Q2R 1 * PI = PI.
Proof. unfold Q2R; simpl. lra. Qed.

Lemma RzQ_to_full_inv : forall {dim} (l : full_ucom_l dim),
  FullList.uc_cong_l (RzQ_to_full (full_to_RzQ l)) l.
Proof.
  intros dim l.
  induction l.
  reflexivity.
  unfold full_to_RzQ, RzQ_to_full.
  rewrite change_gate_set_cons.
  rewrite change_gate_set_app.
  rewrite IHl.
  rewrite cons_to_app.
  FullList.apply_app_congruence_cong.
  destruct a; dependent destruction f;
  unfold change_gate_set; simpl; try reflexivity.
  all: unfold FullList.uc_cong_l; simpl; repeat rewrite <- uc_cong_assoc.
  all: unfold one_Q, half_Q, three_halves_Q, quarter_Q, seven_quarters_Q.
  all: try (apply uc_equiv_cong;
            repeat rewrite Q2R_1_2_PI; repeat rewrite Q2R_3_2_PI;
            repeat rewrite Q2R_1_4_PI; repeat rewrite Q2R_7_4_PI;
            try rewrite Q2R_1_PI; repeat rewrite Q2R_R2Q_PI; reflexivity).
  (* U_I *)
  unfold zero_Q.
  rewrite RMicromega.Q2R_0, Rmult_0_l.
  apply uc_equiv_cong.
  rewrite Rz_0_id.
  reflexivity.
  (* U_Y *)
  apply uc_equiv_cong.
  rewrite Q2R_1_2_PI, Q2R_3_2_PI.
  rewrite 2 SKIP_id_r.
  unfold uc_equiv; simpl.
  autorewrite with eval_db; try lia.
  gridify.
  do 2 (apply f_equal2; try reflexivity).
  solve_matrix; autorewrite with Cexp_db; lca.
  (* U_Rx *)
  rewrite rx_to_rz.
  apply uc_equiv_cong.
  rewrite Q2R_R2Q_PI.
  reflexivity.
  (* U_Ry *)
  rewrite ry_to_rz.
  apply uc_equiv_cong.
  rewrite Q2R_1_2_PI, Q2R_3_2_PI, Q2R_R2Q_PI.
  reflexivity.
  (* U_U2 *)
  apply uc_equiv_cong.
  rewrite 2 Q2R_R2Q_PI.
  rewrite u2_to_rz.
  reflexivity.
  (* U_U3 *)
  rewrite u3_to_rz.
  apply uc_equiv_cong.
  repeat rewrite Q2R_R2Q_PI.
  reflexivity.
Qed.

Lemma full_to_RzQ_WT : forall {dim} (l : full_ucom_l dim),
  uc_well_typed_l l ->
  uc_well_typed_l (full_to_RzQ l).
Proof.
  intros dim l WT.
  unfold full_to_RzQ.
  induction WT.
  - constructor. assumption.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; repeat constructor; assumption.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; repeat constructor; try assumption. lia.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; repeat constructor; assumption.
Qed.

Lemma full_to_RzQ_preserves_mapping : forall {dim} (l : full_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph U_CX l ->
  respects_constraints_directed is_in_graph URzQ_CNOT (full_to_RzQ l).
Proof.
  intros dim l is_in_graph H.
  unfold full_to_RzQ.
  induction l.
  constructor.
  rewrite change_gate_set_cons.
  inversion H; subst.
  apply respects_constraints_directed_app; auto.
  dependent destruction u; repeat constructor.
  apply respects_constraints_directed_app; auto.
  repeat constructor.
  assumption.
Qed.

Lemma RzQ_to_full_preserves_mapping : forall {dim} (l : RzQ_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph URzQ_CNOT l ->
  respects_constraints_directed is_in_graph U_CX (RzQ_to_full l).
Proof.
  intros dim l is_in_graph H.
  unfold RzQ_to_full.
  induction l.
  constructor.
  rewrite change_gate_set_cons.
  inversion H; subst.
  apply respects_constraints_directed_app; auto.
  dependent destruction u; repeat constructor.
  apply respects_constraints_directed_app; auto.
  repeat constructor.
  assumption.
Qed.

(** * Mapping gate set **)

Definition decompose_to_cnot_and_swap_u {dim} (g : gate_app Full_Unitary dim) : full_ucom_l dim :=
  match g with
  | App2 U_CZ m n     => App1 U_H n :: App2 U_CX m n :: App1 U_H n :: []
  | App3 U_CCX m n p  => App1 U_H p :: App2 U_CX n p :: App1 U_Tdg p ::
                        App2 U_CX m p :: App1 U_T p :: App2 U_CX n p ::
                        App1 U_Tdg p :: App2 U_CX m p :: App2 U_CX m n ::
                        App1 U_Tdg n :: App2 U_CX m n :: App1 U_T m ::
                        App1 U_T n :: App1 U_T p :: App1 U_H p :: []
  | App3 U_CCZ m n p  => App2 U_CX n p :: App1 U_Tdg p ::
                        App2 U_CX m p :: App1 U_T p :: App2 U_CX n p ::
                        App1 U_Tdg p :: App2 U_CX m p :: App2 U_CX m n ::
                        App1 U_Tdg n :: App2 U_CX m n :: App1 U_T m ::
                        App1 U_T n :: App1 U_T p :: []
  | g => [g]
  end.

Definition full_to_map_u {dim} (g : gate_app Full_Unitary dim) : gate_app (Map_Unitary (Full_Unitary 1)) dim :=
  match g with
  | App1 u m         => App1 (UMap_U u) m
  | App2 U_CX m n    => App2 UMap_CNOT m n
  | App2 U_SWAP m n  => App2 UMap_SWAP m n
  | _ => App1 (UMap_U U_I) 0 (* unreachable *)
  end.

Definition full_to_map {dim} (l : full_ucom_l dim) : map_ucom_l (Full_Unitary 1) dim :=
  change_gate_set (fun g => map full_to_map_u (decompose_to_cnot_and_swap_u g)) l.

Definition map_to_full_u {dim} (g : gate_app (Map_Unitary (Full_Unitary 1)) dim) : full_ucom_l dim :=
  match g with
  | App1 (UMap_U u) m    => [App1 u m]
  | App2 UMap_CNOT m n   => [App2 U_CX m n]
  | App2 UMap_SWAP m n   => [App2 U_SWAP m n]
  | _ => [] (* unreachable *)
  end.

Definition map_to_full {dim} (l : map_ucom_l (Full_Unitary 1) dim) : full_ucom_l dim :=
  change_gate_set map_to_full_u l.

Lemma map_to_full_inv : forall {dim} (l : full_ucom_l dim),
  FullList.uc_equiv_l (map_to_full (full_to_map l)) l.
Proof.
  intros dim l.
  induction l.
  reflexivity.
  unfold full_to_map, map_to_full.
  rewrite change_gate_set_cons.
  rewrite change_gate_set_app.
  rewrite IHl.
  rewrite cons_to_app.
  FullList.apply_app_congruence.
  destruct a; dependent destruction f;
  unfold change_gate_set; simpl; try reflexivity.
  all: unfold FullList.uc_equiv_l; simpl;
    repeat rewrite <- useq_assoc; reflexivity.
Qed.

Lemma full_to_map_WT : forall {dim} (l : full_ucom_l dim),
  uc_well_typed_l l ->
  uc_well_typed_l (full_to_map l).
Proof.
  intros dim l WT.
  unfold full_to_map.
  induction WT.
  - constructor. assumption.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; repeat constructor; assumption.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; repeat constructor; assumption.
  - dependent destruction u; rewrite change_gate_set_cons;
    simpl; repeat constructor; assumption.
Qed.

Lemma map_to_full_preserves_mapping_undirected : forall {dim} (l : map_ucom_l (Full_Unitary 1) dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_undirected is_in_graph l ->
  respects_constraints_undirected is_in_graph (map_to_full l).
Proof.
  intros dim l is_in_graph H.
  unfold map_to_full.
  induction l.
  constructor.
  rewrite change_gate_set_cons.
  inversion H; subst.
  apply respects_constraints_undirected_app; auto.
  dependent destruction u; repeat constructor.
  apply respects_constraints_undirected_app; auto.
  dependent destruction u; constructor.
  assumption. constructor. assumption. constructor.
Qed.

Lemma map_to_full_preserves_mapping_directed : forall {dim} (l : map_ucom_l (Full_Unitary 1) dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph UMap_CNOT l ->
  respects_constraints_directed is_in_graph U_CX (map_to_full l).
Proof.
  intros dim l is_in_graph H.
  unfold map_to_full.
  induction l.
  constructor.
  rewrite change_gate_set_cons.
  inversion H; subst.
  apply respects_constraints_directed_app; auto.
  dependent destruction u; repeat constructor.
  apply respects_constraints_directed_app; auto.
  repeat constructor.
  assumption.
Qed.

Lemma full_to_map_preserves_mapping_undirected : forall {dim} (l : full_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_undirected is_in_graph l ->
  respects_constraints_undirected is_in_graph (full_to_map l).
Proof.
  intros dim l is_in_graph H.
  unfold full_to_map.
  induction l.
  constructor.
  rewrite change_gate_set_cons.
  inversion H; subst.
  apply respects_constraints_undirected_app; auto.
  dependent destruction u; repeat constructor.
  apply respects_constraints_undirected_app; auto.
  dependent destruction u; repeat apply res_und_app2; try assumption.
  constructor.
  constructor. constructor. assumption. constructor. constructor.
  constructor.
Qed.

(** * Check that every gate in the program satisfies some predicate **)

Definition forall_gates {U : nat -> Set} {dim} (p : gate_app U dim -> Prop) (l : gate_list U dim) :=
  forall g, In g l -> p g.

Lemma forall_gates_drop : forall {U : nat -> Set} {dim} (p : gate_app U dim -> Prop) (g : gate_app U dim) (l : gate_list U dim),
  forall_gates p (g :: l) -> forall_gates p l.
Proof.
  intros U dim p g l H.
  unfold forall_gates in *.
  intros g0 Hg0.
  apply H.
  right.
  assumption.
Qed.

Lemma forall_gates_extend : forall {U : nat -> Set} {dim} (p : gate_app U dim -> Prop) (g : gate_app U dim) (l : gate_list U dim),
  p g -> forall_gates p l -> forall_gates p (g :: l).
Proof.
  intros U dim p g l Hg Hl.
  unfold forall_gates in *.
  intros g0 [Hg0 | Hg0].
  subst.
  assumption.
  apply Hl.
  assumption.
Qed.

Lemma forall_gates_append : forall {U : nat -> Set} {dim} (p : gate_app U dim -> Prop) (l1 l2 : gate_list U dim),
  forall_gates p l1 -> forall_gates p l2 -> forall_gates p (l1 ++ l2).
Proof.
  intros U dim p l1 l2 Hl1 Hl2.
  unfold forall_gates in *.
  intros g Hg.
  apply in_app_or in Hg as [Hg | Hg]; auto.
Qed.

(** * Other gate set conversions **)

(* Transform program in the full gate set to only use CNOT + 1q gates *)
Definition decompose_to_cnot_u {dim} (g : gate_app Full_Unitary dim) : full_ucom_l dim :=
  match g with
  | App2 U_CZ m n     => App1 U_H n :: App2 U_CX m n :: App1 U_H n :: []
  | App2 U_SWAP m n   => App2 U_CX m n :: App2 U_CX n m :: App2 U_CX m n :: []
  | App3 U_CCX m n p  => App1 U_H p :: App2 U_CX n p :: App1 U_Tdg p ::
                        App2 U_CX m p :: App1 U_T p :: App2 U_CX n p ::
                        App1 U_Tdg p :: App2 U_CX m p :: App2 U_CX m n ::
                        App1 U_Tdg n :: App2 U_CX m n :: App1 U_T m ::
                        App1 U_T n :: App1 U_T p :: App1 U_H p :: []
  | App3 U_CCZ m n p  => App2 U_CX n p :: App1 U_Tdg p ::
                        App2 U_CX m p :: App1 U_T p :: App2 U_CX n p ::
                        App1 U_Tdg p :: App2 U_CX m p :: App2 U_CX m n ::
                        App1 U_Tdg n :: App2 U_CX m n :: App1 U_T m ::
                        App1 U_T n :: App1 U_T p :: []
  | g => [g]
  end.

Definition decompose_to_cnot {dim} (l : full_ucom_l dim) :=
  change_gate_set decompose_to_cnot_u l.

Definition only_cnots {dim} (g : gate_app Full_Unitary dim) :=
  match g with
  | App2 U_CZ _ _ | App2 U_SWAP _ _ | App3 U_CCX _ _ _ | App3 U_CCZ _ _ _ => False
  | _ => True
  end.

Lemma decompose_to_cnot_gates : forall {dim} (l : full_ucom_l dim),
  forall_gates only_cnots (decompose_to_cnot l).
Proof.
  intros dim l.
  unfold decompose_to_cnot.
  induction l.
  - rewrite change_gate_set_nil.
    intros g H.
    inversion H.
  - rewrite change_gate_set_cons.
    intros g H.
    apply in_app_or in H as [H | H].
    destruct a; dependent destruction f.
    all: simpl in H; repeat destruct H as [H | H]; try rewrite <- H;
         simpl; auto; try contradiction.
Qed.

Lemma decompose_to_cnot_sound : forall {dim} (l : full_ucom_l dim),
  FullList.uc_equiv_l (decompose_to_cnot l) l.
Proof.
  intros dim l.
  unfold decompose_to_cnot.
  induction l.
  - rewrite change_gate_set_nil.
    reflexivity.
  - rewrite change_gate_set_cons.
    unfold FullList.uc_equiv_l in *.
    simpl.
    rewrite FullList.list_to_ucom_append.
    destruct a; apply useq_congruence; try apply IHl;
      dependent destruction f; simpl;
      repeat rewrite <- useq_assoc; rewrite SKIP_id_r;
      reflexivity.
Qed.

Lemma decompose_to_cnot_WT : forall {dim} (l : full_ucom_l dim),
  uc_well_typed_l l -> uc_well_typed_l (decompose_to_cnot l).
Proof.
  intros dim l WT.
  eapply FullList.uc_equiv_l_implies_WT.
  symmetry.
  apply decompose_to_cnot_sound.
  assumption.
Qed.

Definition convert_to_ibm {dim} (l : full_ucom_l dim) : full_ucom_l dim :=
  IBM_to_full (full_to_IBM l).

Definition only_ibm {dim} (g : gate_app Full_Unitary dim) :=
  match g with
  | App1 (U_U1 _) _ | App1 (U_U2 _ _) _ | App1 (U_U3 _ _ _) _ | App2 U_CX _ _ => True
  | _ => False
  end.

Lemma convert_to_ibm_gates : forall {dim} (l : full_ucom_l dim),
  forall_gates only_ibm (convert_to_ibm l).
Proof.
  intro dim.
  assert (H : forall (l : IBM_ucom_l dim), forall_gates only_ibm (IBM_to_full l)).
  { unfold IBM_to_full.
    induction l.
    - rewrite change_gate_set_nil.
      intros g H.
      inversion H.
    - rewrite change_gate_set_cons.
      intros g H.
      apply in_app_or in H as [H | H].
      destruct a; dependent destruction i.
      all: simpl in H; repeat destruct H as [H | H]; try rewrite <- H.
      all: simpl; auto; contradiction. }
  intro l.
  apply H.
Qed.

Lemma convert_to_ibm_sound : forall {dim} (l : full_ucom_l dim),
  FullList.uc_equiv_l (convert_to_ibm l) l.
Proof. intros. apply IBM_to_full_inv. Qed.

Lemma convert_to_ibm_preserves_mapping : forall {dim} (l : full_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph U_CX l ->
  respects_constraints_directed is_in_graph U_CX (convert_to_ibm l).
Proof.
  intros dim l is_in_graph H.
  unfold convert_to_ibm.
  apply IBM_to_full_preserves_mapping.
  apply full_to_IBM_preserves_mapping.
  assumption.
Qed.

Definition convert_to_rzq {dim} (l : full_ucom_l dim) : full_ucom_l dim :=
  RzQ_to_full (full_to_RzQ l).

Definition only_rzq {dim} (g : gate_app Full_Unitary dim) :=
  match g with
  | App1 U_H _ | App1 U_X _ | App1 (U_Rzq _) _ | App2 U_CX _ _ => True
  | _ => False
  end.

Lemma convert_to_rzq_gates : forall {dim} (l : full_ucom_l dim),
  forall_gates only_rzq (convert_to_rzq l).
Proof.
  intro dim.
  assert (H : forall (l : RzQ_ucom_l dim), forall_gates only_rzq (RzQ_to_full l)).
  { unfold RzQ_to_full.
    induction l.
    - rewrite change_gate_set_nil.
      intros g H.
      inversion H.
    - rewrite change_gate_set_cons.
      intros g H.
      apply in_app_or in H as [H | H].
      destruct a; dependent destruction r.
      all: simpl in H; repeat destruct H as [H | H]; try rewrite <- H.
      all: simpl; auto; contradiction. }
  intro l.
  apply H.
Qed.

Lemma convert_to_rzq_sound : forall {dim} (l : full_ucom_l dim),
  FullList.uc_cong_l (convert_to_rzq l) l.
Proof. intros. apply RzQ_to_full_inv. Qed.

Lemma convert_to_rzq_preserves_mapping : forall {dim} (l : full_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph U_CX l ->
  respects_constraints_directed is_in_graph U_CX (convert_to_rzq l).
Proof.
  intros dim l is_in_graph H.
  unfold convert_to_rzq.
  apply RzQ_to_full_preserves_mapping.
  apply full_to_RzQ_preserves_mapping.
  assumption.
Qed.

(* Replace Rzq gates with I, Z, S, Sdg, T, Tdg, or Rz gates. *)
Definition replace_rzq_u {dim} (g : gate_app Full_Unitary dim) : full_ucom_l dim :=
  match g with
  | App1 (U_Rzq q) m =>
      if Qeq_bool q zero_Q then [App1 U_I m]
      else if Qeq_bool q one_Q then [App1 U_Z m]
      else if Qeq_bool q half_Q then [App1 U_S m]
      else if Qeq_bool q three_halves_Q then [App1 U_Sdg m]
      else if Qeq_bool q quarter_Q then [App1 U_T m]
      else if Qeq_bool q seven_quarters_Q then [App1 U_Tdg m]
      else [App1 (U_Rz (Q2R q * PI)) m]
  | g => [g]
  end.

Definition replace_rzq {dim} (l : full_ucom_l dim) :=
  change_gate_set replace_rzq_u l.

Definition no_rzq {dim} (g : gate_app Full_Unitary dim) :=
  match g with
  | App1 (U_Rzq _) _ => False
  | _ => True
  end.

Ltac destruct_Qeq_bool :=
  repeat match goal with
  | H : context[if Qeq_bool ?a ?b then _ else _] |- _ =>
      destruct (Qeq_bool a b) eqn:?
  | |- context[if Qeq_bool ?a ?b then _ else _] =>
      destruct (Qeq_bool a b) eqn:?
  | H : Qeq_bool _ _ = true |- _ => apply Qeq_bool_iff in H
  | H : Qeq_bool _ _ = false |- _ => clear H
  | H : (_ == _)%Q |- _ => apply Qeq_eqR in H; try rewrite H
  end.

Lemma replace_rzq_gates : forall {dim} (l : full_ucom_l dim),
  forall_gates no_rzq (replace_rzq l).
Proof.
  intros dim l.
  unfold replace_rzq.
  induction l.
  - rewrite change_gate_set_nil.
    intros g H.
    inversion H.
  - rewrite change_gate_set_cons.
    intros g H.
    apply in_app_or in H as [H | H].
    destruct a; dependent destruction f.
    all: simpl in H.
    all: destruct_Qeq_bool.
    all: repeat destruct H as [H | H]; try rewrite <- H.
    all: simpl; auto; try contradiction.
Qed.

Lemma replace_rzq_sound : forall {dim} (l : full_ucom_l dim),
  FullList.uc_equiv_l (replace_rzq l) l.
Proof.
  intros dim l.
  unfold replace_rzq.
  induction l.
  - rewrite change_gate_set_nil.
    reflexivity.
  - rewrite change_gate_set_cons.
    unfold FullList.uc_equiv_l in *.
    simpl.
    rewrite FullList.list_to_ucom_append.
    destruct a; apply useq_congruence; try apply IHl;
      dependent destruction f; simpl;
      repeat rewrite <- useq_assoc; try rewrite SKIP_id_r; try reflexivity.
    destruct_Qeq_bool; simpl; rewrite SKIP_id_r.
    unfold zero_Q.
    rewrite RMicromega.Q2R_0.
    rewrite Rmult_0_l.
    reflexivity.
    unfold one_Q.
    rewrite RMicromega.Q2R_1.
    rewrite Rmult_1_l.
    reflexivity.
    unfold half_Q.
    rewrite Q2R_1_2_PI.
    reflexivity.
    unfold three_halves_Q.
    bdestruct (n <? dim)%nat.
    rewrite Q2R_3_2_PI by assumption.
    reflexivity.
    unfold uc_equiv; simpl; unfold SQIR.PDAG; autorewrite with eval_db; gridify.
    unfold quarter_Q.
    rewrite Q2R_1_4_PI.
    reflexivity.
    unfold seven_quarters_Q.
    bdestruct (n <? dim)%nat.
    rewrite Q2R_7_4_PI by assumption.
    reflexivity.
    unfold uc_equiv; simpl; unfold SQIR.TDAG; autorewrite with eval_db; gridify.
    reflexivity.
Qed.

Lemma replace_rzq_preserves_mapping : forall {dim} (l : full_ucom_l dim) (is_in_graph : nat -> nat -> bool),
  respects_constraints_directed is_in_graph U_CX l ->
  respects_constraints_directed is_in_graph U_CX (replace_rzq l).
Proof.
  intros dim l is_in_graph H.
  unfold replace_rzq.
  induction l.
  constructor.
  rewrite change_gate_set_cons.
  inversion H; subst.
  apply respects_constraints_directed_app; auto.
  dependent destruction u; repeat constructor.
  simpl.
  destruct_Qeq_bool; repeat constructor.
  apply respects_constraints_directed_app; auto.
  repeat constructor.
  assumption.
Qed.


Require Import MetaCoq.Template.All.
Require Import List String Relation_Operators.
Import ListNotations MonadNotation.

(* Require Import sigma. *)

Definition filteri {A: Type} (f : nat -> A -> bool) (l:list A) : list A :=
  let go := fix go n l := match l with
                         | nil => nil
                         | x :: l => if f n x then x::(go (S n) l) else go (S n) l
                         end
  in go 0 l.

Definition ind_eqb (i0 : inductive) (i1 : inductive) : bool :=
  andb (String.eqb i0.(inductive_mind) i1.(inductive_mind))
       (Nat.eqb i0.(inductive_ind) i1.(inductive_ind)).

Definition opt_nil {A : Type} (x : option A) : list A := match x with Some a => [a]| None => [] end.

Definition clift0 (n : nat) (t : context_decl) : context_decl :=
  {| decl_name := t.(decl_name);
     decl_body := match t.(decl_body) with
                   | Some q => Some (lift0 n q)
                   | None => None
                  end;
     decl_type := lift0 n t.(decl_type)
  |}.

Definition subterms_for_constructor
           (refi  : inductive)
           (ref   : term) (* we need the term that contrains exactly this inductive just for the substition *)
           (npars : nat) (* number of parameters in the type *)
           (nind : nat) (* number of proper indeces in the type *)
           (ct    : term) (* type of the constructor *)
           (ncons : nat) (* index of the constructor in the inductive *)
           (nargs : nat) (* number of arguments in this constructor *)
                  : list (nat * term * nat)
  := let nct := subst10 ref ct in
     let '(ctx, ap) := decompose_prod_assum [] nct in
     (* now ctx is reversed list of assumptions and definitions *)
     let len := List.length ctx in
     let params := List.skipn (len - npars) (ctx) in
     let inds := List.skipn npars (snd (decompose_app ap)) in
     let d :=(List.flat_map opt_nil ∘
                  (* so this i represents distance from the innermost object *)
               mapi (fun i t =>
                       let '(ctx, ar) := decompose_prod_assum [] (decl_type t)
                       in match (fst (decompose_app ar)) with
                          | tInd indj _ => if ind_eqb indj refi
                                          then Some (i, ctx,
                                                     snd (decompose_app ar))
                                          else None
                          | _ => None
                          end)) ctx in
     let construct_cons :=
         fun (* index of a subterm in this constructor *)
           (i: nat)
           (* these are arguments for the function
              that is a parameter of the constructor
              and if applied fully returns something of the needed type *)
           (ctx': context)
           (* these are arguments of the type of the subterm *)
           (args' : list term) =>
           let len' := List.length ctx' in
           let ctxl' := (map (clift0 (2 + i)) ctx') in
           it_mkProd_or_LetIn
             (ctxl' ++ ctx)
             (tApp (tRel (len + len'))
                   ((map (lift0 (len' + len - npars))
                         (to_extended_list params)) ++
                    (map (lift (1 + i + len') len') (List.skipn npars args')) ++
                    (map (lift0 len') inds) ++
                    [tApp (tRel (i + len'))
                          (to_extended_list ctxl');
                     tApp (tConstruct refi ncons [])
                          (map (lift0 len')
                               (to_extended_list ctx))])) in
     mapi (fun i '(n, c, a) => (i, construct_cons n c a, len + List.length c)) d.

Definition subterm_for_ind
           (refi  : inductive) (* reference term for the inductive type *)
           (ref   : term)
           (npars : nat)
           (pars  : context)
           (ind   : one_inductive_body)
                  : one_inductive_body
  := let (pai, sort) := decompose_prod_assum [] ind.(ind_type) in
     let inds := List.firstn (List.length pai - npars) pai in
     let leni := List.length inds in
     let aptype1 :=
         tApp ref ((map (lift0 (2 * leni)) (to_extended_list pars)) ++
                   (map (lift0 leni) (to_extended_list inds))) in
     let aptype2 :=
         tApp ref ((map (lift0 (1 + 2 * leni)) (to_extended_list pars)) ++
                   (map (lift0 1) (to_extended_list inds))) in
     let renamer name i := (name ++ "_subterm" ++ (string_of_nat i))%string in
     {| ind_name := (ind.(ind_name) ++ "_direct_subterm")%string;
        (* type_for_direct_subterm npars *)
        ind_type  := it_mkProd_or_LetIn
                       pars
                       (it_mkProd_or_LetIn
                          (inds ++ inds)
                          (tProd nAnon aptype1
                                 (tProd nAnon aptype2 sort)));
        ind_kelim := [InProp];
        ind_ctors :=List.concat
                      (mapi (fun n '(id, ct, k) => (
                        map (fun '(si, st, sk) => (renamer id si, st, sk))
                        (subterms_for_constructor refi ref npars leni ct n k)))
                        ind.(ind_ctors));
        ind_projs := [] |}.

Definition direct_subterm_for_mutual_ind
            (mind : mutual_inductive_body)
            (ind0 : inductive) (* internal metacoq representation of inductive, part of tInd *)
            (ref  : term) (* reference term for the inductive type, like (tInd {| inductive_mind := "Coq.Init.Datatypes.nat"; inductive_ind := 0 |} []) *)
                  : mutual_inductive_body
  := let i0 := inductive_ind ind0 in
     {| ind_finite := BasicAst.Finite;
        ind_npars := mind.(ind_npars);
        ind_universes := mind.(ind_universes);
        ind_params := mind.(ind_params);
        ind_bodies := (map (subterm_for_ind ind0 ref mind.(ind_npars) mind.(ind_params)) ∘
                      (filteri (fun (i : nat) (ind : one_inductive_body) =>
                                  if Nat.eqb i i0 then true else false)))
                      mind.(ind_bodies);
     |}.

Polymorphic Definition subterm (tm : Ast.term)
  : TemplateMonad unit
  := match tm with
     | tInd ind0 _ =>
       (* ge_ <- tmQuoteRec tm;; *)
       decl <- tmQuoteInductive (inductive_mind ind0);;
       let direct_subterm := direct_subterm_for_mutual_ind decl ind0 tm in
       tmMkInductive' direct_subterm
       (* v <- tmEval direct_subterm;;
          tmPrint v;; *)
     | _ => tmPrint tm;; tmFail "is not an inductive"
     end.

Inductive finn (A : Type) : nat -> Set :=
  F1n : forall n : nat, finn A (S n)
| FSn : forall n : nat, finn A n -> finn A (S n).

Inductive fin : nat -> Type :=
  F1 : forall n : nat, fin (let x := S n in x)
| FS : forall n : nat, fin n -> fin (S n).

Run TemplateProgram (subterm <%list%>).
Print list_direct_subterm.

Definition scope := nat.
Inductive scope_le : scope -> scope -> Set :=
| scope_le_n : forall {n m}, n = m -> scope_le n m
| scope_le_S : forall {n m}, scope_le n m -> scope_le n (S m)
| scope_le_map : forall {n m}, scope_le n m -> scope_le (S n) (S m)
.

Run TemplateProgram (subterm <%scope_le%>).

(*
Inductive
scope_le_direct_subterm
    : forall H H0 H1 H2 : scope, scope_le H H0 -> scope_le H1 H2 -> Set :=
    scope_le_S_subterm0 : forall (n m : scope) (H : scope_le n m),
                          scope_le_direct_subterm n m n (S m) H (scope_le_S H)
  | scope_le_map_subterm0 : forall (n m : scope) (H : scope_le n m),
                            scope_le_direct_subterm n m
                              (S n) (S m) H (scope_le_map H)
*)


(*
 * Copyright (c) 2022 BedRock Systems, Inc.
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

Require Import bedrock.prelude.base.
Require Import bedrock.lang.bi.split_andb.

(**
[Split b b1 b2] succeeds if [SplitAndB b] outputs [b1], [b2].
*)
Class Split (b b1 b2 : bool) : Prop := split : SplitAndB b b1 b2.
#[global] Hint Mode Split + + + : typeclass_instances.
#[global] Instance split_instance b b'1 b'2 b1 b2 :
  SplitAndB b b'1 b'2 -> TCEq b1 b'1 -> TCEq b2 b'2 -> Split b b1 b2 | 10.
Proof. by rewrite !TCEq_eq=>? ->->. Qed.

Section split.

  Lemma split_andb b1 b2 : Split (b1 && b2) b1 b2.
  Proof. apply _. Abort.

  Lemma split_x b : Split b b b.
  Proof. apply _. Abort.

End split.

(**
[Combine b1 b2 b] succeeds if [CombineAndB b1 b2] outputs [b].
*)
Class Combine (b1 b2 b : bool) : Prop := combine : CombineAndB b1 b2 b.
#[global] Hint Mode Combine + + + : typeclass_instances.
#[global] Instance combine_instance b1 b2 b' b :
  CombineAndB b1 b2 b' -> TCEq b b' -> Combine b1 b2 b | 10.
Proof. by rewrite TCEq_eq=>? ->. Qed.

Section combine.

  Lemma combine_00 : Combine false false false.
  Proof. apply _. Abort.
  Lemma combine_01 : Combine false true false.
  Proof. apply _. Abort.
  Lemma combine_10 : Combine true false false.
  Proof. apply _. Abort.
  Lemma combine_11 : Combine true true true.
  Proof. apply _. Abort.

  Lemma combine_0x b : Combine false b false.
  Proof. apply _. Abort.
  Lemma combine_x0 b : Combine b false false.
  Proof. apply _. Abort.

  Lemma combine_1x b : Combine true b b.
  Proof. apply _. Abort.
  Lemma combine_x1 b : Combine b true b.
  Proof. apply _. Abort.

  Lemma combine_xx b1 b2 : Combine b1 b2 (b1 && b2).
  Proof. apply _. Abort.

End combine.


From Coq Require Import
     ssreflect
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Functor
     SubFunctor
     Sum1
     UniversalProperty
.

Local Open Scope SubFunctor.
Local Open Scope Sum1.

(**

[ProofAlgebra] captures those algebras that we will use for theorem proving.
Because proofs are not computationally-revelant, they will never use more
advanced algebras like Mendler of Mixin.  Simple, plain old algebras suffice.

In practice, we will use them at type [sig P] for a given property [P] to prove
about the term of interest.

In order to distinguish some [ProofAlgebra]s that would otherwise have the
same signature, each [ProofAlgebra] is given a unique [Tag].  This helps
the typeclass mechanism find the appropriate instance among a bunch of program
algebras with the same carrier types.

You can just create a new label with:
[Variant MyTag := .]
The type does not need any inhabitant, we only use its type identity.

*)

Class ProofAlgebra (* cf. [PAlgebra] *)
      (Tag : Set) F A
      `{Functor F}
  :=
    {
      proofAlgebra : (* cf. [p_algebra] *)
        Algebra F A;
    }.

(**
Just like [proofAlgebra], but when you want to provide the [ProofAlgebra]
explicitly.
 *)
Definition proofAlgebra'
           {Tag F A}
           `{Functor F}
           (PA : ProofAlgebra Tag F A)
  : Algebra F A
  := proofAlgebra (ProofAlgebra := PA).

Global Instance
       ProofAlgebra__Sum1
       Tag F G {A}
       `{Functor F} `{Functor G}
       `{! ProofAlgebra Tag F A}
       `{! ProofAlgebra Tag G A}
  : ProofAlgebra Tag (F + G) A
  :=
    {|
      proofAlgebra :=
        fun fg =>
          match fg with
          | inl1 f => proofAlgebra f
          | inr1 g => proofAlgebra g
          end
      ;
    |}.

(**

A proof-producing [ProofAlgebra] is well-formed if the term it re-creates by
applying the algebra (in the left hand of the dependent pair) is indeed the
original term.  That is, the following diagram commutes:

                          proofAlgebra
F (Σ (e : Fix E) . P e) ---------------> Σ (e : Fix E) . P e
        |                                          |
        | fmap proj1_sig                           |
        v                                          |
     F (Fix E)                                     | proj1_sig
        |                                          |
        | inj                                      |
        v                                          v
    E (Fix E) ---------------------------------> Fix E
                           wrapF

*)

(** NOTE: it does not pay off trying to make [P] be about [WellFormedValue]
    properties, because we will not be able to prove the property over the
    dependent pair, only about its [proj1_sig].
*)
Class WellFormedProofAlgebra (* cf. [WF_Ind] *)
      {Tag E F} {P : Fix E -> Prop}
      `{Functor E} `{Functor F}
      `{E supports F}
      `(PA : ! ProofAlgebra Tag F (sig P))
  :=
    {
      projEq
      : forall e,
        (* run [proofAlgebra], then observe the term *)
        proj1_sig (proofAlgebra e)
        =
        (* observe all subterms via [fmap], and combine them *)
        wrapF (inject (E := E) (fmap (proj1_sig (P := P)) e));
    }.

(* TODO: document why we need this *)
(* TODO: fix this so that [Tag] [F] [G] [H] are explicit and [PA] implicit *)
Class WellFormedProofAlgebra2 (* cf. [WF_Ind2] *)
      {Tag F G H}
      `{SG : SubFunctor F G} `{SH : SubFunctor F H}
      {P : (Fix G * Fix H) -> Prop}
      `(PA : ! ProofAlgebra Tag F (sig P))
  :=
    {
      proj1Eq
      : forall e,
        (* run [proofAlgebra], then observe the term *)
        fst (proj1_sig (proofAlgebra (ProofAlgebra := PA) e))
        =
        (* observe all subterms via [fmap], and combine them *)
        wrapF (inject (SubFunctor := SG) (fmap (fun e => fst (proj1_sig (P := P) e)) e));
      proj2Eq
      : forall e,
        (* run [proofAlgebra], then observe the term *)
        snd (proj1_sig (proofAlgebra (ProofAlgebra := PA) e))
        =
        (* observe all subterms via [fmap], and combine them *)
        wrapF (inject (SubFunctor := SH) (fmap (fun e => snd (proj1_sig (P := P) e)) e));
    }.

(* TODO *)
(*
Global Instance
       WellFormedProofAlgebraSum1
       {P}
       {F} `{Functor F} {FAlg : ProofAlgebra F (sig P)}
       {G} `{Functor G} {GAlg : ProofAlgebra G (sig P)}
       {H} `{Functor H}
       `{FGH : (F + G) <= H}
       {_ : WellFormedProofAlgebra (F := F) (G := H) (FG := SubFunctorLeft  (FG := FGH)) FAlg}
       {_ : WellFormedProofAlgebra (F := G) (G := H) (FG := SubFunctorRight (FH := FGH)) GAlg}
  : WellFormedProofAlgebra (ProofAlgebraSum1 FAlg GAlg).
Proof.
  constructor.
  intros rec f.
  unfold inj.
  unfold SubFunctorLeft.
  simpl.
  rewrite wellFormedProofAlgebra.
  reflexivity.
Qed.
 *)

Lemma Fusion'
      {F} `{Functor F}
      (e : Fix F) {UP : FoldUP' e}
      (A B : Set) (h : A -> B) (f : Algebra F A) (g : Algebra F B)
      (HF : forall a, h (f a) = g (fmap h a))
      : (fun e' => h (fold f e')) e = fold g e.
Proof.
  apply foldUP' => e'.
  rewrite (FoldUP F _ f) => //.
  rewrite HF.
  rewrite fmapFusion.
  rewrite /compose //.
Qed.

Lemma Fusion
      {F} `{Functor F}
      `{Functor F}
      (e : WellFormedValue F)
      (A B : Set) (h : A -> B) (f : Algebra F A) (g : Algebra F B)
      (HF : forall a, h (f a) = g (fmap h a))
      : (fun e' => h (fold f e')) (proj1_sig e) = fold g (proj1_sig e).
Proof.
  case e => *.
  apply Fusion' => //.
Qed.

(**
TODO: document this, where is it used? why does it need a well-formed reflexive
sub-functor?
 *)
Lemma proj1_fold_is_id
      {Tag F} `{Functor F}
      {P : Fix F -> Prop}
      {PA : ProofAlgebra Tag F (sig P)}
      `{! WellFormedProofAlgebra PA}
  : forall (f : Fix F),
    FoldUP' f ->
    proj1_sig (fold (proofAlgebra' PA) f) = f.
Proof.
  move => f UP.
  setoid_rewrite Fusion' with (g := wrapF) => //.
  {
    rewrite fold_wrapF_Identity //.
  }
  {
    move => a.
    rewrite projEq //.
  }
Qed.

Lemma fst_proj1_fold_is_id
      {Tag F} `{Functor F}
      {P : (Fix F * Fix F) -> Prop}
      {PA : ProofAlgebra Tag F (sig P)}
      {WFPA : WellFormedProofAlgebra2 PA}
  : forall (f : Fix F),
    FoldUP' f ->
    fst (proj1_sig (fold (proofAlgebra' PA) f)) = f.
Proof.
  move => f UP.
  setoid_rewrite (Fusion' f _ _ (fun e => fst (proj1_sig e)) _ wrapF).
  {
    rewrite fold_wrapF_Identity //.
  }
  {
    move => a.
    rewrite proj1Eq //.
  }
Qed.

Lemma snd_proj1_fold_is_id
      {Tag F} `{Functor F}
      {P : (Fix F * Fix F) -> Prop}
      {PA : ProofAlgebra Tag F (sig P)}
      {_ : WellFormedProofAlgebra2 PA}
  : forall (f : Fix F),
    FoldUP' f ->
    snd (proj1_sig (fold (proofAlgebra' PA) f)) = f.
Proof.
  move => f UP.
  setoid_rewrite (Fusion' f _ _ (fun e => snd (proj1_sig e)) _ wrapF).
  {
    rewrite fold_wrapF_Identity //.
  }
  {
    move => a.
    rewrite proj2Eq //.
  }
Qed.

Lemma Induction (* cf. [Ind] *)
      {Tag F}
      `{Functor F}
      {P : Fix F -> Prop}
      `{PA : ! ProofAlgebra Tag F (sig P)}
      `{! WellFormedProofAlgebra PA}
  : forall (f : Fix F),
    FoldUP' f ->
    P f.
Proof.
  move => f UP.
  setoid_rewrite <- proj1_fold_is_id => //.
  apply proj2_sig.
Qed.

Lemma Induction'
      {Tag F}
      `{Functor F}
      {P : Fix F -> Prop}
      `{PA : ! ProofAlgebra Tag F (sig P)}
      `{! WellFormedProofAlgebra PA}
  : forall (f : WellFormedValue F),
    P (proj1_sig f).
Proof.
  destruct f as [f UP].
  now apply Induction.
Qed.

Lemma Induction2 (* cf. [Ind2] *)
      {Tag F} `{Functor F}
      {P : (Fix F * Fix F) -> Prop}
      {PA : ProofAlgebra Tag F (sig P)}
      {_ : WellFormedProofAlgebra2 PA}
  : forall (f : Fix F),
    FoldUP' f ->
    P (f, f).
Proof.
  move => f UP.
  setoid_rewrite <- (fst_proj1_fold_is_id f UP) at 1.
  setoid_rewrite <- (snd_proj1_fold_is_id f UP) at 2.
  rewrite <- surjective_pairing.
  apply proj2_sig.
Qed.


(** printing nat %\ensuremath{\mathbb{N}}% #ℕ# *)
(** printing -> %\ensuremath{\to}% #→$ *)

(* begin hide *)
Require Import mathcomp.ssreflect.all_ssreflect.
Require Import Paco.paco.
Require Import Int63.

Require Import Utils.ZooidTac.
Require Import Zooid2.Types.

Set Implicit Arguments.
Set Primitive Projections.
(* end hide *)

(** * Act II: Smol-Zooid: multiparty with shallower embedding  *)

(** ** Preliminaries

Deep embeddings lead to complex complex binder mechanisations. Can shallow
embeddings of binders help mechanising a small process language?

*)

(** ** Smol Zooid *)

(** This is a small process language *)

(** We introduce a typing discipline for [proc], to constraint the kinds of
 traces that are allowed by the process. This typing discipline uses *local
 types* from Multiparty Session Types to categorise processes according to the
 set of traces that they accept. For this tutorial, we simplified the local
 types so they do not accept choices. **)

(** The typing system relates [proc] with [lty] so [proc] can only take a
communication type, if the specification allows it: **)

Section Processes.
  Context (E : Type -> Type).

  Notation CAN_SEND p T kL L := (b_run L = @p_act lprefix (mk_lprefix a_send p) T kL).
  Notation CAN_RECV p T kL L := (b_run L = @p_act lprefix (mk_lprefix a_recv p) T kL).

  Notation IS_SEND := (@erefl _ (@p_act _ (mk_lprefix a_send _) _ _)).
  Notation IS_RECV := (@erefl _ (@p_act _ (mk_lprefix a_recv _) _ _)).

  Inductive msg L : forall T, (T -> LocalType) -> Type :=
  | Send p A  (x : A) kL (H : CAN_SEND p A kL L) : @msg L unit (fun=> kL x)
  | Recv p A          kL (H : CAN_RECV p A kL L) : @msg L A    kL
  (* Silent action *)
  | Eff T (e : E T) : @msg L T (fun=> L)
  .

  Notation CAN_END L := (b_run L = p_end _).
  Notation IS_END := (@erefl _ (p_end _)).

  Inductive procF (X : LocalType -> Type) (L : LocalType) :=
  | Inact (_ : CAN_END L)
  | Tau (k : X L)
  | Do {T kL} (e : @msg L T kL) (k : forall x, X (kL x))
  .
End Processes.

Notation CAN_SEND p T kL L := (b_run L = @p_act lprefix (mk_lprefix a_send p) T kL).
Notation CAN_RECV p T kL L := (b_run L = @p_act lprefix (mk_lprefix a_recv p) T kL).

Notation IS_SEND := (@erefl _ (@p_act _ (mk_lprefix a_send _) _ _)).
Notation IS_RECV := (@erefl _ (@p_act _ (mk_lprefix a_recv _) _ _)).

Notation CAN_END L := (b_run L = p_end _).
Notation IS_END := (@erefl _ (p_end _)).

CoInductive proc E L := mk_proc { observe : @procF E (proc E) L }.
Definition iproc E L := procF E (proc E) L.

Arguments mk_proc & [E L] observe.
Arguments Send & {E L} p {A} x {kL} H.
Arguments Recv & {E L} p {A kL} H.
Arguments Eff & {E L T} e.
Arguments Inact & {E X L}.
Arguments Tau & {E X L } k.
Arguments Do & {E X L T kL} e k.

(** This defines processes ([proc]) with _shallow_ embeddings of binders.
Particularly, this uses regular Coq binders and functions for expressions, and
requires building greatest fixpoints for recursion. *)

Coercion mkProc E L (x : iproc E L) := mk_proc x.

Definition pInact E L (H : CAN_END L) : proc E L := mk_proc (Inact H).
Definition pTau E L (k : proc E L) : proc E L := mk_proc (Tau k).
Definition pDo E L T kL (e : @msg E L T kL) k : proc E L := mk_proc (Do e k).
Definition pSend E L p T x kL (H : CAN_SEND p T kL L) k : proc E L := pDo (Send p x H) k.
Definition pRecv E L p T kL (H : CAN_RECV p T kL L) k : proc E L := pDo (Recv p H) k.
Arguments pInact & {E L}.
Arguments pTau & {E L} k.
Arguments pDo & {E L T kL} e k.
Arguments pSend & {E L} p {T} x {kL} H k.
Arguments pRecv & {E L} p T {kL} H k.

Declare Scope proc_scope.
Notation stop := (pInact erefl).
Notation "'call' K" := (pTau K) (at level 60, no associativity).
Notation "p '<~' x ';;' k" :=
  (pSend p x IS_SEND (fun=> k))
    (at level 60, right associativity) : proc_scope.
Notation "x ':' T '::=' '<~' p ';;' k" :=
  (pRecv p T IS_RECV (fun x => k))
    (at level 60, right associativity) : proc_scope.
Notation "x ':' T '::=' 'lift' e ';;' k" :=
  (pDo (Eff e) (fun (x : T) => k))
    (at level 60, right associativity) : proc_scope.

Section ProcExamples.
  Context (E : Type -> Type).
  Notation process := (proc E).
  Eval compute in b_unroll (b_rec (b_var 1)).
  Example ended_proc : process (b_rec b_end) := stop.

  (* begin hide *)
  (* Definition Alice := 0%int63. *)
  (* Definition Bob := 1%int63. *)
  (* end hide *)

  (* begin details: here we define the specifications that ALICE and BOB
  must satisfy *)
  Definition NRAlice := project GTYExamples.PP GTYExamples.Alice.
  Definition NRBob := project GTYExamples.PP GTYExamples.Bob.

  Open Scope proc_scope.
  Example ping_Alice : process NRAlice
    := GTYExamples.Bob <~ 0;;
       _ : bool ::= <~ GTYExamples.Bob;;
       stop.

  Example ping_Bob : process NRBob :=
    n : nat ::= <~ GTYExamples.Alice ;;
    GTYExamples.Alice <~ true ;;
    stop.

  (* Example NRAlice : lty := *)
  (*   _ <- Bob !! nat ;; *)
  (*   _ <- Bob ?? nat ;; *)
  (*   END. *)

  (* Example NRBob : lty := *)
  (*   _ <- Alice ?? nat ;; *)
  (*   _ <- Alice !! nat ;; *)
  (*   END. *)

  (* Example AliceSpec : lty := *)
  (*   cofix X := *)
  (*     _ <- Bob !! nat ;; *)
  (*     _ <- Bob ?? nat ;; *)
  (*     X. *)

  (* Example BobSpec : lty := *)
  (*   cofix X := *)
  (*     _ <- Alice ?? nat ;; *)
  (*     _ <- Alice !! nat ;; *)
  (*     X. *)
  (* Close Scope lty_scope. *)

  Example infinite_ping_Alice : nat -> process AliceSpec :=
    cofix pingpong x :=
      Bob <~ x;;
      _ : nat ::= <~ Bob;;
      pingpong x.+1.

  Example infinite_ping_Bob : process BobSpec :=
    cofix pingpong :=
      n : nat ::= <~ Alice;;
      Alice <~ n;;
      pingpong.

  Example infinite_ping_Bob0 : process BobSpec :=
    n : nat ::= <~ Alice;;
    cofix pingpong :=
      Alice <~ n;;
      n : nat ::= <~ Alice;;
      pingpong.
  Close Scope proc_scope.
End ProcExamples.

(** ** Semantics of Smol Zooid *)

(** *** Actions **)

(** Actions capture the kind of event that happened (send/receive), and the
necessary information about who performed the action, the other party, and the
payload type. **)

Record event :=
  mk_ev { action_type : action;
          from : participant;
          to : participant;
          payload_type : Type;
        }.
Inductive rt_event :=
  Obs { event_type : event;
        payload : payload_type event_type
      }.
Definition mk_obs a p q T x := Obs (mk_ev a p q T) x.

(** *** Traces **)
(** Traces are (potentially infinite) streams of events. They are parameterised
 by the type of events. **)

Inductive traceF act G :=
| tr_end : traceF act G
| tr_next : act -> G -> traceF act G.
(* begin hide *)
Arguments tr_next & {act G}.
Arguments tr_end & {act G}.
(* end hide *)

CoInductive trace act := roll { unroll : traceF act (trace act) }.

Definition ty_trace := trace event.
Definition rt_trace := trace rt_event.

(* begin details:  *)

Definition trace_mapF {A B : Type} (f : A -> B) X Y G (trc : traceF A X)
  : traceF B Y :=
  match trc with
  | tr_end => tr_end
  | tr_next a trc => tr_next (f a) (G trc)
  end.
CoFixpoint trace_map {A B : Type} (f : A -> B) (trc : trace A) : trace B :=
  roll (trace_mapF f (trace_map f) (unroll trc)).

Definition erase := trace_map event_type.
(* end details *)

(** *** Labelled State Transition System **)

(** We define the steps as functions that take a process, an action, and
attepmpts to run it, returning the continuation. Since we only care about
communication, we define a function that exposes the firsst communication
action: [p_unroll]. This function requires two parameters, [readIO : forall T :
type, unit -> interp_type T] and [writeIO : forall T, T -> unit]. We will use
these functions later for code extraction. **)

Section ProcLTS.
  (** begin details: **)
  Variable (E : Type -> Type)
           (run_eff : forall T, E T -> T).
  (** end details **)

  Inductive proc_step (p : participant) L :
    iproc E L -> option rt_event -> forall L', proc E L' -> Prop
    :=
    (* Observable actions *)
    | step_send q T (x : T) kL (WT : CAN_SEND q T kL L) k :
        proc_step p (Do (Send q x WT) k) (Some (mk_obs a_send p q x)) (k tt)
    | step_recv q T (x : T) kL (WT : CAN_RECV q T kL L) k :
        proc_step p (Do (Recv q WT  ) k) (Some (mk_obs a_recv q p x)) (k x )

    (* Silent actions *)
    | step_eff T a k : proc_step p (Do (Eff a) k) None (k (@run_eff T a))
    | step_unroll e0 : proc_step p (Tau e0)       None e0
  .

  Derive Inversion proc_step_inv
    with (forall p L0 e0 ev L1 e1, @proc_step p L0 e0 ev L1 e1)
         Sort Prop.

  Definition R_trace := rt_trace -> forall L, proc E L -> Prop.
  Inductive proc_lts_ (p : participant) (G : R_trace) : R_trace :=
  | p_end TRC e H :
      unroll TRC = tr_end ->
      observe e = Inact H ->
      @proc_lts_ p G TRC END e
  | p_skip TRC L0 e0 L1 e1 :
      @proc_step p L0 (observe e0) None L1 e1 ->
      @proc_lts_ p G TRC L1 e1 ->
      @proc_lts_ p G TRC L0 e0
  | p_next E TRC0 TRC1 L0 e0 L1 e1 :
      unroll TRC0 = tr_next E TRC1 ->
      @proc_step p L0 (observe e0) (Some E) L1 e1 ->
      G TRC1 L1 e1 ->
      @proc_lts_ p G TRC0 L0 e0
  .
  Arguments p_end {p G}.
  Arguments p_skip [p G TRC L0 e0 L1 e1].
  Arguments p_next [p G E TRC0 TRC1 L0 e0 L1 e1].
  Derive Inversion proc_lts_inv
    with (forall p G TRC L e, @proc_lts_ p G TRC L e) Sort Prop.

  Lemma proc_lts_monotone p : monotone3 (proc_lts_ p).
  (* begin details: [proc_lts_] is monotone *)
  Proof.
    move=> TRC L e R R'.
    elim=>
    [ {}TRC {}e EQ H0 H1 _
    | {}TRC L0 e0 L1 e1 STEP H IH F
    | ev TRC0 TRC1 L0 e0 L1 e1 EQ STEP H F].
    - by apply/p_end.
    - by apply/(p_skip STEP)/IH.
    - by apply/(p_next EQ STEP)/F.
  Qed.
  (* end details *)

  (** [proc_accepts] encodes the property of a process accepting a trace, and it
 is the greatest fixpoint of [proc_lts_]. **)

  Definition proc_accepts p TR L P := paco3 (proc_lts_ p) bot3 TR L P.

  (** ** Preservation **)

  (** We want to make sure that types indeed characterise the traces according to
the allowed traces. We build a semantics for local types, and prove that, given
[p : SZooid L], if [p] transitions to [p'] with some event [E], then [L] also
transitions to [L'] with the "same" event. But, since processes contain payloads
and local types do not, we must first erase these payloads from the trace
events. **)

  Inductive lty_step p : ltyF lty -> event -> lty -> Prop :=
  | lt_send q T x kL :
      lty_step p (l_send q T kL) (mk_ev a_send p q T) (kL x)
  | lt_recv q T x kL :
      lty_step p (l_recv q T kL) (mk_ev a_recv q p T) (kL x)
  .
  Derive Inversion lty_step_inv with
      (forall p L0 Ev L1, @lty_step p L0 Ev L1) Sort Prop.

  Inductive lty_lts_ (p : participant) (G : ty_trace -> lty -> Prop)
    : ty_trace -> lty -> Prop :=
  | ty_end TRC L :
      run_lty L = l_end ->
      unroll TRC = tr_end -> @lty_lts_ p G TRC L
  | ty_next E TRC0 TRC1 L0 L1 :
      unroll TRC0 = tr_next E TRC1 ->
      @lty_step p (run_lty L0) E L1 -> G TRC1 L1 -> @lty_lts_ p G TRC0 L0
  .
  Derive Inversion lty_lts_inv with
      (forall p G TRC L, @lty_lts_ p G TRC L) Sort Prop.
  Definition lty_accepts p := paco2 (lty_lts_ p) bot2.

  Lemma lty_lts_monotone p : monotone2 (lty_lts_ p).
  Proof.
    move=>TRC L r r' H0 H1;  case: H0.
    - by move=> TRC0 U0; constructor.
    - by move=> E0 TRC0 TRC1 L0 L1 U0 ST /H1; apply (ty_next _ _ _ U0).
  Qed.

  Lemma subject_reduction p L0 (e0 : iproc E L0) L1 (e1 : proc E L1) ev :
    proc_step p e0 (Some ev) e1 -> lty_step p (run_lty L0) (event_type ev) L1.
  Proof.
    (* Generalize [Some ev] and remember that [EQ : mev = Some ev] in [St] *)
    move EQ: (Some ev)=> mev St.

    (* By case analysis on the process step *)
    by case: St EQ=>//= q T x kL -> _ [->]; constructor.
  Qed.

  Lemma step_silent p L0 (e0 : iproc E L0) L1 (e1 : proc E L1) :
    proc_step p e0 None e1 -> L0 = L1.
  Proof. by case EQ: _ _ _ /.  Qed.

  Theorem trace_soundness p RT_TRC L (e : proc E L) :
    proc_accepts p RT_TRC         e ->
    @lty_accepts p (erase RT_TRC) L.
  Proof.
    (* By (parametric) coinduction (i.e. paco2_acc) *)
    coind CH=> L RT_TRC e Acc.

    (* unfold proc_accepts proc_accepts = \mu proc_lts_ ==> proc_lts_ (\mu proc_lts) *)
    move: Acc => /(paco3_unfold (@proc_lts_monotone p))-Acc.

    (* generalize Acc *)
    move EQ: (upaco3 _ _) Acc=> RR.

    (* by induction on Acc *)
    elim=>/=
        [ TRC0 e0 H0 U0 Oe
        | TRC L0 e0 L1 e1 STEP _ IH
        | E0 T0 T1 L0 e0 L1 e1 U0 St Acc {e}
        ].
    { (* Case: process trace is ended *)

      (* apply G f -> f (G f), followed by the empty trace constructor *)
      apply/paco2_fold; constructor=>//.

      (* reduce [unroll (erase TRC0)], and rewrite [unroll TRC0 = tr_end] *)
      by cbv; rewrite U0.
    }
    { (* Case: the process takes a silent step *)

      (* Straightforward application of the IH, since
         a silent step does not progress the local type *)
      by move: STEP=>/step_silent->.
    }
    { (* Case: process trace contains one element *)

      (* By applying the constructor for the step trace, we
       then need to prove 3 properties: *)
      apply/paco2_fold/ty_next.

      { (* Property 1: the erasure of the runtime trace contains 1 element *)

        (* Straightforward: if the trace contains one element, so does the erasure *)
        by cbv; rewrite U0 -/(trace_map _ _) -/(erase _).
      }
      { (* Property 2: the local type of [e0] steps to some continuation local type *)

        (* Straightforward by subject reduction *)
        by apply: (subject_reduction St).

      }
      { (* Property 3: the continuation of the local type accepts the remainder
           of the erasure of the trace *)

        (* Straightforward by applying the coinduction hypothesis *)

        (* First rewrite [Acc] so it states that [e1] accepts the remainder of
           the trace [T1]*)
        move: EQ Acc=><-[Acc|//] {RR}.

        (* Then apply the coinduction hypothesis to [Acc] *)
        by right; apply/CH/Acc.
      }
    }
    Qed.
End ProcLTS.

(** ** Extraction **)

(** The main goal of defining a simple process language, with a mixture of deep
and shallow embedded binders is to simplify *certified code extraction*. To
extract [proc], we need an interpretation of its constructs. We do this in a way
that somewhat resembles that of _effect handlers_, by assigning to each
construct an **interpretation** as an OCaml function. **)

Require Extraction ExtrOCamlInt63.
Extraction Implicit Send [ L kL ].
Extraction Implicit Recv [ L kL ].
Extraction Implicit Eff [ L ].
Extraction Implicit Do [ L kL ].
Extraction Implicit Tau [ L ].
Extraction Implicit Inact [ L ].

Extraction Implicit pSend [ L kL ].
Extraction Implicit pRecv [ L kL ].
Extraction Implicit pDo [ L kL ].
Extraction Implicit pTau [ L ].
Extraction Implicit pInact [ L ].

Module ProcExtraction.
  Extract Inductive proc => "Proc.t" [ "" ].
  Extract Inlined Constant pSend => "(fun p t k -> let* _ = Proc.send p (Obj.magic t) in (Obj.magic k tt))".
  Extract Inlined Constant pRecv => "(fun p k -> let* x = Proc.recv p in (Obj.magic k))".
End ProcExtraction.

Section GTYExamples.
  Context (E : Type -> Type).
  Notation process G r := (proc E (unravel (project G r))).

  Example ended_proc : process END Alice := stop.

  Open Scope proc_scope.

  Definition proc_rec A E L (f : A -> proc E L) : A -> proc E L := f.
  Arguments proc_rec & {A E L} f.

  Set Contextual Implicit.

  Example ch_Bob0 : process CH1 Bob :=
    n : MyChoice ::= <~ Alice;;
    match n with
    | Case1 c =>
      proc_rec
        (cofix pingpong c :=
         Alice <~ Nat.even c;;
         n : MyChoice ::= <~ Alice;;
         match n with
         | Case1 c =>
           pingpong c
         | Case2 _ => stop
         end) c
    | Case2 _ =>
      stop
    end.
  Example ping_Bob : process PP Bob :=
      _ : nat ::= <~ Alice;;
    Alice <~ true;;
    stop.
  Example ping_Alice n : process PP Alice :=
    Bob <~ n ;;
    n : bool ::= <~ Bob ;;
    stop.

  Example infinite_ping_Alice : nat -> process PPRec Alice :=
    cofix pingpong x :=
      Bob <~ x;;
      _ : bool ::= <~ Bob;;
      pingpong x.+1.

  Example infinite_ping_Bob : process PPRec Bob :=
    cofix pingpong :=
      n : nat ::= <~ Alice;;
      Alice <~ Nat.even n ;;
      pingpong.

  Example infinite_ping_Bob0 : process PPRec Bob :=
    n : nat ::= <~ Alice;;
    cofix pingpong :=
      Alice <~ Nat.even n;;
      n : nat ::= <~ Alice;;
      pingpong.
  Close Scope proc_scope.
End GTYExamples.