(** * RecordSub: Subtyping with Records *)

(** In this chapter, we combine two significant extensions of the pure
    STLC -- records (from chapter [Records]) and subtyping (from
    chapter [Sub]) -- and explore their interactions.  Most of the
    concepts have already been discussed in those chapters, so the
    presentation here is somewhat terse.  We just comment where things
    are nonstandard. *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import MoreStlc.

(* ################################################################# *)
(** * Core Definitions *)

(* ----------------------------------------------------------------- *)
(** *** Syntax *)

Inductive ty : Type :=
  (* proper types *)
  | Top   : ty
  | Base  : string -> ty
  | Arrow : ty -> ty -> ty
  (* record types *)
  | RNil : ty
  | RCons : string -> ty -> ty -> ty.

Inductive tm : Type :=
  (* proper terms *)
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  | rproj : tm -> string -> tm
  (* record terms *)
  | rnil :  tm
  | rcons : string -> tm -> tm -> tm.

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** The syntax of terms and types is a bit too loose, in the sense
    that it admits things like a record type whose final "tail" is
    [Top] or some arrow type rather than [Nil].  To avoid such cases,
    it is useful to assume that all the record types and terms that we
    see will obey some simple well-formedness conditions.

    [An interesting technical question is whether the basic properties
    of the system -- progress and preservation -- remain true if we
    drop these conditions.  I believe they do, and I would encourage
    motivated readers to try to check this by dropping the conditions
    from the definitions of typing and subtyping and adjusting the
    proofs in the rest of the chapter accordingly.  This is not a
    trivial exercise (or I'd have done it!), but it should not involve
    changing the basic structure of the proofs.  If someone does do
    it, please let me know. --BCP 5/16.] *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty RNil
  | RTcons : forall i T1 T2,
        record_ty (RCons i T1 T2).

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm rnil
  | rtcons : forall i t1 t2,
        record_tm (rcons i t1 t2).

Inductive well_formed_ty : ty -> Prop :=
  | wfTop :
        well_formed_ty Top
  | wfBase : forall i,
        well_formed_ty (Base i)
  | wfArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (Arrow T1 T2)
  | wfRNil :
        well_formed_ty RNil
  | wfRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (RCons i T1 T2).

Hint Constructors record_ty record_tm well_formed_ty.

(* ----------------------------------------------------------------- *)
(** *** Substitution *)

(** Substitution and reduction are as before. *)

Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | var y => if eqb_string x y then s else t
  | abs y T t1 =>  abs y T (if eqb_string x y then t1
                             else (subst x s t1))
  | app t1 t2 => app (subst x s t1) (subst x s t2)
  | rproj t1 i => rproj (subst x s t1) i
  | rnil => rnil
  | rcons i t1 tr2 => rcons i (subst x s t1) (subst x s tr2)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(* ----------------------------------------------------------------- *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (abs x T t)
  | v_rnil : value rnil
  | v_rcons : forall i v vr,
      value v ->
      value vr ->
      value (rcons i v vr).

Hint Constructors value.

Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
  match Tr with
  | RCons i' T Tr' =>
      if eqb_string i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:string) (tr:tm) : option tm :=
  match tr with
  | rcons i' t tr' =>
      if eqb_string i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (app (abs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1  t2')
  | ST_Proj1 : forall tr tr' i,
        tr --> tr' ->
        (rproj tr i) --> (rproj tr' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi    ->
       (rproj tr i) --> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 --> t1' ->
        (rcons i t1 tr2) --> (rcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 --> tr2' ->
        (rcons i v1 tr2) --> (rcons i v1 tr2')

where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step.

(* ################################################################# *)
(** * Subtyping *)

(** Now we come to the interesting part, where the features we've
    added start to interact.  We begin by defining the subtyping
    relation and developing some of its important technical
    properties. *)

(* ================================================================= *)
(** ** Definition *)

(** The definition of subtyping is essentially just what we sketched
    in the discussion of record subtyping in chapter [Sub], but we
    need to add well-formedness side conditions to some of the rules.
    Also, we replace the "n-ary" width, depth, and permutation
    subtyping rules by binary rules that deal with just the first
    field. *)

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    T <: T
  | S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
  | S_Top : forall S,
    well_formed_ty S ->
    S <: Top
  | S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    Arrow S1 S2 <: Arrow T1 T2
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty (RCons i T1 T2) ->
    RCons i T1 T2 <: RNil
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    S1 <: T1 ->
    Sr2 <: Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    RCons i S1 Sr2 <: RCons i T1 Tr2
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty (RCons i1 T1 (RCons i2 T2 Tr3)) ->
    i1 <> i2 ->
       RCons i1 T1 (RCons i2 T2 Tr3)
    <: RCons i2 T2 (RCons i1 T1 Tr3)

where "T '<:' U" := (subtype T U).

Hint Constructors subtype.

(* ================================================================= *)
(** ** Examples *)

Module Examples.
Open Scope string_scope.

Notation x := "x".
Notation y := "y".
Notation z := "z".
Notation j := "j".
Notation k := "k".
Notation i := "i".
Notation A := (Base "A").
Notation B := (Base "B").
Notation C := (Base "C").

Definition TRcd_j  :=
  (RCons j (Arrow B B) RNil).     (* {j:B->B} *)
Definition TRcd_kj :=
  RCons k (Arrow A A) TRcd_j.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  subtype (Arrow C TRcd_kj)
          (Arrow C RNil).
(* C->{k:A->A,j:B->B} <: C->{} *)
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get full
    benefit, make sure you also understand how to prove them on
    paper! *)

(** **** Exercise: 2 stars, standard (subtyping_example_1)  *)
Example subtyping_example_1 :
  subtype TRcd_kj TRcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard (subtyping_example_2)  *)
Example subtyping_example_2 :
  subtype (Arrow Top TRcd_kj)
          (Arrow (Arrow C C) TRcd_j).
(* Top->{k:A->A,j:B->B} <: (C->C)->{j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard (subtyping_example_3)  *)
Example subtyping_example_3 :
  subtype (Arrow RNil (RCons j A RNil))
          (Arrow (RCons k B RNil) RNil).
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (subtyping_example_4)  *)
Example subtyping_example_4 :
  subtype (RCons x A (RCons y B (RCons z C RNil)))
          (RCons z C (RCons y B (RCons x A RNil))).
(* {x:A,y:B,z:C} <: {z:C,y:B,x:A} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples.

(* ================================================================= *)
(** ** Properties of Subtyping *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** To get started proving things about subtyping, we need a couple of
    technical lemmas that intuitively (1) allow us to extract the
    well-formedness assumptions embedded in subtyping derivations
    and (2) record the fact that fields of well-formed record types
    are themselves well-formed types.  *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  induction Hsub;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  - (* S_RcdPerm *)
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve_by_invert.
  - (* RCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (eqb_string i s)...  inversion H0; subst...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

(** The record matching lemmas get a little more complicated in the
    presence of subtyping, for two reasons.  First, record types no
    longer necessarily describe the exact structure of the
    corresponding terms.  And second, reasoning by induction on typing
    derivations becomes harder in general, because typing is no longer
    syntax directed. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  induction Hsub; intros Ti Hget;
    try solve_by_invert.
  - (* S_Refl *)
    exists Ti...
  - (* S_Trans *)
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  - (* S_RcdDepth *)
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (eqb_string i k)...
    + (* i = k -- we're looking up the first field *)
      inversion Hget. subst. exists S1...
  - (* S_RcdPerm *)
    exists Ti. split.
    + (* lookup *)
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (eqb_stringP i i1)...
      * (* i = i1 -- we're looking up the first field *)
        destruct (eqb_stringP i i2)...
        (* i = i2 -- contradictory *)
        destruct H0.
        subst...
    + (* subtype *)
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars, standard (rcd_types_match_informal)

    Write a careful informal proof of the [rcd_types_match]
    lemma. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_rcd_types_match_informal : option (nat*string) := None.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, standard, optional (sub_inversion_arrow)  *)
Lemma sub_inversion_arrow : forall U V1 V2,
     subtype U (Arrow V1 V2) ->
     exists U1 U2,
       (U=(Arrow U1 U2)) /\ (subtype V1 U1) /\ (subtype U2 V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember (Arrow V1 V2) as V.
  generalize dependent V2. generalize dependent V1.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Typing *)

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- var x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- abs x T11 t12 \in Arrow T11 T12
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in Arrow T1 T2 ->
      Gamma |- t2 \in T1 ->
      Gamma |- app t1 t2 \in T2
  | T_Proj : forall Gamma i t T Ti,
      Gamma |- t \in T ->
      Tlookup i T = Some Ti ->
      Gamma |- rproj t i \in Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      subtype S T ->
      Gamma |- t \in T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      Gamma |- rnil \in RNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- rcons i t tr \in RCons i T Tr

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* ================================================================= *)
(** ** Typing Examples *)

Module Examples2.
Import Examples.

(** **** Exercise: 1 star, standard (typing_example_0)  *)
Definition trcd_kj :=
  (rcons k (abs z A (var z))
           (rcons j (abs z B (var z))
                      rnil)).

Example typing_example_0 :
  has_type empty
           (rcons k (abs z A (var z))
                     (rcons j (abs z B (var z))
                               rnil))
           TRcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (typing_example_1)  *)
Example typing_example_1 :
  has_type empty
           (app (abs x TRcd_j (rproj (var x) j))
                   (trcd_kj))
           (Arrow B B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j)
              {k=(\z:A.z), j=(\z:B.z)}
         : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (typing_example_2)  *)
Example typing_example_2 :
  has_type empty
           (app (abs z (Arrow (Arrow C C) TRcd_j)
                           (rproj (app (var z)
                                            (abs x C (var x)))
                                    j))
                   (abs z (Arrow C C) trcd_kj))
           (Arrow B B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples2.

(* ================================================================= *)
(** ** Properties of Typing *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
  - (* T_Sub *)
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr --> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  has_type empty v T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ has_type empty vi Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. revert Ti HeqGamma Hval.
  induction Htyp; intros; subst; try solve_by_invert.
  - (* T_Sub *)
    apply (rcd_types_match S) in H0...
    destruct H0 as [Si [HgetSi Hsub]].
    destruct (IHHtyp Si) as [vi [Hget Htyvi]]...
  - (* T_RCons *)
    simpl in H0. simpl. simpl in H1.
    destruct (eqb_string i i0).
    + (* i is first *)
      inversion H1. subst. exists t...
    + (* i in tail *)
      destruct (IHHtyp2 Ti) as [vi [get Htyvi]]...
      inversion Hval...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Progress *)

(** **** Exercise: 3 stars, standard (canonical_forms_of_arrow_types)  *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     has_type Gamma s (Arrow T1 T2) ->
     value s ->
     exists x S1 s2,
        s = abs x S1 s2.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t --> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht;
    intros HeqGamma; subst...
  - (* T_Var *)
    inversion H.
  - (* T_App *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists ([x:=t2]t12)...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists (app t1 t2')...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists (app t1' t2)...
  - (* T_Proj *)
    right. destruct IHHt...
    + (* rcd is value *)
      destruct (lookup_field_in_value t T i Ti)
        as [t' [Hget Ht']]...
    + (* rcd_steps *)
      destruct H0 as [t' Hstp]. exists (rproj t' i)...
  - (* T_RCons *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2...
      * (* tail steps *)
        right. destruct H2 as [tr' Hstp].
        exists (rcons i t tr')...
    + (* head steps *)
      right. destruct H1 as [t' Hstp].
      exists (rcons i t' tr)...  Qed.

(** _Theorem_ : For any term [t] and type [T], if [empty |- t : T]
    then [t] is a value or [t --> t'] for some term [t'].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We
    proceed by induction on the given typing derivation.

      - The cases where the last step in the typing derivation is
        [T_Abs] or [T_RNil] are immediate because abstractions and
        [{}] are always values.  The case for [T_Var] is vacuous
        because variables cannot be typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that [t =
        t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 :
        T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.

        - Suppose [t1 --> t1'] for some term [t1'].  Then [t1 t2 -->
          t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 --> t2'] for some term [t2'].  Then [t1 t2 -->
            t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By Lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for
            some [x], [S1], and [s2].  But then [(\x:S1.s2) t2 -->
            [x:=t2]s2] by [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        are a term [tr], a type [Tr], and a label [i] such that [t =
        tr.i], [empty |- tr : Tr], and [Tlookup i Tr = Some T].

        By the IH, either [tr] is a value or it steps.  If [tr -->
        tr'] for some term [tr'], then [tr.i --> tr'.i] by rule
        [ST_Proj1].

        If [tr] is a value, then Lemma [lookup_field_in_value] yields
        that there is a term [ti] such that [tlookup i tr = Some ti].
        It follows that [tr.i --> ti] by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then
        there exist some terms [t1] [tr], types [T1 Tr] and a label
        [t] such that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_ty
        tr], [record_tm Tr], [empty |- t1 : T1] and [empty |- tr :
        Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 --> t1'] for some term [t1'].  Then [{i=t1, tr}
          --> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr --> tr'] for some term [tr'].  Then [{i=t1,
            tr} --> {i=t1, tr'}] by rule [ST_Rcd_Tail], since [t1] is
            a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemmas *)

Lemma typing_inversion_var : forall Gamma x T,
  has_type Gamma (var x) T ->
  exists S,
    Gamma x = Some S /\ subtype S T.
Proof with eauto.
  intros Gamma x T Hty.
  remember (var x) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve_by_invert.
  - (* T_Var *)
    exists T...
  - (* T_Sub *)
    destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
  has_type Gamma (app t1 t2) T2 ->
  exists T1,
    has_type Gamma t1 (Arrow T1 T2) /\
    has_type Gamma t2 T1.
Proof with eauto.
  intros Gamma t1 t2 T2 Hty.
  remember (app t1 t2) as t.
  induction Hty; intros;
    inversion Heqt; subst; try solve_by_invert.
  - (* T_App *)
    exists T1...
  - (* T_Sub *)
    destruct IHHty as [U1 [Hty1 Hty2]]...
    assert (Hwf := has_type__wf _ _ _ Hty2).
    exists U1...  Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     has_type Gamma (abs x S1 t2) T ->
     (exists S2, subtype (Arrow S1 S2) T
              /\ has_type (update Gamma x S1) t2 S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember (abs x S1 t2) as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  - (* T_Abs *)
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  - (* T_Sub *)
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma typing_inversion_proj : forall Gamma i t1 Ti,
  has_type Gamma (rproj t1 i) Ti ->
  exists T Si,
    Tlookup i T = Some Si /\ subtype Si Ti /\ has_type Gamma t1 T.
Proof with eauto.
  intros Gamma i t1 Ti H.
  remember (rproj t1 i) as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  - (* T_Proj *)
    assert (well_formed_ty Ti) as Hwf.
    { (* pf of assertion *)
      apply (wf_rcd_lookup i T Ti)...
      apply has_type__wf in H... }
    exists T, Ti...
  - (* T_Sub *)
    destruct IHhas_type as [U [Ui [Hget [Hsub Hty]]]]...
    exists U, Ui...  Qed.

Lemma typing_inversion_rcons : forall Gamma i ti tr T,
  has_type Gamma (rcons i ti tr) T ->
  exists Si Sr,
    subtype (RCons i Si Sr) T /\ has_type Gamma ti Si /\
    record_tm tr /\ has_type Gamma tr Sr.
Proof with eauto.
  intros Gamma i ti tr T Hty.
  remember (rcons i ti tr) as t.
  induction Hty;
    inversion Heqt; subst...
  - (* T_Sub *)
    apply IHHty in H0.
    destruct H0 as [Ri [Rr [HsubRS [HtypRi HtypRr]]]].
    exists Ri, Rr...
  - (* T_RCons *)
    assert (well_formed_ty (RCons i T Tr)) as Hwf.
    { (* pf of assertion *)
      apply has_type__wf in Hty1.
      apply has_type__wf in Hty2... }
    exists T, Tr...  Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  has_type empty (abs x S1 s2) (Arrow T1 T2) ->
     subtype T1 S1
  /\ has_type (update empty x S1) s2 T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Context Invariance *)

Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x  ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)
  | afi_proj : forall x t i,
      appears_free_in x t ->
      appears_free_in x (rproj t i)
  | afi_rhead : forall x i t tr,
      appears_free_in x t ->
      appears_free_in x (rcons i t tr)
  | afi_rtail : forall x i t tr,
      appears_free_in x tr ->
      appears_free_in x (rcons i t tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
     has_type Gamma' t S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  - (* T_Var *)
    apply T_Var... rewrite <- Heqv...
  - (* T_Abs *)
    apply T_Abs... apply IHhas_type. intros x0 Hafi.
    unfold update, t_update. destruct (eqb_stringP x x0)...
  - (* T_App *)
    apply T_App with T1...
  - (* T_RCons *)
    apply T_RCons...  Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; subst; inversion Hafi; subst...
  - (* T_Abs *)
    destruct (IHHtyp H5) as [T Hctx]. exists T.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     has_type (update Gamma x U) t S  ->
     has_type empty v U   ->
     has_type Gamma ([x:=v]t) S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent S. generalize dependent Gamma.
  induction t; intros; simpl.
  - (* var *)
    rename s into y.
    destruct (typing_inversion_var _ _ _ Htypt) as [T [Hctx Hsub]].
    unfold update, t_update in Hctx.
    destruct (eqb_stringP x y)...
    + (* x=y *)
      subst.
      inversion Hctx; subst. clear Hctx.
      apply context_invariance with empty...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra) as [T' HT']...
      inversion HT'.
    + (* x<>y *)
      destruct (subtype__wf _ _ Hsub)...
  - (* app *)
    destruct (typing_inversion_app _ _ _ _ Htypt)
      as [T1 [Htypt1 Htypt2]].
    eapply T_App...
  - (* abs *)
    rename s into y. rename t into T1.
    destruct (typing_inversion_abs _ _ _ _ _ Htypt)
      as [T2 [Hsub Htypt2]].
    destruct (subtype__wf _ _ Hsub) as [Hwf1 Hwf2].
    inversion Hwf2. subst.
    apply T_Sub with (Arrow T1 T2)... apply T_Abs...
    destruct (eqb_stringP x y).
    + (* x=y *)
      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (eqb_string y x)...
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z)...
      subst.  rewrite false_eqb_string...
  - (* rproj *)
    destruct (typing_inversion_proj _ _ _ _ Htypt)
      as [T [Ti [Hget [Hsub Htypt1]]]]...
  - (* rnil *)
    eapply context_invariance...
    intros y Hcontra. inversion Hcontra.
  - (* rcons *)
    destruct (typing_inversion_rcons _ _ _ _ _ Htypt) as
      [Ti [Tr [Hsub [HtypTi [Hrcdt2 HtypTr]]]]].
    apply T_Sub with (RCons s Ti Tr)...
    apply T_RCons...
    + (* record_ty Tr *)
      apply subtype__wf in Hsub. destruct Hsub. inversion H0...
    + (* record_tm ([x:=v]t2) *)
      inversion Hrcdt2; subst; simpl...  Qed.

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t --> t'  ->
     has_type empty t' T.
Proof with eauto.
  intros t t' T HT.
  remember empty as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  - (* T_App *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T...
  - (* T_Proj *)
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    eauto using step_preserves_record_tm.  Qed.

(** _Theorem_: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t --> t'], then [empty |- t' : T].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and [{}] don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [Tlookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr --> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr.i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tlookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_ty tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)

(* Thu Feb 7 20:09:26 EST 2019 *)


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.whiskering.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import displayed_algebras.displayed_algebra.
Require Import existence.hit_existence.
Require Import existence.initial_algebra.
Require Import examples.free_algebra.
Require Import free_alg_biadj.free_alg_functor.

Local Open Scope cat.

Opaque hit_existence.
Opaque make_free_alg_algebra.
Opaque free_ump_1.
Opaque free_alg_ump_2.
Opaque free_alg_ump_eq.

Arguments free_alg_mor_on_A {_ _ _} _ _.

Section FreeAlgebraUnit.
  Variable (Σ : hit_signature).

  Definition free_alg_unit_comp
             (X : one_type)
    : X → alg_carrier (free_alg_psfunctor_obj Σ X)
    := λ x, alg_constr (free_alg Σ X) (inr x).

  Definition free_alg_unit_natural
             {X Y : one_type}
             (f : X → Y)
             (x : X)
    : alg_map_carrier (free_alg_psfunctor_mor Σ f) (free_alg_unit_comp X x)
      =
      free_alg_unit_comp Y (f x)
    := free_alg_mor_on_A f x.

  Definition free_alg_unit_data
    : pstrans_data
        (id_psfunctor one_types)
        (comp_psfunctor
           (hit_algebra_underlying Σ)
           (free_alg_psfunctor Σ)).
  Proof.
    use make_pstrans_data.
    - exact free_alg_unit_comp.
    - intros X Y f.
      use make_invertible_2cell.
      + exact (free_alg_unit_natural f).
      + apply one_type_2cell_iso.
  Defined.

  Local Definition free_alg_unit_natural_natural
        {X Y : one_type}
        {f g : X → Y}
        (p : f ~ g)
        (x : X)
    : alg_2cell_carrier
        (free_alg_psfunctor_cell Σ p)
        (free_alg_unit_comp X x)
      @ free_alg_unit_natural g x
      =
      free_alg_unit_natural f x
      @ maponpaths (free_alg_unit_comp Y) (p x).
  Proof.
    apply free_alg_psfunctor_cell_on_A.
  Qed.

  Local Definition free_alg_unit_id
        (X : one_type)
        (x : X)
    : alg_2cell_carrier (free_alg_psfunctor_id _ X) (free_alg_unit_comp X x)
      @ free_alg_unit_natural (λ x0 : X, x0) x
      =
      idpath _.
  Proof.
    etrans.
    {
      apply maponpaths_2.
      apply free_alg_psfunctor_id_on_A.
    }
    apply pathsinv0l.
  Qed.

  Local Definition free_alg_unit_composition
             {X Y Z : one_type}
             (f : X → Y) (g : Y → Z)
             (x : X)
    : alg_2cell_carrier (free_alg_psfunctor_comp Σ f g) (free_alg_unit_comp X x)
      @ free_alg_unit_natural (λ z, g (f z)) x
      =
      (((maponpaths (alg_map_carrier (free_alg_psfunctor_mor Σ g)) (free_alg_unit_natural f x)
         @ idpath _)
        @ free_alg_unit_natural g (f x))
       @ idpath _)
      @ idpath _.
  Proof.
    refine (!_).
    do 2 refine (pathscomp0rid _ @ _).
    etrans.
    {
      apply maponpaths_2.
      apply pathscomp0rid.
    }
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      exact (free_alg_psfunctor_comp_on_A Σ f g x).
    }
    refine (!(path_assoc _ _ _) @ _) ; apply maponpaths.
    refine (_ @ pathscomp0rid _).
    refine (!(path_assoc _ _ _) @ _) ; apply maponpaths.
    apply pathsinv0l.
  Qed.

  Definition free_alg_unit_is_pstrans
    : is_pstrans free_alg_unit_data.
  Proof.
    repeat split.
    - intros X Y f g p.
      use funextsec.
      exact (free_alg_unit_natural_natural p).
    - intro X.
      use funextsec.
      exact (free_alg_unit_id X).
    - intros X Y Z f g.
      use funextsec.
      exact (free_alg_unit_composition f g).
  Qed.

  Definition free_alg_unit
    : pstrans
        (id_psfunctor one_types)
        (comp_psfunctor
           (hit_algebra_underlying Σ)
           (free_alg_psfunctor Σ)).
  Proof.
    use make_pstrans.
    - exact free_alg_unit_data.
    - exact free_alg_unit_is_pstrans.
  Defined.
End FreeAlgebraUnit.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Set Implicit Arguments.

Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Setoids.Setoid.

Require Import CoqStock.comparable.

Require Import Reexamined.derive_def.
Require Import Reexamined.nullable.
Require Import Reexamined.regex.

Section RegexEq.

  Context {A: Type}.
  Context {cmp: comparable A}.

  Definition bool_eq (b1 b2: bool) : Prop := b1 = b2.

  Definition char_eq (a b: A) : Prop := compare a b = Eq.

  Definition regex_eq (r s: regex A): Prop :=
      forall (xs: list A), matchesb r xs = matchesb s xs.

  Lemma regex_eq_refl : reflexive (regex A) regex_eq.
  Proof.
    unfold reflexive.
    unfold regex_eq.
    reflexivity.
  Qed.

  Lemma regex_eq_sym: symmetric (regex A) regex_eq.
  Proof.
    unfold symmetric.
    unfold regex_eq.
    symmetry.
    apply H.
  Qed.

  Lemma regex_eq_trans: transitive (regex A) regex_eq.
  Proof.
    unfold transitive.
    unfold regex_eq.
    intros.
    specialize H with xs.
    specialize H0 with xs.
    eapply eq_trans.
    - exact H.
    - exact H0.
  Qed.

  Add Parametric Relation: (regex A) regex_eq
      reflexivity proved by regex_eq_refl
      symmetry proved by regex_eq_sym
      transitivity proved by regex_eq_trans as regex_setoid.

  Add Parametric Morphism: nullable
      with signature regex_eq ==> bool_eq as nullable_morph.
  Proof.
    intros.
    unfold bool_eq.
    unfold regex_eq in H.
    specialize H with nil.
    cbn in H.
    assumption.
  Qed.

  Add Parametric Morphism: (@derive A cmp)
      with signature regex_eq ==> char_eq ==> regex_eq as derive_morph.
  Proof.
    intros.
    unfold char_eq in H0.
    symmetry in H0.
    compare_to_eq.
    unfold regex_eq in *.
    unfold matchesb in H.
    intro.
    specialize H with (cons y0 xs).
    cbn in H.
    fold (matchesb (derive x y0) xs) in H.
    fold (matchesb (derive y y0) xs) in H.
    assumption.
  Qed.

  Add Parametric Morphism: or
      with signature regex_eq ==> regex_eq ==> regex_eq as or_morph.
  Proof.
    intros.
    unfold regex_eq in *.
    intros.
    repeat rewrite or_is_logical_or.
    rewrite H.
    rewrite H0.
    reflexivity.
  Qed.

  Add Parametric Morphism: and
    with signature regex_eq ==> regex_eq ==> regex_eq as and_morph.
  Proof.
    intros.
    unfold regex_eq in *.
    intros.
    repeat rewrite and_is_logical_and.
    rewrite H.
    rewrite H0.
    reflexivity.
  Qed.

  Add Parametric Morphism: not
    with signature regex_eq ==> regex_eq as not_morph.
  Proof.
    intros.
    unfold regex_eq in *.
    intro.
    repeat rewrite not_is_logical_not.
    rewrite H.
    reflexivity.
  Qed.

  Lemma concat_morph_specialized : forall
      (xs: list A)
      (x y x0 y0: regex A)
      (H0: (regex_eq x x0))
      (H1: (regex_eq y y0)),
      (matchesb (concat x y) xs) = (matchesb (concat x0 y0) xs).
  Proof.
    intro.
    induction xs.
    - intros.
      cbn.
      rewrite (nullable_morph H0).
      rewrite (nullable_morph H1).
      reflexivity.
    - intros.
      unfold matchesb.
      cbn.
      simpl_matchesb.
      rewrite (nullable_morph H0).
      destruct (nullable x0).
      + repeat rewrite or_is_logical_or.
        rewrite (derive_morph H1 (proof_compare_eq_reflex a)).
        replace (matchesb (concat (derive x0 a) y0) xs) with (matchesb (concat (derive x a) y) xs).
        * reflexivity.
        * eapply IHxs.
          ** rewrite (derive_morph H0 (proof_compare_eq_reflex a)).
            reflexivity.
          ** assumption.
      + eapply IHxs.
        * rewrite (derive_morph H0 (proof_compare_eq_reflex a)).
          reflexivity.
        * assumption.
  Qed.

  Add Parametric Morphism: concat
      with signature regex_eq ==> regex_eq ==> regex_eq as concat_morph.
  Proof.
    intros.
    unfold regex_eq.
    intro.
    eapply concat_morph_specialized.
    - assumption.
    - assumption.
  Qed.

  Add Parametric Morphism: star
      with signature regex_eq ==> regex_eq as star_morph.
  Proof.
  (* TODO: Help Wanted *)
  Abort.

End RegexEq.

Existing Instance regex_setoid.
Existing Instance and_morph_Proper.
Existing Instance or_morph_Proper.
Existing Instance not_morph_Proper.
Existing Instance concat_morph_Proper.
Existing Instance nullable_morph_Proper.
Existing Instance derive_morph_Proper.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


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

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

Print Assumptions carry.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(* Main quantum library *)

From mathcomp Require Import all_ssreflect all_algebra all_field all_real_closed.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope ring_scope.
Import Num.Theory GRing.Theory ComplexField.

Require Import other_stuff complex_stuff.

Section QubitVectorDef.

Variable n: nat.

(* The qubit datatype, parametrised by the length of the vector and a proof that it is a unit vector.
 * (qubit_vector_of n) is therefore the type of n-qubit vectors. *)
Structure qubit_vector_of := QubitVector {
  vector:> 'cV[complex_stuff.R [i]]_(2 ^ n);
  vector_is_unit: \sum_(i < 2^n) `|vector i 0| ^+ 2 == 1
}.

Canonical qubit_vector_subType := Eval hnf in [subType for vector].

Implicit Type qv: qubit_vector_of.

Definition qubit_vector qv mkQV : qubit_vector_of :=
  mkQV (let: QubitVector _ qvP := qv return \sum_(i < 2^n) `|qv i 0|^+2 == 1 in qvP).

Lemma qubit_vectorE qv : qubit_vector (fun qvP => @QubitVector qv qvP) = qv.
Proof.
  by case: qv.
Qed.

End QubitVectorDef.

Lemma zero_qubitP: \sum_(i < 2^0) `|((1:R[i])%:M) i 0| ^+ 2 == 1.
Proof.
  by rewrite big_ord1; rewrite mxE; rewrite normc_def; rewrite expr1n; rewrite expr0n; rewrite addr0; rewrite sqrtr1; rewrite expr1n.
Qed.
Canonical zero_qubit := QubitVector zero_qubitP.

Section GateDef.

Variable n: nat.

(* The gate datatype, paramtetrised by its size (number of inputs) and proof that it is a unitary matrix *)
Structure gate_of := Gate {
  matrix:> 'M[complex_stuff.R [i]]_(2 ^ n);
  matrix_is_unitary: unitarymx matrix
}.

Canonical matrix_subType := Eval hnf in [subType for matrix].

Implicit Type g: gate_of.

Definition gate g mkG : gate_of :=
  mkG (let: Gate _ gP := g return unitarymx g in gP).

Lemma gateE g : gate (fun gP => @Gate g gP) = g.
Proof.
  by case: g.
Qed.

End GateDef.

(* The apply operator; (apply q g) applies gate g to qubit vector q.
 * Needs proof that this results in a new qubit, which is by using the fact that gates are unitary matrices. *)
Lemma applyP: forall n g q,
  \sum_(i < 2^n) `|(matrix g *m vector q) i 0| ^+ 2 == 1.
  intros n g q; destruct q as [q Hq]; destruct g as [g Hg]; simpl;
  rewrite -conjugate_is_sum; rewrite -unitary_preserves_product;
  [ rewrite mxE; rewrite -(eqP Hq); apply/eqP; apply eq_bigr; intros i _;
    rewrite mulrC; rewrite !mxE; symmetry; apply sqr_normc
  | apply Hg
  ].
Qed.
Canonical apply n g q := (@QubitVector n _ (applyP g q)).

Lemma I_gateP: (@unitarymx 2 'M{[:: [:: 1; 0]; [:: 0; 1]]}).
  unfold unitarymx; apply/eqP; apply/matrixP; intros x y; rewrite !mxE; rewrite !big_ord_recl;
  rewrite big_ord0. rewrite !mxE; simpl.
  destruct x as [m H]; destruct m as [ | m]; destruct y as [m' H']; destruct m' as [ | m'];
  [
  | destruct m' as [ | m'];
    [ rewrite mulr0; rewrite add0r; rewrite addr0
    | absurd (m'.+2 < 2)%N; auto; apply H'
    ]
  | destruct m as [ | m ];
    [
    | absurd (m.+2 < 2)%N; auto; apply H
    ]
  | destruct m as [ | m ];
    [ destruct m' as [ | m' ];
      [
      | absurd (m'.+2 < 2)%N; auto; apply H'
      ]
    | absurd (m.+2 < 2)%N; auto; apply H
    ]
  ];
  simpl; try repeat (rewrite mulr0 || rewrite mul0r || rewrite addr0 || rewrite add0r || rewrite mul1r || rewrite mulr1);
  rewrite oppr0 //.
Qed.
Canonical I_gate := (@Gate 1 _ I_gateP).

(* Definition of the X gate *)
Lemma X_gateP: (@unitarymx 2 'M{[:: [:: 0; 1]; [:: 1; 0]]}).
Proof.
  apply/eqP. apply/matrixP; intros x y; rewrite !mxE; rewrite !big_ord_recl; rewrite big_ord0; rewrite !mxE;
  destruct x as [[ | [ | x]] Hx]; destruct y as [[ | [ | y]] Hy]; simpl;
  try (absurd (x.+2 < 2)%N; auto); try (absurd (y.+2 < 2)%N; auto);
  try repeat (rewrite mul0r || rewrite mulr0 || rewrite mulr1 || rewrite addr0 || rewrite add0r || rewrite oppr0 || rewrite mulNr || rewrite mulrN);
  auto.
Qed.
Canonical X_gate := (@Gate 1 _ X_gateP).

(* Definition of the Y gate *)
Lemma Y_gateP: (@unitarymx 2 'M{[:: [:: 0; -'i]; [:: 'i; 0]]}).
Proof.
  apply/eqP. apply/matrixP; intros x y; rewrite !mxE; rewrite !big_ord_recl; rewrite big_ord0; rewrite !mxE;
  destruct x as [[ | [ | x]] Hx]; destruct y as [[ | [ | y]] Hy]; simpl;
  try (absurd (x.+2 < 2)%N; auto); try (absurd (y.+2 < 2)%N; auto);
  try repeat (rewrite mul0r || rewrite mulr0 || rewrite mulr1 || rewrite addr0 || rewrite add0r || rewrite oppr0 || rewrite mulNr || rewrite mulrN || rewrite opprK || rewrite -expr2 || rewrite sqr_i || rewrite complex_minus_i);
  auto.
Qed.
Canonical Y_gate := (@Gate 1 _ Y_gateP).

(* Definition of the Z gate *)
Lemma Z_gateP: (@unitarymx 2 'M{[:: [:: 1; 0]; [:: 0; -1]]}).
Proof.
  apply/eqP; apply/matrixP; intros x y; rewrite !mxE; rewrite !big_ord_recl; rewrite big_ord0; rewrite !mxE;
  destruct x as [[ | [ | x]] Hx]; destruct y as [[ | [ | y]] Hy]; simpl;
  try (absurd (x.+2 < 2)%N; auto); try (absurd (y.+2 < 2)%N; auto);
  try repeat (rewrite mul0r || rewrite mulr0 || rewrite mulr1 || rewrite addr0 || rewrite add0r || rewrite oppr0 || rewrite mulNr || rewrite mulrN);
  auto;
  rewrite -oppr0; unfold GRing.opp; simpl; rewrite !opprK //.
Qed.
Canonical Z_gate := (@Gate 1 _ Z_gateP).

(* Definition of the Hadamard gate *)
Lemma hadamard_gateP: (@unitarymx 2 'M{[:: [:: (1/Num.sqrt (2%:R))%:C; (1/Num.sqrt (2%:R))%:C];
          [:: (1/Num.sqrt (2%:R))%:C; -(1/Num.sqrt (2%:R))%:C]]})%C.
Proof.
  apply/eqP; apply/matrixP; intros x y; rewrite !mxE; rewrite !big_ord_recl; rewrite big_ord0; rewrite !mxE;
  destruct x as [[ | [ | x]] Hx]; destruct y as [[ | [ | y]] Hy]; simpl;
  try (absurd (x.+2 < 2)%N; auto); try (absurd (y.+2 < 2)%N; auto); rewrite addr0; rewrite !oppr0.
  rewrite mulr_real_complex. rewrite mulf_div. rewrite mulr1. rewrite -expr2. rewrite sqr_sqrtr; [|apply ler0n].
  rewrite addr_real_complex. rewrite addf_div; try (rewrite -unitfE; apply unitf_gt0; apply ltr0Sn).
  rewrite !mul1r. rewrite !mulr_natl. rewrite [2%:R *+ 2]mulr2n.
  rewrite divrr //; try (apply unitf_gt0; apply addr_gt0; apply ltr0Sn).

  rewrite mulrN. rewrite mulr_real_complex; rewrite mulf_div; rewrite mulr1; rewrite -expr2; rewrite sqr_sqrtr; [| apply ler0n].
  rewrite subr_real_complex. rewrite -mulNr. rewrite addf_div; try (rewrite -unitfE; apply unitf_gt0; apply ltr0Sn).
  rewrite mulNr. rewrite !mul1r. rewrite addrN. rewrite mul0r //.

  rewrite -mulNr; rewrite !mulr_real_complex; rewrite !mulf_div. rewrite !mulr1. rewrite -expr2. rewrite sqr_sqrtr; [| apply ler0n].
  rewrite addr_real_complex. rewrite addf_div; try (rewrite -unitfE; apply unitf_gt0; apply ltr0Sn).
  rewrite mulNr. rewrite mul1r. rewrite addrN. rewrite mul0r //.

  rewrite oppr_real_complex. rewrite -!mulNr. rewrite !mulr_real_complex. rewrite !mulf_div. rewrite mulNr. rewrite mulrN. rewrite opprK. rewrite mulr1. rewrite -expr2; rewrite sqr_sqrtr; [|apply ler0n].
  rewrite addr_real_complex; rewrite addf_div; try (rewrite -unitfE; apply unitf_gt0; apply ltr0Sn).
  rewrite !mul1r; rewrite !mulr_natl; rewrite [2%:R *+ 2]mulr2n.
  rewrite divrr //; try (apply unitf_gt0; apply addr_gt0; apply ltr0Sn).
Qed.
Canonical hadamard_gate := (@Gate 1 _ hadamard_gateP).

(* Definition of the Cnot gate *)
Lemma cnot_gateP: (@unitarymx 4 'M{[:: [:: 1; 0; 0; 0]; [:: 0; 1; 0; 0]; [:: 0; 0; 0; 1]; [:: 0; 0; 1; 0]]}).
Proof.
  apply/eqP; apply/matrixP; intros x y; rewrite !mxE; rewrite !big_ord_recl; rewrite big_ord0; rewrite !mxE.
  destruct x as [[ | [ | [ | [ | x]]]] Hx]; destruct y as [[ | [ | [ | [ | y]]]] Hy]; simpl;
  try (absurd (x.+4 < 4)%N; auto); try (absurd (y.+4 < 4)%N; auto);
  try repeat (rewrite !mulr0 || rewrite !mul0r || rewrite !addr0 || rewrite !add0r || rewrite !mulr1 || rewrite !oppr0 || reflexivity).
Qed.
Canonical cnot_gate := (@Gate 2 _ cnot_gateP).

(* Here we begin the definitions pertaining to measurement. *)

(* A binary predicate to select the parts of a qubit vector that represent a specific qubit measuring as 1.
   In a 3-qubit vector, which has 8 elements, the elements represent P(|000>), P(|001>), P(|010>), ..., P(|111>).
   Therefore, the elements representing bit 1 (counting from 0) measuring as 1 are elements 2, 3, 6 and 7
   (if we start counting at 0).
   i.e. the elements n where n modulo 4 is 2 or 3 *)
Definition select n (i: 'I_(2^n)) (bit: 'I_n) :=
  (i %% (2^(bit + 1)) >= 2^bit)%N.

(* The probabilities that qubit b of qubit vector q measures as 0 or 1 respectively. *)

Local Open Scope complex_scope.
Definition prob_0 {n} b q: R :=
  \sum_(i < 2^n | ~~select i b) (normc ((vector q) i 0)) ^+ 2.

Definition prob_1 {n} b q: R :=
  \sum_(i < 2^n | select i b) (normc ((vector q) i 0)) ^+ 2.

(* The new qubit vectors that result after measuring bit b of qubit vector q and getting 0 or 1 respectively. *)
Definition measure_0 n (b: 'I_n) (q: qubit_vector_of n) :=
  if prob_0 b q == 0
  then (vector q)
  else (\col_(i < 2^n)
     if ~~(select i b)
     then (vector q) i 0 / sqrtc (prob_0 b q)%:C
     else 0).

Definition measure_1 n (b: 'I_n) (q: qubit_vector_of n) :=
  if prob_1 b q == 0
  then (vector q)
  else (\col_(i < 2^n)
      if select i b
      then (vector q) i 0 / sqrtc (prob_1 b q)%:C
      else 0).

(* The proofs that these new vectors are unitary. *)
Lemma measure_aux: forall I (r: seq I) P (F: I -> R[i]),
  (\sum_(i <- r | P i) `|F i|^+2) \is a GRing.unit ->
  \sum_(i <- r | P i) (`|F i / sqrtc (\sum_(i <- r | P i) `|F i|^+2)|^+2) == 1.
Proof.
  intros I r P F; destruct r;
  [ rewrite !big_nil; intros H; absurd (((0:R)%:C)%C \is a GRing.unit);
    [ rewrite unitr0 //
    | apply H
    ]
  | rewrite !big_cons; destruct (P i); intros H;
    [ rewrite normf_div; rewrite expr_div_n; replace (\sum_(j <- r | P j) `|F j / sqrtc _| ^+ 2) with
      (\sum_(j <- r | P j) `|F j| ^+ 2 / `|sqrtc (`|F i| ^+ 2 + \sum_(j0 <- r | P j0) `|F j0| ^+ 2)| ^+ 2);
      [ rewrite -mulr_suml; rewrite -mulrDl; rewrite sqrtc_norm;
        [ rewrite divrr //; apply H
        | apply addr_ge0; [ apply exprn_ge0; apply normr_ge0 | apply sumr_ge0; intros x _; apply exprn_ge0; apply normr_ge0 ]
        ]
      | apply eq_bigr; intros x _; rewrite Num.Theory.normf_div; rewrite expr_div_n //
      ]
    | replace (\sum_(j <- r | P j) `|F j / sqrtc _| ^+ 2) with
      (\sum_(j <- r | P j) `|F j|^+2 / `|sqrtc (\sum_(j0 <- r | P j0) `|F j0|^+2)|^+2);
      [ rewrite -mulr_suml; rewrite sqrtc_norm;
        [ rewrite divrr //; apply H
        | apply sumr_ge0; intros x _; apply exprn_ge0; apply normr_ge0
        ]
      | apply eq_bigr; intros x _; rewrite normf_div; rewrite expr_div_n //
      ]
    ]
  ].
Qed.

Lemma blerp3: forall x: R,
  x%:C = 0 -> x = 0.
Proof.
  intros. transitivity (complex.Re (x%:C)).
    auto.
    assert (x%:C == 0). apply/eqP. apply H.
    rewrite (eq_complex x%:C 0) in H0.
    destruct (proj1 (andP _ _) H0).
    rewrite H. auto.
Qed.

Lemma measure0_unitary: forall n b q,  \sum_(i < 2^n) `|(measure_0 b q) i 0|^+2 == 1.
Proof.
  move=> n b q. unfold measure_0. unfold prob_0.
  destruct (\sum_(i0 < 2^n | ~~select i0 b) (normc ((vector q) i0 0)) ^+ 2 == 0) eqn:H.
    rewrite H; apply (vector_is_unit q).
    rewrite H. replace (\sum_(i < 2 ^ n) _) with
      (\sum_(i < 2^n) (if ~~select i b then `|vector q i 0 / sqrtc (\sum_(i1 < 2 ^ n | ~~select i1 b) `|(vector q) i1 0| ^+2)| ^+ 2 else 0)).
    rewrite -!big_mkcond. apply measure_aux. rewrite unitfE.
    assert ((\sum_(i < 2^n | ~~select i b) (normc ((vector q) i 0)) ^+ 2)%:C =
       \sum_(i < 2^n | ~~select i b) `|q i 0| ^+ 2).
      rewrite -rcsum. apply eq_bigr. intros. rewrite normc_equiv. rewrite !expr2. simpc. reflexivity.
    rewrite -H0. apply/eqP. intro.
    apply Bool.eq_true_false_abs with (\sum_(i0 < 2^n|~~select i0 b) normc (q i0 0) ^+ 2 == 0).
    apply/eqP. apply blerp3. apply H1. apply H.
    apply eq_bigr. intros i _. rewrite mxE.
    destruct (~~select i b).
       repeat f_equal. rewrite -rcsum. apply eq_bigr. intros. (* here *)
       rewrite normc_equiv. rewrite !real_complexE. rewrite !expr2. simpc. reflexivity.
    auto; rewrite normr0; rewrite expr0n //.
Qed.

Lemma measure1_unitary: forall n b q,
  \sum_(i < 2^n) `|(measure_1 b q) i 0|^+2 == 1.
Proof.
  move=> n b q. unfold measure_1. unfold prob_1.
  destruct (\sum_(i0 < 2^n | select i0 b) (normc ((vector q) i0 0)) ^+ 2 == 0) eqn:H.
    rewrite H; apply (vector_is_unit q).
    rewrite H; replace (\sum_(i < 2 ^ n) _) with
    (\sum_(i < 2^n) (if select i b then `|vector q i 0 / sqrtc (\sum_(i1 < 2 ^ n | select i1 b) `|(vector q) i1 0| ^+2)| ^+ 2 else 0)).
  rewrite -!big_mkcond. apply measure_aux. rewrite unitfE.
  assert ((\sum_(i < 2^n | select i b) (normc ((vector q) i 0)) ^+ 2)%:C =
       \sum_(i < 2^n | select i b) `|q i 0| ^+ 2).
    rewrite -rcsum. apply eq_bigr. intros. rewrite normc_equiv. rewrite !expr2. simpc. reflexivity.
    rewrite -H0. apply/eqP. intro.
    apply Bool.eq_true_false_abs with (\sum_(i0 < 2^n|select i0 b) normc (q i0 0) ^+ 2 == 0).
    apply/eqP. apply blerp3. apply H1. apply H.
  apply eq_bigr; intros i _; rewrite mxE; destruct (select i b);
  [ repeat f_equal; rewrite -rcsum; apply eq_bigr; intros;
    rewrite normc_equiv; rewrite !real_complexE; rewrite !expr2; simpc; reflexivity
  | auto; rewrite normr0; rewrite expr0n //
  ].
Qed.

(* The measure function. measure_p b q returns a tuple of two pairs; the first element of each pair is the
 * probability that bit b of qubit vector q is 0 or 1 respectively; the second element of each pair is the
 * new qubit vector that results in each case. *)
Definition measure_p (n: nat)  (b: 'I_n) (q: qubit_vector_of n):
           (R * qubit_vector_of n) * (R * qubit_vector_of n) :=
  ((prob_0 b q, (QubitVector (measure0_unitary b q))),
   (prob_1 b q, (QubitVector (measure1_unitary b q)))).

(* Qubit vector casting. If m = n, then the datatypes (qubit_vector m) and (qubit_vector n) are interchangeable. *)
Lemma castP:
  forall m q n (Heq: m = n), \sum_(i < 2^n) `|(castmx (f_equal (expn 2) Heq, (eq_S 0 0 (eqP (eq_refl 0)))%N) (vector q)) i 0| ^+ 2 == 1.
Proof.
  intros. rewrite <- (eqP (vector_is_unit q)).
  apply/eqP. apply sum_cast with (f_equal (expn 2) (sym_eq Heq)).
    auto.
    intros. rewrite castmxE. rewrite cast_ord_id.
      unfold cast_ord. repeat f_equal. apply eq_irrelevance.
Qed.
Canonical cast m q n Heq := (@QubitVector n _ (@castP m q n Heq)).

Lemma cast_id: forall n (h: qubit_vector_of n) (Heq: n = n),
  cast h Heq = h.
Proof.
  intros; destruct h as [h Hh]. unfold cast. apply val_inj; simpl; apply castmx_id.
Qed.

Lemma cast_irrelevance: forall n (h: qubit_vector_of n) n' (H1 H2: n = n'),
  cast h H1 = cast h H2.
Proof.
  intros. apply val_inj; simpl. apply/matrixP. intros i j. rewrite !castmxE. unfold cast_ord. simpl.
  rewrite (ordinal_eq (cast_ord_proof i (esym (f_equal (expn 2) H1))) (cast_ord_proof i (esym (f_equal (expn 2) H2)))).
    reflexivity. reflexivity.
Qed.

(* Qubit vector combination. An m-qubit vector and an n-qubit vector can be combined (by taking their tensor
 * product) into an m+n-qubit vector. *)
Lemma combineP:
  forall m n q1 q2, \sum_(i < 2^(m+n)) `|(castmx (sym_eq (expnD 2 m n), (eq_S 0 0 (eqP (eq_refl 0)))%N) (vector q1 *t vector q2)) i 0| ^+ 2 == 1.
Proof.
  intros m n q1 q2. apply/eqP.
  replace (\sum_(i < 2^(m+n)) _) with
    (\sum_(i < 2^m * 2^n) `|(vector q1 *t vector q2) i 0| ^+ 2).
  transitivity (\sum_(i < 2^m*2^n) `|vector q1 (mxtens_unindex i).1 (mxtens_unindex (m:=1) (n:=1) 0).1| ^+ 2 * `|vector q2 (mxtens_unindex i).2 (mxtens_unindex (m:=1) (n:=1) 0).2| ^+ 2).
  apply eq_bigr; intros i _; rewrite mxE. rewrite normrM. rewrite exprMn //.
  destruct q1 as [q1 Hq1]; destruct q2 as [q2 Hq2].
  rewrite -(mulr_sum (fun x => `|q1 x (mxtens_unindex (m:=1) (n:=1) 0).1| ^+ 2) (fun x => `|q2 x (mxtens_unindex (m:=1) (n:=1) 0).2| ^+ 2)).
  rewrite sum_mul_dist. simpl.
  (* This can probably be done in a much easier way, but you know... *)
  replace (\sum_(j<2^n) `|q2 j _|^+2) with (1:R[i]).
  rewrite (eq_bigr _ (fun P x => mulr1 _)).
  replace (\sum_(i<2^m) `|q1 i _|^+2) with (1:R[i]). reflexivity.
    rewrite -(eqP Hq1). apply eq_bigr. intros i _. replace (q1 i 0) with (q1 i (Ordinal (mxtens_index_proof1 (m:=1) (n:=1) 0))).
      reflexivity. transitivity (q1 i (Ordinal (ltn0Sn 0))). replace (Ordinal (ltn0Sn 0)) with (Ordinal (mxtens_index_proof1 (m:=1) (n:=1) 0)).
      reflexivity. apply/val_eqP. simpl. auto.
      reflexivity.
    rewrite -(eqP Hq2). apply eq_bigr. intros i _. replace (q2 i 0) with (q2 i (Ordinal (mxtens_index_proof2 (m:=1) (n:=1) 0))).
      reflexivity. transitivity (q2 i (Ordinal (ltn0Sn 0))). replace (Ordinal (ltn0Sn 0)) with (Ordinal (mxtens_index_proof2 (m:=1) (n:=1) 0)).
      reflexivity. apply/val_eqP. simpl. auto.
      reflexivity.
    apply sum_cast with (sym_eq (expnD 2 m n)). auto. intros. rewrite castmxE. rewrite cast_ordK. rewrite cast_ord_id. reflexivity.
Qed.
Canonical combine m n q1 q2 := (@QubitVector (m+n) _ (@combineP m n q1 q2)).

Lemma combine0q: forall n, left_id zero_qubit (@combine 0 n).
Proof.
  intros n x; destruct x as [x Hx]; unfold combine.
  apply val_inj. simpl. rewrite tens_scalar1mx. rewrite castmx_comp. apply/matrixP.
  intros i j. rewrite !castmxE. simpl; f_equal; apply cast_ord_id.
Qed.

Lemma combineq0: forall n q, (@combine n 0 q zero_qubit) = (cast q (sym_eq (addn0 n))).
Proof.
  intros n x; destruct x as [x Hx]; unfold cast; unfold combine.
  apply val_inj; simpl. rewrite tens_mx_scalar. rewrite castmx_comp. apply/matrixP.
  intros i j. rewrite !castmxE. simpl. rewrite scale1r. f_equal; unfold cast_ord; f_equal; apply eq_irrelevance.
Qed.

Lemma combineA: forall m n k (h: qubit_vector_of m) (h': qubit_vector_of n) (q: qubit_vector_of k) H,
 cast (combine (combine h h') q) H = combine h (combine h' q).
Proof.
  intros. apply val_inj; simpl. rewrite !castmx_comp. apply/matrixP. intros i j. rewrite !castmxE.
  rewrite !mxE. rewrite !castmxE. rewrite !mxE. simpl. rewrite mulrA. f_equal. f_equal.
    rewrite (ordinal_eq (mxtens_index_proof1 (cast_ord (esym (Logic.eq_sym (expnD 2 m n)))
           (Ordinal
              (mxtens_index_proof1
                 (cast_ord (esym (etrans (Logic.eq_sym (expnD 2 (m + n) k)) (f_equal (expn 2) H))) i)))))
      (mxtens_index_proof1 (cast_ord (esym (Logic.eq_sym (expnD 2 m (n + k)))) i))).
    rewrite (ordinal_eq
       (@mxtens_index_proof1 1 1
        (@cast_ord 1 1 (@esym nat 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0))))%N
           (@Ordinal 1 (j %/ 1)
              (@mxtens_index_proof1 1 1
                 (@cast_ord 1 1
                    (@esym nat 1 1
                       (@etrans nat 1 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0)))
                          (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0)))))%N j)))))
       (@mxtens_index_proof1 1 1 (@cast_ord 1 1 (@esym nat 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0))))%N j))).
    reflexivity.
      rewrite divn1 //.
      simpl. rewrite -divnMA. rewrite (mulnC (2^k) (2^n))%N. rewrite (expnD 2 n k). reflexivity.
    rewrite (ordinal_eq (mxtens_index_proof2
        (cast_ord (esym (Logic.eq_sym (expnD 2 m n)))
           (Ordinal
              (mxtens_index_proof1
                 (cast_ord (esym (etrans (Logic.eq_sym (expnD 2 (m + n) k)) (f_equal (expn 2) H))) i)))))
      (mxtens_index_proof1
        (cast_ord (esym (Logic.eq_sym (expnD 2 n k)))
           (Ordinal (mxtens_index_proof2 (cast_ord (esym (Logic.eq_sym (expnD 2 m (n + k)))) i)))))).
    rewrite (ordinal_eq (@mxtens_index_proof2 1 1
        (@cast_ord 1 1 (@esym nat 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0))))%N
           (@Ordinal 1 (j %/ 1)
              (@mxtens_index_proof1 1 1
                 (@cast_ord 1 1
                    (@esym nat 1 1
                       (@etrans nat 1 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0)))
                          (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0)))))%N j)))))
     (@mxtens_index_proof1 1 1
        (@cast_ord 1 1 (@esym nat 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0))))%N
           (@Ordinal 1 (j %% 1)
              (@mxtens_index_proof2 1 1
                 (@cast_ord 1 1 (@esym nat 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0))))%N j)))))).
      reflexivity.
        simpl. rewrite !divn1 //.
        simpl. rewrite (expnD 2 n k). rewrite !modn_def. case: edivnP => p r. case: edivnP => p' r'. simpl. intros.
          rewrite e in e0. rewrite mulnA in e0. rewrite divnMDl in e0. symmetry. apply (blerp e0).
          rewrite ltn_divLR. apply (implP i0). rewrite muln_gt0. apply <- andP. split.
            rewrite expn_gt0. apply orP. left; auto.
            rewrite expn_gt0. apply orP. left; auto.
            rewrite expn_gt0. apply orP. left; auto.
            apply (implP i1).            rewrite expn_gt0. apply orP. left; auto.
            rewrite expn_gt0. apply orP. left; auto.
  rewrite (ordinal_eq (mxtens_index_proof2 (cast_ord (esym (etrans (Logic.eq_sym (expnD 2 (m + n) k)) (f_equal (expn 2) H))) i))
   (mxtens_index_proof2
        (cast_ord (esym (Logic.eq_sym (expnD 2 n k)))
           (Ordinal (mxtens_index_proof2 (cast_ord (esym (Logic.eq_sym (expnD 2 m (n + k)))) i)))))).
  rewrite (ordinal_eq (@mxtens_index_proof2 1 1
        (@cast_ord 1 1
           (@esym nat 1 1
              (@etrans nat 1 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0)))
                 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0)))))%N j))
(@mxtens_index_proof2 1 1
        (@cast_ord 1 1 (@esym nat 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0))))%N
           (@Ordinal 1 (j %% 1)
              (@mxtens_index_proof2 1 1
                 (@cast_ord 1 1 (@esym nat 1 1 (eq_S 0 0 ((@eqP nat_eqType 0 0) (eqxx 0))))%N j)))))).
    reflexivity.
       simpl. rewrite !modn1 //.
       simpl. rewrite (expnD 2 n k). symmetry. apply modn_dvdm. apply dvdn_mull. apply dvdnn.
Qed.

Lemma blerp2: forall n k: nat, (k = 0 -> n = n + k)%N.
Proof.
  intros. rewrite H. symmetry. apply addn0.
Qed.
Lemma gnarf: forall n k k', k = k'.+1 -> (n + 1 + k' = n + k)%N.
Proof.
  intros. rewrite H. rewrite (addnS n k'). rewrite addnAC. rewrite addn1 //.
Qed.
Lemma znoits: forall k k', k = k'.+1 -> k.-1 = k'.
Proof.
  intros. rewrite H. reflexivity.
Qed.

(* Combine a list of k 1-qubit vectors into one k-qubit vector. We use the 0-qubit vector as an initial value
   here, as it is the neutral element of the tensor product. *)
Fixpoint combine_tuple_aux (n: nat) (q: qubit_vector_of n) (k: nat) (l: k .-tuple (qubit_vector_of 1)) { struct k }: (qubit_vector_of (n+k)) :=
  (match k as m return (k = m) -> _ with
  | 0     => fun H: (k = 0)%N =>
             cast q (blerp2 n H)
  | k'.+1 => fun H: k = k'.+1 =>
             cast (combine_tuple_aux (combine q (thead (tcast H l))) (tcast (znoits H) (behead_tuple l))) (gnarf n H)
  end) (Logic.eq_refl k).

Definition combine_tuple (k: nat) (l: k.-tuple (qubit_vector_of 1)): (qubit_vector_of k) :=
  (combine_tuple_aux zero_qubit l).

Lemma combine_tuple_rec: forall (k: nat) (n: nat) (h: qubit_vector_of n) (t: k.-tuple (qubit_vector_of 1)),
  combine_tuple_aux h t = combine h (combine_tuple t).
Proof.
  intros. unfold combine_tuple. generalize n h; clear n h; induction k; intros n h;
  [ simpl; rewrite !cast_id; rewrite combineq0; f_equal; apply eq_irrelevance
  |
  ].
  simpl. rewrite !cast_id. rewrite !tcast_id. generalize t; clear t; case/tupleP. intros h' t.
    rewrite !theadE. rewrite behead_tupleE. rewrite combine0q.
    rewrite IHk. rewrite IHk. rewrite combine0q. rewrite (IHk [tuple of t] (1%N) h').
    rewrite -(combineA h h'). apply cast_irrelevance.
Qed.

(*Lemma combine_tupleE: forall k (l: k.-tuple (qubit_vector_of 1)) i,
  vector (combine_tuple l) i 0 =
  \prod_(n < k) (vector (tnth l n)) (if (select i n) then 1 else 0) 0. *)

(* Definition of decomposability. A qubit vector is decomposable if it can be written as the combination of
 * two qubit vectors. It is maximally decomposable if it can be written as a combination of 1-qubit vectors. *)
Definition decomposable_aux (p: nat) (q: qubit_vector_of p) (n m: nat) (Heq: (n + m = p)%N) :=
  exists (q1: qubit_vector_of n) (q2: qubit_vector_of m),
  (cast (combine q1 q2) Heq) = q.

Definition decomposable (p: nat) (q: qubit_vector_of p) :=
  exists n m Heq, (@decomposable_aux p q n m Heq).

Definition maximally_decomposable (n: nat) (q: qubit_vector_of n) :=
  exists (l: n.-tuple (qubit_vector_of 1)), combine_tuple l = q.

(* Definition of entanglement. A qubit vector is entangled if there are two qubits b1 and b2 such that measuring
 * b1 influences the probability distribution of measuring b2. It is maximally entangled if all qubits in the
 * vector influence each other. It is disentangled if no qubits in the vector influence each other. *)
Definition disentangled_aux (n: nat) (b1 b2: 'I_n) (q: qubit_vector_of n) :=
  prob_0 b1 (QubitVector (measure0_unitary b2 q)) = prob_0 b1 (QubitVector (measure1_unitary b2 q)) /\
  prob_1 b1 (QubitVector (measure0_unitary b2 q)) = prob_1 b1 (QubitVector (measure1_unitary b2 q)).

Definition disentangled (n: nat) (q: qubit_vector_of n) :=
  forall b1 b2, disentangled_aux b1 b2 q.

Definition maximally_entangled (n: nat) (q: qubit_vector_of n) :=
  forall b1 b2, ~disentangled_aux b1 b2 q.

Lemma frob:
  forall n q b, ~(\sum_(i < 2^n | ~~select i b) `|(vector q) i 0| ^+2 == 0 /\
                  \sum_(i < 2^n | select i b) `|(vector q) i 0| ^+ 2 == 0).
Proof.
  intros. intro X. destruct X.
  absurd ((GRing.one (ComplexField.complex_numDomainType R)) == 0 + 0).
    intro. rewrite add0r in H1. rewrite oner_eq0 in H1. inversion H1.
  rewrite -{1}(eqP H). rewrite -{2}(eqP H0).
  rewrite sum_if_not. apply/eqP. symmetry. apply/eqP. apply (vector_is_unit q).
Qed.

(* Entanglement and decomposability are equivalent. *)
(* Theorem decdis n (q: qubit_vector_of n):
  maximally_decomposable q -> disentangled q. *)


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

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

Print Assumptions carry.


Require Import List Bool DFA NFA.

Import ListNotations.

Definition swap_alpha_trans {A B C : Type} (M : dfa A (B * C)) (q : A) (x : C * B) : A :=
  match x with
  | (c,b) => t M q (b,c)
  end.

Definition swap_alpha_dfa {A B C : Type} (M : dfa A (B * C)) : dfa A (C * B) :=
  Build_dfa A (C * B) (swap_alpha_trans M) (s M) (F M).

Definition swap {B C : Type} (xs : list (B * C)) : list (C * B) :=
  map (fun letter =>
    match letter with
    | (b,c) => (c,b)
    end) xs.

Lemma swap_app :
  forall {B C : Type} (b : B) (c : C) (xs : list (B * C)),
    swap (xs ++ [(b,c)]) = swap xs ++ [(c,b)].
Proof.
intuition.
induction xs.
intuition.
simpl.
rewrite IHxs.
reflexivity.
Qed.

Lemma swap_alpha_mirror
  {A B C : Type} (M : dfa A (B * C)) :
    forall (str : list (B * C)),
      tStar (swap_alpha_dfa M) (s (swap_alpha_dfa M)) (swap str) = tStar M (s M) str.
Proof.
apply rev_ind.
intuition.
intuition.
rewrite tStar_step.
rewrite swap_app.
rewrite tStar_step.
simpl.
rewrite <- H.
intuition.
Qed.

Theorem swap_alpha_correct
  {A B C : Type} (M : dfa A (B * C)) :
    forall (str : list (B * C)),
      accepted (swap_alpha_dfa M) (swap str) = true <-> accepted M str = true.
Proof.
apply rev_ind.
intuition.

intuition.

unfold accepted.
rewrite tStar_step.
unfold accepted in H.
rewrite <- swap_alpha_mirror.
rewrite swap_app in H.
rewrite tStar_step in H.
intuition.

unfold accepted in H.
rewrite tStar_step in H.
unfold accepted.
rewrite swap_app.
rewrite tStar_step.
rewrite <- swap_alpha_mirror in H.
intuition.
Qed.

Definition exist_dfa_trans {A B : Type} (M : dfa A (B * C))

Definition exist_quant_dfa
  {A B C : Type} (M : dfa A (B * C)) : dfa A B :=
    Build_dfa A B.


Require Import nat.
Require Import list.
Require Import syntax.
Require Import state.
Require Import ISA.
Require Import compile.

Example test_compile1 :
  s_compile (AMinus (AKey x) (AMult (ANum 2) (AKey y))) =
  [SLoad x, SPush 2, SLoad y, SMult, SMinus].
Proof. reflexivity. Qed.


Require Import Ascii.
Require Import List.

Inductive reg_exp : Type :=
| EmptySet : reg_exp
| Epsilon : reg_exp
| Lit : ascii -> reg_exp
| App : reg_exp -> reg_exp -> reg_exp
| Union : reg_exp -> reg_exp -> reg_exp
| Star : reg_exp -> reg_exp.

Inductive std_reg_exp : Type :=
| SEmptySet : std_reg_exp
| SLit : ascii -> std_reg_exp
| SApp : std_reg_exp -> std_reg_exp -> std_reg_exp
| SUnion : std_reg_exp -> std_reg_exp -> std_reg_exp
| SPlus : std_reg_exp -> std_reg_exp.

Inductive inL : list ascii -> reg_exp -> Prop :=
| inEpsilon : inL nil Epsilon
| inLit : forall c, inL (c :: nil) (Lit c)
| inApp : forall l1 l2 r1 r2,
    inL l1 r1 -> inL l2 r2 -> inL (l1 ++ l2) (App r1 r2)
| inUnion : forall l r1 r2,
    inL l r1 /\ inL l r2 -> inL l (Union r1 r2)
| inStar0 : forall r, inL nil r -> inL nil (Star r)
| inStar : forall l1 l2 r,
    inL l1 r -> inL l2 (Star r) -> inL (l1 ++ l2) (Star r).

Inductive inLS : list ascii -> std_reg_exp -> Prop :=
| inLitS : forall c, inLS (c :: nil) (SLit c)
| inAppS : forall l1 l2 r1 r2,
    inLS l1 r1 -> inLS l2 r2 -> inLS (l1 ++ l2) (SApp r1 r2)
| inUnionS : forall l r1 r2,
    inLS l r1 /\ inLS l r2 -> inLS l (SUnion r1 r2)
| inPlus1S : forall l r, inLS l r -> inLS l (SPlus r)
| inPlusS : forall l1 l2 r,
    inLS l1 r -> inLS l2 (SPlus r) -> inLS (l1 ++ l2) (SPlus r).

Lemma nil_append : forall l1 l2 : list ascii,
    l1 ++ l2 = nil -> l1 = nil /\ l2 = nil.
Proof. intros. induction l1. induction l2.
  auto.
  + simpl in *. auto.
  + simpl in *. inversion H.
Qed.

Lemma non_empty : forall r, ~ (inLS nil r).
Proof. intros r i. induction r.
  + inversion i.
  + inversion i.
  + inversion i. subst. destruct (nil_append l1 l2 H).
    subst. auto.
  + inversion i. destruct H1. auto.
  + inversion i.
    - auto.
    - destruct (nil_append l1 l2 H). subst. auto.
Qed.

(* Suffix *)

Inductive suffix : list ascii -> list ascii -> Prop :=
| stop : forall x xs, suffix xs (x :: xs)
| drop : forall y xs ys, suffix xs ys -> suffix xs (y :: ys).

Lemma suffix_trans : forall xs ys zs,
    suffix xs ys -> suffix ys zs -> suffix xs zs.
Proof. intros. induction H0; constructor; auto. Qed.

Lemma suffix_nil_cons : forall x xs, suffix nil (x :: xs).
Proof. intros x xs.
  generalize dependent x.
  induction xs as [|y ys].
  + constructor.
  + intro x. constructor. apply (IHys y).
Qed.

(* Recursion permission *)

Inductive recursion_permission : list ascii -> Prop :=
| can_rec : forall ys, (forall xs, suffix xs ys -> recursion_permission xs)
          -> recursion_permission ys.

Lemma perm_suffix_nil : forall xs,
    suffix xs nil -> recursion_permission xs.
Proof. intros xs sf. inversion sf. Qed.

Lemma perm_suffix : forall y xs ys,
    suffix xs (y :: ys)
    -> recursion_permission ys
    -> recursion_permission xs.
Proof. intros y xs ys sf perm.
  remember sf as wit1 in sf.
  destruct sf eqn:wit3.
  Admitted.

Lemma well_founded : forall ys, recursion_permission ys.
Proof. intros ys. induction ys; constructor.
  + apply perm_suffix_nil.
  + intros xs sf. apply (perm_suffix _ _ _ sf IHys).
Qed.

(* Matcher *)

Definition bmatch : forall (r : std_reg_exp) (s : list ascii),
                    ({s' | suffix s' s} -> bool)
                  -> recursion_permission s
                  -> bool.
Proof. intros r.
  induction r.
  + (* EmptySet *) intros. apply false.
  + (* Lit *) intros s k perm.
    induction s as [|x xs].
    - apply false.
    - destruct (ascii_dec x a).
      * apply k. exists xs. apply stop.
      * apply false.
  + (* App *) intros s k perm.
    apply (IHr1 s).
    - intros [s' sf].
      apply (IHr2 s').
      * intros [s'' sf'].
        apply k. exists s''. apply (suffix_trans s'' s' s); auto.
      * destruct perm as [ys f]. auto.
    - apply perm.
  + (* Union *)intros s k perm.
    apply (orb (IHr1 s k perm) (IHr2 s k perm)).
  + (* Plus *) intros s k perm.
    apply (orb (IHr s k perm)).
    (* Plus multiple case *)
    apply (IHr s).
    - intros [s' sf].
      apply (IHr s').
      * intros [s'' sf'].
        apply k. exists s''. apply (suffix_trans s'' s' s); auto.
      * destruct perm as [ys f]. auto.
    - apply perm.
Qed.

Theorem match_soundness : forall r s k perm,
     bmatch r s k perm = true
     -> exists p, exists s', exists sf,
          (p ++ s' = s) /\ (inLS p r) /\ (k (exist _ s' sf) = true).
Proof. intros r s k perm eq.
  induction r.
  + destruct s as [|x xs].
    -
Admitted.

Conjecture match_completeness : forall r s k perm,
      (exists p, exists s', exists sf,
          (p ++ s' = s) /\ (inLS p r) /\ (k (exist _ s' sf) = true))
     -> bmatch r s k perm = true.

Definition null (l : list ascii) : bool :=
  match l with | nil => true | _ :: _ => false end.

Definition acceptsS (r : std_reg_exp) (s : list ascii) : bool :=
  bmatch r s (fun H => let (s', _) := H in null s') (well_founded s).

Theorem acceptsS_soundness : forall r s,
    acceptsS r s = true
    -> inLS s r.
Proof. intros r s eq.
  destruct (match_soundness r s _ _ eq)
        as [p [s' [sf [app [i keq]]]]].
  assert (emp : s' = nil).
  Focus 2.
  subst. rewrite (app_nil_r p). assumption.
  destruct s' as [|b bs]. auto. inversion keq.
Qed.

Theorem acceptsS_completeness : forall r s,
    inLS s r
    -> acceptsS r s = true.
Proof. intros r s i. destruct s as [|x xs].
  + destruct (non_empty r i).
  + apply match_completeness.
    exists (x :: xs). exists nil. exists (suffix_nil_cons _ _).
    split. apply (app_nil_r _). auto.
Qed.


From PetitC Require Import Ids Values Tactics.

From Coq Require Import FSets.FMapAVL Structures.OrderedTypeEx ZArith Program.Wf Lia Lists.List.

Module OffsetMap := FMapAVL.Make Z_as_OT.

Definition heap_block : Type := OffsetMap.t value.

Definition stack : Type := OffsetMap.t value.

Definition heap : Type := BlockIdMap.t heap_block.

Definition memory : Type := stack * heap.

Inductive read : memory -> ptr_value -> value -> Prop :=
  | ReadStack offset value stack heap :
        OffsetMap.find offset stack = Some value ->
      read (stack, heap) (StackPtr offset) value

  | ReadHeap block_id block offset value stack heap :
        BlockIdMap.find block_id heap = Some block ->
        OffsetMap.find offset block = Some value ->
    read (stack, heap) (HeapPtr block_id offset) value.

Definition word_size : nat := 8.

Definition divisible (x y : Z) : Prop := exists q, (y = x * q)%Z.

Definition alligned (offset : offset) : Prop := divisible (Z.of_nat word_size) offset.

Inductive write : memory -> ptr_value -> value -> memory -> Prop :=
  | WriteStack offset value stack heap :
        (offset <= 0)%Z ->
        alligned offset ->
      write (stack, heap) (StackPtr offset) value (OffsetMap.add offset value stack, heap)

  | WriteHeap block_id block offset value stack heap :
        BlockIdMap.find block_id heap = Some block ->
        OffsetMap.In offset block ->
      write (stack, heap) (HeapPtr block_id offset) value
        (stack, BlockIdMap.add block_id (OffsetMap.add offset value block) heap).

Program Fixpoint fresh_heap_block (size : nat) {measure size}: heap_block :=
  match size with
  | 0 => OffsetMap.empty _
  | _ => if size <? word_size
         then OffsetMap.empty _
         else OffsetMap.add (Z.of_nat (size / word_size * word_size))
                            Undef
                            (fresh_heap_block (size - word_size))
  end.

Next Obligation. unfold word_size. lia. Qed.

Definition unused_block_id (heap : heap) : block_id :=
  BlockIdMap.fold (fun block_id _ acc => max (1 + block_id) acc) heap 0.

Definition unused_offset (stack : stack) : offset :=
  OffsetMap.fold (fun offset _ acc => Z.min (offset - Z.of_nat word_size)%Z acc) stack 0%Z.

Definition malloc (mem : memory) (size : nat) : ptr_value * memory :=
  let '(stack, heap) := mem in
  let block_id := (unused_block_id heap) in
  let new_heap := BlockIdMap.add block_id (fresh_heap_block size) heap in
  (HeapPtr block_id 0%Z, (stack, new_heap)).

Definition allocate_stack (mem : memory) : ptr_value * memory :=
  let '(stack, heap) := mem in
  let offset := unused_offset stack in
  let new_stack := OffsetMap.add offset Undef stack in
  (StackPtr offset, (new_stack, heap)).


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func_Prop.
From Categories Require Import Functor.Functor_Extender.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat
     Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
From Categories Require Import Adjunction.Adjunction Adjunction.Duality
     Adjunction.Adj_Facts.
From Categories Require Import KanExt.Global.

(** In this module we establish the dualit of kan extensions.
That is, the left kan extension along p is just the right kan extension along
pᵒᵖ and vice versa.
 *)
Section GlobalDuality.
  Context {C C' : Category} (p : (C --> C')%functor) (D : Category).

  (** We establish this duality though hom functor definition of adjunction. *)

  Local Obligation Tactic := idtac.

  Section Left_to_Right.
    Context (lke : Left_KanExt p D).

    (** The natural Isomorphism underlying the right kan extension which is to
        be shown.
        Hom_{Func_Cat Cᵒᵖ Dᵒᵖ}(– ∘ p, –) ≃ Hom_{Func_Cat C'ᵒᵖ Dᵒᵖ}(–, lkeᵒᵖ)
    *)
    Local Definition KanExt_Left_to_Right_NIso :=
      (
        (
          (
            ((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C' D))
               ∘_h (NatTrans_id_Iso
                      (Prod_Functor
                         (Functor_id ((Func_Cat C' D) ^op) ^op) (lke^op)))
            )
              ∘ (Hom_Adjunct_Duality (Adj_to_Hom_Adj (left_kan_ext_adj lke)))
          )
            ∘ (((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C D))⁻¹)
                 ∘_h (NatTrans_id_Iso
                        (Prod_Functor
                           (Left_Functor_Extender p D)
                           (Functor_id (Func_Cat C D) ^op))))
        )
          ∘_h (NatTrans_id_Iso
                 (Prod_Functor
                    ((inverse_morphism (Func_Cat_Op_Iso C' D))^op)
                    (inverse_morphism (Func_Cat_Op_Iso C D))
                 )
              )
      )%natiso.

    (** If we give the trans formations (e.g., function given in the first
        obligation) explicitly "Program" generates obligations for
        equalities that are definitional! *)

    Program Definition KanExt_Left_to_Right :
      Right_KanExt  (p^op) (D^op) :=
      {|
        right_kan_ext :=
          ((Op_Func_Cat_to_Func_Cat_Op C' D) ∘
          (lke^op ∘ (Func_Cat_Op_to_Op_Func_Cat C D)))%functor;
        right_kan_ext_adj :=
          Hom_Adj_to_Adj
            {|
              iso_morphism :=
                {|
                  Trans := _
                |};
              inverse_morphism :=
                {|
                  Trans := _
                |}
            |}
      |}.

    Next Obligation.
    Proof.
      exact (fun c => Trans (iso_morphism KanExt_Left_to_Right_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h; simpl.
      set (w := Trans_com (iso_morphism KanExt_Left_to_Right_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      rewrite NatTrans_hor_comp_Op.
      repeat rewrite <- NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry; simpl.
      apply KanExt_Left_to_Right_obligation_2.
    Qed.

    Next Obligation.
    Proof.
      exact (fun c => Trans (inverse_morphism KanExt_Left_to_Right_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h; simpl.
      set (w := Trans_com (inverse_morphism KanExt_Left_to_Right_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      rewrite NatTrans_hor_comp_Op.
      repeat rewrite <- NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry; simpl.
      apply KanExt_Left_to_Right_obligation_5.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; simpl.
      match goal with
        [|- _ = ?A] =>
        let w := constr:((
                   ((KanExt_Left_to_Right_NIso ⁻¹)
                      ∘ KanExt_Left_to_Right_NIso)%morphism)%nattrans)
        in
        change (
            Trans w = A
          )
      end.
      rewrite (left_inverse KanExt_Left_to_Right_NIso); trivial.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; simpl.
      match goal with
        [|- _ = ?A] =>
        let w := constr:((
                   (KanExt_Left_to_Right_NIso
                      ∘ KanExt_Left_to_Right_NIso⁻¹)%morphism)%nattrans)
        in
        change (
            Trans w = A
          )
      end.
      rewrite (right_inverse KanExt_Left_to_Right_NIso); trivial.
    Qed.

  End Left_to_Right.

  Section Right_to_Left.
    Context (rke : Right_KanExt p D).

    (** The natural Isomorphism underlying the right kan extension which is
        to be shown.

        Hom_{Func_Cat C'ᵒᵖ Dᵒᵖ}(rke, –) ≃ Hom_{Func_Cat Cᵒᵖ Dᵒᵖ}(–, – ∘ p)
     *)
    Local Definition KanExt_Right_to_Left_NIso :=
      (
        (
          (
            (
              (Hom_Func_Cat_Iso (Func_Cat_Op_Iso C D))
                ∘_h (
                  NatTrans_id_Iso
                    (Prod_Functor
                       (Functor_id ((Func_Cat C D) ^op) ^op)
                       ((Left_Functor_Extender p D)^op)
                ))
            )
              ∘ (Hom_Adjunct_Duality (Adj_to_Hom_Adj (right_kan_ext_adj rke)))
          )
            ∘ (
              ((Hom_Func_Cat_Iso (Func_Cat_Op_Iso C' D))⁻¹)
                ∘_h (NatTrans_id_Iso
                       (Prod_Functor rke (Functor_id (Func_Cat C' D) ^op))))
        )
          ∘_h
          (NatTrans_id_Iso
             (Prod_Functor
                ((inverse_morphism (Func_Cat_Op_Iso C D))^op)
                (inverse_morphism (Func_Cat_Op_Iso C' D))
             )
          )
      )%natiso.

    Program Definition KanExt_Right_to_Left :
      Left_KanExt  (p^op) (D^op) :=
      {|
        left_kan_ext :=
          (
            (Op_Func_Cat_to_Func_Cat_Op C' D)
              ∘ (rke^op ∘ (Func_Cat_Op_to_Op_Func_Cat C D))
          )%functor;
        left_kan_ext_adj :=
          Hom_Adj_to_Adj
            {|
              iso_morphism :=
                {|
                  Trans := _
                |};
              inverse_morphism :=
                {|
                  Trans := _
                |}
            |}
      |}.

    Next Obligation.
    Proof.
      exact (fun c => Trans (iso_morphism KanExt_Right_to_Left_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h; simpl.
      set (w := Trans_com (iso_morphism KanExt_Right_to_Left_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      repeat rewrite NatTrans_hor_comp_Op.
      repeat rewrite NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry; simpl.
      apply KanExt_Right_to_Left_obligation_2.
    Qed.

    Next Obligation.
    Proof.
      exact (fun c => Trans (inverse_morphism KanExt_Right_to_Left_NIso) c).
    Defined.

    Next Obligation.
    Proof.
      intros c c' h; simpl.
      set (w := Trans_com (inverse_morphism KanExt_Right_to_Left_NIso) h).
      etransitivity; [etransitivity;[| apply w]|];
      clear w; trivial; cbn.
      repeat rewrite NatTrans_hor_comp_Op.
      repeat rewrite NatTrans_id_Op.
      trivial.
    Qed.

    Next Obligation.
    Proof.
      symmetry; simpl.
      apply KanExt_Right_to_Left_obligation_5.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; simpl.
      match goal with
        [|- _ = ?A] =>
        let w := constr:((
                   ((KanExt_Right_to_Left_NIso ⁻¹)
                      ∘ KanExt_Right_to_Left_NIso)%morphism)%nattrans)
        in
        change (
            Trans w = A
          )
      end.
      rewrite (left_inverse KanExt_Right_to_Left_NIso); trivial.
    Qed.

    Next Obligation.
    Proof.
      apply NatTrans_eq_simplify; simpl.
      match goal with
        [|- _ = ?A] =>
        let w := constr:((
                   (KanExt_Right_to_Left_NIso
                      ∘ KanExt_Right_to_Left_NIso⁻¹)%morphism)%nattrans)
        in
        change (
            Trans w = A
          )
      end.
      rewrite (right_inverse KanExt_Right_to_Left_NIso); trivial.
    Qed.

  End Right_to_Left.

End GlobalDuality.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Export Coq.Relations.Relations.
Require Export Coq.Classes.RelationClasses.
Require Import Coq.Lists.List.
Export ListNotations.

Notation rel A := (relation A).
Definition rels A :=
  list (relation A).

Definition rel_true: forall {A}, relation A :=
  fun _ x y => True.

Notation "⊤" := rel_true.
Notation "x ⊓ y" := (relation_conjunction x y) (at level 40).

Definition interp_rels {A} (i: rel A) (R: rels A) : relation A :=
  List.fold_right relation_conjunction i R.

Lemma interp_rels_intersect_top:
  forall A q1 q2 (R: rels A) top,
    interp_rels top R q1 q2 <->
    (top ⊓ interp_rels top R) q1 q2.
Proof.
  induction R; cbn; intuition.
  apply IHR, H1.
Qed.

Local Program Instance f_Equivalence {A B} {equiv: rel B} `{Equivalence B equiv} (f: A -> B): Equivalence (fun x y => equiv (f x) (f y)).
Next Obligation.
  repeat intro.
  eapply Equivalence_Reflexive; eauto.
Qed.
Next Obligation.
  repeat intro.
  eapply Equivalence_Symmetric; eauto.
Qed.
Next Obligation.
  repeat intro.
  eapply Equivalence_Transitive; eauto.
Qed.

Definition rels_equiv {A} i (R S: rels A) : Prop :=
  relation_equivalence (interp_rels i R) (interp_rels i S).

Global Program Instance rels_Equivalence {A i}: Equivalence (@rels_equiv A i) :=
  ltac:(typeclasses eauto).

Lemma interp_rels_bound:
  forall A (R: rels A) i,
    forall x y,
      interp_rels i R x y ->
      i x y.
Proof.
  induction R; intros; eauto.
  simpl in H.
  destruct H.
  eapply IHR.
  eauto.
Qed.

Lemma interp_rels_in:
  forall A (R: rels A) i,
    forall x y,
      interp_rels i R x y ->
      forall r, In r R -> r x y.
Proof.
  induction R; intros.
  - inversion H0.
  - inversion H0; subst; clear H0.
    + simpl in *.
      apply H.
    + destruct H; eapply IHR; eauto.
Qed.

Lemma in_interp_rels:
  forall A (i: rel A) (R: rels A),
    forall x y,
      i x y ->
      (forall r, In r R -> r x y) ->
      interp_rels i R x y.
Proof.
  induction R; intros.
  - eauto.
  - simpl in *.
    split.
    + eapply H0; eauto.
    + eapply IHR; eauto.
      firstorder.
Qed.

Lemma interp_rels_mono:
  forall A (i: rel A) (R S: rels A),
    forall x y,
      i x y ->
      interp_rels i S x y ->
      (forall r, In r R -> In r S) ->
      interp_rels i R x y.
Proof.
  induction R.
  - eauto.
  - unfold interp_rels in *.
    intros.
    simpl.
    split.
    + assert (In a (a :: R))
        by (eauto with datatypes).
      eapply interp_rels_in in H0; eauto.
    + eapply (IHR S); eauto.
      intros.
      eauto with datatypes.
Qed.

Lemma interp_rels_map:
  forall A B i (f: A -> rel B) l x y,
    interp_rels i (map f l) x y ->
    forall a,
      In a l -> f a x y.
Proof.
  intros.
  eapply interp_rels_in; eauto using in_map.
Qed.

Lemma interp_rels_app:
  forall A i (R S: rels A) x y,
    interp_rels i R x y ->
    interp_rels i S x y ->
    interp_rels i (R ++ S) x y.
Proof.
  intros.
  apply in_interp_rels.
  - eapply interp_rels_bound; eauto.
  - intros.
    rewrite in_app_iff in H1.
    destruct H1.
    + eapply interp_rels_in; [|eauto]; eauto.
    + eapply interp_rels_in; [|eauto]; eauto.
Qed.

Lemma app_interp_rels:
  forall A i (R S: rels A) x y,
    interp_rels i (R ++ S) x y ->
    interp_rels i R x y /\
    interp_rels i S x y.
Proof.
  intros.
  split.
  - apply in_interp_rels.
    + eapply interp_rels_bound; eauto.
    + intros.
      eapply interp_rels_in; eauto with datatypes.
  - apply in_interp_rels.
    + eapply interp_rels_bound; eauto.
    + intros.
      eapply interp_rels_in; eauto with datatypes.
Qed.


Require Export Monad.
Require Import Decision.

(** * The [option] monad *)

(** ** [option] is a fully invertible monad *)

Section INSTANCES.
  Global Instance option_monad_ops: MonadOps option := {
    bind A B f mx :=
      match mx with
        | Some a => f a
        | None => None
      end;
    ret := @Some
  }.

  Global Instance option_monad: Monad option.
  Proof.
    split; intros; try destruct m; try reflexivity.
    typeclasses eauto.
  Qed.

  Global Instance option_inv_ret: MonadInvRet option.
  Proof.
    intros A x y H.
    inversion H; reflexivity.
  Qed.

  Global Instance option_inv_bind: MonadInvBind option.
  Proof.
    intros A B f ma b.
    destruct ma.
    - exists a; reflexivity.
    - discriminate.
  Qed.
End INSTANCES.

(** ** Some [option]-specific rewrite rule *)

Lemma option_bind_none {A B} (f: A -> option B):
  bind f None = None.
Proof.
  reflexivity.
Qed.

Hint Rewrite @option_bind_none : monad.

(** ** Some [option]-specific definition *)

Definition assert P `{HP: Decision P}: option P :=
  match (decide P) with
    | left HP => Some HP
    | right _ => None
  end.

Definition guard {X} P `{Decision P} (x: option X): option X :=
  _ <- assert P; x.

Lemma assert_inv `{Decision} {A} (f: P -> option A) (r: A):
  bind f (assert P) = Some r ->
  exists H, f H = Some r.
Proof.
  unfold assert.
  destruct (decide P); try discriminate.
  unfold bind; simpl.
  eauto.
Qed.

Ltac assert_inv H :=
  match type of H with
    | bind _ (assert _) = _ =>
        apply assert_inv in H;
        let H' := fresh H in
          destruct H as [H' H];
        try assert_inv H
  end.

(** * [option]-related decision procedures *)

Definition isSome {A} (x: option A) :=
  exists a, x = Some a.

Definition isNone {A} (x: option A) :=
  x = None.

Global Instance isSome_dec {A} (x: option A): Decision (exists a, x = Some a) :=
  match x with
    | Some a => left _
    | None => right _
  end.
Proof.
  abstract eauto.
  abstract (intros [a Ha]; discriminate).
Defined.

Global Instance isNone_dec {A} (x: option A): Decision (x = None) :=
  match x with
    | Some _ => right _
    | None => left _
  end.
Proof.
  abstract discriminate.
  abstract reflexivity.
Defined.


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

(** Library for binary natural numbers *)

Require Export BinPos.
Require Export BinNat.
Require Export Nnat.
Require Export Ndiv_def.
Require Export Nsqrt_def.
Require Export Ngcd_def.
Require Export Ndigits.
Require Export NArithRing.
Require NBinary.

Module N.
 Include NBinary.N.
End N.

(** [N] contains an [order] tactic for natural numbers *)

(** Note that [N.order] is domain-agnostic: it will not prove
    [1<=2] or [x<=x+x], but rather things like [x<=y -> y<=x -> x=y]. *)

Local Open Scope N_scope.

Section TestOrder.
 Let test : forall x y, x<=y -> y<=x -> x=y.
 Proof.
 N.order.
 Qed.
End TestOrder.