Require Import Coq.ZArith.BinInt.
Require Import Coq.ZArith.Zcomplements.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.Znat.

Require Import compcert.lib.Integers.
Require Import compcert.common.Values.
Require Import compcert.exportclight.Clightdefs.

Require Import VST.veric.expr.
Require Import VST.veric.mpred.
Require Import VST.floyd.forward.
Require Import VST.floyd.sublist.
Require Import VST.floyd.field_at.
Require Import VST.floyd.coqlib3.
Require Import VST.msl.iter_sepcon.
Require Import VST.msl.seplog.

Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.graph.MathAdjMatGraph.

Section Spatial_AdjMat_Model_3.
  (* Model 3 is for a stack-allocated graph,
     where the graph is declared on the stack
     as a two-dimension array: graph[size][size].
   *)

  Context {size : Z}.
  Context {CompSpecs : compspecs}.
  Context {V_EqDec : EquivDec.EqDec V eq}.
  Context {E_EqDec: EquivDec.EqDec E eq}.

  (* SPATIAL REPRESENTATION *)

  (* Assumption:
     (v,0), (v,1) ... (v, size-1) are edges.

     Action:
      Makes a list containing each edge's elabel.
      The argument f is an opportunity to tweak the edges as needed
   *)
  Definition vert_to_list (g: AdjMatLG) (f : E -> E) (v : V) :=
    map (elabel g)
        (map (fun x => f (v,x))
             (nat_inc_list (Z.to_nat size))).

  (* Assumptions:
     1. 0, 1, ... (size-1) are vertices
     2. for any vertex v,
          (v,0), (v,1) ... (v, size-1) are edges.

     Action:
      Makes a list of lists, where each member list
      is a vertex's edge-label-list (see helper above).
   *)
  Definition graph_to_mat (g: AdjMatLG) (f : E -> E) : list (list Z) :=
    map (vert_to_list g f)
        (nat_inc_list (Z.to_nat size)).

  Lemma graph_to_mat_Zlength:
    forall g (f : E -> E),
      0 <= size ->
      Zlength (graph_to_mat g f) = size.
  Proof.
    intros. unfold graph_to_mat.
    rewrite Zlength_map, nat_inc_list_Zlength, Z2Nat.id; trivial.
  Qed.

  Lemma elabel_Znth_graph_to_mat:
    forall (g: AdjMatLG) (f: E -> E) src dst,
      0 <= size ->
      0 <= src < size ->
      0 <= dst < size ->
      elabel g (f (src, dst)) =
      Znth dst (Znth src (graph_to_mat g f)).
  Proof.
    intros.
    unfold graph_to_mat.
    rewrite Znth_map, nat_inc_list_i.
    unfold vert_to_list. rewrite Znth_map.
    rewrite Znth_map. rewrite nat_inc_list_i.
    reflexivity.
    3: rewrite Zlength_map.
    2, 3, 5: rewrite nat_inc_list_Zlength.
    all: rewrite Z2Nat.id; trivial.
  Qed.

  Definition graph_to_list (g: AdjMatLG) (f : E -> E) : list Z :=
    (concat (graph_to_mat g f)).

  Definition list_address a index : val :=
    offset_val (index * sizeof (tarray tint size)) a.

  Definition list_rep sh l contents_mat index :=
    let mylist := (Znth index contents_mat) in
    data_at sh (tarray tint size)
            (map Vint (map Int.repr mylist))
            (list_address l index).

    Definition SpaceAdjMatGraph' sh g_contents gaddr : mpred :=
    iter_sepcon (list_rep sh gaddr g_contents)
                (nat_inc_list (Z.to_nat size)).

    Definition SpaceAdjMatGraph sh (f : E -> E) g gaddr : mpred :=
      SpaceAdjMatGraph' sh (graph_to_mat g f) gaddr.

  Lemma SpaceAdjMatGraph_unfold': forall sh g_contents ptr
                                        (addresses0 : list val) i,
      0 <= i < size ->
      Zlength g_contents = size ->
      SpaceAdjMatGraph' sh g_contents ptr =
      sepcon (iter_sepcon (list_rep sh ptr g_contents)
                          (sublist 0 i (nat_inc_list (Z.to_nat size))))
             (sepcon
                (list_rep sh ptr g_contents i)
                (iter_sepcon (list_rep sh ptr g_contents)
                             (sublist (i + 1) (Zlength g_contents) (nat_inc_list (Z.to_nat size))))).
  Proof.
    intros. unfold SpaceAdjMatGraph'.
    replace (nat_inc_list (Z.to_nat size)) with
        (sublist 0 size (nat_inc_list (Z.to_nat size))) at 1.
    2: rewrite sublist_same; trivial; rewrite nat_inc_list_Zlength; lia.
    rewrite (sublist_split 0 i size),
    (sublist_split i (i+1) size), (sublist_one i); try lia.
    2, 3, 4: rewrite nat_inc_list_Zlength; rewrite Z2Nat.id; lia.
    rewrite nat_inc_list_i.
    2: rewrite Z2Nat_id', Z.max_r; lia.
    repeat rewrite iter_sepcon_app.
    simpl. rewrite sepcon_emp. rewrite H0.
    reflexivity.
  Qed.

  Lemma SpaceAdjMatGraph_unfold: forall sh (f : E -> E) g ptr
                                        (addresses0 : list val) i,
      let contents := (graph_to_mat g f) in
      0 <= i < size ->
      SpaceAdjMatGraph sh f g ptr =
      sepcon (iter_sepcon (list_rep sh ptr contents)
                          (sublist 0 i (nat_inc_list (Z.to_nat size))))
             (sepcon
                (list_rep sh ptr contents i)
                (iter_sepcon (list_rep sh ptr contents)
                             (sublist (i + 1) (Zlength contents) (nat_inc_list (Z.to_nat size))))).
  Proof.
    intros. unfold SpaceAdjMatGraph.
    apply SpaceAdjMatGraph_unfold'; trivial.
    subst contents. rewrite graph_to_mat_Zlength; trivial. lia.
  Qed.

End Spatial_AdjMat_Model_3.


Set Implicit Arguments.
Require Import Morphisms Lia.
From Undecidability.HOU Require Import std.std.
From Undecidability.HOU.calculus Require Import
  prelim terms syntax semantics confluence typing order.
Import ArsInstances.
(* * Weak Normalisation *)

