(** * Soundness of LJT w.r.t. Kripke Semantics *)

Set Implicit Arguments.

Require Import decidable_IN.
Require Import associations.
Require Import sublist.
Require Import language_syntax.
Require Import renaming_substitution.
Require Import fresh_cst.
Require Import LJT_and_weakening.
Require Import kripke_semantics.

(** The soundness of [LJT] with respect to Kripke semantics
   is relatively simple.

   If we had included parameters (free variables), the soundness
   proof of [LJT] would be a simple simultaneous induction
   on the derivation, cf. with_FreeVar_soundness.v.

   However, because we use constants instead, the case
   [ProofForallR] requires more attention. *)

(** ** Some auxiliary predicates and operations *)

(** A predicate checking that a property holds for all elements
   of a list. *)

Inductive list_forall (A:Type)(P:A -> Type) : list A -> Type :=
| ForallNil  : list_forall P nil
| ForallCons : forall a l,
               P a -> list_forall P l -> list_forall P (cons a l).

Definition force_ctx K (w:worlds K) eta Ga :=
  list_forall (fun B : fml => w ||- B {[eta]}) Ga.

Lemma force_IN_ctx : forall K (w:worlds K) eta Ga,
  force_ctx K w eta Ga ->
  forall A,
    IN_ctx A Ga ->
    w ||- A {[eta]}.
Proof.
  induction 1 as [ | B]; simpl; intros A; [ intro Hnil; elim Hnil | intro Hcons ].
  destruct (fml_dec A B); subst; auto.
Qed.

Lemma list_force_assoc_equiv : forall Ga K (w:worlds K) eta eta0,
  wf_c Ga ->
  list_forall (fun B : fml => w ||- B {[eta]}) Ga ->
  list_forall (fun B : fml => w ||- B {[eta0]}) Ga.
Proof.
  induction Ga; constructor; intros.
  apply force_formula_assoc_indep with eta.
  inversion H; assumption. inversion X; assumption.
  apply IHGa with eta.
  inversion H; assumption.
  inversion X; apply wCons with (A:=a) in H; try assumption.
  inversion H; assumption.
Defined.

(** Forcing is monotone wrt. the world relation. *)

