(***************************************************************)
(*                                                             *)
(*  Coq script (certificate) accompanying IMR submission       *)
(*    "Certified Functions for Mesh Generation"                *)
(*                                                             *)
(*  Copyright (C) 2019                                         *)
(*    (Author's name and affiliation anonymized                *)
(*     for IMR review purposes and will appear upon            *)
(*     publication.)                                           *)
(*                                                             *)
(***************************************************************)
(*                                                             *)
(*  This work is licensed under the Creative Commons           *)
(*    Attribution-NonCommercial-ShareAlike 4.0 International   *)
(*    License. To view a copy of this license, visit           *)
(*    http://creativecommons.org/licenses/by-nc-sa/4.0/        *)
(*    or send a letter to                                      *)
(*    Creative Commons, PO Box 1866,                           *)
(*    Mountain View, CA 94042, USA.                            *)
(*                                                             *)
(***************************************************************)

Require Export List BinPosDef Omega.
Export ListNotations.

Inductive Coord3 :=
  C3 : Z -> Z -> Z -> Coord3.

Inductive Sign := Inside | Outside | Boundary.

Inductive StructuredTetCase :=
  Tet_I1 | Tet_I2 | Tet_I3 | Tet_I4 |
  Tet_J1 | Tet_J2 | Tet_J3 | Tet_J4 |
  Tet_K1 | Tet_K2 | Tet_K3 | Tet_K4.

Inductive StructuredTetId :=
  STId : Coord3 -> StructuredTetCase
         -> StructuredTetId.

Definition VertexOrder : Type :=
  Coord3 -> Coord3 -> Coord3 -> Coord3 ->
  (Coord3 * Coord3 * Coord3 * Coord3).

Inductive StructuredTet :=
  ST : Coord3 -> Coord3 -> Coord3 -> Coord3 ->
       StructuredTetId * VertexOrder ->
       StructuredTetId * VertexOrder ->
       StructuredTetId * VertexOrder ->
       StructuredTetId * VertexOrder ->
       StructuredTet.

Local Open Scope Z_scope.

Definition GetStructuredTet (tid : StructuredTetId)
                            : StructuredTet :=
  let P0123 v0 v1 v2 v3 := (v0, v1, v2, v3) in
  let P1032 v0 v1 v2 v3 := (v1, v0, v3, v2) in
  match tid with STId (C3 i j k) t =>
    let i1 := i + 1 in
    let j1 := j + 1 in
    let k1 := k + 1 in
    let i2 := i + 2 in
    let j2 := j + 2 in
    let k2 := k + 2 in
    let i3 := i + 3 in
    let j3 := j + 3 in
    let k3 := k + 3 in
    let v000 := C3 i  j  k in
    let v200 := C3 i2 j  k in
    let v020 := C3 i  j2 k in
    let v220 := C3 i2 j2 k in
    let v002 := C3 i  j  k2 in
    let v202 := C3 i2 j  k2 in
    let v022 := C3 i  j2 k2 in
    let v222 := C3 i2 j2 k2 in
    let v111 := C3 i1 j1 k1 in
    let v311 := C3 i3 j1 k1 in
    let v131 := C3 i1 j3 k1 in
    let v331 := C3 i3 j3 k1 in
    let v113 := C3 i1 j1 k3 in
    let v313 := C3 i3 j1 k3 in
    let v133 := C3 i1 j3 k3 in
    let v333 := C3 i3 j3 k3 in
    let i2' := i - 2 in
    let j2' := j - 2 in
    let k2' := k - 2 in
    match t with
    | Tet_I1 =>
        ST v022 v222 v131 v111
           (STId v000 Tet_K4, P0123)
           (STId (C3 i2' j k) Tet_K1, P1032)
           (STId v000 Tet_I3, P0123)
           (STId v000 Tet_I2, P0123)
    | Tet_I2 =>
        ST v022 v222 v131 v133
           (STId (C3 i j2 k) Tet_J2, P1032)
           (STId (C3 i2' j2 k) Tet_J3, P0123)
           (STId v000 Tet_I4, P0123)
           (STId v000 Tet_I1, P0123)
    | Tet_I3 =>
        ST v022 v222 v113 v111
           (STId v000 Tet_J2, P0123)
           (STId (C3 i2' j k) Tet_J3, P1032)
           (STId v000 Tet_I1, P0123)
           (STId v000 Tet_I4, P0123)
    | Tet_I4 =>
        ST v022 v222 v113 v133
           (STId (C3 i j k2) Tet_K4, P1032)
           (STId (C3 i2' j k2) Tet_K1, P0123)
           (STId v000 Tet_I2, P0123)
           (STId v000 Tet_I3, P0123)
    | Tet_J1 =>
        ST v202 v222 v113 v313
           (STId (C3 i j k2) Tet_K2, P1032)
           (STId (C3 i j2' k2) Tet_K3, P0123)
           (STId v000 Tet_J3, P0123)
           (STId v000 Tet_J2, P0123)
    | Tet_J2 =>
        ST v202 v222 v113 v111
           (STId v000 Tet_I3, P0123)
           (STId (C3 i j2' k) Tet_I2, P1032)
           (STId v000 Tet_J4, P0123)
           (STId v000 Tet_J1, P0123)
    | Tet_J3 =>
        ST v202 v222 v311 v313
           (STId (C3 i2 j k) Tet_I3, P1032)
           (STId (C3 i2 j2' k) Tet_I2, P0123)
           (STId v000 Tet_J1, P0123)
           (STId v000 Tet_J4, P0123)
    | Tet_J4 =>
        ST v202 v222 v311 v111
           (STId v000 Tet_K2, P0123)
           (STId (C3 i j2' k) Tet_K3, P1032)
           (STId v000 Tet_J2, P0123)
           (STId v000 Tet_J3, P0123)
    | Tet_K1 =>
        ST v220 v222 v311 v331
           (STId (C3 i2 j k) Tet_I1, P1032)
           (STId (C3 i2 j k2') Tet_I4, P0123)
           (STId v000 Tet_K3, P0123)
           (STId v000 Tet_K2, P0123)
    | Tet_K2 =>
        ST v220 v222 v311 v111
           (STId v000 Tet_J4, P0123)
           (STId (C3 i j k2') Tet_J1, P1032)
           (STId v000 Tet_K4, P0123)
           (STId v000 Tet_K1, P0123)
    | Tet_K3 =>
        ST v220 v222 v131 v331
           (STId (C3 i j2 k) Tet_J4, P1032)
           (STId (C3 i j2 k2') Tet_J1, P0123)
           (STId v000 Tet_K1, P0123)
           (STId v000 Tet_K4, P0123)
    | Tet_K4 =>
        ST v220 v222 v131 v111
           (STId v000 Tet_I1, P0123)
           (STId (C3 i j k2') Tet_I4, P1032)
           (STId v000 Tet_K2, P0123)
           (STId v000 Tet_K3, P0123)
    end
  end.

Local Close Scope Z_scope.

Section Get_Unstructured_Tets.

  Variable Vertex : Type.
  Variable GetSign : Vertex -> Sign.
  Variable GetIntersection :
             Vertex -> Vertex -> Vertex.

  Inductive UnstructuredTet :=
    UT : Vertex -> Vertex ->
         Vertex -> Vertex -> UnstructuredTet.

  Definition GetUnstructuredTets
               (v1 v2 v3 v4 : Vertex)
               : list UnstructuredTet :=

    let II_IO u1 u2 u3 m14 m24 m34 :=
      [UT u1 u2 u3 m34; UT u1 u2 m34 m14;
       UT u2 m34 m14 m24] in

    let II_BO u1 u2 u3 m14 m24 :=
      [UT u1 u2 u3 m14; UT m14 u2 u3 m24] in

    let II_OO u1 u2 m13 m14 m23 m24 :=
      [UT u2 m23 m14 m24; UT u1 u2 m23 m14;
       UT u1 m14 m23 m13] in

    let IB_IO u1 u2 u3 m14 m34 :=
      [UT u1 u3 u2 m34; UT u1 m34 u2 m14] in

    let IO_IO u1 u3 m12 m14 m23 m34 :=
      [UT u1 m34 m12 u3; UT u1 m14 m12 m34;
       UT m12 m34 u3 m23] in

    let IBBO u1 u2 u3 m14 :=
      [UT u1 u2 u3 m14] in

    let IBOO u1 u2 m13 m14 :=
      [UT u1 u2 m13 m14] in

    let IOOO u1 m12 m13 m14 :=
      [UT m14 m13 m12 u1] in

    let b := GetIntersection in

    match GetSign v1, GetSign v2, GetSign v3, GetSign v4 with
    | Inside  , Inside  , Inside  , Inside   => [UT v1 v2 v3 v4]
    | Inside  , Inside  , Inside  , Boundary => [UT v1 v2 v3 v4]
    | Inside  , Inside  , Inside  , Outside  => II_IO v1 v2 v3 (b v1 v4) (b v2 v4) (b v3 v4)
    | Inside  , Inside  , Boundary, Inside   => [UT v1 v2 v3 v4]
    | Inside  , Inside  , Boundary, Boundary => [UT v1 v2 v3 v4]
    | Inside  , Inside  , Boundary, Outside  => II_BO v1 v2 v3 (b v1 v4) (b v2 v4)
    | Inside  , Inside  , Outside , Inside   => II_IO v2 v1 v4 (b v2 v3) (b v1 v3) (b v4 v3)
    | Inside  , Inside  , Outside , Boundary => II_BO v2 v1 v4 (b v2 v3) (b v1 v3)
    | Inside  , Inside  , Outside , Outside  => II_OO v1 v2 (b v1 v3) (b v1 v4) (b v2 v3) (b v2 v4)

    | Inside  , Boundary, Inside  , Inside   => [UT v1 v2 v3 v4]
    | Inside  , Boundary, Inside  , Boundary => [UT v1 v2 v3 v4]
    | Inside  , Boundary, Inside  , Outside  => IB_IO v1 v2 v3 (b v1 v4) (b v3 v4)
    | Inside  , Boundary, Boundary, Inside   => [UT v1 v2 v3 v4]
    | Inside  , Boundary, Boundary, Boundary => [UT v1 v2 v3 v4]
    | Inside  , Boundary, Boundary, Outside  => IBBO v1 v2 v3 (b v1 v4)
    | Inside  , Boundary, Outside , Inside   => IB_IO v1 v2 v4 (b v1 v3) (b v4 v3)
    | Inside  , Boundary, Outside , Boundary => IBBO v1 v2 v4 (b v1 v3)
    | Inside  , Boundary, Outside , Outside  => IBOO v1 v2 (b v1 v3) (b v1 v4)

    | Inside  , Outside , Inside  , Inside   => II_IO v3 v4 v1 (b v3 v2) (b v4 v2) (b v1 v2)
    | Inside  , Outside , Inside  , Boundary => IB_IO v3 v4 v1 (b v3 v2) (b v1 v2)
    | Inside  , Outside , Inside  , Outside  => IO_IO v1 v3 (b v1 v2) (b v1 v4) (b v3 v2) (b v3 v4)
    | Inside  , Outside , Boundary, Inside   => IB_IO v4 v3 v1 (b v4 v2) (b v1 v2)
    | Inside  , Outside , Boundary, Boundary => IBBO v1 v3 v4 (b v1 v2)
    | Inside  , Outside , Boundary, Outside  => IBOO v1 v3 (b v1 v2) (b v1 v4)
    | Inside  , Outside , Outside , Inside   => IO_IO v1 v4 (b v1 v2) (b v1 v3) (b v4 v2) (b v4 v3)
    | Inside  , Outside , Outside , Boundary => IBOO v1 v4 (b v1 v2) (b v1 v3)
    | Inside  , Outside , Outside , Outside  => IOOO v1 (b v1 v2) (b v1 v3) (b v1 v4)

    | Boundary, Inside  , Inside  , Inside   => [UT v1 v2 v3 v4]
    | Boundary, Inside  , Inside  , Boundary => [UT v1 v2 v3 v4]
    | Boundary, Inside  , Inside  , Outside  => IB_IO v2 v1 v3 (b v2 v4) (b v3 v4)
    | Boundary, Inside  , Boundary, Inside   => [UT v1 v2 v3 v4]
    | Boundary, Inside  , Boundary, Boundary => [UT v1 v2 v3 v4]
    | Boundary, Inside  , Boundary, Outside  => IBBO v2 v1 v3 (b v2 v4)
    | Boundary, Inside  , Outside , Inside   => IB_IO v2 v1 v4 (b v2 v3) (b v4 v3)
    | Boundary, Inside  , Outside , Boundary => IBBO v2 v1 v4 (b v2 v3)
    | Boundary, Inside  , Outside , Outside  => IBOO v2 v1 (b v2 v3) (b v2 v4)

    | Boundary, Boundary, Inside  , Inside   => [UT v1 v2 v3 v4]
    | Boundary, Boundary, Inside  , Boundary => [UT v1 v2 v3 v4]
    | Boundary, Boundary, Inside  , Outside  => IBBO v3 v1 v2 (b v3 v4)
    | Boundary, Boundary, Boundary, Inside   => [UT v1 v2 v3 v4]
    | Boundary, Boundary, Boundary, Boundary => []
    | Boundary, Boundary, Boundary, Outside  => []
    | Boundary, Boundary, Outside , Inside   => IBBO v4 v1 v2 (b v4 v3)
    | Boundary, Boundary, Outside , Boundary => []
    | Boundary, Boundary, Outside , Outside  => []

    | Boundary, Outside , Inside  , Inside   => II_BO v3 v4 v1 (b v3 v2) (b v4 v2)
    | Boundary, Outside , Inside  , Boundary => IBBO v3 v1 v4 (b v3 v2)
    | Boundary, Outside , Inside  , Outside  => IBOO v3 v1 (b v3 v2) (b v3 v4)
    | Boundary, Outside , Boundary, Inside   => IBBO v4 v1 v3 (b v4 v2)
    | Boundary, Outside , Boundary, Boundary => []
    | Boundary, Outside , Boundary, Outside  => []
    | Boundary, Outside , Outside , Inside   => IBOO v4 v1 (b v4 v2) (b v4 v3)
    | Boundary, Outside , Outside , Boundary => []
    | Boundary, Outside , Outside , Outside  => []

    | Outside , Inside  , Inside  , Inside   => II_IO v4 v3 v2 (b v4 v1) (b v3 v1) (b v2 v1)
    | Outside , Inside  , Inside  , Boundary => IB_IO v3 v4 v2 (b v3 v1) (b v2 v1)
    | Outside , Inside  , Inside  , Outside  => IO_IO v2 v3 (b v2 v1) (b v2 v4) (b v3 v1) (b v3 v4)
    | Outside , Inside  , Boundary, Inside   => IB_IO v4 v3 v2 (b v4 v1) (b v2 v1)
    | Outside , Inside  , Boundary, Boundary => IBBO v2 v3 v4 (b v2 v1)
    | Outside , Inside  , Boundary, Outside  => IBOO v2 v3 (b v2 v1) (b v2 v4)
    | Outside , Inside  , Outside , Inside   => IO_IO v2 v4 (b v2 v1) (b v2 v3) (b v4 v1) (b v4 v3)
    | Outside , Inside  , Outside , Boundary => IBOO v2 v4 (b v2 v1) (b v2 v3)
    | Outside , Inside  , Outside , Outside  => IOOO v2 (b v2 v1) (b v2 v3) (b v2 v4)

    | Outside , Boundary, Inside  , Inside   => II_BO v4 v3 v2 (b v4 v1) (b v3 v1)
    | Outside , Boundary, Inside  , Boundary => IBBO v3 v2 v4 (b v3 v1)
    | Outside , Boundary, Inside  , Outside  => IBOO v3 v2 (b v3 v1) (b v3 v4)
    | Outside , Boundary, Boundary, Inside   => IBBO v4 v2 v3 (b v4 v1)
    | Outside , Boundary, Boundary, Boundary => []
    | Outside , Boundary, Boundary, Outside  => []
    | Outside , Boundary, Outside , Inside   => IBOO v4 v2 (b v4 v1) (b v4 v3)
    | Outside , Boundary, Outside , Boundary => []
    | Outside , Boundary, Outside , Outside  => []

    | Outside , Outside , Inside  , Inside   => II_OO v3 v4 (b v3 v1) (b v3 v2) (b v4 v1) (b v4 v2)
    | Outside , Outside , Inside  , Boundary => IBOO v3 v4 (b v3 v1) (b v3 v2)
    | Outside , Outside , Inside  , Outside  => IOOO v3 (b v3 v1) (b v3 v2) (b v3 v4)
    | Outside , Outside , Boundary, Inside   => IBOO v4 v3 (b v4 v1) (b v4 v2)
    | Outside , Outside , Boundary, Boundary => []
    | Outside , Outside , Boundary, Outside  => []
    | Outside , Outside , Outside , Inside   => IOOO v4 (b v4 v1) (b v4 v2) (b v4 v3)
    | Outside , Outside , Outside , Boundary => []
    | Outside , Outside , Outside , Outside  => []
    end.

End Get_Unstructured_Tets.

Section GetStructuredTet_Spec.

  Variables (v1 v2 v3 v4 : Coord3)
            (nei_tid : StructuredTetId)
            (nei_order : VertexOrder).

  Definition U :=
    match GetStructuredTet nei_tid with
      ST u1 u2 u3 u4 _ _ _ _ =>
        nei_order u1 u2 u3 u4
    end.

  Definition Face1Correct :=
    match U with (u1, u2, u3, u4) =>
      ~(v1 = u1) /\ (v2 = u2) /\
      (v3 = u3) /\ (v4 = u4)
    end.

  Definition Face2Correct :=
    match U with (u1, u2, u3, u4) =>
      (v1 = u1) /\ ~(v2 = u2) /\
      (v3 = u3) /\ (v4 = u4)
    end.

  Definition Face3Correct :=
    match U with (u1, u2, u3, u4) =>
      (v1 = u1) /\ (v2 = u2) /\
      ~(v3 = u3) /\ (v4 = u4)
    end.

  Definition Face4Correct :=
    match U with (u1, u2, u3, u4) =>
      (v1 = u1) /\ (v2 = u2) /\
      (v3 = u3) /\ ~(v4 = u4)
    end.

End GetStructuredTet_Spec.

Local Open Scope Z_scope.

Lemma Zplus_minus_comm : forall a b c : Z,
  a - b + c = a + (c - b).
Proof. intros. omega. Qed.

Section GetStructuredTet_Proof.

  Hint Rewrite
    Zplus_minus_comm Zplus_assoc_reverse
    Z.add_0_r Z.add_opp_r : Rewrite1.

  Hint Extern 5 (~_) =>
    red; intros H; inversion H; omega.

  Theorem FacesCorrect :
    forall tid : StructuredTetId,
    match GetStructuredTet tid with
      ST v1 v2 v3 v4 (tid1, o1) (tid2, o2)
                     (tid3, o3) (tid4, o4) =>
        (Face1Correct v1 v2 v3 v4 tid1 o1) /\
        (Face2Correct v1 v2 v3 v4 tid2 o2) /\
        (Face3Correct v1 v2 v3 v4 tid3 o3) /\
        (Face4Correct v1 v2 v3 v4 tid4 o4)
    end.
  Proof.
    intros [[i j k] t];
    unfold Face1Correct, Face2Correct,
           Face3Correct, Face4Correct, U;
    destruct t;
    unfold GetStructuredTet;
    autorewrite with Rewrite1;
    repeat (split; auto 20).
  Qed.

End GetStructuredTet_Proof.

Local Close Scope Z_scope.

Inductive BCoord := Zero | Interior | One.

Inductive Below : BCoord -> BCoord ->
                  BCoord -> Prop :=
  | B_1 : Below Zero Zero Interior
  | B_2 : Below Zero Zero One
  | B_3 : Below Zero Interior Interior
  | B_4 : Below Zero Interior One.

Inductive Above : BCoord -> BCoord ->
                  BCoord -> Prop :=
  | A_1 : Above One Zero Interior
  | A_2 : Above One Zero One
  | A_3 : Above One Interior Interior
  | A_4 : Above One Interior One.

Section Below_Above_Symm.
  Variables c a b : BCoord.
  Inductive BelowSymm : Prop :=
  | BS_1 : Below c a b -> BelowSymm
  | BS_2 : Below c b a -> BelowSymm.
  Inductive AboveSymm : Prop :=
  | AS_1 : Above c a b -> AboveSymm
  | AS_2 : Above c b a -> AboveSymm.
End Below_Above_Symm.

Section Segment_Point_Not_Interiorersecting_1D.
  Variables c a b : BCoord.
  Inductive SPNI1D : Prop :=
  | SPNI1D_1 : BelowSymm c a b -> SPNI1D
  | SPNI1D_2 : AboveSymm c a b -> SPNI1D.
End Segment_Point_Not_Interiorersecting_1D.

Section Segment_Point_Not_Interiorersecting_3D.
  Variables a1 a2 a3 b1 b2 b3 c1 c2 c3 : BCoord.
  Inductive SPNI3D : Prop :=
  | SPNI3D_1 : SPNI1D c1 a1 b1 -> SPNI3D
  | SPNI3D_2 : SPNI1D c2 a2 b2 -> SPNI3D
  | SPNI3D_3 : SPNI1D c3 a3 b3 -> SPNI3D.
End Segment_Point_Not_Interiorersecting_3D.

Section Segment_Segment_Not_Interiorersecting_1D.
  Variables a b c d : BCoord.
  Inductive SSNI1D : Prop :=
  | SSNI1D_1 : BelowSymm a c d ->
               BelowSymm b c d -> SSNI1D
  | SSNI1D_2 : BelowSymm c a b ->
               BelowSymm d a b -> SSNI1D.
End Segment_Segment_Not_Interiorersecting_1D.

Section Segment_Segment_Not_Interiorersecting_3D.
  Variables a1 a2 a3 b1 b2 b3
            c1 c2 c3 d1 d2 d3 : BCoord.
  Inductive SSNI3D : Prop :=
  | SSNI3D_1 : SSNI1D a1 b1 c1 d1 -> SSNI3D
  | SSNI3D_2 : SSNI1D a2 b2 c2 d2 -> SSNI3D
  | SSNI3D_3 : SSNI1D a3 b3 c3 d3 -> SSNI3D.
End Segment_Segment_Not_Interiorersecting_3D.

Section GetUnstructuredTets_Spec.

  Variable Vertex : Type.
  Variable GetSign : Vertex -> Sign.
  Variable GetIntersection : Vertex -> Vertex -> Vertex.

  Definition Edge : Type := Vertex * Vertex.

  Definition Edges (t : UnstructuredTet Vertex)
             : list Edge :=
    match t with UT _ u v w r =>
      [(u, v); (u, w); (u, r); (v, w); (v, r); (w, r)]
    end.

  Variables f1 f2 f3 p q : Vertex.

  Inductive FCoord : Vertex -> BCoord ->
                     BCoord -> BCoord -> Prop :=
    | FC_1 : FCoord f1 One Zero Zero
    | FC_2 : FCoord f2 Zero One Zero
    | FC_3 : FCoord f3 Zero Zero One
    | FC_4 : FCoord (GetIntersection f1 f2)
                    Interior Interior Zero
    | FC_5 : FCoord (GetIntersection f2 f1)
                    Interior Interior Zero
    | FC_6 : FCoord (GetIntersection f1 f3)
                    Interior Zero Interior
    | FC_7 : FCoord (GetIntersection f3 f1)
                    Interior Zero Interior
    | FC_8 : FCoord (GetIntersection f2 f3)
                    Zero Interior Interior
    | FC_9 : FCoord (GetIntersection f3 f2)
                    Zero Interior Interior.

  Inductive PCoord : Vertex -> Prop :=
    | PC_1 : PCoord p
    | PC_2 : PCoord (GetIntersection p f1)
    | PC_3 : PCoord (GetIntersection f1 p)
    | PC_4 : PCoord (GetIntersection p f2)
    | PC_5 : PCoord (GetIntersection f2 p)
    | PC_6 : PCoord (GetIntersection p f3)
    | PC_7 : PCoord (GetIntersection f3 p).

  Inductive QCoord : Vertex -> Prop :=
    | QC_1 : QCoord q
    | QC_2 : QCoord (GetIntersection q f1)
    | QC_3 : QCoord (GetIntersection f1 q)
    | QC_4 : QCoord (GetIntersection q f2)
    | QC_5 : QCoord (GetIntersection f2 q)
    | QC_6 : QCoord (GetIntersection q f3)
    | QC_7 : QCoord (GetIntersection f3 q).

  Section Special_Vertex.
    Variables (v u1 u2 : Vertex)
              (V : Vertex -> Prop).
    Inductive SpecialVertex : Prop :=
    | SV_1 : v = u1 -> SpecialVertex
    | SV_2 : v = u2 -> SpecialVertex
    | SV_3 : V v -> SpecialVertex.
  End Special_Vertex.

  Section Not_In.
    Variables (v u1 u2 : Vertex)
              (V U : Vertex -> Prop).
    Inductive NotIn : Prop :=
    | NI_1 : SpecialVertex v u1 u2 V -> NotIn
    | NI_2 : U u1 -> NotIn
    | NI_3 : U u2 -> NotIn
    | NI_4 : forall a1 a2 a3 b1 b2 b3 c1 c2 c3 : BCoord,
             FCoord u1 a1 a2 a3 ->
             FCoord u2 b1 b2 b3 ->
             FCoord v c1 c2 c3 ->
             SPNI3D a1 a2 a3 b1 b2 b3 c1 c2 c3 ->
             NotIn.
  End Not_In.

  Section Two_Edges_Compatible.
    Variables p1 p2 q1 q2 : Vertex.
    Inductive TwoEdgesCompatible : Prop :=
    | EC_1 : SpecialVertex p1 q1 q2 PCoord ->
             NotIn p2 q1 q2 PCoord QCoord ->
             TwoEdgesCompatible
    | EC_2 : SpecialVertex p2 q1 q2 PCoord ->
             NotIn p1 q1 q2 PCoord QCoord ->
             TwoEdgesCompatible
    | EC_3 : SpecialVertex q1 p1 p2 QCoord ->
             NotIn q2 p1 p2 QCoord PCoord ->
             TwoEdgesCompatible
    | EC_4 : SpecialVertex q2 p1 p2 QCoord ->
             NotIn q1 p1 p2 QCoord PCoord ->
             TwoEdgesCompatible
    | EC_5 : forall a1 a2 a3 b1 b2 b3
                    c1 c2 c3 d1 d2 d3 : BCoord,
             FCoord p1 a1 a2 a3 ->
             FCoord p2 b1 b2 b3 ->
             FCoord q1 c1 c2 c3 ->
             FCoord q2 d1 d2 d3 ->
             SSNI3D a1 a2 a3 b1 b2 b3
                    c1 c2 c3 d1 d2 d3 ->
             TwoEdgesCompatible.
  End Two_Edges_Compatible.

  Definition EdgePairCompatible ee :=
    let '((p1, p2), (q1, q2)) := ee in
    TwoEdgesCompatible p1 p2 q1 q2.

  Definition AllEdgesCompatible
             (u1 u2 u3 u4 v1 v2 v3 v4 : Vertex)
             : Prop :=
    let T := GetUnstructuredTets Vertex
               GetSign GetIntersection in
    forall (t1 t2 : UnstructuredTet Vertex),
    List.In t1 (T u1 u2 u3 u4) ->
    List.In t2 (T v1 v2 v3 v4) ->
    Forall EdgePairCompatible
           (list_prod (Edges t1) (Edges t2)).

End GetUnstructuredTets_Spec.

Section GetUnstructuredTets_Proof.

  Hint Constructors
    Below BelowSymm Above AboveSymm SPNI1D SPNI3D
    SSNI1D SSNI3D FCoord PCoord QCoord
    SpecialVertex NotIn TwoEdgesCompatible.

  Ltac Proof1 := time
    match goal with
      [ |- AllEdgesCompatible _ ?GetSign _
             ?f1 ?f2 ?f3 ?p ?q _ _ _ _ _ _ _ _  ] =>
        unfold AllEdgesCompatible;
        intros t1 t2 H1 H2;
        apply Forall_forall;
        destruct t1 as [u1 u2 u3 u4], t2 as [v1 v2 v3 v4];
        unfold Edges;
        unfold list_prod;
        unfold List.map;
        simpl;
        unfold GetUnstructuredTets in H1, H2;
        intros ee H3;
        destruct (GetSign p) eqn: CP,
                 (GetSign f1) eqn: CF1,
                 (GetSign f2) eqn: CF2,
                 (GetSign f3) eqn: CF3,
                 (GetSign q) eqn: CQ;
        unfold List.In in H1, H2;
        firstorder;
        match goal with [H: _, H0: _, H1: _ |- _] =>
          try rewrite <- H;
          try (inversion H0 as [[V1 V2 V3 V4]];
              try rewrite <- V1; try rewrite <- V2;
              try rewrite <- V3; try rewrite <- V4);
          try (inversion H1 as [[U1 U2 U3 U4]];
              try rewrite <- U1; try rewrite <- U2;
              try rewrite <- U3; try rewrite <- U4);
          unfold EdgePairCompatible;
          eauto 20
        end
    end.

  Lemma CompatibilityOrders :
    forall Vertex GetSign GetIntersection f1 f2 f3 p q,
    let P := AllEdgesCompatible Vertex GetSign
             GetIntersection f1 f2 f3 p q in
    P p f1 f2 f3 q f1 f2 f3 /\
    P p f1 f2 f3 f1 q f3 f2 /\
    P f1 p f2 f3 q f1 f3 f2 /\
    P f1 p f2 f3 f1 q f2 f3 /\
    P f1 f2 p f3 f1 f2 q f3 /\
    P f1 f2 f3 p f1 f2 f3 q.
   (* This proof takes about an hour to execute
    on a MacBook Pro equipped with Intel Core i9
    @ 2.4 GHz processor. *)
  Proof.
    repeat split.
    Proof1. Proof1. Proof1. Proof1. Proof1. Proof1.
  Qed.

End GetUnstructuredTets_Proof.

Section Structured_Unstructured_Proof.

  Hint Rewrite
    Zplus_minus_comm Zplus_assoc_reverse
    Z.add_0_r Z.add_opp_r : Rewrite1.

  Ltac Proof2 :=
    intros GetSign GetIntersection [[i j k] t];
    destruct t;
    unfold GetStructuredTet;
    autorewrite with Rewrite1;
    simpl;
    apply CompatibilityOrders.

  Theorem Face1Compatible :
    forall GetSign GetIntersection tid,
    match GetStructuredTet tid with
      ST v1 v2 v3 v4 (tid1, order1) _ _ _ =>
        match GetStructuredTet tid1 with
          ST u1 u2 u3 u4 _ _ _ _ =>
            let '(w1, w2, w3, w4) :=
              order1 u1 u2 u3 u4 in
            AllEdgesCompatible Coord3 GetSign
              GetIntersection w2 w3 w4 v1 w1
              v1 v2 v3 v4 u1 u2 u3 u4
        end
    end.
  Proof. Proof2.  Qed.

  Theorem Face2Compatible :
    forall GetSign GetIntersection tid,
    match GetStructuredTet tid with
      ST v1 v2 v3 v4 _ (tid2, order2) _ _ =>
        match GetStructuredTet tid2 with
          ST u1 u2 u3 u4 _ _ _ _ =>
            let '(w1, w2, w3, w4) :=
              order2 u1 u2 u3 u4 in
            AllEdgesCompatible Coord3 GetSign
              GetIntersection w1 w3 w4 v2 w2 v1 v2 v3 v4
              u1 u2 u3 u4
        end
    end.
  Proof. Proof2.  Qed.

  Theorem Face3Compatible :
    forall GetSign GetIntersection tid,
    match GetStructuredTet tid with
      ST v1 v2 v3 v4 _ _ (tid3, order3) _ =>
        match GetStructuredTet tid3 with
          ST u1 u2 u3 u4 _ _ _ _ =>
            let '(w1, w2, w3, w4) :=
              order3 u1 u2 u3 u4 in
              AllEdgesCompatible Coord3 GetSign
                GetIntersection w1 w2 w4 v3 w3 v1 v2 v3 v4
                u1 u2 u3 u4
        end
    end.
  Proof. Proof2.  Qed.

  Theorem Face4Compatible :
    forall GetSign GetIntersection tid,
    match GetStructuredTet tid with
      ST v1 v2 v3 v4 _ _ _ (tid4, order4) =>
        match GetStructuredTet tid4 with
          ST u1 u2 u3 u4 _ _ _ _ =>
            let '(w1, w2, w3, w4) :=
              order4 u1 u2 u3 u4 in
              AllEdgesCompatible Coord3 GetSign
                GetIntersection w1 w2 w3 v4 w4 v1 v2 v3 v4
                u1 u2 u3 u4
        end
    end.
  Proof. Proof2.  Qed.

End Structured_Unstructured_Proof.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language Automations Subtyping LibTactics.
Require Import Strings.String.

(* aux lemma for tred_determinism *)
Lemma tred_ord_toplike :
  forall (v v' : trm) (A : typ),
    ordinary A -> toplike A -> typedred v A v' ->
    v' = (trm_anno (trm_int 1) A).
Proof.
  induction 3; eauto; try solve [inversion_toplike | inversion_ordinary].
Qed.

Hint Resolve tred_ord_toplike : core.

(* aux lemma for disjoint_value_consistent *)
Lemma tred_sub :
  forall (A : typ) (v v' : trm),
    value v -> typedred v A v' -> forall (B : typ),
    typing nil nil v B ->
    sub B A.
Proof.
  introv Hv Hred.
  dependent induction Hred; eauto; introv Htyp.
  - dependent destruction Htyp.
    dependent destruction Htyp; eauto.
    simpl_as; eauto.
  - dependent destruction Htyp; eauto.
    simpl_as; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp;
    eapply sub_and_l; eapply IHHred; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp;
    eapply sub_and_r; eapply IHHred; eauto.
Qed.

(* aux lemma for disjoint_value_consistent *)
Lemma tred_determinism_toplike :
  forall (A : typ),
    toplike A ->
    forall (e1 e2 e1' e2' : trm), typedred e1 A e1' -> typedred e2 A e2' -> e1' = e2'.
Proof.
  intros A Htop.
  dependent induction Htop; introv Hred1 Hred2.
  - eapply tred_ord_toplike in Hred1; eauto.
    eapply tred_ord_toplike in Hred2; eauto.
    congruence.
  - dependent destruction Hred1; eauto; try solve [inversion_ordinary].
    dependent destruction Hred2; try solve [inversion_ordinary].
    assert (v1 = v0). eapply IHHtop1; eauto 3.
    assert (v2 = v3). eapply IHHtop2; eauto 3.
    congruence.
  - assert (toplike (typ_arrow A B)); eauto.
    eapply tred_ord_toplike in Hred1; eauto.
    eapply tred_ord_toplike in Hred2; eauto.
    congruence.
Qed.

(* aux lemma for tred_determinism *)
Lemma disjoint_value_consistent :
  forall (A B : typ) (v1 v2 : trm),
    disjoint_spec A B -> value v1 -> value v2 ->
    typing nil nil v1 A -> typing nil nil v2 B ->
    consistency_spec v1 v2.
Proof.
  intros. unfold consistency_spec. intros.
  unfold disjoint_spec in *.
  assert (sub A A0). eapply tred_sub with (v:=v1); eauto.
  assert (sub B A0). eapply tred_sub with (v:=v2); eauto.
  assert (toplike A0); eauto.
  eapply tred_determinism_toplike; eauto.
Qed.

Hint Resolve disjoint_value_consistent : core.

Theorem tred_determinism :
  forall (v v1 v2 : trm) (A : typ),
    value v -> (exists B, typing nil nil v B) ->
    typedred v A v1 -> typedred v A v2 -> v1 = v2.
Proof.
  introv Hv Htyp Hred1.
  generalize dependent v2.
  dependent induction Hred1; eauto; introv Hred2.
  - dependent induction Hred2; try solve [inversion_toplike]; eauto.
  - dependent destruction Hred2; try solve [inversion_toplike | inversion_ordinary]; eauto.
    + symmetry. eapply tred_ord_toplike; eauto.
    + symmetry. eapply tred_ord_toplike; eauto.
  - dependent destruction Hred2; try solve [inversion_toplike]; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp.
    dependent destruction Hred2; try solve [inversion_ordinary]; eauto.
    + dependent destruction H; eauto.
    + dependent destruction H; eauto.
      assert (consistency_spec v1 v2).
      eapply disjoint_value_consistent; eauto 3. eauto.
  - dependent destruction Hv.
    dependent destruction Htyp.
    dependent destruction Hred2; try solve [inversion_ordinary]; eauto.
    + dependent destruction H; eauto.
      * assert (consistency_spec v1 v2); eauto.
        symmetry. eauto.
      * symmetry. eauto.
    + dependent destruction H; eauto.
  - dependent destruction Hred2; try solve [inversion_ordinary]; eauto.
    assert (v1 = v0); eauto.
    assert (v2 = v3); eauto.
    congruence.
Qed.

Lemma tred_value :
  forall (v v' : trm) (A : typ),
    value v -> typedred v A v' -> value v'.
Proof.
  intros.
  dependent induction H0; try solve [eauto | dependent destruction H; eauto].
Qed.

Hint Resolve tred_value : core.

Lemma tred_transitivity :
  forall (v1 v2 v3 : trm) (A B : typ),
    value v1 ->
    typedred v1 A v2 ->
    typedred v2 B v3 ->
    typedred v1 B v3.
Proof.
  intros.
  generalize dependent v3.
  generalize dependent B.
  dependent induction H0; eauto; introv Hred2.
  - dependent induction Hred2; eauto.
  - dependent induction Hred2; try solve [inversion_toplike_sub]; eauto.
  - dependent induction Hred2; eauto 4.
    eapply tred_arrow_anno; eauto;
    eapply sub_transitivity; eauto.
  - dependent destruction H.
    dependent induction Hred2; eauto.
  - dependent destruction H.
    dependent induction Hred2; eauto.
  - generalize dependent v3.
    induction B0; intros v0 Hred2; try solve [eauto | dependent destruction Hred2; eauto].
Qed.

Lemma tred_consistency :
  forall (v v1 v2 : trm) (A B C : typ),
    value v -> typing nil nil v C ->
    typedred v A v1 ->
    typedred v B v2 ->
    consistency_spec v1 v2.
Proof.
  intros.
  unfold consistency_spec; intros.
  assert (typedred v A0 e1').
  eapply tred_transitivity with (v1:=v) (v2:=v1) (v3:=e1'); eauto.
  assert (typedred v A0 e2').
  eapply tred_transitivity with (v1:=v) (v2:=v2) (v3:=e2'); eauto.
  eapply tred_determinism; eauto.
Qed.

Theorem tred_preservation:
  forall (v v': trm) (A B: typ),
    value v ->
    typing nil nil v B ->
    typedred v A v' ->
    typing nil nil v' A.
Proof.
  intros v v' A B Hv Htyp Hred.
  assert (Hsub: sub B A). eapply tred_sub; eauto.
  generalize dependent B.
  dependent induction Hred; eauto 3; intros.
  - eapply typing_anno; eauto.
  - dependent destruction Htyp.
    dependent destruction Htyp.
    eapply typing_anno; eauto.
    eapply sub_transitivity; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp; eapply IHHred; eauto.
    + eapply tred_sub. apply Hv1. apply Hred. apply Htyp1.
    + eapply tred_sub. apply Hv1. apply Hred. apply Htyp1.
  - dependent destruction Hv.
    dependent destruction Htyp; eapply IHHred; eauto.
    + eapply tred_sub. apply Hv2. apply Hred. apply Htyp2.
    + eapply tred_sub. apply Hv2. apply Hred. apply Htyp2.
  - eapply typing_merge_value; eauto.
    + eapply tred_consistency; eauto.
    + eapply IHHred1; eauto.
      eapply tred_sub. apply Hv. apply Hred1. apply Htyp.
    + eapply IHHred2; eauto.
      eapply tred_sub. apply Hv. apply Hred2. apply Htyp.
Qed.

Theorem tred_progress :
  forall (v : trm) (A B : typ),
    value v -> typing nil nil v A ->
    sub A B ->
    exists v', typedred v B v'.
Proof.
  introv Hv Htyp Hsub.
  generalize dependent A.
  induction B; introv Htyp Hsub; eauto.
  - dependent induction Htyp; try solve [inversion Hv].
    + simpl_as. dependent destruction Hv.
      dependent destruction H.
      * clear IHHtyp. dependent destruction Htyp.
        exists (trm_anno (trm_int n) typ_int); eauto.
      * clear IHHtyp.
        dependent destruction Htyp.
        assert (sub (typ_arrow A0 B) typ_int). eapply sub_transitivity; eauto.
        inversion H1.
    + dependent destruction Hv.
      dependent destruction Hsub.
      * assert (exists v', typedred e1 typ_int v'); eauto.
        destruct H0; eauto.
      * assert (exists v', typedred e2 typ_int v'); eauto.
        destruct H0; eauto.
    + dependent destruction Hv.
      dependent destruction Hsub.
      * assert (exists v', typedred v1 typ_int v'); eauto.
        destruct H2; eauto.
      * assert (exists v', typedred v2 typ_int v'); eauto.
        destruct H2; eauto.
  - destruct (toplike_or_not_toplike B2).
    + exists (trm_anno (trm_int 1) (typ_arrow B1 B2)).
      eapply tred_top; eauto.
    + clear IHB1 IHB2.
      dependent induction Htyp; try solve [inversion Hv].
      * simpl_as.
        dependent destruction Hv.
        dependent induction H.
        (* case 1 *)
        dependent destruction Htyp.
        assert (sub typ_int (typ_arrow B1 B2)).
        eapply sub_transitivity; eauto.
        dependent destruction H2.
        assert (toplike B2); eauto.
        (* case 2 *)
        dependent destruction Htyp.
        exists (trm_anno (trm_abs e A0 B) (typ_arrow B1 B2)); eauto.
      * dependent destruction Hv.
        eapply sub_and_inversion2 in Hsub.
        destruct Hsub.
        (* case 1 *)
        assert (exists v', typedred e1 (typ_arrow B1 B2) v'); eauto.
        destruct H2. exists x; eauto.
        destruct H1.
        (* case 2 *)
        assert (exists v', typedred e2 (typ_arrow B1 B2) v'); eauto.
        destruct H2. exists x; eauto.
        (* case 3 *)
        destruct H1. destruct H1. inversion H1.
      * dependent destruction Hv.
        eapply sub_and_inversion2 in Hsub.
        destruct Hsub.
        (* case 1 *)
        assert (exists v', typedred v1 (typ_arrow B1 B2) v'); eauto.
        destruct H4. exists x; eauto.
        destruct H3.
        (* case 2 *)
        assert (exists v', typedred v2 (typ_arrow B1 B2) v'); eauto.
        destruct H4. exists x; eauto.
        (* case 3 *)
        destruct H3. destruct H3. inversion H3.
  - eapply sub_and_inversion1 in Hsub.
    destruct Hsub.
    assert (exists v', typedred v B1 v'); eauto.
    assert (exists v', typedred v B2 v'); eauto.
    destruct H1. destruct H2.
    exists (trm_merge x x0); eauto.
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Require Import ZArith Znumtheory Zpow_facts.
Require Import CyclicAxioms Cyclic63 Int63Compat.
From Bignums Require Import DoubleCyclic BigN.
Require Import W.
Require Import Mod_op.
Require Import ZEll.
Require Import Bits.
Import CyclicAxioms DoubleType DoubleBase.
Require Import Zmod.

Set Implicit Arguments.

Open Scope Z_scope.

Record ex: Set := mkEx {
  vN : positive;
  vS : positive;
  vR:  List.list (positive * positive);
  vA:  Z;
  vB:  Z;
  vx:  Z;
  vy:  Z
}.

Local Coercion Zpos : positive >-> Z.

Record ex_spec (exx: ex): Prop := mkExS {
  n2_div: ~(2 | exx.(vN));
  n_pos: 2 < exx.(vN);
 lprime:
  forall p : positive * positive, List.In p (vR exx) -> prime (fst p);
   lbig:
    4 * vN exx < (Zmullp (vR exx) - 1) ^ 2;
   inC:
    vy exx ^ 2 mod vN exx = (vx exx ^ 3 + vA exx * vx exx + vB exx) mod vN exx
}.

Section NEll.

Variable exx: ex.
Variable exxs: ex_spec exx.

Variable zZ: univ_of_cycles.
Variable op: ZnZ.Ops zZ.
Variable op_spec: ZnZ.Specs op.
Definition z2Z z :=  ZnZ.to_Z z.
Definition zN := snd (ZnZ.of_pos exx.(vN)).
Variable mop: mod_op zZ.
Variable mop_spec: mod_spec op zN mop.
Variable N_small:  exx.(vN) < base (ZnZ.digits op).

Lemma z2ZN: z2Z zN = exx.(vN).
apply (@ZnZ.of_Z_correct _ _ op_spec exx.(vN)); split; auto with zarith.
Qed.

Definition Z2z z :=
 match z mod exx.(vN) with
 | Zpos p => snd (ZnZ.of_pos p)
 | _ => ZnZ.zero
 end.

Definition S := exx.(vS).
Definition R := exx.(vR).
Definition A := Z2z exx.(vA).
Definition B := Z2z exx.(vB).
Definition xx := Z2z exx.(vx).
Definition yy := Z2z exx.(vy).
Definition c3 := Z2z 3.
Definition c2 := Z2z 2.
Definition c1 := Z2z 1.
Definition c0 := Z2z 0.

Inductive nelt: Type :=
  nzero | ntriple: zZ -> zZ -> zZ  -> nelt.

Definition pp := ntriple xx yy c1.

Definition nplus x y := mop.(add_mod) x y.
Definition nmul x y :=  mop.(mul_mod) x y.
Definition nsub x y :=  mop.(sub_mod) x y.
Definition neq x y := match ZnZ.compare x y with Eq => true | _ => false end.

Notation "x ++ y " := (nplus x y).
Notation "x -- y" := (nsub x y) (at level 50, left associativity).
Notation "x ** y" := (nmul x y) (at level 40, left associativity).
Notation "x ?= y" := (neq x y).

Definition ndouble: zZ -> nelt -> (nelt * zZ):= fun (sc: zZ) (p1: nelt) =>
 match p1 with
  nzero => (p1, sc)
 | (ntriple x1 y1 z1) =>
    if (y1 ?= c0) then (nzero, z1 ** sc) else
     (* we do 2p *)
    let m' := c3 ** x1 ** x1 ++ A ** z1 ** z1 in
    let l' := c2 ** y1 ** z1 in
    let m'2 := m' ** m' in
    let l'2 := l' ** l' in
    let l'3 := l'2 ** l' in
    let x3 := m'2 ** z1 -- c2 ** x1 ** l'2 in
    (ntriple
          (l' ** x3)
          (l'2 ** (m' ** x1 -- y1 ** l') -- m' ** x3)
          (z1 ** l'3), sc)
  end.

Definition nadd := fun (sc: zZ) (p1 p2: nelt) =>
 match p1, p2 with
  nzero, _ => (p2, sc)
 | _ , nzero => (p1, sc)
 | (ntriple x1 y1 z1), (ntriple x2 y2 z2) =>
  let d1 := x2 ** z1 in
  let d2 := x1 ** z2 in
  let l := d1 -- d2 in
  let dl := d1 ++ d2 in
  let m := y2 ** z1 -- y1 ** z2 in
  if (l ?= c0) then
   (* we have p1 = p2 o p1 = -p2 *)
   if (m ?= c0) then
    if (y1 ?= c0) then (nzero, z1 ** z2 ** sc) else
     (* we do 2p *)
    let m' := c3 ** x1 ** x1 ++ A ** z1 ** z1 in
    let l' := c2 ** y1 ** z1 in
    let m'2 := m' ** m' in
    let l'2 := l' ** l' in
    let l'3 := l'2 ** l' in
    let x3 := m'2 ** z1 -- c2 ** x1 ** l'2 in
    (ntriple
          (l' ** x3)
          (l'2 ** (m' ** x1 -- y1 ** l') -- m' ** x3)
          (z1 ** l'3), z2 ** sc)
    else (* p - p *)  (nzero, m ** z1 ** z2 ** sc)
  else
     let l2 := l ** l in
     let l3 := l2 ** l in
     let m2 := m ** m in
     let x3 := z1 ** z2 ** m2 -- l2 ** dl in
      (ntriple (l ** x3)
             (z2 ** l2 ** (m ** x1 -- y1 ** l) -- m ** x3)
             (z1 ** z2 ** l3), sc)
  end.

Definition nopp p :=
  match p with nzero => p | (ntriple x1 y1 z1) => (ntriple x1 (c0 -- y1) z1) end.

Fixpoint scalb (sc: zZ) (b:bool) (a: nelt) (p: positive) {struct p}:
 nelt * zZ :=
 match p with
   xH => if b then ndouble sc a else (a,sc)
 | xO p1 => let (a1, sc1) := scalb sc false a p1 in
              if b then
                let (a2, sc2) := ndouble sc1 a1 in
                nadd sc2 a a2
              else ndouble sc1 a1
 | xI p1 => let (a1, sc1) := scalb sc true a p1 in
              if b then  ndouble sc1 a1
              else
              let (a2, sc2) := ndouble sc1 a1 in
              nadd sc2 (nopp a) a2
 end.

Definition scal sc a p := scalb sc false a p.

Definition scal_list sc a l :=
  List.fold_left
  (fun (asc: nelt * zZ) p1 => let (a,sc) := asc in scal sc a p1) l (a,sc).

Fixpoint scalL (sc:zZ) (a: nelt) (l: List.list positive) {struct l}: (nelt * zZ) :=
   match l with
     List.nil => (a,sc)
   | List.cons n l1 =>
        let (a1, sc1) := scal sc a n in
        let (a2, sc2) := scal_list sc1 a l1 in
          match a2 with
             nzero => (nzero, c0)
          |  ntriple _ _ z => scalL (sc2 ** z) a1 l1
          end
   end.

Definition zpow sc p n :=
  let (p,sc') := scal sc p n in
  (p, ZnZ.to_Z (ZnZ.gcd sc' zN)).

Definition e2E n :=
  match n with
    nzero => ZEll.nzero
  | ntriple x1 y1 z1 => ZEll.ntriple (z2Z x1) (z2Z y1) (z2Z z1)
  end.

Definition wft t :=  z2Z t = (z2Z t) mod (z2Z zN).

Lemma vN_pos: 0 < exx.(vN).
red; simpl; auto.
Qed.

Hint Resolve vN_pos : core.

Lemma nplusz: forall x y, wft x -> wft y ->
      z2Z (x ++ y) = ZEll.nplus (vN exx) (z2Z x) (z2Z y).
Proof.
intros x y Hx Hy.
unfold z2Z, nplus.
rewrite (mop_spec.(add_mod_spec) _ _ _ _ Hx Hy); auto.
rewrite <- z2ZN; auto.
Qed.

Lemma nplusw: forall x y, wft x -> wft y ->  wft (x ++ y).
Proof.
intros x y Hx Hy.
unfold wft.
pattern (z2Z (x ++ y)) at 2; rewrite (nplusz Hx Hy).
unfold ZEll.nplus; rewrite z2ZN.
rewrite Zmod_mod; auto.
apply (nplusz Hx Hy).
Qed.

Lemma nsubz: forall x y, wft x -> wft y ->
      z2Z (x -- y) = ZEll.nsub (vN exx) (z2Z x) (z2Z y).
Proof.
intros x y Hx Hy.
unfold z2Z, nsub.
rewrite (mop_spec.(sub_mod_spec) _ _ _ _ Hx Hy); auto.
rewrite <- z2ZN; auto.
Qed.

Lemma nsubw: forall x y, wft x -> wft y ->  wft (x -- y).
Proof.
intros x y Hx Hy.
unfold wft.
pattern (z2Z (x -- y)) at 2; rewrite (nsubz Hx Hy).
unfold ZEll.nsub; rewrite z2ZN.
rewrite Zmod_mod; auto.
apply (nsubz Hx Hy).
Qed.

Lemma nmulz: forall x y, wft x -> wft y ->
      z2Z (x ** y) = ZEll.nmul (vN exx) (z2Z x) (z2Z y).
Proof.
intros x y Hx Hy.
unfold z2Z, nmul.
rewrite (mop_spec.(mul_mod_spec) _ _ _ _ Hx Hy); auto.
rewrite <- z2ZN; auto.
Qed.

Lemma nmulw: forall x y, wft x -> wft y ->  wft (x ** y).
Proof.
intros x y Hx Hy.
unfold wft.
pattern (z2Z (x ** y)) at 2; rewrite (nmulz Hx Hy).
unfold ZEll.nmul; rewrite z2ZN.
rewrite Zmod_mod; auto.
apply (nmulz Hx Hy).
Qed.

Hint Resolve nmulw nplusw nsubw : core.

Definition wfe p := match p with
  ntriple x y z => wft x /\ wft y /\ wft z
| _ => True
end.

Lemma z2Zx: forall x, z2Z (Z2z x) = x mod exx.(vN).
unfold Z2z; intros x.
generalize (Z_mod_lt x exx.(vN)).
case_eq (x mod exx.(vN)).
intros _ _.
simpl; unfold z2Z; rewrite ZnZ.spec_0; auto.
intros p Hp HH; case HH. auto with zarith. clear HH.
intros _ HH1.
case (ZnZ.spec_to_Z zN).
generalize  z2ZN; unfold z2Z; intros HH; rewrite HH.
intros _ H0.
set (v := ZnZ.of_pos p); generalize HH1.
rewrite (ZnZ.spec_of_pos p); fold v.
case (fst v).
  simpl; auto.
intros p1 H1.
contradict H0; apply Zle_not_lt.
apply Zlt_le_weak; apply Z.le_lt_trans with (2:= H1).
apply Z.le_trans with (1 * base (ZnZ.digits op) + 0). auto with zarith.
apply Zplus_le_compat.
apply Zmult_gt_0_le_compat_r.
  case (ZnZ.spec_to_Z (snd v)); auto with zarith.
  case p1; red; simpl; intros; discriminate.
  case (ZnZ.spec_to_Z (snd v)); auto with zarith.
intros p Hp; case (Z_mod_lt x exx.(vN)). auto with zarith.
rewrite Hp; intros HH; case HH; auto.
Qed.

Lemma z2Zx1: forall x, z2Z (Z2z x) = z2Z (Z2z x) mod z2Z zN.
Proof.
unfold Z2z; intros x.
generalize (Z_mod_lt x exx.(vN)).
case_eq (x mod exx.(vN)).
intros _ _.
simpl; unfold z2Z; rewrite ZnZ.spec_0; auto.
intros p H1 H2.
case (ZnZ.spec_to_Z zN).
generalize  z2ZN; unfold z2Z; intros HH; rewrite HH.
intros _ H0.
case H2; auto with zarith; clear H2; intros _ H2.
rewrite Zmod_small. reflexivity.
set (v := ZnZ.of_pos p).
split.
  case (ZnZ.spec_to_Z (snd v)); auto.
generalize H2; rewrite (ZnZ.spec_of_pos p); fold v.
case (fst v).
  simpl; auto.
intros p1 H.
contradict H0; apply Zle_not_lt.
apply Zlt_le_weak; apply Z.le_lt_trans with (2:= H).
apply Z.le_trans with (1 * base (ZnZ.digits op) + 0). auto with zarith.
apply Zplus_le_compat.
apply Zmult_gt_0_le_compat_r.
  case (ZnZ.spec_to_Z (snd v)); auto with zarith.
  case p1; red; simpl; intros; discriminate.
  case (ZnZ.spec_to_Z (snd v)); auto with zarith.
intros p Hp; case (Z_mod_lt x exx.(vN)). auto with zarith.
rewrite Hp; intros HH; case HH; auto.
Qed.

Lemma c0w: wft c0.
Proof.
red; unfold c0; apply z2Zx1.
Qed.

Lemma c2w: wft c2.
Proof.
red; unfold c2; apply z2Zx1.
Qed.

Lemma c3w: wft c3.
Proof.
red; unfold c3; apply z2Zx1.
Qed.

Lemma Aw: wft A.
Proof.
red; unfold A; apply z2Zx1.
Qed.

Hint Resolve c0w c2w c3w Aw : core.

Ltac nw :=
  repeat (apply nplusw || apply nsubw || apply nmulw || apply c2w ||
          apply c3w || apply Aw); auto.

Lemma nadd_wf: forall x y sc,
  wfe x -> wfe y -> wft sc ->
  wfe (fst (nadd sc x y)) /\  wft (snd (nadd sc x y)).
Proof.
intros x; case x; clear x; auto.
intros x1 y1 z1 y; case y; clear y; auto.
  intros x2 y2 z2 sc (wfx1,(wfy1, wfz1)) (wfx2,(wfy2, wfz2)) wfsc;
    simpl; auto.
   case neq.
    2: repeat split; simpl; nw.
   case neq.
    2: repeat split; simpl; nw.
   case neq.
   repeat split; simpl; nw; auto.
   repeat split; simpl; nw; auto.
Qed.

 Lemma ztest: forall x y,
     x ?= y =Zeq_bool (z2Z x) (z2Z y).
 Proof.
 intros x y.
 unfold neq.
 rewrite (ZnZ.spec_compare x y); case Z.compare_spec; intros HH;
 match goal with H: context[x] |- _ =>
   generalize H; clear H; intros HH1
 end.
 symmetry; apply GZnZ.Zeq_iok; auto.
 case_eq (Zeq_bool (z2Z x) (z2Z y)); intros H1; auto;
   generalize HH1; generalize (Zeq_bool_eq _ _ H1); unfold z2Z;
   intros HH; rewrite HH; auto with zarith.
 case_eq (Zeq_bool (z2Z x) (z2Z y)); intros H1; auto;
   generalize HH1; generalize (Zeq_bool_eq _ _ H1); unfold z2Z;
   intros HH; rewrite HH; auto with zarith.
 Qed.

 Lemma zc0: z2Z c0 = 0.
 Proof.
 unfold z2Z, c0, z2Z; simpl.
 generalize ZnZ.spec_0; auto.
 Qed.

Ltac iftac t :=
  match t with
   context[if ?x ?= ?y then _ else _] =>
      case_eq (x ?= y)
  end.

Ltac ftac := match goal with
  |- context[?x = ?y] => (iftac x);
    let H := fresh "tmp" in
     (try rewrite ztest; try rewrite zc0; intros H;
      repeat ((rewrite nmulz in H || rewrite nplusz in H || rewrite nsubz in H); auto);
      try (rewrite H; clear H))
    end.

Lemma c2ww: forall x, ZEll.nmul (vN exx) 2 x = ZEll.nmul (vN exx) (z2Z c2) x.
intros x; unfold ZEll.nmul.
unfold c2; rewrite z2Zx; rewrite Zmodml; auto.
Qed.
Lemma c3ww: forall x, ZEll.nmul (vN exx) 3 x = ZEll.nmul (vN exx) (z2Z c3) x.
intros x; unfold ZEll.nmul.
unfold c3; rewrite z2Zx; rewrite Zmodml; auto.
Qed.

Lemma Aww: forall x, ZEll.nmul (vN exx) exx.(vA) x = ZEll.nmul (vN exx) (z2Z A) x.
intros x; unfold ZEll.nmul.
unfold A; rewrite z2Zx; rewrite Zmodml; auto.
Qed.

Lemma nadd_correct: forall x y sc,
  wfe x -> wfe y -> wft sc ->
  e2E (fst (nadd sc x y)) = fst (ZEll.nadd exx.(vN) exx.(vA) (z2Z sc) (e2E x) (e2E y) )/\
  z2Z (snd (nadd sc x y)) = snd (ZEll.nadd exx.(vN) exx.(vA) (z2Z sc) (e2E x) (e2E y)).
Proof.
intros x; case x; clear x; auto.
intros x1 y1 z1 y; case y; clear y; auto.
  intros x2 y2 z2 sc (wfx1,(wfy1, wfz1)) (wfx2,(wfy2, wfz2)) wfsc; simpl.
  ftac.
  ftac.
  ftac.
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz); auto).
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz||
           rewrite c2ww || rewrite c3ww || rewrite Aww); try nw; auto).
  rewrite nmulz; auto.
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz); auto).
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz ||
           rewrite c2ww || rewrite c3ww || rewrite Aww); try nw; auto).
  Qed.

 Lemma ndouble_wf: forall x sc,
  wfe x -> wft sc ->
  wfe (fst (ndouble sc x)) /\  wft (snd (ndouble sc x)).
Proof.
intros x; case x; clear x; auto.
intros x1 y1 z1 sc (wfx1,(wfy1, wfz1)) wfsc;
    simpl; auto.
  repeat (case neq; repeat split; simpl; nw; auto).
Qed.

Lemma ndouble_correct: forall x sc,
  wfe x -> wft sc ->
  e2E (fst (ndouble sc x)) = fst (ZEll.ndouble exx.(vN) exx.(vA) (z2Z sc) (e2E x))/\
  z2Z (snd (ndouble sc x)) = snd (ZEll.ndouble exx.(vN) exx.(vA) (z2Z sc) (e2E x)).
Proof.
intros x; case x; clear x; auto.
  intros x1 y1 z1 sc (wfx1,(wfy1, wfz1))  wfsc; simpl.
  ftac.
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz); auto).
  simpl; split; auto.
  repeat ((rewrite nmulz || rewrite nplusz || rewrite nsubz ||
           rewrite c2ww || rewrite c3ww || rewrite Aww); try nw; auto).
  Qed.

Lemma nopp_wf: forall x, wfe x -> wfe (nopp x).
Proof.
intros x; case x; simpl nopp; auto.
intros x1 y1 z1 [H1 [H2 H3]]; repeat split; auto.
Qed.

Lemma scalb_wf: forall n b x sc,
  wfe x -> wft sc ->
  wfe (fst (scalb sc b x n)) /\  wft (snd (scalb sc b x n)).
Proof.
intros n; elim n; unfold scalb; fold scalb; auto.
  intros n1 Hrec b x sc H H1.
    case (Hrec true x sc H H1).
    case scalb; simpl fst; simpl snd.
    intros a1 sc1 H2 H3.
    case (ndouble_wf _ H2 H3); auto;
    case ndouble; simpl fst; simpl snd; intros x2 sc2 H4 H5.
    case b; auto.
    case (nadd_wf _ _ (nopp_wf _ H) H4 H5); auto;
    case ndouble; simpl fst; simpl snd; intros x2 sc2 H4 H5.
  intros n1 Hrec b x sc H H1.
    case (Hrec false x sc H H1).
    case scalb; simpl fst; simpl snd.
    intros a1 sc1 H2 H3.
    case (ndouble_wf _ H2 H3); auto;
    case ndouble; simpl fst; simpl snd; intros x2 sc2 H4 H5.
    case b; auto.
    case (nadd_wf _ _ H H4 H5); auto;
    case ndouble; simpl fst; simpl snd; intros x2 sc2 H4 H5.
intros b x sc H H1; case b; auto.
case (ndouble_wf _ H H1); auto.
Qed.

Lemma scal_wf: forall n x sc,
  wfe x -> wft sc ->
  wfe (fst (scal sc x n)) /\  wft (snd (scal sc x n)).
Proof.
intros n; exact (scalb_wf n false).
Qed.

Lemma nopp_correct: forall x,
  wfe x -> e2E x = ZEll.nopp exx.(vN) (e2E (nopp x)).
Proof.
intros x; case x; simpl; auto.
intros x1 y1 z1 [H1 [H2 H3]]; apply f_equal3 with (f := ZEll.ntriple); auto.
rewrite nsubz; auto.
rewrite zc0.
unfold ZEll.nsub, ninv; simpl.
apply sym_equal.
rewrite <- (Z_mod_plus) with (b := -(-z2Z y1 /exx.(vN))); auto with zarith.
rewrite <- Zopp_mult_distr_l.
rewrite <- Zopp_plus_distr.
rewrite Zmult_comm; rewrite Zplus_comm.
rewrite <- Z_div_mod_eq_full.
rewrite Z.opp_involutive; rewrite <- z2ZN.
apply sym_equal; auto.
Qed.

Lemma scalb_correct: forall n b x sc,
  wfe x -> wft sc ->
  e2E (fst (scalb sc b x n)) = fst (ZEll.scalb exx.(vN) exx.(vA) (z2Z sc) b (e2E x) n)/\
  z2Z (snd (scalb sc b x n)) = snd (ZEll.scalb exx.(vN) exx.(vA) (z2Z sc) b (e2E x) n).
Proof.
intros n; elim n; clear n; auto.
intros p Hrec b x sc H1 H2.
  case b; unfold scalb; fold scalb.
    generalize (scalb_wf p true x H1 H2);
    generalize (Hrec true _ _ H1 H2); case scalb; simpl.
    case ZEll.scalb; intros r1 rc1; simpl.
    intros a2 sc2 (H3, H4) (H5, H6); subst r1 rc1.
    apply ndouble_correct; auto.
    generalize (scalb_wf p true x H1 H2);
    generalize (Hrec true _ _ H1 H2); case scalb; simpl.
    case ZEll.scalb; intros r1 rc1; simpl.
    intros a2 sc2 (H3, H4) (H5, H6); subst r1 rc1.
    generalize (ndouble_wf _ H5 H6);
      generalize (ndouble_correct _ H5 H6); case ndouble; simpl.
    case ZEll.ndouble; intros r1 rc1; simpl.
    intros a3 sc3 (H7,H8) (H9,H10); subst r1 rc1.
    replace (ZEll.nopp (vN exx) (e2E x)) with
      (e2E (nopp x)).
    apply nadd_correct; auto.
    generalize H1; case x; auto.
    intros x1 y1 z1 [HH1 [HH2 HH3]]; split; auto.
    rewrite nopp_correct; auto.
    apply f_equal2 with (f := ZEll.nopp); auto.
    generalize H1; case x; simpl; auto; clear x H1.
    intros x1 y1 z1 [HH1 [HH2 HH3]];
      apply f_equal3 with (f := ZEll.ntriple); auto.
    repeat rewrite nsubz; auto.
    rewrite zc0.
    unfold ZEll.nsub; simpl.
    rewrite <- (Z_mod_plus) with (b := -(-z2Z y1 /exx.(vN))); auto with zarith.
    rewrite <- Zopp_mult_distr_l.
    rewrite <- Zopp_plus_distr.
    rewrite Zmult_comm; rewrite Zplus_comm.
    rewrite <- Z_div_mod_eq_full.
    rewrite Z.opp_involutive; rewrite <- z2ZN.
    apply sym_equal; auto.
    generalize H1; case x; auto.
    intros x1 y1 z1 [HH1 [HH2 HH3]]; split; auto.
intros p Hrec b x sc H1 H2.
  case b; unfold scalb; fold scalb.
    generalize (scalb_wf p false x H1 H2);
    generalize (Hrec false _ _ H1 H2); case scalb; simpl.
    case ZEll.scalb; intros r1 rc1; simpl.
    intros a2 sc2 (H3, H4) (H5, H6); subst r1 rc1.
    generalize (ndouble_wf _ H5 H6);
      generalize (ndouble_correct _ H5 H6); case ndouble; simpl.
    case ZEll.ndouble; intros r1 rc1; simpl.
    intros a3 sc3 (H7,H8) (H9,H10); subst r1 rc1.
    replace (ZEll.nopp (vN exx) (e2E x)) with
      (e2E (nopp x)).
    apply nadd_correct; auto.
    rewrite nopp_correct; auto.
    apply f_equal2 with (f := ZEll.nopp); auto.
    generalize H1; case x; simpl; auto; clear x H1.
    intros x1 y1 z1 [HH1 [HH2 HH3]];
      apply f_equal3 with (f := ZEll.ntriple); auto.
    repeat rewrite nsubz; auto.
    rewrite zc0.
    unfold ZEll.nsub; simpl.
    rewrite <- (Z_mod_plus) with (b := -(-z2Z y1 /exx.(vN))); auto with zarith.
    rewrite <- Zopp_mult_distr_l.
    rewrite <- Zopp_plus_distr.
    rewrite Zmult_comm; rewrite Zplus_comm.
    rewrite <- Z_div_mod_eq_full.
    rewrite Z.opp_involutive; rewrite <- z2ZN.
    apply sym_equal; auto.
    generalize H1; case x; auto.
    intros x1 y1 z1 [HH1 [HH2 HH3]]; split; auto.
    generalize (scalb_wf p false x H1 H2);
    generalize (Hrec false _ _ H1 H2); case scalb; simpl.
    case ZEll.scalb; intros r1 rc1; simpl.
    intros a2 sc2 (H3, H4) (H5, H6); subst r1 rc1.
    apply ndouble_correct; auto.
intros b x sc H H1.
case b; simpl; auto.
apply ndouble_correct; auto.
Qed.

Lemma scal_correct: forall n x sc,
  wfe x -> wft sc ->
  e2E (fst (scal sc x n)) = fst (ZEll.scal exx.(vN) exx.(vA) (z2Z sc) (e2E x) n)/\
  z2Z (snd (scal sc x n)) = snd (ZEll.scal exx.(vN) exx.(vA) (z2Z sc) (e2E x) n).
Proof.
intros n; exact (scalb_correct n false).
Qed.

Lemma scal_list_correct: forall l x sc,
  wfe x -> wft sc ->
  e2E (fst (scal_list sc x l)) = fst (ZEll.scal_list exx.(vN) exx.(vA) (z2Z sc) (e2E x) l)/\
  z2Z (snd (scal_list sc x l)) = snd (ZEll.scal_list exx.(vN) exx.(vA) (z2Z sc) (e2E x) l).
Proof.
intros l1; elim l1; simpl; auto.
unfold scal_list, ZEll.scal_list; simpl; intros a l2 Hrec x sc H1 H2.
generalize (scal_correct a _ H1 H2) (scal_wf a _ H1 H2); case scal.
case ZEll.scal; intros r1 rsc1; simpl.
simpl; intros a1 sc1 (H3, H4) (H5, H6); subst r1 rsc1; auto.
Qed.

Lemma scal_list_wf: forall l x sc,
  wfe x -> wft sc ->
  wfe (fst (scal_list sc x l)) /\  wft (snd (scal_list sc x l)).
Proof.
intros l1; elim l1; simpl; auto.
unfold scal_list; intros a l Hrec x sc H1 H2; simpl.
generalize (@scal_wf a _ _ H1 H2);
  case (scal sc x a); simpl; intros x1 sc1 [H3 H4]; auto.
Qed.

Lemma scalL_wf: forall l x sc,
  wfe x -> wft sc ->
  wfe (fst (scalL sc x l)) /\  wft (snd (scalL sc x l)).
Proof.
intros l1; elim l1; simpl; auto.
intros a l2 Hrec x sc H1 H2.
generalize (scal_wf a _ H1 H2); case scal; simpl.
intros a1 sc1 (H3, H4); auto.
generalize (scal_list_wf l2 _ H1 H4); case scal_list; simpl.
intros a2 sc2; case a2; simpl; auto.
intros x1 y1 z1 ((V1, (V2, V3)), V4); apply Hrec; auto.
Qed.

Lemma scalL_correct: forall l x sc,
  wfe x -> wft sc ->
  e2E (fst (scalL sc x l)) = fst (ZEll.scalL exx.(vN) exx.(vA) (z2Z sc) (e2E x) l)/\
  z2Z (snd (scalL sc x l)) = snd (ZEll.scalL exx.(vN) exx.(vA) (z2Z sc) (e2E x) l).
Proof.
intros l1; elim l1; simpl; auto.
intros a l2 Hrec x sc H1 H2.
generalize (scal_wf a _ H1 H2) (scal_correct a _ H1 H2); case scal; simpl.
case ZEll.scal; intros r1 rsc1; simpl.
intros a1 sc1 (H3, H4) (H5, H6); subst r1 rsc1.
generalize (scal_list_wf l2 _ H1 H4) (scal_list_correct l2 _ H1 H4); case scal_list; simpl.
case ZEll.scal_list; intros r1 rsc1; simpl.
intros a2 sc2 (H7, H8) (H9, H10); subst r1 rsc1.
generalize H7; clear H7; case a2; simpl; auto.
rewrite zc0; auto.
intros x1 y1 z1 (V1, (V2, V3)); auto.
generalize (nmulw H8 V3) (nmulz H8 V3); intros V4 V5; rewrite <- V5.
apply Hrec; auto.
Qed.

Lemma f4 : wft (Z2z 4).
Proof.
red; apply z2Zx1.
Qed.

Lemma f27 : wft (Z2z 27).
Proof.
red; apply z2Zx1.
Qed.

Lemma Bw : wft B.
Proof.
red; unfold B; apply z2Zx1.
Qed.

Hint Resolve f4 f27 Bw : core.

Lemma mww: forall x y, ZEll.nmul (vN exx) (x mod (vN exx) ) y = ZEll.nmul (vN exx) x y.
intros x  y; unfold ZEll.nmul; rewrite Zmodml; auto.
Qed.

Lemma wwA: forall x, ZEll.nmul (vN exx) x exx.(vA) = ZEll.nmul (vN exx) x (z2Z A).
intros x; unfold ZEll.nmul.
unfold A; rewrite z2Zx; rewrite Zmodmr; auto.
Qed.

Lemma wwB: forall x, ZEll.nmul (vN exx) x exx.(vB) = ZEll.nmul (vN exx) x (z2Z B).
intros x; unfold ZEll.nmul.
unfold B; rewrite z2Zx; rewrite Zmodmr; auto.
Qed.

 Lemma  scalL_prime:
  let a := ntriple (Z2z (exx.(vx))) (Z2z (exx.(vy))) c1 in
  let isc := (Z2z 4) ** A ** A ** A  ++ (Z2z 27) ** B ** B in
  let (a1, sc1) := scal isc a exx.(vS) in
  let (S1,R1) := psplit exx.(vR) in
  let (a2, sc2) := scal sc1 a1 S1 in
  let (a3, sc3) := scalL sc2 a2 R1 in
    match a3 with
     nzero => if (Zeq_bool (Z.gcd (z2Z sc3) exx.(vN)) 1) then prime exx.(vN)
              else True
   | _ => True
   end.
  Proof.
  intros a isc.
  case_eq (scal isc a (vS exx)); intros a1 sc1 Ha1.
  case_eq (psplit (vR exx)); intros S1 R1 HS1.
  case_eq (scal sc1 a1 S1); intros a2 sc2 Ha2.
  case_eq (scalL sc2 a2 R1); intros a3 sc3; case a3; auto.
  intros Ha3; case_eq (Zeq_bool (Z.gcd (z2Z sc3) (vN exx)) 1); auto.
  intros H1.
  assert (F0:
     (vy exx mod vN exx) ^ 2 mod vN exx =
       ((vx exx mod vN exx) ^ 3 + vA exx * (vx exx mod vN exx) +
        vB exx) mod vN exx).
      generalize exxs.(inC).
      simpl; unfold Zpower_pos; simpl.
      repeat rewrite Zmult_1_r.
      intros HH.
      match goal with |- ?t1 = ?t2 => rmod t1; auto end.
      rewrite HH.
      rewrite Zplus_mod; auto; symmetry; rewrite Zplus_mod; auto; symmetry.
      apply f_equal2 with (f := Z.modulo); auto.
      apply f_equal2 with (f := Zplus); auto.
      rewrite Zplus_mod; auto; symmetry; rewrite Zplus_mod; auto; symmetry.
      apply f_equal2 with (f := Z.modulo); auto.
      apply f_equal2 with (f := Zplus); auto.
      rewrite Zmult_mod; auto; symmetry; rewrite Zmult_mod; auto; symmetry.
      apply f_equal2 with (f := Z.modulo); auto.
      apply f_equal2 with (f := Zmult); auto.
      rewrite Zmod_mod; auto.
      match goal with |- ?t1 = ?t2 => rmod t2; auto end.
      rewrite Zmult_mod; auto; symmetry; rewrite Zmult_mod; auto; symmetry.
      apply f_equal2 with (f := Z.modulo); auto.
      rewrite Zmod_mod; auto.
   generalize (@ZEll.scalL_prime exx.(vN)
               (exx.(vx) mod exx.(vN))
               (exx.(vy) mod exx.(vN))
               exx.(vA)
               exx.(vB)
               exxs.(n_pos) exxs.(n2_div) exx.(vR)
               exxs.(lprime) exx.(vS) exxs.(lbig) F0); simpl.
generalize (@scal_wf (vS exx) a isc) (@scal_correct (vS exx) a isc).
unfold isc.
rewrite nplusz; auto; try nw; auto.
repeat rewrite nmulz; auto; try nw; auto.
  repeat rewrite z2Zx.
repeat rewrite wwA || rewrite wwB|| rewrite mww.
replace (e2E a) with (ZEll.ntriple (vx exx mod vN exx) (vy exx mod vN exx) 1).
case ZEll.scal.
fold isc; rewrite HS1; rewrite Ha1; simpl; auto.
intros r1 rsc1 HH1 HH2.
case HH1; clear HH1.
  unfold c1; repeat split; red; try apply z2Zx1.
  unfold isc; nw.
case HH2; clear HH2.
  unfold c1; repeat split; red; try apply z2Zx1.
  unfold isc; nw.
intros U1 U2 W1 W2; subst r1 rsc1.
generalize (@scal_wf S1 a1 sc1) (@scal_correct S1 a1 sc1).
case ZEll.scal.
intros r1 rsc1 HH1 HH2.
case HH1; clear HH1; auto.
case HH2; clear HH2; auto.
rewrite Ha2; simpl.
intros U1 U2 W3 W4; subst r1 rsc1.
generalize (@scalL_wf R1 a2 sc2) (@scalL_correct R1 a2 sc2).
case ZEll.scalL.
intros n; case n; auto.
rewrite Ha3; simpl.
intros rsc1 HH1 HH2.
case HH1; clear HH1; auto.
case HH2; clear HH2; auto.
intros _ U2 _ W5; subst rsc1.
rewrite H1; auto.
intros x1 y1 z1 sc4; rewrite Ha3; simpl; auto.
intros _ HH; case HH; auto.
intros; discriminate.
unfold a; simpl.
unfold c1; repeat rewrite z2Zx.
rewrite (Zmod_small 1); auto.
generalize exxs.(n_pos).
auto with zarith.
Qed.

End NEll.

Fixpoint plength (p: positive) : positive :=
  match p with
    xH => xH
  | xO p1 => Pos.succ (plength p1)
  | xI p1 => Pos.succ (plength p1)
  end.

Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z.
assert (F: (forall p, 2 ^ (Zpos (Pos.succ p)) = 2 * 2 ^ Zpos p)%Z).
intros p; replace (Zpos (Pos.succ p)) with (1 + Zpos p)%Z.
rewrite Zpower_exp; auto with zarith.
rewrite Zpos_succ_morphism; unfold Z.succ; auto with zarith.
intros p; elim p; simpl plength; auto.
intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI.
assert (tmp: (forall p, 2 * p = p + p)%Z);
  try repeat rewrite tmp; auto with zarith.
intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1).
assert (tmp: (forall p, 2 * p = p + p)%Z);
  try repeat rewrite tmp; auto with zarith.
rewrite Zpower_1_r; auto with zarith.
Qed.

Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Pos.pred p)))
%Z.
intros p; case (Psucc_pred p); intros H1.
subst; simpl plength.
rewrite Zpower_1_r; auto with zarith.
pattern p at 1; rewrite <- H1.
rewrite Zpos_succ_morphism; unfold Z.succ; auto with zarith.
generalize (plength_correct (Pos.pred p)); auto with zarith.
Qed.

Definition pheight p := plength (Pos.pred (plength (Pos.pred p))).

Theorem pheight_correct: forall p, (Zpos p <= 2 ^ (2 ^ (Zpos (pheight p))))%Z.
intros p; apply Z.le_trans with (1 := (plength_pred_correct p)).
apply Zpower_le_monotone; auto with zarith.
split; auto with zarith.
unfold pheight; apply plength_pred_correct.
Qed.

Definition isM2 p :=
  match p with
    xH   => false
|    xO _ => false
|     _ => true
end.

Lemma isM2_correct: forall p,
  if isM2 p then ~(Z.divide 2 p) /\ 2 < p else True.
Proof.
intros p; case p; simpl; auto; clear p.
intros p1; split; auto.
intros HH; inversion_clear HH.
generalize H; rewrite Zmult_comm.
case x; simpl; intros; discriminate.
case p1; red; simpl; auto.
Qed.

Definition ell_test (N S: positive) (l: List.list (positive * positive))
                      (A B x y: Z) :=
  let op := cmk_op (Peano.pred (nat_of_P (get_height 63 (plength N)))) in
  let mop := make_mod_op op (ZnZ.of_Z N) in
    if isM2 N then
    match (4 * N) ?= (ZEll.Zmullp l - 1) ^ 2  with
      Lt =>
       match y ^ 2 mod N ?= (x ^ 3 + A * x + B) mod N with
       Eq =>
          let ex := mkEx N S l A B x y in
          let a := ntriple (Z2z ex op x) (Z2z ex op y) (Z2z ex op 1)  in
          let A := (Z2z  ex op A) in
          let B := (Z2z  ex op B) in
          let d4 := (Z2z  ex op 4) in
          let d27 := (Z2z  ex op 27) in
          let da := mop.(add_mod) in
          let dm := mop.(mul_mod) in
          let isc := (da (dm (dm  (dm d4 A) A) A) (dm (dm d27 B) B)) in
          let (a1, sc1) := scal ex op mop isc a S in
          let (S1,R1) := ZEll.psplit l in
          let (a2, sc2) := scal ex op mop sc1 a1 S1 in
          let (a3, sc3) := scalL ex op mop sc2 a2 R1 in
          match a3 with
           nzero _ => if (Zeq_bool (Z.gcd (z2Z op sc3) N) 1) then true
                    else false
          | _ => false
          end
      | _  => false
       end
    | _  => false
    end
    else false.

Lemma Zcompare_correct: forall x y,
  match x ?= y with Eq => x = y | Gt => x > y | Lt => x < y end.
Proof.
intros x y; unfold Z.lt, Z.gt; generalize (Zcompare_Eq_eq x y); case Z.compare; auto.
Qed.

Lemma ell_test_correct: forall (N S: positive) (l: List.list (positive * positive))
                      (A B x y: Z),
  (forall p, List.In p l -> prime (fst p)) ->
  if ell_test N S l A B x y then prime N else True.
intros N S1 l A1 B1 x y H; unfold ell_test.
generalize (isM2_correct N); case isM2; auto.
intros (H1, H2).
match goal with |- context[?x ?= ?y] =>
  generalize (Zcompare_correct x y); case Z.compare; auto
end; intros H3.
match goal with |- context[?x ?= ?y] =>
  generalize (Zcompare_correct x y); case Z.compare; auto
end; intros H4.
set (n := Peano.pred (nat_of_P (get_height 63 (plength N)))).
set (op := cmk_op n).
set (mop := make_mod_op op (ZnZ.of_Z N)).
set (exx := mkEx N S1 l A1 B1 x y).
set (op_spec := cmk_spec n).
assert (exxs: ex_spec exx).
  constructor; auto.
assert (H0: N < base (ZnZ.digits op)).
  apply Z.lt_le_trans with (1 := plength_correct N).
  unfold op, base.
  rewrite cmk_op_digits.
  apply Zpower_le_monotone; split. auto with zarith.
  generalize (get_height_correct 63 (plength N)); unfold n.
  set (p := plength N).
  replace (Z_of_nat (Peano.pred (nat_of_P (get_height 63 p)))) with
       ((Zpos (get_height 63 p) - 1) ). auto with zarith.
  rewrite <- Nat.sub_1_r; rewrite inj_minus1.
  rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; reflexivity.
  generalize (lt_O_nat_of_P (get_height 63 p)); auto with zarith.
assert (mspec: mod_spec op (zN exx op) mop).
  unfold mop; apply make_mod_spec; auto.
  rewrite ZnZ.of_Z_correct; auto with zarith.
generalize (@scalL_prime exx exxs _ op (cmk_spec n) mop mspec H0).
lazy zeta.
unfold c1, A, B,  nplus, nmul;
  simpl (exx.(vA)); simpl (exx.(vB)); simpl (exx.(vx)); simpl (exx.(vy));
  simpl (exx.(vS)); simpl (exx.(vR)); simpl (exx.(vN)).
case scal; intros a1 sc1.
case ZEll.psplit; intros S2 R2.
case scal; intros a2 sc2.
case scalL; intros a3 sc3.
case a3; auto.
case Zeq_bool; auto.
Qed.

Time Eval vm_compute in (ell_test
  329719147332060395689499
  8209062
  (List.cons (40165264598163841%positive,1%positive) List.nil)
  (-94080)
  9834496
  0
  3136).

Time Eval vm_compute in (ell_test
  1384435372850622112932804334308326689651568940268408537
  13077052794
  (List.cons (105867537178241517538435987563198410444088809%positive, 1%positive) List.nil)
  (-677530058123796416781392907869501000001421915645008494)
  0
  (-169382514530949104195348226967375250000355478911252124)
  1045670343788723904542107880373576189650857982445904291
).


(**
Derivation of an over  signature
(copied from SignatureDerivation)
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.CategoryTheory.Monads.Derivative.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.terminal.

Require Import Modules.Prelims.lib.

Require Import Modules.Prelims.LModulesCoproducts.
Require Import Modules.Prelims.DerivationIsFunctorial.
Require Import Modules.Signatures.Signature.
Require Import Modules.Signatures.ModelCat.
Require Import Modules.SoftEquations.SignatureOver.

Section DAr.

  Context {C : category}
          (bcpC : limits.bincoproducts.BinCoproducts C)
          (CT : limits.terminal.Terminal C).
Local Notation "∂" := (LModule_deriv_functor (TerminalObject CT) bcpC
                                             _).

Local Notation Signature := (signature C).
Local Notation MOD R := (category_LModule R C).

Context { Sig : signature C}.
Local Notation MODEL := (model Sig).
Local Notation MODEL_MOR := rep_fiber_mor.
Local Notation OSIG := (signature_over Sig).
Variable (a : OSIG).

  Definition signature_over_deriv_on_objects (R : MODEL)  : LModule R C :=
    ∂ (a R).

  Definition signature_over_deriv_on_morphisms (R S : MODEL)
             (f : MODEL_MOR R S) : LModule_Mor _ (signature_over_deriv_on_objects R)
                                               (pb_LModule f (signature_over_deriv_on_objects S)) :=
    (# ∂ (# a f)%sigo ) · (inv_from_iso (pb_LModule_deriv_iso _ bcpC  f _ )).

  Definition signature_over_deriv_data : signature_over_data Sig
    := signature_over_deriv_on_objects ,, signature_over_deriv_on_morphisms.

  Lemma signature_over_deriv_is_signature_over : is_signature_over _ signature_over_deriv_data.
  Proof.
    split.
    - intros R c.
      cbn -[LModule_deriv_functor identity].
      repeat rewrite id_right.
      etrans.
      {
        set (f := ((#a)%sigo _)).
        eapply (maponpaths  (fun (z : LModule_Mor _ _ _) => (# ∂ z : LModule_Mor _ _ _) c )(t1 := f)
                            (t2 := morphism_from_iso (pb_LModule_id_iso _) )
               ).
        apply LModule_Mor_equiv;[apply homset_property|].
        apply nat_trans_eq;[apply homset_property|].
        apply signature_over_id.
      }
      apply idpath.
    - intros R S T f g.
      etrans.
      {
      apply (cancel_postcomposition (C := MOD R)).
      rewrite signature_over_comp.
      apply functor_comp.
      }
      apply LModule_Mor_equiv;[apply homset_property|].
      apply nat_trans_eq;[apply homset_property|].
      intro x.
      cbn.
      repeat rewrite id_right.
      apply idpath.
  Qed.

  Definition signature_over_deriv : signature_over Sig := _ ,, signature_over_deriv_is_signature_over.

End DAr.

Fixpoint signature_over_deriv_n {C : category} (S : signature C) bcp T a (n :nat) : signature_over S :=
  match n with
    0 => a
  | S m => @signature_over_deriv C bcp T S (@signature_over_deriv_n C S bcp T a m)
  end.


From Coq Require Import ZArith .
From Common Require Import Var .
From mQhasm Require Import zDSL zRadix .
From mathcomp Require Import seq .

Open Scope N_scope.
Open Scope zdsl_scope.

Definition fe25519_mul_stage3_1 : program :=

let         wsize :=   64%nat in

let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let           tmp := 998 in

let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in

let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in

let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in

let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
[::
zAssign z0 (zBinop zAdd (zVar r0) (zmul2p (zVar mulr01) 64));
zAssign z1 (zBinop zAdd (zVar r1) (zmul2p (zVar mulr11) 64));
zAssign z2 (zBinop zAdd (zVar r2) (zmul2p (zVar mulr21) 64));
zAssign z3 (zBinop zAdd (zVar r3) (zmul2p (zVar mulr31) 64));
zAssign z4 (zBinop zAdd (zVar r4) (zmul2p (zVar mulr41) 64));
      (*   mulr01 = (mulr01.r0) << 13 *)
      (*   r0 &= mulredmask *)
zSplit tmp r0 (zVar r0) 51;
zAssign mulr01 (zBinop zAdd (zmul2p (zVar mulr01) 13) (zVar tmp));
      (*   mulr11 = (mulr11.r1) << 13 *)
      (*   r1 &= mulredmask *)
      (*   r1 += mulr01 *)
zSplit tmp r1 (zVar r1) 51;
zAssign mulr11 (zBinop zAdd (zmul2p (zVar mulr11) 13) (zVar tmp));
zAssign r1 (zBinop zAdd (zVar r1) (zVar mulr01));
      (*   mulr21 = (mulr21.r2) << 13 *)
      (*   r2 &= mulredmask *)
      (*   r2 += mulr11 *)
zSplit tmp r2 (zVar r2) 51;
zAssign mulr21 (zBinop zAdd (zmul2p (zVar mulr21) 13) (zVar tmp));
zAssign r2 (zBinop zAdd (zVar r2) (zVar mulr11));
      (*   mulr31 = (mulr31.r3) << 13 *)
      (*   r3 &= mulredmask *)
      (*   r3 += mulr21 *)
zSplit tmp r3 (zVar r3) 51;
zAssign mulr31 (zBinop zAdd (zmul2p (zVar mulr31) 13) (zVar tmp));
zAssign r3 (zBinop zAdd (zVar r3) (zVar mulr21));
      (*   mulr41 = (mulr41.r4) << 13 *)
      (*   r4 &= mulredmask *)
      (*   r4 += mulr31 *)
zSplit tmp r4 (zVar r4) 51;
zAssign mulr41 (zBinop zAdd (zmul2p (zVar mulr41) 13) (zVar tmp));
zAssign r4 (zBinop zAdd (zVar r4) (zVar mulr31));
      (*   mulr41 = mulr41 * 19 *)
zAssign mulr41 (zBinop zMul (zVar mulr41) (zConst 19%Z));
      (*   r0 += mulr41 *)
zAssign r0 (zBinop zAdd (zVar r0) (zVar mulr41))
      (*  *)
      (*  *)
      (*  *)
      (*  *)
] .

Definition fe25519_mul_stage3_1_inputs : VS.t :=
let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in
let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in
let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in
let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
VSLemmas.OP.P.of_list [:: mulr01; r0; mulr11; r1; mulr21; r2; mulr31; r3; mulr41; r4].

Definition fe25519_mul_stage3_1_pre : bexp := zTrue.

Definition fe25519_mul_stage3_1_post : bexp :=
let            x0 :=   0 in (* *[uint64 *](xp +  0) *)
let            x1 :=   1 in (* *[uint64 *](xp +  8) *)
let            x2 :=   2 in (* *[uint64 *](xp + 16) *)
let            x3 :=   3 in (* *[uint64 *](xp + 24) *)
let            x4 :=   4 in (* *[uint64 *](xp + 32) *)
let            y0 :=   5 in (* *[uint64 *](yp +  0) *)
let            y1 :=   6 in (* *[uint64 *](yp +  8) *)
let            y2 :=   7 in (* *[uint64 *](yp + 16) *)
let            y3 :=   8 in (* *[uint64 *](yp + 24) *)
let            y4 :=   9 in (* *[uint64 *](yp + 32) *)
let            z0 :=  10 in (* *[uint64 *](rp +  0) *)
let            z1 :=  11 in (* *[uint64 *](rp +  8) *)
let            z2 :=  12 in (* *[uint64 *](rp + 16) *)
let            z3 :=  13 in (* *[uint64 *](rp + 24) *)
let            z4 :=  14 in (* *[uint64 *](rp + 32) *)
let         carry := 999 in
let           tmp := 998 in
let            r0 :=  20 in
let            r1 :=  21 in
let            r2 :=  22 in
let            r3 :=  23 in
let            r4 :=  24 in
let            c0 :=  30 in
let            c1 :=  31 in
let            c2 :=  32 in
let            c3 :=  33 in
let            c4 :=  34 in
let        mulr01 :=  40 in
let        mulr11 :=  41 in
let        mulr21 :=  42 in
let        mulr31 :=  43 in
let        mulr41 :=  44 in
let        mulrax :=  50 in
let        mulrdx :=  51 in
let          mult :=  52 in
let    mulredmask :=  53 in
let       mulx219 :=  54 in
let       mulx319 :=  55 in
let       mulx419 :=  56 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
zEqMod
  (radix51 [::zVar z0; zVar z1; zVar z2; zVar z3; zVar z4])
  (radix51 [::zVar r0; zVar r1; zVar r2; zVar r3; zVar r4])
  (zConst n25519).

Definition fe25519_mul_stage3_1_spec :=
  {| spre := fe25519_mul_stage3_1_pre;
     sprog := fe25519_mul_stage3_1;
     spost := fe25519_mul_stage3_1_post |}.

From mathcomp Require Import eqtype ssrbool.
From mQhasm Require Import zVerify.

Lemma valid_fe25519_mul_stage3_1 : valid_zspec (fe25519_mul_stage3_1_inputs, fe25519_mul_stage3_1_spec).
Proof.
  time "valid_fe25519_mul_stage3_1" verify_zspec.
Qed.

Close Scope zdsl_scope.
Close Scope N_scope.


Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Spec.CompleteEdwardsCurve.
Require Import Crypto.Spec.EdDSA.

Require Crypto.Arithmetic.PrimeFieldTheorems. (* to know that Z mod p is a field *)
Require Crypto.Curves.Edwards.AffineProofs.

(* these 2 proofs can be generated using https://github.com/REDACTED-REDACTED/safecurves-primes *)
Axiom prime_q : Znumtheory.prime (2^255-19). Global Existing Instance prime_q.
Axiom prime_l : Znumtheory.prime (2^252 + 27742317777372353535851937790883648493). Global Existing Instance prime_l.

Section Ed25519.

  Local Open Scope Z_scope.

  Definition q : BinPos.positive := 2^255 - 19.
  Definition Fq : Type := F q.

  Definition l : BinPos.positive := 2^252 + 27742317777372353535851937790883648493.
  Definition Fl : Type := F l.

  Local Open Scope F_scope.

  Definition a : Fq := F.opp 1.
  Definition d : Fq := F.opp (F.of_Z _ 121665) / (F.of_Z _ 121666).

  Local Open Scope nat_scope.

  Definition b : nat := 256.
  Definition n : nat := b - 2.
  Definition c : nat := 3.

  Context {SHA512: forall n : nat, Word.word n -> Word.word 512}.

  Local Instance char_gt_e :
    @Ring.char_ge (@F q) eq F.zero F.one F.opp F.add F.sub F.mul
                  (BinNat.N.succ_pos BinNat.N.two).
  Proof. eapply Hierarchy.char_ge_weaken;
           [apply (_:Ring.char_ge q)|Decidable.vm_decide]. Qed.

  Definition E : Type := E.point
                           (F:=Fq) (Feq:=Logic.eq) (Fone:=F.one) (Fadd:=F.add) (Fmul:=F.mul)
                           (a:=a) (d:=d).

  Local Obligation Tactic := Decidable.vm_decide. (* to prove that B is on curve *)

  Program Definition B : E :=
    (F.of_Z q 15112221349535400772501151409588531511454012693041857206046113283949847762202,
     F.of_Z q 4 / F.of_Z q 5).

  Local Infix "++" := Word.combine.
  Local Notation bit b := (Word.WS b Word.WO : Word.word 1).

  Definition Fencode {len} {m} : F m -> Word.word len :=
    fun x : F m => (Word.NToWord _ (BinIntDef.Z.to_N (F.to_Z x))).
  Definition sign (x : F q) : bool := BinIntDef.Z.testbit (F.to_Z x) 0.
  Definition Eenc : E -> Word.word b := fun P =>
    let '(x,y) := E.coordinates P in Fencode (len:=b-1) y ++ bit (sign x).
  Definition Senc : Fl -> Word.word b := Fencode (len:=b).

  Lemma nonzero_a : a <> 0%F.
  Proof using Type. Crypto.Util.Decidable.vm_decide. Qed.
  Lemma square_a : exists sqrt_a : Fq, (sqrt_a * sqrt_a)%F = a.
  Proof using Type. pose (@PrimeFieldTheorems.F.Decidable_square q _ ltac:(Crypto.Util.Decidable.vm_decide) a); Crypto.Util.Decidable.vm_decide. Qed.
  Lemma nonsquare_d : forall x : Fq, (x * x)%F <> d.
  Proof using Type. pose (@PrimeFieldTheorems.F.Decidable_square q _ ltac:(Crypto.Util.Decidable.vm_decide) d); Crypto.Util.Decidable.vm_decide. Qed.

  Let add := E.add(nonzero_a:=nonzero_a)(square_a:=square_a)(nonsquare_d:=nonsquare_d).
  Let zero := E.zero(nonzero_a:=nonzero_a)(d:=d).
  (* TODO: move scalarmult_ref to Spec? *)
  Let mul := ScalarMult.scalarmult_ref(zero:=zero)(add:=add)(opp:=AffineProofs.E.opp(nonzero_a:=nonzero_a)).

  Definition ed25519 (l_order_B: (mul l B = zero)%E) :
    EdDSA (E:=E) (Eadd:=add) (Ezero:=zero) (ZEmul:=mul) (B:=B)
          (Eopp:=Crypto.Curves.Edwards.AffineProofs.E.opp(nonzero_a:=nonzero_a)) (* TODO: move defn *)
          (Eeq:=E.eq) (* TODO: move defn *)
          (l:=l) (b:=b) (n:=n) (c:=c)
          (Eenc:=Eenc) (Senc:=Senc) (H:=SHA512).
  Proof using Type.
    split; try exact _.
    Crypto.Util.Decidable.vm_decide.
    Crypto.Util.Decidable.vm_decide.
    Crypto.Util.Decidable.vm_decide.
    Crypto.Util.Decidable.vm_decide.
    Crypto.Util.Decidable.vm_decide.
    exact l_order_B.
  Qed.
End Ed25519.


(* -*- mode: coq; mode: visual-line -*- *)
(** * Theorems about the universe, including the Univalence Axiom. *)

Require Import HoTT.Basics.
Require Import Types.Sigma Types.Forall Types.Arrow Types.Paths Types.Equiv Types.Bool Types.Prod.

Local Open Scope path_scope.

Generalizable Variables A B f.

(** ** Paths *)

Global Instance isequiv_path {A B : Type} (p : A = B)
  : IsEquiv (transport (fun X:Type => X) p) | 0
  := Build_IsEquiv _ _ _ (transport (fun X:Type => X) p^)
  (transport_pV idmap p)
  (transport_Vp idmap p)
  (fun a => match p in _ = C return
              (transport_pp idmap p^ p (transport idmap p a))^ @
                 transport2 idmap (concat_Vp p) (transport idmap p a) =
              ap (transport idmap p) ((transport_pp idmap p p^ a) ^ @
                transport2 idmap (concat_pV p) a) with idpath => 1 end).

Definition equiv_path (A B : Type) (p : A = B) : A <~> B
  := Build_Equiv _ _ (transport (fun X:Type => X) p) _.

Definition equiv_path_V `{Funext} (A B : Type) (p : A = B) :
  equiv_path B A (p^) = (equiv_path A B p)^-1%equiv.
Proof.
  destruct p. simpl. unfold equiv_path, equiv_inverse. simpl. apply ap.
  refine (@path_ishprop _ (hprop_isequiv _) _ _).
Defined.

(** See the note by [Funext] in Overture.v *)
Monomorphic Axiom Univalence : Type0.
Existing Class Univalence.
Axiom isequiv_equiv_path : forall `{Univalence} (A B : Type), IsEquiv (equiv_path A B).
Global Existing Instance isequiv_equiv_path.

Section Univalence.
Context `{Univalence}.

Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B
  := (equiv_path A B)^-1 f.

Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B)
  := path_universe_uncurried (Build_Equiv _ _ f feq).

Global Arguments path_universe {A B}%type_scope f%function_scope {feq}.

Definition eta_path_universe {A B : Type} (p : A = B)
  : path_universe (equiv_path A B p) = p
  := eissect (equiv_path A B) p.

Definition eta_path_universe_uncurried {A B : Type} (p : A = B)
  : path_universe_uncurried (equiv_path A B p) = p
  := eissect (equiv_path A B) p.

Definition isequiv_path_universe {A B : Type}
  : IsEquiv (@path_universe_uncurried A B)
 := _.

Definition equiv_path_universe (A B : Type) : (A <~> B) <~> (A = B)
  := Build_Equiv _ _ (@path_universe_uncurried A B) isequiv_path_universe.

Definition equiv_equiv_path  (A B : Type) : (A = B) <~> (A <~> B)
  := (equiv_path_universe A B)^-1%equiv.

(** These operations have too many names, making [rewrite] a pain.  So we give lots of names to the computation laws. *)
Definition path_universe_equiv_path {A B : Type} (p : A = B)
  : path_universe (equiv_path A B p) = p
  := eissect (equiv_path A B) p.
Definition path_universe_uncurried_equiv_path {A B : Type} (p : A = B)
  : path_universe_uncurried (equiv_path A B p) = p
  := eissect (equiv_path A B) p.
Definition path_universe_transport_idmap {A B : Type} (p : A = B)
  : path_universe (transport idmap p) = p
  := eissect (equiv_path A B) p.
Definition path_universe_uncurried_transport_idmap {A B : Type} (p : A = B)
  : path_universe_uncurried (equiv_transport idmap A B p) = p
  := eissect (equiv_path A B) p.
Definition equiv_path_path_universe {A B : Type} (f : A <~> B)
  : equiv_path A B (path_universe f) = f
  := eisretr (equiv_path A B) f.
Definition equiv_path_path_universe_uncurried {A B : Type} (f : A <~> B)
  : equiv_path A B (path_universe_uncurried f) = f
  := eisretr (equiv_path A B) f.
Definition transport_idmap_path_universe {A B : Type} (f : A <~> B)
  : transport idmap (path_universe f) = f
  := ap equiv_fun (eisretr (equiv_path A B) f).
Definition transport_idmap_path_universe_uncurried {A B : Type} (f : A <~> B)
  : transport idmap (path_universe_uncurried f) = f
  := ap equiv_fun (eisretr (equiv_path A B) f).

(** ** Behavior on path operations *)

Definition equiv_path_pp `{Funext} {A B C : Type} (p : A = B) (q : B = C)
: equiv_path A C (p @ q) = equiv_path B C q oE equiv_path A B p.
Proof.
  destruct p, q. simpl.
  apply path_equiv, path_arrow.
  intros x; reflexivity.
Defined.

Definition path_universe_compose_uncurried `{Funext} {A B C : Type}
           (f : A <~> B) (g : B <~> C)
: path_universe_uncurried (equiv_compose g f)
= path_universe_uncurried f @ path_universe_uncurried g.
Proof.
  revert f. equiv_intro (equiv_path A B) f.
  revert g. equiv_intro (equiv_path B C) g.
  refine ((ap path_universe_uncurried (equiv_path_pp f g))^ @ _).
  refine (eta_path_universe (f @ g) @ _).
  apply concat2; symmetry; apply eta_path_universe.
Defined.

Definition path_universe_compose `{Funext} {A B C : Type}
           (f : A <~> B) (g : B <~> C)
: path_universe (g o f) = path_universe f @ path_universe g.
Proof.
  revert f. equiv_intro (equiv_path A B) f.
  revert g. equiv_intro (equiv_path B C) g.
  refine ((ap path_universe_uncurried (equiv_path_pp f g))^ @ _).
  refine (eta_path_universe (f @ g) @ _).
  apply concat2; symmetry; apply eta_path_universe.
Defined.

Definition path_universe_1 {A : Type}
: path_universe (equiv_idmap A) = 1
  := eta_path_universe 1.

Definition path_universe_V_uncurried `{Funext} {A B : Type} (f : A <~> B)
  : path_universe_uncurried f^-1 = (path_universe_uncurried f)^.
Proof.
  revert f. equiv_intro ((equiv_path_universe A B)^-1) p. simpl.
  transitivity (p^).
    2: exact (inverse2 (eisretr (equiv_path_universe A B) p)^).
  transitivity (path_universe_uncurried (equiv_path B A p^)).
  - by refine (ap _ (equiv_path_V A B p)^).
  - by refine (eissect (equiv_path B A) p^).
Defined.

Definition path_universe_V `{Funext} `(f : A -> B) `{IsEquiv A B f}
  : path_universe (f^-1) = (path_universe f)^
  := path_universe_V_uncurried (Build_Equiv A B f _).

(** ** Path operations vs Type operations *)

(** [ap (Equiv A)] behaves like postcomposition. *)
Definition ap_equiv_path_universe `{Funext} A {B C} (f : B <~> C)
: equiv_path (A <~> B) (A <~> C) (ap (Equiv A) (path_universe f))
  = equiv_functor_equiv (equiv_idmap A) f.
Proof.
  revert f. equiv_intro (equiv_path B C) f.
  rewrite (eissect (equiv_path B C) f : path_universe (equiv_path B C f) = f).
  destruct f; simpl.
  apply path_equiv, path_forall; intros g.
  apply path_equiv, path_forall; intros a.
  reflexivity.
Defined.

(** [ap (prod A)] behaves like [equiv_functor_prod_l]. *)
Definition ap_prod_l_path_universe `{Funext} A {B C} (f : B <~> C)
  : equiv_path (A * B) (A * C) (ap (prod A) (path_universe f))
    = equiv_functor_prod_l f.
Proof.
  revert f. equiv_intro (equiv_path B C) f.
  rewrite (eissect (equiv_path B C) f : path_universe (equiv_path B C f) = f).
  destruct f.
  apply path_equiv, path_arrow; intros x; reflexivity.
Defined.

(** [ap (fun Z => Z * A)] behaves like [equiv_functor_prod_r]. *)
Definition ap_prod_r_path_universe `{Funext} A {B C} (f : B <~> C)
  : equiv_path (B * A) (C * A) (ap (fun Z => Z * A) (path_universe f))
    = equiv_functor_prod_r f.
Proof.
  revert f. equiv_intro (equiv_path B C) f.
  rewrite (eissect (equiv_path B C) f : path_universe (equiv_path B C f) = f).
  destruct f.
  apply path_equiv, path_arrow; intros x; reflexivity.
Defined.

(** ** Transport *)

(** There are two ways we could define [transport_path_universe]: we could give an explicit definition, or we could reduce it to paths by [equiv_ind] and give an explicit definition there.  The two should be equivalent, but we choose the second for now as it makes the currently needed coherence lemmas easier to prove. *)
Definition transport_path_universe_uncurried
           {A B : Type} (f : A <~> B) (z : A)
  : transport (fun X:Type => X) (path_universe_uncurried f) z = f z.
Proof.
  revert f.  equiv_intro (equiv_path A B) p.
  exact (ap (fun s => transport idmap s z) (eissect _ p)).
Defined.

Definition transport_path_universe
           {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A)
  : transport (fun X:Type => X) (path_universe f) z = f z
  := transport_path_universe_uncurried (Build_Equiv A B f feq) z.
(* Alternatively, [ap10_equiv (eisretr (equiv_path A B) (Build_Equiv _ _ f feq)) z]. *)

Definition transport_path_universe_equiv_path
           {A B : Type} (p : A = B) (z : A)
  : transport_path_universe (equiv_path A B p) z =
    (ap (fun s => transport idmap s z) (eissect _ p))
  := equiv_ind_comp _ _ _.

(* This somewhat fancier version is useful when working with HITs. *)
Definition transport_path_universe'
  {A : Type} (P : A -> Type) {x y : A} (p : x = y)
  (f : P x <~> P y) (q : ap P p = path_universe f) (u : P x)
  : transport P p u = f u
  := transport_compose idmap P p u
   @ ap10 (ap (transport idmap) q) u
   @ transport_path_universe f u.

(** And a version for transporting backwards. *)

Definition transport_path_universe_V_uncurried `{Funext}
           {A B : Type} (f : A <~> B) (z : B)
  : transport (fun X:Type => X) (path_universe_uncurried f)^ z = f^-1 z.
Proof.
  revert f. equiv_intro (equiv_path A B) p.
  exact (ap (fun s => transport idmap s z) (inverse2 (eissect _ p))).
Defined.

Definition transport_path_universe_V `{Funext}
           {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : B)
  : transport (fun X:Type => X) (path_universe f)^ z = f^-1 z
  := transport_path_universe_V_uncurried (Build_Equiv _ _ f feq) z.
(* Alternatively, [(transport2 idmap (path_universe_V f) z)^ @ (transport_path_universe (f^-1) z)]. *)

Definition transport_path_universe_V_equiv_path `{Funext}
           {A B : Type} (p : A = B) (z : B)
  : transport_path_universe_V (equiv_path A B p) z =
    ap (fun s => transport idmap s z) (inverse2 (eissect _ p))
  := equiv_ind_comp _ _ _.

(** And some coherence for it. *)

Definition transport_path_universe_Vp_uncurried `{Funext}
           {A B : Type} (f : A <~> B) (z : A)
: ap (transport idmap (path_universe f)^) (transport_path_universe f z)
  @ transport_path_universe_V f (f z)
  @ eissect f z
  = transport_Vp idmap (path_universe f) z.
Proof.
  pattern f.
  refine (equiv_ind (equiv_path A B) _ _ _); intros p.
  (* Something slightly sneaky happens here: by definition of [equiv_path], [eissect (equiv_path A B p)] is judgmentally equal to [transport_Vp idmap p].  Thus, we can apply [ap_transport_Vp_idmap]. *)
  refine (_ @ ap_transport_Vp_idmap p (path_universe (equiv_path A B p))
            (eissect (equiv_path A B) p) z).
  apply whiskerR. apply concat2.
  - apply ap. apply transport_path_universe_equiv_path.
  - apply transport_path_universe_V_equiv_path.
Defined.

Definition transport_path_universe_Vp `{Funext}
           {A B : Type} (f : A -> B) {feq : IsEquiv f} (z : A)
: ap (transport idmap (path_universe f)^) (transport_path_universe f z)
  @ transport_path_universe_V f (f z)
  @ eissect f z
  = transport_Vp idmap (path_universe f) z
:= transport_path_universe_Vp_uncurried (Build_Equiv A B f feq) z.

(** ** 2-paths *)

Definition equiv_path2_universe `{Funext}
           {A B : Type} (f g : A <~> B)
: (f == g) <~> (path_universe f = path_universe g).
Proof.
  refine (_ oE equiv_path_arrow f g).
  refine (_ oE equiv_path_equiv f g).
  exact (equiv_ap (equiv_path A B)^-1 _ _).
Defined.

Definition path2_universe `{Funext}
           {A B : Type} {f g : A <~> B}
: (f == g) -> (path_universe f = path_universe g)
  := equiv_path2_universe f g.

Definition equiv_path2_universe_1 `{Funext}
           {A B : Type} (f : A <~> B)
: equiv_path2_universe f f (fun x => 1) = 1.
Proof.
  simpl.
  rewrite concat_1p, concat_p1, path_forall_1, path_sigma_hprop_1.
  reflexivity.
Qed.

Definition path2_universe_1 `{Funext}
           {A B : Type} (f : A <~> B)
: @path2_universe _ _ _ f f (fun x => 1) = 1
  := equiv_path2_universe_1 f.

(** There ought to be a lemma which says something like this:

<<
Definition path2_universe_postcompose `{Funext}
           {A B C : Type} {f1 f2 : A <~> B} (p : f1 == f2)
           (g : B <~> C)
: equiv_path2_universe (g o f1)
                       (g o f2)
                       (fun a => ap g (p a))
  = path_universe_compose f1 g
    @ whiskerR (path2_universe p) (path_universe g)
    @ (path_universe_compose f2 g)^.
>>

and similarly

<<
Definition path2_universe_precompose `{Funext}
           {A B C : Type} {f1 f2 : B <~> C} (p : f1 == f2)
           (g : A <~> B)
: equiv_path2_universe (f1 o g)
                       (f2 o g)
                       (fun a => (p (g a)))
  = path_universe_compose g f1
    @ whiskerL (path_universe g) (path2_universe p)
    @ (path_universe_compose g f2)^.
>>

but I haven't managed to prove them yet.  Fortunately, for existing applications what we actually need is the following rather different-looking version that applies only when [f1] and [f2] are identities. *)

(** Coq is too eager about unfolding [equiv_path_equiv] in the following proofs, so we tell it not to.  We go into a section in order to limit the scope of the [simpl never] command. *)
Section PathEquivSimplNever.
  Local Arguments equiv_path_equiv : simpl never.

  Definition path2_universe_postcompose_idmap `{Funext}
             {A C : Type} (p : forall a:A, a = a)
             (g : A <~> C)
  : equiv_path2_universe g g (fun a => ap g (p a))
    = (concat_1p _)^
      @ whiskerR (path_universe_1)^ (path_universe g)
      @ whiskerR (equiv_path2_universe (equiv_idmap A) (equiv_idmap A) p)
        (path_universe g)
      @ whiskerR path_universe_1 (path_universe g)
      @ concat_1p _.
  Proof.
    transitivity ((eta_path_universe (path_universe g))^
                  @ equiv_path2_universe
                    (equiv_path A C (path_universe g))
                    (equiv_path A C (path_universe g))
                    (fun a => ap (equiv_path A C (path_universe g)) (p a))
                    @ eta_path_universe (path_universe g)).
    - refine ((apD (fun g' => equiv_path2_universe g' g'
                                (fun a => ap g' (p a)))
                   (eisretr (equiv_path A C) g))^ @ _).
      refine (transport_paths_FlFr (eisretr (equiv_path A C) g) _ @ _).
      apply concat2.
      + apply whiskerR.
        apply inverse2, symmetry.
        refine (eisadj (equiv_path A C)^-1 g).
      + symmetry; refine (eisadj (equiv_path A C)^-1 g).
    - generalize (path_universe g).
      intros h. destruct h. cbn.
      rewrite !concat_1p, !concat_p1.
      refine (_ @ whiskerR (whiskerR_pp 1 path_universe_1^ _) _).
      refine (_ @ whiskerR_pp 1 _ path_universe_1).
      refine (_ @ (whiskerR_p1_1 _)^).
      apply whiskerR, whiskerL, ap, ap, ap.
      apply path_forall; intros x; apply ap_idmap.
  Defined.

  Definition path2_universe_precompose_idmap `{Funext}
             {A B : Type} (p : forall b:B, b = b)
             (g : A <~> B)
  : equiv_path2_universe g g (fun a => (p (g a)))
    = (concat_p1 _)^
      @ whiskerL (path_universe g) (path_universe_1)^
      @ whiskerL (path_universe g)
          (equiv_path2_universe (equiv_idmap B) (equiv_idmap B) p)
      @ whiskerL (path_universe g) (path_universe_1)
      @ concat_p1 _.
  Proof.
  transitivity ((eta_path_universe (path_universe g))^
                @ equiv_path2_universe
                  (equiv_path A B (path_universe g))
                  (equiv_path A B (path_universe g))
                  (fun a => p (equiv_path A B (path_universe g) a))
                @ eta_path_universe (path_universe g)).
  - refine ((apD (fun g' => equiv_path2_universe g' g'
                              (fun a => p (g' a)))
              (eisretr (equiv_path A B) g))^ @ _).
    refine (transport_paths_FlFr (eisretr (equiv_path A B) g) _ @ _).
    apply concat2.
    + apply whiskerR.
      apply inverse2, symmetry.
      refine (eisadj (equiv_path A B)^-1 g).
    + symmetry; refine (eisadj (equiv_path A B)^-1 g).
  - generalize (path_universe g).
    intros h. destruct h. cbn.
    rewrite !concat_p1.
    refine (_ @ (((concat_1p (whiskerL 1 path_universe_1^))^ @@ 1) @@ 1)).
    refine (_ @ whiskerR (whiskerL_pp 1 path_universe_1^ _) _).
    refine (_ @ whiskerL_pp 1 _ path_universe_1).
    exact ((whiskerL_1p_1 _)^).
  Defined.

End PathEquivSimplNever.

(** ** 3-paths *)

Definition equiv_path3_universe `{Funext}
           {A B : Type} {f g : A <~> B} (p q : f == g)
: (p == q) <~> (path2_universe p = path2_universe q).
Proof.
  refine (_ oE equiv_path_forall p q).
  refine (_ oE equiv_ap (equiv_path_arrow f g) p q).
  refine (_ oE equiv_ap (equiv_path_equiv f g) _ _).
  unfold path2_universe, equiv_path2_universe.
  simpl. refine (equiv_ap (ap (equiv_path A B)^-1) _ _).
Defined.

Definition path3_universe `{Funext}
           {A B : Type} {f g : A <~> B} {p q : f == g}
: (p == q) -> (path2_universe p = path2_universe q)
  := equiv_path3_universe p q.

Definition transport_path_universe_pV_uncurried `{Funext}
           {A B : Type} (f : A <~> B) (z : B)
: transport_path_universe f (transport idmap (path_universe f)^ z)
  @ ap f (transport_path_universe_V f z)
  @ eisretr f z
  = transport_pV idmap (path_universe f) z.
Proof.
  pattern f.
  refine (equiv_ind (equiv_path A B) _ _ _); intros p.
  refine (_ @ ap_transport_pV_idmap p (path_universe (equiv_path A B p))
            (eissect (equiv_path A B) p) z).
  apply whiskerR.
  refine ((concat_Ap _ _)^ @ _).
  apply concat2.
  - apply ap.
    refine (transport_path_universe_V_equiv_path _ _ @ _).
    unfold inverse2. symmetry; apply (ap_compose inverse (fun s => transport idmap s z)).
  - apply transport_path_universe_equiv_path.
Defined.

Definition transport_path_universe_pV `{Funext}
           {A B : Type} (f : A -> B) {feq : IsEquiv f } (z : B)
: transport_path_universe f (transport idmap (path_universe f)^ z)
  @ ap f (transport_path_universe_V f z)
  @ eisretr f z
  = transport_pV idmap (path_universe f) z
:= transport_path_universe_pV_uncurried (Build_Equiv A B f feq) z.

(** ** Equivalence induction *)

(** Paulin-Mohring style *)
Theorem equiv_induction {U : Type} (P : forall V, U <~> V -> Type) :
  (P U (equiv_idmap U)) -> (forall V (w : U <~> V), P V w).
Proof.
  intros H0 V.
  apply (equiv_ind (equiv_path U V)).
  intro p; induction p; exact H0.
Defined.

Definition equiv_induction_comp {U : Type} (P : forall V, U <~> V -> Type)
  (didmap : P U (equiv_idmap U))
  : equiv_induction P didmap U (equiv_idmap U) = didmap
  := (equiv_ind_comp (P U) _ 1).

(** Martin-Lof style *)
Theorem equiv_induction' (P : forall U V, U <~> V -> Type) :
  (forall T, P T T (equiv_idmap T)) -> (forall U V (w : U <~> V), P U V w).
Proof.
  intros H0 U V w.
  apply (equiv_ind (equiv_path U V)).
  intro p; induction p; apply H0.
Defined.

Definition equiv_induction'_comp (P : forall U V, U <~> V -> Type)
  (didmap : forall T, P T T (equiv_idmap T)) (U : Type)
  : equiv_induction' P didmap U U (equiv_idmap U) = didmap U
  := (equiv_ind_comp (P U U) _ 1).

Theorem equiv_induction_inv {U : Type} (P : forall V, V <~> U -> Type) :
  (P U (equiv_idmap U)) -> (forall V (w : V <~> U), P V w).
Proof.
  intros H0 V.
  apply (equiv_ind (equiv_path V U)).
  intro p; induction p; apply H0.
Defined.

Definition equiv_induction_inv_comp {U : Type} (P : forall V, V <~> U -> Type)
  (didmap : P U (equiv_idmap U))
  : equiv_induction_inv P didmap U (equiv_idmap U) = didmap
  := (equiv_ind_comp (P U) _ 1).

(** ** Based equivalence types *)

Global Instance contr_basedequiv {X : Type}
: Contr {Y : Type & X <~> Y}.
Proof.
  exists (X; equiv_idmap).
  intros [Y f]; revert Y f.
  exact (equiv_induction _ idpath).
Defined.

Global Instance contr_basedequiv' {X : Type}
: Contr {Y : Type & Y <~> X}.
Proof.
  (* The next line is used so that Coq can figure out the type of (X; equiv_idmap). *)
  serapply Build_Contr.
  - exact (X; equiv_idmap).
  - intros [Y f]; revert Y f.
    refine (equiv_induction_inv _ idpath).
Defined.

(** ** Truncations *)

(** Truncatedness of the universe is a subtle question, but with univalence we can conclude things about truncations of certain of its path-spaces. *)
Global Instance istrunc_paths_Type `{Funext}
       {n : trunc_index} {A B : Type} `{IsTrunc n.+1 B}
: IsTrunc n.+1 (A = B).
Proof.
  refine (trunc_equiv _ path_universe_uncurried).
Defined.

(** We can also say easily that the universe is not a set. *)
Definition not_hset_Type : ~ (IsHSet Type).
Proof.
  intro HT.
  apply true_ne_false.
  pose (r := path_ishprop (path_universe equiv_negb) 1).
  refine (_ @ (ap (fun q => transport idmap q false) r)).
  symmetry; apply transport_path_universe.
Defined.

End Univalence.