Section SemanticTyping.

  Variable (X: Const).

  Definition SemType := exp X -> Prop.

  (* ** Logical Relations *)
  Definition active (s: exp X) :=
    match s with lambda s => True | _ => False end.

  Definition C (T: SemType) (s: exp X) :=
    exists t, s ▷ t /\ (active t -> T t).

  Fixpoint V (A: type) (s: exp X) :=
    match A with
    | typevar beta => False
    | A → B => match s with
              | lambda s => normal s /\
                      forall t delta, C (V A) t -> C (V B) ((ren delta (lambda s)) t)
              | _ => False
              end
    end.

  Definition E A := C (V A).
  Definition G Gamma gamma := forall i A, nth Gamma i = Some A -> E A (gamma i).

  Lemma E_evaluates s A:
    E A s -> exists t, s ▷ t.
  Proof. intros (t & H1 & H2); exists t; intuition. Qed.

  Lemma closure_under_expansion s t A:
    s >* t -> E A s -> E A t.
  Proof.
    intros H [v [[H1 H2] H3]]. exists v. intuition. split; eauto.
    eapply confluence_normal_left; eauto.
  Qed.

  Lemma closure_under_reduction s t A:
    s >* t -> E A t -> E A s.
  Proof.
    intros H [v [[H1 H2] H3]]. exists v; intuition. split; eauto.
  Qed.

  Definition ren_closed (S: SemType) :=
    forall delta s, S s -> S (ren delta s).

  Lemma ren_closed_C S: ren_closed S -> ren_closed (C S).
  Proof.
    intros H delta s; unfold C in *; intros (t & [H1 H2] & H3).
    exists (ren delta t); split.
    split; eauto using ren_steps, normal_ren.
    intros H4. eapply H, H3. destruct t; cbn in *; intuition.
  Qed.

  Lemma ren_closed_V A: ren_closed (V A).
  Proof.
    induction A as [beta | A IHA B IHB].
    - intros ? ? [].
    - intros delta []; cbn in *; eauto; intros [H1 H2].
      split; eauto using normal_ren.
      intros t delta' H'. asimpl.
      replace (_ • e) with (ren (upRen_exp_exp (delta >> delta')) e)by now asimpl.
      now eapply H2.
  Qed.

  Lemma ren_closed_E A: ren_closed (E A).
  Proof.
    eapply ren_closed_C, ren_closed_V.
  Qed.

  Lemma ren_closed_G Gamma gamma delta: G Gamma gamma -> G Gamma (gamma >> ren delta).
  Proof.
    intros H x A E. eapply ren_closed_E, H, E.
  Qed.

  Lemma E_var x A: E A (var x).
  Proof.
    exists (var x). unfold evaluates; cbn; intuition.
  Qed.

  Lemma G_id Gamma: G Gamma var.
  Proof.
    intros ???. eapply E_var.
  Qed.

  Lemma G_cons Gamma A s gamma:
    G Gamma gamma -> E A s -> G (A :: Gamma) (s .: gamma).
  Proof.
    intros. intros [|] B H'; cbn in *.
    now injection H' as ->. now eapply H.
  Qed.

  Lemma G_up Gamma A gamma:
    G Gamma gamma -> G (A :: Gamma) (up gamma).
  Proof.
    eauto using G_cons, ren_closed_G, E_var.
  Qed.

  Lemma compat_var Gamma i A gamma:
    nth Gamma i = Some A -> G Gamma gamma -> E A (gamma i).
  Proof. intuition. Qed.

  Lemma compat_const c:
    E (ctype X c) (const c).
  Proof.
    exists (const c); split; [split|]; cbn; intuition.
  Qed.

  Lemma compat_lambda A B s:
    E B s -> (forall t delta, E A t -> E B (ren delta (lambda s) t)) ->  E (A → B) (lambda s).
  Proof.
    intros [t [[H1 H2] _]] ?; cbn; exists (lambda t); intuition; split; rewrite ?H1; eauto.
    intros; eapply closure_under_expansion; [|eauto]; now rewrite H1.
  Qed.

  Lemma compat_app A B s t:
    E (A → B) s -> E A t -> E B (s t).
  Proof.
    intros (v1 & [H1 H2] & H3). intros (v2 & [H4 H5] & H6).
    eapply closure_under_reduction. rewrite H1, H4; eauto.
    destruct v1.
    1, 2, 4: eexists; split; [split|]; eauto; cbn; intuition.
    cbn in H3; mp H3; cbn; intuition.
    specialize (H0 v2 id); asimpl in H0; unfold id in H0.
    eapply H0; exists v2; split; [split|]; eauto.
  Qed.

End SemanticTyping.

(* ** Semantic Soundness *)
Section Soundness.

  Context {X: Const}.

  Implicit Type (s: exp X).

  Definition semtyping Gamma s A := forall gamma, G Gamma gamma -> E A (gamma • s).

  Notation "Gamma ⊨ s : A" := (semtyping Gamma s A) (at level 80, s at level 99).

  Lemma semantic_soundness Gamma s A:
    Gamma ⊢ s : A -> Gamma ⊨ s : A.
  Proof.
    induction 1.
    - intros ??; cbn; eapply compat_var; eauto.
    - intros ??; cbn; eapply compat_const.
    - intros ??; cbn; eapply compat_lambda; eauto using G_up.
      intros; eapply closure_under_reduction. cbn; dostep; now asimpl.
      eapply IHtyping, G_cons; eauto.
      replace (gamma >> _) with (gamma >> ren delta) by now asimpl.
      eapply ren_closed_G; eauto.
    - intros ??; cbn; eapply compat_app; eauto.
  Qed.

  (* ** Termination *)
  Lemma termination_steps Gamma s A:
    Gamma ⊢ s : A -> exists t, s ▷ t.
  Proof.
    intros H % semantic_soundness.
    specialize (H var (@G_id X Gamma)).
    asimpl in H; unfold id in H.
    eapply E_evaluates, H.
  Qed.

  Lemma ordertyping_termination_steps Gamma n s A:
    Gamma ⊢(n) s : A -> exists t, s ▷ t.
  Proof.
    now intros ? % ordertyping_soundness % termination_steps.
  Qed.

End Soundness.


(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Type of Matrix Element
  author    : ZhengPu Shi
  date      : 2021.12

  remark    :
  1. This is an inteface of different matrix implementation.
  2. Element type is orgainized to several levels
     (1) ElementType
         EqElementType, Aeq is eq.
     (2) DecidableElementType, based on ElementType.
     (3) RingElementType, based on ElementType.
     (4) FieldElementType, based on RingEementType.
     (5) DecidableFieldElementType, based on FieldElementType, and
         satisfy Decidable relation.
*)

Require NatExt ZExt QExt QcExt RExt RAST Complex.
Require Export HierarchySetoid.

(* ######################################################################### *)
(** * Base type *)

(** ** Type of base type *)
Module Type BaseType.
  Parameter A : Type.
End BaseType.

(** ** Instances *)

Module BaseTypeNat <: BaseType.
  Export NatExt.
  Definition A := nat.
End BaseTypeNat.

Module BaseTypeZ <: BaseType.
  Export ZExt.
  Definition A := Z.
End BaseTypeZ.

Module BaseTypeQ <: BaseType.
  Export QExt.
  Definition A := Q.
End BaseTypeQ.

Module BaseTypeQc <: BaseType.
  Export QcExt.
  Definition A := Qc.
End BaseTypeQc.

Module BaseTypeR <: BaseType.
  Export RExt.
  Definition A := R.
End BaseTypeR.

Module BaseTypeA <: BaseType.
  Export RAST.
  Definition A := A.
End BaseTypeA.

Module BaseTypeC <: BaseType.
  Export Complex.
  Definition A := C.
End BaseTypeC.

Module BaseTypeFun (A B : BaseType) <: BaseType.
  (* Import Reals. *)
  Definition A := A.A -> B.A.
End BaseTypeFun.

(* ######################################################################### *)
(** * Element with setoid equality *)

(** ** Type of element *)
Module Type ElementType <: BaseType.
  Parameter A : Type.
  Parameter Aeq : relation A.
  Parameter A0 : A.

  Global Infix "==" := Aeq : A_scope.

  Axiom Equiv_Aeq : Equivalence Aeq.
  Global Existing Instance Equiv_Aeq.
End ElementType.

(** Type of element which specify the Aeq is eq, used in lots of cases *)
Module Type EqElementType (B : BaseType)
<: ElementType
   with Definition A := B.A
   with Definition Aeq := @eq B.A.
  Definition A := B.A.
  Definition Aeq := @eq B.A.
  Parameter A0 : A.
  Parameter Equiv_Aeq : Equivalence Aeq.
End EqElementType.

(* Note, these code only works in Coq-8.16, but failed at Coq-8.13,8.14,
   I'm not sure why? *)
(* Module Type EqElementType (B : BaseType) *)
(* <: BaseType *)
(*   := ElementType *)
(*      with Definition A := B.A *)
(*      with Definition Aeq := @eq B.A. *)

(** ** Instances *)
Module ElementTypeNat <: EqElementType BaseTypeNat.
  Export BaseTypeNat.

  Definition A : Type := nat.
  Definition Aeq : relation A := eq.
  Definition A0 : A := 0.

  Infix "==" := Aeq : A_scope.

  Lemma Equiv_Aeq : Equivalence Aeq.
  Proof.
    apply eq_equivalence.
  Qed.
End ElementTypeNat.

Module ElementTypeZ <: EqElementType BaseTypeZ.
  Export BaseTypeZ.

  Definition A : Type := Z.
  Definition Aeq : relation A := eq.
  Definition A0 : A := 0.

  Infix "==" := Aeq : A_scope.

  Lemma Equiv_Aeq : Equivalence Aeq.
  Proof.
    apply eq_equivalence.
  Qed.
End ElementTypeZ.

(** Tips, this module cannot be a EqElementType *)
Module ElementTypeQ <: ElementType.
  Export BaseTypeQ.

  Definition A : Type := Q.
  Definition Aeq : relation A := Qeq.
  Definition A0 : A := 0.

  Infix "==" := Aeq : A_scope.

  Lemma Equiv_Aeq : Equivalence Aeq.
  Proof.
    apply Q_Setoid.
  Qed.
End ElementTypeQ.

Module ElementTypeQc <: EqElementType BaseTypeQc.
  Export BaseTypeQc.

  Definition A : Type := Qc.
  Definition Aeq : relation A := eq.
  Definition A0 : A := 0.

  Infix "==" := Aeq : A_scope.

  Lemma Equiv_Aeq : Equivalence Aeq.
  Proof.
    apply eq_equivalence.
  Qed.
End ElementTypeQc.

Module ElementTypeR <: EqElementType BaseTypeR.
  Export BaseTypeR.

  Definition A : Type := R.
  Definition Aeq : relation A := eq.
  Definition A0 : A := 0%R.

  Infix "==" := Aeq : A_scope.

  Lemma Equiv_Aeq : Equivalence Aeq.
  Proof.
    apply eq_equivalence.
  Qed.
End ElementTypeR.

Module ElementTypeA <: EqElementType BaseTypeA.
  Export BaseTypeA.

  Definition A : Type := A.
  Definition Aeq : relation A := eq.
  Definition A0 : A := A0.

  Infix "==" := Aeq : A_scope.

  Lemma Equiv_Aeq : Equivalence Aeq.
  Proof.
    apply eq_equivalence.
  Qed.
End ElementTypeA.

Module ElementTypeC <: EqElementType BaseTypeC.
  Export BaseTypeC.

  Definition A : Type := C.
  Definition Aeq : relation A := eq.
  Definition A0 : A := 0.

  Infix "==" := Aeq : A_scope.

  Lemma Equiv_Aeq : Equivalence Aeq.
  Proof.
    apply eq_equivalence.
  Qed.
End ElementTypeC.

Module ElementTypeFun (I O : ElementType) <: ElementType.
  Definition A : Type := {f : I.A -> O.A | Proper (I.Aeq ==> O.Aeq) f}.
  Definition Aeq : relation A :=
    fun (f g : A) => forall (a : I.A),
        O.Aeq (proj1_sig f a) (proj1_sig g a).
  Infix "=I=" := I.Aeq (at level 20).
  Infix "=O=" := O.Aeq (at level 20).
  Infix "==" := Aeq : A_scope.

  Definition A0 : A.
    refine (exist _ (fun _ => O.A0) _).
    unfold Proper, respectful. intros. destruct (O.Equiv_Aeq). reflexivity.
  Defined.
  Lemma Equiv_Aeq : Equivalence Aeq.
  Proof.
    destruct (I.Equiv_Aeq), (O.Equiv_Aeq).
    constructor; cbv; intros; try easy.
    destruct x.
    specialize (H a). specialize (H0 a).
    rewrite H0 in H. auto.
  Qed.
End ElementTypeFun.

Module ElementType_Test.

  Import ElementTypeNat ElementTypeR.
  Module Import ElementTypeFunEx1 := ElementTypeFun ElementTypeNat ElementTypeR.

  Definition f : A.
    refine (exist _ (fun i => match i with 0%nat => 1 | 1%nat => 2 | _ => 1 end) _).
    unfold Proper, respectful. intros. rewrite H. reflexivity.
  Defined.
  Definition g : A.
    refine (exist _ (fun i => match i with 1%nat => 2 | _ => 1 end) _ ).
    unfold Proper, respectful. intros. rewrite H. reflexivity.
  Defined.

  Goal f == g.
  Proof.
    cbv. intros. auto.
  Qed.
End ElementType_Test.

(* ######################################################################### *)
(** * Element with decidable relation *)

(** ** Type of element with decidable relation *)
Module Type DecidableElementType <: ElementType.
  Include ElementType.

  Axiom Dec_Aeq : Decidable Aeq.
End DecidableElementType.

Module Type EqDecidableElementType (B : BaseType)
<: EqElementType B
  := DecidableElementType
     with Definition A := B.A
     with Definition Aeq := @eq B.A.

(** ** Instances *)
Module DecidableElementTypeNat
<: DecidableElementType.
  Include ElementTypeNat.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    constructor. apply Nat.eq_dec.
  Qed.
End DecidableElementTypeNat.

Module DecidableElementTypeZ
<: DecidableElementType.
  Include ElementTypeZ.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    constructor. apply Z.eq_dec.
  Qed.
End DecidableElementTypeZ.

Module DecidableElementTypeQ
<: DecidableElementType.
  Include ElementTypeQ.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    constructor. apply Qeq_dec.
  Qed.
End DecidableElementTypeQ.

Module DecidableElementTypeQc
<: DecidableElementType.
  Include ElementTypeQc.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    constructor. apply Qc_eq_dec.
  Qed.
End DecidableElementTypeQc.

Module DecidableElementTypeR
<: DecidableElementType.
  Include ElementTypeR.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    constructor. apply Req_EM_T.
  Qed.
End DecidableElementTypeR.

Module DecidableElementTypeA
<: DecidableElementType.
  Include ElementTypeA.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    constructor. apply Aeqdec.
  Qed.
End DecidableElementTypeA.

Module DecidableElementTypeC
<: DecidableElementType.
  Include ElementTypeC.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof. apply Decidable_Ceq. Qed.
End DecidableElementTypeC.

Module DecidableElementTypeFun (I O : DecidableElementType)
<: DecidableElementType.
  Include (ElementTypeFun I O).

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    constructor.
    intros. destruct a as [a Ha], b as [b Hb].
  Admitted.

End DecidableElementTypeFun.

(* ######################################################################### *)
(** * Element with ring structure *)

(** ** Type of Element with ring structure *)
Module Type RingElementType <: ElementType.
  Include ElementType.
  Open Scope A_scope.

  Parameter A1 : A.
  Parameter Aadd Amul : A -> A -> A.
  Parameter Aopp : A -> A.

  Notation Asub := (fun x y => Aadd x (Aopp y)).
  Global Infix "+" := Aadd : A_scope.
  Global Infix "*" := Amul : A_scope.
  Global Notation "- a" := (Aopp a) : A_scope.
  Global Infix "-" := Asub : A_scope.

  (** Use these lemmas, we can replace "Add Morphism ..." with "Existing Morphism" *)
  Axiom Aadd_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Aadd).
  Axiom Aopp_aeq_mor : Proper (Aeq ==> Aeq) (Aopp).
  Axiom Amul_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Amul).

  Global Existing Instance Aadd_aeq_mor.
  Global Existing Instance Aopp_aeq_mor.
  Global Existing Instance Amul_aeq_mor.

  Axiom Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.

  (** A Group structure can be derived from the context *)
  Axiom AGroup_inst : AGroup Aadd A0 Aopp Aeq.
  Global Existing Instance AGroup_inst.

  (** A Ring structure can be derived from the context *)
  Axiom Ring_inst : Ring Aadd A0 Aopp Amul A1 Aeq.
  Global Existing Instance Ring_inst.

End RingElementType.

Module Type EqRingElementType (B : BaseType)
<: EqElementType B
  := RingElementType
     with Definition A := B.A
     with Definition Aeq := @eq B.A.

(** ** Instances *)

Module RingElementTypeZ
<: RingElementType.
  Include ElementTypeZ.

  Definition A1 : A := 1.
  Definition Aadd := Zplus.
  Definition Aopp := Z.opp.
  Definition Amul := Zmult.

  Notation Asub := (fun x y => Aadd x (Aopp y)).
  Global Infix "+" := Aadd : A_scope.
  Global Infix "*" := Amul : A_scope.
  Global Notation "- a" := (Aopp a) : A_scope.
  Global Infix "-" := Asub : A_scope.

  Lemma Aadd_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Aadd).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Aopp_aeq_mor : Proper (Aeq ==> Aeq) (Aopp).
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma Amul_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Amul).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.
  Proof.
    constructor; intros;
      unfold A,Aeq,Aadd,Aopp,Amul,A0,A1;
      unfold ElementTypeQ.Aeq,ElementTypeQ.A0,ElementTypeQ.A;
      auto with zarith.
  Qed.

  Add Ring Ring_thy_inst : Ring_thy.

  Lemma AGroup_inst : AGroup Aadd A0 Aopp Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor; try apply Equiv_Aeq;
    unfold Aadd,Aeq,Aopp,A0,A; ring.
  Qed.

  Lemma Ring_inst : Ring Aadd A0 Aopp Amul A1 Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor, Amul_aeq_mor; try apply Equiv_Aeq;
      unfold Aadd,Aeq,Aopp,Amul,A0,A1,A; ring.
  Qed.

End RingElementTypeZ.

Module RingElementTypeQ
<: RingElementType.
  Include ElementTypeQ.

  Definition A1 : A := 1.
  Definition Aadd := Qplus.
  Definition Aopp := Qopp.
  Definition Amul := Qmult.

  Notation Asub := (fun x y => Aadd x (Aopp y)).
  Global Infix "+" := Aadd : A_scope.
  Global Infix "*" := Amul : A_scope.
  Global Notation "- a" := (Aopp a) : A_scope.
  Global Infix "-" := Asub : A_scope.

  Lemma Aadd_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Aadd).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Aopp_aeq_mor : Proper (Aeq ==> Aeq) (Aopp).
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma Amul_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Amul).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.
  Proof.
    constructor; intros;
      unfold A,Aeq,Aadd,Aopp,Amul,A0,A1;
      unfold ElementTypeQ.Aeq,ElementTypeQ.A0,ElementTypeQ.A;
      try ring.
  Qed.

  Add Ring Ring_thy_inst : Ring_thy.

  Lemma AGroup_inst : AGroup Aadd A0 Aopp Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor; try apply Equiv_Aeq;
    unfold Aadd,Aeq,Aopp,A0,A; ring.
  Qed.

  Lemma Ring_inst : Ring Aadd A0 Aopp Amul A1 Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor, Amul_aeq_mor; try apply Equiv_Aeq;
      unfold Aadd,Aeq,Aopp,Amul,A0,A1,A; ring.
  Qed.

End RingElementTypeQ.

Module RingElementTypeQc
<: RingElementType.
  Include ElementTypeQc.

  Definition A1 : A := 1.
  Definition Aadd := Qcplus.
  Definition Aopp := Qcopp.
  Definition Amul := Qcmult.

  Notation Asub := (fun x y => Aadd x (Aopp y)).
  Global Infix "+" := Aadd : A_scope.
  Global Infix "*" := Amul : A_scope.
  Global Notation "- a" := (Aopp a) : A_scope.
  Global Infix "-" := Asub : A_scope.

  Lemma Aadd_aeq_mor : Proper (Aeq  ==> Aeq ==> Aeq) (Aadd).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Aopp_aeq_mor : Proper (Aeq ==> Aeq) (Aopp).
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma Amul_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Amul).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.
  Proof.
    constructor; intros;
      unfold A,Aeq,Aadd,Aopp,Amul,A0,A1;
      unfold ElementTypeQc.Aeq,ElementTypeQc.A0,ElementTypeQc.A;
      try ring.
  Qed.

  Add Ring Ring_thy_inst : Ring_thy.

  Lemma AGroup_inst : AGroup Aadd A0 Aopp Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor; try apply Equiv_Aeq;
      unfold Aadd,Aeq,Aopp,A0,A; ring.
  Qed.

  Lemma Ring_inst : Ring Aadd A0 Aopp Amul A1 Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor, Amul_aeq_mor; try apply Equiv_Aeq;
      unfold Aadd,Aeq,Aopp,Amul,A0,A1,A; ring.
  Qed.

End RingElementTypeQc.

Module RingElementTypeR
<: RingElementType.
  Include ElementTypeR.

  Definition A1 : A := 1.
  Definition Aadd := Rplus.
  Definition Aopp := Ropp.
  Definition Amul := Rmult.

  Notation Asub := (fun x y => Aadd x (Aopp y)).
  Global Infix "+" := Aadd : A_scope.
  Global Infix "*" := Amul : A_scope.
  Global Notation "- a" := (Aopp a) : A_scope.
  Global Infix "-" := Asub : A_scope.

  Lemma Aadd_aeq_mor : Proper (Aeq  ==> Aeq ==> Aeq) (Aadd).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Aopp_aeq_mor : Proper (Aeq ==> Aeq) (Aopp).
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma Amul_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Amul).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.
  Proof.
    constructor; intros;
      unfold A,Aeq,Aadd,Aopp,Amul,A0,A1;
      unfold ElementTypeR.Aeq,ElementTypeR.A0,ElementTypeR.A;
      try ring.
  Qed.

  Add Ring Ring_thy_inst : Ring_thy.

  Lemma AGroup_inst : AGroup Aadd A0 Aopp Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor; try apply Equiv_Aeq;
      unfold Aadd,Aeq,Aopp,A0,A; ring.
  Qed.

  Lemma Ring_inst : Ring Aadd A0 Aopp Amul A1 Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor, Amul_aeq_mor; try apply Equiv_Aeq;
      unfold Aadd,Aeq,Aopp,Amul,A0,A1,A; ring.
  Qed.