Lemma mono_force_ctx : forall K (w w':worlds K),
  w <= w' ->
  forall eta (Ga:context),
    force_ctx K w eta Ga ->
    force_ctx K w' eta Ga.
Proof.
  induction 2 as [| B]; constructor; eauto using mono_force.
Qed.

(** ** Creation of a new Kripke model *)

Section Creation_new_Kripke.

(** This section reflects the fact that fresh constants are
   as good as fresh parameters.

   - Syntactically, this fact is represented by the renaming lemma.

   - At the semantic level, this corresponds to creating a new Kripke
     model from a given one such that the semantics remains
     nearly identical.

   - The following section is not necessary when we had introduced
     parameters. *)

  Variable K : Kripke.

(** Given an arbitrary association for constants, we construct
   a new Kripke model which differs only for a specific constant. *)

  Definition Kripke_new_csts (f : name -> domain K) : Kripke
    := @Build_Kripke (worlds K) (wle K) (wle_refl K) (wle_trans K)
    (domain K) f (funs K) (atoms K) (atoms_mon K).

(** [csts_up] creates a new association for constants using a specific
   value for a specific contant. *)

  Definition csts_up (f:name -> domain K) (n:name) (d:domain K) :
    name -> domain K
    := (fun m => if eqdec m n then d else f m).

(** If [c] is a fresh constant for a class of formulae, then
   the new Kripke model has the same interpretation as before
   w.r.t. the class.

   For technical reason, we need to exclude the case [c=0],
   Note its special role in the definition of forcing. *)

  Lemma fresh_csts_psem : forall (t:trm) (c:name) (eta:assoc (domain K)),
    c # (oc_t t) ->
    sub_name (bv_t t) (dom eta) ->
    forall (d:domain K),
      psem K t eta = psem (Kripke_new_csts (csts_up (csts K) c d)) t eta.
  Proof.
    unfold csts_up; induction t; simpl; intros.
    destruct (IN_dom_sig n eta (H0 n (IN_eq eqdec n nil))) as [d' Hd'].
    rewrite Hd' in *.
    auto.
    repeat case_var; intuition.
    generalize (sub_appL _ _ H0); intro.
    generalize (sub_appR _ _ H0); intro.
    destruct_notin; f_equal; eauto.
  Defined.

  Lemma fresh_csts_forceL : forall (A:fml) (c:name) (eta:assoc (domain K)),
    c # oc A ->
    sub_name (bv A) (dom eta) ->
    forall (w:worlds K) (d:domain K),
      force K w A eta ->
      force (Kripke_new_csts (csts_up (csts K) c d)) w A eta

    with fresh_csts_forceR : forall (A:fml) (c:name) (eta:assoc (domain K)),
      c # oc A ->
      sub_name (bv A) (dom eta) ->
      forall (w:worlds K) (d:domain K),
        force (Kripke_new_csts (csts_up (csts K) c d)) w A eta ->
        force K w A eta.
  Proof.
    * destruct A as [ [p t] | | ]; simpl; intros.
      - rewrite <- fresh_csts_psem; assumption.
      - generalize (sub_appL _ _ H0); intro.
        generalize (sub_appR _ _ H0); intro.
        destruct_notin; eauto.
      - assert (sub_name (bv A) (dom ((n,d0)::eta))).
        + apply sub_rm_2; auto.
        + apply fresh_csts_forceL; auto.
    * destruct A as [ [p t] | | ]; simpl; intros.
      - rewrite <- fresh_csts_psem in X; assumption.
      - generalize (sub_appL _ _ H0); intro.
        generalize (sub_appR _ _ H0); intro.
        destruct_notin; eauto.
      - assert (sub_name (bv A)(dom ((n,d0)::eta))).
        + apply sub_rm_2; auto.
        + apply fresh_csts_forceR with (c:=c)(d:=d0); eauto.
  Defined.

  Lemma fresh_csts_force_ctx : forall (Ga:context) (c:name),
    c # oc_c Ga ->
    wf_c Ga ->
    forall (w:worlds K) (eta:assoc (domain K)) (d:domain K),
      force_ctx K w eta Ga ->
      force_ctx (Kripke_new_csts (csts_up (csts K) c d)) w eta Ga.
  Proof.
    - induction Ga as [ | A]; simpl; intros.
      + apply ForallNil.
      + destruct_notin; apply ForallCons; inversion X; try assumption.
        apply fresh_csts_forceL; try assumption.
        inversion H0.
        rewrite wf_bv_empty; auto with datatypes.
        apply IHGa; auto with datatypes.
        inversion H0; assumption.
  Defined.

End Creation_new_Kripke.

(** ** Soundness *)

Lemma subst_t_eq_notIN : forall y u t,
    y # bv_t t -> t [[(y,u)::nil]] = t.
Proof.
  induction t; simpl; intros.
  case_var; auto; case_var; try tauto; auto.
  auto.
  destruct_notin.
  rewrite IHt1, IHt2; auto.
Defined.

Lemma subst_eq_notIN : forall B y u,
    y # bv B -> (B[(y,u)::nil]=B).
Proof.
  induction B; simpl; intros; auto.
  destruct a.
  rewrite subst_t_eq_notIN; auto.
  destruct_notin; rewrite IHB1, IHB2; auto.
  case_var; auto.
  rewrite nil_subst; auto.
  rewrite IHB; auto.
  apply notIN_rm_2 with n; auto.
Defined.

Lemma IN_subst_wf_t : forall t y u,
    y @ bv_t t ->
    bv_t (t [[(y,u)::nil]])=nil ->
    wf_t u.
Proof.
  induction t; simpl; intros.
  repeat case_var; auto with datatypes; tauto. tauto.
  apply IN_app_or in H.
  apply app_eq_nil in H0; destruct H0.
  destruct H.
  apply IHt1 with (y:=y); auto.
  apply IHt2 with (y:=y); auto.
Defined.

Lemma notIN_rm_eq : forall n l,
    n # l -> remove eqdec n l = l.
Proof.
  induction l; simpl; intros; auto.
  case_var; simpl; intros; auto; try tauto.
  rewrite IHl; auto.
Defined.

Lemma IN_open_0 : forall n y B u,
    n <> y -> n @ bv (B [(y, u) :: nil]) -> n # bv_t u ->
    n @ bv B.
Proof.
  induction B.
  intros.
  destruct a.
  simpl in *.
  induction t.
  simpl in *.
  case_var; try tauto.
  case_var; try tauto.
  simpl in *.
  case_var; try tauto.
  simpl in *; try tauto.
  simpl in *.
  apply IN_or_app.
  apply IN_app_or in H0.
  destruct H0.
  left; apply IHt1; auto.
  right; apply IHt2; auto.
  simpl in *; intros.
  apply IN_or_app.
  apply IN_app_or in H0.
  destruct H0.
  left; apply IHB1 with u; auto.
  right; apply IHB2 with u; auto.
  simpl in *; intros.
  case_var.
  rewrite <- nil_subst in H0; auto.
  destruct (n==n0).
  rewrite e in *.
  apply notIN_rm_1 in H0; try tauto.
  apply IN_rm_2; auto.
  apply IHB with u; auto.
  apply IN_rm_1 with n0; auto.
Defined.

Hint Rewrite notIN_rm_eq IN_open_0.
Hint Resolve notIN_rm_eq IN_open_0.

Lemma IN_subst_wf_tt : forall t y eta,
    y @ bv_t t ->
    y @ dom eta ->
    bv_t (t[[eta]])=nil ->
    wf_t ((BVar y) [[eta]]).
Proof.
induction t; intros; simpl in H, H1; try tauto.
case_var; try tauto; auto with datatypes.
apply IN_app_or in H; apply app_eq_nil in H1; destruct H1, H.
apply IHt1; auto. apply IHt2; auto.
Defined.

Hint Resolve IN_subst_wf_t subst_eq_notIN subst_t_eq_notIN.
Hint Rewrite subst_eq_notIN subst_t_eq_notIN.

Theorem soundness : forall Ga A,
  Ga |- A ->
    forall K (w:worlds K),
      list_forall (fun B => w ||- B {[nil]}) Ga ->
      w ||- A {[nil]}

with soundness_stoup : forall Ga A C,
  Ga ;; A |- C ->
    forall K (w:worlds K),
      list_forall (fun B => w ||- B {[nil]}) Ga ->
      w ||- A {[nil]}
      -> w ||- C {[nil]}.
Proof.

  (* soundness *)

  - destruct 1; simpl; intros.

    + apply soundness_stoup with (Ga:=Ga)(A:=A); eauto using force_IN_ctx.

    + apply soundness with (Ga:=B::Ga); auto;
      apply ForallCons; auto; apply mono_force_ctx with (w:=w); assumption.

    + set (K' := Kripke_new_csts K (csts_up K (csts K) a d)).
      assert (K'= Kripke_new_csts K (csts_up K (csts K) a d)).
      auto.
      assert (d = psem K' (Cst a) nil).
      simpl; unfold csts_up; simpl; case_var; intuition congruence.
      rewrite H1.
      simpl in n; destruct_notin.
      apply fresh_csts_forceR with (c:=a)(d:=d); auto.
      apply wf_prove in H.
      destruct H.
      simpl.
      apply forall_wf_sub.
      apply wf_bv_empty in H4.
      apply empty_bv_wf.
      apply sub_nil with eqdec.
      rewrite <- H4.
      apply sub_q_open.
      apply subst_force with (K:=K'); simpl; auto with datatypes.
      apply soundness with (K:=K')(Ga:=Ga); auto.
      apply fresh_csts_force_ctx; auto.
      apply wf_prove in H; destruct H; assumption.
      apply mono_force_ctx with (w:=w); auto.

  (* soundness_stoup *)

  - destruct 1; simpl; intros.

    + assumption.

    + apply soundness_stoup with (Ga:=Ga)(A:=C); auto; apply X0.
      apply wle_refl.
      apply soundness with Ga; auto.

    + apply soundness_stoup with (Ga:=Ga)(A:=B[(y,u)::nil]); auto.
      pose proof decIN eqdec y (bv B).
      destruct H0.
      apply force_assoc_equiv with (m:=nil)(eta:=(y, psem K u nil)::nil); auto.
      apply wf_prove_stoup in H; destruct H; destruct H0.
      apply wf_bv_empty in H0.
      unfold open in H0; rewrite H0; auto.
      apply force_subst with (eta:=(y, psem K u nil) :: nil).
      apply wf_prove_stoup in H; destruct H; destruct H0.
      apply wf_bv_empty in H0.
      unfold open in H0.
      assumption.
      assert (w0<=w0). apply wle_refl.
      pose proof X0 w0 X1 (psem K u ((y, psem K u nil) ::nil)).
      apply force_st_assoc_equiv
      with (eta:=(y, psem K u ((y, psem K u nil) :: nil)) :: nil); auto.
      rewrite subst_eq_notIN; auto.
      assert (w0<=w0). apply wle_refl.
      set (d:= csts K 0).
      pose proof X0 w0 X1 d.
      apply force_assoc_equiv with (m:= bv B)(eta:=(y,d)::nil); auto.
      intro; intros; simpl.
      case_var; try tauto.
Defined.


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

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

Print Assumptions sub.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import coqutil.Word.Interface.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.PushButtonSynthesis.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Translation.Parameters.SelectParameters.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.ReifiedOperation.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Translation.Proofs.ValidComputable.Func.
Require Import Crypto.Util.Tactics.SpecializeBy.
Local Open Scope Z_scope.
Import ListNotations.
Import AbstractInterpretation.Compilers.

Class bedrock2_wbwmontgomery_funcs :=
  { mul : func;
    square : func;
    add : func;
    sub : func;
    opp : func;
    to_montgomery : func;
    from_montgomery : func;
    nonzero : func;
    selectznz : func;
    to_bytes : func;
    from_bytes : func }.

Class bedrock2_wbwmontgomery_specs
      {funcs : bedrock2_wbwmontgomery_funcs }:=
  { spec_of_mul : spec_of (fst mul);
    spec_of_square : spec_of (fst square);
    spec_of_add : spec_of (fst add);
    spec_of_sub : spec_of (fst sub);
    spec_of_opp : spec_of (fst opp);
    spec_of_to_montgomery : spec_of (fst to_montgomery);
    spec_of_from_montgomery : spec_of (fst from_montgomery);
    spec_of_nonzero : spec_of (fst nonzero);
    spec_of_selectznz : spec_of (fst selectznz);
    spec_of_to_bytes : spec_of (fst to_bytes);
    spec_of_from_bytes : spec_of (fst from_bytes) }.

Class bedrock2_wbwmontgomery_correctness
      {funcs : bedrock2_wbwmontgomery_funcs}
      {specs : bedrock2_wbwmontgomery_specs} :=
  { mul_correct :
      forall functions,
        spec_of_mul (mul :: functions);
    square_correct :
      forall functions,
        spec_of_square (square :: functions);
    add_correct :
      forall functions,
        spec_of_add (add :: functions);
    sub_correct :
      forall functions,
        spec_of_sub (sub :: functions);
    opp_correct :
      forall functions,
        spec_of_opp (opp :: functions);
    to_montgomery_correct :
      forall functions,
        spec_of_to_montgomery (to_montgomery :: functions);
    from_montgomery_correct :
      forall functions,
        spec_of_from_montgomery (from_montgomery :: functions);
    nonzero_correct :
      forall functions,
        spec_of_nonzero (nonzero :: functions);
    selectznz_correct :
      forall functions,
        spec_of_selectznz (selectznz :: functions);
    to_bytes_correct :
      forall functions,
        spec_of_to_bytes (to_bytes :: functions);
    from_bytes_correct :
      forall functions,
        spec_of_from_bytes (from_bytes :: functions) }.

Class names_of_operations :=
  { name_of_mul : string;
    name_of_square : string;
    name_of_add : string;
    name_of_sub : string;
    name_of_opp : string;
    name_of_to_montgomery : string;
    name_of_from_montgomery : string;
    name_of_nonzero : string;
    name_of_selectznz : string;
    name_of_to_bytes : string;
    name_of_from_bytes : string }.

Record wbwmontgomery_reified_ops
       {names : names_of_operations} {m machine_wordsize} :=
  { params : Types.parameters;
    reified_mul :
      reified_op name_of_mul
                 (@Generic.WordByWordMontgomery.mul params m)
                 (PushButtonSynthesis.WordByWordMontgomery.mul
                    m machine_wordsize);
    reified_square :
      reified_op name_of_square
                 (@Generic.WordByWordMontgomery.square params m)
                 (PushButtonSynthesis.WordByWordMontgomery.square
                    m machine_wordsize);
    reified_add :
      reified_op name_of_add
                 (@Generic.WordByWordMontgomery.add params m)
                 (PushButtonSynthesis.WordByWordMontgomery.add
                    m machine_wordsize);
    reified_sub :
      reified_op name_of_sub
                 (@Generic.WordByWordMontgomery.sub params m)
                 (PushButtonSynthesis.WordByWordMontgomery.sub
                    m machine_wordsize);
    reified_opp :
      reified_op name_of_opp
                 (@Generic.WordByWordMontgomery.opp params m)
                 (PushButtonSynthesis.WordByWordMontgomery.opp
                    m machine_wordsize);
    reified_to_montgomery :
      reified_op name_of_to_montgomery
                 (@Generic.WordByWordMontgomery.to_montgomery params m)
                 (PushButtonSynthesis.WordByWordMontgomery.to_montgomery
                    m machine_wordsize);
    reified_from_montgomery :
      reified_op name_of_from_montgomery
                 (@Generic.WordByWordMontgomery.from_montgomery params m)
                 (PushButtonSynthesis.WordByWordMontgomery.from_montgomery
                    m machine_wordsize);
    reified_nonzero :
      reified_op name_of_nonzero
                 (@Generic.WordByWordMontgomery.nonzero params m)
                 (PushButtonSynthesis.WordByWordMontgomery.nonzero
                    m machine_wordsize);
    reified_selectznz :
      reified_op name_of_selectznz
                 (@Generic.WordByWordMontgomery.selectznz params m)
                 (PushButtonSynthesis.WordByWordMontgomery.selectznz
                    m machine_wordsize);
    reified_to_bytes :
      reified_op name_of_to_bytes
                 (@Generic.WordByWordMontgomery.to_bytes params m)
                 (PushButtonSynthesis.WordByWordMontgomery.to_bytes
                    m machine_wordsize);
    reified_from_bytes :
      reified_op name_of_from_bytes
                 (@Generic.WordByWordMontgomery.from_bytes params m)
                 (PushButtonSynthesis.WordByWordMontgomery.from_bytes
                    m machine_wordsize) }.
Arguments wbwmontgomery_reified_ops {names} m machine_wordsize.

(*** Helpers ***)

Definition names_from_prefix (prefix : string)
  : names_of_operations :=
  {| name_of_mul := (prefix ++ "mul")%string;
     name_of_square := (prefix ++ "square")%string;
     name_of_add := (prefix ++ "add")%string;
     name_of_sub := (prefix ++ "sub")%string;
     name_of_opp := (prefix ++ "opp")%string;
     name_of_to_montgomery := (prefix ++ "to_montgomery")%string;
     name_of_from_montgomery := (prefix ++ "from_montgomery")%string;
     name_of_nonzero := (prefix ++ "nonzero")%string;
     name_of_selectznz := (prefix ++ "selectznz")%string;
     name_of_to_bytes := (prefix ++ "to_bytes")%string;
     name_of_from_bytes := (prefix ++ "from_bytes")%string
  |}.

(*** Synthesis Tactics ***)

Ltac funcs_from_ops ops :=
  let mul_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_mul ops))) in
  let square_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_square ops))) in
  let add_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_add ops))) in
  let sub_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_sub ops))) in
  let to_montgomery_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_to_montgomery ops))) in
  let from_montgomery_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_from_montgomery ops))) in
  let opp_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_opp ops))) in
  let nonzero_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_nonzero ops))) in
  let selectznz_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_selectznz ops))) in
  let to_bytes_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_to_bytes ops))) in
  let from_bytes_func_value :=
      (eval lazy in
          (computed_bedrock_func (reified_from_bytes ops))) in
  exact {| mul := mul_func_value;
           square := square_func_value;
           add := add_func_value;
           sub := sub_func_value;
           opp := opp_func_value;
           to_montgomery := to_montgomery_func_value;
           from_montgomery := from_montgomery_func_value;
           nonzero := nonzero_func_value;
           selectznz := selectznz_func_value;
           to_bytes := to_bytes_func_value;
           from_bytes := from_bytes_func_value |}.

