Require Export UnitarySem.
Require Export QuantumLib.VectorStates.

(* This file contains useful operations over unitary programs including:
   - inversion
   - control
   - iteration
   - parallel composition

   It also contains a definition for projecting a qubit into a classical state, which
   is useful for defining the behavior of control. *)

Local Open Scope ucom.

(** Inversion **)

Fixpoint invert {dim} (c : base_ucom dim) : base_ucom dim :=
  match c with
  | c1 ; c2 => invert c2 ; invert c1
  | uapp1 (U_R θ ϕ λ) n => uapp1 (U_R (- θ) (- λ) (- ϕ)) n
  | uapp2 U_CNOT m n => uapp2 U_CNOT m n
  | _ => SKIP
  end.

Lemma uc_well_typed_invert : forall (dim : nat) (c : base_ucom dim),
  uc_well_typed c <-> uc_well_typed (invert c).
Proof.
  intros dim c.
  split; intro H.
  induction c; try dependent destruction u;
    inversion H; subst; constructor; auto.
  induction c; try dependent destruction u;
    inversion H; subst; constructor; auto.
Qed.

Lemma invert_correct : forall (dim : nat) (c : base_ucom dim),
  (uc_eval c)† = uc_eval (invert c).
Proof.
  intros.
  induction c; try dependent destruction u; simpl.
  - Msimpl. rewrite IHc1. rewrite IHc2. reflexivity.
  - unfold pad_u, pad.
    bdestruct (n + 1 <=? dim); try apply zero_adjoint_eq.
    repeat setoid_rewrite kron_adjoint; Msimpl.
    rewrite rotation_adjoint.
    reflexivity.
  - autorewrite with eval_db.
    gridify.
    Qsimpl. reflexivity.
    Qsimpl. reflexivity.
Qed.

(* A few common inverses *)

Hint Rewrite sin_neg cos_neg : trig_db.

Lemma invert_CNOT : forall dim m n, invert (@CNOT dim m n) ≡ CNOT m n.
Proof. intros. reflexivity. Qed.

Local Transparent X.
Lemma invert_X : forall dim n, invert (@X dim n) ≡ X n.
Proof.
  intros dim n.
  unfold uc_equiv. simpl.
  unfold pad_u, pad.
  gridify.
  do 2 (apply f_equal2; try reflexivity).
  unfold rotation.
  solve_matrix; try rewrite Ropp_div; autorewrite with Cexp_db trig_db; lca.
Qed.
Local Opaque X.

Local Transparent H.
Lemma invert_H : forall dim n, invert (@H dim n) ≡ H n.
Proof.
  intros dim n.
  unfold uc_equiv. simpl.
  unfold pad_u, pad.
  gridify.
  do 2 (apply f_equal2; try reflexivity).
  unfold rotation.
  solve_matrix; try rewrite Ropp_div; autorewrite with Cexp_db trig_db; lca.
Qed.
Local Opaque H.

Local Transparent Rz.
Lemma invert_Rz : forall dim n r, (invert (@Rz dim r n) ≡ Rz (- r) n)%ucom.
Proof.
  intros dim n r.
  unfold uc_equiv. simpl.
  autorewrite with eval_db.
  gridify.
  do 2 (apply f_equal2; try reflexivity).
  unfold rotation.
  solve_matrix; autorewrite with R_db Cexp_db trig_db; lca.
Qed.
Local Opaque Rz.

(** Programs with arbitrary control **)