End RingElementTypeR.

Module RingElementTypeA
<: RingElementType.
  Include ElementTypeA.

  Definition A1 : A := A1.

  (** Note that, this explicit annotation is must,
      otherwise, the ring has no effect. (because RAST.A and A are different) *)
  Definition Aadd : A -> A -> A := fun a b => Aadd a b.
  Definition Aopp : A -> A := fun a => Aopp a.
  Definition Amul : A -> A -> A := fun a b => Amul a b.

  Notation Asub := (fun x y => Aadd x (Aopp y)).
  Global Infix "+" := Aadd : A_scope.
  Global Infix "*" := Amul : A_scope.
  Global Notation "- a" := (Aopp a) : A_scope.
  Global Infix "-" := Asub : A_scope.

  Lemma Aadd_aeq_mor : Proper (Aeq  ==> Aeq ==> Aeq) (Aadd).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Aopp_aeq_mor : Proper (Aeq ==> Aeq) (Aopp).
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma Amul_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Amul).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.

  Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.
  Proof.
    apply A_ring.
  Qed.

  Add Ring Ring_thy_inst : Ring_thy.

  Lemma AGroup_inst : AGroup Aadd A0 Aopp Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor; try apply Equiv_Aeq; ring.
  Qed.

  Lemma Ring_inst : Ring Aadd A0 Aopp Amul A1 Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor, Amul_aeq_mor; try apply Equiv_Aeq; ring.
  Qed.

End RingElementTypeA.

Module RingElementTypeC
<: RingElementType.
  Include ElementTypeC.

  Definition A1 : A := 1.
  (** Note that, this explicit annotation is must,
      otherwise, the ring has no effect. (because C and A are different) *)
  (* Definition Aadd := Cadd. *)
  (* Definition Aopp := Copp. *)
  (* Definition Amul := Cmul. *)
  Definition Aadd : A -> A -> A := fun a b => Cadd a b.
  Definition Aopp : A -> A := fun a => Copp a.
  Definition Amul : A -> A -> A := fun a b => Cmul a b.

  Notation Asub := (fun x y => Aadd x (Aopp y)).
  Global Infix "+" := Aadd : A_scope.
  Global Infix "*" := Amul : A_scope.
  Global Notation "- a" := (Aopp a) : A_scope.
  Global Infix "-" := Asub : A_scope.

  Lemma Aadd_aeq_mor : Proper (Aeq  ==> Aeq ==> Aeq) (Aadd).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.
  (* Global Existing Instance Aadd_aeq_mor. *)

  Lemma Aopp_aeq_mor : Proper (Aeq ==> Aeq) (Aopp).
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.
  (* Global Existing Instance Aopp_aeq_mor. *)

  Lemma Amul_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) (Amul).
  Proof.
    unfold Proper, respectful. intros. rewrite H,H0. easy.
  Qed.
  (* Global Existing Instance Amul_aeq_mor. *)

  Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.
  Proof.
    constructor; intros;
      unfold A,Aeq,Aadd,Aopp,Amul,A0,A1;
      unfold ElementTypeC.Aeq,ElementTypeC.A0,ElementTypeC.A; ring.
  Qed.

  Add Ring Ring_thy_inst : Ring_thy.

  Lemma AGroup_inst : AGroup Aadd A0 Aopp Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor; try apply Equiv_Aeq; ring.
  Qed.

  Lemma Ring_inst : Ring Aadd A0 Aopp Amul A1 Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor, Amul_aeq_mor; try apply Equiv_Aeq; ring.
  Qed.

End RingElementTypeC.

Module RingElementTypeFun (I O : RingElementType) <: RingElementType.
  Include (ElementTypeFun I O).

  Definition A1 : A.
    refine (exist _ (fun _ => O.A1) _).
    unfold Proper, respectful. intros. destruct (O.Equiv_Aeq). reflexivity.
  Defined.

  Definition Aadd : A -> A -> A.
    cbv. intros [f Pf] [g Pg].
    refine (exist _ (fun x : I.A => O.Aadd (f x) (g x)) _).
    intros.
    pose proof (O.Aadd_aeq_mor). apply H0. apply Pf; easy. apply Pg; easy.
  Defined.

  Definition Aopp : A -> A.
    cbv. intros [f Pf].
    refine (exist _ (fun x : I.A => O.Aopp (f x)) _).
    intros.
    pose proof (O.Aopp_aeq_mor). apply H0. apply Pf; easy.
  Defined.

  Definition Amul : A -> A -> A.
    cbv. intros [f Pf] [g Pg].
    refine (exist _ (fun x : I.A => O.Amul (f x) (g x)) _).
    intros.
    pose proof (O.Amul_aeq_mor). apply H0. apply Pf; easy. apply Pg; easy.
  Defined.

  Notation Asub := (fun x y => Aadd x (Aopp y)).

  Lemma Aadd_aeq_mor : Proper (Aeq  ==> Aeq ==> Aeq) (Aadd).
  Proof.
    unfold Proper, respectful.
    intros [x Px] [y Py] H1 [x0 Px0] [y0 Py0] H2.
    cbv in *. intros. apply O.Aadd_aeq_mor; auto.
  Qed.

  Lemma Aopp_aeq_mor : Proper (Aeq ==> Aeq) (Aopp).
  Proof.
    unfold Proper, respectful. intros [x Px] [y Py] H1.
    cbv in *. intros. apply O.Aopp_aeq_mor; auto.
  Qed.

  Lemma Amul_aeq_mor : Proper (Aeq  ==> Aeq ==> Aeq) (Amul).
  Proof.
    unfold Proper, respectful. intros [x Px] [y Py] H1 [x0 Px0] [y0 Py0] H2.
    cbv in *. intros. apply O.Amul_aeq_mor; auto.
  Qed.

  Lemma Ring_thy : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.
  Proof.
    destruct (O.Ring_thy).
    constructor; intros; cbv; intros;
      repeat match goal with | x:A |- _ => destruct x end; auto.
  Qed.

  Lemma AGroup_inst : AGroup Aadd A0 Aopp Aeq.
  Proof.
    Add Ring Ring_thy_inst_o : O.Ring_thy.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor; try apply Equiv_Aeq;
      unfold Aadd,Aeq,Aopp,A0,A;
      repeat match goal with a : ?A |- _ => destruct a end; intros; simpl; ring.
  Qed.

  Lemma Ring_inst : Ring Aadd A0 Aopp Amul A1 Aeq.
  Proof.
    repeat constructor; intros;
      auto using Aadd_aeq_mor, Aopp_aeq_mor, Amul_aeq_mor; try apply Equiv_Aeq;
      unfold Aadd,Aeq,Aopp,Amul,A0,A1,A;
      repeat match goal with a : ?A |- _ => destruct a end; intros; simpl; ring.
  Qed.