Ltac specs_from_ops ops m :=
  let p := eval cbn [params ops] in (params ops) in
  let mul_name := (eval compute in name_of_mul) in
  let square_name := (eval compute in name_of_square) in
  let add_name := (eval compute in name_of_add) in
  let sub_name := (eval compute in name_of_sub) in
  let opp_name := (eval compute in name_of_opp) in
  let to_montgomery_name := (eval compute in name_of_to_montgomery) in
  let from_montgomery_name := (eval compute in name_of_from_montgomery) in
  let nonzero_name := (eval compute in name_of_nonzero) in
  let selectznz_name := (eval compute in name_of_selectznz) in
  let to_bytes_name := (eval compute in name_of_to_bytes) in
  let from_bytes_name := (eval compute in name_of_from_bytes) in
  let mul_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.mul
                 Generic.WordByWordMontgomery.spec_of_mul] in
          (@Generic.WordByWordMontgomery.spec_of_mul
             p m mul_name)) in
  let square_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.square
                 Generic.WordByWordMontgomery.spec_of_square] in
          (@Generic.WordByWordMontgomery.spec_of_square
             p m square_name)) in
  let add_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.add
                 Generic.WordByWordMontgomery.spec_of_add] in
          (@Generic.WordByWordMontgomery.spec_of_add
             p m add_name)) in
  let sub_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.sub
                 Generic.WordByWordMontgomery.spec_of_sub] in
          (@Generic.WordByWordMontgomery.spec_of_sub
             p m sub_name)) in
  let to_montgomery_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.to_montgomery
                 Generic.WordByWordMontgomery.spec_of_to_montgomery] in
          (@Generic.WordByWordMontgomery.spec_of_to_montgomery
             p m to_montgomery_name)) in
  let from_montgomery_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.from_montgomery
                 Generic.WordByWordMontgomery.spec_of_from_montgomery] in
          (@Generic.WordByWordMontgomery.spec_of_from_montgomery
             p m from_montgomery_name)) in
  let opp_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.opp
                 Generic.WordByWordMontgomery.spec_of_opp] in
          (@Generic.WordByWordMontgomery.spec_of_opp
             p m opp_name)) in
  let nonzero_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.nonzero
                 Generic.WordByWordMontgomery.spec_of_nonzero] in
          (@Generic.WordByWordMontgomery.spec_of_nonzero
             p m nonzero_name)) in
  let selectznz_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.selectznz
                 Generic.WordByWordMontgomery.spec_of_selectznz] in
          (@Generic.WordByWordMontgomery.spec_of_selectznz
             p m selectznz_name)) in
  let to_bytes_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.to_bytes
                 Generic.WordByWordMontgomery.spec_of_to_bytes] in
          (@Generic.WordByWordMontgomery.spec_of_to_bytes
             p m to_bytes_name)) in
  let from_bytes_spec :=
      (eval cbv
            [fst snd precondition postcondition
                 Generic.WordByWordMontgomery.from_bytes
                 Generic.WordByWordMontgomery.spec_of_from_bytes] in
          (@Generic.WordByWordMontgomery.spec_of_from_bytes
             p m from_bytes_name)) in
  exact {| spec_of_mul := mul_spec;
           spec_of_square := square_spec;
           spec_of_add := add_spec;
           spec_of_sub := sub_spec;
           spec_of_opp := opp_spec;
           spec_of_to_montgomery := to_montgomery_spec;
           spec_of_from_montgomery := from_montgomery_spec;
           spec_of_nonzero := nonzero_spec;
           spec_of_selectznz := selectznz_spec;
           spec_of_to_bytes := to_bytes_spec;
           spec_of_from_bytes := from_bytes_spec |}.

Ltac handle_easy_preconditions :=
  lazymatch goal with
  | |- ZRange.type.option.is_tighter_than _ _ = true =>
    abstract vm_cast_no_check (eq_refl true)
  | |- Types.ok => solve [typeclasses eauto]
  | |- _ = ErrorT.Success _ => solve [apply reified_eq]
  | |- API.Wf _ => solve [apply reified_Wf]
  | |- Func.valid_func _ => solve [apply reified_valid]
  | _ => first [ apply inname_gen_varname_gen_disjoint
               | apply outname_gen_varname_gen_disjoint
               | apply outname_gen_inname_gen_disjoint
               | apply prefix_name_gen_unique ]
  | |- ?g => fail "Unrecognized goal" g
  end.

Ltac use_correctness_proofs p m :=
  let Hc := fresh in
  match goal with
  | |- context [Generic.WordByWordMontgomery.mul] =>
    apply (@Generic.WordByWordMontgomery.mul_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.square] =>
    apply (@Generic.WordByWordMontgomery.square_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.add] =>
    apply (@Generic.WordByWordMontgomery.add_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.sub] =>
    apply (@Generic.WordByWordMontgomery.sub_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.opp] =>
    apply (@Generic.WordByWordMontgomery.opp_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.to_montgomery] =>
    apply (@Generic.WordByWordMontgomery.to_montgomery_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.from_montgomery] =>
    apply (@Generic.WordByWordMontgomery.from_montgomery_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.nonzero] =>
    apply (@Generic.WordByWordMontgomery.nonzero_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.selectznz] =>
    apply (@Generic.WordByWordMontgomery.selectznz_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.to_bytes] =>
    apply (@Generic.WordByWordMontgomery.to_bytes_correct
             p default_inname_gen default_outname_gen m)
  | |- context [Generic.WordByWordMontgomery.from_bytes] =>
    apply (@Generic.WordByWordMontgomery.from_bytes_correct
             p default_inname_gen default_outname_gen m)
  end.

Ltac change_with_computed_func ops :=
  lazymatch goal with
  | |- context [mul] =>
    change mul with (computed_bedrock_func (reified_mul ops))
  | |- context [square] =>
    change square with (computed_bedrock_func (reified_square ops))
  | |- context [add] =>
    change add with (computed_bedrock_func (reified_add ops))
  | |- context [sub] =>
    change sub with (computed_bedrock_func (reified_sub ops))
  | |- context [opp] =>
    change opp with (computed_bedrock_func (reified_opp ops))
  | |- context [to_montgomery] =>
    change to_montgomery with (computed_bedrock_func (reified_to_montgomery ops))
  | |- context [from_montgomery] =>
    change from_montgomery with (computed_bedrock_func (reified_from_montgomery ops))
  | |- context [nonzero] =>
    change nonzero with (computed_bedrock_func (reified_nonzero ops))
  | |- context [selectznz] =>
    change selectznz with (computed_bedrock_func (reified_selectznz ops))
  | |- context [to_bytes] =>
    change to_bytes with (computed_bedrock_func (reified_to_bytes ops))
  | |- context [from_bytes] =>
    change from_bytes with (computed_bedrock_func (reified_from_bytes ops))
  end.

Ltac prove_correctness ops m machine_wordsize :=
  assert (WordByWordMontgomery.check_args
            m machine_wordsize (ErrorT.Success tt) =
          ErrorT.Success tt) by abstract (native_compute; reflexivity);
  lazymatch goal with
    | |- bedrock2_wbwmontgomery_correctness => econstructor end;
  change_with_computed_func ops; rewrite computed_bedrock_func_eq;
  let p := (eval cbn [params ops] in (params ops)) in
  use_correctness_proofs p m; try assumption;
  handle_easy_preconditions.

Ltac make_names_of_operations prefix :=
  match goal with
  | |- names_of_operations =>
    let n := eval vm_compute in (names_from_prefix prefix) in
        exact n
  end.

Ltac make_reified_ops :=
  lazymatch goal with
    |- wbwmontgomery_reified_ops ?m ?machine_wordsize =>
    let p := parameters_from_wordsize machine_wordsize in
    eapply Build_wbwmontgomery_reified_ops with (params:=p)
  end; prove_reified_op.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight 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.solinas64_2e222m117_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight 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_2e413m21_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight 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_2e291m19_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight 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.solinas64_2e495m31_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight 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.solinas64_2e382m105_7limbs.Synthesis.

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