(* Standard decomposition; see Qiskit's cu3 gate or Ch.4 of N & C *)
Definition CU {dim} θ ϕ λ c t : base_ucom dim :=
  Rz ((λ + ϕ)/2) c ;
  Rz ((λ - ϕ)/2) t ;
  CNOT c t ;
  uapp1 (U_R (-θ/2) 0 (-(ϕ + λ)/2)) t ;
  CNOT c t ;
  uapp1 (U_R (θ/2) ϕ 0) t.

(* Convert a program to be controlled by qubit q *)
Fixpoint control {dim} q (c : base_ucom dim) : base_ucom dim :=
  match c with
  | c1; c2 => control q c1; control q c2
  | uapp1 (U_R θ ϕ λ) n => CU θ ϕ λ q n
  | uapp2 U_CNOT m n => CCX q m n
  | _ => SKIP
  end.

Inductive is_fresh {U dim} : nat -> ucom U dim -> Prop :=
  | fresh_seq  : forall q c1 c2, is_fresh q c1 -> is_fresh q c2 -> is_fresh q (c1; c2)
  | fresh_app1 : forall q u n, q <> n -> is_fresh q (uapp1 u n)
  | fresh_app2 : forall q u m n, q <> m -> q <> n -> is_fresh q (uapp2 u m n)
  | fresh_app3 : forall q u m n p,  q <> m -> q <> n -> q <> p -> is_fresh q (uapp3 u m n p).

Fixpoint is_fresh_b {U dim} q (c : ucom U dim) :=
  match c with
  | c1 ; c2 => is_fresh_b q c1 && is_fresh_b q c2
  | uapp1 _ m => negb (m =? q)
  | uapp2 _ m n => negb (m =? q) && negb (n =? q)
  | uapp3 _ m n p => negb (m =? q) && negb (n =? q) && negb (p =? q)
  end.

Ltac simpl_fresh_b :=
  repeat match goal with
  | H : _ && _ = true |- _ => apply andb_true_iff in H as [? ?]
  | H : negb _ = true |- _ => apply negb_true_iff in H
  | H : (_ =? _) = false |- _ => apply Nat.eqb_neq in H
  | |- _ && _ = true => apply andb_true_iff; split
  | |- negb _ = true => apply negb_true_iff
  | |- (_ =? _) = false => apply Nat.eqb_neq
  end.

Lemma is_fresh_b_equiv : forall U dim q (c : ucom U dim),
  is_fresh_b q c = true <-> is_fresh q c.
Proof.
  intros U dim q c.
  split; intro H.
  - induction c; simpl in H; simpl_fresh_b; constructor; auto.
  - induction c; inversion H; subst; simpl; simpl_fresh_b; auto.
Qed.

Lemma uc_well_typed_control : forall dim q (c : base_ucom dim),
  ((q < dim)%nat /\ is_fresh q c /\ uc_well_typed c) <->
  uc_well_typed (control q c).
Proof.
  intros dim q c.
  split.
  - intros [H [Hfr WT]].
    induction c; try dependent destruction u; simpl;
      inversion Hfr; inversion WT; subst.
    constructor.
    apply IHc1; auto.
    apply IHc2; auto.
    1,2: repeat constructor; try assumption.
    all: try apply uc_well_typed_Rz; try apply uc_well_typed_CNOT; auto.
    1,2: apply uc_well_typed_H; auto.
  - intro H.
    induction c; try dependent destruction u.
    inversion H; subst.
    apply IHc1 in H2 as [? [? ?]].
    apply IHc2 in H3 as [_ [? ?]].
    repeat split; try constructor; auto.
    inversion H; subst.
    inversion H2; subst.
    apply uc_well_typed_CNOT in H5 as [? [? ?]].
    repeat split; try constructor; auto.
    inversion H; subst.
    repeat match goal with
       | H : uc_well_typed (_ ; _) |- _ => inversion H; subst; clear H
       end.
    repeat split; auto.
    apply uc_well_typed_Rz in H7; auto.
    apply uc_well_typed_CNOT in H8 as [? [? ?]].
    apply uc_well_typed_CNOT in H11 as [? [? ?]].
    constructor; auto.
Qed.

Local Transparent SQIR.H X U1 Rz CNOT.
Lemma fresh_U1: forall dim r q1 q2, q1 <> q2 <-> is_fresh q1 (@U1 dim r q2).
Proof.
  intros.
  split; intro H.
  constructor. auto.
  inversion H. auto.
Qed.

Lemma fresh_X: forall dim q1 q2, q1 <> q2 <-> is_fresh q1 (@X dim q2).
Proof.
  intros.
  split; intro H.
  constructor. auto.
  inversion H. auto.
Qed.

Lemma fresh_H: forall dim q1 q2, q1 <> q2 <-> is_fresh q1 (@H dim q2).
Proof.
  intros.
  split; intro H0.
  constructor. auto.
  inversion H0. auto.
Qed.

Lemma fresh_CNOT: forall dim a b c, a <> b /\ a <> c <-> is_fresh a (@CNOT dim b c).
Proof.
  intros.
  split; intro H.
  destruct H.
  constructor; auto.
  inversion H; auto.
Qed.

Lemma fresh_CU : forall {dim} θ ϕ λ q c t,
  q <> c -> q <> t -> @is_fresh _ dim q (CU θ ϕ λ c t).
Proof. intros. repeat constructor; auto. Qed.

Ltac invert_is_fresh :=
  repeat match goal with
  | H : is_fresh _ _ |- _ => inversion H; subst; clear H
  end; clear_dups.

Lemma fresh_CCX : forall {dim} q c1 c2 t,
  q <> c1 /\ q <> c2 /\ q <> t <-> @is_fresh _ dim q (CCX c1 c2 t).
Proof.
  intros. split.
  intros [? [? ?]].
  repeat constructor; auto.
  intro.
  invert_is_fresh. auto.
Qed.

Lemma fresh_control : forall {dim} q1 q2 c,
  (q1 <> q2 /\ @is_fresh _ dim q1 c) <-> @is_fresh _ dim q1 (control q2 c).
Proof.
  intros dim q1 q2 c.
  split.
  - intros [H1 H2].
    induction H2; simpl; try dependent destruction u.
    apply fresh_seq; auto.
    apply fresh_CU; auto.
    apply fresh_CCX; auto.
  - intro H.
    split.
    induction c; try dependent destruction u; inversion H; subst.
    auto.
    invert_is_fresh; auto.
    invert_is_fresh; auto.
    induction c; try dependent destruction u; inversion H; subst.
    constructor; auto.
    constructor. invert_is_fresh; auto.
    constructor; invert_is_fresh; auto.
Qed.
Local Opaque SQIR.H X U1 Rz CNOT.

(* Project onto the space where qubit q is in classical state b.
   TODO: possibly move to QuantumLib *)
Definition proj q dim (b : bool) := pad_u dim q (bool_to_matrix b).

Lemma WF_proj : forall q dim b, WF_Matrix (proj q dim b).
Proof. intros. unfold proj. auto with wf_db. Qed.
#[export] Hint Resolve WF_proj : wf_db.

Lemma f_to_vec_proj_eq : forall f q n b,
  (q < n)%nat -> f q = b ->
  proj q n b × (f_to_vec n f) = f_to_vec n f.
Proof.
  intros f q n b ? ?.
  rewrite (f_to_vec_split 0 n q) by lia.
  replace (n - 1 - q)%nat with (n - (q + 1))%nat by lia.
  unfold proj, pad_u, pad.
  gridify.
  do 2 (apply f_equal2; try reflexivity).
  destruct (f q); solve_matrix.
Qed.

Lemma f_to_vec_proj_neq : forall f q n b,
  (q < n)%nat -> f q <> b ->
  proj q n b × (f_to_vec n f) = Zero.
Proof.
  intros f q n b ? H.
  rewrite (f_to_vec_split 0 n q) by lia.
  replace (n - 1 - q)%nat with (n - (q + 1))%nat by lia.
  unfold proj, pad_u, pad.
  gridify.
  destruct (f q); destruct b; try easy; lma.
Qed.

(* We can use 'proj' to state that qubit q is in classical state b. *)
Definition classical {dim} q b (ψ : Vector (2 ^ dim)) := proj q dim b × ψ = ψ.

Lemma f_to_vec_classical : forall n q f,
  (q < n)%nat -> classical q (f q) (f_to_vec n f).
Proof.
  intros n q f Hq.
  unfold classical, proj.
  induction n; try lia.
  unfold pad_u, pad.
  replace (q + 1)%nat with (S q) by lia.
  bdestructΩ (S q <=? S n); clear H.
  bdestruct (q =? n).
  - subst. replace (n - n)%nat with O by lia.
    simpl. Msimpl_light.
    restore_dims.
    rewrite kron_mixed_product.
    Msimpl_light; apply f_equal2; auto.
    destruct (f n); solve_matrix.
  - remember (n - q - 1)%nat as x.
    replace (n - q)%nat with (x + 1)%nat by lia.
    replace n with (q + 1 + x)%nat by lia.
    replace (2 ^ (x + 1))%nat with (2 ^ x * 2)%nat by unify_pows_two.
    rewrite <- id_kron.
    rewrite <- kron_assoc by auto with wf_db.
    replace (2 ^ (q + 1 + x) + (2 ^ (q + 1 + x) + 0))%nat with (2 ^ (q + 1 + x) * 2)%nat by lia.
    repeat rewrite Nat.pow_add_r.
    replace 1%nat with (1 * 1)%nat by lia.
    rewrite kron_mixed_product; simpl.
    replace (q + 1 + x)%nat with n by lia.
    subst.
    Msimpl_light.
    rewrite <- IHn at 2; try lia.
    unfold pad_u, pad.
    bdestructΩ (q + 1 <=? n); clear H0.
    replace (n - (q + 1))%nat with (n - q - 1)%nat by lia.
    restore_dims. reflexivity.
Qed.

Lemma proj_commutes_1q_gate : forall dim u q n b,
  q <> n ->
  proj q dim b × ueval_r dim n u = ueval_r dim n u × proj q dim b.
Proof.
  intros dim u q n b neq.
  dependent destruction u; simpl.
  unfold proj.
  apply pad_A_B_commutes; auto with wf_db.
Qed.

Lemma proj_commutes_2q_gate : forall dim q n1 n2 b,
  q <> n1 -> q <> n2 ->
  proj q dim b × ueval_cnot dim n1 n2 = ueval_cnot dim n1 n2 × proj q dim b.
Proof.
  intros dim q n1 n2 b neq1 neq2.
  unfold proj, ueval_cnot.
  apply pad_A_ctrl_commutes; auto with wf_db.
Qed.

Lemma proj_commutes : forall dim q1 q2 b1 b2,
  proj q1 dim b1 × proj q2 dim b2 = proj q2 dim b2 × proj q1 dim b1.
Proof.
  intros dim q1 q2 b1 b2.
  unfold proj, pad_u, pad.
  gridify; trivial.
  destruct b1; destruct b2; simpl; Qsimpl; reflexivity.
Qed.

Lemma proj_twice_eq : forall dim q b,
  proj q dim b × proj q dim b = proj q dim b.
Proof.
  intros dim q b.
  unfold proj, pad_u, pad.
  gridify.
  destruct b; simpl; Qsimpl; reflexivity.
Qed.

Lemma proj_twice_neq : forall dim q b1 b2,
  b1 <> b2 -> proj q dim b1 × proj q dim b2 = Zero.
Proof.
  intros dim q b1 b2 neq.
  unfold proj, pad_u, pad.
  gridify.
  destruct b1; destruct b2; try contradiction; simpl; Qsimpl; reflexivity.
Qed.

(* TODO: move to QuantumLib *)

Lemma bra0_phase : forall ϕ, bra 0 × phase_shift ϕ = bra 0.
Proof. intros; solve_matrix. Qed.

Lemma bra1_phase : forall ϕ, bra 1 × phase_shift ϕ = Cexp ϕ .* bra 1.
Proof. intros; solve_matrix. Qed.

Hint Rewrite bra0_phase bra1_phase : bra_db.

Lemma braketbra_same : forall x y, bra x × (ket x × bra y) = bra y.
Proof. intros. destruct x; destruct y; solve_matrix. Qed.

Lemma braketbra_diff : forall x y z, (x + y = 1)%nat -> bra x × (ket y × bra z) = Zero.
Proof. intros. destruct x; destruct y; try lia; solve_matrix. Qed.

Hint Rewrite braketbra_same braketbra_diff using lia : bra_db.

(* Auxiliary proofs about the semantics of CU and TOFF *)
Lemma CU_correct : forall (dim : nat) θ ϕ λ c t,
  (t < dim)%nat -> c <> t ->
  uc_eval (CU θ ϕ λ c t) = proj c dim false .+ (proj c dim true) × (ueval_r dim t (U_R θ ϕ λ)).
Proof.
  intros.
  unfold proj; simpl.
  autorewrite with eval_db.
  unfold pad_u, pad.
  gridify. (* slow *)
  all: clear.
  all: autorewrite with M_db_light ket_db bra_db.
  all: rewrite Mplus_comm;
       repeat (apply f_equal2; try reflexivity).
  (* A little messy because we need to apply trig identities;
     goal #1 = goal #3 and goal #2 = goal #4 *)
  - solve_matrix; autorewrite with R_db C_db RtoC_db Cexp_db trig_db;
      try lca; field_simplify_eq; try nonzero; group_Cexp.
    + simpl. rewrite Rplus_comm; setoid_rewrite sin2_cos2; easy.
    + rewrite Copp_mult_distr_l, Copp_mult_distr_r.
      repeat rewrite <- Cmult_assoc; rewrite <- Cmult_plus_distr_l.
      autorewrite with RtoC_db. rewrite Ropp_involutive.
      setoid_rewrite sin2_cos2. rewrite Cmult_1_r.
      apply f_equal; lra.
  - rewrite <- Mscale_kron_dist_l.
    repeat rewrite <- Mscale_kron_dist_r.
    repeat (apply f_equal2; try reflexivity).
    (* Note: These destructs shouldn't be necessary - weakness in destruct_m_eq'.
       The mat_equiv branch takes a more principled approach (see lma there, port). *)
    solve_matrix; destruct x0; try destruct x0; simpl;
    autorewrite with R_db C_db Cexp_db trig_db; try lca;
    rewrite RtoC_opp; field_simplify_eq; try nonzero; group_Cexp;
    repeat rewrite <- Cmult_assoc.
    + unfold Cminus.
      rewrite Copp_mult_distr_r, <- Cmult_plus_distr_l.
      apply f_equal2; [apply f_equal; lra|].
      autorewrite with RtoC_db.
      rewrite <- Rminus_unfold, <- cos_plus.
      apply f_equal. apply f_equal. lra.
    + apply f_equal2; [apply f_equal; lra|].
      apply c_proj_eq; simpl; try lra.
      R_field_simplify.
      rewrite <- sin_2a.
      apply f_equal; lra.
    + rewrite Copp_mult_distr_r.
      apply f_equal2; [apply f_equal; lra|].
      apply c_proj_eq; simpl; try lra.
      R_field_simplify.
      replace (-2)%R with (-(2))%R by lra.
      repeat rewrite <- Ropp_mult_distr_l.
      apply f_equal.
      rewrite <- sin_2a.
      apply f_equal; lra.
    + rewrite Copp_mult_distr_r.
      rewrite <- Cmult_plus_distr_l.
      apply f_equal2; [apply f_equal; lra|].
      autorewrite with RtoC_db.
      rewrite Rplus_comm; rewrite <- Rminus_unfold, <- cos_plus.
      apply f_equal; apply f_equal; lra.
  - solve_matrix; autorewrite with R_db C_db RtoC_db Cexp_db trig_db; try lca;
      field_simplify_eq; try nonzero; group_Cexp.
    + rewrite Rplus_comm; setoid_rewrite sin2_cos2; easy.
    + rewrite Copp_mult_distr_l, Copp_mult_distr_r.
      repeat rewrite <- Cmult_assoc; rewrite <- Cmult_plus_distr_l.
      autorewrite with RtoC_db. rewrite Ropp_involutive.
      setoid_rewrite sin2_cos2. rewrite Cmult_1_r.
      apply f_equal; lra.
  - rewrite <- 3 Mscale_kron_dist_l.
    repeat rewrite <- Mscale_kron_dist_r.
    repeat (apply f_equal2; try reflexivity).
    solve_matrix; destruct x; try destruct x; simpl;
    autorewrite with R_db C_db Cexp_db trig_db; try lca;
    try rewrite RtoC_opp; field_simplify_eq; try nonzero; group_Cexp;
    repeat rewrite <- Cmult_assoc.
    + unfold Cminus.
      rewrite Copp_mult_distr_r, <- Cmult_plus_distr_l.
      apply f_equal2; [apply f_equal; lra|].
      autorewrite with RtoC_db.
      rewrite <- Rminus_unfold, <- cos_plus.
      apply f_equal. apply f_equal. lra.
    + apply f_equal2; [apply f_equal; lra|].
      apply c_proj_eq; simpl; try lra.
      R_field_simplify.
      rewrite <- sin_2a.
      apply f_equal; lra.
    + rewrite Copp_mult_distr_r.
      apply f_equal2; [apply f_equal; lra|].
      apply c_proj_eq; simpl; try lra.
      R_field_simplify.
      replace (-2)%R with (-(2))%R by lra.
      repeat rewrite <- Ropp_mult_distr_l.
      apply f_equal.
      rewrite <- sin_2a.
      apply f_equal; lra.
    + rewrite Copp_mult_distr_r.
      rewrite <- Cmult_plus_distr_l.
      apply f_equal2; [apply f_equal; lra|].
      autorewrite with RtoC_db.
      rewrite Rplus_comm; rewrite <- Rminus_unfold, <- cos_plus.
      apply f_equal; apply f_equal; lra.
Qed.

Lemma UR_not_WT : forall (dim a b : nat) r r0 r1,
  ~ uc_well_typed (@uapp1 _ dim (U_R r r0 r1) b) ->
  uc_eval (@CU dim r r0 r1 a b) = Zero.
Proof.
  intros dim a b r r0 r1 H.
  simpl. unfold pad_u.
  assert (@pad 1 b dim (rotation (r / 2) r0 0) = Zero).
  { unfold pad. gridify.
    assert (uc_well_typed (@uapp1 _ (b + 1 + d) (U_R r r0 r1) b)).
    constructor; lia.
    contradiction. }
  rewrite H0.
  Msimpl_light.
  reflexivity.
Qed.

Lemma UR_not_fresh : forall (dim a b : nat) r r0 r1,
  ~ is_fresh a (@uapp1 _ dim (U_R r r0 r1) b) ->
  uc_eval (@CU dim r r0 r1 a b) = Zero.
Proof.
  intros dim a b r r0 r1 H.
  simpl.
  assert (uc_eval (@CNOT dim a b) = Zero).
  { assert (a = b).
    apply Classical_Prop.NNPP.
    intro contra. contradict H.
    constructor; assumption.
    autorewrite with eval_db. gridify. }
  rewrite H0.
  Msimpl_light.
  reflexivity.
Qed.

Lemma UR_a_geq_dim : forall (dim a b : nat) r r0 r1,
  (dim <= a)%nat ->
  uc_eval (@CU dim r r0 r1 a b) = Zero.
Proof.
  intros dim a b r r0 r1 H.
  simpl.
  assert (uc_eval (@Rz dim ((r1 + r0) / 2) a) = Zero).
  { autorewrite with eval_db. gridify. }
  rewrite H0.
  Msimpl_light.
  reflexivity.
Qed.
Local Opaque CU.

Lemma f_to_vec_X : forall (n i : nat) (f : nat -> bool), (i < n)%nat ->
  (uc_eval (X i)) × (f_to_vec n f) = f_to_vec n (update f i (¬ (f i))).
Proof.
  intros. rewrite denote_X. apply f_to_vec_σx. auto.
Qed.

Lemma f_to_vec_CNOT : forall (n i j : nat) (f : nat -> bool),
  (i < n)%nat -> (j < n)%nat -> i <> j ->
  (uc_eval (SQIR.CNOT i j)) × (f_to_vec n f) = f_to_vec n (update f j (f j ⊕ f i)).
Proof.
   intros. rewrite denote_cnot. unfold ueval_cnot. apply f_to_vec_cnot; auto.
Qed.

Lemma f_to_vec_SWAP : forall (n i j : nat) (f : nat -> bool),
  (i < n)%nat -> (j < n)%nat -> i <> j ->
  uc_eval (SWAP i j) × (f_to_vec n f) = f_to_vec n (fswap f i j).
Proof.
   intros. rewrite denote_swap_alt. apply f_to_vec_swap; auto.
Qed.

Lemma f_to_vec_Rz : forall (n i : nat) (θ : R) (f : nat -> bool),
  (i < n)%nat ->
  (uc_eval (SQIR.Rz θ i)) × (f_to_vec n f) =
    (Cexp (b2R (f i) * θ)) .* f_to_vec n f.
Proof.
   intros. rewrite denote_Rz. apply f_to_vec_phase_shift; auto.
Qed.

Lemma f_to_vec_H : forall (n i : nat) (f : nat -> bool),
  (i < n)%nat ->
  (uc_eval (SQIR.H i)) × (f_to_vec n f)
      = /√2 .* ((f_to_vec n (update f i false))
                .+ (Cexp (b2R (f i) * PI)) .* f_to_vec n (update f i true)).
Proof.
   intros. rewrite denote_H. apply f_to_vec_hadamard; auto.
Qed.

Hint Rewrite f_to_vec_CNOT f_to_vec_Rz f_to_vec_X using lia : f_to_vec_db.

Ltac f_to_vec_simpl_body :=
  autorewrite with f_to_vec_db;
  try match goal with
      | |- context [uc_eval (SQIR.H _) × f_to_vec _ _] =>
            rewrite f_to_vec_H by lia
      end;
  distribute_scale;
  distribute_plus;
  try match goal with
      | |- context [update (update (update _ ?x _) ?y _) ?z _ ] =>
            rewrite (update_twice_neq _ x y) by lia
      end.

Ltac f_to_vec_simpl := repeat f_to_vec_simpl_body.

Lemma f_to_vec_CCX : forall (dim a b c : nat) (f : nat -> bool),
   (a < dim)%nat -> (b < dim)%nat -> (c < dim)%nat -> a <> b -> a <> c -> b <> c ->
  (uc_eval (CCX a b c)) × (f_to_vec dim f)
      = f_to_vec dim (update f c (f c ⊕ (f a && f b))).
Proof.
  intros.
  unfold CCX, T, TDAG.
  simpl uc_eval.
  repeat rewrite Mmult_assoc.
  f_to_vec_simpl.
  rewrite (update_same _ b).
  2: destruct (f a); destruct (f b); reflexivity.
  destruct (f a); destruct (f b); destruct (f c); simpl.
  all: autorewrite with R_db C_db Cexp_db.
  all: cancel_terms (Cexp (PI * / 4)).
  all: group_Cexp.
  all: repeat match goal with
       | |- context [Cexp ?r] => field_simplify r
       end.
  all: autorewrite with R_db C_db Cexp_db.
  all: rewrite Mscale_plus_distr_r.
  all: distribute_scale; group_radicals.
  all: lma.
Qed.

Lemma CCX_a_geq_dim : forall (dim a b c : nat),
  (dim <= a)%nat -> uc_eval (@CCX dim a b c) = Zero.
Proof.
  intros dim a b c H.
  unfold CCX.
  simpl.
  rewrite (denote_cnot dim a b).
  unfold ueval_cnot, pad_ctrl, pad.
  gridify.
Qed.

Lemma CCX_not_WT : forall (dim a b c : nat),
  ~ uc_well_typed (@CNOT dim b c) -> uc_eval (@CCX dim a b c) = Zero.
Proof.
  intros dim a b c H.
  unfold CCX.
  simpl.
  assert (uc_eval (@CNOT dim b c) = Zero).
  { autorewrite with eval_db.
    gridify.
    assert (uc_well_typed (@CNOT (b + (1 + d + 1) + d0) b (b + 1 + d))).
    apply uc_well_typed_CNOT; repeat split; lia.
    contradiction.
    assert (uc_well_typed (@CNOT (c + (1 + d + 1) + d0) (c + 1 + d) c)).
    apply uc_well_typed_CNOT; repeat split; lia.
    contradiction. }
  rewrite H0.
  Msimpl_light.
  reflexivity.
Qed.

Local Transparent CNOT.
Lemma CCX_not_fresh : forall (dim a b c : nat),
  ~ is_fresh a (@CNOT dim b c) -> uc_eval (@CCX dim a b c) = Zero.
Proof.
  intros dim a b c H.
  unfold CCX.
  simpl.
  assert (ueval_cnot dim  a b = Zero \/ ueval_cnot dim  a c = Zero).
  { assert (a = b \/ a = c).
    apply Classical_Prop.NNPP.
    intro contra. contradict H.
    apply Classical_Prop.not_or_and in contra as [? ?].
    constructor; assumption.
    destruct H0.
    left. autorewrite with eval_db. gridify.
    right. autorewrite with eval_db. gridify. }
  destruct H0; rewrite H0; Msimpl_light; reflexivity.
Qed.
Local Opaque CNOT.
Local Opaque CCX.

Lemma CCX_correct : forall (dim : nat) a b c,
  (b < dim)%nat -> (c < dim)%nat -> a <> b -> a <> c -> b <> c ->
  uc_eval (CCX a b c) = proj a dim false .+ (proj a dim true) × (ueval_cnot dim b c).
  intros dim a b c ? ? ? ? ?.
  bdestruct (a <? dim).
  2: { rewrite CCX_a_geq_dim by assumption.
       unfold proj, pad_u, pad. gridify. }
  eapply equal_on_basis_states_implies_equal; auto with wf_db.
  intro f.
  rewrite f_to_vec_CCX by auto.
  rewrite Mmult_plus_distr_r.
  rewrite proj_commutes_2q_gate by auto.
  rewrite Mmult_assoc.
  destruct (f a) eqn:fa.
  - rewrite (f_to_vec_proj_eq _ _ _ true); auto.
    rewrite (f_to_vec_proj_neq _ _ _ false); auto.
    2: rewrite fa; easy.
    setoid_rewrite f_to_vec_CNOT; auto.
    rewrite andb_true_l.
    Msimpl_light; reflexivity.
  - rewrite (f_to_vec_proj_eq _ _ _ false); auto.
    rewrite (f_to_vec_proj_neq _ _ _ true); auto.
    2: rewrite fa; easy.
    rewrite andb_false_l, xorb_false_r.
    rewrite update_same by auto.
    Msimpl_light; reflexivity.
Qed.

(* generalization of proj_commutes_1q_gate and proj_commutes_2q_gate *)
Lemma proj_fresh_commutes : forall dim q b (c : base_ucom dim),
  is_fresh q c ->
  proj q dim b × uc_eval c = uc_eval c × proj q dim b.
Proof.
  intros.
  induction c; simpl; inversion H; subst.
  rewrite <- (Mmult_assoc (proj _ _ _)).
  rewrite (Mmult_assoc _ _ (proj _ _ _)).
  rewrite <- IHc1, IHc2 by auto.
  rewrite Mmult_assoc. reflexivity.
  apply proj_commutes_1q_gate; auto.
  apply proj_commutes_2q_gate; auto.
  Msimpl_light. reflexivity.
Qed.

Lemma control_correct : forall (dim : nat) q (c : base_ucom dim),
  is_fresh q c -> uc_well_typed c ->
  uc_eval (control q c) = proj q dim false .+ (proj q dim true) × (uc_eval c).
Proof.
  intros dim q c Hfr WT.
  induction c; try dependent destruction u; simpl;
  inversion WT; inversion Hfr; subst.
  rewrite IHc1, IHc2 by auto.
  distribute_plus.
  rewrite Mmult_assoc.
  rewrite <- proj_fresh_commutes by auto.
  rewrite Mmult_assoc, <- (Mmult_assoc (uc_eval c2)).
  rewrite <- proj_fresh_commutes by auto.
  repeat rewrite <- Mmult_assoc.
  rewrite 2 proj_twice_eq.
  rewrite 2 proj_twice_neq; try easy.
  Msimpl_light. reflexivity.
  apply CU_correct; auto.
  apply CCX_correct; auto.
Qed.

Lemma control_not_WT : forall {dim} n (c : base_ucom dim),
  not (uc_well_typed c) -> uc_eval (control n c) = Zero.
Proof.
  intros dim n c nWT.
  induction c; try dependent destruction u.
  - assert (not (uc_well_typed c1) \/ not (uc_well_typed c2)).
    apply Classical_Prop.not_and_or.
    intros [contra1 contra2].
    contradict nWT.
    constructor; auto.
    simpl.
    destruct H as [H | H].
    rewrite IHc1 by assumption.
    Msimpl. reflexivity.
    rewrite IHc2 by assumption.
    Msimpl. reflexivity.
  - apply UR_not_WT. assumption.
  - apply CCX_not_WT. assumption.
Qed.

Lemma control_not_fresh : forall {dim} n (c : base_ucom dim),
  not (is_fresh n c) -> uc_eval (control n c) = Zero.
Proof.
  intros dim n c nfr.
  induction c; try dependent destruction u.
  - assert (not (is_fresh n c1) \/ not (is_fresh n c2)).
    apply Classical_Prop.not_and_or.
    intros [contra1 contra2].
    contradict nfr.
    constructor; auto.
    simpl.
    destruct H as [H | H].
    rewrite IHc1 by assumption.
    Msimpl. reflexivity.
    rewrite IHc2 by assumption.
    Msimpl. reflexivity.
  - apply UR_not_fresh. assumption.
  - apply CCX_not_fresh. assumption.
Qed.

Lemma control_q_geq_dim : forall {dim} q (c : base_ucom dim),
  (dim <= q)%nat -> uc_eval (control q c) = Zero.
Proof.
  intros dim q c Hq.
  induction c; try dependent destruction u; simpl.
  - rewrite IHc1. Msimpl_light. trivial.
  - apply UR_a_geq_dim. assumption.
  - apply CCX_a_geq_dim. assumption.
Qed.

(* c ≡ c' implies (uc_well_typed c <-> uc_well_typed c' *)
Lemma control_cong : forall {dim} n (c c' : base_ucom dim),
  c ≡ c' -> (is_fresh n c <-> is_fresh n c') -> control n c ≡ control n c'.
Proof.
  intros dim n c c' H Hfr.
  unfold uc_equiv in *.
  destruct (uc_well_typed_b c) eqn:WT.
  2: { rewrite <- not_true_iff_false in WT.
       rewrite uc_well_typed_b_equiv in WT.
       rewrite control_not_WT by assumption.
       rewrite <- uc_eval_zero_iff in WT.
       rewrite WT in H.
       symmetry in H.
       rewrite uc_eval_zero_iff in H.
       rewrite control_not_WT by assumption.
       reflexivity. }
  apply uc_well_typed_b_equiv in WT.
  assert (uc_well_typed c').
  { apply WT_if_nonzero.
    intro contra.
    rewrite contra in H.
    rewrite <- uc_eval_nonzero_iff in WT.
    contradiction. }
  destruct (is_fresh_b n c) eqn:Hfr'.
  2: { rewrite <- not_true_iff_false in Hfr'.
       rewrite is_fresh_b_equiv in Hfr'.
       rewrite control_not_fresh by assumption.
       rewrite Hfr in Hfr'.
       rewrite control_not_fresh by assumption.
       reflexivity. }
  apply is_fresh_b_equiv in Hfr'.
  assert (is_fresh n c').
  { apply Hfr. assumption. }
  rewrite 2 control_correct by assumption.
  rewrite H.
  reflexivity.
Qed.

(* Sanity check *)
Local Transparent X CU.
Lemma CNOT_is_control_X : forall dim c t,
  uc_eval (@CNOT dim c t) = uc_eval (control c (X t)).
Proof.
  intros dim c t.
  bdestruct (c <? dim).
  2: simpl; autorewrite with eval_db; gridify.
  bdestruct (t <? dim).
  2: simpl; autorewrite with eval_db; gridify.
  bdestruct (c =? t).
  simpl; autorewrite with eval_db; gridify.
  rewrite control_correct; try constructor; auto.
  unfold proj.
  autorewrite with eval_db.
  gridify.
  all: rewrite Mplus_comm; reflexivity.
Qed.
Local Opaque X CU.

Lemma invert_fresh : forall dim q (u : base_ucom dim),
  is_fresh q u <-> is_fresh q (invert u).
Proof.
  intros dim q u.
  split; intro H.
  induction u; try dependent destruction u; inversion H; subst; constructor; auto.
  induction u; try dependent destruction u; inversion H; subst; constructor; auto.
Qed.

Lemma proj_adjoint : forall dim q b, (proj q dim b) † = proj q dim b.
Proof.
  intros.
  unfold proj, pad_u, pad.
  gridify.
  destruct b; simpl; Msimpl; reflexivity.
Qed.

Lemma invert_control : forall dim q (u : base_ucom dim),
  invert (control q u) ≡ control q (invert u).
Proof.
  intros dim q u.
  unfold uc_equiv.
  destruct (uc_well_typed_b u) eqn:WT.
  2: { rewrite <- not_true_iff_false in WT.
       rewrite uc_well_typed_b_equiv in WT.
       rewrite <- invert_correct.
       rewrite (control_not_WT _ u) by assumption.
       rewrite uc_well_typed_invert in WT.
       rewrite (control_not_WT _ (invert _)) by assumption.
       lma. }
  rewrite uc_well_typed_b_equiv in WT.
  destruct (is_fresh_b q u) eqn:Hfr.
  2: { rewrite <- not_true_iff_false in Hfr.
       rewrite is_fresh_b_equiv in Hfr.
       rewrite <- invert_correct.
       rewrite (control_not_fresh _ u) by assumption.
       rewrite invert_fresh in Hfr.
       rewrite (control_not_fresh _ (invert _)) by assumption.
       lma. }
  rewrite is_fresh_b_equiv in Hfr.
  assert (uc_well_typed (invert u)).
  rewrite <- uc_well_typed_invert; auto.
  assert (is_fresh q (invert u)).
  rewrite <- invert_fresh; auto.
  rewrite <- invert_correct.
  rewrite control_correct by assumption.
  rewrite control_correct by assumption.
  rewrite <- invert_correct.
  distribute_adjoint.
  rewrite 2 proj_adjoint.
  rewrite invert_correct.
  rewrite proj_fresh_commutes by assumption.
  reflexivity.
Qed.

Lemma proj_control_true : forall {dim} q c,
  is_fresh q c ->
  uc_eval (control q c) × proj q dim true = proj q dim true × uc_eval c.
Proof.
  intros.
  destruct (uc_well_typed_b c) eqn:WT.
  apply uc_well_typed_b_equiv in WT.
  rewrite control_correct by auto.
  rewrite Mmult_plus_distr_r.
  rewrite proj_fresh_commutes by auto.
  rewrite proj_twice_neq.
  rewrite Mmult_assoc, proj_twice_eq.
  Msimpl. reflexivity.
  easy.
  apply not_true_iff_false in WT.
  rewrite uc_well_typed_b_equiv in WT.
  rewrite control_not_WT by auto.
  apply uc_eval_zero_iff in WT.
  rewrite WT.
  Msimpl. reflexivity.
Qed.

Lemma proj_control_false : forall {dim} q c,
  is_fresh q c -> uc_well_typed c ->
  uc_eval (control q c) × proj q dim false = proj q dim false.
Proof.
  intros.
  rewrite control_correct by auto.
  rewrite Mmult_plus_distr_r.
  rewrite proj_fresh_commutes by auto.
  rewrite proj_twice_eq.
  rewrite Mmult_assoc, proj_twice_neq.
  Msimpl. reflexivity.
  easy.
Qed.

Lemma proj_CNOT_ctl_true : forall dim m n,
  m <> n ->
  uc_eval (CNOT m n) × proj m dim true = proj m dim true × uc_eval (X n).
Proof.
  intros dim m n H.
  unfold proj.
  autorewrite with eval_db.
  gridify; Qsimpl; reflexivity.
Qed.

Lemma proj_CNOT_ctl_false : forall dim m n,
  (n < dim)%nat -> m <> n ->
  uc_eval (CNOT m n) × proj m dim false = proj m dim false.
Proof.
  intros dim m n H1 H2.
  unfold proj.
  autorewrite with eval_db.
  gridify; Qsimpl; reflexivity.
Qed.

Lemma proj_X : forall dim q b,
  uc_eval (X q) × proj q dim b = proj q dim (negb b) × uc_eval (X q).
Proof.
  intros.
  unfold proj.
  autorewrite with eval_db.
  gridify.
  destruct b; simpl; Qsimpl; reflexivity.
Qed.

(** n iterations of a program **)

Fixpoint niter {dim} n (c : base_ucom dim) : base_ucom dim :=
  match n with
  | 0    => SKIP
  | 1    => c
  | S n' => niter n' c ; c
  end.

Lemma uc_well_typed_niter : forall {d} (c : base_ucom d) i,
  uc_well_typed c -> uc_well_typed (niter i c).
Proof.
  intros.
  induction i; simpl.
  apply uc_well_typed_ID.
  apply uc_well_typed_implies_dim_nonzero in H.
  assumption.
  destruct i; try assumption.
  constructor; assumption.
Qed.

Lemma niter_correct : forall dim (c : base_ucom dim) n,
  (dim > 0)%nat -> uc_eval (niter n c) = n ⨉ (uc_eval c).
Proof.
  intros dim c n Hdim.
  induction n; simpl.
  apply denote_SKIP; auto.
  destruct n. simpl. Msimpl. reflexivity.
  remember (S n) as n'.
  simpl. rewrite IHn.
  reflexivity.
Qed.

Lemma niter_control_commute : forall d (c : base_ucom d) i j,
  (i > 0)%nat ->
  niter i (control j c) ≡ control j (niter i c).
Proof.
  intros d c i j Hi.
  destruct i; try lia.
  induction i.
  reflexivity.
  replace (niter (S (S i)) (control j c)) with (niter (S i) (control j c) ; control j c) by reflexivity.
  rewrite IHi; try lia.
  reflexivity.
Qed.

Lemma is_fresh_niter : forall {d} (c : base_ucom d) q i,
  (i > 0)%nat -> is_fresh q c -> is_fresh q (niter i c).
Proof.
  intros.
  destruct i; try lia.
  induction i.
  simpl. assumption.
  replace (niter (S (S i)) c) with (niter (S i) c ; c) by reflexivity.
  constructor; try assumption.
  apply IHi. lia.
Qed.

(** Padding lemmas to ease composition **)

(* General qubit re-labeling function. *)
Fixpoint map_qubits {U dim} (f : nat -> nat) (c : ucom U dim) : ucom U dim :=
  match c with
  | c1; c2 => map_qubits f c1; map_qubits f c2
  | uapp1 u n => uapp1 u (f n)
  | uapp2 u m n => uapp2 u (f m) (f n)
  | uapp3 u m n p => uapp3 u (f m) (f n) (f p)
  end.

(* Change a program's dimension *)
(* TODO: Is there a nicer way to write this? *)
Fixpoint cast {U dim} (c : ucom U dim) dim' : ucom U dim' :=
  match c with
  | c1; c2 => cast c1 dim' ; cast c2 dim'
  | uapp1 u n => uapp1 u n
  | uapp2 u m n => uapp2 u m n
  | uapp3 u m n p => uapp3 u m n p
  end.

Lemma typed_cast : forall {U n} (c : ucom U n) (n' : nat),
  uc_well_typed c -> (n <= n')%nat -> uc_well_typed (cast c n').
Proof.
  intros.
  induction H; simpl; constructor; try lia.
  apply IHuc_well_typed1. apply IHuc_well_typed2.
Qed.

Lemma uc_well_typed_map_qubits : forall U dim k (c : ucom U dim),
  uc_well_typed c -> uc_well_typed (cast (map_qubits (fun q => k + q)%nat c) (k + dim)%nat) .
Proof.
  intros U dim k c WT.
  induction c; simpl; inversion WT; subst; constructor; try lia.
  apply IHc1; auto.
  apply IHc2; auto.
Qed.

Lemma cast_control_commute : forall d d' (c : base_ucom d) i,
  cast (control i c) d' = control i (cast c d').
Proof.
  intros d d' c i.
  induction c; try dependent destruction u; try reflexivity.
  simpl. rewrite IHc1, IHc2. reflexivity.
Qed.

Lemma cast_niter_commute : forall d d' (c : base_ucom d) i,
  cast (niter i c) d' = niter i (cast c d').
Proof.
  intros d d' c i.
  induction i; simpl.
  reflexivity.
  destruct i; try reflexivity.
  remember (S i) as i'.
  simpl cast. rewrite IHi. reflexivity.
Qed.

Lemma map_qubits_fresh : forall k n q (c : base_ucom n) n',
  (q < k)%nat ->
  is_fresh q (cast (map_qubits (fun i => k + i) c)%nat n').
Proof.
  intros k n q c n' Hq.
  induction c; try dependent destruction u; simpl; constructor;
  try assumption; try lia.
Qed.

Lemma pad_dims_r : forall {dim} (c : base_ucom dim) (k : nat),
  uc_well_typed c ->
  (uc_eval c) ⊗ I (2^k) = uc_eval (cast c (dim + k)).
Proof.
  intros dim c k H.
  induction c; try dependent destruction u.
  - inversion H; subst.
    simpl. rewrite <- IHc1, <- IHc2; trivial.
    restore_dims; Msimpl; reflexivity.
  - simpl. inversion H; subst.
    autorewrite with eval_db.
    gridify; reflexivity.
  - simpl. inversion H; subst.
    autorewrite with eval_db.
    gridify; reflexivity.
Qed.

Lemma pad_dims_l : forall {dim} (c : base_ucom dim) (k : nat),
  I (2^k) ⊗ (uc_eval c) = uc_eval (cast (map_qubits (fun q => k + q) c) (k + dim))%nat.
Proof.
  intros.
  induction c; try dependent destruction u; simpl.
  - rewrite <- IHc1, <- IHc2.
    restore_dims; Msimpl. reflexivity.
  - autorewrite with eval_db.
    gridify; reflexivity.
  - autorewrite with eval_db.
    gridify; reflexivity.
Qed.

Lemma cast_cong_r : forall {dim} (u u' : base_ucom dim) n,
  uc_well_typed u -> (u ≡ u')%ucom -> (cast u (dim + n) ≡ cast u' (dim + n))%ucom.
Proof.
  intros dim u u' n WT H.
  unfold uc_equiv in *.
  rewrite <- 2 pad_dims_r.
  rewrite H. reflexivity.
  apply uc_eval_nonzero_iff.
  apply uc_eval_nonzero_iff in WT.
  rewrite <- H; assumption.
  assumption.
Qed.

Lemma cast_cong_l : forall {dim} (u u' : base_ucom dim) n,
  (u ≡ u')%ucom ->
  (cast (UnitaryOps.map_qubits (fun q : nat => (n + q)%nat) u) (n + dim) ≡
   cast (UnitaryOps.map_qubits (fun q : nat => (n + q)%nat) u') (n + dim))%ucom.
Proof.
  intros dim u u' n H.
  unfold uc_equiv in *.
  rewrite <- 2 pad_dims_l.
  rewrite H. reflexivity.
Qed.

(** n copies of a gate in parallel **)

Fixpoint npar' dim n (U : base_Unitary 1) : base_ucom dim :=
  match n with
  | 0 => SKIP
  | S n' => npar' dim n' U ; uapp1 U n'
  end.
Definition npar n U := npar' n n U.

Lemma npar_correct : forall n U,
  (n > 0)%nat -> uc_eval (npar n U) = n ⨂ (@uc_eval 1 (uapp1 U 0)).
Proof.
  assert (H : forall dim n U,
    (0 < dim)%nat -> (n <= dim)%nat ->
    uc_eval (npar' dim n U) = (n ⨂ (@uc_eval 1 (uapp1 U 0))) ⊗ I (2 ^ (dim - n))).
  { intros dim n U Hdim Hn.
    induction n.
    - replace (dim - 0)%nat with dim by lia.
      Msimpl_light. simpl. rewrite denote_SKIP; auto.
    - simpl.
      rewrite IHn; try lia.
      simpl.
      dependent destruction U.
      autorewrite with eval_db.
      bdestruct_all.
      replace (dim - (n + 1))%nat with (dim - (S n))%nat by lia.
      replace (2 ^ (dim - n))%nat with (2 * 2 ^ (dim - (S n)))%nat by unify_pows_two.
      rewrite <- id_kron.
      rewrite <- kron_assoc by auto with wf_db.
      simpl I. Msimpl_light.
      replace (2 ^ dim)%nat with (2 ^ n * 2 * 2 ^ (dim - S n))%nat by unify_pows_two.
      repeat rewrite kron_mixed_product.
      Msimpl_light.
      reflexivity. }
  intros.
  unfold npar.
  rewrite H; auto.
  replace (n - n)%nat with O by lia.
  simpl I. rewrite kron_1_r.
  reflexivity.
Qed.

Lemma npar_WT : forall n U, (n > 0)%nat -> uc_well_typed (npar n U).
Proof.
  assert (H: forall dim n U, (0 < dim)%nat -> (n <= dim)%nat ->
    uc_well_typed (npar' dim n U)).
  { intros dim n U Hdim Hn.
    induction n; simpl. apply uc_well_typed_ID. auto.
    constructor. apply IHn. lia.
    constructor. lia. }
  intros.
  unfold npar.
  apply H; auto.
Qed.

(* Common use case: *)
Lemma npar_H : forall n,
  (n > 0)%nat -> uc_eval (npar n U_H) = n ⨂ hadamard.
Proof.
  intros.
  rewrite npar_correct by auto.
  simpl. rewrite hadamard_rotation.
  unfold pad_u, pad. bdestruct_all.
  simpl I. Msimpl_light.
  reflexivity.
Qed.

(** Compose arbitrary programs in parallel **)

Definition inPar {U dim1 dim2} (c1 : ucom U dim1) (c2 : ucom U dim2) :=
  (cast c1 (dim1 + dim2)); (cast (map_qubits (fun q => dim1 + q)%nat c2) (dim1 + dim2)).

Lemma inPar_WT : forall {U dim1 dim2} (c1 : ucom U dim1) (c2 : ucom U dim2),
  uc_well_typed c1 -> uc_well_typed c2 -> uc_well_typed (inPar c1 c2).
Proof.
  intros U dim1 dim2 c1 c2 WTc1 WTc2.
  unfold inPar.
  apply WT_seq.
  - clear - WTc1.
    induction WTc1; simpl; constructor; try lia; assumption.
  - clear - WTc2.
    induction WTc2; simpl; constructor; try lia; assumption.
Qed.

Lemma inPar_correct : forall {dim1 dim2} (c1 : base_ucom dim1) (c2 : base_ucom dim2),
  uc_well_typed c1 -> uc_eval (inPar c1 c2) = (uc_eval c1) ⊗ (uc_eval c2).
Proof.
  intros dim1 dim2 c1 c2 WTc1.
  simpl.
  rewrite <- (pad_dims_r c1); try assumption.
  rewrite <- pad_dims_l.
  restore_dims.
  rewrite kron_mixed_product.
  Msimpl.
  reflexivity.
Qed.


From iris.program_logic Require Export weakestpre hoare.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import proofmode notation.

Section list.
  Context `{!heapG Σ}. (* Set up the heap context *)

  (** * List *)

  (** In this chapter, we are studying data-structures that
   _represent_ an abstract concept of list/list-segment.
It means that, we map the abstract list to our physical memory,
and provide a set of operations whose spec is _abstract_. *)

  (** Below is the abstract definition of list: Just using the Coq's
standard list *)

  Definition List a := list a.

  (** Compared to the imperative & low-level language, e.g. C,
heap_lang is functional & fairly high-level. It is intuitive that
we will need to use option type and pair to model the classical lisp list (since
[heap_lang] can't define ADT conveniently now:

<<
-- Haskell

data List a = Cons { hd :: a, tl :: List a }
            | Nil
>>
*)

  Definition nil : val := NONEV.

  Definition cons : val := λ: "x" "xl", ref SOME ("x", "xl").

(*
TODO: It might be clearer to draw a graph here, but I won't bother now :P
*)

  (* Here is the "shape" predicate *)
  Fixpoint isList (l: val) (xs: List val) : iProp Σ :=
    match xs with
    | [] => ⌜ l = NONEV ⌝%I
    | x :: xs => (∃ (hd: loc) (tl: val),
                    ⌜ #hd = l ⌝ ∗ hd ↦ SOMEV (x, tl) ∗ isList tl xs)%I
    end.

  (** This predicate, when applied with an abstract list, maps to
its physical configuration. Now we can give spec for nil and cons.  *)

  Lemma nil_spec: True ⊢ isList nil [].
  Proof.
    simpl. rewrite /nil. auto.
  Qed.

  Lemma cons_spec (l: val) (x: val) (xl: List val) : ∀ Φ,
    isList l xl ∗
    (∀ l': val, isList l' (x::xl) -∗ Φ l')
    ⊢ WP cons x l {{ Φ }}.
  Proof.
    iIntros (Φ) "(Hl & HΦ)".
    rewrite /cons.
    wp_let. wp_let.
    wp_alloc l' as "Hl'".
    iApply "HΦ".
    iExists l', l.
    by iFrame.
  Qed.

  (** * List Segment *)

  Fixpoint isListSeg (m n: val) (xs: List val) : iProp Σ :=
    match xs with
    | [] => ⌜ m = n ⌝%I
    | x :: xs => (∃ (hd: loc) (m': val),
                     ⌜ #hd = m ⌝ ∗ hd ↦ SOMEV (x, m') ∗ isListSeg m' n xs)%I
    end.

  (** we will prove a trivial lemma first *)
  Lemma list_seg_list: ∀ (xl: List val) (l: val),
      isListSeg l nil xl ⊣⊢ isList l xl.
  Proof.
    induction xl as [|x xl' IHxl']=>//.
    intros l. apply uPred.equiv_spec.
    split.
    - iIntros "Hls".
      simpl.
      iDestruct "Hls" as (hd m') "(% & Hhd & Htl)".
      subst. iExists hd, m'.
      iDestruct (IHxl' m' with "Htl") as "Hm".
      by iFrame.
    - iIntros "Hls".
      simpl.
      iDestruct "Hls" as (hd m') "(% & Hhd & Htl)".
      iExists hd, m'.
      iDestruct (IHxl' m' with "Htl") as "Hm".
      by iFrame.
      (* Look, two branches are exactly the same ! *)
  Qed.
End list.


From elpi Require Import elpi.
From Coq Require Import QArith Ring.
From Coq.micromega Require Import RingMicromega QMicromega EnvRing Tauto Lqa.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat choice seq.
From mathcomp Require Import fintype finfun bigop order ssralg ssrnum ssrint.
From mathcomp.zify Require Import ssrZ zify.
From mathcomp.algebra_tactics Require Import common.
From mathcomp.algebra_tactics Extra Dependency "common.elpi" as common.
From mathcomp.algebra_tactics Extra Dependency "lra.elpi" as lra.

Import Order.TTheory GRing.Theory Num.Theory.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope ring_scope.

Module Import Internals.

Implicit Types (k : kind) (R S : ringType) (F : fieldType).

Inductive RExpr : ringType -> Type :=
  | RX R : R -> RExpr R
  | R0 R : RExpr R
  | ROpp R : RExpr R -> RExpr R
  | RAdd R : RExpr R -> RExpr R -> RExpr R
  (* TODO: support nat expressions: *)
  | RMuln R : RExpr R -> large_nat -> RExpr R
  | RMulz R : RExpr R -> RExpr [ringType of int] -> RExpr R
  | R1 R : RExpr R
  | RMul R : RExpr R -> RExpr R -> RExpr R
  | RExpn R : RExpr R -> large_nat -> RExpr R
  | RInv F : RExpr F -> RExpr F
  | RMorph R R' : {rmorphism R -> R'} -> RExpr R -> RExpr R'
  | RintC : large_int -> RExpr [ringType of int]
  | RZC : Z -> RExpr [ringType of Z].

Fixpoint Reval_expr R (e : RExpr R) : R :=
  match e with
  | RX _ x => x
  | R0 _ => 0%R
  | ROpp _ e => - Reval_expr e
  | RAdd _ e1 e2 => Reval_expr e1 + Reval_expr e2
  | RMuln _ e n => Reval_expr e *+ nat_of_large_nat n
  | RMulz _ e1 e2 => Reval_expr e1 *~ Reval_expr e2
  | R1 _ => 1%R
  | RMul _ e1 e2 => Reval_expr e1 * Reval_expr e2
  | RExpn _ e n => Reval_expr e ^+ nat_of_large_nat n
  | RInv _  e => (Reval_expr e)^-1
  | RMorph _ _ f e => f (Reval_expr e)
  | RintC x => int_of_large_int x
  | RZC x => x
  end.

(* Define [Reval_formula] the semantics of [BFormula (Formula Z) Tauto.isProp]
   as arithmetic expressions on some [realDomainType].
   Then prove [RTautoChecker_sound] stating that [ZTautoChecker f w = true]
   implies that the formula [Reval_formula f] holds. *)
Record RFormula R := { Rlhs : RExpr R;  Rop : Op2;  Rrhs : RExpr R }.

Section Rnorm_expr.

Variables (R' : ringType).
Variables (R_of_Z : Z -> R') (R_of_ZE : R_of_Z = (fun n => (int_of_Z n)%:~R)).
Variables (opp : R' -> R') (oppE : opp = -%R).
Variables (add : R' -> R' -> R') (addE : add = +%R).
Variables (mul : R' -> R' -> R') (mulE : mul = *%R).
Variables (exp : R' -> N -> R') (expE : exp = (fun x n => x ^+ nat_of_N n)).

Fixpoint Rnorm_expr R (f : {rmorphism R -> R'}) (e : RExpr R) : R' :=
  match e in RExpr R return {rmorphism R -> R'} -> R' with
  | RX _ x => fun f => f x
  | R0 _ => fun=> R_of_Z 0
  | ROpp _ e => fun f => opp (Rnorm_expr f e)
  | RAdd _ e1 e2 => fun f => add (Rnorm_expr f e1) (Rnorm_expr f e2)
  | RMuln _ e n => fun f => mul (Rnorm_expr f e) (R_of_Z (Z_of_large_nat n))
  | RMulz _ e1 e2 =>
      fun f => mul (Rnorm_expr f e1) (Rnorm_expr [rmorphism of intmul 1] e2)
  | R1 _ => fun=> R_of_Z 1
  | RMul _ e1 e2 => fun f => mul (Rnorm_expr f e1) (Rnorm_expr f e2)
  | RExpn _ e1 n => fun f => exp (Rnorm_expr f e1) (N_of_large_nat n)
  | RInv _ _ => fun=> f (Reval_expr e)
  | RMorph _ _ g e => fun f => Rnorm_expr [rmorphism of f \o g] e
  | RintC x => fun=> R_of_Z (Z_of_large_int x)
  | RZC x => fun=> R_of_Z x
  end f.

Lemma Rnorm_expr_correct_rec R (f : {rmorphism R -> R'}) (e : RExpr R) :
  f (Reval_expr e) = Rnorm_expr f e.
Proof.
move: f; elim: e => {R} //=.
- by move=> R f; rewrite R_of_ZE rmorph0.
- by move=> R e IHe f; rewrite oppE rmorphN IHe.
- by move=> R e1 IHe1 e2 IHe2 f; rewrite addE rmorphD IHe1 IHe2.
- move=> R e IHe n f.
  by rewrite mulE R_of_ZE rmorphMn -mulr_natr IHe large_nat_Z_int.
- by move=> R e1 IHe1 e2 IHe2 f; rewrite mulE rmorphMz -mulrzr IHe1 IHe2.
- by move=> R f; rewrite R_of_ZE rmorph1.
- by move=> R e1 IHe1 e2 IHe2 f; rewrite mulE rmorphM IHe1 IHe2.
- by move=> R e IHe n f; rewrite expE rmorphX IHe large_nat_N_nat.
- by move=> R S g e IHe f; rewrite -IHe.
- by move=> x f; rewrite R_of_ZE -(rmorph_int f) intz large_int_Z_int.
- by move=> x f; rewrite R_of_ZE -(rmorph_int f); congr (f _); lia.
Qed.

Lemma Rnorm_expr_correct (e : RExpr R') :
  Reval_expr e = Rnorm_expr [rmorphism of idfun] e.
Proof. exact: Rnorm_expr_correct_rec [rmorphism of idfun] _. Qed.

End Rnorm_expr.

Section Rnorm_formula.

Variables (R : numDomainType).
Variables (R_of_Z : Z -> R) (R_of_ZE : R_of_Z = (fun n => (int_of_Z n)%:~R)).
Variables (opp : R -> R) (oppE : opp = -%R).
Variables (add : R -> R -> R) (addE : add = +%R).
Variables (sub : R -> R -> R) (subE : sub = (fun x y => x - y)).
Variables (mul : R -> R -> R) (mulE : mul = *%R).
Variables (exp : R -> N -> R) (expE : exp = (fun x n => x ^+ nat_of_N n)).
Variables (eqProp : R -> R -> Prop) (eqPropE : eqProp = eq).
Variables (eqBool : R -> R -> bool) (eqBoolE : eqBool = eq_op).
Variables (le : R -> R -> bool) (leE : le = <=%O).
Variables (lt : R -> R -> bool) (ltE : lt = <%O).

Notation Rnorm_expr := (Rnorm_expr R_of_Z opp add mul exp).

Definition Reval_pop2 (o : Op2) : R -> R -> Prop :=
  match o with
  | OpEq => eqProp
  | OpNEq => fun x y => ~ eqProp x y
  | OpLe => le
  | OpGe => fun x y => le y x
  | OpLt => lt
  | OpGt => fun x y => lt y x
  end.

Definition Reval_bop2 (o : Op2) : R -> R -> bool :=
  match o with
  | OpEq  => eqBool
  | OpNEq => fun x y => ~~ eqBool x y
  | OpLe  => le
  | OpGe  => fun x y => le y x
  | OpLt  => lt
  | OpGt  => fun x y => lt y x
  end.

Definition Reval_op2 k : Op2 -> R -> R -> rtyp k :=
  match k with isProp => Reval_pop2 | isBool => Reval_bop2 end.

Definition Reval_formula k (ff : RFormula R) : rtyp k :=
  let (lhs,o,rhs) := ff in Reval_op2 k o (Reval_expr lhs) (Reval_expr rhs).

Definition Rnorm_formula k (ff : RFormula R) :=
  let norm := Rnorm_expr [rmorphism of idfun] in
  let (lhs,o,rhs) := ff in Reval_op2 k o (norm lhs) (norm rhs).

Lemma Rnorm_formula_correct k (ff : RFormula R) :
  Reval_formula k ff = Rnorm_formula k ff.
Proof. by case: ff => l o r /=; rewrite -!Rnorm_expr_correct. Qed.

Lemma Rnorm_bf_correct k (ff : BFormula (RFormula R) k) :
  eval_bf Reval_formula ff = eval_bf Rnorm_formula ff.
Proof.
elim: ff => // {k}.
- by move=> k ff ?; exact: Rnorm_formula_correct.
- by move=> k ff1 IH1 ff2 IH2; congr eAND.
- by move=> k ff1 IH1 ff2 IH2; congr eOR.
- by move=> k ff IH; congr eNOT.
- by move=> k ff1 IH1 o ff2 IH2; congr eIMPL.
- by move=> k ff1 IH1 ff2 IH2; congr eIFF.
- by move=> ff1 IH1 ff2 IH2; congr eq.
Qed.

Definition Reval_PFormula (e : PolEnv R) k (ff : Formula Z) : rtyp k :=
  let eval := PEeval add mul sub opp R_of_Z id exp e in
  let (lhs,o,rhs) := ff in Reval_op2 k o (eval lhs) (eval rhs).

Lemma pop2_bop2 (op : Op2) (q1 q2 : R) :
  Reval_bop2 op q1 q2 <-> Reval_pop2 op q1 q2.
Proof. by case: op => //=; rewrite eqPropE eqBoolE; split => /eqP. Qed.

Lemma Reval_formula_compat (env : PolEnv R) k (f : Formula Z) :
  hold k (Reval_PFormula env k f) <->
  eval_formula add mul sub opp eqProp le lt R_of_Z id exp env f.
Proof. by case: f => lhs op rhs; case: k => //=; rewrite pop2_bop2. Qed.

End Rnorm_formula.

Section RealDomain.

Variable R : realDomainType.

Notation Rsor := (Rsor R).
Notation RSORaddon := (RSORaddon R).

Definition ZTautoChecker (f : BFormula (Formula Z) isProp) (w: list (Psatz Z)) :
    bool :=
  @tauto_checker
    (Formula Z) (NFormula Z) unit
    (check_inconsistent 0 Z.eqb Z.leb)
    (nformula_plus_nformula 0 Z.add Z.eqb)
    (@cnf_normalise Z 0 1 Z.add Z.mul Z.sub Z.opp Z.eqb Z.leb unit)
    (@cnf_negate Z 0 1 Z.add Z.mul Z.sub Z.opp Z.eqb Z.leb unit)
    (Psatz Z)
    (fun cl => check_normalised_formulas
                 0 1 Z.add Z.mul Z.eqb Z.leb (List.map fst cl)) f w.

Definition Reval_nformula : PolEnv R -> NFormula Z -> Prop :=
  eval_nformula 0 +%R *%R eq <=%O <%O (fun n => (int_of_Z n)%:~R).

Lemma RTautoChecker_sound
    (ff : BFormula (RFormula R) isProp) (f : BFormula (Formula Z) isProp)
    (w : seq (Psatz Z)) (env : PolEnv R) :
  (forall R_of_Z opp add sub mul exp eqProp eqBool le lt,
      let norm_ff := Rnorm_formula R_of_Z opp add mul exp eqProp eqBool le lt in
      let eval_f :=
        Reval_PFormula R_of_Z opp add sub mul exp eqProp eqBool le lt env in
      eval_bf norm_ff ff = eval_bf eval_f f) ->
  ZTautoChecker f w -> eval_bf (Reval_formula eq eq_op <=%O <%O) ff.
Proof.
rewrite (Rnorm_bf_correct erefl erefl erefl erefl erefl).
move=> /(_ _ _ _ (fun x y => x - y)) -> Hchecker.
move: Hchecker env; apply: (tauto_checker_sound _ _ _ _ Reval_nformula).
- exact: (eval_nformula_dec Rsor).
- by move=> [? ?] ? ?; apply: (check_inconsistent_sound Rsor RSORaddon).
- move=> t t' u deducett'u env evalt evalt'.
  exact: (nformula_plus_nformula_correct Rsor RSORaddon env t t').
- move=> env k t tg cnfff; rewrite Reval_formula_compat //.
  exact: (cnf_normalise_correct Rsor RSORaddon env t tg).1.
- move=> env k t tg cnfff; rewrite hold_eNOT Reval_formula_compat //.
  exact: (cnf_negate_correct Rsor RSORaddon env t tg).1.
- move=> t w0 checkw0 env; rewrite (Refl.make_impl_map (Reval_nformula env)) //.
  exact: (checker_nf_sound Rsor RSORaddon) checkw0 env.
Qed.

End RealDomain.

Section Fnorm_expr.

Variables (F : fieldType).
Variables (F_of_Q : Q -> F) (F_of_QE : F_of_Q = R_of_Q).
Variables (opp : F -> F) (oppE : opp = -%R).
Variables (add : F -> F -> F) (addE : add = +%R).
Variables (mul : F -> F -> F) (mulE : mul = *%R).
Variables (exp : F -> N -> F) (expE : exp = (fun x n => x ^+ nat_of_N n)).
Variables (inv : F -> F) (invE : inv = GRing.inv).

Fixpoint Fnorm_expr R (f : {rmorphism R -> F}) (e : RExpr R) (invb : bool) :
    F :=
  match e in RExpr R, invb return {rmorphism R -> F} -> F with
  | RX _ x, false => fun f => f x
  | RX _ x, true => fun f => inv (f x)
  | R0 _, _ => fun=> F_of_Q 0
  | ROpp _ e, _ => fun f => opp (Fnorm_expr f e invb)
  | RAdd _ e1 e2, false =>
      fun f => add (Fnorm_expr f e1 false) (Fnorm_expr f e2 false)
  | RMuln _ e n, _ => fun f =>
      mul (Fnorm_expr f e invb)
        (if invb then
           F_of_Q (Qinv (Z_of_large_nat n # 1))
         else F_of_Q (Z_of_large_nat n # 1))
  | RMulz _ e1 e2, _ => fun f =>
      mul (Fnorm_expr f e1 invb) (Fnorm_expr [rmorphism of intmul 1] e2 invb)
  | R1 _, _ => fun=> F_of_Q 1
  | RMul _ e1 e2, _ =>
      fun f => mul (Fnorm_expr f e1 invb) (Fnorm_expr f e2 invb)
  | RExpn _ e1 n, _ => fun f => exp (Fnorm_expr f e1 invb) (N_of_large_nat n)
  | RInv _ e, _ => fun f => Fnorm_expr f e (negb invb)
  | RMorph _ _ g e, _ => fun f => Fnorm_expr [rmorphism of f \o g] e invb
  | RintC x, false => fun=> F_of_Q (Z_of_large_int x # 1)
  | RintC x, true => fun=> F_of_Q (Qinv (Z_of_large_int x # 1))
  | RZC x, false => fun=> F_of_Q (x # 1)
  | RZC x, true => fun=> F_of_Q (Qinv (x # 1))
  | _, true => fun=> inv (f (Reval_expr e))
  end f.

Lemma Fnorm_expr_correct_rec R (f : {rmorphism R -> F}) (e : RExpr R) :
  (f (Reval_expr e) = Fnorm_expr f e false) /\
    ((f (Reval_expr e))^-1 = Fnorm_expr f e true).
Proof.
move: f; elim: e => {R} //=.
- by move=> R x f; rewrite invE.
- by move=> R f; rewrite F_of_QE rmorph0 invr0 /R_of_Q divr1.
- move=> R e IHe f; case: (IHe f) => {}IHe IHe'.
  by rewrite oppE rmorphN invrN IHe' IHe.
- move=> R e1 IHe1 e2 IHe2 f; move: (IHe1 f) (IHe2 f) => [{}IHe1 _] [{}IHe2 _].
  by rewrite addE invE rmorphD IHe1 IHe2.
- move=> R e IHe n f; move: (IHe f) => [{}IHe IHe'].
  rewrite mulE F_of_QE rmorphMn -mulr_natr invfM IHe' IHe R_of_Q_invZ.
  by rewrite /R_of_Q divr1 large_nat_Z_int.
- move=> R e1 IHe1 e2 IHe2 f.
  move: (IHe1 f) (IHe2 [rmorphism of intr]) => [{}IHe1 IHe1'] [{}IHe2 IHe2'].
  by rewrite mulE rmorphMz -mulrzr invfM IHe1' IHe1 IHe2' IHe2.
- by move=> R f; rewrite F_of_QE rmorph1 invr1 /R_of_Q divr1.
- move=> R e1 IHe1 e2 IHe2 f.
  move: (IHe1 f) (IHe2 f) => [{}IHe1 IHe1'] [{}IHe2 IHe2'].
  by rewrite mulE rmorphM invfM IHe1' IHe1 IHe2' IHe2.
- move=> R e IHe n f; case: (IHe f) => {}IHe IHe'.
  by rewrite expE rmorphX -exprVn IHe' IHe large_nat_N_nat.
- move=> R e IHe f; case: (IHe f) => {}IHe IHe'.
  by rewrite fmorphV invrK IHe' IHe.
- by move=> R S g e IHe f; case: (IHe [rmorphism of f \o g]); split.
- move=> x f; rewrite F_of_QE R_of_Q_invZ /R_of_Q divr1 /= -(rmorph_int f).
  by rewrite intz large_int_Z_int.
- move=> x f; rewrite F_of_QE R_of_Q_invZ /R_of_Q divr1 /= -(rmorph_int f).
  by split; [congr (f _) | congr (f _)^-1]; lia.
Qed.

Lemma Fnorm_expr_correct (e : RExpr F) :
  Reval_expr e = Fnorm_expr [rmorphism of idfun] e false.
Proof. by have [] := Fnorm_expr_correct_rec [rmorphism of idfun] e. Qed.

End Fnorm_expr.

Section Fnorm_formula.

Variables (F : numFieldType).
Variables (F_of_Q : Q -> F) (F_of_QE : F_of_Q = R_of_Q).
Variables (opp : F -> F) (oppE : opp = -%R).
Variables (add : F -> F -> F) (addE : add = +%R).
Variables (sub : F -> F -> F) (subE : sub = (fun x y => x - y)).
Variables (mul : F -> F -> F) (mulE : mul = *%R).
Variables (exp : F -> N -> F) (expE : exp = (fun x n => x ^+ nat_of_N n)).
Variables (eqProp : F -> F -> Prop) (eqPropE : eqProp = eq).
Variables (eqBool : F -> F -> bool) (eqBoolE : eqBool = eq_op).
Variables (le : F -> F -> bool) (leE : le = <=%O).
Variables (lt : F -> F -> bool) (ltE : lt = <%O).

Notation Fnorm_expr := (Fnorm_expr F_of_Q opp add mul exp GRing.inv).
Notation Feval_pop2 := (Reval_pop2 eqProp le lt).
Notation Feval_bop2 := (Reval_bop2 eqBool le lt).
Notation Feval_op2 := (Reval_op2 eqProp eqBool le lt).
Notation Feval_formula := (Reval_formula eqProp eqBool le lt).

Definition Fnorm_formula k (ff : RFormula F) :=
  let norm := Fnorm_expr [rmorphism of idfun] in
  let (lhs,o,rhs) := ff in Feval_op2 k o (norm lhs false) (norm rhs false).

Lemma Fnorm_formula_correct k (ff : RFormula F) :
  Feval_formula k ff = Fnorm_formula k ff.
Proof. by case: ff => l o r /=; rewrite -!Fnorm_expr_correct. Qed.

Lemma Fnorm_bf_correct k (ff : BFormula (RFormula F) k) :
  eval_bf Feval_formula ff = eval_bf Fnorm_formula ff.
Proof.
elim: ff => // {k}.
- by move=> k ff ?; exact: Fnorm_formula_correct.
- by move=> k ff1 IH1 ff2 IH2; congr eAND.
- by move=> k ff1 IH1 ff2 IH2; congr eOR.
- by move=> k ff IH; congr eNOT.
- by move=> k ff1 IH1 o ff2 IH2; congr eIMPL.
- by move=> k ff1 IH1 ff2 IH2; congr eIFF.
- by move=> ff1 IH1 ff2 IH2; congr eq.
Qed.

Definition Feval_PFormula (e : PolEnv F) k (ff : Formula Q) : rtyp k :=
  let eval := eval_pexpr add mul sub opp F_of_Q id exp e in
  let (lhs,o,rhs) := ff in Feval_op2 k o (eval lhs) (eval rhs).

Lemma pop2_bop2' (op : Op2) (q1 q2 : F) :
  Feval_bop2 op q1 q2 <-> Feval_pop2 op q1 q2.
Proof. by case: op => //=; rewrite eqPropE eqBoolE; split => /eqP. Qed.

Lemma Feval_formula_compat env b f :
  hold b (Feval_PFormula env b f) <->
  eval_formula add mul sub opp eqProp le lt F_of_Q id exp env f.
Proof. by case: f => lhs op rhs; case: b => //=; rewrite pop2_bop2'. Qed.

End Fnorm_formula.

(* Define [Feval_formula] the semantics of [BFormula (Formula Q) Tauto.isProp]
   as arithmetic expressions on some [realFieldType].
   Then prove [FTautoChecker_sound] stating that [QTautoChecker f w = true]
   implies that the formula [Feval_formula f] holds. *)
Section RealField.

Variable F : realFieldType.

Notation Rsor := (Rsor F).
Notation FSORaddon := (FSORaddon F).

Definition Feval_nformula : PolEnv F -> NFormula Q -> Prop :=
  eval_nformula 0 +%R *%R eq (fun x y => x <= y) (fun x y => x < y) R_of_Q.

Lemma FTautoChecker_sound
    (ff : BFormula (RFormula F) isProp) (f : BFormula (Formula Q) isProp)
    (w : seq (Psatz Q)) (env : PolEnv F) :
  (forall F_of_Q opp add sub mul exp eqProp eqBool le lt,
      let norm_ff := Fnorm_formula F_of_Q opp add mul exp eqProp eqBool le lt in
      let eval_f :=
        Feval_PFormula F_of_Q opp add sub mul exp eqProp eqBool le lt env in
      eval_bf norm_ff ff = eval_bf eval_f f) ->
  QTautoChecker f w -> eval_bf (Reval_formula eq eq_op <=%O <%O) ff.
Proof.
rewrite (Fnorm_bf_correct erefl erefl erefl erefl erefl).
move=> /(_ _ _ _ (fun x y => x - y)) -> Hchecker.
move: Hchecker env; apply: (tauto_checker_sound _ _ _ _ Feval_nformula).
- exact: (eval_nformula_dec Rsor).
- by move=> [? ?] ? ?; apply: (check_inconsistent_sound Rsor FSORaddon).
- move=> t t' u deducett'u env evalt evalt'.
  exact: (nformula_plus_nformula_correct Rsor FSORaddon env t t').
- move=> env k t tg cnfff; rewrite Feval_formula_compat //.
  exact: (cnf_normalise_correct Rsor FSORaddon env t tg).1.
- move=> env k t tg cnfff; rewrite hold_eNOT Feval_formula_compat //.
  exact: (cnf_negate_correct Rsor FSORaddon env t tg).1.
- move=> t w0 checkw0 env; rewrite (Refl.make_impl_map (Feval_nformula env)) //.
  exact: (checker_nf_sound Rsor FSORaddon) checkw0 env.
Qed.

End RealField.

(* Auxiliary function called from lra.elpi *)
Definition vm_of_list T (l : list T) : VarMap.t T :=
  let fix aux acc p l :=
    match l with
    | [::] => acc
    | x :: l => aux (VarMap.vm_add x p x acc) (Pos.succ p) l
    end in
  aux VarMap.Empty 1%positive l.

(* Translating formulas and witnesses from Q to Z for the realDomainType case *)

Definition omap2 {aT1 aT2 rT} (f : aT1 -> aT2 -> rT) o1 o2 :=
  obind (fun a1 => omap (f a1) o2) o1.

Fixpoint PExpr_Q2Z (e : PExpr Q) : option (PExpr Z) := match e with
  | PEc (Qmake z 1) => Some (PEc z) | PEc _ => None
  | PEX n => Some (PEX n)
  | PEadd e1 e2 => omap2 PEadd (PExpr_Q2Z e1) (PExpr_Q2Z e2)
  | PEsub e1 e2 => omap2 PEsub (PExpr_Q2Z e1) (PExpr_Q2Z e2)
  | PEmul e1 e2 => omap2 PEmul (PExpr_Q2Z e1) (PExpr_Q2Z e2)
  | PEopp e1 => omap PEopp (PExpr_Q2Z e1)
  | PEpow e1 n => omap (PEpow ^~ n) (PExpr_Q2Z e1) end.

Definition Formula_Q2Z (ff : Formula Q) : option (Formula Z) :=
  omap2
    (fun l r => Build_Formula l (Fop ff) r)
    (PExpr_Q2Z (Flhs ff)) (PExpr_Q2Z (Frhs ff)).

Fixpoint BFormula_Q2Z [k] (ff : BFormula (Formula Q) k) :
    option (BFormula (Formula Z) k) := match ff with
  | TT k => Some (TT k)
  | FF k => Some (FF k)
  | X k P => Some (X k P)
  | A k a aa => omap (A k ^~ aa) (Formula_Q2Z a)
  | AND _ f1 f2 => omap2 (fun f => AND f) (BFormula_Q2Z f1) (BFormula_Q2Z f2)
  | OR _ f1 f2 => omap2 (fun f => OR f) (BFormula_Q2Z f1) (BFormula_Q2Z f2)
  | NOT _ f1 => omap (fun f => NOT f) (BFormula_Q2Z f1)
  | IMPL _ f1 o f2 =>
      omap2 (fun f => IMPL f o) (BFormula_Q2Z f1) (BFormula_Q2Z f2)
  | IFF _ f1 f2 => omap2 (fun f => IFF f) (BFormula_Q2Z f1) (BFormula_Q2Z f2)
  | EQ f1 f2 => omap2 EQ (BFormula_Q2Z f1) (BFormula_Q2Z f2) end.

Fixpoint Pol_Q2Z (p : Pol Q) : Pol Z * positive := match p with
  | Pc (Qmake n d) => (Pc n, d)
  | Pinj j p => let (p, n) := Pol_Q2Z p in (Pinj j p, n)
  | PX p1 i p2 =>
      let (p1, n1) := Pol_Q2Z p1 in
      let (p2, n2) := Pol_Q2Z p2 in
      let mulc c p := PmulC Z0 (Zpos 1) Z.mul Z.eqb p (Zpos c) in
      (PX (mulc n2 p1) i (mulc n1 p2), Pos.mul n1 n2)
  end.

Fixpoint Psatz_Q2Z (l : seq positive) (p : Psatz Q) : Psatz Z * positive :=
  match p with
  | PsatzC (Qmake n d) => (PsatzC n, d)
  | PsatzLet p1 p2 =>
      let (p1, n1) := Psatz_Q2Z l p1 in
      let (p2, n2) := Psatz_Q2Z (n1 :: l) p2 in
      (PsatzLet p1 p2, n2)
  | PsatzIn n => (PsatzIn _ n, nth 1%positive l n)
  | PsatzSquare p => let (p, n) := Pol_Q2Z p in (PsatzSquare p, Pos.mul n n)
  | PsatzMulC p1 p2 =>
      let (p1, n1) := Pol_Q2Z p1 in
      let (p2, n2) := Psatz_Q2Z l p2 in
      (PsatzMulC p1 p2, Pos.mul n1 n2)
  | PsatzMulE p1 p2 =>
      let (p1, n1) := Psatz_Q2Z l p1 in
      let (p2, n2) := Psatz_Q2Z l p2 in
      (PsatzMulE p1 p2, Pos.mul n1 n2)
  | PsatzAdd p1 p2 =>
      let (p1, n1) := Psatz_Q2Z l p1 in
      let (p2, n2) := Psatz_Q2Z l p2 in
      let mulc c p := PsatzMulE (PsatzC (Zpos c)) p in
      (PsatzAdd (mulc n2 p1) (mulc n1 p2), Pos.mul n1 n2)
  | PsatzZ => (PsatzZ _, 1%positive)
  end.

Definition seq_Psatz_Q2Z : seq (Psatz Q) -> seq (Psatz Z) :=
  map (fun p => fst (Psatz_Q2Z [::] p)).

(* Main tactics, called from the elpi parser (c.f., lra.elpi) *)

Ltac lra_witness n f := let w := fresh "__wit" in wlra_Q w f.
Ltac nra_witness n f := let w := fresh "__wit" in wnra_Q w f.
Ltac psatz_witness n f :=
  let w := fresh "__wit" in wsos_Q w f || wpsatz_Q n w f.

Ltac tacF F hyps rff ff varmap wit :=
  let irff := fresh "__rff" in
  let iff := fresh "__ff" in
  let ivarmap := fresh "__varmap" in
  pose (irff := rff);
  pose (iff := ff);
  pose (ivarmap := varmap);
  refine (hyps (@FTautoChecker_sound F irff iff wit
                  (VarMap.find 0 (vm_of_list ivarmap))
                  (fun _ _ _ _ _ _ _ _ _ _ => erefl) _));
  [ vm_compute; reflexivity ].

Ltac tacR R hyps rff ff varmap wit :=
  let irff := fresh "__rff" in
  let iff := fresh "__ff" in
  let ivarmap := fresh "__varmap" in
  lazymatch eval vm_compute in (BFormula_Q2Z ff) with
  | Some ?f =>
      pose (irff := rff);
      pose (iff := f);
      pose (ivarmap := varmap);
      refine (hyps (@RTautoChecker_sound R irff iff (seq_Psatz_Q2Z wit)
                      (VarMap.find 0 (vm_of_list ivarmap))
                      (fun _ _ _ _ _ _ _ _ _ _ => erefl) _));
      [ vm_compute; reflexivity ]
  | _ => fail  (* should never happen, the parser only parses int constants *)
  end.

End Internals.

Strategy expand [addn_expand nat_of_pos_rec_expand nat_of_pos_expand].
Strategy expand [nat_of_N_expand int_of_Z_expand Z_of_N_expand].
Strategy expand [nat_of_large_nat N_of_large_nat Z_of_large_nat].
Strategy expand [int_of_large_int Z_of_large_int].

Strategy expand [Reval_expr Rnorm_expr Fnorm_expr].
Strategy expand [Reval_pop2 Reval_bop2 Reval_op2].
Strategy expand [Reval_formula Rnorm_formula Fnorm_formula].
Strategy expand [Reval_PFormula Feval_PFormula].

Elpi Tactic lra.
Elpi Accumulate File common lra.
Elpi Typecheck.

Tactic Notation "lra" := elpi lra "lra_witness" "tacF" "tacR" 0.
Tactic Notation "nra" := elpi lra "nra_witness" "tacF" "tacR" 0.
Tactic Notation "psatz" integer(n) :=
  elpi lra "psatz_witness" "tacF" "tacR" ltac_int:(n).
Tactic Notation "psatz" := elpi lra "psatz_witness" "tacF" "tacR" (-1).


(** * The unification algorithm
      This file contains the defintions of constraints for
      the termination proof, the type specification of the unfication
      algorithm, the algorithm itself, several lemmas and proofs and
      some functions/interfaces so it's easy to use the unification. *)

Set Implicit Arguments.

Require Import Arith.Arith_base List Omega.
Require Import Wellfounded.Lexicographic_Product.
Require Import Relation_Operators.
Require Import LibTactics.
Require Import Coq.Setoids.Setoid.
Require Import Program.
Require Import HoareMonad.
Require Import SimpleTypes.
Require Import Subst.
Require Import NewTypeVariable.
Require Import MyLtacs.
Require Import Varctxt.
Require Import Occurs.
Require Import WellFormed.

(** The size of a type. This is used in by the termination argument of
    the unification algorithm.  *)

Fixpoint size (t : ty) : nat :=
  match t with
  | arrow l r => 1 + size l + size r
  | _ => 1
  end.

(** * The Constraint definition *)

(** We define a constraint as a dependent product of
    a variable context and two types.
    This is needed for a simple termination argument
    for the unification algorithm. **)

Definition constraints := sigT (fun _ : varctxt => (ty * ty)%type).

Definition get_ctxt(c : constraints) : varctxt := let (v,_) := c in v.
Definition get_tys(c : constraints) : (ty * ty)%type := let (_,l) := c in l.
Definition mk_constraints(C : varctxt) (t1 t2 : ty) : constraints := existT _ C (t1, t2).

Definition wf_constraints (c : constraints) :=
  wf_tys (get_ctxt c) (fst (get_tys c)) (snd (get_tys c)).

Definition size_t (t : (ty * ty)) : nat :=
  match t with
  | (t1, t2) => size t1 + size t2
  end.

(** ** Constraint ordering *)

(** A strict order on constraints. Here we use the library definition of lexicographic orderings. *)
Definition constraints_lt : constraints -> constraints -> Prop :=
  lexprod varctxt (fun _ => (ty * ty)%type)
          (fun (x y : varctxt) => length x < length y)
          (fun (x : varctxt) (t t' : (ty * ty)%type) => size_t t < size_t t').

(** A proof that the order is well-founded *)
Definition well_founded_constraints_lt : well_founded constraints_lt :=
  @wf_lexprod varctxt (fun _ : varctxt => (ty * ty)%type)
              (fun (x y : varctxt) => length x < length y)
              (fun (x : varctxt) (l l' : (ty * ty)%type) => size_t l < size_t l')
              (well_founded_ltof varctxt (@length id))
              (fun _ => well_founded_ltof (ty * ty)%type size_t).

(** ** More lemmas about constraints *)
Lemma constraints_mk_inversion : forall t1 t2 C l, get_tys l = (t1, t2) -> get_ctxt l = C ->
                                              l = mk_constraints C (fst (get_tys l)) (snd (get_tys l)).
Proof.
  intros.
  induction l. mysimp.
  destruct p.
  simpl in *.
  unfold mk_constraints.
  subst.
  reflexivity.
Defined.

Hint Resolve constraints_mk_inversion:core.
Hint Rewrite constraints_mk_inversion:RE.

Hint Resolve left_lex:core.
Hint Resolve right_lex:core.

Lemma arrow_lt_constraints1: forall C l1 l2 r1 r2,
    constraints_lt (mk_constraints C l1 l2) (mk_constraints C (arrow l1 r1) (arrow l2 r2)).
Proof.
  intros.
  apply right_lex ; auto.
  simpl. omega.
Qed.

Hint Resolve arrow_lt_constraints1:core.

Lemma arrow_lt_constraints2: forall C l1 l2 r1 r2,
    constraints_lt (mk_constraints C r1 r2) (mk_constraints C (arrow l1 r1) (arrow l2 r2)).
Proof.
  intros ; apply right_lex ; auto.
  simpl.
  omega.
Defined.

Hint Resolve arrow_lt_constraints2:core.

(** * Specification of the Unification Algorithm *)

(** ** Definition of unifier *)
Definition unifier (t1 t2 : ty) (s : substitution) : Prop := apply_subst s t1 = apply_subst s t2.

(** A lemma about unifiers and variable substitutions. *)
Lemma unifier_arrowend : forall v t t1 t2 s,
    unifier (apply_subst ((v, t) :: nil) t1) (apply_subst ((v, t) :: nil) t2) s ->
    unifier t1 t2 (compose_subst ((v,t)::nil) s).
Proof.
  intros.
  unfold unifier in *.
  repeat rewrite apply_compose_equiv.
  assumption.
Qed.

Lemma unify_ty : forall t v t' s,
    apply_subst s (var v) = apply_subst s t' ->
    apply_subst s t = apply_subst s (apply_subst ((v, t')::nil) t).
Proof.
  induction t ; intros ; mysimp.
  fequals*.
Qed.

Hint Resolve unify_ty:core.

Hint Resolve unifier_arrowend:core.

(** ** The type of the unification algorithm *)

(**
The type of unification algorithm specifies that from well-formed constraints
we can either:

1 - Produce a well-formed substitution s such that it unifies the constraints and s is the
    least of such unifiers.

2 - It returns a proof that no such unifier exists.
    UnifyFailure is defined in HoareMonad file.
 *)

Definition unify_type (c : constraints) :=
  wf_constraints c -> sum
  ({ s | unifier (fst (get_tys c)) (snd (get_tys c)) s /\ wf_subst (get_ctxt c) s /\
         (forall st, (new_tv_ty (fst (get_tys c)) st /\ new_tv_ty (snd (get_tys c)) st) -> new_tv_subst s st) /\
         forall s', unifier (fst (get_tys c)) (snd (get_tys c)) s' ->
               exists s'', forall v, apply_subst s' (var v) = apply_subst (compose_subst s s'') (var v)})
    (UnifyFailure (fst (get_tys c)) (snd (get_tys c))) .

Unset Implicit Arguments.

(** * The unification algorithm itself *)

(** ** Main definition of the unification function *)

(** The unification algorithm is defined by a combinator that performs well-founded recursion
   over a well-founded relation. The constraints_lt is a well founded relation over constraints,
   so, we can use the library combinator for well-founded recursion in order to compute the
   unifier over such constraints. *)

Program Fixpoint unify' (l : constraints) {wf constraints_lt l} : unify_type l :=
  fun wfl => match get_tys l with
          | (var i, t) => match occurs_dec i t with
                         | left _ => inr _ _
                         | right _ => if (eq_ty_dec (var i) t)
                                     then inl _ (@exist substitution _ nil _)
                                     else inl _ (@exist substitution _ ((i, t)::nil) _)
                         end
          | (t, var i) => match occurs_dec i t with
                         | left _ =>  inr _ _
                         | right _ => if (eq_ty_dec (var i) t)
                                     then inl _ (@exist substitution _ nil _)
                                     else inl _ (@exist substitution _ ((i, t)::nil) _)
                         end
          | (con i, con j) => if eq_id_dec i j
                             then inl _ (@exist substitution _ nil _)
                             else inr _ _
          | (arrow l1 r1, arrow l2 r2) => match unify' (mk_constraints (get_ctxt l) l1 l2) _ with
                                         | inr _ E => inr _ _
                                         | inl _ (exist _ s1 HS) =>
                                           match unify' (mk_constraints (minus (get_ctxt l) (dom s1))
                                                                        (apply_subst s1 r1) (apply_subst s1 r2)) _ with
                                           | inr _ E => inr _ _
                                           | inl _ (exist _ s2 HS') =>
                                             inl _ (@exist substitution _ (compose_subst s1 s2) _)
                                           end
                                         end
          | (arrow _ _, con _) => inr _ _
          | (con  _, arrow _ _) => inr _ _
          end.
Next Obligation.
  eauto.
Defined.
Next Obligation.
  splits; crush.
Defined.
Next Obligation.
  unfold wf_constraints in wfl.
  rewrite <- Heq_anonymous0 in wfl.
  simpl in wfl.
  destruct wfl.
  unfold unifier.
  splits; crush.
  exists s'.
  intros.
  crush.
  Unshelve.
  assumption.
Defined.
Next Obligation.
  crush.
Defined.
Next Obligation.
  unfold wf_constraints in wfl.
  rewrite <- Heq_anonymous0 in wfl.
  simpl in wfl.
  destruct wfl.
  unfold unifier.
  splits;
    crush.
Defined.
Next Obligation.
  unfold wf_constraints in wfl.
  rewrite <- Heq_anonymous0 in wfl.
  simpl in wfl.
  destruct wfl.
  unfold unifier.
  splits;
    crush.
  exists s'.
  crush.
  Unshelve. assumption.
Defined.
Next Obligation.
  splits; crush.
  exists s'.
  crush.
Defined.
Next Obligation.
  eauto.
Defined.
Next Obligation.
  unfold wf_constraints in wfl.
  rewrite <- Heq_anonymous in wfl.
  simpl in wfl.
  destruct wfl.
  erewrite constraints_mk_inversion with (C := get_ctxt l); eauto.
  repeat rewrite <- Heq_anonymous.
  crush.
Defined.
Next Obligation.
  unfold wf_constraints in *.
  rewrite <- Heq_anonymous in *.
  destruct wfl.
  crush.
Defined.
Next Obligation.
  eauto.
Defined.
Next Obligation.
  clear e Heq_anonymous unify'.
  clear n.
  erewrite constraints_mk_inversion with (C := get_ctxt l); eauto.
  destruct wfl.
  repeat rewrite <- Heq_anonymous0 in *.
  induction s1; simpl in *.
  apply right_lex ; eauto.
  repeat rewrite apply_subst_nil.
  simpl. omega.
  apply left_lex ; eauto.
  destruct a; crush.
  apply member_len_minus_lt. eauto.
Defined.
Next Obligation.
  simpl.
  clear Heq_anonymous.
  unfold wf_constraints in *.
  repeat rewrite <- Heq_anonymous0 in wfl.
  simpl in wfl.
  destruct wfl.
  crush.
Defined.
Next Obligation.
  eauto.
Defined.
Next Obligation.
  clear Heq_anonymous Heq_anonymous0 Heq_anonymous1.
  unfold unifier in *.
  splits; crush.
  - inversion H. inversion H0. subst.
    eapply new_tv_compose_subst; eauto. eapply n; eauto.
    splits; eauto.
  - intros.
    inversion H.
    eapply e0 in u0 as Hl1.
    eapply e0 in H1 as Hl2.
    destruct Hl1 as [ss1 Hl1].
    destruct Hl2 as [ss1' Hl2].
    rewrite apply_subst_fold2 in *.
    eapply ext_subst_var_ty in Hl2 as Hl2'.
    eapply ext_subst_var_ty in Hl2 as Hl2''.
    rewrite Hl2' in H2.
    rewrite Hl2'' in H2.
    repeat rewrite apply_compose_equiv in H2.
    eapply e in H2.
    destruct H2 as [ss2 H2].
    rewrite apply_subst_fold2 in *.
    sort.
    exists ss2.
    rewrite apply_subst_fold2 in *.
    intros.
    rewrite Hl2.
    rewrite apply_compose_assoc_var.
    rewrite apply_compose_equiv.
    rewrite apply_compose_equiv.
    eapply ext_subst_var_ty in H2 as H2'.
    rewrite <- H2'.
    reflexivity.
Defined.
Next Obligation.
  eauto.
Defined.
Next Obligation.
  eauto.
Defined.
Next Obligation.
  apply well_founded_constraints_lt.
Defined.

(** * Auxiliary functions so we can use the unification algorithm *)

(** This function gives a list of ids from a type with a proof of wf_ty *)
Definition ids_ty_dep : forall (tau : ty), {l : list id | wf_ty l tau}.
  refine (fix ids_ty_dep (tau : ty) : {t : list id | wf_ty t tau} :=
            match tau with
            | var i => exist _ (i::nil) _
            | arrow l r => match ids_ty_dep l with
                          | exist _ g' a => match ids_ty_dep r with
                                           | exist _ g'' b => exist _ (g'++g'') _
                                           end
                          end
            | _ => exist _ nil _
            end).
  crush.
  crush.
  simpl.
  splits; eauto.
  apply wf_ty_app_comm.
  apply wf_ty_app;
    auto.
Qed.

(** An extension from the above function, but for two types *)
Definition ids_ty_dep2 : forall (tau tau' : ty), {l : list id | wf_ty l tau /\ wf_ty l tau'}.
  refine (fix ids_ty_dep2 (tau tau' : ty) : {t : list id | wf_ty t tau /\ wf_ty t tau'} :=
            match tau,tau' with
            | var i, var j => exist _ (i::j::nil) _
            | arrow l r, arrow l' r' =>
              match ids_ty_dep2 l l' with
              | exist _ g' a => match ids_ty_dep2 r r' with
                               | exist _ g'' b => exist _ (g'++g'') _
                               end
              end
            | arrow l r, (var i) => match ids_ty_dep l with
                                   | exist _ g' a => match ids_ty_dep r with
                                                    | exist _ g'' b => exist _ (i::g'++g'') _
                                                    end
                                   end
            | arrow l r, (con i) => match ids_ty_dep l with
                                   | exist _ g' a => match ids_ty_dep r with
                                                    | exist _ g'' b => exist _ (g'++g'') _
                                                    end
                                   end
            | (var i), arrow l r => match ids_ty_dep l with
                                   | exist _ g' a => match ids_ty_dep r with
                                                    | exist _ g'' b => exist _ (i::g'++g'') _
                                                    end
                                   end
            | (con i), arrow l r => match ids_ty_dep l with
                                   | exist _ g' a => match ids_ty_dep r with
                                                    | exist _ g'' b => exist _ (g'++g'') _
                                                    end
                                   end
            | var i, _ => exist _ (i::nil) _
            | _, var j => exist _ (j::nil) _
            | _,_ => exist _ nil _
            end);
    mysimp;
    try apply wf_ty_cons;
    try (apply wf_ty_app; auto; fail);
    try (apply wf_ty_app_comm; apply wf_ty_app; auto).
Qed.

(** An interface so unify can work by only providing the two types to be unified *)
Definition unify'' : forall t1 t2 : ty,
    {x & sum ({ s | unifier t1 t2 s /\ wf_subst x s /\
                (forall st, (new_tv_ty t1 st /\ new_tv_ty t2 st) -> new_tv_subst s st) /\
                forall s', unifier t1 t2 s' ->
                           exists s'', forall v, apply_subst s' (var v) = apply_subst (compose_subst s s'') (var v)})
         (UnifyFailure t1 t2)} .
Proof.
  intros.
  pose proof ids_ty_dep2 as dep.
  specialize dep with (tau:=t1) (tau':=t2).
  destruct dep, a.
  exists x.
  refine (unify' (mk_constraints x t1 t2) _).
  unfold wf_constraints.
  simpl.
  split; auto.
Qed.

(** An interface to the Infer monad  *)
Program Definition unify (tau1 tau2 : ty) :
  @Infer (@top id) substitution (fun i mu f =>
                                   i = f /\
                                   (forall s', apply_subst s' tau1 = apply_subst s' tau2 ->
                                          exists s'', forall tau, apply_subst s' tau = apply_subst (compose_subst mu s'') tau) /\
                                   ((new_tv_ty tau1 i /\ new_tv_ty tau2 i) -> new_tv_subst mu i) /\
                                   apply_subst mu tau1 = apply_subst mu tau2) :=
  match unify'' tau1 tau2 as y  with
  | existT _ c (inl _ (exist _ mu HS)) => ret mu
  | existT _ c (inr _ error) => failT (@UnifyFailure' tau1 tau2 error) substitution
  end.
Next Obligation.
  splits; intros; eauto.
  edestruct e; eauto.
  exists x0.
  eapply ext_subst_var_ty.
  intros.
  simpl.
  eauto.
Defined.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This file provides a constructive form of definite description; it
    allows building functions from the proof of their existence in any
    context; this is weaker than Church's iota operator *)

Require Import ChoiceFacts.

Set Implicit Arguments.

Axiom constructive_definite_description :
  forall (A : Type) (P : A->Prop),
    (exists! x, P x) -> { x : A | P x }.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.arrival_sequence rt.model.priority.
Require Import rt.model.schedule.uni.schedule.
Require Import rt.model.schedule.uni.susp.platform.
Require Import rt.model.schedule.uni.transformation.construction.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype bigop seq path.

Module ConcreteScheduler.

  Import Job ArrivalSequence UniprocessorSchedule PlatformWithSuspensions Priority
         ScheduleConstruction.

  (* In this section, we implement a priority-based uniprocessor scheduler *)
  Section Implementation.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.

    (* Let arr_seq be any consistent job arrival sequence...*)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.

    (* ...that is subject to job suspensions. *)
    Variable next_suspension: job_suspension Job.

    (* Also, assume that a JLDP policy is given. *)
    Variable higher_eq_priority: JLDP_policy Job.

    (* Next, we show how to recursively construct the schedule. *)
    Section ScheduleConstruction.

      (* For any time t, suppose that we have generated the schedule prefix in the
         interval [0, t). Then, we must define what should be scheduled at time t. *)
      Variable sched_prefix: schedule Job.
      Variable t: time.

      (* For simplicity, let's use some local names. *)
      Let is_pending := pending job_arrival job_cost sched_prefix.
      Let is_suspended :=
        suspended_at job_arrival job_cost next_suspension sched_prefix.

      (* Consider the list of pending, non-suspended jobs at time t. *)
      Definition pending_jobs :=
        [seq j <- jobs_arrived_up_to arr_seq t | is_pending j t && ~~ is_suspended j t].

      (* To make the scheduling decision, we just pick one of the highest-priority jobs
         that are pending (if it exists). *)
      Definition highest_priority_job :=
        seq_min (higher_eq_priority t) pending_jobs.

    End ScheduleConstruction.

    (* Starting from the empty schedule, the final schedule is obtained by iteratively
       picking the highest-priority job. *)
    Let empty_schedule : schedule Job := fun t => None.
    Definition scheduler :=
      build_schedule_from_prefixes highest_priority_job empty_schedule.

    (* Then, by showing that the construction function depends only on the prefix, ... *)
    Lemma scheduler_depends_only_on_prefix:
      forall sched1 sched2 t,
        (forall t0, t0 < t -> sched1 t0 = sched2 t0) ->
        highest_priority_job sched1 t = highest_priority_job sched2 t.
    Proof.
      intros sched1 sched2 t ALL.
      rewrite /highest_priority_job.
      suff SAME: pending_jobs sched1 t = pending_jobs sched2 t by rewrite SAME.
      apply eq_in_filter.
      rewrite /jobs_arrived_up_to; intros j IN.
      apply in_arrivals_implies_arrived_before with (job_arrival0 := job_arrival) in IN;
        last by done.
      rewrite /arrived_before ltnS in IN.
      rewrite /pending /has_arrived IN 2!andTb.
      have COMP: completed_by job_cost sched1 j t =
                 completed_by job_cost sched2 j t.
      {
        rewrite /completed_by.
        rewrite /completed_by; f_equal.
        apply eq_big_nat; move => i /= LTi.
        by rewrite /service_at /scheduled_at ALL.
      }
      rewrite COMP; do 2 f_equal.
      rewrite /suspended_at; f_equal; first by rewrite COMP.
      have EX: [exists t0: 'I_t, scheduled_at sched1 j t0] =
               [exists t0: 'I_t, scheduled_at sched2 j t0].
      {
        apply/idP/idP.
        {
          move => /existsP [t0 SCHED].
          by apply/existsP; exists t0; rewrite /scheduled_at -ALL.
        }
        {
          move => /existsP [t0 SCHED].
          by apply/existsP; exists t0; rewrite /scheduled_at ALL.
        }
      }
      have BEG: time_after_last_execution job_arrival sched1 j t =
                time_after_last_execution job_arrival sched2 j t.
      {
        rewrite /time_after_last_execution EX.
        case: ifP => _; last by done.
        f_equal; apply eq_bigl.
        by intros t0; rewrite /scheduled_at ALL.
      }
      have SUSP: suspension_duration job_arrival next_suspension sched1 j t =
                 suspension_duration job_arrival next_suspension sched2 j t.
      {
        rewrite /suspension_duration BEG; f_equal.
        rewrite /service /service_during big_nat_cond [in RHS]big_nat_cond.
        apply congr_big; try (by done).
        move => i /= /andP [LTi _].
        rewrite /service_at /scheduled_at ALL //.
        apply: (leq_trans LTi).
        by apply last_execution_bounded_by_identity.
      }
      by rewrite BEG SUSP.
    Qed.

    (* ...we infer that the generated schedule is indeed based on the construction function. *)
    Corollary scheduler_uses_construction_function:
      forall t, scheduler t = highest_priority_job scheduler t.
    Proof.
      by ins; apply prefix_dependent_schedule_construction,
                    scheduler_depends_only_on_prefix.
    Qed.

  End Implementation.

  (* In this section, we prove the properties of the scheduler that are used
     as hypotheses in the analyses. *)
  Section Proofs.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.

    (* Assume any job arrival sequence with consistent, non-duplicate arrivals... *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_no_duplicate_arrivals: arrival_sequence_is_a_set arr_seq.

    (* ...that is subject to suspension times. *)
    Variable next_suspension: job_suspension Job.

    (* Consider any JLDP policy that is reflexive, transitive and total. *)
    Variable higher_eq_priority: JLDP_policy Job.
    Hypothesis H_priority_is_transitive: JLDP_is_transitive higher_eq_priority.
    Hypothesis H_priority_is_total: JLDP_is_total arr_seq higher_eq_priority.

    (* Let sched denote our concrete scheduler implementation. *)
    Let sched := scheduler job_arrival job_cost arr_seq next_suspension higher_eq_priority.

    (* To conclude, we prove the important properties of the scheduler implementation. *)

    (* First, we show that scheduled jobs come from the arrival sequence. *)
      Lemma scheduler_jobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched arr_seq.
      Proof.
        move => j t /eqP SCHED.
        rewrite /sched scheduler_uses_construction_function // /highest_priority_job in SCHED.
        apply seq_min_in_seq in SCHED.
        rewrite mem_filter in SCHED.
        move: SCHED => /andP [_ ARR].
        by eapply in_arrivals_implies_arrived, ARR.
      Qed.

    (* Next, we show that jobs do not execute before they arrive...*)
    Theorem scheduler_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched.
    Proof.
      move => j t /eqP SCHED.
      rewrite /sched scheduler_uses_construction_function // /highest_priority_job in SCHED.
      apply seq_min_in_seq in SCHED.
      rewrite mem_filter in SCHED.
      by move: SCHED => /andP [/andP [/andP [ARR _] _] _].
    Qed.

    (* ... nor after completion. *)
    Theorem scheduler_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.
    Proof.
      intros j t.
      induction t;
        first by rewrite /service /service_during big_geq //.
      rewrite /service /service_during big_nat_recr //=.
      rewrite leq_eqVlt in IHt; move: IHt => /orP [/eqP EQ | LT]; last first.
      {
        apply: leq_trans LT; rewrite -addn1.
          by apply leq_add; last by apply leq_b1.
      }
      rewrite -[job_cost _]addn0; apply leq_add; first by rewrite -EQ.
      rewrite leqn0 eqb0 /scheduled_at.
      rewrite /sched scheduler_uses_construction_function //.
      rewrite /highest_priority_job.
      apply/eqP; intro HP.
      apply seq_min_in_seq in HP.
      by rewrite mem_filter /pending /completed_by -EQ eq_refl andbF 2!andFb in HP.
    Qed.

    (* In addition, the scheduler is work conserving, ... *)
    Theorem scheduler_work_conserving:
      work_conserving job_arrival job_cost next_suspension arr_seq sched.
    Proof.
      intros j t IN BACK.
      move: BACK => /andP [/andP [/andP [ARR NOTCOMP] NOTSCHED] NOTSUSP].
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in NOTSCHED.
      rewrite /scheduled_at /sched scheduler_uses_construction_function //.
      case HP: (highest_priority_job _ _ _ _ _ ) => [j_hp|]; first by exists j_hp.
      set hp := highest_priority_job _ _ _ _ _ _ _ in NOTSCHED HP.
      suff BUG: hp != None by rewrite HP in BUG.
      apply seq_min_exists with (x := j).
      rewrite mem_filter /pending NOTSUSP ARR NOTCOMP /=.
      by eapply arrived_between_implies_in_arrivals, ARR.
    Qed.

    (* ... respects the JLDP policy..., *)
    Theorem scheduler_respects_policy :
      respects_JLDP_policy job_arrival job_cost next_suspension arr_seq sched higher_eq_priority.
    Proof.
      rename H_priority_is_transitive into TRANS, H_priority_is_total into TOTAL.
      move => j1 j2 t ARR1 BACK /eqP SCHED.
      move: BACK => /andP [/andP [/andP [ARR NOTCOMP] NOTSCHED] NOTSUSP].
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in NOTSCHED.
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in SCHED.
      rewrite /highest_priority_job in SCHED NOTSCHED.
      set jobs := pending_jobs _ _ _ _ _ _ in SCHED NOTSCHED.
      have IN: j1 \in jobs.
      {
        rewrite mem_filter /pending ARR NOTCOMP NOTSUSP /=.
        by eapply arrived_between_implies_in_arrivals, ARR.
      }
      apply seq_min_computes_min with (y := j1) in SCHED; try (by done).
      by intros x y; rewrite 2!mem_filter; move => /andP [_ INx] /andP [_ INy];
         apply TOTAL; eapply in_arrivals_implies_arrived; eauto 2.
    Qed.

    (* ... and respects self-suspensions. *)
    Theorem scheduler_respects_self_suspensions:
      respects_self_suspensions job_arrival job_cost next_suspension sched.
    Proof.
      move => j t /eqP SCHED.
      rewrite /scheduled_at /sched scheduler_uses_construction_function // in SCHED.
      rewrite /highest_priority_job in SCHED; apply seq_min_in_seq in SCHED.
      rewrite mem_filter in SCHED.
      by move: SCHED => /andP [/andP [_ NOTSUSP] _]; apply/negP.
    Qed.

  End Proofs.

End ConcreteScheduler.


Require Export RelationClasses Morphisms.
From discprob.basic Require Import base.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype seq.
From Coquelicot Require Import Hierarchy.

Require Import Reals.
Instance Rge_Transitive: Transitive Rge.
Proof. intros ???. eapply Rge_trans. Qed.
Instance Rle_Transitive: Transitive Rle.
Proof. intros ???. eapply Rle_trans. Qed.
Instance Rle_Reflexive: Reflexive Rle.
Proof. intros ?. eapply Rle_refl. Qed.
Instance Rgt_Transitive: Transitive Rgt.
Proof. intros ???. eapply Rgt_trans. Qed.
Instance Rlt_Transitive: Transitive Rlt.
Proof. intros ???. eapply Rlt_trans. Qed.

Instance ge_Transitive: Transitive ge.
Proof. intros ???. auto with *. Qed.
Instance le_Transitive: Transitive le.
Proof. intros ???. auto with *. Qed.
Instance le_Reflexive: Reflexive le.
Proof. intros ?. auto with *. Qed.
Instance gt_Transitive: Transitive gt.
Proof. intros ???. auto with *. Qed.
Instance lt_Transitive: Transitive lt.
Proof. intros ???. auto with *. Qed.

(* To be compatible with ssreflect in various ways it's nice to make R
   into an eqType *)

Definition R_eqP : Equality.axiom (fun x y: R => Req_EM_T x y).
Proof. move => x y. apply sumboolP. Qed.

Canonical R_eqMixin := EqMixin R_eqP.
Canonical R_eqType := Eval hnf in EqType R R_eqMixin.

Require Import Psatz.
Instance Rlt_plus_proper: Proper (Rlt ==> Rlt ==> Rlt) Rplus.
Proof.
  intros ?? Hle ?? Hle'. apply Rplus_lt_compat; auto.
Qed.
Instance Rlt_plus_proper': Proper (Rlt ==> eq ==> Rlt) Rplus.
Proof.
  intros ?? Hle ?? Hle'. subst. nra.
Qed.
Instance Rlt_plus_proper'': Proper (Rlt ==> Rle ==> Rlt) Rplus.
Proof.
  intros ?? Hle ?? Hle'. subst. nra.
Qed.

Instance Rle_plus_proper_left: Proper (Rle ==> eq ==> Rle) Rplus.
Proof. intros ?? Hle ?? Hle'. nra. Qed.
Instance Rle_plus_proper_right: Proper (eq ==> Rle ==> Rle) Rplus.
Proof. intros ?? Hle ?? Hle'. nra. Qed.
Instance Rle_plus_proper: Proper (Rle ==> Rle ==> Rle) Rplus.
Proof. intros ?? Hle ?? Hle'. nra. Qed.

Lemma Rmax_INR a b: Rmax (INR a) (INR b) = INR (max a b).
Proof.
  apply Rmax_case_strong; intros ?%INR_le; f_equal;
    [ rewrite Max.max_l // | rewrite Max.max_r //].
Qed.