End RingElementTypeFun.

Module RingElementTypeTest.
  Import FunctionalExtensionality.
  Import RingElementTypeQ.
  Import RingElementTypeR.

  Module Import RingElementTypeFunEx1 :=
    RingElementTypeFun RingElementTypeQ RingElementTypeR.
  Definition f : A.
    refine (exist _ (fun i:Q => Q2R i + R1) _).
    unfold Proper, respectful. intros. rewrite H. easy.
  Defined.

  Definition g : A.
    refine (exist _ (fun i:Q => Q2R (i+1)) _).
    unfold Proper, respectful. intros. rewrite H. easy.
  Defined.

  Goal (f == g)%A.
  Proof.
    unfold f,g,Aeq. hnf. cbn. intros. rewrite Qreals.Q2R_plus.
    hnf. f_equal. cbv. auto with real.
  Qed.

End RingElementTypeTest.

(* ######################################################################### *)
(** * Element with field structure *)

(** ** Type of Element with field structure *)

Module Type FieldElementType <: RingElementType.
  Include RingElementType.
  Open Scope A_scope.

  Parameter Ainv : A -> A.

  Notation Adiv := (fun x y => Amul x (Ainv y)).
  Notation "/ a" := (Ainv a) : A_scope.
  Infix "/" := Adiv : A_scope.

  Axiom Ainv_aeq_mor : Proper (Aeq ==> Aeq) Ainv.
  Global Existing Instance Ainv_aeq_mor.

  (** 1 <> 0. *)
  Axiom A1_neq_A0 : ~(A1 == A0)%A.

  Axiom Field_thy: field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv Aeq.
  (* Add Field Field_thy_inst : Field_thy. *)

  (** A Field structure can be derived from the context *)

  Axiom Field_inst : Field Aadd A0 Aopp Amul A1 Ainv Aeq.
  Global Existing Instance Field_inst.

End FieldElementType.

(** ** Instances *)

Module FieldElementTypeQ <: FieldElementType.
  Include RingElementTypeQ.

  Definition Ainv := Qinv.

  Notation Adiv := (fun x y => Amul x (Ainv y)).

  Lemma Ainv_aeq_mor : Proper (Aeq ==> Aeq) Ainv.
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma A1_neq_A0 : ~(A1 == A0)%A.
  Proof.
    intro. cbv in *. inv H.
  Qed.

  Lemma Field_thy: field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv Aeq.
  Proof.
    constructor; intros; try easy.
    apply Ring_thy.
    unfold Amul,Ainv,A1,Aeq. unfold ElementTypeQ.Aeq. field. auto.
  Qed.

  Add Field Field_thy_inst : Field_thy.

  Lemma Field_inst : Field Aadd A0 Aopp Amul A1 Ainv Aeq.
  Proof.
    constructor. apply Ring_inst.
    intros. unfold Amul,Ainv,Aeq,A1,A. field. auto.
    apply A1_neq_A0.
    apply Ainv_aeq_mor.
  Qed.

End FieldElementTypeQ.

Module FieldElementTypeQc
<: FieldElementType.
  Include RingElementTypeQc.

  Definition Ainv := Qcinv.

  Notation Adiv := (fun x y => Amul x (Ainv y)).

  Lemma Ainv_aeq_mor : Proper (Aeq ==> Aeq) Ainv.
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma A1_neq_A0 : ~(A1 == A0)%A.
  Proof.
    intro. cbv in *. inv H.
  Qed.

  Lemma Field_thy: field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv Aeq.
  Proof.
    constructor; intros; try easy.
    apply Ring_thy.
    unfold Amul,Ainv,A1,Aeq. unfold ElementTypeQc.Aeq,ElementTypeQc.A. field. auto.
  Qed.

  (* Bug: when publish the project to opam, CI report error in ocaml4.07.1 as follows,

Error: Illegal application:
The term "@fieldAinvProper" of type
 "forall (A : Type) (Aadd : A -> A -> A) (A0 : A) (Aopp : A -> A) (Amul : A -> A -> A)
    (A1 : A) (Ainv : A -> A) (Aeq : A -> A -> Prop),
  Field Aadd A0 Aopp Amul A1 Ainv Aeq -> Proper (Aeq ==> Aeq) Ainv"
cannot be applied to the terms
 "A" : "Type"
 "Qcplus" : "Qc -> Qc -> Qc"
 "Q2Qc 0" : "Qc"
 "Qcopp" : "Qc -> Qc"
 "Qcmult" : "Qc -> Qc -> Qc"
 "1" : "Qc"
 "Ainv" : "Qc -> Qc"
 "Aeq" : "relation A"
 "Field_Qc" : "Field Qcplus (Q2Qc 0) Qcopp Qcmult 1 Qcinv eq"
The 1st term has type "Type@{A.u0}" which should be coercible to "Type@{Field.u0}".

    But I don't know why?
    just need comment this declaration.
*)
  (* Check @fieldAinvProper Qc Qcplus (Q2Qc (Qmake Z0 xH)) *)
  (*   Qcopp Qcmult (Q2Qc (Qmake (Zpos xH) xH)) Ainv Aeq. *)

  (* Add Field Field_thy_inst : Field_thy. *)

  Lemma Field_inst : Field Aadd A0 Aopp Amul A1 Ainv Aeq.
  Proof.
    constructor. apply Ring_inst.
    intros. unfold Amul,Ainv,Aeq,A1,A. field. auto.
    apply A1_neq_A0.
    apply Ainv_aeq_mor.
  Qed.

End FieldElementTypeQc.

Module FieldElementTypeR
<: FieldElementType.
  Include RingElementTypeR.

  Definition Ainv := Rinv.

  Notation Adiv := (fun x y => Amul x (Ainv y)).

  Lemma Ainv_aeq_mor : Proper (Aeq ==> Aeq) Ainv.
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma A1_neq_A0 : ~(A1 == A0)%A.
  Proof.
    cbv in *. auto with real.
  Qed.

  Lemma Field_thy: field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv Aeq.
  Proof.
    constructor; intros; try easy.
    apply Ring_thy.
    apply A1_neq_A0.
    unfold Amul,Ainv,A1,Aeq. unfold ElementTypeR.Aeq,ElementTypeR.A. field. auto.
  Qed.

  Add Field Field_thy_inst : Field_thy.

  Lemma Field_inst : Field Aadd A0 Aopp Amul A1 Ainv Aeq.
  Proof.
    constructor. apply Ring_inst.
    intros. unfold Amul,Ainv,Aeq,A1,A. field. auto.
    apply A1_neq_A0.
    apply Ainv_aeq_mor.
  Qed.

End FieldElementTypeR.

Module FieldElementTypeA
<: FieldElementType.
  Include RingElementTypeA.

  Definition Ainv := Ainv.

  Notation Adiv := (fun (x y : A) => Amul x (Ainv y)).

  Lemma Ainv_aeq_mor : Proper (Aeq ==> Aeq) Ainv.
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma A1_neq_A0 : ~(A1 == A0)%A.
  Proof.
    cbv in *. intros. inversion H.
  Qed.

  Lemma Field_thy: field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv Aeq.
  Proof.
    constructor; intros; try easy.
    apply Ring_thy.
    cbv. field. auto.
  Qed.

  Add Field Field_thy_inst : Field_thy.

  Lemma Field_inst : Field Aadd A0 Aopp Amul A1 Ainv Aeq.
  Proof.
    constructor.
    - apply Ring_inst.
    - intros. cbv. field. auto.
    - apply A1_neq_A0.
    - apply Ainv_aeq_mor.
  Qed.

End FieldElementTypeA.

Module FieldElementTypeC
<: FieldElementType.
  Include RingElementTypeC.

  Definition Ainv := Cinv.

  Notation Adiv := (fun x y => Amul x (Ainv y)).

  Lemma Ainv_aeq_mor : Proper (Aeq ==> Aeq) Ainv.
  Proof.
    unfold Proper, respectful. intros. rewrite H. easy.
  Qed.

  Lemma A1_neq_A0 : ~(A1 == A0)%A.
  Proof.
    cbv in *. auto with complex.
  Qed.

  Lemma Field_thy: field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv Aeq.
  Proof.
    constructor; intros; auto with complex; try easy.
    apply Ring_thy. apply Cmul_inv_l. auto.
  Qed.

  (* Add Field Field_thy_inst : Field_thy. *)

  Lemma Field_inst : Field Aadd A0 Aopp Amul A1 Ainv Aeq.
  Proof.
    constructor. apply Ring_inst.
    intros. unfold Amul,Ainv,Aeq,A1,A. field. auto.
    apply A1_neq_A0.
    apply Ainv_aeq_mor.
  Qed.

End FieldElementTypeC.

(* Module FieldElementTypeFun (I O : FieldElementType) <: FieldElementType. *)
(*   Include (RingElementTypeFun I O). *)

(*   Definition Ainv : A -> A. *)
(*     cbv. intros [f Pf]. *)
(*     refine (exist _ (fun x : I.A => O.Ainv (f x)) _). *)
(*     constructor. intros. *)
(*     pose proof (O.Resp_Ainv_Aeq). apply respectUnary. apply Pf; easy. *)
(*   Defined. *)

(*   Notation Adiv := (fun x y => Amul x (Ainv y)). *)

  (* Lemma Ainv_aeq_mor : Proper (Aeq ==> Aeq) Ainv. *)
  (* Proof. *)
  (*   unfold Proper, respectful. intros [x Px] [y Py] H1. *)
  (*   cbv in *. intros. apply O.Resp_Ainv_Aeq; auto. *)
  (* Qed. *)

(*   (* Import FunctionalExtensionality. *) *)
(*   Lemma A1_neq_A0 : ~(A1 == A0)%A. *)
(*   Proof. cbv in *. intros. specialize (H I.A0). apply O.A1_neq_A0 in H. auto. Qed. *)

(*   Lemma Field_thy: field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv Aeq. *)
(*   Proof. *)
(*     destruct (I.Field_thy), (O.Field_thy). *)
(*     constructor. *)
(*     - apply Ring_thy. *)
(*     - apply A1_neq_A0. *)
(*     - intros. *)
(*       repeat match goal with | x:A |- _ => destruct x end. *)
(*       cbv in *; intros. *)
(*       pose proof (O.Amul_aeq_mor). *)
(*       pose proof (O.Equiv_Aeq). *)
(*       apply H; easy. *)
(*     - intros. *)
(*       repeat match goal with | x:A |- _ => destruct x end. *)
(*       cbv in *; intros. *)
(*       apply Finv_l0. revert a. *)
(*       (* Note that, this is not true. *)
(*          H means: ~(x a1 = 0 /\ x a2 = 0 /\ ...) *)
(*          but we need: x a1 <> 0 /\ x a2 <> 0 /\ ... *)
(*          !!this is not provable. *)
(*        *) *)
(*       admit. *)
(*   Admitted. *)

(* End FieldElementTypeFun. *)

Module FieldElementTypeTest.
  Import FunctionalExtensionality.
  Import FieldElementTypeQ.
  Import FieldElementTypeR.

  (* Include (FieldElementTypeFun FieldElementTypeQ FieldElementTypeR). *)
End FieldElementTypeTest.

(* ######################################################################### *)
(** * Element with field structure and decidable relation *)

(** ** Type of Element with field structure and decidable relation *)

Module Type DecidableFieldElementType
<: FieldElementType
<: DecidableElementType.
  Include FieldElementType.
  Open Scope A_scope.

  Axiom Dec_Aeq : Decidable Aeq.
  Global Existing Instance Dec_Aeq.
End DecidableFieldElementType.

Module Type EqDecidableFieldElementType (B : BaseType)
<: EqElementType B
<: DecidableFieldElementType
  := DecidableFieldElementType
     with Definition A := B.A
     with Definition Aeq := @eq B.A.

(** ** Instances *)

Module DecidableFieldElementTypeQ
<: DecidableFieldElementType.
  Include FieldElementTypeQ.
  Import DecidableElementTypeQ.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    apply Dec_Aeq.
  Qed.
End DecidableFieldElementTypeQ.

Module DecidableFieldElementTypeQc
<: DecidableFieldElementType.
(* <: EqDecidableFieldElementType BaseTypeQc. *) (* needn't do this *)
  Include FieldElementTypeQc.
  Import DecidableElementTypeQc.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    apply Dec_Aeq.
  Qed.
End DecidableFieldElementTypeQc.

Module DecidableFieldElementTypeR
<: DecidableFieldElementType.
  Include FieldElementTypeR.
  Import DecidableElementTypeR.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    apply Dec_Aeq.
  Qed.
End DecidableFieldElementTypeR.

Module DecidableFieldElementTypeA
<: DecidableFieldElementType.
  Include FieldElementTypeA.
  Import DecidableElementTypeA.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    apply Dec_Aeq.
  Qed.
End DecidableFieldElementTypeA.

Module DecidableFieldElementTypeC
<: DecidableFieldElementType.
  Include FieldElementTypeC.
  Import DecidableElementTypeC.

  Lemma Dec_Aeq : Decidable Aeq.
  Proof.
    apply Dec_Aeq.
  Qed.
End DecidableFieldElementTypeC.


Require Export SfLib.
Require Import Coq.Lists.ListSet.
Require Import List. Open Scope list_scope.
Require Import FunctionalExtensionality.

Inductive var_kind :=
| holevar : var_kind
| recvar : var_kind
| ordvar : var_kind.

Inductive tm :=
| tnat : nat -> tm
| tvar : id -> tm
| tabs : id -> tm -> tm
| tapp : tm -> tm -> tm
| tfix : id -> id -> tm -> tm
| trec : rec -> tm
| trec_select : rec -> id -> tm
| tlet : id -> tm -> tm -> tm

with rec :=
| rempty : rec
| rvar : id -> rec
| rextend1 : rec -> id -> id -> rec
| rextend2 : rec -> id -> tm -> rec.

Inductive value : tm -> Prop :=
| vnat : forall n, value (tnat n)
| vabs : forall i1 t, value (tabs i1 t)
| vfix : forall i1 i2 t, value (tfix i1 i2 t)
| vrec : forall t, recordval t -> value (trec t)

with recordval : rec -> Prop :=
| emptyrec : recordval rempty
| recordext : forall r i t,
    value t ->
    recordval r ->
    recordval (rextend2 r i t).

Inductive substx :=
| substx_var : id -> tm -> substx
| substx_record : id -> rec -> substx.

Inductive subst : substx -> tm -> tm -> Prop :=
| snat : forall x n, subst x (tnat n) (tnat n)
| svar : forall i t, subst (substx_var i t) (tvar i) t
| svar1 : forall a b r, subst (substx_record a r) (tvar b) (tvar b)
| svar2 : forall a b t, a <> b -> subst (substx_var a t) (tvar b) (tvar b)
| sabs : forall x i t b b',
    x <> i ->
    subst (substx_var x t) b b' ->
    subst (substx_var x t) (tabs i b) (tabs i b')
| sabs' : forall x i r b b',
    subst (substx_record x r) b b' ->
    subst (substx_record x r) (tabs i b) (tabs i b')
| sabs1 : forall x t b,
    subst (substx_var x t) (tabs x b) (tabs x b)
| sapp : forall x t1 t2 t1' t2',
    subst x t1 t1' ->
    subst x t2 t2' ->
    subst x (tapp t1 t2) (tapp t1' t2')
| srec : forall x r r',
    subst_rec x r r' ->
    subst x (trec r) (trec r')
| srec_select : forall x i r r',
    subst_rec x r r' ->
    subst x (trec_select r i) (trec_select r' i)
| slet : forall i x t t1 t2 t1' t2',
    i <> x ->
    subst (substx_var x t) t1 t1' ->
    subst (substx_var x t) t2 t2' ->
    subst (substx_var x t) (tlet i t1 t2) (tlet i t1' t2')
| slet' : forall x r i t1 t2 t1' t2',
    subst (substx_record x r) t1 t1' ->
    subst (substx_record x r) t2 t2' ->
    subst (substx_record x r) (tlet i t1 t2) (tlet i t1' t2')
| slet1 : forall i t t1 t2 t1',
    subst (substx_var i t) t1 t1' ->
    subst (substx_var i t) (tlet i t1 t2) (tlet i t1' t2)

with subst_rec : substx -> rec -> rec -> Prop :=
| srec_empty : forall x, subst_rec x rempty rempty
| srec_var : forall i r,
    subst_rec (substx_record i r) (rvar i) r
| srec_var' : forall a b t,
    subst_rec (substx_var a t) (rvar b) (rvar b)
| srec_var'' : forall a b r,
    a <> b ->
    subst_rec (substx_record a r) (rvar b) (rvar b)
| srec_extend : forall r i t x t',
    subst x t t' ->
    subst_rec x (rextend2 r i t) (rextend2 r i t').

Inductive access : rec -> id -> tm -> Prop :=
| access1 : forall r i t i' t',
    access r i t ->
    access (rextend2 r i' t') i t
| access2 : forall r i t,
    access (rextend2 r i t) i t.

Inductive step : tm -> tm -> Prop :=
|  step_app1 : forall t1 t2 t1',
    step t1 t1' ->
    step (tapp t1 t2) (tapp t1' t2)
| step_app2 : forall t1 t2 t2',
    value t1 ->
    step t2 t2' ->
    step (tapp t1 t2) (tapp t1 t2')
| step_appabs : forall i x t t',
    subst (substx_var i x) t t' ->
    step (tapp (tabs i t) x) t'
| step_let1 : forall i t1 t2 t1',
    step t1 t1' ->
    step (tlet i t1 t2) (tlet i t1' t2)
| step_let : forall i x t t',
    value x ->
    subst (substx_var i x) t t' ->
    step (tlet i x t) t'
| step_acc : forall r x t,
    recordval r ->
    access r x t ->
    step (trec_select r x) t.

Hint Constructors step.

Inductive ty :=
| tynat : ty
| tyarr : ty -> ty -> ty
| tyrec : (id -> option ty) -> ty.

Definition tyenv := id -> option ty.

Definition empty_tyenv : tyenv := fun i => None.

Definition extend_tyenv env i (t : ty) :=
    fun i' => if eq_id_dec i' i then Some t else env i'.

Definition recty := tyenv.

Inductive has_ty : tyenv -> tm -> ty -> Prop :=
| typenat : forall env n,
    has_ty env (tnat n) tynat
| typevar : forall env i ty,
    env i = Some ty ->
    has_ty env (tvar i) ty
| typeabs : forall env x t ty1 ty2,
    has_ty (extend_tyenv env x ty1) t ty2 ->
    has_ty env (tabs x t) (tyarr ty1 ty2)
| tyfix : forall env f x t ty1 ty2,
    has_ty (extend_tyenv (extend_tyenv env x ty1) f (tyarr ty1 ty2)) t ty2 ->
    has_ty env (tfix f x t) (tyarr ty1 ty2)
| tyapp : forall env t1 t2 ty1 ty2,
    has_ty env t1 (tyarr ty1 ty2) ->
    has_ty env t2 ty1 ->
    has_ty env (tapp t1 t2) ty2
| tylet : forall env i x body ty1 ty2,
    has_ty env x ty1 ->
    has_ty (extend_tyenv env i ty1) body ty2 ->
    has_ty env (tlet i x body) ty2
| tyempty_rec : forall env,
    has_ty env (trec rempty) (tyrec empty_tyenv)
| tyupate_rec : forall env i ext ty r recty,
    has_ty env ext ty ->
    has_ty_rec env r recty ->
    has_ty env (trec (rextend2 r i ext)) (tyrec (extend_tyenv recty i ty))
| tyacc_rec : forall env rec recty i ty,
    has_ty_rec env rec recty ->
    recty i = Some ty ->
    has_ty env (trec_select rec i) ty

with has_ty_rec : tyenv -> rec -> recty -> Prop :=
| has_ty_rec_empty : forall env,
    has_ty_rec env rempty empty_tyenv
| has_ty_rec_extend1 : forall env i var extty rec recty,
    has_ty env (tvar var) extty ->
    has_ty_rec env rec recty ->
    has_ty_rec env (rextend1 rec i var) (extend_tyenv recty i extty)
| has_ty_rec_extend2 : forall env i ext extty rec recty,
    has_ty env ext extty ->
    has_ty_rec env rec recty ->
    has_ty_rec env (rextend2 rec i ext) (extend_tyenv recty i extty).

Theorem progress : forall tm ty,
    has_ty empty_tyenv tm ty ->
    value tm \/ exists tm', step tm tm'.
Proof.
    intros tm. induction tm.
    Case "tnat". intros. left. apply vnat.
    Case "tnat". intros. inversion H. inversion H2.
    Case "tabs". admit.
    Case "tapp". intros. inversion H; subst. destruct IHtm1 with (ty := tyarr ty1 ty0); auto.
      SCase "tm1 is value". destruct IHtm2 with (ty := ty1); auto.
        SSCase "tm2 is value". (* tm1 should be a lambda or fix *) inversion H3; subst.
          inversion H3. inversion H7.
          (* show substitution *) admit.
          (* same as appabs *) admit.
          inversion H0.
          inversion H0.
          inversion H0.
        SSCase "tm2 can take a step".
          right. inversion H1. exists (tapp tm1 x); auto.
      SCase "tm1 can take a step".
        right. inversion H0. exists (tapp x tm2); auto.
    Case "tfix". admit.
    Case "trec". admit.
    Case "trec_select". admit.
    Case "tlet". intros. right. inversion H; subst. destruct IHtm1 with (ty := ty1); auto.
      SCase "tm1 is value". (* again, need to show substitution *) admit.
      SCase "tm1 can take a step". inversion H0. exists (tlet i x tm2). auto.
Qed.


(* Exercise 71 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_071 : (forall x : D, x = x).
Proof.
all_i a.
lin_solve.
Qed.


(** * P: Liczby [TODO] *)

(** * Liczby naturalne *)

(** ** Unarne *)

(** [nat] to jedyne normalne liczby, reszta to lipa.
    ~ parafraza z zapomniałem nazwiska, ale był Niemcem
    (albo Austryjakiem) *)

Print nat.
(* ===>
Inductive nat : Type :=
| O : nat
| S : nat -> nat.
*)

(** ** Dodatnie liczby naturalne, binarnie (TODO) *)

Inductive BinPos : Set :=
| H : BinPos
| O : BinPos -> BinPos
| I : BinPos -> BinPos.

(** [H] to binarne 1, [O k] to binarnie 2k, zaś [I k] to binarnie
    2k + 1. *)

Fixpoint to_nat (n : BinPos) : nat :=
match n with
| H => 1
| O n' => 2 * to_nat n'
| I n' => S (2 * to_nat n')
end.

Compute to_nat (O (O (O H))).

(** Liczby binarne można też zrobić inaczej, np. jako [list bool], ale
    wtedy reprezentacja nie jest unikalna. *)

(** * Liczby całkowite *)

(** ** Unarne *)

(** Jeżeli mamy liczby naturalne, to możemy zrobić liczby całkowite. *)

Module Z_unary.

Inductive Z : Type :=
| Z0 : Z
| Zpos : nat -> Z
| Zneg : nat -> Z.

End Z_unary.

(** ** Binarne *)

(** Mając dodatnie liczby binarne, możemy zrobić liczby całkowite za
    pomocą rozbicia na liczby ujemne, zero i dodatnie. *)

Module Z_binary.

Inductive Z : Set :=
| Z0 : Z
| Zpos : BinPos -> Z
| Zneg : BinPos -> Z.

End Z_binary.

(** ** Klasyczne *)

Module Z_classic.

Record Z : Type :=
{
  L : nat;
  R : nat;
}.

Definition Z_eq (k l : Z) : Prop :=
  L k + R l = R k + L l.

End Z_classic.

(** ** Klasyczne znormalizowane *)

Module Z_norm.

Record Z : Type := mkZ
{
  L : nat;
  R : nat;
}.

Fixpoint norm' (l r : nat) : nat * nat :=
match l, r with
| 0   , _    => (l, r)
| _   , 0    => (l, r)
| S l', S r' => norm' l' r'
end.

Definition norm (k : Z) : Z :=
  let (l, r) := norm' (L k) (R k) in mkZ l r.

Definition Z_eq (k l : Z) : Prop :=
  L k + R l = R k + L l.

End Z_norm.

(** ** HITowe *)

(** Jeżeli mamy wyższe typy induktywne, to można też spróbować definicji
    dość podobnej do [nat]. *)

Module Z_HIT.

Fail Inductive Z : Type :=
| zero : Z
| succ : Z -> Z
| pred : Z -> Z
| SP : forall z : Z, succ (pred z) = z
| PS : forall z : Z, pred (succ z) = z
| Z_isSet : forall (x y : Z) (p q : x = y), p = q.

End Z_HIT.

(** ** HITowe zasymulowane *)

Module Z_HIT_norm.

Inductive Z : Type :=
| zero : Z
| succ : Z -> Z
| pred : Z -> Z.

Fixpoint norm (k : Z) : Z :=
match k with
| zero    => zero
| succ k' =>
  match norm k' with
  | pred k'' => k''
  | k''      => succ k''
  end
| pred k' =>
  match norm k' with
  | succ k'' => k''
  | k''      => pred k''
  end
end.

Compute norm (succ (pred (succ zero))).

End Z_HIT_norm.

(** * Liczby wymierne (TODO) *)

(** ** Klasycznie *)

(** Liczby wymierne można zrobić naiwnie albo sprytnie (albo zastosować
    jakiś inny wariant), ale oba pomysły są dość głupie, bo w obu
    przypadkach potrzebne są setoidy. *)

Require Import ZArith.

Module Q_naive.

(** Bardzo naiwnie. *)

Record Q : Type :=
{
  numerator : Z;
  denominator : nat;
  _ : denominator <> 0;
}.

(** Warunek niezerowości można ulepszyć za pomocą sortu [SProp]. *)

Fail Definition Q_eq (q1 q2 : Q) : Prop :=
  numerator q1 * denominator q2 =
  numerator q2 * denominator q1.

End Q_naive.

Module Q_less_naive.

(** Sprytniej: mianownik interpretujemy jako liczbę dodatnią. *)

Record Q : Type :=
{
  numerator : Z;
  denominator : nat;
}.

Fail Definition Q_eq (q1 q2 : Q) : Prop :=
  numerator q1 * S (denominator q2) =
  numerator q2 * S (denominator q1).

End Q_less_naive.

(** ** HITowo *)

Module Q_HIT.

Fail Inductive Q : Type :=
| numden : Z -> nat -> Q
| path :
    forall (z1 z2 : Z) (n1 n2 : N),
      z1 * (S n2) = z2 * (S n1) -> numden z1 n1 = numden z2 n2.

End Q_HIT.

(** ** Induktywnie *)

(** Coś jak ułamki łańcuchowe:
    Yves Bertot,
    #
    A simple canonical representation of rational numbers#
*)

Module Q_Ind.

Inductive Q : Type :=
| One : Q
| N : Q -> Q
| D : Q -> Q.

End Q_Ind.

(** * Liczby rzeczywiste *)

(** Zbyt skomplikowane jak na jeden podrozdział - ludzie piszą o tym
    całe traktaty. *)

(** * Liczby porządkowe *)

(** ** Jakieś takie proste *)

Module Ord_simple.

Inductive Ord : Type :=
| ZZ : Ord
| SS : Ord -> Ord
| lim : (nat -> Ord) -> Ord.

End Ord_simple.

(** ** Skomplikowańsze *)

(** Indukcja-indukcja-rekursja wita nas: https://arxiv.org/pdf/1904.10759.pdf *)

Module Ord_IIR.

End Ord_IIR.

(** * Liczby nadrzeczywiste *)

(** Znów indukcja-indukcja wita. Patrz: HoTTBook, rozdział 11.6. *)

Module Sur.

End Sur.


Set Implicit Arguments.
(* Load the CFML library. *)
Require Import CFML.CFLib.
Require Import CFML.Stdlib.Array_proof CFML.Stdlib.Pervasives_proof.
Require Import TLC.LibListZ.
(* Load the examples CF definitions. *)
Require Import PairInsertionSort_ml.

Require Import Permutation.
Hint Constructors Permutation.
Hint Constructors Forall.
Ltac auto_tilde ::= rew_list in *; eauto with maths.

Definition sorted (l : list int) :=
  forall i, 0 <= i -> i < length l - 1 -> l[i] <= l[i+1].

Lemma sort_spec : forall a (L : list int),
  app sort [a]
    PRE (a ~> Array L)
    POST (fun (t : unit) => Hexists L', a ~> Array L' \* \[sorted L' /\ Permutation L L']).
Proof.
  introv.
  xcf.
  xapp as ir.
  xwhile_inv_basic_measure (fun (b:bool) (m:int) =>
    Hexists L1 L2 i,
    a ~> Array (L1 ++ L2) \*
    ir ~~> i \*
    \[ m = length L2 /\ length L1 = i /\ sorted L1 /\ Permutation L (L1 ++ L2) /\
       if b then True else m <= 1 ]
  ).
  - hsimpl true (@nil int) L.
    splits~. red.
    intros. rew_list in *. math.
  - intros.
    xpull.
    intros.
    xapps.
    xapps.
    xrets.
    unpack H; subst.
    splits~.
    case_if~.
  - admit.
  - intros m l1 l2 i H.
    unpack H; subst.
    xapps.
    xapps.
    xrets.
    xif.
    + xapps.
      xapp as y.
      { apply~ index_of_inbound. }
      intros Hy.
      assert (l2 = y :: nil).
      { destruct~ l2.
        - math.
        - f_equal.
          rew_list in *.
          + rewrite~ read_middle in Hy.
          + apply~ length_zero_inv. }
      xapps.
      xapp as jr.
      xgc (ir ~~> length l1).
      xwhile_inv_basic (fun (b':bool) (m':int) =>
        Hexists L1a h L1b L2t,
          a ~> Array (L1a ++ h :: L1b ++ L2t) \*
          jr ~~> m' \*
          \[ m' + 1 = length L1a /\
             l2 = y :: L2t /\
             l1 = L1a ++ L1b /\
             Forall (fun z => z > y) L1b /\
             b' = isTrue ((m' >= 0) /\ (L1a[m'] > y)) ]) (downto (-1)).
(*             if b' then m' >= 0 else Forall (fun z => z <= y) L1a ]).*)
      * hsimpl (>> __ l1 y __ (@nil int)).
        { subst l2. rew_list~. }
        splits~.
      * intros b' m'. xpull.
        intros ? ? ? ? H0.
        xapps.
        xands.
        -- xapps.
           xapps.
           { apply~ index_of_inbound. }
           xrets.
           unpack H0.
           splits~.
           rewrite read_app.
           assert (m' < length x) by math.
           case_if~.
           splits~.
        -- unpack. splits~.
      * intros m'.
        xpull.
        intros ? ? ? ? H0.
        unpack H0.
        xapps.
        xapps.
        { apply~ index_of_inbound. }
        xapps.
        xapps.
        { apply~ index_of_inbound. }
        xapps.
        rew_bool_eq in *.
        forwards~Hx: (length_pos_inv_last x).
        destruct Hx as [y' [x' Hx]].
        hsimpl (>> __ (m' - 1) x' y' (y' :: x1) (@nil int)).
        { subst l2. rew_list~ in *.
          rewrite read_app.
          assert (m' < length x) by math.
          case_if~. subst x.
          rewrite~ update_middle.
          rewrite read_last_case.
          assert (m' = length x') by math.
          case_if~.
          inversion~ TEMP3. }
        -- subst x. splits~.
           unpack.
           rewrite read_last_case in H1.
           case_if~ in H1.
        -- math.
      * intros. unpack.
        xapps. xapps.
        { apply~ index_of_inbound. }
        hsimpl.
        subst l1 l2.
        inversion H1; subst.
        rew_list in *.
        rewrite~ update_middle.
        assert (x0[x] <= y).
        { admit. }
        admit.
    + xrets.
      assert (l2 = nil) as -> by apply~ length_zero_inv.
      rew_list~.
Qed.


Require Import HoTT.
From GR.bicategories Require Import
     general_category bicategory.bicategory bicategory.univalent.

Section TwoTypeBiGroupoid.
  Variable (X : Type).
  Context `{IsTrunc 2 X}.

  Definition path_bigroupoid_d : BiCategory_d.
  Proof.
    make_bicategory.
    - exact X.
    - exact (fun x y => Core.groupoid_category (x = y)).
    - exact (fun _ => idpath).
    - exact (fun _ _ _ p => Datatypes.snd p @ Datatypes.fst p).
    - intros x y z [p₁ p₂] [q₁ q₂] [s₁ s₂] ; simpl in *.
      exact (ap (fun z => z @ p₁) s₂ @ ap (fun z => q₂ @ z) s₁).
    - intros x y p ; simpl in *.
      exact (concat_p1 p).
    - intros x y p ; simpl in *.
      exact (concat_p1 p)^.
    - intros x y p ; simpl in *.
      exact (concat_1p p).
    - intros x y p ; simpl in *.
      exact (concat_1p p)^.
    - intros w x y z p q r ; simpl in *.
      exact (concat_p_pp r q p).
    - intros w x y z p q r ; simpl in *.
      exact (concat_p_pp r q p)^.
  Defined.

  Definition path_bigroupoid_is_bicategory : is_bicategory path_bigroupoid_d.
  Proof.
    make_is_bicategory.
    - reflexivity.
    - intros x y z [p₁ p₂] [q₁ q₂] [r₁ r₂] [s₁ s₂] [t₁ t₂] ; simpl in *.
      induction s₁, s₂, t₁, t₂ ; simpl.
      reflexivity.
    - intros x y p₁ p₂ s ; simpl in *.
      induction s ; simpl.
      exact (concat_1p _ @ (concat_p1 _)^).
    - intros x y p₁ p₂ s ; simpl in *.
      induction s ; simpl.
      exact (concat_1p _ @ (concat_p1 _)^).
    - intros x y p₁ p₂ s ; simpl in *.
      induction s ; simpl.
      exact (concat_1p _ @ (concat_p1 _)^).
    - intros x y p₁ p₂ s ; simpl in *.
      induction s ; simpl.
      exact (concat_1p _ @ (concat_p1 _)^).
    - intros x y p ; simpl in *.
      exact (concat_Vp _).
    - intros x y p ; simpl in *.
      exact (concat_pV _).
    - intros x y p ; simpl in *.
      exact (concat_Vp _).
    - intros x y p ; simpl in *.
      exact (concat_pV _).
    - intros w x y z p₁ p₂ q₁ q₂ r₁ r₂ sp sq sr ; simpl in *.
      induction sp, sq, sr ; simpl.
      exact (concat_1p _ @ (concat_p1 _)^).
    - intros w x y z p₁ p₂ q₁ q₂ r₁ r₂ sp sq sr ; simpl in *.
      induction sp, sq, sr ; simpl.
      exact (concat_1p _ @ (concat_p1 _)^).
    - intros w x y z p q r ; simpl in *.
      exact (concat_Vp _).
    - intros w x y z p q r ; simpl in *.
      exact (concat_pV _).
    - intros x y z p q ; simpl in *.
      induction p, q ; simpl.
      reflexivity.
    - intros v w x y z p q r s ; simpl in *.
      induction p, q, r, s ; simpl.
      reflexivity.
  Qed.

  Definition path_bigroupoid : BiCategory
    := Build_BiCategory path_bigroupoid_d path_bigroupoid_is_bicategory.

  Global Instance locally_univalent_path_bigroupoid
    : LocallyUnivalent path_bigroupoid.
  Proof.
    intro ; apply _.
  Qed.
End TwoTypeBiGroupoid.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e384m317_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import rt.util.all.
Require Import rt.model.time rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.arrival.basic.arrival_sequence
               rt.model.priority.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Workload.

  Import Time ArrivalSequence Priority.

  (* In this section, we define the notion of workload for sets of jobs. *)
  Section WorkloadDefs.

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

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any (finite) set of jobs. *)
    Variable jobs: seq Job.

    (* First, we define the workload for generic sets of jobs. *)
    Section WorkloadOfJobs.

      (* Given any predicate over Jobs, ... *)
      Variable P: Job -> bool.

      (* ...we define the total workload of the jobs that satisfy such a predicate. *)
      Definition workload_of_jobs := \sum_(j <- jobs | P j) job_cost j.

    End WorkloadOfJobs.

    (* Then, we define the workload of tasks with higher or equal priority
       under FP policies. *)
    Section PerTaskPriority.

      (* Consider any FP policy that indicates whether a task has
         higher or equal priority. *)
      Variable higher_eq_priority: FP_policy Task.

      (* Let tsk be the task to be analyzed. *)
      Variable tsk: Task.

      (* Recall the notion of a job of higher or equal priority. *)
      Let of_higher_or_equal_priority j :=
        higher_eq_priority (job_task j) tsk.

      (* Then, we define the workload of all jobs of tasks with
         higher-or-equal priority than tsk. *)
      Definition workload_of_higher_or_equal_priority_tasks :=
        workload_of_jobs of_higher_or_equal_priority.

    End PerTaskPriority.

    (* Then, we define the workload of jobs with higher or equal priority
       under JLFP policies. *)
    Section PerJobPriority.

      (* Consider any JLFP policy that indicates whether a job has
         higher or equal priority. *)
      Variable higher_eq_priority: JLFP_policy Job.

      (* Let j be the job to be analyzed. *)
      Variable j: Job.

      (* Recall the notion of a job of higher or equal priority. *)
      Let of_higher_or_equal_priority j_hp := higher_eq_priority j_hp j.

      (* Then, we define the workload of higher or equal priority of all jobs
         with higher-or-equal priority than j. *)
      Definition workload_of_higher_or_equal_priority_jobs :=
        workload_of_jobs of_higher_or_equal_priority.

    End PerJobPriority.

  End WorkloadDefs.

End Workload.


Require Export QuantumLib.VectorStates.
Require Export UnitaryOps.

Local Open Scope ucom_scope.
Local Close Scope C_scope.
Local Close Scope R_scope.

(** Some useful equivalences over unitary circuits. **)

Lemma ID_equiv_SKIP : forall dim n, n < dim -> @ID dim n ≡ SKIP.
Proof.
  intros dim n WT.
  unfold uc_equiv.
  autorewrite with eval_db.
  gridify. reflexivity.
  lia.
Qed.

Lemma SKIP_id_l : forall {dim} (c : base_ucom dim), SKIP; c ≡ c.
Proof.
  intros dim c.
  unfold uc_equiv.
  simpl.
  destruct (uc_well_typed_b c) eqn:WT.
  - apply uc_well_typed_b_equiv in WT.
    apply uc_well_typed_implies_dim_nonzero in WT.
    autorewrite with eval_db; try assumption.
    Msimpl_light; reflexivity.
  - apply not_true_iff_false in WT.
    rewrite uc_well_typed_b_equiv in WT.
    apply uc_eval_zero_iff in WT.
    rewrite WT.
    Msimpl_light; reflexivity.
Qed.

Lemma SKIP_id_r : forall {dim} (c : base_ucom dim), c; SKIP ≡ c.
Proof.
  intros dim c.
  unfold uc_equiv.
  simpl.
  destruct (uc_well_typed_b c) eqn:WT.
  - apply uc_well_typed_b_equiv in WT.
    apply uc_well_typed_implies_dim_nonzero in WT.
    autorewrite with eval_db; try assumption.
    Msimpl_light; reflexivity.
  - apply not_true_iff_false in WT.
    rewrite uc_well_typed_b_equiv in WT.
    apply uc_eval_zero_iff in WT.
    rewrite WT.
    Msimpl_light; reflexivity.
Qed.

Lemma SKIP_id_l_cong : forall {dim} (c : base_ucom dim), SKIP; c ≅ c.
Proof.
  intros.
  apply uc_equiv_cong.
  apply SKIP_id_l.
Qed.

Lemma SKIP_id_r_cong : forall {dim} (c : base_ucom dim), c; SKIP ≅ c.
Proof.
  intros.
  apply uc_equiv_cong.
  apply SKIP_id_r.
Qed.

Lemma X_X_id : forall {dim} q, X q; X q ≡ @ID dim q.
Proof.
  intros dim q.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify.
  replace (σx × σx) with (I 2) by solve_matrix.
  reflexivity.
Qed.

Lemma H_H_id : forall {dim} q, H q; H q ≡ @ID dim q.
Proof.
  intros dim q.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify.
  replace (hadamard × hadamard) with (I 2) by solve_matrix.
  reflexivity.
Qed.

Lemma Rz_Rz_add : forall {dim} q θ θ', @Rz dim θ q; Rz θ' q ≡ Rz (θ + θ') q.
Proof.
  intros.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify.
  rewrite phase_mul.
  rewrite Rplus_comm.
  reflexivity.
Qed.

Lemma Rz_0_id : forall {dim} q, Rz 0 q ≡ @ID dim q.
Proof.
  intros.
  unfold uc_equiv.
  autorewrite with eval_db; simpl.
  gridify.
  Qsimpl.
  reflexivity.
Qed.

Lemma CNOT_CNOT_id : forall {dim} m n,
  m < dim -> n < dim -> m <> n -> (* easier to state with restrictions on m, n *)
  CNOT m n; CNOT m n ≡ @SKIP dim.
Proof.
  intros dim m n Hm Hn Hneq.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  2: lia.
  gridify.
  all: Qsimpl.
  all: repeat rewrite <- kron_plus_distr_r;
       repeat rewrite <- kron_plus_distr_l.
  all: rewrite Mplus10; reflexivity.
Qed.

Lemma U_V_comm : forall {dim} (m n : nat) (U V : base_Unitary 1),
  m <> n ->
  @uapp1 _ dim U m; uapp1 V n ≡ uapp1 V n ; uapp1 U m.
Proof.
  intros.
  unfold uc_equiv; simpl.
  dependent destruction U; dependent destruction V.
  unfold ueval_r.
  apply pad_A_B_commutes; auto with wf_db.
Qed.

Lemma U_CNOT_comm : forall {dim} (q n1 n2 : nat) (U : base_Unitary 1),
  q <> n1 ->
  q <> n2 ->
  @uapp1 _ dim U q ; CNOT n1 n2 ≡ CNOT n1 n2 ; uapp1 U q.
Proof.
  intros.
  unfold uc_equiv; simpl.
  dependent destruction U.
  rewrite denote_cnot.
  unfold ueval_cnot, ueval_r.
  rewrite pad_A_ctrl_commutes; auto with wf_db.
Qed.

Lemma CNOT_CNOT_comm : forall {dim} (n1 n2 n1' n2' : nat),
  n1' <> n1 -> n1' <> n2 -> n2' <> n1 -> n2' <> n2 ->
  @CNOT dim n1 n2 ; CNOT n1' n2' ≡ CNOT n1' n2' ; CNOT n1 n2.
Proof.
  intros.
  unfold uc_equiv; simpl.
  rewrite 2 denote_cnot.
  unfold ueval_cnot.
  rewrite pad_ctrl_ctrl_commutes; auto with wf_db.
Qed.

Lemma H_comm_Z : forall {dim} q, @H dim q; SQIR.Z q ≡ X q; H q.
Proof.
  intros.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify.
  replace (σz × hadamard) with (hadamard × σx) by solve_matrix.
  reflexivity.
Qed.

Local Transparent Rz.
Lemma X_comm_Rz : forall {dim} q a,
  @X dim q; Rz a q ≅ invert (Rz a q); X q.
Proof.
  intros.
  unfold uc_cong.
  exists a.
  simpl; autorewrite with eval_db.
  rewrite phase_shift_rotation.
  gridify.
  rewrite <- Mscale_kron_dist_l, <- Mscale_kron_dist_r.
  do 2 (apply f_equal2; trivial).
  solve_matrix.
  all: autorewrite with R_db C_db Cexp_db trig_db; reflexivity.
Qed.
Local Opaque Rz.

Lemma X_comm_CNOT_control : forall {dim} m n,
  @X dim m; CNOT m n ≡ CNOT m n; X m; X n.
Proof.
  intros dim m n.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify; trivial.
  all: Qsimpl.
  all: rewrite Mplus_comm; reflexivity.
Qed.

Lemma X_comm_CNOT_target : forall {dim} m n,
  @X dim n; CNOT m n ≡ CNOT m n; X n.
Proof.
  intros dim m n.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify; reflexivity.
Qed.

Lemma Rz_comm_H_CNOT_H : forall {dim} a q1 q2,
  @Rz dim a q2; H q2; CNOT q1 q2; H q2 ≡ H q2; CNOT q1 q2; H q2; Rz a q2.
Proof.
  intros dim a q1 q2.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify.
  - rewrite <- (Mmult_assoc hadamard hadamard).
    Qsimpl.
    rewrite <- (Mmult_assoc _ hadamard), <- (Mmult_assoc hadamard).
    replace (hadamard × (σx × hadamard)) with σz by solve_matrix.
    rewrite <- phase_pi, 2 phase_mul.
    rewrite Rplus_comm.
    reflexivity.
  - rewrite <- (Mmult_assoc hadamard hadamard).
    Qsimpl.
    rewrite <- (Mmult_assoc _ hadamard), <- (Mmult_assoc hadamard).
    replace (hadamard × (σx × hadamard)) with σz by solve_matrix.
    rewrite <- phase_pi, 2 phase_mul.
    rewrite Rplus_comm.
    reflexivity.
Qed.

Lemma Rz_comm_CNOT_Rz_CNOT : forall {dim} a a' q1 q2,
  @Rz dim a q2; CNOT q1 q2; Rz a' q2; CNOT q1 q2 ≡ CNOT q1 q2; Rz a' q2; CNOT q1 q2; Rz a q2.
Proof.
  intros dim a a' q1 q2.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify.
  - Qsimpl.
    rewrite 2 phase_mul, Rplus_comm.
    replace (σx × (phase_shift a' × (σx × phase_shift a)))
      with (phase_shift a × (σx × (phase_shift a' × σx))) by
      solve_matrix.
    reflexivity.
  - Qsimpl.
    rewrite 2 phase_mul, Rplus_comm.
    replace (σx × (phase_shift a' × (σx × phase_shift a)))
      with (phase_shift a × (σx × (phase_shift a' × σx))) by
      solve_matrix.
    reflexivity.
Qed.

Lemma Rz_comm_CNOT : forall {dim} a q1 q2,
  @Rz dim a q1; CNOT q1 q2 ≡ CNOT q1 q2; Rz a q1.
Proof.
  intros dim a q1 q2.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify.
  - replace  (∣1⟩⟨1∣ × phase_shift a)
      with (phase_shift a × ∣1⟩⟨1∣) by solve_matrix.
    replace  (∣0⟩⟨0∣ × phase_shift a)
      with (phase_shift a × ∣0⟩⟨0∣) by solve_matrix.
    reflexivity.
  - replace  (∣1⟩⟨1∣ × phase_shift a)
      with (phase_shift a × ∣1⟩⟨1∣) by solve_matrix.
    replace  (∣0⟩⟨0∣ × phase_shift a)
      with (phase_shift a × ∣0⟩⟨0∣) by solve_matrix.
    reflexivity.
Qed.

Lemma CNOT_comm_CNOT_sharing_target : forall {dim} q1 q2 q3,
  @CNOT dim q1 q3; CNOT q2 q3 ≡ CNOT q2 q3; CNOT q1 q3.
Proof.
  intros dim q1 q2 q3.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify; reflexivity.
Qed.

Lemma CNOT_comm_CNOT_sharing_control : forall {dim} q1 q2 q3,
  @CNOT dim q1 q3; CNOT q1 q2 ≡ CNOT q1 q2; CNOT q1 q3.
Proof.
  intros dim q1 q2 q3.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify; Qsimpl; reflexivity.
Qed.

Lemma CNOT_comm_H_CNOT_H : forall {dim} q1 q2 q3,
  q1 <> q3 ->
  @CNOT dim q1 q2; H q2; CNOT q2 q3; H q2 ≡ H q2; CNOT q2 q3; H q2; CNOT q1 q2.
Proof.
  intros dim q1 q2 q3 H.
  unfold uc_equiv.
  simpl; autorewrite with eval_db.
  gridify; trivial. (* slow *)
  all: replace (hadamard × (∣1⟩⟨1∣ × (hadamard × σx))) with
         (σx × (hadamard × (∣1⟩⟨1∣ × hadamard))) by solve_matrix;
       replace (hadamard × (∣0⟩⟨0∣ × (hadamard × σx))) with
         (σx × (hadamard × (∣0⟩⟨0∣ × hadamard))) by solve_matrix;
       reflexivity.
Qed.

Lemma H_swaps_CNOT : forall {dim} m n,
  @H dim m; H n; CNOT n m; H m; H n ≡ CNOT m n.
Proof.
  intros.
  unfold uc_equiv; simpl.
  autorewrite with eval_db.
  gridify; trivial. (* trivial shouldn't be necessary -RR *)
  (* The trivial seems to be the result of autorewrite doing something weird. If
     you have 'repeat Msimpl_light' in gridify then you don't need the trivial. -KH *)
  - rewrite <- 2 kron_plus_distr_r.
    apply f_equal2; trivial.
    repeat rewrite kron_assoc by auto with wf_db.
    restore_dims.
    rewrite <- 2 kron_plus_distr_l.
    apply f_equal2; trivial.
    replace (hadamard × hadamard) with (∣0⟩⟨0∣ .+ ∣1⟩⟨1∣) by solve_matrix.
    replace (hadamard × (σx × hadamard)) with (∣0⟩⟨0∣ .+ (- 1)%R .* ∣1⟩⟨1∣) by solve_matrix.
    distribute_plus.
    repeat rewrite <- Mplus_assoc.
    rewrite Mplus_swap_mid.
    rewrite (Mplus_assoc _ _ _ (_ ⊗ (_ ⊗ ((-1)%R .* ∣1⟩⟨1∣)))).
    repeat rewrite Mscale_kron_dist_r.
    rewrite Mplus_comm.
    apply f_equal2.
    + rewrite <- Mscale_kron_dist_l.
      rewrite <- kron_plus_distr_r.
      apply f_equal2; trivial.
      solve_matrix.
    + rewrite <- kron_plus_distr_r.
      apply f_equal2; trivial.
      solve_matrix.
  - rewrite <- 2 kron_plus_distr_r.
    apply f_equal2; trivial.
    repeat rewrite kron_assoc by auto with wf_db.
    restore_dims.
    rewrite <- 2 kron_plus_distr_l.
    apply f_equal2; trivial.
    replace (hadamard × hadamard) with (∣0⟩⟨0∣ .+ ∣1⟩⟨1∣) by (Qsimpl; easy).
    replace (hadamard × (σx × hadamard)) with (∣0⟩⟨0∣ .+ (- 1)%R .* ∣1⟩⟨1∣) by solve_matrix.
    distribute_plus.
    repeat rewrite <- Mplus_assoc.
    rewrite Mplus_swap_mid.
    rewrite (Mplus_assoc _ _ _ (((-1)%R .* ∣1⟩⟨1∣) ⊗ _)).
    rewrite Mplus_comm.
    apply f_equal2.
    + rewrite Mscale_kron_dist_l.
      rewrite <- Mscale_kron_dist_r.
      rewrite <- Mscale_kron_dist_r.
      repeat rewrite <- kron_assoc by auto with wf_db.
      restore_dims.
      rewrite <- kron_plus_distr_l.
      apply f_equal2; trivial.
      solve_matrix.
    + rewrite <- 2 kron_plus_distr_l.
      apply f_equal2; trivial.
      apply f_equal2; trivial.
      solve_matrix.
Qed.

Lemma SWAP_extends_CNOT : forall {dim} a b c,
  a < dim -> b < dim -> c < dim ->
  a <> b -> b <> c -> a <> c ->
  @SWAP dim a b ; CNOT b c ; SWAP a b ≡ CNOT a c.
Proof.
  intros.
  eapply equal_on_basis_states_implies_equal; auto with wf_db.
  intro f.
  simpl uc_eval.
  repeat rewrite Mmult_assoc.
  rewrite f_to_vec_SWAP by auto.
  rewrite 2 f_to_vec_CNOT by auto.
  rewrite f_to_vec_SWAP by auto.
  rewrite fswap_simpl2.
  rewrite fswap_neq by auto.
  apply f_to_vec_eq.
  intros i Hi.
  bdestruct (i =? c); subst.
  rewrite update_index_eq.
  rewrite fswap_neq by auto.
  rewrite update_index_eq.
  reflexivity.
  rewrite update_index_neq by auto.
  bdestructΩ (i =? a); bdestructΩ (i =? b); subst.
  rewrite fswap_simpl1, update_index_neq by auto.
  apply fswap_simpl2.
  rewrite fswap_simpl2, update_index_neq by auto.
  apply fswap_simpl1.
  rewrite fswap_neq, update_index_neq by auto.
  apply fswap_neq; auto.
Qed.

Local Transparent SWAP.
Lemma SWAP_symmetric : forall {dim} a b,
  @SWAP dim a b ≡ SWAP b a.
Proof.
  intros dim a b.
  unfold uc_equiv, SWAP.
  simpl; autorewrite with eval_db.
  gridify; Qsimpl; lma.
Qed.
Local Opaque SWAP.

Lemma proj_Rz_comm : forall dim q n b k,
  proj q dim b × uc_eval (SQIR.Rz k n) = uc_eval (SQIR.Rz k n) × proj q dim b.
Proof.
  intros dim q n b k.
  unfold proj.
  autorewrite with eval_db.
  gridify; trivial.
  apply f_equal2; trivial.
  apply f_equal2; trivial.
  destruct b; solve_matrix.
Qed.

Lemma proj_Rz : forall dim q b θ,
  uc_eval (SQIR.Rz θ q) × proj q dim b = Cexp (b2R b * θ) .* proj q dim b.
Proof.
  intros dim q b θ.
  unfold proj.
  autorewrite with eval_db.
  gridify.
  rewrite <- Mscale_kron_dist_l, <- Mscale_kron_dist_r.
  apply f_equal2; trivial.
  apply f_equal2; trivial.
  destruct b; solve_matrix.
  rewrite Rmult_1_l. reflexivity.
  rewrite Rmult_0_l, Cexp_0. reflexivity.
Qed.

Lemma proj_CNOT_control : forall dim q m n b,
  (q <> n \/ m = n) ->
  proj q dim b × uc_eval (SQIR.CNOT m n) = uc_eval (SQIR.CNOT m n) × proj q dim b.
Proof.
  intros dim q m n b H.
  destruct H.
  bdestruct (m =? n).
  (* badly typed case *)
  1,3: subst; replace (uc_eval (SQIR.CNOT n n)) with (@Zero (2 ^ dim) (2 ^ dim));
       Msimpl_light; try reflexivity.
  1,2: autorewrite with eval_db; bdestructΩ (n <? n); reflexivity.
  bdestruct (q =? m).
  (* q = control *)
  subst. unfold proj.
  autorewrite with eval_db.
  gridify.
  destruct b; simpl; Qsimpl; reflexivity.
  destruct b; simpl; Qsimpl; reflexivity.
  (* disjoint qubits *)
  bdestructΩ (q =? n).
  apply proj_commutes_2q_gate; assumption.
Qed.

Lemma proj_CNOT_target : forall dim f q n,
  proj q dim ((f q) ⊕ (f n)) × proj n dim (f n) × uc_eval (SQIR.CNOT n q) = proj n dim (f n) × uc_eval (SQIR.CNOT n q) × proj q dim (f q).
Proof.
  intros dim f q n.
  unfold proj.
  autorewrite with eval_db.
  gridify. (* slow! *)
  all: try (destruct (f n); destruct (f (n + 1 + d)%nat));
       try (destruct (f q); destruct (f (q + 1 + d)%nat));
       auto with wf_db.
  all: simpl; Qsimpl; reflexivity.
Qed.