Print Assumptions sub.


(* ******************************************************************************* *)
(** * Strict bicategories
 ********************************************************************************* *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.TwoCategories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.TransportLaws.

Local Open Scope bicategory_scope.
Local Open Scope cat.

(** Data of strictness structure *)
Definition strictness_structure_data
           (B : bicat)
  : UU
  := (∏ (a b : B) (f : a --> b), id₁ a · f = f)
     × (∏ (a b : B) (f : a --> b), f · id₁ b = f)
     × (∏ (a b c d : B) (f : a --> b) (g : b --> c) (h : c --> d),
        f · (g · h) = f · g · h).

(** Projections *)
Definition plunitor
           {B : bicat}
           (S : strictness_structure_data B)
           {a b : B}
           (f : a --> b)
  : id₁ a · f = f
  := pr1 S _ _ f.

Definition plinvunitor
           {B : bicat}
           (S : strictness_structure_data B)
           {a b : B}
           (f : a --> b)
  : f = id₁ a · f
  := !(pr1 S _ _ f).

Definition prunitor
           {B : bicat}
           (S : strictness_structure_data B)
           {a b : B}
           (f : a --> b)
  : f · id₁ b = f
  := pr12 S _ _ f.

Definition prinvunitor
           {B : bicat}
           (S : strictness_structure_data B)
           {a b : B}
           (f : a --> b)
  : f = f · id₁ b
  := !(pr12 S _ _ f).

Definition plassociator
           {B : bicat}
           (S : strictness_structure_data B)
           {a b c d : B}
           (f : a --> b)
           (g : b --> c)
           (h : c --> d)
  : f · (g · h) = f · g · h
  := pr22 S _ _ _ _ f g h.

Definition prassociator
           {B : bicat}
           (S : strictness_structure_data B)
           {a b c d : B}
           (f : a --> b)
           (g : b --> c)
           (h : c --> d)
  : f · g · h = f · (g · h)
  := !(pr22 S _ _ _ _ f g h).

(** The requirements for the data *)
Definition strictness_structure_laws
           {B : bicat}
           (S : strictness_structure_data B)
  : UU
  := (∏ (a b : B) (f : a --> b), pr1 (idtoiso_2_1 _ _ (plunitor S f)) = lunitor f)
     × (∏ (a b : B) (f : a --> b), pr1 (idtoiso_2_1 _ _ (prunitor S f)) = runitor f)
     × (∏ (a b c d : B) (f : a --> b) (g : b --> c) (h : c --> d),
        pr1 (idtoiso_2_1 _ _ (plassociator S f g h)) = lassociator f g h).

Definition strictness_structure
           (B : bicat)
  : UU
  := ∑ (S : strictness_structure_data B), strictness_structure_laws S.

(** The laws form a proposition *)
Lemma isPredicate_strictness_structure_laws
           (B : bicat)
  : isPredicate (@strictness_structure_laws B).
Proof.
  intro S.
  repeat use isapropdirprod.
  - do 3 (use impred ; intro).
    apply B.
  - do 3 (use impred ; intro).
    apply B.
  - do 7 (use impred ; intro).
    apply B.
Qed.

(** Projections *)
Coercion strictness_structure_to_data
         {B : bicat}
         (S : strictness_structure B)
  : strictness_structure_data B
  := pr1 S.

Definition idtoiso_plunitor
           {B : bicat}
           (S : strictness_structure B)
           {a b : B}
           (f : a --> b)
  : pr1 (idtoiso_2_1 _ _ (plunitor S f)) = lunitor f
  := pr12 S _ _ f.

Definition idtoiso_prunitor
           {B : bicat}
           (S : strictness_structure B)
           {a b : B}
           (f : a --> b)
  : pr1 (idtoiso_2_1 _ _ (prunitor S f)) = runitor f
  := pr122 S _ _ f.

Definition idtoiso_plassociator
           {B : bicat}
           (S : strictness_structure B)
           {a b c d : B}
           (f : a --> b)
           (g : b --> c)
           (h : c --> d)
  : pr1 (idtoiso_2_1 _ _ (plassociator S f g h)) = lassociator f g h
  := pr222 S _ _ _ _ f g h.

(** Coherent strictness structure. For these, one also needs the triangle and pentagon. *)
Definition is_coh_strictness_structure
           {B : bicat}
           (S : strictness_structure B)
  : UU
  := (∏ (a b c : B) (f : a --> b) (g : b --> c),
      maponpaths (λ z, f · z) (plunitor S g)
      =
      plassociator S _ _ _ @ maponpaths (λ z, z · g) (prunitor S f))
      ×
      ∏ (v w x y z : B)
      (f : v --> w) (g : w --> x)
      (h : x --> y) (k : y --> z),
     maponpaths (λ z, f · z) (plassociator S g h k)
     @ plassociator S f (g · h) k
     @ maponpaths (λ z, z · k) (plassociator S f g h)
     =
     plassociator S f g (h · k)
     @ plassociator S (f · g) h k.

Definition coh_strictness_structure
           (B : bicat)
  := ∑ (S : strictness_structure B), is_coh_strictness_structure S.

Coercion pr_strictness_structure
         {B : bicat}
         (S : coh_strictness_structure B)
  : strictness_structure B
  := pr1 S.

(** Being coherent is a proposition *)
Lemma isPredicate_is_coh_strictness_structure
           {B : bicat}
           (HB : is_univalent_2_1 B)
  : isPredicate (@is_coh_strictness_structure B).
Proof.
  intro S.
  use isapropdirprod.
  - do 5 (use impred ; intro).
    exact (univalent_bicategory_1_cell_hlevel_3 _ HB _ _ _ _ _ _).
  - do 9 (use impred ; intro).
    exact (univalent_bicategory_1_cell_hlevel_3 _ HB _ _ _ _ _ _).
Qed.

(** Definition of 2-category *)
Definition locally_strict
           (B : bicat)
  : UU
  := ∏ (a b : B), isaset (a --> b).

Definition is_strict_bicat
           (B : bicat)
  : UU
  := locally_strict B
     ×
     coh_strictness_structure B.

Definition make_is_strict_bicat
           {B : bicat}
           (HB : locally_strict B)
           (S : strictness_structure B)
  : is_strict_bicat B.
Proof.
  use tpair.
  - exact HB.
  - repeat use tpair.
    + exact (@plunitor _ S).
    + exact (@prunitor _ S).
    + exact (@plassociator _ S).
    + exact (@idtoiso_plunitor _ S).
    + exact (@idtoiso_prunitor _ S).
    + exact (@idtoiso_plassociator _ S).
    + abstract (simpl ; intros ; apply HB).
    + abstract (simpl ; intros ; apply HB).
Defined.

Lemma isPredicate_is_coh_strictness_structure_from_locally_strict
           {B : bicat}
           (HB : locally_strict B)
  : isPredicate (@is_coh_strictness_structure B).
Proof.
  intro z.
  apply invproofirrelevance.
  intros c₁ c₂.
  use pathsdirprod.
  - do 5 (use funextsec ; intro).
    apply (isasetaprop (HB _ _ _ _)).
  - do 9 (use funextsec ; intro).
    apply (isasetaprop (HB _ _ _ _)).
Qed.

Lemma isaprop_is_strict_bicat
           (B : bicat)
  : isaprop (is_strict_bicat B).
Proof.
  apply invproofirrelevance.
  intros x y.
  induction x as [LSx CSx].
  induction y as [LSY CSy].
  use pathsdirprod.
  - do 2 (use funextsec ; intro).
    apply isapropisaset.
  - use subtypePath.
    { exact (isPredicate_is_coh_strictness_structure_from_locally_strict LSx). }
    use subtypePath.
    { exact (isPredicate_strictness_structure_laws B). }
    repeat use pathsdirprod.
    + repeat (use funextsec ; intro).
      apply LSx.
    + repeat (use funextsec ; intro).
      apply LSx.
    + repeat (use funextsec ; intro).
      apply LSx.
Qed.

Definition strict_bicat
  := ∑ (B : bicat), is_strict_bicat B.

Coercion bicat_of_strict_bicat
         (B : strict_bicat)
  : bicat
  := pr1 B.

(** Strict bicat to 2-cat *)
Definition strict_bicat_to_precategory_data
           (B : strict_bicat)
  : precategory_data.
Proof.
  - use make_precategory_data.
    + use make_precategory_ob_mor.
      * exact (ob B).
      * exact (λ b₁ b₂, b₁ --> b₂).
    + exact (λ z, id₁ z).
    + exact (λ _ _ _ f g, f · g).
Defined.

Definition strict_bicat_to_precategory_is_precategory
           (B : strict_bicat)
  : is_precategory (strict_bicat_to_precategory_data B).
Proof.
  repeat split ; cbn.
  - exact (λ _ _ f, plunitor (pr22 B) f).
  - exact (λ _ _ f, prunitor (pr22 B) f).
  - exact (λ _ _ _ _ f g h, plassociator (pr22 B) f g h).
  - exact (λ _ _ _ _ f g h, prassociator (pr22 B) f g h).
Defined.
(* the definition is exploited further down in Lemma [strict_bicat_to_two_cat_laws] *)

Lemma strict_bicat_to_precategory_has_homsets
           (B : strict_bicat)
  : has_homsets (strict_bicat_to_precategory_data B).
Proof.
  exact (pr12 B).
Qed.

Definition strict_bicat_to_two_cat_data
           (B : strict_bicat)
  : two_cat_data.
Proof.
  use tpair.
  - exact (strict_bicat_to_precategory_data B).
  - use tpair.
    + exact (λ _ _ f g, f ==> g).
    + repeat split.
      * exact (λ _ _ f, id₂ f).
      * exact (λ _ _ _ _ _ α β, α • β).
      * exact (λ _ _ _ f _ _ α, f ◃ α).
      * exact (λ _ _ _ _ _ g α, α ▹ g).
Defined.

Definition strict_bicat_to_two_cat_category
           (B : strict_bicat)
  : two_cat_category.
Proof.
  use tpair.
  - exact (strict_bicat_to_two_cat_data B).
  - split.
    + exact (strict_bicat_to_precategory_is_precategory B).
    + exact (strict_bicat_to_precategory_has_homsets B).
Defined.

Lemma idto2mor_idtoiso
           {B : strict_bicat}
           {a b : B}
           {f g : a --> b}
           (p : f = g)
  : @idto2mor (strict_bicat_to_two_cat_data B) _ _ _ _ p
    =
    pr1 (idtoiso_2_1 _ _ p).
Proof.
  induction p.
  apply idpath.
Qed.

Lemma strict_bicat_to_two_cat_laws
           (B : strict_bicat)
  : two_cat_laws (strict_bicat_to_two_cat_category B).
Proof.
  repeat split.
  - intros ; apply id2_left.
  - intros ; apply id2_right.
  - intros ; apply vassocr.
  - intros ; apply lwhisker_id2.
  - intros ; apply id2_rwhisker.
  - intros ; apply lwhisker_vcomp.
  - intros ; apply rwhisker_vcomp.
  - intros ; apply vcomp_whisker.
  - intros ; cbn.
    rewrite !idto2mor_idtoiso.
    rewrite !idtoiso_plunitor.
    apply vcomp_lunitor.
  - intros ; cbn.
    rewrite !idto2mor_idtoiso.
    rewrite !idtoiso_prunitor.
    apply vcomp_runitor.
  - intros ; cbn.
    rewrite !idto2mor_idtoiso.
    rewrite !idtoiso_plassociator.
    apply lwhisker_lwhisker.
  - intros ; cbn.
    rewrite !idto2mor_idtoiso.
    rewrite !idtoiso_plassociator.
    apply rwhisker_lwhisker.
  - intros ; cbn.
    rewrite !idto2mor_idtoiso.
    rewrite !idtoiso_plassociator.
    apply rwhisker_rwhisker.
Qed.

Definition strict_bicat_to_two_cat
           (B : strict_bicat)
  : two_cat.
Proof.
  use tpair.
  - use tpair.
    + exact (strict_bicat_to_two_cat_category B).
    + exact (strict_bicat_to_two_cat_laws B).
  - intros x y f g ; simpl.
    apply (pr1 B).
Defined.

(** Univalent 2-categories *)
Lemma univalent_two_cat_2cells_are_prop
           (B : strict_bicat)
           (HB : is_univalent_2_1 B)
           {a b : B}
           (f g : a --> b)
  : isaprop (invertible_2cell f g).
Proof.
  refine (isofhlevelweqf 1 (make_weq _ (HB _ _ f g)) _).
  exact (pr12 B _ _ f g).
Qed.

(** Univalent categories do not form a 2-category *)
Definition diag_set
  : HSET_univalent_category ⟶ HSET_univalent_category.
Proof.
  use make_functor.
  - use make_functor_data.
    + exact (λ X, setdirprod X X).
    + exact (λ _ _ f x, f (pr1 x) ,, f (pr2 x)).
  - split.
    + intro X.
      apply idpath.
    + intros X Y Z f g.
      apply idpath.
Defined.

Definition swap
  : nat_z_iso diag_set diag_set.
Proof.
  use make_nat_z_iso.
  - use make_nat_trans.
    + intros X x.
      exact (pr2 x ,, pr1 x).
    + intros X Y f.
      apply idpath.
  - intros X.
    cbn.
    use tpair.
    + exact (λ z, pr2 z ,, pr1 z).
    + split.
      * apply idpath.
      * apply idpath.
Defined.

Lemma cat_not_a_two_cat
  : ¬ (is_strict_bicat bicat_of_univ_cats).
Proof.
  intro H.
  pose (maponpaths
          pr1
          (eqtohomot
             (nat_trans_eq_pointwise
                (maponpaths
                   (λ z, pr1 z)
                   (proofirrelevance
                      _
                      (@univalent_two_cat_2cells_are_prop
                         (bicat_of_univ_cats ,, H)
                         univalent_cat_is_univalent_2_1
                         HSET_univalent_category
                         HSET_univalent_category
                         diag_set
                         diag_set)
                      (id2_invertible_2cell _)
                      (nat_z_iso_to_invertible_2cell _ _ swap)))
                boolset)
             (true ,, false)))
    as C.
  exact (nopathstruetofalse C).
Qed.

(** Local univalence gives rise to a unique strictness structure *)
Definition strictness_from_univalent_2_1
           {B : bicat}
           (HB : is_univalent_2_1 B)
  : strictness_structure B.
Proof.
  repeat use tpair.
  - refine (λ _ _ f, isotoid_2_1 HB (lunitor f ,, _)).
    is_iso.
  - refine (λ _ _ f, isotoid_2_1 HB (runitor f ,, _)).
    is_iso.
  - refine (λ _ _ _ _ f g h, isotoid_2_1 HB (lassociator f g h ,, _)).
    is_iso.
  - abstract
      (cbn ; intros ;
       rewrite idtoiso_2_1_isotoid_2_1 ;
       apply idpath).
  - abstract
      (cbn ; intros ;
       rewrite idtoiso_2_1_isotoid_2_1 ;
       apply idpath).
  - abstract
      (cbn ; intros ;
       rewrite idtoiso_2_1_isotoid_2_1 ;
       apply idpath).
Defined.

Lemma is_coh_strictness_from_univalent_2_1
           {B : bicat}
           (HB : is_univalent_2_1 B)
  : is_coh_strictness_structure (strictness_from_univalent_2_1 HB).
Proof.
  split.
  - intros a b c f g ; cbn.
    rewrite isotoid_2_1_lwhisker.
    rewrite isotoid_2_1_rwhisker.
    rewrite isotoid_2_1_vcomp.
    apply maponpaths.
    use subtypePath.
    { intro ; apply isaprop_is_invertible_2cell. }
    simpl.
    refine (!_).
    apply runitor_rwhisker.
  - intros v w x y z f g h k ; cbn.
    rewrite isotoid_2_1_lwhisker.
    rewrite isotoid_2_1_rwhisker.
    rewrite !isotoid_2_1_vcomp.
    apply maponpaths.
    use subtypePath.
    { intro ; apply isaprop_is_invertible_2cell. }
    simpl.
    rewrite vassocr.
    apply lassociator_lassociator.
Qed.

Definition coh_strictness_from_univalent_2_1
           (B : bicat)
           (HB : is_univalent_2_1 B)
  : coh_strictness_structure B.
Proof.
  use tpair.
  - exact (strictness_from_univalent_2_1 HB).
  - exact (is_coh_strictness_from_univalent_2_1 HB).
Defined.

Lemma isaprop_coh_strictness_from_univalence_2_1
           (B : bicat)
           (HB : is_univalent_2_1 B)
  : isaprop (coh_strictness_structure B).
Proof.
  apply invproofirrelevance.
  intros S₁ S₂.
  use subtypePath.
  { exact (isPredicate_is_coh_strictness_structure HB). }
  use subtypePath.
  { exact (isPredicate_strictness_structure_laws B). }
  repeat use pathsdirprod.
  - use funextsec ; intro a.
    use funextsec ; intro b.
    use funextsec ; intro f.
    refine (_ @ isotoid_2_1_idtoiso_2_1 HB (plunitor S₂ f)).
    refine (!(isotoid_2_1_idtoiso_2_1 HB (plunitor S₁ f)) @ _).
    apply maponpaths.
    use subtypePath.
    { intro ; apply isaprop_is_invertible_2cell. }
    rewrite !idtoiso_plunitor.
    apply idpath.
  - use funextsec ; intro a.
    use funextsec ; intro b.
    use funextsec ; intro f.
    refine (_ @ isotoid_2_1_idtoiso_2_1 HB (prunitor S₂ f)).
    refine (!(isotoid_2_1_idtoiso_2_1 HB (prunitor S₁ f)) @ _).
    apply maponpaths.
    use subtypePath.
    { intro ; apply isaprop_is_invertible_2cell. }
    rewrite !idtoiso_prunitor.
    apply idpath.
  - use funextsec ; intro a.
    use funextsec ; intro b.
    use funextsec ; intro c.
    use funextsec ; intro d.
    use funextsec ; intro f.
    use funextsec ; intro g.
    use funextsec ; intro h.
    refine (_ @ isotoid_2_1_idtoiso_2_1 HB (plassociator S₂ f g h)).
    refine (!(isotoid_2_1_idtoiso_2_1 HB (plassociator S₁ f g h)) @ _).
    apply maponpaths.
    use subtypePath.
    { intro ; apply isaprop_is_invertible_2cell. }
    rewrite !idtoiso_plassociator.
    apply idpath.
Qed.

Definition unique_strictness_structure_is_univalent_2_1
           (B : bicat)
           (HB : is_univalent_2_1 B)
  : iscontr (coh_strictness_structure B).
Proof.
  use tpair.
  - exact (coh_strictness_from_univalent_2_1 B HB).
  - intro.
    apply isaprop_coh_strictness_from_univalence_2_1.
    exact HB.
Defined.

Lemma idto2mor_transport
           (C : two_cat)
           {x y : pr1 C}
           {f g : x --> y}
           (p : f = g)
  : idto2mor p = transportf _ p (TwoCategories.id2 f).
Proof.
  induction p.
  apply idpath.
Qed.

Lemma precomp_transportf
           (C : two_cat)
           {x y : pr1 C}
           {f g h: x --> y}
           (p : g = h)
           (α : two_cat_cells _ f g)
  : TwoCategories.vcomp2
      α
      (transportf (two_cat_cells _ g) p (TwoCategories.id2 g))
    =
    transportf (two_cat_cells _ f) p α.
Proof.
  induction p.
  cbn.
  unfold idfun.
  rewrite TwoCategories.id2_right.
  apply idpath.
Qed.

Lemma postcomp_transportf
           (C : two_cat)
           {x y : pr1 C}
           {f g h: x --> y}
           (p : f = g)
           (α : two_cat_cells _ g h)
  : TwoCategories.vcomp2
      (transportf (two_cat_cells _ f) p (TwoCategories.id2 f))
      α
    =
    transportb (λ z, two_cat_cells _ z h) p α.
Proof.
  induction p.
  cbn.
  unfold idfun.
  rewrite TwoCategories.id2_left.
  apply idpath.
Qed.

Definition two_cat_to_prebicat_data
           (C : two_cat)
  : prebicat_data.
Proof.
  use build_prebicat_data.
  - apply C.
  - simpl.
    intros x y.
    refine (x --> y).
  - simpl.
    intros ? ? f g.
    exact (two_cat_cells _ f g).
  - simpl.
    intros.
    apply identity.
  - simpl.
    intros ? ? ? f g.
    refine (f · g).
  - simpl.
    intros.
    apply TwoCategories.id2.
  - simpl.
    intros ? ? ? ? ? α β.
    exact (TwoCategories.vcomp2 α β).
  - simpl.
    intros ? ? ? f g h α.
    refine (TwoCategories.lwhisker f α).
  - simpl.
    intros ? ? ? g h f α.
    refine (TwoCategories.rwhisker f α).
  - simpl.
    intros ? ? f.
    apply idto2mor.
    exact (id_left (f : pr1 C ⟦ X , Y ⟧)).
  - simpl.
    intros ? ? f.
    apply idto2mor.
    exact (!id_left (f : pr1 C ⟦ X , Y ⟧)).
  - simpl.
    intros ? ? f.
    apply idto2mor.
    exact (id_right (f : pr1 C ⟦ X , Y ⟧)).
  - simpl.
    intros ? ? f.
    apply idto2mor.
    exact (!id_right (f : pr1 C ⟦ X , Y ⟧)).
  - simpl.
    intros ? ? ? ? f g h.
    apply idto2mor.
    refine (assoc (f : pr1 C ⟦ _ , _ ⟧) g h).
  - simpl.
    intros ? ? ? ? f g h.
    apply idto2mor.
    refine (!assoc (f : pr1 C ⟦ _ , _ ⟧) g h).
Defined.

Lemma two_cat_to_prebicat_laws
           (C : two_cat)
  : prebicat_laws (two_cat_to_prebicat_data C).
Proof.
  repeat split.
  - intros.
    apply TwoCategories.id2_left.
  - intros.
    apply TwoCategories.id2_right.
  - intros.
    apply TwoCategories.vassocr.
  - intros.
    apply TwoCategories.lwhisker_id2.
  - intros.
    apply TwoCategories.id2_rwhisker.
  - intros.
    apply TwoCategories.lwhisker_vcomp.
  - intros.
    apply TwoCategories.rwhisker_vcomp.
  - intros.
    apply TwoCategories.vcomp_lunitor.
  - intros.
    apply TwoCategories.vcomp_runitor.
  - intros.
    apply TwoCategories.lwhisker_lwhisker.
  - intros.
    apply TwoCategories.rwhisker_lwhisker.
  - intros.
    apply TwoCategories.rwhisker_rwhisker.
  - intros.
    apply TwoCategories.vcomp_whisker.
  - intros ; cbn.
    etrans.
    {
      apply idto2mor_comp.
    }
    rewrite pathsinv0r.
    apply idpath.
  - intros ; cbn.
    etrans.
    {
      apply idto2mor_comp.
    }
    rewrite pathsinv0l.
    apply idpath.
  - intros ; cbn.
    etrans.
    {
      apply idto2mor_comp.
    }
    rewrite pathsinv0r.
    apply idpath.
  - intros ; cbn.
    etrans.
    {
      apply idto2mor_comp.
    }
    rewrite pathsinv0l.
    apply idpath.
  - intros ; cbn.
    etrans.
    {
      apply idto2mor_comp.
    }
    rewrite pathsinv0r.
    apply idpath.
  - intros ; cbn.
    etrans.
    {
      apply idto2mor_comp.
    }
    rewrite pathsinv0l.
    apply idpath.
  - intros ; cbn.
    etrans.
    {
      apply maponpaths.
      apply idto2mor_rwhisker.
    }
    etrans.
    {
      apply idto2mor_comp.
    }
    refine (!_).
    etrans.
    {
      apply idto2mor_lwhisker.
    }
    refine (!_).
    apply maponpaths.
    apply (homset_property C).
  - intros ; cbn.
    etrans.
    {
      apply maponpaths.
      apply idto2mor_rwhisker.
    }
    etrans.
    {
      do 2 apply maponpaths_2.
      apply idto2mor_lwhisker.
    }
    etrans.
    {
      apply maponpaths_2.
      apply idto2mor_comp.
    }
    etrans.
    {
      apply idto2mor_comp.
    }
    refine (!_).
    etrans.
    {
      apply idto2mor_comp.
    }
    refine (!_).
    apply maponpaths.
    apply (homset_property C).
Qed.

Definition two_cat_to_prebicat
           (C : two_cat)
  : prebicat.
Proof.
  use tpair.
  - apply (two_cat_to_prebicat_data C).
  - apply two_cat_to_prebicat_laws.
Defined.

Definition two_cat_to_bicat
           (C : two_cat)
  : bicat.
Proof.
  use tpair.
  - exact (two_cat_to_prebicat C).
  - apply C.
Defined.

Lemma idto2mor_idtoiso_two_cat
           {C : two_cat}
           {a b : C}
           {f g : a --> b}
           (p : f = g)
  : pr1 (@idtoiso_2_1 (two_cat_to_bicat C) _ _ _ _ p)
    =
    idto2mor p.
Proof.
  induction p.
  apply idpath.
Qed.

Lemma two_cat_is_strict_bicat
           (C : two_cat)
  : is_strict_bicat (two_cat_to_bicat C).
Proof.
  use make_is_strict_bicat.
  - apply (homset_property C).
  - use tpair.
    + repeat split.
      * intros a b f.
        exact (id_left (f : pr1 C ⟦ _ , _ ⟧)).
      * intros a b f.
        exact (id_right (f : pr1 C ⟦ _ , _ ⟧)).
      * intros a b c d f g h.
        exact (assoc (f : pr1 C ⟦ _ , _ ⟧) g h).
    + simpl.
      repeat split ; intros ; apply idto2mor_idtoiso_two_cat.
Qed.
(* it is remarkable that this can be opaque although [strictness_structure_data]
   is being constructed under the first + item *)

Definition two_cat_to_strict_bicat
           (C : two_cat)
  : strict_bicat.
Proof.
  use tpair.
  - exact (two_cat_to_bicat C).
  - exact (two_cat_is_strict_bicat C).
Defined.

Lemma strict_bicat_to_two_cat_to_strict_bicat
           (C : strict_bicat)
  : two_cat_to_strict_bicat (strict_bicat_to_two_cat C) = C.
Proof.
  use subtypePath.
  {
    intro.
    apply isaprop_is_strict_bicat.
  }
  use subtypePath.
  {
    intro.
    do 4 (apply impred ; intro).
    apply isapropisaset.
  }
  use total2_paths2_f.
  - use total2_paths2_f.
    + apply idpath.
    + cbn.
      repeat use pathsdirprod ; try apply idpath.
      * use funextsec.
        intro x.
        use funextsec.
        intro y.
        use funextsec.
        intro f.
        rewrite !idto2mor_idtoiso.
        apply idtoiso_plunitor.
      * use funextsec.
        intro x.
        use funextsec.
        intro y.
        use funextsec.
        intro f.
        rewrite !idto2mor_idtoiso.
        apply idtoiso_prunitor.
      * use funextsec.
        intro x.
        use funextsec.
        intro y.
        use funextsec.
        intro f.
        rewrite !idto2mor_idtoiso.
        rewrite idtoiso_2_1_inv ; simpl.
        refine (!(id2_right _) @ _).
        use vcomp_move_R_pM.
        { is_iso. }
        simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply idtoiso_plunitor.
        }
        apply lunitor_linvunitor.
      * use funextsec.
        intro x.
        use funextsec.
        intro y.
        use funextsec.
        intro f.
        rewrite !idto2mor_idtoiso.
        rewrite idtoiso_2_1_inv ; simpl.
        refine (!(id2_right _) @ _).
        use vcomp_move_R_pM.
        { is_iso. }
        simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply idtoiso_prunitor.
        }
        apply runitor_rinvunitor.
      * use funextsec ; intro w.
        use funextsec ; intro x.
        use funextsec ; intro y.
        use funextsec ; intro z.
        use funextsec ; intro f.
        use funextsec ; intro g.
        use funextsec ; intro h.
        rewrite !idto2mor_idtoiso.
        rewrite idtoiso_2_1_inv ; simpl.
        refine (!(id2_right _) @ _).
        use vcomp_move_R_pM.
        { is_iso. }
        simpl.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply idtoiso_plassociator.
        }
        apply lassociator_rassociator.
      * use funextsec ; intro w.
        use funextsec ; intro x.
        use funextsec ; intro y.
        use funextsec ; intro z.
        use funextsec ; intro f.
        use funextsec ; intro g.
        use funextsec ; intro h.
        rewrite !idto2mor_idtoiso.
        apply idtoiso_plassociator.
  - apply isaprop_prebicat_laws.
    intros.
    apply cellset_property.
