(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (C) 2010-2012, ENS de Lyon.
Copyright (C) 2010-2016, Inria.
Copyright (C) 2014-2016, IRIT.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Rdefinitions Raxioms RIneq Rbasic_fun.
From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq bigop.

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

(** Missing results about natural numbers *)

Section NatCompl.

Lemma leq_subnK: forall m n : nat, n <= (n - m) + m.
Proof. elim=> [|n IHn] m; first by rewrite addn0 subn0.
rewrite subnS -addSnnS.
move/(_ m) in IHn.
have H := leqSpred (m - n).
apply: leq_trans IHn _.
exact: leq_add H _.
Qed.

Lemma leq_addLR m n p : n <= p -> (m + n <= p) = (m <= p - n).
Proof. by move => H; rewrite -!subn_eq0 subnBA. Qed.

Lemma leq_addLRI m n p : (m + n <= p) -> (m <= p - n).
Proof.
move=> Hmnp.
- have Hnp : n <= p by exact: leq_trans (leq_addl _ _) Hmnp.
- move: Hmnp; rewrite -!subn_eq0 subnBA //.
Qed.

Lemma ltn_leqN m n : m < n <= m = false.
Proof. by apply/andP=> [[_n n_]]; have:= leq_ltn_trans n_ _n; rewrite ltnn. Qed.

Lemma max1n n : maxn 1 n = n.-1.+1.
Proof. by case: n =>//; case. Qed.

Lemma ltn_leq_pred m n : m < n -> m <= n.-1.
Proof. by move=> H; rewrite -ltnS (ltn_predK H). Qed.

Lemma addn_pred_leqI a b k i :
  (a + b).-1 <= k -> i <= k -> a <= i \/ b <= k - i.
Proof.
move=> Hk Hi; case: (leqP a i) => Ha; [by left|right].
apply: leq_addLRI.
apply: leq_trans _ Hk.
apply: ltn_leq_pred.
by rewrite addnC ltn_add2r.
Qed.

End NatCompl.

(** Missing result(s) about bigops *)

Section bigops.
Lemma big_nat_leq_idx :
  forall (R : Type) (idx : R) (op : Monoid.law idx) (m n : nat) (F : nat -> R),
  n <= m -> (forall i : nat, n <= i < m -> F i = idx) ->
  \big[op/idx]_(0 <= i < n) F i = \big[op/idx]_(0 <= i < m) F i.
Proof.
move=> R idx op m n F Hmn H.
rewrite [RHS](big_cat_nat _ (n := n)) //.
rewrite [in X in _ = op _ X]big_nat_cond.
rewrite [in X in _ = op _ X]big1 ?Monoid.mulm1 //.
move=> i; rewrite andbT; move=> *; exact: H.
Qed.
End bigops.

(** Missing results about lists (aka sequences) *)

Section Head_Last.
Variables (T : Type) (d : T).

Definition hb s := head d (behead s).

Lemma nth_behead s n : nth d (behead s) n = nth d s n.+1.
Proof. by case: s =>//; rewrite /= nth_nil. Qed.

Lemma last_rev : forall s, last d (rev s) = head d s.
Proof. by elim=> [//|s IHs]; rewrite rev_cons last_rcons. Qed.
End Head_Last.

Lemma nth_map_dflt (C : Type) (x0 : C) (f : C -> C) (n : nat) (s : seq C) :
  nth x0 (map f s) n = if size s <= n then x0 else f (nth x0 s n).
Proof.
case: (leqP (size s) n); last exact: nth_map.
by move=> ?; rewrite nth_default // size_map.
Qed.

Section Map2.
Variable C : Type.
Variable x0 : C.
Variable op : C -> C -> C.
Variable op' : C -> C. (* will be [id] or [opp] *)
Fixpoint map2 (s1 : seq C) (s2 : seq C) : seq C :=
  match s1, s2 with
    | _, [::] => s1
    | [::], b :: s4 => op' b :: map2 [::] s4
    | a :: s3, b :: s4 => op a b :: map2 s3 s4
  end.

Lemma size_map2 s1 s2 : size (map2 s1 s2) = maxn (size s1) (size s2).
Proof.
elim: s1 s2 => [|x1 s1 IHs1] s2; elim: s2 => [|x2 s2 IHs2] //=.
- by rewrite IHs2 !max0n.
- by rewrite IHs1 maxnSS.
Qed.

Lemma nth_map2_dflt (n : nat) (s1 s2 : seq C) :
  nth x0 (map2 s1 s2) n =
    match size s1 <= n, size s2 <= n with
    | true, true => x0
    | true, false => op' (nth x0 s2 n)
    | false, true => nth x0 s1 n
    | false, false => op (nth x0 s1 n) (nth x0 s2 n)
    end.
Proof.
elim: s1 s2 n => [|x1 s1 IHs1] s2 n.
  elim: s2 n => [|x2 s2 /= IHs2] n //=; first by rewrite nth_nil.
  by case: n =>[|n] //=; rewrite IHs2.
case: s2 => [|x2 s2] /=.
  by case: leqP => H; last rewrite nth_default.
case: n => [|n] //=.
by rewrite IHs1.
Qed.
End Map2.

Lemma nth_mkseq_dflt (C : Type) (x0 : C) (f : nat -> C) (n i : nat) :
  nth x0 (mkseq f n) i = if n <= i then x0 else f i.
Proof.
case: (leqP n i); last exact: nth_mkseq.
by move=> ?; rewrite nth_default // size_mkseq.
Qed.

Lemma nth_take_dflt (n0 : nat) (T : Type) (x0 : T) (i : nat) (s : seq T) :
  nth x0 (take n0 s) i = if n0 <= i then x0 else nth x0 s i.
Proof.
case: (leqP n0 i) => Hi; last by rewrite nth_take.
by rewrite nth_default // size_take; case: ltnP=>// H'; apply: leq_trans H' Hi.
Qed.

(** Generic results to be instantiated for polynomials' opp, add, sub, mul... *)

Section map_proof.
Variables (V T : Type) (Rel : V -> T -> Prop).
Variables (dv : V) (dt : T).
Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing).
Variables (vop : V -> V) (top : T -> T).
Hypothesis H0 : Rel dv dt.
Hypothesis H0t : forall v : V, Rel v dt -> Rel (vop v) dt.
Hypothesis H0v : forall t : T, Rel dv t -> Rel dv (top t).
Hypothesis Hop : forall v t, Rel v t -> Rel (vop v) (top t).
Lemma map_correct :
  forall sv st, RelP sv st -> RelP (map vop sv) (map top st).
Proof.
move=> sv st Hnth k; move/(_ k) in Hnth.
rewrite !nth_map_dflt.
do 2![case:ifP]=> A B //; rewrite ?(nth_default _ A) ?(nth_default _ B) in Hnth.
- exact: H0v.
- exact: H0t.
- exact: Hop.
Qed.
End map_proof.

Section map2_proof.
Variables (V T : Type) (Rel : V -> T -> Prop).
Variables (dv : V) (dt : T).
Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing).
Variables (vop : V -> V -> V) (vop' : V -> V).
Variables (top : T -> T -> T) (top' : T -> T).
Hypothesis H0 : Rel dv dt.

Hypothesis H0t : forall v : V, Rel v dt -> Rel (vop' v) dt.
Hypothesis H0v : forall t : T, Rel dv t -> Rel dv (top' t).
Hypothesis Hop' : forall v t, Rel v t -> Rel (vop' v) (top' t).

Hypothesis H0eq : forall v, Rel v dt -> v = dv.

Hypothesis H0t1 : forall (v1 v2 : V) (t1 : T), Rel v1 t1 ->
                                               Rel v2 dt ->
                                               Rel (vop v1 v2) t1.
Hypothesis H0t2 : forall (v1 v2 : V) (t2 : T), Rel v1 dt ->
                                               Rel v2 t2 ->
                                               Rel (vop v1 v2) (top' t2).
Hypothesis H0v1 : forall (v1 : V) (t1 t2 : T), Rel v1 t1 ->
                                               Rel dv t2 ->
                                               Rel v1 (top t1 t2).
Hypothesis H0v2 : forall (v2 : V) (t1 t2 : T), Rel dv t1 ->
                                               Rel v2 t2 ->
                                               Rel (vop' v2) (top t1 t2).
Hypothesis Hop : forall v1 v2 t1 t2, Rel v1 t1 -> Rel v2 t2 -> Rel (vop v1 v2) (top t1 t2).

Lemma map2_correct :
  forall sv1 sv2 st1 st2,
    RelP sv1 st1 ->
    RelP sv2 st2 ->
    RelP (map2 vop vop' sv1 sv2) (map2 top top' st1 st2).
Proof using H0 H0t H0v Hop' H0eq H0t1 H0t2 H0v1 H0v2 Hop.
move=> sv1 sv2 st1 st2 H1 H2 k; move/(_ k) in H1; move/(_ k) in H2.
rewrite !nth_map2_dflt.
do 4![case:ifP]=> A B C D; rewrite
  ?(nth_default _ A) ?(nth_default _ B) ?(nth_default _ C) ?(nth_default _ D) //
  in H1 H2; try solve
  [exact: H0t1|exact: H0t2|exact: H0v1|exact: H0v2|exact: Hop'|exact: Hop|exact: H0t|exact: H0v].
- rewrite (H0eq (H0t H2)); exact: H1.
- rewrite (H0eq H1); apply: H0v; exact: H2.
Qed.
End map2_proof.

Section fold_proof.
Variables (V T : Type).
Variable Rel : V -> T -> Prop.
Variables (dv : V) (dt : T).
Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing).
Hypothesis H0 : Rel dv dt.
Lemma foldr_correct fv ft sv st :
  RelP sv st ->
  (forall xv yv, Rel xv dt -> Rel yv dt -> Rel (fv xv yv) dt) ->
  (forall xt yt, Rel dv xt -> Rel dv yt -> Rel dv (ft xt yt)) ->
  (forall xv xt yv yt, Rel xv xt -> Rel yv yt -> Rel (fv xv yv) (ft xt yt)) ->
  Rel (foldr fv dv sv) (foldr ft dt st).
Proof.
move=> Hs H0t H0v Hf.
elim: sv st Hs => [ | xv sv IH1] st Hs /=.
- elim: st Hs => [ | xt st IH2] Hs //=.
  apply: H0v; first by move/(_ 0): Hs.
  by apply: IH2 => k; move/(_ k.+1): Hs; rewrite /= nth_nil.
- case: st Hs => [ | xt st] Hs /=.
  + apply: H0t; first by move/(_ 0): Hs.
    change dt with (foldr ft dt [::]).
    apply/IH1 => k.
    by move/(_ k.+1): Hs; rewrite /= nth_nil.
  + apply: Hf; first by move/(_ 0): Hs.
    apply: IH1.
    move=> k; by move/(_ k.+1): Hs.
Qed.

Lemma seq_foldr_correct fv ft sv st (zv := [::]) (zt := [::]) :
  RelP sv st ->
  (forall xv yv, Rel xv dt -> RelP yv zt -> RelP (fv xv yv) zt) ->
  (forall xt yt, Rel dv xt -> RelP zv yt -> RelP zv (ft xt yt)) ->
  (forall xv xt yv yt, Rel xv xt -> RelP yv yt -> RelP (fv xv yv) (ft xt yt)) ->
  RelP (foldr fv zv sv) (foldr ft zt st).
Proof.
move=> Hs H0t H0v Hf.
elim: sv st Hs => [ | xv sv IH1] st Hs /=.
- elim: st Hs => [ | xt st IH2] Hs //=.
  apply: H0v; first by move/(_ 0): Hs.
  by apply: IH2 => k; move/(_ k.+1): Hs; rewrite /= nth_nil.
- case: st Hs => [ | xt st] Hs /=.
  + apply: H0t; first by move/(_ 0): Hs.
    change zt with (foldr ft zt [::]).
    apply/IH1 => k.
    by move/(_ k.+1): Hs; rewrite /= nth_nil.
  + apply: Hf; first by move/(_ 0): Hs.
    apply: IH1.
    move=> k; by move/(_ k.+1): Hs.
Qed.

End fold_proof.

Section Foldri.
Variables (T R : Type) (f : T -> nat -> R -> R) (z0 : R).

Fixpoint foldri (s : seq T) (i : nat) : R :=
  match s with
  | [::] => z0
  | x :: s' => f x i (foldri s' i.+1)
  end.
End Foldri.

Section foldri_proof.
Variables (V T : Type).
Variable Rel : V -> T -> Prop.
Variables (dv : V) (dt : T).
Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing).
Hypothesis H0 : Rel dv dt.
Lemma seq_foldri_correct fv ft sv st (zv := [::]) (zt := [::]) i :
  RelP sv st ->
  (* RelP zv zt -> *)
  (forall xv yv i, Rel xv dt -> RelP yv zt -> RelP (fv xv i yv) zt) ->
  (forall xt yt i, Rel dv xt -> RelP zv yt -> RelP zv (ft xt i yt)) ->
  (forall xv xt yv yt i, Rel xv xt -> RelP yv yt -> RelP (fv xv i yv) (ft xt i yt)) ->
  RelP (foldri fv zv sv i) (foldri ft zt st i).
Proof.
move=> Hs H0t H0v Hf.
elim: sv st Hs i => [ | xv sv IH1] st Hs i /=.
- elim: st Hs i => [ | xt st IH2] Hs i //=.
  apply: H0v; first by move/(_ 0): Hs.
  by apply: IH2 => k; move/(_ k.+1): Hs; rewrite /= nth_nil.
- case: st Hs => [ | xt st] Hs /=.
  + apply: H0t; first by move/(_ 0): Hs.
    change zt with (foldri ft zt [::] i.+1).
    apply/IH1 => k.
    by move/(_ k.+1): Hs; rewrite /= nth_nil.
  + apply: Hf; first by move/(_ 0): Hs.
    apply: IH1.
    move=> k; by move/(_ k.+1): Hs.
Qed.
End foldri_proof.

Section mkseq_proof.
Variables (V T : Type).
Variable Rel : V -> T -> Prop.
Variables (dv : V) (dt : T).
Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing).
Hypothesis H0 : Rel dv dt.
Lemma mkseq_correct fv ft (mv mt : nat) :
  (forall k : nat, Rel (fv k) (ft k)) ->
  (* the following 2 hyps hold if mv <> mt *)
  (forall k : nat, mv <= k < mt -> fv k = dv) ->
  (forall k : nat, mt <= k < mv -> fv k = dv) ->
  RelP (mkseq fv mv) (mkseq ft mt).
Proof.
move=> Hk Hv1 Hv2 k; rewrite !nth_mkseq_dflt.
do 2![case: ifP]=> A B.
- exact: H0.
- by rewrite -(Hv1 k) // B ltnNge A.
- by rewrite (Hv2 k) // A ltnNge B.
- exact: Hk.
Qed.
End mkseq_proof.

Section misc_proofs.
Variables (V T : Type).
Variable Rel : V -> T -> Prop.
Variables (dv : V) (dt : T).
Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing).
Lemma set_nth_correct sv st bv bt n :
  RelP sv st ->
  Rel bv bt ->
  RelP (set_nth dv sv n bv) (set_nth dt st n bt).
Proof. by move=> Hs Hb k; rewrite !nth_set_nth /=; case: ifP. Qed.

Lemma drop_correct sv st n :
  RelP sv st ->
  RelP (drop n sv) (drop n st).
Proof. by move=> Hs k; rewrite !nth_drop; apply: Hs. Qed.

Hypothesis H0 : Rel dv dt.
Lemma ncons_correct sv st n :
  RelP sv st ->
  RelP (ncons n dv sv) (ncons n dt st).
Proof. by move=> Hs k; rewrite !nth_ncons; case: ifP. Qed.

End misc_proofs.

Definition eqr (r1 r2 : R) : bool :=
  if Req_EM_T r1 r2 is left _ then true else false.

Lemma eqrP : Equality.axiom eqr.
Proof.
by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP).
Qed.

Canonical Structure real_eqMixin := EqMixin eqrP.
Canonical Structure real_eqType := Eval hnf in EqType R real_eqMixin.

Fact RplusA : associative (Rplus).
Proof. by move=> *; rewrite Rplus_assoc. Qed.

Fact RmultA : associative (Rmult).
Proof. by move=> *; rewrite Rmult_assoc. Qed.

Import Monoid.

Canonical Radd_monoid := Law RplusA Rplus_0_l Rplus_0_r.
Canonical Radd_comoid := ComLaw Rplus_comm.

Canonical Rmul_monoid := Law RmultA Rmult_1_l Rmult_1_r.
Canonical Rmul_comoid := ComLaw Rmult_comm.

Canonical Rmul_mul_law := MulLaw Rmult_0_l Rmult_0_r.
Canonical Radd_add_law := AddLaw Rmult_plus_distr_r Rmult_plus_distr_l.


(* CoreMLDef.v *)
(* 2014/10/31 by Yukiyoshi Kameyama *)

Require Export SfLib.
Require Import Ascii String.
Require Import BinInt.

Open Scope type_scope.

Inductive ty : Type :=
  | Tint   : ty
  | Tbool  : ty
  | Tvar   : id -> ty
  | Tarrow : ty -> ty -> ty
  | Tprod  : ty -> ty -> ty
.

Inductive pty : Type :=
  | Tmono  : ty -> pty
  | Tall   : ty -> pty -> pty  (* Tall (Tvar id) pty *)
.

Inductive tm : Type :=
  | TM_var   : id -> tm
  | TM_int   : Z -> tm
  | TM_bool  : bool -> tm
  | TM_add   : tm -> tm -> tm
  | TM_eq    : tm -> tm -> tm
  | TM_gt    : tm -> tm -> tm
  | TM_lam   : tm -> tm -> tm
  | TM_app   : tm -> tm -> tm
  | TM_pair  : tm -> tm -> tm
  | TM_left  : tm -> tm
  | TM_right : tm -> tm
  | TM_if    : tm -> tm -> tm -> tm
  | TM_fix   : tm -> tm -> tm -> tm   (* fix f x -> t100 *)
  | TM_let   : tm -> tm -> tm -> tm   (* let x = t100 in t2 *)
.

(*
Eval compute in 3.
Eval compute in 3%Z.
Eval compute in (-3)%Z.
*)

Inductive valueT : Type :=
  | V_int    : Z -> valueT
  | V_bool   : bool -> valueT
  | V_pair   : valueT -> valueT -> valueT
  | V_closure : tm -> tm -> list (tm * valueT) -> valueT   (* lam x -> t in E *)
  | V_rclosure : tm -> tm -> tm -> list (tm * valueT) -> valueT   (* fix f x -> t in E *)
.

Definition envT := list (tm * valueT).

Inductive tytm :=
  | typeOf : tm -> ty -> tytm
.
Notation "t '\in' T" := (typeOf t T) (at level 80).

Fixpoint lookup (x : id) (Gamma : list tytm) : option ty :=
  match Gamma with
      | ((TM_var y) \in T) :: Gamma2 => if eq_id_dec x y then Some T
                                     else lookup x Gamma2
      | _  => None
  end
.
Definition extend Gamma t T := (t \in T) :: Gamma.

Reserved Notation "Gamma '|-' tt" (at level 90, t at level 40).

Inductive has_type : list tytm -> tytm -> Set :=
  | T_int    : forall n Gamma,
                 Gamma |- (TM_int n) \in Tint
  | T_bool   : forall b Gamma,
                 Gamma |- (TM_bool b) \in Tbool
  | T_var    : forall id1 ty1 Gamma,
                 (lookup id1 Gamma = Some ty1)
                  -> Gamma |- (TM_var id1) \in ty1
  | T_add    : forall t1 t2 Gamma,
                 Gamma |- t1 \in Tint
               -> Gamma |- t2 \in Tint
               -> Gamma |- (TM_add t1 t2) \in Tint
  | T_eq    : forall t1 t2 Gamma,
                 Gamma |- t1 \in Tint
               -> Gamma |- t2 \in Tint
               -> Gamma |- (TM_eq t1 t2) \in Tbool
  | T_gt    : forall t1 t2 Gamma,
                 Gamma |- t1 \in Tint
               -> Gamma |- t2 \in Tint
               -> Gamma |- (TM_gt t1 t2) \in Tbool
  | T_lam    : forall x t ty1 ty2 Gamma,
                 ((x \in ty1) :: Gamma) |- t \in ty2
                 -> Gamma |- (TM_lam x t) \in (Tarrow ty1 ty2)
  | T_app    : forall t1 t2 ty1 ty2 Gamma,
                 Gamma |- t1 \in (Tarrow ty1 ty2)
               -> Gamma |- t2 \in ty1
               -> Gamma |- (TM_app t1 t2) \in ty2
  | T_pair   : forall t1 t2 ty1 ty2 Gamma,
               Gamma |- t1 \in ty1
               -> Gamma |- t2 \in ty2
               -> Gamma |- (TM_pair t1 t2) \in (Tprod ty1 ty2)
  | T_left   : forall t ty1 ty2 Gamma,
               Gamma |- t \in (Tprod ty1 ty2)
               -> Gamma |- (TM_left t) \in ty1
  | T_right  : forall t ty1 ty2 Gamma,
               Gamma |- t \in (Tprod ty1 ty2)
               -> Gamma |- (TM_right t) \in ty2
  | T_if  : forall t1 t2 t3 ty1 Gamma,
                Gamma |- t1 \in Tbool
               -> Gamma |- t2 \in ty1
               -> Gamma |- t3 \in ty1
               -> Gamma |- (TM_if t1 t2 t3) \in ty1
  | T_fix  : forall f x t ty1 ty2 Gamma,
               ((f \in Tarrow ty1 ty2) :: (x \in ty1) :: Gamma) |- t \in ty2
               -> Gamma |- (TM_fix f x t) \in Tarrow ty1 ty2
  | T_let  : forall t1 t2 x ty1 ty2 Gamma,
               Gamma |- t1 \in ty1
               -> (x \in ty1) :: Gamma |- t2 \in ty2
               -> Gamma |- (TM_let x t1 t2) \in ty2
where "Gamma '|-' tt" := (has_type Gamma tt).

Ltac Rint      := apply T_int.
Ltac Rbool     := apply T_bool.
Ltac Rvar      := apply T_var; reflexivity.
Ltac Radd      := apply T_add.
Ltac Rplus     := apply T_add.   (* alias for rule name *)
Ltac Req       := apply T_eq.
Ltac Rgt       := apply T_gt.
Ltac Rcomp     := apply T_gt.    (* alias for rule name *)
Ltac Rlam      := apply T_lam.
Ltac Rlambda   := apply T_lam.
Ltac Rapply T1 := apply (T_app _ _ T1 _ _).
Ltac Rapp   T1 := apply (T_app _ _ T1 _ _).
Ltac Rpair     := apply T_pair.
Ltac Rleft T2  := apply (T_left _ _ T2 _).
Ltac Rright T1 := apply (T_right _ T1 _ _).
Ltac Rif       := apply T_if.
Ltac Rfix      := apply T_fix.
Ltac Rlet T1   := apply (T_let _ _ _ T1).


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_functor.examples.composition
     lax_functor.examples.identity
     lax_transformation.lax_transformation
     lax_transformation.examples.identity
     general_category.

Section LaxLeftIdentityInv.
  Context `{Univalence}
          {C D : BiCategory}.
  Variable (F : LaxFunctor C D).

  Definition lax_left_identity_inv_d
    : PseudoTransformation_d F (lax_comp (lax_id_functor D) F).
  Proof.
    make_pseudo_transformation.
    - exact (fun X => id₁ (F X)).
    - exact (fun X Y f => (left_unit_inv (F ₁ f)) ∘ right_unit (F ₁ f)).
    - exact (fun X Y f => right_unit_inv (F ₁ f) ∘ left_unit (F ₁ f)).
  Defined.

  Definition is_lax_left_inv_d
    : is_pseudo_transformation_p lax_left_identity_inv_d.
  Proof.
    make_is_pseudo_transformation.
    - intros X Y f g α ; simpl.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite !vcomp_assoc.
      reflexivity.
    - intros X ; cbn in *.
      rewrite <- right_unit_id_is_left_unit_id.
      rewrite !vcomp_assoc.
      rewrite right_unit_right.
      rewrite vcomp_right_identity.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      rewrite right_unit_id_is_left_unit_id.
      rewrite vcomp_assoc.
      rewrite left_unit_right.
      rewrite !vcomp_right_identity.
      reflexivity.
    - intros X Y Z f g ; cbn in *.
      rewrite vcomp_assoc.
      rewrite right_unit_natural.
      rewrite <- vcomp_assoc.
      rewrite left_unit_inv_natural.
      symmetry.
      rewrite <- (vcomp_left_identity (id₂ (F ₁ f))).
      rewrite <- (vcomp_left_identity (id₂ (F ₁ g))).
      rewrite !interchange.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ (_ ∘ (_ ∘ z))) (vcomp_assoc _ _ _)^).
      rewrite triangle_l.
      rewrite <- interchange.
      rewrite left_unit_left.
      rewrite vcomp_left_identity, hcomp_id₂.
      rewrite !vcomp_left_identity, !vcomp_right_identity.
      f_ap.
      rewrite <- right_unit_assoc.
      rewrite <- !vcomp_assoc.
      f_ap.
      pose (left_unit_inv_assoc (F ₁ g) (F ₁ f)) as p.
      unfold bc_whisker_r in p.
      rewrite p ; clear p.
      rewrite <- vcomp_assoc.
      rewrite assoc_left.
      apply vcomp_left_identity.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite right_unit_left, vcomp_left_identity.
      apply left_unit_right.
    - intros X Y f ; simpl in *.
      rewrite !vcomp_assoc.
      rewrite (ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite left_unit_left, vcomp_left_identity.
      apply right_unit_right.
  Qed.

  Definition lax_left_identity_inv
    : PseudoTransformation F (lax_comp (lax_id_functor D) F)
    := Build_PseudoTransformation lax_left_identity_inv_d is_lax_left_inv_d.
End LaxLeftIdentityInv.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Local Open Scope Z_scope.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults32.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Local Open Scope string_scope.
Import ListNotations.
Require Import bedrock2.NotationsCustomEntry.
Require Import bedrock2.Syntax.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults32.
Require Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Syntax.
Require Import Coq.Lists.List.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.UnsaturatedSolinasHeuristics.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import bedrock2.Semantics.
Import ListNotations.
Import Syntax.Coercions.
Local Open Scope Z_scope.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.ReifiedOperation.
Require Import Crypto.Bedrock.Field.Common.Names.VarnameGenerator.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Local Open Scope Z_scope.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import bedrock2.Array.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Syntax.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import coqutil.Word.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import Crypto.Spec.MxDH.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Operation.
Require Import Crypto.Bedrock.Field.Translation.Parameters.SelectParameters.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.Tactics.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import bedrock2.Semantics.
Require Import Theory.Fields.QuadraticFieldExtensions.
Import ListNotations.
Import Syntax.Coercions.
Local Open Scope Z_scope.
Require Import Bedrock.Field.bls12prime.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Arithmetic.UniformWeight.
Require Import Theory.WordByWordMontgomery.MontgomeryCurveSpecs.
Require Import Theory.WordByWordMontgomery.MontgomeryRingTheory.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Require Import coqutil.Map.Properties.
Require Import bedrock2.Lift1Prop.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.Bignum.
Require Import Bedrock.Util.Word.
Require Import SOSReduction.
Require Import Bedrock.Util.Util.
Require Import Bedrock.Util.Bignum.
Require Import Bedrock.Util.Tactics.
Require Import Bedrock.Util.SeparationLogic.

Local Open Scope Z_scope.

(*Parameters to be changed: specify prime and import reification from cache.*)
    Require Import Bedrock.Examples.felem_copy_64.
    Local Definition felem_suffix := felem_copy_64.aff.
    Local Notation m := bls12prime.m.
    Local Definition prefix := "bls12_"%string. (* placed before function names *)
    Local Notation a := (0 mod m).
    Local Notation b := (4 mod m).

    Existing Instances Defaults64.default_parameters Defaults64.default_parameters_ok bls12_bedrock2_funcs
    bls12_bedrock2_specs bls12_bedrock2_correctness.

(*  We instantiate specs of all imported bedrock2 functions.
    This needs to be done for typeclass inference to work properly.*)

  Instance spec_of_reified_mul :
  spec_of (append prefix "mul") := spec_of_mul.

  Instance spec_of_reified_square :
  spec_of (append prefix "square") := spec_of_square.

  Instance spec_of_reified_add :
  spec_of (append prefix "add") := spec_of_add.

  Instance spec_of_reified_sub :
  spec_of (append prefix "sub") := spec_of_sub.

  Instance spec_of_reified_opp :
  spec_of (append prefix "opp") := spec_of_opp.

  Instance spec_of_reified_to_montgomery :
  spec_of (append prefix "to_montgomery") := spec_of_to_montgomery.

  Instance spec_of_reified_from_montgomery :
  spec_of (append prefix "from_montgomery") := spec_of_from_montgomery.

  Instance spec_of_reified_nonzero :
  spec_of (append prefix "nonzero") := spec_of_nonzero.

  Instance spec_of_reified_selectznz :
  spec_of (append prefix "selectznz") := spec_of_selectznz.

  Instance spec_of_reified_to_bytes :
  spec_of (append prefix "to_bytes") := spec_of_to_bytes.

  Instance spec_of_reified_from_bytes :
  spec_of (append prefix "from_bytes") := spec_of_from_bytes.
(*Instantiation done.*)

(*Initializing parameters; do not touch*)
Local Notation bw := width.
Local Notation m' := (@WordByWordMontgomery.m' m bw).
Notation n := (WordByWordMontgomery.n m (@width semantics)).
Local Notation eval := (@WordByWordMontgomery.WordByWordMontgomery.eval bw n).
Local Notation valid := (@WordByWordMontgomery.valid bw n m).
Local Notation from_mont := (@WordByWordMontgomery.from_montgomerymod bw n m m').
Local Notation thisword := (@word semantics).
Local Definition valid_words w := valid (List.map (@Interface.word.unsigned width thisword) w).
Local Definition map_words := List.map (@Interface.word.unsigned width thisword).
Local Notation r := (WordByWordMontgomery.r bw).
Local Notation r' := (WordByWordMontgomery.r' m bw).
Local Definition num_bytes := Eval compute in (Z.of_nat (((Z.to_nat bw * n) / 8)%nat)).
Local Notation three_b := (3 * b mod m).
Local Notation uw := (uweight bw).
Notation three_b_list := (MontgomeryCurveSpecs.three_b_list bw n three_b).
Definition three_b_mont := Eval vm_compute in (MontgomeryCurveSpecs.three_b_mont_list m bw n m' three_b).

(*Lemmas of correctness of parameters to be used for montgomery arithmetic.*)
Lemma a_small : a = a mod m.
Proof. auto. Qed.

Lemma three_b_small : three_b = three_b mod m.
Proof. auto. Qed.

Lemma r'_correct : (2 ^ bw * r') mod m = 1.
Proof. auto with zarith. Qed.

Lemma m'_correct : (m * m') mod 2 ^ bw = -1 mod 2 ^ bw.
Proof. auto with zarith. Qed.

Lemma bw_big : 0 < bw.
Proof. cbv; auto. Qed.

Lemma m_big : 1 < m.
Proof. cbv; auto. Qed.

Lemma n_nz : n <> 0%nat.
Proof. cbv; discriminate. Qed.

Lemma m_small : m < (2 ^ bw) ^ Z.of_nat n.
Proof. cbv; auto. Qed.

Lemma m_big' : 1 < m.
Proof. cbv; auto. Qed.

Lemma n_small : Z.of_nat n < 2 ^ bw.
Proof. cbv. auto. Qed.

Ltac wbw_conds :=
  repeat first [ progress apply r'_correct
               | progress apply m'_correct
               | progress apply bw_big
               | progress apply m_big
               | progress apply n_nz
               | progress apply m_small
               | progress apply m'_correct
               | progress apply m'_correct ].

Local Notation from_mont_correct := (@from_mont_correct m bw n r' m' r'_correct m'_correct bw_big n_nz m_big m_small).
Local Notation valid_mod := (valid_mod m bw n r' m' r'_correct m'_correct bw_big n_nz m_big m_small).
Local Notation mont_add := (mont_add m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
Local Notation mont_sub := (mont_sub m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
Local Notation mont_mul := (mont_mul m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
Local Notation valid_valid'_equiv := (valid_valid'_equiv m bw n n_nz m_big).
Local Notation evfrom_mod := (evfrom_mod' m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
Local Notation eval_from_mont_inj := (eval_from_mont_inj m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
Local Notation mont_zero := (mont_zero m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).
Local Notation toZ_ofZ_eq := (toZ_ofZ_eq n n_nz n_small m).

Lemma num_bytes_correct : num_bytes = Z.of_nat (n * Z.to_nat word_size_in_bytes).
Proof. cbv; auto. Qed.

Lemma three_b_mont_correct : three_b_mont = (WordByWordMontgomery.to_montgomerymod bw n m m' three_b_list).
Proof. vm_compute (WordByWordMontgomery.to_montgomerymod bw n m m' three_b_list). reflexivity. Qed.

Lemma three_b_valid: valid three_b_list.
Proof.
  apply three_b_list_valid; cbv; auto. intros; discriminate.
Qed.

Lemma three_b_mont_valid : valid three_b_mont.
Proof.
  unfold three_b_mont. cbv; repeat split; auto; intros; discriminate.
Qed.

Lemma a_mont_zero : (a_mont m bw n r' m' a a_small
    r'_correct m'_correct bw_big n_nz m_small m_big) = mont_zero.
  Proof.
    apply mont_enc_irr. simpl. cbv [a_mont_list]. apply f_equal. cbv [a_list].
    assert (a = 0) by (cbv; reflexivity). rewrite H. cbv. auto.
  Qed.

(*Some notation*)
Notation my_mul := (my_mul m).
Notation my_add := (my_add m).
Notation my_sub := (my_sub m).

Local Infix "*'" := my_mul (at level 70).
Local Infix "+'" := my_add (at level 80).
Local Infix "-'" := my_sub (at level 80).

Local Notation evfrom x := (eval (from_mont x)).

(*Gallina specs
  Note that we use 2 different specs; one is more general and proven correct in Fiats library.
  The other is correct only when the parameter a is 0; which is the case here.
  Their equivalence is shown below.*)
Definition BLS12_add_Gallina_spec :=
    BLS12_add_Gallina_spec m bw n m' a three_b.

Definition BLS12_add_Gallina_spec_a_0 X1 Y1 Z1 X2 Y2 Z2 outx outy outz :=
  let X1 := evfrom X1 in
  let Y1 := evfrom Y1 in
  let Z1 := evfrom Z1 in
  let X2 := evfrom X2 in
  let Y2 := evfrom Y2 in
  let Z2 := evfrom Z2 in
  let t0 := X1*'X2 in
  let t1 := Y1*'Y2 in
  let t2 := Z1*'Z2 in
  let t3 := X1+'Y1 in
  let t4 := X2+'Y2 in
  let t3 := t3*'t4 in
  let t4 := t0+'t1 in
  let t3 := t3-'t4 in
  let t4 := X1+'Z1 in
  let t5 := X2+'Z2 in
  let t4 := t4*'t5 in
  let t5 := t0+'t2 in
  let t4 := t4-'t5 in
  let t5 := Y1+'Z1 in
  let X3 := Y2+'Z2 in
  let t5 := t5*'X3 in
  let X3 := t1+'t2 in
  let t5 := t5-'X3 in
  let Z3 := eval three_b_list *'t2 in
  let X3 := t1-'Z3 in
  let Z3 := t1+'Z3 in
  let Y3 := X3*'Z3 in
  let t1 := t0+'t0 in
  let t1 := t1+'t0 in
  let t4 := eval three_b_list *'t4 in
  let t0 := t1*'t4 in
  let Y3 := Y3+'t0 in
  let t0 := t5*'t4 in
  let X3 := t3*'X3 in
  let X3 := X3-'t0 in
  let t0 := t3*'t1 in
  let Z3 := t5*'Z3 in
  let Z3 := Z3+'t0 in
  ( eval (from_mont (outx)), eval (from_mont ( outy)), eval (from_mont(outz))) = (X3, Y3, Z3).

Lemma add_specs_equiv : forall X1 X2 Y1 Y2 Z1 Z2 outx outy outz,
  BLS12_add_Gallina_spec X1 X2 Y1 Y2 Z1 Z2 outx outy outz
  <-> BLS12_add_Gallina_spec_a_0 X1 X2 Y1 Y2 Z1 Z2 outx outy outz.
Proof.
  intros X1 X2 Y1 Y2 Z1 Z2 outx outy outz.
  unfold BLS12_add_Gallina_spec, MontgomeryCurveSpecs.BLS12_add_Gallina_spec.
  unfold BLS12_add_Gallina_spec_a_0.
  assert (H0 : eval (a_list bw n a) = 0) by auto. rewrite H0.

  remember (evfrom X1) as x1.
  remember (evfrom X2) as x2.
  remember (evfrom Y1) as y1.
  remember (evfrom Y2) as y2.
  remember (evfrom Z1) as z1.
  remember (evfrom Z2) as z2.
  remember (eval three_b_list) as tb.
  unfold my_mul, my_add, my_sub.
  pull_Zmod.

  split; (intros H; rewrite H; apply pair_equal_spec; split; [apply pair_equal_spec; split| ]; apply (f_equal (fun y => y mod m)); ring).
Qed.

(*Bedrock2 Function Definition*)
Definition BLS12_add : Syntax.func :=
    let outx := "outx" in
    let outy := "outy" in
    let outz := "outz" in

    let X1 := "X1" in
    let Y1 := "Y1" in
    let Z1 := "Z1" in

    let X2 := "X2" in
    let Y2 := "Y2" in
    let Z2 := "Z2" in

    let t0 := "t0" in
    let t1 := "t1" in
    let t2 := "t2" in
    let t3 := "t3" in
    let t4 := "t4" in
    let t5 := "t5" in
    let three_b := "three_b" in
    let add := (append prefix "add") in
    let mul := (append prefix "mul") in
    let sub := (append prefix "sub") in
    ("BLS12_add", (
      [outx; outy; outz; X1; Y1; Z1; X2; Y2; Z2], [],
      bedrock_func_body:(
      stackalloc num_bytes as three_b{
        stackalloc num_bytes as t0 {
          stackalloc num_bytes as t1 {
            stackalloc num_bytes as t2 {
              stackalloc num_bytes as t3 {
                stackalloc num_bytes as t4 {
                  stackalloc num_bytes as t5 {
                      store(three_b, (coq:(nth 0 three_b_mont 0)));
                      store(three_b + coq:(8), coq:(nth 1 three_b_mont 0));
                      store(three_b + coq:(16), coq:(nth 2 three_b_mont 0));
                      store(three_b + coq:(24), coq:(nth 3 three_b_mont 0));
                      store(three_b + coq:(32), coq:(nth 4 three_b_mont 0));
                      store(three_b + coq:(40), coq:(nth 5 three_b_mont 0));
                      mul (t0, X1, X2);
                      mul (t1, Y1, Y2);
                      mul (t2, Z1, Z2);
                      add (t3, X1, Y1);
                      add (t4, X2, Y2);
                      mul (t3, t3, t4);
                      add (t4, t0, t1);
                      sub (t3, t3, t4);
                      add (t4, X1, Z1);
                      add (t5, X2, Z2);
                      mul (t4, t4, t5);
                      add (t5, t0, t2);
                      sub (t4, t4, t5);
                      add (t5, Y1, Z1);
                      add (outx, Y2, Z2);
                      mul (t5, t5, outx);
                      add (outx, t1, t2);
                      sub (t5, t5, outx);
                      mul (outz, three_b, t2);
                      sub (outx, t1, outz);
                      add (outz, outz, t1);
                      mul (outy, outx, outz);
                      add (t1, t0, t0);
                      add (t1, t1, t0);
                      mul (t4, three_b, t4);
                      mul (t0, t1, t4);
                      add (outy, outy, t0);
                      mul (t0, t5, t4);
                      mul (outx, t3, outx);
                      sub (outx, outx, t0);
                      mul (t0, t3, t1);
                      mul (outz, t5, outz);
                      add (outz, outz, t0)
                  }
                }
              }
            }
          }
        }
      }
      )
    )).

Local Open Scope string_scope.
Local Infix "*" := sep : sep_scope.
Delimit Scope sep_scope with sep.
Local Notation toZ x := (List.map Interface.word.unsigned x).

(*Bedrock2 function Spec*)
Instance spec_of_BLS12_add: spec_of BLS12_add :=
fun functions : list (string * (list string * list string * cmd)) =>
    forall (wX1 wY1 wZ1 wX2 wY2 wZ2 : list Interface.word.rep)
    (pX1 pY1 pZ1 pX2 pY2 pZ2  poutx pouty poutz: Interface.word.rep)
    (wold_outx wold_outy wold_outz: list Interface.word.rep) (t : Semantics.trace)
    (m0 : Interface.map.rep) (Rout : Interface.map.rep -> Prop),
    valid (List.map Interface.word.unsigned wX1) /\
    valid (List.map Interface.word.unsigned wY1) /\
    valid (List.map Interface.word.unsigned wZ1) /\
    valid (List.map Interface.word.unsigned wX2) /\
    valid (List.map Interface.word.unsigned wY2) /\
    valid (List.map Interface.word.unsigned wZ2) ->
    ((Bignum n pX1 wX1) *
    (Bignum n pX2 wX2) *
    (Bignum n pY1 wY1) *
    (Bignum n pY2 wY2) *
    (Bignum n pZ1 wZ1) *
    (Bignum n pZ2 wZ2) *
    (Bignum n poutx wold_outx) * (Bignum n pouty wold_outy) * (Bignum n poutz wold_outz) * Rout)%sep m0 ->
    WeakestPrecondition.call functions ( "BLS12_add") t m0
    ([poutx; pouty; poutz; pX1; pY1; pZ1; pX2; pY2; pZ2])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutx wouty woutz : list Interface.word.rep) Rout,
        (
                (BLS12_add_Gallina_spec (toZ wX1) (toZ wY1) (toZ wZ1) (toZ wX2) (toZ wY2)
                (toZ wZ2) (toZ woutx) (toZ wouty) (toZ woutz)/\
                valid (List.map Interface.word.unsigned woutx) /\
                valid (List.map Interface.word.unsigned wouty) /\
                valid (List.map Interface.word.unsigned woutz)) /\
             ((Bignum n pX1 wX1) *
             (Bignum n pX2 wX2) *
             (Bignum n pY1 wY1) *
             (Bignum n pY2 wY2) *
             (Bignum n pZ1 wZ1) *
             (Bignum n pZ2 wZ2) * (Bignum n poutx woutx) * (Bignum n pouty wouty) * (Bignum n poutz woutz) * Rout)%sep m'))).

(*Number of lemmas and tactics used in proof.*)
(*First some notation is introduced*)
Notation msplit := Interface.map.split.

Notation montsub a b c :=
  ((eval (from_mont (a))) mod m =
      (eval (from_mont (b)) -
       eval (from_mont (c))) mod m).

Notation montadd a b c :=
  ((eval (from_mont (a))) mod m =
      (eval (from_mont (b)) +
       eval (from_mont (c))) mod m).

Notation montmul a b c :=
  ((eval (from_mont (a))) mod m =
      (eval (from_mont (b)) *
       eval (from_mont (c))) mod m).

Notation S aw := (word.add (word.of_Z word_size_in_bytes) aw).

Add Ring Mp : (MontgomeryRingTheory.mont_enc_ring BLS12Curve_G1.m bw n r' m' r'_correct m'_correct bw_big n_nz m_small m_big).

Local Notation wordof_Z := (@word.of_Z width
(@word _)).

(*Tactics to cast from Bignum to bytes*)
Ltac unfold_Bignum_list_step H l :=
  destruct l; [unfold Bignum in H; sepsimpl_hyps; discriminate|].

Ltac unfold_Bignum_list H l :=
  repeat unfold_Bignum_list_step H l;
  assert (Hl : l = []) by ( unfold Bignum in H; sepsimpl_hyps;
  apply length_nil;
  match goal with
  | [H : Datatypes.length _ = n|- _ ]
    => repeat apply NPeano.Nat.succ_inj in H; auto
  end); rewrite Hl in H; clear Hl.

Ltac straightline' :=
  match goal with
  | [Hminit : ?mcond (?minit)
      |- forall (_ : @word.rep _ _)
                (_ _ : @Interface.map.rep _ _ _),
          anybytes _ ?numbytes _ -> msplit _ ?minit _ -> _ ] =>
      let a := (fresh "a") in
      let mStack := (fresh "mStack") in
      let mnew := (fresh "mnew") in
      let Hany := (fresh "Hany") in
      let HanyBignum := (fresh "HanyBignum") in
      let anyval := (fresh "anyval") in
      let Hsplit := (fresh "Hsplit") in
      let Hmnew := (fresh "Hmnew") in
      let R := (fresh "R") in
      intros a mStack mnew Hany Hsplit; destruct (anybytes_Bignum n num_bytes mStack a num_bytes_correct Hany) as [anyval HanyBignum];
      destruct (alloc_seps_alt mnew minit mStack mcond (Bignum _ _ _) Hsplit (empty_frame mcond minit Hminit) (empty_frame (Bignum _ _ _) mStack HanyBignum)) as [R Hmnew];
      clear Hany Hsplit HanyBignum
  | _ => straightline
  end.

Ltac clear_emps_step :=
lazymatch goal with
| [H' : (_ * _)%sep ?mem |- _] =>
    let thisH := (fresh "H") in
    eassert (thisH : (emp _ * _)%sep mem) by ecancel_assumption; clear H'; sepsimpl_hyps
    end.

Ltac get_list_from_length l :=
  (repeat (destruct l; [discriminate| ])); destruct l; [| discriminate].

Ltac Bignum_to_Scalars l := let Hsep := (fresh "Hsep") in
eassert (Hsep : (Bignum n _ l * _)%sep _) by ecancel_assumption;
apply Bignum_manyScalars_R in Hsep; sepsimpl_hyps; get_list_from_length l;
lazymatch goal with
| [H : (many_Scalars n _ _ * _)%sep _ |- _] => let Htemp := (fresh "Htemp") in
  eassert (Htemp : many_Scalars n _ _ = many_Scalars _ _ _) by (vm_compute n; auto);
  rewrite Htemp in H; clear Htemp;
  repeat rewrite many_Scalars_next in H;
  rewrite many_Scalars_nil in H
| _ => fail
end.

(*Tactics to store constants into allocated memory*)
Ltac subst_vars :=
  lazymatch goal with
  | [|- WeakestPrecondition.store _ _ ?thisa _ _] =>
    try subst thisa
  end.

Ltac handle_store_step :=
  lazymatch goal with
    | [ |- ((Scalars.scalar ?thisa _) * _)%sep _ ] =>
     try subst thisa; repeat (rewrite next_word'; try (rewrite word_add_0)); ecancel_assumption
  end.

Ltac handle_store :=
  repeat (subst_vars; eapply Scalars.store_word_of_sep; [handle_store_step|]; repeat straightline'); clear_old_seps.

(*Tactics to handle stack allocation*)
Lemma alloc_anybytes_Bignum n0 : forall (R : Interface.map.rep -> Prop) a m m0 m1, n0 = Z.of_nat (n * Z.to_nat word_size_in_bytes) -> msplit m m0 m1 -> anybytes a n0 m1 -> R m0 -> exists l, (R * (Bignum n a l))%sep m.
Proof.
  intros.
  pose proof (anybytes_Bignum n m1 n0 a).
  apply H3 in H1; [| cbv; auto].
  destruct H1. exists x. unfold sep. exists m0. exists m1. auto.
Qed.

Ltac alloc_Bignum := lazymatch goal with
  | Hprec : _ ?mpre |- forall _ _ _, anybytes _ ?n0 _ ->
    msplit _ ?mpre _ -> _ =>
    let a := (fresh "a") in
    let mStack := (fresh "mStack") in
    let mComb := (fresh "mComb") in
    let Hany := (fresh "Hany") in
    let Hcomb := (fresh "Hcomb") in
    let Htemp := (fresh "Htemp") in
    intros a mStack mComb Hany Hcomb;
    assert (Htemp : n0 = Z.of_nat (n * Z.to_nat word_size_in_bytes)) by (cbv; auto);
    destruct (alloc_anybytes_Bignum n0 _ a mComb mpre mStack Htemp Hcomb Hany Hprec); clear Htemp Hprec Hany
  | _ => idtac
  end.

Ltac straightline_stackalloc_Bignum := try (alloc_Bignum); straightline.

(*Lemmas for Montgomery arithmetic*)
Lemma valid_toZ_wordofZ_three_b_mont : valid (toZ (List.map (@word.of_Z bw _) three_b_mont)).
Proof.
  simpl. repeat rewrite Zmod_small; [apply three_b_mont_valid|..]; split; lia.
Qed.

Lemma montadd_to_Mp x y z (Hx : valid' m bw n x) (Hy : valid' m bw n y) (Hz : valid' m bw n z) :
  montadd z x y -> (enc_mont BLS12Curve_G1.m bw n z Hz)
    = mont_add (enc_mont BLS12Curve_G1.m bw n x Hx) (enc_mont BLS12Curve_G1.m bw n y Hy).
Proof.
  intros; apply eval_from_mont_inj; rewrite !mont_enc_val; rewrite mont_add_spec;
  rewrite evfrom_mod; [| apply valid_valid'_equiv]; auto.
Qed.

Lemma montsub_to_Mp x y z (Hx : valid' m bw n x) (Hy : valid' m bw n y) (Hz : valid' m bw n z) :
montsub z x y -> (enc_mont BLS12Curve_G1.m bw n z Hz)
  = mont_sub (enc_mont BLS12Curve_G1.m bw n x Hx) (enc_mont BLS12Curve_G1.m bw n y Hy).
Proof.
intros; apply eval_from_mont_inj; rewrite !mont_enc_val; rewrite mont_sub_spec;
rewrite evfrom_mod; [| apply valid_valid'_equiv]; auto.
Qed.

Lemma montmul_to_Mp x y z (Hx : valid' m bw n x) (Hy : valid' m bw n y) (Hz : valid' m bw n z) :
montmul z x y -> (enc_mont BLS12Curve_G1.m bw n z Hz)
  = mont_mul (enc_mont BLS12Curve_G1.m bw n x Hx) (enc_mont BLS12Curve_G1.m bw n y Hy).
Proof.
intros; apply eval_from_mont_inj; rewrite !mont_enc_val; rewrite mont_mul_spec;
rewrite evfrom_mod; [| apply valid_valid'_equiv]; auto.
Qed.

Ltac assert_valid' x H' := let H := (fresh "Hvalid") in
assert (H : MontgomeryRingTheory.valid' BLS12Curve_G1.m bw n (toZ x)) by (apply H'; assumption).

Local Notation valid' := (valid' m bw n).

Ltac assertvalid' x H :=
  tryif (assert (H : valid' x) by assumption; clear H) then idtac else (assert (H : valid' x) by (apply valid_valid'_equiv; assumption)).

Lemma three_b_mont_rewrite (H : valid'  (toZ (map wordof_Z three_b_mont))) : ((MontgomeryCurveSpecs.three_b_mont m bw n r' m' three_b
three_b_small r'_correct m'_correct bw_big n_nz m_small m_big) = {| val := toZ (map wordof_Z three_b_mont); Hvalid := H |}).
Proof.
  apply mont_enc_irr. rewrite !mont_enc_val. rewrite (toZ_ofZ_eq three_b_mont three_b_mont_valid).
  cbv [MontgomeryCurveSpecs.three_b_mont]. rewrite mont_enc_val.
  rewrite three_b_mont_correct. reflexivity.
Qed.

(*To use return values of callees*)
Ltac this_mod' x :=
  lazymatch goal with
  | H1 : montsub x ?y ?z |- _ => let Htemp := (fresh "Htemp") in let Htemp' := (fresh "Htemp") in
  assertvalid' y Htemp;
  assertvalid' z Htemp';
  lazymatch goal with | Hy : valid' y |- _ => lazymatch goal with Hz : valid' z |- _ =>
  rewrite (montsub_to_Mp y z x Hy Hz) end end; [| apply H1]; try (this_mod' y); try (this_mod' z)
  | H1 : montadd x ?y ?z |- _ => let Htemp := (fresh "Htemp") in let Htemp' := (fresh "Htemp") in
  assertvalid' y Htemp;
  assertvalid' z Htemp';
  lazymatch goal with | Hy : valid' y |- _ => lazymatch goal with Hz : valid' z |- _ =>
  rewrite (montadd_to_Mp y z x Hy Hz) end end; [| apply H1]; try (this_mod' y); try (this_mod' z)
  | H1 : montmul x ?y ?z |- _ => let Htemp := (fresh "Htemp") in let Htemp' := (fresh "Htemp") in
  assertvalid' y Htemp;
  assertvalid' z Htemp';
  lazymatch goal with | Hy : valid' y |- _ => lazymatch goal with Hz : valid' z |- _ =>
  rewrite (montmul_to_Mp y z x Hy Hz) end end; [| apply H1]; try (this_mod' y); try (this_mod' z)
  | _ => idtac
  end.

Ltac remember_mont x := lazymatch goal with
| H1 : valid' x |- _ => let p := (fresh "p") in
  remember {| val := x; Hvalid := H1 |} as p
end.

(*For function calls*)
Ltac next_call :=
  lazymatch goal with
    | [H' : (_ * _)%sep _ |- _] =>
      straightline_call; [| ecancel_assumption| ecancel_assumption| ecancel_assumption| ]; [eauto| ]; repeat straightline'; clear H'; repeat clear_emps_step
    end.

(*For undoing memory fragmentation done by stack allocation*)
Ltac defrag_in_context := lazymatch goal with
| [
    |- exists (_ _ : @Interface.map.rep _ _ _),
      (anybytes ?addr _ _) /\ (msplit ?mem _ _) /\ _ ] =>
      repeat match goal with
      | [ H : (?Rl * ((Bignum _ addr ?aval) * ?Rr))%sep mem |- _ ] =>
        let Ha := (fresh "Ha") in
        let m := fresh "m" in
        let Htemp := fresh "Htemp" in
        let Htemp' := fresh "Htemp'" in
        let mStack := fresh "mStack" in
        assert (Ha : ((Bignum n addr aval) * (Rl * Rr))%sep mem) by ecancel_assumption; clear H;
        destruct Ha as [mStack [m [ Htemp [Htemp' ]]]];
        exists m; exists mStack; split; [ eapply Bignum_anybytes; [|eassumption]; cbv; reflexivity | split; [apply Properties.map.split_comm; auto| clear Htemp Htemp']]
      | [ H : (((Bignum _ addr ?aval) * ?Rr))%sep mem |- _ ] =>
        let Ha := (fresh "Ha") in
        let m := fresh "m" in
        let mStack := fresh "mStack" in
        assert (Ha : ((Bignum n addr aval) * (Rr))%sep mem) by ecancel_assumption; clear H;
        destruct Ha as [mStack [m [Htemp [Htemp' ]]]];
        exists m; exists mStack; split; [ eapply Bignum_anybytes; [|eassumption]; cbv; reflexivity | split; [apply Properties.map.split_comm; auto| clear Ha]]

      | [ H : _ mem |- _ ] => apply (sep_assoc_proj2 mem) in H
      end
end.

Ltac defrag_in_context' := lazymatch goal with
| [ |- exists (_ _ : @Interface.map.rep _ _ _),
      (anybytes ?addr _ _) /\ (msplit ?mem _ _) /\ _ ] =>
      match goal with
      | [ H : _ mem |- _ ] => cleanup_hyp H mem
      end
    end; defrag_in_context.

Theorem G1_add_func_ok : program_logic_goal_for_function! BLS12_add.
Proof.
  repeat straightline_stackalloc_Bignum.
  (*initialize proof*)

  (* clear H33 Hmnew Hmnew0 Hmnew1 Hmnew2 Hmnew3 Hmnew4. *)
  repeat straightline'.

  (*Unfolding Bignum-notation in order to store constant into newly allocated memory*)
  Bignum_to_Scalars x. clear H39.

  (*Store values*)
  handle_store.

  (*Rephrase hypothesis in terms of Bignum again*)
  eassert ( (Bignum n a (List.map wordof_Z three_b_mont) * _)%sep _).
  {
    unfold Bignum. sepsimpl; [ cbv; auto|]. unfold array. cbv [three_b_mont map].
    repeat rewrite (word_add_comm _ (word.of_Z word_size_in_bytes)).
    repeat (rewrite next_word' in H45; try rewrite word_add_0 in H45).
    ecancel_assumption.
  }

  clear H45 H33.

  (*Must be in context to automate function calls*)
  pose proof valid_toZ_wordofZ_three_b_mont as H3b.

  (*Handle function calls.*)
  repeat next_call.

  (*Rephrase as single separation hypothesis in context*)
  repeat defrag_in_context'.
  repeat straightline.

  (*Postcondition*)

  (*First, trivial subgoals are handled.*)
  split; [reflexivity| ]. split; [reflexivity| ].
  do 4 eexists.
  split; [| ecancel_assumption].
  split; [| auto].

  (*Gallina specification part of postcondition*)
  unfold BLS12_add_Gallina_spec.

  (*Inputs/Outputs are valid elements of Mp*)
  pose proof (valid_valid'_equiv).
  assert_valid' wX1 H105.
  assert_valid' wX2 H105.
  assert_valid' wY1 H105.
  assert_valid' wY2 H105.
  assert_valid' wZ1 H105.
  assert_valid' wZ2 H105.
  assert_valid' x28 H105.
  assert_valid' x25 H105.
  assert_valid' x31 H105.

  (*Use alternative curve spec for a = 0*)
  destruct (MontgomeryCurveSpecs.BLS12_add_specs_equiv' m bw n r' m' (BLS12Curve_G1.a) three_b a_small three_b_small r'_correct m'_correct bw_big n_nz m_small m_big _ _ _ _ _ _ _ _ _ Hvalid Hvalid0 Hvalid1 Hvalid2 Hvalid3 Hvalid4 Hvalid5 Hvalid6 Hvalid7) as [Heq _].
  apply Heq; clear Heq.

  (*Use return values from function calls*)
  this_mod' (toZ x28).
  this_mod' (toZ x25).
  this_mod' (toZ x31).

  unfold BLS12_add_mont_spec.

  (*alias each Mp ring element to help ring tactic*)
  rewrite <- three_b_mont_rewrite.
  rewrite a_mont_zero.

  remember_mont (toZ wX1).
  remember_mont (toZ wX2).
  remember_mont (toZ wY1).
  remember_mont (toZ wY2).
  remember_mont (toZ wZ1).
  remember_mont (toZ wZ2).
  remember (MontgomeryCurveSpecs.three_b_mont BLS12Curve_G1.m bw n r' m'
  three_b three_b_small r'_correct m'_correct bw_big n_nz
  m_small m_big) as pnew.

  (*Equality of each coordinate is solved by ring tactic*)
  apply pair_equal_spec; split; [apply pair_equal_spec; split; ring| ring].
Qed.

(*Version that allows overlapping inputs/outputs. *)

  (*Bedrock2 Function Definition*)
Definition BLS12_add_alt : Syntax.func :=
    let outx := "outx" in
    let outy := "outy" in
    let outz := "outz" in

    let X1 := "X1" in
    let Y1 := "Y1" in
    let Z1 := "Z1" in

    let X2 := "X2" in
    let Y2 := "Y2" in
    let Z2 := "Z2" in

    let X1sep := "X1sep" in
    let Y1sep := "Y1sep" in
    let Z1sep := "Z1sep" in

    let X2sep := "X2sep" in
    let Y2sep := "Y2sep" in
    let Z2sep := "Z2sep" in

    let BLS12_add := "BLS12_add" in
    let felem_copy := ("felem_copy" ++ felem_suffix) in
    ("BLS12_add_alt", (
      [outx; outy; outz; X1; Y1; Z1; X2; Y2; Z2], [],
      bedrock_func_body:(

      stackalloc num_bytes as X1sep {
      stackalloc num_bytes as Y1sep {
      stackalloc num_bytes as Z1sep {
      stackalloc num_bytes as X2sep {
      stackalloc num_bytes as Y2sep {
      stackalloc num_bytes as Z2sep {

          (*copying X1*)
          felem_copy(X1sep, X1);
          felem_copy(Y1sep, Y1);
          felem_copy(Z1sep, Z1);
          felem_copy(X2sep, X2);
          felem_copy(Y2sep, Y2);
          felem_copy(Z2sep, Z2);

          BLS12_add (outx, outy, outz, X1sep, Y1sep, Z1sep, X2sep, Y2sep, Z2sep)
        }}}}}}
      )
    )).

(*Bedrock2 function Spec*)

Instance spec_of_BLS12_add_alt: spec_of BLS12_add_alt :=
fun functions : list (string * (list string * list string * cmd)) =>
    forall (wX1 wY1 wZ1 wX2 wY2 wZ2 : list Interface.word.rep)
    (pX1 pY1 pZ1 pX2 pY2 pZ2  poutx pouty poutz: Interface.word.rep)
    (wold_outx wold_outy wold_outz: list Interface.word.rep) (t : Semantics.trace)
    (m0 : @Interface.map.rep (@word.rep (@width (@semantics default_parameters))
    (@word (@semantics default_parameters))) Init.Byte.byte (@mem (@semantics default_parameters))) (RX1 RY1 RZ1 RX2 RY2 RZ2 Rout : (@Interface.map.rep (@word.rep (@width (@semantics default_parameters))
    (@word (@semantics default_parameters))) Init.Byte.byte (@mem (@semantics default_parameters))) -> Prop),
    valid (List.map Interface.word.unsigned wX1) /\
    valid (List.map Interface.word.unsigned wY1) /\
    valid (List.map Interface.word.unsigned wZ1) /\
    valid (List.map Interface.word.unsigned wX2) /\
    valid (List.map Interface.word.unsigned wY2) /\
    valid (List.map Interface.word.unsigned wZ2) ->
    (Bignum n pX1 wX1 * RX1)%sep m0 ->
    (Bignum n pX2 wX2 * RX2)%sep m0 ->
    (Bignum n pY1 wY1 * RY1)%sep m0 ->
    (Bignum n pY2 wY2 * RY2)%sep m0 ->
    (Bignum n pZ1 wZ1 * RZ1)%sep m0 ->
    (Bignum n pZ2 wZ2 * RZ2)%sep m0 ->
    ((Bignum n poutx wold_outx) * (Bignum n pouty wold_outy) * (Bignum n poutz wold_outz))%sep m0 ->
    WeakestPrecondition.call functions ( "BLS12_add_alt") t m0
    ([poutx; pouty; poutz; pX1; pY1; pZ1; pX2; pY2; pZ2])
    (fun (t' : Semantics.trace) (m' : Interface.map.rep)
        (rets : list Interface.word.rep) =>
    t = t' /\
    rets = nil /\
    (exists (woutx wouty woutz : list Interface.word.rep) Rout,
        (
                (BLS12_add_Gallina_spec (toZ wX1) (toZ wY1) (toZ wZ1) (toZ wX2) (toZ wY2)
                (toZ wZ2) (toZ woutx) (toZ wouty) (toZ woutz)/\
                valid (List.map Interface.word.unsigned woutx) /\
                valid (List.map Interface.word.unsigned wouty) /\
                valid (List.map Interface.word.unsigned woutz)) /\
             ((Bignum n poutx woutx) * (Bignum n pouty wouty) * (Bignum n poutz woutz) * Rout)%sep m'))).

Local Definition num_bytes_word := Eval compute in (Z.of_nat (n * Z.to_nat word_size_in_bytes)).

Lemma numbytes_correct : num_bytes_word = (Z.of_nat (n * Z.to_nat word_size_in_bytes)).
Proof. auto. Qed.

Ltac straightline'' :=
lazymatch goal with
| [Hminit : ?mcond (?minit)
    |- forall (_ : @word.rep _ _)
              (_ _ : @Interface.map.rep _ _ _),
        anybytes _ ?numbytes _ -> msplit _ ?minit _ -> _ ] =>
    let a := (fresh "a") in
    let mStack := (fresh "mStack") in
    let mnew := (fresh "mnew") in
    let Hany := (fresh "Hany") in
    let HanyBignum := (fresh "HanyBignum") in
    let anyval := (fresh "anyval") in
    let Hsplit := (fresh "Hsplit") in
    let Hmnew := (fresh "Hmnew") in
    let R := (fresh "R") in
    intros a mStack mnew Hany Hsplit; destruct (anybytes_Bignum n mStack numbytes a numbytes_correct Hany) as [anyval HanyBignum];
    destruct (alloc_seps_alt mnew minit mStack mcond (Bignum _ _ _) Hsplit (empty_frame mcond minit Hminit) (empty_frame (Bignum _ _ _) mStack HanyBignum)) as [R Hmnew];
    clear Hany Hsplit HanyBignum
| _ => straightline
end.

Theorem G1_add_alt_func_ok : program_logic_goal_for_function! BLS12_add_alt.
Proof.
  do 9 straightline''.

  (*Assert single hypothesis for stackallocation.*)
  remember (Bignum n pX1 wX1 * RX1)%sep as RX1'.
  remember (Bignum n pY1 wY1 * RY1)%sep as RY1'.
  remember (Bignum n pZ1 wZ1 * RZ1)%sep as RZ1'.
  remember (Bignum n pX2 wX2 * RX2)%sep as RX2'.
  remember (Bignum n pY2 wY2 * RY2)%sep as RY2'.
  remember (Bignum n pZ2 wZ2 * RZ2)%sep as RZ2'.
  remember ((Bignum n poutx wold_outx * Bignum n pouty wold_outy *
  Bignum n poutz wold_outz)%sep) as Rout'.

  assert (
      id (fun m => (RX1' m /\ RY1' m /\ RZ1' m /\ RX2' m /\ RY2' m /\ RZ2' m /\ Rout' m)) m0).
  {
    cbv [id]. split; auto. repeat (split; auto); auto.
  }

  (*Allocate memory on stack. *)
   repeat straightline''. clear H1 Hmnew Hmnew0 Hmnew1 Hmnew2 Hmnew3.
   repeat straightline''. cbv [id] in *.

  (*Handle calls to felem_copy*)
   Ltac copy_next R fR thism pX1 wX1 RX1 a H := straightline_call; [subst R; remember fR as thisP;
   eassert (thisH : ((fun m => (Bignum n pX1 wX1 * RX1)%sep m /\ thisP m) * Bignum n a _ * _)%sep thism) by (subst thisP; ecancel_assumption); subst thisP; apply thisH |]; clear H; repeat straightline.

   copy_next RX1' (fun m => RY1' m /\ RZ1' m /\ RX2' m /\ RY2' m /\ RZ2' m /\ Rout' m) mnew4 pX1 wX1 RX1 a Hmnew4.
   copy_next RY1' (fun m => RZ1' m /\ RX2' m /\ RY2' m /\ RZ2' m /\ Rout' m) a6 pY1 wY1 RY1 a0 H21.
   copy_next RZ1' (fun m => RX2' m /\ RY2' m /\ RZ2' m /\ Rout' m) a8 pZ1 wZ1 RZ1 a1 H21.
   copy_next RX2' (fun m => RY2' m /\ RZ2' m /\ Rout' m) a6 pX2 wX2 RX2 a2 H21.
   copy_next RY2' (fun m => RZ2' m /\ Rout' m) a8 pY2 wY2 RY2 a3 H21.
   copy_next RZ2' (fun m => Rout' m) a6 pZ2 wZ2 RZ2 a4 H21.

  (*Handle function call*)
  repeat straightline.
  straightline_call.
  2: {
    assert (Hnumlimbs : n = num_limbs) by auto.
    repeat rewrite Hnumlimbs. repeat rewrite Hnumlimbs in H21. ecancel_assumption.
  }
  1: split; auto.

  (*Defragment memory in context after stack allocation. *)
  repeat straightline.
  repeat Tactics.defrag_in_context (WordByWordMontgomery.n BLS12Curve_G1.m (@width semantics)).
  repeat straightline.

  (*Postcondition*)
  do 2 split; auto.
  do 4 eexists. split.
  2: ecancel_assumption.
  split; auto.
Qed.

(* From bedrock2 Require Import ToCString Bytedump.
Definition bls12_c_add :=
  c_module (add :: nil).
  Definition bls12_c_mul :=
  c_module (mul :: nil).
  Definition bls12_c_sub :=
  c_module (sub :: nil).
  Definition G1_add :=
  c_module (BLS12_add :: nil).
  Definition G1_add_alt :=
    c_module (BLS12_add_alt :: nil).
    Definition G1_felem_copy :=
      c_module (felem_copy :: nil).
  Eval compute in G1_felem_copy. *)


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Local Open Scope Z_scope.

Local Definition m := 2^256 - 2^224 + 2^192 + 2^96 - 1.
Local Definition machine_wordsize := 64.
Local Definition prefix := "p256_"%string. (* placed before function names *)

Instance names : names_of_operations.
  make_names_of_operations prefix. Defined.

Definition ops : wbwmontgomery_reified_ops m machine_wordsize.
  make_reified_ops. Time Defined.

Instance p256_bedrock2_funcs : bedrock2_wbwmontgomery_funcs.
funcs_from_ops ops. Defined.

Instance p256_bedrock2_specs : bedrock2_wbwmontgomery_specs.
specs_from_ops ops m. Defined.

Instance p256_bedrock2_correctness : bedrock2_wbwmontgomery_correctness.
prove_correctness ops m machine_wordsize. Defined.

(*
Require Import bedrock2.NotationsCustomEntry.
Require Import bedrock2.NotationsInConstr.
Require Import bedrock2.Syntax.
Local Open Scope bedrock_expr.
Coercion expr.var : string >-> Syntax.expr.
Eval cbv [add p256_bedrock2_funcs] in add.
Eval cbv [spec_of_add p256_bedrock2_specs] in spec_of_add.
*)


(** * Pre-lB-systems (unital)

By Vladimir Voevodsky, split off the file prelBsystems.v on March 3, 2015 *)

Require Import UniMath.Foundations.All.

Require Import TypeTheory.Csystems.hSet_ltowers.
Require Export TypeTheory.Bsystems.prelB_non_unital.
Require Export TypeTheory.Bsystems.dlt.

(** *** The structure formed by operations dlt *)

Definition dlt_layer_0 ( BB : lBsystem_carrier ) :=
  ∑ dlt : dlt_ops_type BB, dlt_ax0_type dlt.

Definition dlt_layer_0_to_dlt_ops_type ( BB : lBsystem_carrier ) :
  dlt_layer_0 BB -> dlt_ops_type BB := pr1 .
Coercion dlt_layer_0_to_dlt_ops_type : dlt_layer_0 >-> dlt_ops_type .

(** *** Complete definition of a (unital) pre-lB-system *)

Definition prelBsystem :=
  ∑ BB : prelBsystem_non_unital, dlt_layer_0 BB.

(** This definition adds exactly what Definition 2.2 adds in arXiv:1410.5389v1
    to a non-unital pre-B-system. *)

Definition prelBsystem_pr1 : prelBsystem -> prelBsystem_non_unital := pr1 .
Coercion prelBsystem_pr1 : prelBsystem >-> prelBsystem_non_unital .

(** *** Access functions for the operation dlt and its zeroth axiom *)

Definition dlt_op { BB : prelBsystem } : dlt_ops_type BB := pr2 BB .

Definition dlt_ax0 { BB : prelBsystem } : dlt_ax0_type ( @dlt_op BB ) :=
  pr2 ( pr2 BB ) .

(* End of the file prelB.v *)


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require option.Option.

(* Why3 goal *)
Definition nth: forall {a:Type} {a_WT:WhyType a}, Z -> (list a) ->
  (option a).
intros a a_WT.
exact (fix nth n l := match l with nil => None | cons h t => if Zeq_bool n Z0 then Some h else nth (n - 1)%Z t end).
Defined.

(* Why3 goal *)
Lemma nth_def : forall {a:Type} {a_WT:WhyType a}, forall (n:Z) (l:(list a)),
  match l with
  | Init.Datatypes.nil => ((nth n l) = Init.Datatypes.None)
  | (Init.Datatypes.cons x r) => ((n = 0%Z) -> ((nth n
      l) = (Init.Datatypes.Some x))) /\ ((~ (n = 0%Z)) -> ((nth n
      l) = (nth (n - 1%Z)%Z r)))
  end.
Proof.
intros a a_WT n l.
revert n.
induction l.
easy.
intros n.
split.
intros ->.
easy.
simpl.
generalize (Zeq_bool_if n 0).
now case Zeq_bool.
Qed.


(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** * Free variables/names for the locally nameless style.

cf <http://www.chargueraud.org/viewcoq.php?sFile=softs%2Ftlc%2Fsrc%2FLibVar.v>
*)
(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(* [Coq.Classes.EquivDec] is Coq 8.3 only *)
Require Import Coq.Arith.Lt.
Require Import Coq.Arith.Plus.
Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.ListSet.
Require Import Coq.Lists.List.
Require Import Coq.Classes.EquivDec.
Require Import WrengrUtil.Tactics.Introv.
Require Import WrengrUtil.CoqExtras.Nat.
Require Export LNSet.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** * The specification of a variable type. *)
Class VarType (Var : Set) `{eqdec0 : EqDec Var eq} :=
    { inhabVar : inhabited Var
    ; freshVar : forall (xs:set Var), { x:Var | x \notin xs }
    }.

(*
(** * The specification of a variable type. *)
Module Type VarType.

    (** We leave the type of variables abstract. *)
    Parameter Var : Set.

    (** This type is inhabited. *) (* TODO: who cares? *)
    Parameter inhabVar : inhabited Var.

    (** We can decide equality on this type. *)
    Parameter _VarEqDec : EqDec Var eq. (* Defines [equiv_dec] *)
    Program Instance VarEqDec : EqDec Var eq := _VarEqDec.

    (** Finally, we have a means of generating fresh variables. *)
    Parameter freshVar : forall (xs:set Var), { x:Var | x \notin xs }.

End VarType.
*)

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** * A concrete implementation using [nat]. *)

(* Module Export NatVar : VarType. *)
Section NatVar.

    Definition NatVar := nat.

    Lemma inhabNatVar : inhabited NatVar.
    Proof. apply inhabits. apply 0. Qed.

    Program Instance NatVarEqDec : EqDec NatVar eq := nat_eq_eqdec.

    (** The method for generating a new variable. *)
    Definition genNatVar (xs:set NatVar) : NatVar :=
        1 + fold_right plus 0 xs.

    (** A lemma for proving [freshNatVar_spec]. *)
    Lemma genNatVar_gt : forall xs x, x \in xs -> x < genNatVar xs.
    Proof.
      unfold genNatVar. induction xs as [ | x0 xs0 IHxs0 ]; introv I.
        contradiction.

        destruct I as [H | I']; simpl.
          rewrite H.
          auto with arith.
          (* Or:
          rewrite plus_Snm_Sn_m.
          apply lt_plus_trans.
          apply lt_n_Sn.
          *)

          simpl in IHxs0.
          (* [auto with arith] can's solve any part of this. Is the [plus_Snm_n_Sm] hint really in there?? *)
          rewrite plus_Snm_n_Sm.
          rewrite plus_comm.
          apply lt_plus_trans.
          apply IHxs0.
          exact I'.
    Qed.

    (** Proof that [genNatVar] satisfies the specification of [freshNatVar]. *)
    Lemma freshNatVar_spec : forall xs, (genNatVar xs) \notin xs.
    Proof.
      unfold genNatVar, not. intros xs H.
      destruct xs as [|x0 xs0]; simpl.
        assumption.

        inversion_clear H as [H0|H0]; simpl in H0.
          rewrite plus_comm in H0.
          exact (succ_plus_discr _ _ H0).

          apply genNatVar_gt    in H0.
          unfold genNatVar      in H0.
          rewrite plus_Snm_n_Sm in H0.
          destruct x0.
            exact (lt_irrefl _ H0).

            assert (H1 : forall x y, ~ S x + y < y) by auto with arith.
            exact (H1 _ _ H0).
    Qed.

    Lemma freshNatVar : forall (xs:set NatVar), { x:NatVar | x \notin xs }.
    Proof. intros xs. exists (genNatVar xs). apply freshNatVar_spec. Qed.

    Instance NatVarType : VarType NatVar :=
        { inhabVar := inhabNatVar
        ; freshVar := freshNatVar
        }.
End NatVar.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(* N.B., must use a section in order to use [Context], and must use
    [Context] instead of [Variable] if we want it to be implicit.
    However, we can't define notations inside sections if we want
    them to last. *)
Section DerivedOperations.
Context  {Var : Set}.
Context `{VT : VarType Var}.

(** Freshness of [n] variables [ys] from a set [xs] and from one another. *)
Fixpoint Fresh (xs:set Var) (n:nat) (ys:set Var) {struct ys} : Prop :=
    match ys, n with
    | nil,    O    => True
    | y::ys', S n' => y \notin xs /\ Fresh (y \a xs) n' ys'
    | _,      _    => False
    end.
(* TODO: How is this different than [Hint Unfold Fresh]? *)
Hint Extern 1 (Fresh _ _ _) => simpl.

(** Generate [n] variables fresh from [xs] and one another. *)
Lemma freshVars : forall xs n, { ys:set Var | Fresh xs n ys }.
Proof.
  intros. generalize dependent xs. induction n; intros xs;
    [ exists nil; auto
    | destruct (freshVar xs)   as [y  Hy]
    ; destruct (IHn (y \a xs)) as [ys Hys]
    ; exists (y::ys); auto
    ].
Qed.
End DerivedOperations.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ fin. *)


(*|
###########################################################################
Coq: Implementation of ``split_string`` and proof that nothing gets deleted
###########################################################################

:Link: https://stackoverflow.com/q/73026651
|*)

(*|
Question
********

After working for a whole day on this with no success, I might get
some help here. I implemented a splitString function in Coq: It takes
a String (In my case a ``list ascii``) and a function ``f : ascii ->
bool``. I want to return a list of strings (In my case a ``list (list
ascii)``) containing all the substrings. This means that the input
string has been split at all ``ascii``\ s where f is true. Note that
my output also includes the delimiter as a string (``list ascii``) of
length 1.

My first question: exists this function in a library somewhere? Many
other, non-functional, programming languages I know includes this
function in the default library.

I didn't found something, so I implemented it by myself:
|*)

Require Import Ascii List. (* .none *)
Import ListNotations. (* .none *)
Fixpoint split_string (f : ascii -> bool) (z s : list ascii): list (list ascii) :=
  match s with
  | [] => [rev z]
  | h :: t => match f h with
              | true => ([rev z] ++ [[h]]) ++ split_string f [] t
              | false => split_string f (h :: z) t
              end
  end.

(*|
The function needs to be called with an empty ``z``, like ``Compute
split_string isWhite [] some_string.``

The clue of that List ``z`` is that the current string gets saved in
it until a delimiter is found, then the whole string ``z`` gets
returned. I don't see another way of solving this.

The problem with the List ``z`` is that, when it comes to proofing, it
makes trouble.

I want to proove that, when the output of the splitString function
gets flattened (in Coq with ``concat``) it is equal to the input,
because the splitString method does not remove information. I
formulated a theorem:
|*)

Variable isWhite : ascii -> bool. (* .none *)
Theorem not_more_not_less_splitWhite : forall s : list ascii,
    s = concat (split_string isWhite [] s).

(*|
But every time when I try to solve this with induction, I get stuck
because the List ``z`` is not empty anymore (since one char which is
not white has been processed). Then I can never apply the induction
hypothesis. This is how far I've made it:
|*)

Proof.
  intros s. induction s.
  - simpl. reflexivity.
  - simpl. destruct isWhite eqn:W.
    * simpl. rewrite <- IHs. reflexivity.
    *
Abort. (* .none *)

(*|
I found myself in willing to induce in ``s`` a second time, but I
think this is bullshit and does not use the power of induction. So, if
the answer to my first question is no, my second question is how do I
solve this, or is there a better implementation for ``split_string``.
|*)

(*|
Answer (Ana Borges)
*******************

This problem is common whenever proving things by induction about a
fixpoint with an accumulator, such as yours. The standard advice is to
find a stronger statement that has your desired result as a corollary.
This stronger statement should be about all lists, not only the empty
list. The latter should hopefully be easier to prove with induction,
since the stronger statement leads to a stronger induction hypothesis.

In your case, I guess (but haven't checked) the stronger statement
could be something like:
|*)

Theorem not_more_not_less_splitWhite_stronger : forall (z s : list ascii),
    rev z ++ s = concat (split_string isWhite z s).
Abort. (* .none *)

(*|
Answer (Pierre Castéran)
************************

Here is a proof of your theorem:
|*)

Goal forall p l buf, rev buf ++ l = concat (split_string p buf l).
Proof.
  induction l as [ | a l IHl].
  - intro. now cbn.
  - cbn. case_eq (p a); intro Ha.
    + intro buf. repeat rewrite concat_cons. now rewrite <- IHl.
    + intro buf. rewrite <- IHl. cbn. now rewrite <- app_assoc.
Qed.

(*|
Please note that it worked thanks to the universal quantification on
``buf`` in the induction hypothesis. It was made easier thanks to the
order of quantifications in the goal statement.

Ana's statement can be proved the same way, with a small bookkeeping
sequence before the induction:
|*)

Goal forall p buf l, rev buf ++ l = concat (split_string p buf l).
Proof.
  intros p buf l; revert buf.
  induction l as [| a l IHl].
  (* ... *)


From Hammer Require Import Hammer.

From ZornsLemma Require Export FunctionProperties.
Require Export Relation_Definitions.
From ZornsLemma Require Import Relation_Definitions_Implicit.
From ZornsLemma Require Import CSB.
From ZornsLemma Require Import EnsemblesSpec.

Inductive Cardinal : Type :=
| cardinality: Type -> Cardinal.

Fixpoint n_element_set (n:nat) : Set :=
match n with
| O => False
| S m => option (n_element_set m)
end.
Definition nat_to_cardinal (n:nat) :=
cardinality (n_element_set n).

Definition aleph0 := cardinality nat.

Inductive eq_cardinal : Cardinal -> Cardinal -> Prop :=
| bij_eq_cardinal: forall {X Y:Type} (f:X->Y),
bijective f -> eq_cardinal (cardinality X) (cardinality Y).
Inductive le_cardinal : Cardinal -> Cardinal -> Prop :=
| inj_le_cardinal: forall {X Y:Type} (f:X->Y),
injective f -> le_cardinal (cardinality X) (cardinality Y).

Definition lt_cardinal (kappa lambda:Cardinal) : Prop :=
le_cardinal kappa lambda /\ ~ eq_cardinal kappa lambda.
Definition ge_cardinal (kappa lambda:Cardinal) : Prop :=
le_cardinal lambda kappa.
Definition gt_cardinal (kappa lambda:Cardinal) : Prop :=
lt_cardinal lambda kappa.

Lemma eq_cardinal_equiv: equivalence eq_cardinal.
Proof. hammer_hook "Cardinals" "Cardinals.eq_cardinal_equiv".
constructor.
red; intro.
destruct x.
exists (fun x:T => x).
red; split.
red; intros.
assumption.
red; intro.
exists y.
reflexivity.

red; intros.
destruct H.
inversion H0.
destruct H1.
destruct H3.
exists (fun x:X => f0 (f x)).
red; split.
red; intros.
apply H.
apply H2.
assumption.
red; intro.
destruct H.
destruct H2.
pose proof (H3 y).
destruct H4.
pose proof (H1 x).
destruct H5.
exists x0.
rewrite H5.
assumption.

red; intros.
destruct H.
apply bijective_impl_invertible in H.
destruct (function_inverse f H) as [finv].
destruct a.
exists finv.
apply invertible_impl_bijective.
exists f.
assumption.
assumption.
Qed.

Lemma eq_cardinal_impl_le_cardinal: forall kappa lambda: Cardinal,
eq_cardinal kappa lambda -> le_cardinal kappa lambda.
Proof. hammer_hook "Cardinals" "Cardinals.eq_cardinal_impl_le_cardinal".
intros.
destruct H.
exists f.
destruct H.
assumption.
Qed.

Lemma le_cardinal_preorder: preorder le_cardinal.
Proof. hammer_hook "Cardinals" "Cardinals.le_cardinal_preorder".
constructor.
red; intro.
apply eq_cardinal_impl_le_cardinal.
apply (equiv_refl eq_cardinal_equiv).
red; intros.
destruct H.
inversion H0.
exists (fun x:X => f0 (f x)).
red; intros.
apply H.
apply H2.
assumption.
Qed.

Lemma le_cardinal_antisym: forall kappa lambda:Cardinal,
le_cardinal kappa lambda -> le_cardinal lambda kappa ->
eq_cardinal kappa lambda.
Proof. hammer_hook "Cardinals" "Cardinals.le_cardinal_antisym".
intros.
destruct H.
inversion H0.
destruct H1.
destruct H2.
pose proof (CSB Y0 X0 f f0 H H3).
destruct H1.
exists x.
assumption.
Qed.

Lemma cantor_diag: forall (X:Type) (f:X->(X->bool)),
~ surjective f.
Proof. hammer_hook "Cardinals" "Cardinals.cantor_diag".
intros.
red; intro.
pose (g := fun x:X => negb (f x x)).
pose proof (H g).
destruct H0.
assert (f x x = g x).
rewrite H0.
reflexivity.
unfold g in H1.
destruct (f x x).
discriminate H1.
discriminate H1.
Qed.

Lemma P_neq_not_P: forall (P:Prop), P <> ~P.
Proof. hammer_hook "Cardinals" "Cardinals.P_neq_not_P".
unfold not; intros.
assert (~P).
unfold not; intro.
assert (P->False).
rewrite <- H.
assumption.
tauto.
assert P.
rewrite H.
assumption.
tauto.
Qed.

Lemma cantor_diag2: forall (X:Type) (f:X->(X->Prop)),
~ surjective f.
Proof. hammer_hook "Cardinals" "Cardinals.cantor_diag2".
unfold not; intros.
pose (g := fun x:X => ~ f x x).
pose proof (H g).
destruct H0.
assert (f x x = g x).
rewrite H0.
reflexivity.
unfold g in H1.
contradiction P_neq_not_P with (f x x).
Qed.

Lemma cardinals_unbounded: forall kappa:Cardinal, exists lambda:Cardinal,
gt_cardinal lambda kappa.
Proof. hammer_hook "Cardinals" "Cardinals.cardinals_unbounded".
destruct kappa.
exists (cardinality (T->Prop)).
red; red; split.
exists (@eq T).
red; intros.
rewrite H.
reflexivity.

unfold not; intro.
inversion H.
destruct H0.
destruct H2.
contradiction (cantor_diag2 _ f).
Qed.

Require Import ClassicalChoice.

Lemma surj_le_cardinal: forall {X Y:Type} (f:X->Y),
surjective f -> le_cardinal (cardinality Y) (cardinality X).
Proof. hammer_hook "Cardinals" "Cardinals.surj_le_cardinal".
intros.
pose proof (choice (fun (y:Y) (x:X) => f x = y) H).
simpl in H0.
destruct H0 as [g].
exists g.
red; intros.
congruence.
Qed.

From ZornsLemma Require Import ZornsLemma.
From ZornsLemma Require Import EnsemblesImplicit.
Require Import ProofIrrelevance.
Require Import FunctionalExtensionality.
Require Import Description.

Section le_cardinal_total.

Variable X Y:Type.

Record partial_injection : Type := {
pi_dom: Ensemble X;
pi_func: forall x:X, In pi_dom x -> Y;
pi_inj: forall (x1 x2:X) (i1:In pi_dom x1) (i2:In pi_dom x2),
pi_func x1 i1 = pi_func x2 i2 -> x1 = x2
}.
Record partial_injection_ord (pi1 pi2:partial_injection) : Prop := {
pi_dom_inc: Included (pi_dom pi1) (pi_dom pi2);
pi_func_ext: forall (x:X) (i1:In (pi_dom pi1) x)
(i2:In (pi_dom pi2) x),
pi_func pi1 x i1 = pi_func pi2 x i2
}.

Lemma partial_injection_preord: preorder partial_injection_ord.
Proof. hammer_hook "Cardinals" "Cardinals.partial_injection_preord".
constructor.
red; intros.
destruct x.
constructor.
auto with sets.
intros.
assert (i1 = i2).
apply proof_irrelevance.
rewrite H.
reflexivity.

red; intros.
destruct H.
destruct H0.
constructor.
auto with sets.
intros.
assert (In (pi_dom y) x0).
auto with sets.
transitivity (pi_func y x0 H); trivial.
Qed.

Lemma partial_injection_chain_ub: forall S:Ensemble partial_injection,
chain partial_injection_ord S -> exists x:partial_injection,
forall y:partial_injection, In S y -> partial_injection_ord y x.
Proof. hammer_hook "Cardinals" "Cardinals.partial_injection_chain_ub".
intros.
pose (ub_dom := [x:X | exists y:partial_injection,
In S y /\ In (pi_dom y) x]).
assert (forall x:X, In ub_dom x -> { y:Y | exists z:partial_injection,
In S z /\ exists i:In (pi_dom z) x, pi_func z x i = y }).
intros.
apply constructive_definite_description.
destruct H0.
destruct H0.
destruct H0.
exists (pi_func x0 x H1).
red; split.
exists x0.
split.
assumption.
exists H1.
reflexivity.
intros.
destruct H2.
destruct H2.
destruct H3.
pose proof (H x0 x1 H0 H2).
case H4.
intro.
rewrite <- H3.
apply pi_func_ext.
assumption.
intro.
rewrite <- H3.
symmetry.
apply pi_func_ext.
assumption.

assert (forall (x1 x2:X) (i1:In ub_dom x1) (i2:In ub_dom x2),
proj1_sig (X0 x1 i1) = proj1_sig (X0 x2 i2) -> x1 = x2).
intros.
destruct X0 in H0.
destruct X0 in H0.
simpl in H0.
destruct H0.
destruct e.
destruct H0.
destruct H1.
destruct e0.
destruct H2.
destruct H3.
destruct H1.
case (H x0 x4 H0 H2).
intro.
assert (In (pi_dom x4) x1).
apply (pi_dom_inc _ _ H1).
assumption.
assert (pi_func x4 x1 H4 = pi_func x4 x2 x5).
rewrite H3.
symmetry.
apply pi_func_ext.
assumption.
apply pi_inj in H5.
assumption.

intro.
assert (In (pi_dom x0) x2).
apply (pi_dom_inc _ _ H1).
assumption.
assert (pi_func x0 x1 x3 = pi_func x0 x2 H4).
rewrite <- H3.
apply pi_func_ext.
assumption.
apply pi_inj in H5.
assumption.

exists (Build_partial_injection ub_dom
(fun (x:X) (i:In ub_dom x) => proj1_sig (X0 x i)) H0).
intros.
constructor.
simpl.
red; intros.
constructor.
exists y.
tauto.
simpl.
intros.
destruct (X0 x i2).
simpl.
destruct e.
destruct H2.
destruct H3.
destruct H3.
case (H y x1 H1 H2).
intro.
apply pi_func_ext.
assumption.
intro.
symmetry.
apply pi_func_ext.
assumption.
Qed.

Lemma premaximal_partial_injection:
exists x:partial_injection, premaximal partial_injection_ord x.
Proof. hammer_hook "Cardinals" "Cardinals.premaximal_partial_injection".
apply ZornsLemmaForPreorders.
exact partial_injection_preord.
exact partial_injection_chain_ub.
Qed.

Lemma premaximal_pi_is_full_or_surj:
forall x:partial_injection, premaximal partial_injection_ord x ->
pi_dom x = Full_set \/
forall y:Y, exists x0:X, exists i:(In (pi_dom x) x0),
pi_func x x0 i = y.
Proof. hammer_hook "Cardinals" "Cardinals.premaximal_pi_is_full_or_surj".
intros.
case (classic (pi_dom x = Full_set)).
left.
trivial.
intro.
assert (exists x0:X, ~ In (pi_dom x) x0).
apply NNPP.
intuition.
apply H0.
apply Extensionality_Ensembles.
red; split.
red; intros.
constructor.
red; intros.
apply NNPP.
intuition.
apply H1.
exists x0.
assumption.
right.
destruct H1.
intros.
apply NNPP.
intuition.

pose (pi_dom_ext := Add (pi_dom x) x0).
assert (forall (x':X), In pi_dom_ext x' ->
{ y':Y | (exists i2:In (pi_dom x) x', y' = pi_func x x' i2) \/
(x' = x0 /\ y' = y) }).
intros.
apply constructive_definite_description.
case H3.
intros.
exists (pi_func x x1 H4).
red; split.
left.
exists H4.
reflexivity.
intros.
case H5.
intro.
destruct H6.
rewrite H6.
assert (H4 = x2).
apply proof_irrelevance.
rewrite H7.
reflexivity.

intros.
destruct H6.
contradict H1.
rewrite <- H6.
assumption.

intros.
destruct H4.
exists y.
red; split.
right.
tauto.
intros.
case H4.
intro.
destruct H5.
contradiction H1.
intros.
symmetry.
tauto.

pose (pi_func_ext0 := fun (x:X) (i:In pi_dom_ext x) =>
proj1_sig (X0 x i)).

assert (forall (x1:X) (i:In (pi_dom x) x1) (i2:In pi_dom_ext x1),
pi_func_ext0 x1 i2 = pi_func x x1 i).
intros.
unfold pi_func_ext0.
destruct (X0 x1 i2).
simpl.
case o.
intros.
destruct H3.
assert (i = x3).
apply proof_irrelevance.
rewrite H4.
assumption.
intros.
destruct H3.
contradiction H1.
rewrite <- H3.
assumption.

assert (forall (i:In pi_dom_ext x0), pi_func_ext0 x0 i = y).
intros.
unfold pi_func_ext0.
destruct (X0 x0 i); simpl.
case o.
intro.
destruct H4.
contradiction H1.
tauto.

assert (forall (x1 x2:X) (i1:In pi_dom_ext x1) (i2:In pi_dom_ext x2),
pi_func_ext0 x1 i1 = pi_func_ext0 x2 i2 -> x1 = x2).
intros.
inversion i1.
inversion i2.
rewrite (H3 x1 H6 i1) in H5.
rewrite (H3 x2 H8 i2) in H5.
apply pi_inj in H5.
assumption.
destruct H8.
rewrite (H3 x1 H6 i1) in H5.
rewrite H4 in H5.
contradiction H2.
exists x1.
exists H6.
assumption.
destruct H6.
rewrite H4 in H5.
inversion i2.
rewrite (H3 x2 H6 i2) in H5.
contradiction H2.
exists x2.
exists H6.
symmetry; assumption.
destruct H6.
reflexivity.

pose (pi_ext := Build_partial_injection pi_dom_ext pi_func_ext0 H5).
assert (partial_injection_ord x pi_ext).
constructor.
unfold pi_ext; simpl.
unfold pi_dom_ext.
red; intros.
left.
assumption.
intros.
symmetry.
apply H3.

apply H in H6.
contradiction H1.
apply (pi_dom_inc _ _ H6).
simpl.
right.
auto with sets.
Qed.

Lemma types_comparable: (exists f:X->Y, injective f) \/
(exists f:Y->X, injective f).
Proof. hammer_hook "Cardinals" "Cardinals.types_comparable".
pose proof premaximal_partial_injection.
destruct H.
apply premaximal_pi_is_full_or_surj in H.
case H.
left.
assert (forall x0:X, In (pi_dom x) x0).
rewrite H0.
constructor.
exists (fun x0:X => pi_func x x0 (H1 x0)).
red; intros.
apply pi_inj in H2.
assumption.

right.
assert (forall y:Y, { x0:X | exists i:In (pi_dom x) x0, pi_func x x0 i = y }).
intro.
apply constructive_definite_description.
pose proof (H0 y).
destruct H1.
exists x0.
red; split.
assumption.
intros.
destruct H1.
destruct H2.
destruct H2.
apply pi_inj in H1.
assumption.

exists (fun y:Y => proj1_sig (X0 y)).
red; intros.
destruct X0 in H1; destruct X0 in H1; simpl in H1.
destruct e; destruct e0.
destruct H1.
assert (x4 = x5).
apply proof_irrelevance.
destruct H1.
destruct H2.
assumption.
Qed.

End le_cardinal_total.

Lemma le_cardinal_total: forall kappa lambda:Cardinal,
le_cardinal kappa lambda \/ le_cardinal lambda kappa.
Proof. hammer_hook "Cardinals" "Cardinals.le_cardinal_total".
intros.
destruct kappa.
destruct lambda.
pose proof (types_comparable T T0).
case H.
left.
destruct H0.
exists x.
assumption.
right.
destruct H0.
exists x.
assumption.
Qed.


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

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

Print Assumptions mul.


(** **********************************************************

Ralph Matthes

2019, change to [z_iso] as base notion in 2021
*)

(** **********************************************************

Contents :

- build monoidal category for the endofunctors

************************************************************)

Require Import UniMath.Foundations.PartD.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
(* Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.UnitorsAndAssociatorsForEndofunctors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.HorizontalComposition. *)
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.

Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.

Local Open Scope cat.

Section Endofunctors_as_monoidal_category.

  Context (C : category).

  (*
(** The category of endofunctors on [C] *)
Local Notation "'EndC'":= ([C, C]) .

Local Lemma is_nat_trans_left_unitor_data: is_nat_trans (I_pretensor (functorial_composition _ _ _) (functor_identity C)) (functor_identity [C, C]) (@λ_functors C C).
Proof.
  intros F F' m.
  apply nat_trans_eq_alt.
  intro c. cbn.
  rewrite (functor_id F).
  do 2 rewrite id_left.
  apply id_right.
Qed.

Definition left_unitor_of_endofunctors: left_unitor (functorial_composition _ _ _) (functor_identity C).
Proof.
  use make_nat_z_iso.
  + use make_nat_trans.
    * intro F. apply λ_functors.
    * apply is_nat_trans_left_unitor_data.
  + red. intro F. cbn.
    use nat_trafo_z_iso_if_pointwise_z_iso.
    intro c.
    use tpair.
    * exact (identity (pr1 F c)).
    * abstract ( apply Isos.is_inverse_in_precat_identity ).
Defined.

Local Lemma is_nat_trans_right_unitor_data: is_nat_trans (I_posttensor (functorial_composition _ _ _) (functor_identity C))
  (functor_identity [C, C]) (@ρ_functors C C).
Proof.
  intros F F' m.
  apply nat_trans_eq_alt.
  intro c. cbn.
  rewrite id_left.
  rewrite id_right.
  apply id_right.
Qed.

Definition right_unitor_of_endofunctors: right_unitor (functorial_composition _ _ _) (functor_identity C).
Proof.
  use make_nat_z_iso.
  + use make_nat_trans.
    * intro F. apply ρ_functors.
    * apply is_nat_trans_right_unitor_data.
  + red. intro F. cbn.
    use nat_trafo_z_iso_if_pointwise_z_iso.
    intro c.
    use tpair.
    * exact (identity (pr1 F c)).
    * abstract ( apply Isos.is_inverse_in_precat_identity ).
Defined.

Definition associator_of_endofunctors: associator (functorial_composition _ _ _) :=
    associativity_as_nat_z_iso C C C C.

Lemma triangle_eq_of_endofunctors: triangle_eq (functorial_composition _ _ _) (functor_identity C)
  left_unitor_of_endofunctors right_unitor_of_endofunctors associator_of_endofunctors.
Proof.
  intros F G.
  apply nat_trans_eq_alt.
  intro c.
  cbn.
  rewrite functor_id.
  do 3 rewrite id_right.
  apply functor_id.
Qed.

Lemma pentagon_eq_of_endofunctors: pentagon_eq (functorial_composition _ _ _) associator_of_endofunctors.
Proof.
  intros F G H I.
  apply nat_trans_eq_alt.
  intro c.
  cbn.
  do 4 rewrite id_right.
  do 3 rewrite functor_id.
  rewrite id_right.
  apply pathsinv0, functor_id.
Qed.

Definition monoidal_cat_of_endofunctors: monoidal_cat.
Proof.
  use make_monoidal_cat.
  - exact EndC.
  - apply functorial_composition.
  - apply functor_identity.
  - exact left_unitor_of_endofunctors.
  - exact right_unitor_of_endofunctors.
  - exact associator_of_endofunctors.
  - exact triangle_eq_of_endofunctors.
  - exact pentagon_eq_of_endofunctors.
Defined.
   *)

  Definition monoidal_cat_of_endofunctors: monoidal_cat := monoidal_cat_from_bicat_and_ob(C:=bicat_of_cats) C.
  (** we need this high-level view in order to be able to instantiate [montrafotargetbicat_moncat] in [ActionBasedStrongFunctorsMonoidal] *)

End Endofunctors_as_monoidal_category.


Require Import Bool.
Require Import List.
Require Import Omega.

From mathcomp
Require Import ssreflect.

Require Import Utility.
Require Import Cell.
Require Import Concentric.
Require Import Tactic.

Import ListNotations.

Section ConcentricLemma.
  Open Scope Z_scope.
  Open Scope list_scope.

  Lemma s_alt_consistency (st st' : State) (x y : Z) (tmp alt : bool) :
    st x y = s tmp alt ->
    st' x y = s tmp (negb alt) ->
    c_type (st x y) = c_type (st' x y).
  Proof.
    move=> st_xy st'_xy.
    rewrite st_xy st'_xy.
    by case tmp.
  Qed.

  Lemma si_alt_consistency
    (st st' : State) (x y i : Z) (tmp alt : bool) :
    st x y = si tmp alt i ->
    st' x y = si tmp (negb alt) i ->
    c_type (st x y) = c_type (st' x y).
  Proof.
    move=> st_xy st'_xy.
    rewrite st_xy st'_xy.
    by case tmp.
  Qed.

  Lemma safe_to_safe
    (c : CellState) (cs : list CellState) (c' : CellState) :
    CTrans c cs c' -> c_type c = Safe -> c_type c' = Safe.
  Proof.
    move=> ctrans c_type_c.
    by destruct ctrans.
  Qed.

  Lemma safe_from_temp_or_safe
    (c : CellState) (cs : list CellState) (c' : CellState) :
    CTrans c cs c' -> c_type c' = Safe ->
    (c_type c = Temp \/ c_type c = Safe).
  Proof.
    move=> ctrans c_type_c'.
    destruct ctrans; auto; done.
  Qed.

  Lemma temp_from_white_or_temp
    (c : CellState) (cs : list CellState) (c' : CellState) :
    CTrans c cs c' -> c_type c' = Temp ->
    (c_type c = White \/ c_type c = Temp).
  Proof.
    move=> ctrans c_type_c'.
    destruct ctrans; auto.
  Qed.

  Lemma trans_safe_to_safe
    (st st' : State) (x y : Z) :
    trans st st' -> c_type (st x y) = Safe -> c_type (st' x y) = Safe.
  Proof.
    rewrite /trans => trans_st_st'.
    case (trans_st_st' x y) => st_st'.
    -by rewrite st_st'.
    -rewrite /rule_existence in st_st'.
      by destruct st_st'.
  Qed.

  Lemma trans_tmp_to_tmp_or_safe
    (st st' : State) (x y : Z) :
    trans st st' -> c_type (st x y) = Temp ->
    c_type (st' x y) = Safe \/ c_type (st' x y) = Temp.
  Proof.
    rewrite /trans => trans_st_st'.
    case (trans_st_st' x y) => ctrans.
    -rewrite ctrans.
      move=> s0. by right.
    -rewrite /rule_existence in ctrans.
      move=> s0.
      destruct_ctrans ctrans.
      +by right.
      +by right.
      +by right.
      +have s1: st x y = s tmp alt. by [].
        have s2: st' x y = s tmp (negb alt). by [].
        specialize (s_alt_consistency st st' x y tmp alt s1 s2).
        move=> s3.
        rewrite s2 in s3.
        right.
        by rewrite -s3.
      +have s1: st x y = si tmp alt i. by [].
        have s2: st' x y = si tmp (negb alt) i. by [].
        specialize (si_alt_consistency st st' x y i tmp alt s1 s2).
        move=> s3.
        rewrite s2 in s3.
        right.
        by rewrite -s3.
      +by left.
      +by left.
      +by left.
  Qed.

  Lemma trans_tmp_from_tmp_or_white
    (st st' : State) (x y : Z) :
    trans st st' ->
    c_type (st' x y) = Temp ->
    c_type (st x y) = Temp \/ c_type (st x y) = White.
  Proof.
    rewrite /trans => trans_st_st'.
    case (trans_st_st' x y) => st_st'.
    -rewrite st_st'. auto.
    -rewrite /rule_existence in st_st'.
      +by destruct st_st'; auto.
  Qed.

  Lemma trans_safe_from_safe_or_tmp
    (st st' : State) (x y : Z) :
    trans st st' ->
    c_type (st' x y) = Safe ->
    c_type (st x y) = Safe \/ c_type (st x y) = Temp.
  Proof.
    rewrite /trans => trans_st_st'.
    case (trans_st_st' x y) => st_st'.
    -rewrite st_st'. auto.
    -rewrite /rule_existence in st_st'.
      +destruct st_st'; auto; by rewrite /=.
  Qed.

  Lemma si_tmp_tmp_parallel_false
    (st : State) (x y i : Z) (alt : bool) :
    i_safe st ->
    ((x > 0 \/ x < 0) /\
    st (x - 1) y = si true alt i /\
    st (x + 1) y = si true (negb alt) i) \/
    ((y > 0 \/ y < 0) /\
    st x (y - 1) = si true alt i /\
    st x (y + 1) = si true (negb alt) i) ->
    False.
  Proof.
    move=> i_sf.
    case; case=> ex_mid; case=> s0 s1.
    -apply i_sf in s0. apply i_sf in s1.
      case ex_mid => x0.
      +have: 0 <= x - 1. omega. have: 0 <= x + 1. omega.
        move /(Z.abs_eq (x + 1)) => x_eq0.
        move /(Z.abs_eq (x - 1)) => x_eq1.
        rewrite x_eq0 x_eq1 in s0 s1.
        specialize (Zdiv.Zminus_mod
        (x - 1 + Z.abs y - 2)
        (x + 1 + Z.abs y - 2)
        5).
        rewrite -s0 -s1.
        suff eq: x - 1 + Z.abs y - 2 - (x + 1 + Z.abs y - 2) = -2.
        *by rewrite eq Z.sub_diag.
        *omega.
      +have: x - 1 <= 0. omega. have: x + 1 <= 0. omega.
        move /(Z.abs_neq (x + 1)) => x_eq0.
        move /(Z.abs_neq (x - 1)) => x_eq1.
        rewrite x_eq0 x_eq1 in s0 s1.
        specialize (Zdiv.Zminus_mod
        (- (x - 1) + Z.abs y - 2)
        (- (x + 1) + Z.abs y - 2)
        5).
        rewrite -s0 -s1.
        suff eq: -(x - 1) + Z.abs y - 2 - (-(x + 1) + Z.abs y - 2) = 2.
        *by rewrite eq Z.sub_diag.
        *omega.
    -apply i_sf in s0. apply i_sf in s1.
      case ex_mid => y0.
      +have: 0 <= y - 1. omega. have: 0 <= y + 1. omega.
        move /(Z.abs_eq (y + 1)) => y_eq0.
        move /(Z.abs_eq (y - 1)) => y_eq1.
        rewrite y_eq0 y_eq1 in s0 s1.
        specialize (Zdiv.Zminus_mod
        (Z.abs x + (y - 1) - 2)
        (Z.abs x + (y + 1) - 2)
        5).
        rewrite -s0 -s1.
        suff eq: Z.abs x + (y - 1) - 2 - (Z.abs x + (y + 1) - 2) = -2.
        *by rewrite eq Z.sub_diag.
        *omega.
      +have: y - 1 <= 0. omega. have: y + 1 <= 0. omega.
        move /(Z.abs_neq (y + 1)) => y_eq0.
        move /(Z.abs_neq (y - 1)) => y_eq1.
        rewrite y_eq0 y_eq1 in s0 s1.
        specialize (Zdiv.Zminus_mod
        (Z.abs x - (y - 1) - 2)
        (Z.abs x - (y + 1) - 2)
        5).
        rewrite -s0 -s1.
        suff eq: Z.abs x -(y - 1) - 2 - (Z.abs x - (y + 1) - 2) = 2.
        *by rewrite eq Z.sub_diag.
        *omega.
  Qed.

  Lemma tmp_safe_diag_x
    (st : State) (x y : Z) :
    t_safe st /\ s_safe st ->
    x > 0 /\ c_type (st (x + 1) y) = Temp \/
    x < 0 /\ c_type (st (x - 1) y) = Temp ->
    (y > 0 -> c_type (st x (y - 1)) = Safe) /\
    (y < 0 -> c_type (st x (y + 1)) = Safe).
  Proof.
    case=> t_sf s_sf.
    case; case=> x0 c_st_xy.
    -apply t_sf in c_st_xy.
      case: c_st_xy => s0.
      +case: s0 => x1 s0.
        rewrite Z.add_simpl_r in s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        case: s2 => s2 s3.
        by split.
      +case: s0 => s0. omega.
      +case: s0 => s0.
        case: s0 => y0 s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        rewrite Z.add_simpl_r in s0.
        split.
        *move=> y1.
          apply s0. omega.
        *omega.
      +case: s0 => y0 s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        rewrite Z.add_simpl_r in s0.
        split.
        *omega.
        *move=> y1.
          apply s0. omega.
    -apply t_sf in c_st_xy.
      case: c_st_xy => s0.
      +omega.
      +case: s0 => s0.
        case: s0 => x1 s0.
        rewrite Z.sub_simpl_r in s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        case: s2 => s2 s3.
        by split.
      +case: s0 => s0.
        case: s0 => y0 s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        rewrite Z.sub_simpl_r in s1.
        split.
        *move=> y1.
        apply s1. omega.
        *omega.
      +case: s0 => y0 s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        rewrite Z.sub_simpl_r in s1.
        split.
        *omega.
        *move=> y1.
        apply s1. omega.
  Qed.

  Lemma tmp_safe_diag_y
    (st : State) (x y : Z) :
    t_safe st /\ s_safe st ->
    y > 0 /\ c_type (st x (y + 1)) = Temp \/
    y < 0 /\ c_type (st x (y - 1)) = Temp ->
    (x > 0 -> c_type (st (x - 1) y) = Safe) /\
    (x < 0 -> c_type (st (x + 1) y) = Safe).
  Proof.
    case=> t_sf s_sf.
    case; case=> y0 c_st_xy.
    -apply t_sf in c_st_xy.
      case: c_st_xy => s0.
      +case: s0 => x0 s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        case: s2 => s2 s3.
        rewrite Z.add_simpl_r in s2.
        split.
        *move=> x1.
          apply s2. omega.
        *omega.
      +case: s0 => s0.
        case: s0 => x0 s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        case: s2 => s2 s3.
        rewrite Z.add_simpl_r in s2.
        split.
        *omega.
        *move=> x1.
          apply s2. omega.
      +case: s0 => s0.
        case: s0 => y1 s0.
        rewrite Z.add_simpl_r in s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        case: s2 => s2 s3.
        by split.
      +omega.
    -apply t_sf in c_st_xy.
      case: c_st_xy => s0.
      +case: s0 => x0 s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        case: s2 => s2 s3.
        rewrite Z.sub_simpl_r in s3.
        split.
        *move=> x1.
          apply s3. omega.
        *omega.
      +case: s0 => s0.
        case: s0 => x0 s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        case: s2 => s2 s3.
        rewrite Z.sub_simpl_r in s3.
        split.
        *omega.
        *move=> x1.
        apply s3. omega.
      +case: s0 => s0. omega.
      +case: s0 => y1 s0.
        rewrite Z.sub_simpl_r in s0.
        apply s_sf in s0.
        case: s0 => s0 s1.
        case: s1 => s1 s2.
        case: s2 => s2 s3.
        by split.
  Qed.

  Close Scope list_scope.
  Close Scope Z_scope.

End ConcentricLemma.


(** This library provides some examples of label-structured modal
    transition systems built with boolean labels. They can be found in
    the article _Extending Modal Transition Systems with Structured
    Labels_, by Sebastian S. Bauer, Line Juhl, Kim G. Larsen, Axel Legay,
    and Jiri Srba, and published in 2012 in the journal _Mathematical
    Structures in Computer Science_, volume 22, pages 581-617. *)

Add LoadPath "..".
Require Import Coq.Bool.Bool.
Require Import Coq.Classes.RelationClasses.
Require Import LabelSet.

(** The binary relation [leb] on [bool] is a preorder.  *)

Instance leb_PreOrder :
    PreOrder leb.
(* begin hide *)
Proof.
    split.
    - unfold Reflexive;
      destr_bool.
    - unfold Transitive;
      destr_bool.
Qed.
(* end hide *)

(** The set [bool] together with the preorder [leb] and the least
    boolean [false] is a label-set. *)

Program Instance bool_LabelSet : LabelSet leb false :=
    Build_LabelSet leb false leb_PreOrder _.

(** The boolean [true] is an implementation label. *)

Lemma implementation_true : LabS_implementation true.
(* begin hide *)
Proof.
    unfold LabS_implementation.
    split;
    try discriminate.
    destr_bool.
    apply (reflexivity (Reflexive := Equivalence_Reflexive (Equivalence := LabS_eqrel))).
    exfalso;
    apply H;
    reflexivity.
Qed.
(* end hide *)

(** The set [bool] together with the preorder [leb] and the least
    boolean [false] is a well-formed label-set. *)

Instance bool_WFLabelSet : WFLabelSet bool_LabelSet.
(* begin hide *)
Proof.
    split.
    destr_bool;
    exists true;
    split;
    apply implementation_true;
    simpl;
    trivial.
Qed.
(* end hide *)

(*
Inductive configurations1
    : Set
    := i0 | i1.

Definition may1
    (pre : configurations1)
    (l : bool)
    (post : configurations1)
    : Prop
    :=
        match (pre, l, post) with
        |   (i0, true, i1) => True
        |   (i1, true, i0) => True
        | _ => False
        end.

Lemma booleanLSMTS1_incl :
    forall (pre : configurations1) (l : bool) (post : configurations1),
        may1 pre l post -> may1 pre l post.
Proof.
    trivial.
Qed.

Instance booleanLSMTS1 : LSMTS bool_WFLabelSet i0 may1 may1.
Proof.
    apply (Build_LSMTS bool_WFLabelSet i0 may1 may1 booleanLSMTS1_incl).
Qed.
*)