Qed.

Lemma two_cat_to_strict_bicat_to_two_cat
           (C : two_cat)
  : strict_bicat_to_two_cat (two_cat_to_strict_bicat C) = C.
Proof.
  use subtypePath.
  {
    intro.
    do 4 (use impred ; intro).
    apply isapropisaset.
  }
  use total2_paths2_f.
  - use total2_paths2_f.
    + apply idpath.
    + apply isapropdirprod.
      * apply isaprop_is_precategory.
        intros x y.
        apply (pr22 (pr11 C)).
      * apply isaprop_has_homsets.
  - apply isaprop_two_cat_laws.
Qed.

Definition two_cat_equiv_strict_bicat
  : two_cat ≃ strict_bicat.
Proof.
  use make_weq.
  - exact two_cat_to_strict_bicat.
  - use isweq_iso.
    + exact strict_bicat_to_two_cat.
    + exact two_cat_to_strict_bicat_to_two_cat.
    + exact strict_bicat_to_two_cat_to_strict_bicat.
Defined.


Set Implicit Arguments.

Require Import
        List
        Syntax.Regex
        Utils.Functions.ListUtils
        Utils.Functions.StringUtils.

Import ListNotations.

Fixpoint accept (e : regex)(s : string) : bool :=
  match e with
  | #0 => false
  | #1 => if string_dec s "" then true else false
  | $ c =>
    match s with
    | String c' EmptyString =>
      if ascii_dec c c' then true else false
    | _ => false
    end
  | e1 :+: e2 => accept e1 s || accept e2 s
  | e1 @ e2 => existsb (fun p => accept e1 (fst p) && accept e2 (snd p))
                      (splits_string s)
  | e ^* => existsb (fun ys => forallb (fun y => accept e y) ys) (parts_string s)
  end.

Lemma accept_cat
  : forall e e' s s', accept e s = true ->
                 accept e' s' = true ->
                 accept (e @ e') (s ++ s') = true.
Proof.
  intros. simpl.
  apply existsb_Exists.
  apply Exists_exists.
  exists (s,s') ; splits*.
  apply append_splits_string_correct  with (s := (s ++ s')) ; auto.
  crush.
Qed.

Lemma parts_string_non_empty
  : forall s, In [] (parts_string s) -> s = "".
Proof.
  pose ascii_dec as K.
  intros s H.
  unfold parts_string in *.
  apply in_map_iff in H.
  destruct H as [x [Heq Hin]].
  apply map_eq_nil in Heq. substs.
  apply parts_append_correct in Hin ; auto.
  simpl in *.
  symmetry in Hin.
  apply string_to_list_empty in Hin ; auto.
Qed.

Hint Resolve accept_cat.

Lemma accept_sound
  : forall e s, accept e s = true -> s <<- e.
Proof.
  induction e ; intros s H ; crush.
  +
    destruct (string_dec s "") ; crush.
  +
    destruct s ; crush. destruct s ; crush.
    destruct (ascii_dec a a0) ; crush.
  +
    apply existsb_Exists in H.
    apply Exists_exists in H.
    destruct H as [[s1 s2] [Hin Hacc]].
    simpl in *.
    apply andb_prop in Hacc.
    destruct Hacc.
    lets J : IHe1 H.
    lets K : IHe2 H0.
    apply splits_string_correct in Hin.
    rewrite <- Hin.
    eapply InCat ; eauto.
  +
    apply orb_prop in H.
    destruct H.
    lets* J : IHe1 H.
    lets* K : IHe2 H.
  +
    apply existsb_Exists in H.
    apply Exists_exists in H.
    destruct H as [x [Hin Hfa]].
    destruct s ; eauto.
    eapply forallb_Forall in Hfa.
Admitted.

Lemma accept_complete
  : forall e s, s <<- e -> accept e s = true.
Proof.
  induction e ; intros s H ; inverts* H.
  +
    simpl ; destruct (ascii_dec a a) ; crush.
  +
    lets* J : IHe1 H2. crush.
  +
    lets* J : IHe2 H2. crush.
  +
    apply IHe in H1.
    simpl.
    apply existsb_Exists.
    apply Exists_exists.

Admitted.


Module CK.
Require Export maps assets asset_mapping form name decidability feature_model formula_theory.

  Import Maps Assets AssetMapping
  Name FormulaTheory Form Decidability FeatureModel.
  Require Import Coq.Lists.ListSet.

  Inductive Transformation : Type.

  Definition Item : Type := Formula * Transformation.
  Definition CK : Type := list Item.

  Variable ts: list Transformation.
  Variable t: Transformation.
  Variable am am1 am2 amt1 amt2: AM.
  Variable fm: FM.
  Variable exp: Formula.
  Variable ck ck2 its: CK.
  Variable item it it2: Item.
  Variable items its1 its2: list Item.
  Variable c: Configuration.
  Variable assets S S1 S2: set Asset.
  Variable s: set Configuration.
  Variable an: AssetName.

 Variable l l1 l2    : Maps.S.
 Variable r r1 r2    : Maps.T.
 Variable ls ls1 ls2 : set Maps.S.

  (* Get all Formulas*)
  Fixpoint exps (ck: CK) : set Formula :=
    match ck with
    | nil => nil
    | x :: xs => set_union form_dec (set_add form_dec (fst x) nil) (exps xs)
    end.

  (* get Formula*)
  Definition getExp (it : Item) : Formula := fst it.

  (* get Transformation*)
  Definition getRS (it: Item) : Transformation := snd it.

  Parameter Inline(40) transform : Transformation -> AM-> AM -> AM.

  Axiom preserv :
   forall am1 am2 amt1 amt2 t,
      (unique am1) /\ (unique am2) /\ (unique amt1) /\ (unique amt2) ->
      aMR am1 am2 /\ aMR amt1 amt2 ->
        aMR (transform t am1 am2) (transform t am2 amt2).

  (* get each asset if it satisfies a configuration*)
  Fixpoint semanticsCK (ck : CK) (am amt: AM) (c: Configuration) : set Asset :=
    match ck with
     | nil => img amt
     | x :: xs => if is_true (satisfies (getExp x) c) then
                    semanticsCK xs am (transform (getRS x) am amt) c
                  else semanticsCK xs am amt c
    end.

  (* get AM if it satisfies a configuration*)
  Fixpoint semanticCK (ck : CK) (am amt: AM) (c: Configuration) : AM :=
    match ck with
    |nil => amt
    | x :: xs => if is_true (satisfies (getExp x) c)
                    then semanticCK xs am (transform (getRS x) am amt) c
                 else semanticCK xs am amt c
    end.

  Definition semantics (ck: CK) (am: AM) (c: Configuration): set Asset :=
    semanticsCK ck am (nil) c.

  (* return the same result*)
  Lemma similarFunctions:
    forall ck am amt c, (unique am) -> semanticsCK ck am amt c
      = img (semanticCK ck am amt c).
  Proof.
    induction ck0.
      - induction amt.
        + induction am0.
          * intros. simpl. reflexivity.
          * intros. simpl. reflexivity.
        + induction amt.
          * intros. simpl. reflexivity.
          * intros. simpl. reflexivity.
      - induction amt.
        + induction am0.
          * intros. simpl. intuition.
          * intros. simpl. intuition.
        + induction amt.
          * intros. simpl. intuition.
          * intros. simpl. intuition.
  Qed.

  (* Provar este teorema garante que esta linguagem é consistente
     com a teoria de refinamento da linha de produtos*)

  Theorem compAmRefEmptyset:
    forall am1 am2,
      (unique am1) /\ (unique am2) ->
        aMR am1 am2 ->
          forall ck c,
            assetRef (semantics ck am1 c) (semantics ck am2 c) /\
            wfProduct (semantics ck am1 c) ->
               wfProduct (semantics ck am2 c).
  Proof.
    induction am1.
      - induction am2.
        + induction ck.
          { intros. destruct H. unfold unique in H. unfold unique in H2.
            specialize (H l r1 r2). specialize (H2 l r1 r2).
            intuition. }
          { intros. destruct H. intuition. }
        + induction ck.
          { intros. destruct H. intuition. }
          { intuition. }
      - induction am2.
        + induction ck.
          { intuition. }
          { intuition. }
        + induction ck.
          { intuition. }
          { intuition. }
  Qed.

 (*  O seguinte teorema estabelece que a avaliação de CK sobre
  o refinamento de AM produz produtos bem formados*)

  Theorem compAmRef:
    forall am1 am2,
      (unique am1) /\ (unique am2) ->
        aMR am1 am2 ->
          (forall ck c amt1 amt2,
            assetRef (semanticsCK ck am1 amt1 c) (semanticsCK ck am2 amt2 c)) /\
            aMR amt1 amt2 /\ wfProduct (semanticsCK ck am1 amt1 c) ->
              wfProduct (semanticsCK ck am2 amt2 c).
  Proof.
   induction am1.
      - induction am2.
        + induction ck.
          { intuition. }
          { intuition. }
        + induction ck.
          { intuition. }
          { intuition. }
      - induction am2.
        + induction ck.
          { intuition. }
          { intuition. }
        + induction ck.
          { intuition. }
          { intuition. }
  Qed.

  Lemma wfCKAux:
  forall exp ck f (a: Item),
    (set_In exp (exps ck) -> wt f exp) ->
      (set_In exp (exps (a :: ck)) ->
        wt f exp).
  Proof.
    induction exp0.
    + intros. simpl. intuition.
    + intros. simpl. intuition.
    + intros. admit.
    + intros. simpl. specialize (IHexp0 ck f a). simpl in H.

  Admitted.

  Lemma wfCK (fm: FM) (am :AM) (ck: CK) :
    (unique am) ->
      forall (exp : Formula), set_In exp (exps ck) -> wt (fst fm) exp.
  Proof.
    intros.
    destruct fm.
    simpl.
    induction ck.
      + simpl in H. contradiction.
      + generalize H0. apply wfCKAux.
        apply IHck.
  Qed.

  Lemma addItemsBefore:
    forall am amt ck its s,
        forall c,
          set_In c s-> (
            (forall exp, set_In exp (exps its) -> ~(satisfies exp c) ->
              (semanticsCK ck am amt c = semanticsCK ( its ++ ck) am amt c))).
  Proof.
      unfold not.
      induction its0.
       + induction ck0.
          * simpl. intros. reflexivity.
          * simpl. intros. reflexivity.
       + induction ck0.
          * simpl. intros. specialize (IHits0 s0).
            specialize (IHits0 c0). intuition. specialize (H2 exp0). admit.
          *  simpl. intros. specialize (IHits0 s0). specialize (IHits0 c0). intuition.
              specialize (H2 exp0). admit.
Admitted.

  Lemma addItemsAfter:
    forall am amt ck its s,
        forall c,
          set_In c s-> (
            (forall (exp: Formula), set_In exp (exps its) -> ~(satisfies exp c) ->
              (semanticsCK ck am amt c = semanticsCK ( ck ++ its) am amt c))).
  Proof.
   unfold not.
      induction its0.
       + induction ck0.
          * simpl. intros. reflexivity.
          * simpl. intros. contradiction.
       + induction ck0.
          * simpl. intros. specialize (IHits0 s0).
            specialize (IHits0 c0). intuition. specialize (H2 exp0). intuition. admit.
          *  simpl. intros. specialize (IHits0 s0). specialize (IHits0 c0). intuition.
              specialize (H2 exp0). admit.
Admitted.

End CK.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.

(****************************************************************************)
(* This is a small library to do epsilon - N reasonning.                    *)
(* In order to use it, one only has to know the following tactics:          *)
(*                                                                          *)
(*      pose_big_enough i == pose a big enough natural number i             *)
(*   pose_big_modulus m F == pose a function m : F -> nat which should      *)
(*                           provide a big enough return value              *)
(* exists_big_modulus m F := pose_big_modulus m F; exists m                 *)
(*             big_enough == replaces a big enough constraint x <= i        *)
(*                           by true and implicity remembers that i should  *)
(*                           be bigger than x.                              *)
(*                close   == all "pose" tactics create a dummy subgoal to   *)
(*                           force the user to explictely indicate that all *)
(*                           constraints have been found                    *)
(****************************************************************************)

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

Module BigEnough.

Record big_rel_class_of T (leq : rel T) :=
  BigRelClass {
      leq_big_internal_op : rel T;
      bigger_than_op : seq T -> T;
      _ : leq_big_internal_op = leq;
      _ : forall i s, leq_big_internal_op i (bigger_than_op (i :: s));
      _ : forall i j s, leq_big_internal_op i (bigger_than_op s) ->
                        leq_big_internal_op i (bigger_than_op (j :: s))
}.

Record big_rel_of T := BigRelOf {
  leq_big :> rel T;
  big_rel_class : big_rel_class_of leq_big
}.

Definition bigger_than_of T (b : big_rel_of T)
           (phb : phantom (rel T) b) :=
  bigger_than_op (big_rel_class b).
Notation bigger_than leq := (@bigger_than_of _ _ (Phantom (rel _) leq)).

Definition leq_big_internal_of T (b : big_rel_of T)
           (phb : phantom (rel T) b) :=
  leq_big_internal_op (big_rel_class b).
Notation leq_big_internal leq := (@leq_big_internal_of _ _ (Phantom (rel _) leq)).

Lemma next_bigger_than T (b : big_rel_of T) i j s :
  leq_big_internal b i (bigger_than b s) ->
  leq_big_internal b i (bigger_than b (j :: s)).
Proof. by case: b i j s => [? []]. Qed.

Lemma instantiate_bigger_than T (b : big_rel_of T) i s :
  leq_big_internal b i (bigger_than b (i :: s)).
Proof. by case: b i s => [? []]. Qed.

Lemma leq_big_internalE T (b : big_rel_of T) : leq_big_internal b = leq_big b.
Proof. by case: b => [? []]. Qed.

(* Lemma big_enough  T (b : big_rel_of T) i s : *)
(*   leq_big_internal b i (bigger_than b s) -> *)
(*   leq_big b i (bigger_than b s). *)
(* Proof. by rewrite leq_big_internalE. Qed. *)

Lemma context_big_enough P T (b : big_rel_of T) i s :
  leq_big_internal b i (bigger_than b s) ->
  P true ->
  P (leq_big b i (bigger_than b s)).
Proof. by rewrite leq_big_internalE => ->. Qed.

Definition big_rel_leq_class : big_rel_class_of leq.
Proof.
exists leq (foldr maxn 0%N) => [|i s|i j s /leq_trans->] //;
by rewrite (leq_maxl, leq_maxr).
Qed.
Canonical big_enough_nat := BigRelOf big_rel_leq_class.

Definition closed T (i : T) := {j : T | j = i}.
Ltac close :=  match goal with
                 | |- context [closed ?i] =>
                   instantiate (1 := [::]) in (Value of i); exists i
               end.

Ltac pose_big_enough i :=
  evar (i : nat); suff : closed i; first do
    [move=> _; instantiate (1 := bigger_than leq _) in (Value of i)].

Ltac pose_big_modulus m F :=
  evar (m : F -> nat); suff : closed m; first do
    [move=> _; instantiate (1 := (fun e => bigger_than leq _)) in (Value of m)].

Ltac exists_big_modulus m F := pose_big_modulus m F; first exists m.

Ltac olddone :=
   trivial; hnf; intros; solve
   [ do ![solve [trivial | apply: sym_equal; trivial]
         | discriminate | contradiction | split]
   | case not_locked_false_eq_true; assumption
   | match goal with H : ~ _ |- _ => solve [case H; trivial] end].

Ltac big_enough :=
  do ?[ apply context_big_enough;
        first do [do ?[ now apply instantiate_bigger_than
                      | apply next_bigger_than]]].

Ltac big_enough_trans :=
  match goal with
    | [leq_nm : is_true (?n <= ?m)%N |- is_true (?x <= ?m)] =>
        apply: leq_trans leq_nm; big_enough; olddone
    | _ => big_enough; olddone
  end.

Ltac done := do [olddone|big_enough_trans].

End BigEnough.


Require Import Tweetnacl.Libs.Export.
Require Export Tweetnacl.Gen.Get_abcdef.

Definition get_m (c:(list Z * list Z)) : list Z := match c with
  (m,t) => m
end.
Definition get_t (c:(list Z * list Z)) : list Z := match c with
  (m,t) => t
end.

Lemma get_a_length : forall (a b c d e f:list Z), length (get_a (a,b,c,d,e,f)) = length a. Proof. go. Qed.
Lemma get_b_length : forall (a b c d e f:list Z), length (get_b (a,b,c,d,e,f)) = length b. Proof. go. Qed.
Lemma get_c_length : forall (a b c d e f:list Z), length (get_c (a,b,c,d,e,f)) = length c. Proof. go. Qed.
Lemma get_d_length : forall (a b c d e f:list Z), length (get_d (a,b,c,d,e,f)) = length d. Proof. go. Qed.
Lemma get_e_length : forall (a b c d e f:list Z), length (get_e (a,b,c,d,e,f)) = length e. Proof. go. Qed.
Lemma get_f_length : forall (a b c d e f:list Z), length (get_f (a,b,c,d,e,f)) = length f. Proof. go. Qed.
Lemma get_m_length : forall m t, length (get_m (m,t)) = length m. Proof. go. Qed.
Lemma get_t_length : forall m t, length (get_t (m,t)) = length t. Proof. go. Qed.

Open Scope Z.

Lemma get_a_Zlength : forall (a b c d e f:list Z), Zlength (get_a (a,b,c,d,e,f)) = Zlength a. Proof. go. Qed.
Lemma get_b_Zlength : forall (a b c d e f:list Z), Zlength (get_b (a,b,c,d,e,f)) = Zlength b. Proof. go. Qed.
Lemma get_c_Zlength : forall (a b c d e f:list Z), Zlength (get_c (a,b,c,d,e,f)) = Zlength c. Proof. go. Qed.
Lemma get_d_Zlength : forall (a b c d e f:list Z), Zlength (get_d (a,b,c,d,e,f)) = Zlength d. Proof. go. Qed.
Lemma get_e_Zlength : forall (a b c d e f:list Z), Zlength (get_e (a,b,c,d,e,f)) = Zlength e. Proof. go. Qed.
Lemma get_f_Zlength : forall (a b c d e f:list Z), Zlength (get_f (a,b,c,d,e,f)) = Zlength f. Proof. go. Qed.
Lemma get_m_Zlength : forall m t, Zlength (get_m (m,t)) = Zlength m. Proof. go. Qed.
Lemma get_t_Zlength : forall m t, Zlength (get_t (m,t)) = Zlength t. Proof. go. Qed.

Close Scope Z.