(** Autosubst Header for Scoped Syntax
    Our development utilises well-scoped de Bruijn syntax. This means that the de Bruijn indices are taken from finite types. As a consequence, any kind of substitution or environment used in conjunction with well-scoped syntax takes the form of a mapping from some finite type _I^n_. In particular, _renamings_ are mappings _I^n -> I^m_. Here we develop the theory of how these parts interact.

Version: December 11, 2019.
*)
Require Export axioms.
Set Implicit Arguments.
Unset Strict Implicit.

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition apc {X Y} {f g : X -> Y} {x y : X} (p : f = g) (q : x = y) : f x = g y :=
  match q with eq_refl => match p with eq_refl => eq_refl end end.

(** Primitives of the Sigma Calculus
    We implement the finite type with _n_ elements, _I^n_, as the _n_-fold iteration of the Option Type. _I^0_ is implemented as the empty type.
*)

Fixpoint fin (n : nat) : Type :=
  match n with
  | 0 => False
  | S m => option (fin m)
  end.

(** Renamings and Injective Renamings
     _Renamings_ are mappings between finite types.
*)
Definition ren (m n : nat) : Type := fin m -> fin n.

Definition id {X} (x : X) := x.

Definition idren {k: nat} : ren k k :=
  fun x => x.

(** We give a special name, to the newest element in a non-empty finite type, as it usually corresponds to a freshly bound variable. *)
Definition var_zero {n : nat} : fin (S n) := None.

Definition null {T} (i : fin 0) : T := match i with end.

Definition shift {n : nat} : ren n (S n) :=
  Some.

Definition comp := @funcomp.

(** Extension of Finite Mappings
    Assume we are given a mapping _f_ from _I^n_ to some type _X_, then we can _extend_ this mapping with a new value from _x : X_ to a mapping from _I^n+1_ to _X_. We denote this operation by _x . f_ and define it as follows:
*)
Definition scons {X : Type} {n : nat} (x : X) (f : fin n -> X) (m : fin (S n)) : X :=
  match m with
  | None => x
  | Some i => f i
  end.

(** Type Class Instances for Notation *)

(**** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Notation "s ⟨ xi1 ⟩" := (ren1  xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.

(**** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.

(** Type Class for Variables *)
Class Var X Y :=
  ids : X -> Y.

(** Proofs for substitution primitives *)

(** Forward Function Composition
    Substitutions represented as functions are ubiquitious in this development and we often have to compose them, without talking about their pointwise behaviour.
    That is, we are interested in the forward compostion of functions, _f o g_, for which we introduce a convenient notation, "f >> g". The direction of the arrow serves as a reminder of the _forward_ nature of this composition, that is first apply _f_, then _g_. *)

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Notation "f >> g" := (funcomp g f) (at level 50).
Open Scope subst_scope.

Notation "x .: f" := (@scons _ _ x f) (at level 55) : subst_scope.

(** Generic lifting operation for renamings *)
Definition up_ren m n (xi : ren m n) : ren (S m) (S n) :=
  var_zero .: xi >> shift.

(** Generic proof that lifting of renamings composes. *)
Lemma up_ren_ren k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [x|].
  - simpl. unfold funcomp. now rewrite <- E.
  - reflexivity.
Qed.

Arguments up_ren_ren {k l m} xi zeta rho E.

Lemma scons_eta {T} {n : nat} (f : fin (S n) -> T) :
  f var_zero .: shift >> f = f.
Proof. fext. intros [x|]; reflexivity.  Qed.

Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (fin (S n) -> fin (S n)).
Proof. fext. intros [x|]; reflexivity. Qed.

Lemma scons_comp (T: Type) U {m} (s: T) (sigma: fin m -> T) (tau: T -> U ) :
  (s .: sigma) >> tau = (tau s) .: (sigma >> tau) .
Proof.
  fext. intros [x|]. reflexivity. simpl. reflexivity.
Qed.

Lemma fin_eta {X} (f g : fin 0 -> X) :
  forall x, f x = g x.
Proof. intros []. Qed.

(** Variadic Substitution Primitives *)

Fixpoint shift_p (p : nat) {n} : ren n (p + n) :=
  fun n => match p with
        | 0 => n
        | S p => Some (shift_p p n)
        end.

Fixpoint scons_p {X: Type} {m : nat} : forall {n} (f : fin m -> X) (g : fin n -> X), fin (m + n)  -> X.
Proof.
  destruct m.
  - intros n f g. exact g.
  - intros n f g. cbn. apply scons.
    + exact (f var_zero).
    + apply scons_p.
      * intros z. exact (f (Some z)).
      * exact g.
Defined.

Definition zero_p {m : nat} {n} : fin m -> fin (m + n).
Proof.
  induction m.
  - intros [].
  - intros [x|].
    + exact (shift_p 1 (IHm x)).
    + exact var_zero.
Defined.

Lemma scons_p_head' {X} {m n} (f : fin m -> X) (g : fin n -> X) z:
  (scons_p  f g) (zero_p  z) = f z.
Proof.
 induction m.
  - inversion z.
  - destruct z.
    + simpl. simpl. now rewrite IHm.
    + reflexivity.
Qed.

Lemma scons_p_head X m n (f : fin m -> X) (g : fin n -> X) :
  (zero_p  >> scons_p f g) = f.
Proof. fext. intros z. unfold funcomp. apply scons_p_head'. Qed.

Lemma scons_p_tail' X  m n (f : fin m -> X) (g : fin n -> X) z :
  scons_p  f g (shift_p m z) = g z.
Proof. induction m; cbn; eauto. Qed.

Lemma scons_p_tail X  m n (f : fin m -> X) (g : fin n -> X) :
  shift_p m  >> scons_p f g = g.
Proof. fext. intros z. unfold funcomp. apply scons_p_tail'. Qed.

Lemma destruct_fin {m n} (x : fin (m + n)):
  (exists x', x = zero_p  x') \/ exists x', x = shift_p m x'.
Proof.
  induction m; simpl in *.
  - right. eauto.
  - destruct x as [x|].
    + destruct (IHm x) as [[x' ->] |[x' ->]].
      * left. now exists (Some x').
      * right. eauto.
    + left. exists None. eauto.
Qed.

Lemma scons_p_comp' X Y m n (f : fin m -> X) (g : fin n -> X) (h : X -> Y) x:
 h (scons_p  f g x)  = scons_p (f >> h) (g >> h) x.
Proof.
  destruct (destruct_fin x) as [[x' ->]|[x' ->]].
  - now rewrite !scons_p_head'.
  - now rewrite !scons_p_tail'.
Qed.

Lemma scons_p_comp {X Y m n} {f : fin m -> X} {g : fin n -> X} {h : X -> Y} :
  (scons_p f g) >> h = scons_p   (f >> h) (g >> h).
Proof. fext. intros z. unfold funcomp. apply scons_p_comp'. Qed.

Lemma scons_p_congr {X} {m n} (f f' : fin m -> X) (g g': fin n -> X) z:
  (forall x, f x = f' x) -> (forall x, g x = g' x) -> scons_p f g z = scons_p f' g' z.
Proof. intros H1 H2. induction m; eauto. cbn. destruct z; eauto. Qed.

(** Generic n-ary lifting operation. *)
Definition upRen_p p { m : nat } { n : nat } (xi : (fin) (m) -> (fin) (n)) : fin (p + m) -> fin (p + n)  :=
   scons_p  (zero_p ) (xi >> shift_p _).

Arguments upRen_p p {m n} xi.

(** Generic proof for composition of n-ary lifting. *)
Lemma up_ren_ren_p p k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (upRen_p p xi >> upRen_p p zeta) x = upRen_p p rho x.
Proof.
  intros x. destruct (destruct_fin x) as [[? ->]|[? ->]].
  - unfold upRen_p. unfold funcomp. now repeat rewrite scons_p_head'.
  - unfold upRen_p. unfold funcomp. repeat rewrite scons_p_tail'.
    now rewrite <- E.
Qed.

Arguments zero_p m {n}.
Arguments scons_p  {X} m {n} f g.

Lemma scons_p_eta {X} {m n} {f : fin m -> X}
      {g : fin n -> X} (h: fin (m + n) -> X) {z: fin (m + n)}:
  (forall x, g x = h (shift_p m x)) -> (forall x, f x = h (zero_p m x)) -> scons_p m f g z = h z.
Proof.
  intros H1 H2. destruct (destruct_fin z) as [[? ->] |[? ->]].
  - rewrite scons_p_head'. eauto.
  - rewrite scons_p_tail'. eauto.
Qed.

Arguments scons_p_eta {X} {m n} {f g} h {z}.
Arguments scons_p_congr {X} {m n} {f f'} {g g'} {z}.

Opaque scons.
Opaque var_zero.
Opaque null.
Opaque shift.
Opaque up_ren.
Opaque var_zero.
Opaque idren.
Opaque comp.
Opaque funcomp.
Opaque id.

(** Notations for Scoped Syntax *)

Module CommaNotation.
Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope.
End CommaNotation.

Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.

Notation "↑" := (shift) : subst_scope.

Ltac unfold_funcomp := match goal with
                           | |-  context[(?f >> ?g) ?s] => change ((f >> g) s) with (g (f s))
                           end.

(** Tactics for Scoped Syntax *)

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[comp ?f ?g]] => change (comp f g) with (g >> f) (* AsimplCompIdL *)
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h)) (* AsimplComp *)

         | [|- zero_p >> scons_p ?f ?g] => rewrite scons_p_head

         | [|- context[(?s.:?sigma) var_zero]] => change ((s.:sigma) var_zero) with s
         | [|- context[(?s.:?sigma) (shift ?m)]] => change ((s.:sigma) (shift m)) with (sigma m)

         | [|- context[idren >> ?f]] => change (idren >> f) with f
         | [|- context[?f >> idren]] => change (f >> idren) with f
         | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g
         | [|- context[?x2 .: shift >> ?f]] => change x2 with (f var_zero); rewrite (@scons_eta _ _ f)
         | [|- context[?f var_zero .: ?g]] => change g with (shift >> f); rewrite scons_eta

         |[|- _ =  ?h (?f ?s)] => change (h (f s)) with ((f >> h) s)
         |[|-  ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s)

         | _ => first [progress (rewrite scons_comp) |  progress (rewrite scons_eta_id) | progress (autorewrite with FunctorInstances)]
         end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  repeat match goal with
         | [H: context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id]|- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s]|- _] => change (id s) with s in H
         | [H: context[comp ?f ?g]|- _] => change (comp f g) with (g >> f) in H (* AsimplCompIdL *)
         | [H: context[(?f >> ?g) >> ?h]|- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H (* AsimplComp *)
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) (shift ?m)]|- _] => change ((s.:sigma) (shift m)) with (sigma m) in H
                                                                                |[H : context[ _ =  ?h (?f ?s)]|- _] => change (h (f s)) with ((f >> h) s) in H
         |[H: context[?h (?f ?s) = _]|- _] => change (h (f s)) with ((f >> h) s) in H
         | [H: context[idren >> ?f]|- _] => change (idren >> f) with f in H
         | [H: context[?f >> idren]|- _] => change (f >> idren) with f in H
         | [H: context[?f >> (?x .: ?g)]|- _] =>
           change (f >> (x .: g)) with g in H
         | [H: context[?x2 .: shift >> ?f]|- _] =>
           change x2 with (f var_zero) in H; rewrite (@scons_eta _ _ f) in H
         | [H: context[?f var_zero .: ?g]|- _] =>
           change g with (shift >> f) in H; rewrite scons_eta in H
         | _ => first [progress (rewrite scons_comp in *) | progress (rewrite scons_eta_id in *) | progress (autorewrite with FunctorInstances in *)]
         end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : fin 0), _] => intros []; t
                                           | [|- forall (i : fin (S (S (S (S _))))), _] => intros [[[[|]|]|]|]; t
                                           | [|- forall (i : fin (S (S (S _)))), _] => intros [[[|]|]|]; t
                                           | [|- forall (i : fin (S (S _))), _] => intros [[?|]|]; t
                                           | [|- forall (i : fin (S _)), _] =>  intros [?|]; t
                                           end).

Hint Rewrite  @scons_p_comp scons_p_head scons_p_tail @scons_p_head' @scons_p_tail': FunctorInstances.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Return Preservation

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Dynamic_Semantics.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_WFC_Lemmas.
Require Export Cyclone_WFU_Lemmas.
Require Export Cyclone_Context_Weakening_Proof.
Require Export Cyclone_Substitutions_Proof.
Require Export Cyclone_LN_Types_Lemmas.
Require Export Cyclone_Get_Lemmas.
Require Export Cyclone_Admit_Environment.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma open_term_preserves_ret:
  forall s x,
    ret s ->
    forall n,
      ret (TM.open_rec_st n x s).
Proof.
  introv Rd.
  induction Rd; simpl; auto.
Qed.

Lemma open_type_preserves_ret:
  forall s x,
    ret s ->
    ret (TTM.open_rec_st 0 x s).
Proof.
  introv Rd.
  induction Rd; simpl; auto.
Qed.

Ltac inversion_complex_ret :=
 match goal with
  | H : ret (_ _) |- _ => inversions* H
  | H : ret (_ _ _) |- _ => inversions* H
  end.

Lemma A_8_Return_Preservation:
  forall s H H' s',
    ret s ->
    S H s H' s' ->
    ret s'.
Proof.
  introv Rs Sd.
  induction Sd; try solve[auto];
    try solve[inversion_complex_ret ; try inversion_complex_ret];
    try solve[inversion_complex_ret;
              try constructor;
              try applys* open_type_preserves_ret;
              try applys* open_term_preserves_ret].
Qed.


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

(*i $Id: DoubleCyclic.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.
Require Import DoubleAdd.
Require Import DoubleSub.
Require Import DoubleMul.
Require Import DoubleSqrt.
Require Import DoubleLift.
Require Import DoubleDivn1.
Require Import DoubleDiv.
Require Import CyclicAxioms.

Local Open Scope Z_scope.

Section Z_2nZ.

 Variable w : Type.
 Variable w_op : znz_op w.
 Let w_digits      := w_op.(znz_digits).
 Let w_zdigits      := w_op.(znz_zdigits).

 Let w_to_Z        := w_op.(znz_to_Z).
 Let w_of_pos      := w_op.(znz_of_pos).
 Let w_head0       := w_op.(znz_head0).
 Let w_tail0       := w_op.(znz_tail0).

 Let w_0            := w_op.(znz_0).
 Let w_1            := w_op.(znz_1).
 Let w_Bm1          := w_op.(znz_Bm1).

 Let w_compare     := w_op.(znz_compare).
 Let w_eq0         := w_op.(znz_eq0).

 Let w_opp_c       := w_op.(znz_opp_c).
 Let w_opp         := w_op.(znz_opp).
 Let w_opp_carry   := w_op.(znz_opp_carry).

 Let w_succ_c      := w_op.(znz_succ_c).
 Let w_add_c       := w_op.(znz_add_c).
 Let w_add_carry_c := w_op.(znz_add_carry_c).
 Let w_succ        := w_op.(znz_succ).
 Let w_add         := w_op.(znz_add).
 Let w_add_carry   := w_op.(znz_add_carry).

 Let w_pred_c      := w_op.(znz_pred_c).
 Let w_sub_c       := w_op.(znz_sub_c).
 Let w_sub_carry_c := w_op.(znz_sub_carry_c).
 Let w_pred        := w_op.(znz_pred).
 Let w_sub         := w_op.(znz_sub).
 Let w_sub_carry   := w_op.(znz_sub_carry).

 Let w_mul_c       := w_op.(znz_mul_c).
 Let w_mul         := w_op.(znz_mul).
 Let w_square_c    := w_op.(znz_square_c).

 Let w_div21       := w_op.(znz_div21).
 Let w_div_gt      := w_op.(znz_div_gt).
 Let w_div         := w_op.(znz_div).

 Let w_mod_gt      := w_op.(znz_mod_gt).
 Let w_mod         := w_op.(znz_mod).

 Let w_gcd_gt      := w_op.(znz_gcd_gt).
 Let w_gcd         := w_op.(znz_gcd).

 Let w_add_mul_div := w_op.(znz_add_mul_div).

 Let w_pos_mod := w_op.(znz_pos_mod).

 Let w_is_even     := w_op.(znz_is_even).
 Let w_sqrt2       := w_op.(znz_sqrt2).
 Let w_sqrt        := w_op.(znz_sqrt).

 Let _zn2z := zn2z w.

 Let wB := base w_digits.

 Let w_Bm2 := w_pred w_Bm1.

 Let ww_1 := ww_1 w_0 w_1.
 Let ww_Bm1 := ww_Bm1 w_Bm1.

 Let w_add2 a b := match w_add_c a b with C0 p => WW w_0 p | C1 p => WW w_1 p end.

 Let _ww_digits := xO w_digits.

 Let _ww_zdigits := w_add2 w_zdigits w_zdigits.

 Let to_Z := zn2z_to_Z wB w_to_Z.

 Let w_W0 := znz_W0 w_op.
 Let w_0W := znz_0W w_op.
 Let w_WW := znz_WW w_op.

 Let ww_of_pos p :=
  match w_of_pos p with
  | (N0, l) => (N0, WW w_0 l)
  | (Npos ph,l) =>
    let (n,h) := w_of_pos ph in (n, w_WW h l)
  end.

 Let head0 :=
  Eval lazy beta delta [ww_head0] in
  ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits.

 Let tail0 :=
  Eval lazy beta delta [ww_tail0] in
  ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits.

 Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW w).
 Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W w).
 Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 w).

 (* ** Comparison ** *)
 Let compare :=
  Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare.

 Let eq0 (x:zn2z w) :=
  match x with
  | W0 => true
  | _ => false
  end.

 (* ** Opposites ** *)
 Let opp_c :=
  Eval lazy beta delta [ww_opp_c] in ww_opp_c w_0 w_opp_c w_opp_carry.

 Let opp :=
  Eval lazy beta delta [ww_opp] in ww_opp w_0 w_opp_c w_opp_carry w_opp.

 Let opp_carry :=
  Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry.

 (* ** Additions ** *)

 Let succ_c :=
  Eval lazy beta delta [ww_succ_c] in ww_succ_c w_0 ww_1 w_succ_c.

 Let add_c :=
  Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c.

 Let add_carry_c :=
  Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in
  ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c.

 Let succ :=
  Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ.

 Let add :=
  Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry.

 Let add_carry :=
  Eval lazy beta iota delta [ww_add_carry ww_succ] in
  ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry.

 (* ** Subtractions ** *)

 Let pred_c :=
  Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c.

 Let sub_c :=
  Eval lazy beta iota delta [ww_sub_c ww_opp_c] in
  ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c.

 Let sub_carry_c :=
  Eval lazy beta iota delta [ww_sub_carry_c ww_pred_c ww_opp_carry] in
  ww_sub_carry_c w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c.

 Let pred :=
  Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred.

 Let sub :=
  Eval lazy beta iota delta [ww_sub ww_opp] in
  ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry.

 Let sub_carry :=
  Eval lazy beta iota delta [ww_sub_carry ww_pred ww_opp_carry] in
  ww_sub_carry w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_carry_c w_pred
  w_sub w_sub_carry.

 (* ** Multiplication ** *)

 Let mul_c :=
  Eval lazy beta iota delta [ww_mul_c double_mul_c] in
  ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry.

 Let karatsuba_c :=
  Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in
  ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c
    add_c add add_carry sub_c sub.

 Let mul :=
  Eval lazy beta delta [ww_mul] in
  ww_mul w_W0 w_add w_mul_c w_mul add.

 Let square_c :=
  Eval lazy beta delta [ww_square_c] in
  ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry.

 (* Division operation *)

 Let div32 :=
   Eval lazy beta iota delta [w_div32] in
   w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c
   w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c.

 Let div21 :=
  Eval lazy beta iota delta [ww_div21] in
   ww_div21 w_0 w_0W div32 ww_1 compare sub.

 Let low (p: zn2z w) := match p with WW _ p1 => p1 | _ => w_0 end.

 Let add_mul_div :=
  Eval lazy beta delta [ww_add_mul_div] in
  ww_add_mul_div w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_zdigits low.

 Let div_gt :=
  Eval lazy beta delta [ww_div_gt] in
  ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp
  w_opp_carry w_sub_c w_sub w_sub_carry
  w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits.

 Let div :=
  Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt.

 Let mod_gt :=
  Eval lazy beta delta [ww_mod_gt] in
  ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry
  w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits.

 Let mod_ :=
  Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt.

 Let pos_mod :=
  Eval lazy beta delta [ww_pos_mod] in
    ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits.

 Let is_even :=
  Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even.

 Let sqrt2 :=
  Eval lazy beta delta [ww_sqrt2] in
    ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c
    w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c
    pred add_c add sub_c add_mul_div.

 Let sqrt :=
  Eval lazy beta delta [ww_sqrt] in
    ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits
     _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low.

 Let gcd_gt_fix :=
  Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in
  ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry
      w_sub_c w_sub w_sub_carry w_gcd_gt
      w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div
      w_zdigits.

 Let gcd_cont :=
  Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare.

 Let gcd_gt :=
  Eval lazy beta delta [ww_gcd_gt] in
  ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont.

 Let gcd :=
  Eval lazy beta delta [ww_gcd] in
  ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont.

 (* ** Record of operators on 2 words *)

 Definition mk_zn2z_op :=
  mk_znz_op _ww_digits _ww_zdigits
    to_Z ww_of_pos head0 tail0
    W0 ww_1 ww_Bm1
    compare eq0
    opp_c opp opp_carry
    succ_c add_c add_carry_c
    succ add add_carry
    pred_c sub_c sub_carry_c
    pred sub sub_carry
    mul_c mul square_c
    div21 div_gt div
    mod_gt mod_
    gcd_gt gcd
    add_mul_div
    pos_mod
    is_even
    sqrt2
    sqrt.

 Definition mk_zn2z_op_karatsuba :=
   mk_znz_op _ww_digits _ww_zdigits
    to_Z ww_of_pos head0 tail0
    W0 ww_1 ww_Bm1
    compare eq0
    opp_c opp opp_carry
    succ_c add_c add_carry_c
    succ add add_carry
    pred_c sub_c sub_carry_c
    pred sub sub_carry
    karatsuba_c mul square_c
    div21 div_gt div
    mod_gt mod_
    gcd_gt gcd
    add_mul_div
    pos_mod
    is_even
    sqrt2
    sqrt.

 (* Proof *)
 Variable op_spec : znz_spec w_op.

 Hint Resolve
    (spec_to_Z op_spec)
    (spec_of_pos op_spec)
    (spec_0 op_spec)
    (spec_1 op_spec)
    (spec_Bm1 op_spec)
    (spec_compare op_spec)
    (spec_eq0 op_spec)
    (spec_opp_c op_spec)
    (spec_opp op_spec)
    (spec_opp_carry op_spec)
    (spec_succ_c op_spec)
    (spec_add_c op_spec)
    (spec_add_carry_c op_spec)
    (spec_succ op_spec)
    (spec_add op_spec)
    (spec_add_carry op_spec)
    (spec_pred_c op_spec)
    (spec_sub_c op_spec)
    (spec_sub_carry_c op_spec)
    (spec_pred op_spec)
    (spec_sub op_spec)
    (spec_sub_carry op_spec)
    (spec_mul_c op_spec)
    (spec_mul op_spec)
    (spec_square_c op_spec)
    (spec_div21 op_spec)
    (spec_div_gt op_spec)
    (spec_div op_spec)
    (spec_mod_gt op_spec)
    (spec_mod op_spec)
    (spec_gcd_gt op_spec)
    (spec_gcd op_spec)
    (spec_head0 op_spec)
    (spec_tail0 op_spec)
    (spec_add_mul_div op_spec)
    (spec_pos_mod)
    (spec_is_even)
    (spec_sqrt2)
    (spec_sqrt)
    (spec_W0 op_spec)
    (spec_0W op_spec)
    (spec_WW op_spec).

 Ltac wwauto := unfold ww_to_Z; auto.

 Let wwB := base _ww_digits.

 Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).

 Notation "[+| c |]" :=
   (interp_carry 1 wwB to_Z c)  (at level 0, x at level 99).

 Notation "[-| c |]" :=
   (interp_carry (-1) wwB to_Z c)  (at level 0, x at level 99).

 Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x)  (at level 0, x at level 99).

 Let spec_ww_to_Z   : forall x, 0 <= [| x |] < wwB.
 Proof. refine (spec_ww_to_Z w_digits w_to_Z _);auto. Qed.

 Let spec_ww_of_pos : forall p,
     Zpos p = (Z_of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|].
 Proof.
  unfold ww_of_pos;intros.
  assert (H:= spec_of_pos op_spec p);unfold w_of_pos;
   destruct (znz_of_pos w_op p). simpl in H.
  rewrite H;clear H;destruct n;simpl to_Z.
  simpl;unfold w_to_Z,w_0;rewrite (spec_0 op_spec);trivial.
  unfold Z_of_N; assert (H:= spec_of_pos op_spec p0);
  destruct (znz_of_pos w_op p0). simpl in H.
  rewrite H;unfold fst, snd,Z_of_N, to_Z.
  rewrite (spec_WW op_spec).
  replace wwB with (wB*wB).
  unfold wB,w_to_Z,w_digits;clear H;destruct n;ring.
  symmetry. rewrite <- Zpower_2; exact (wwB_wBwB w_digits).
 Qed.

 Let spec_ww_0 : [|W0|] = 0.
 Proof. reflexivity. Qed.

 Let spec_ww_1 : [|ww_1|] = 1.
 Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);auto. Qed.

 Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1.
 Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed.

 Let spec_ww_compare :
     forall x y,
       match compare x y with
       | Eq => [|x|] = [|y|]
       | Lt => [|x|] < [|y|]
       | Gt => [|x|] > [|y|]
       end.
 Proof.
  refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto.
  exact (spec_compare op_spec).
 Qed.

 Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0.
 Proof. destruct x;simpl;intros;trivial;discriminate. Qed.

 Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|].
 Proof.
  refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _);
  auto.
 Qed.

 Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB.
 Proof.
  refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp
   w_digits w_to_Z _ _ _ _ _);
  auto.
 Qed.

 Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1.
 Proof.
  refine (spec_ww_opp_carry w_WW ww_Bm1 w_opp_carry w_digits w_to_Z _ _ _);
  wwauto.
 Qed.

 Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1.
 Proof.
  refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);auto.
 Qed.

 Let spec_ww_add_c  : forall x y, [+|add_c x y|] = [|x|] + [|y|].
 Proof.
  refine (spec_ww_add_c w_WW w_add_c w_add_carry_c w_digits w_to_Z _ _ _);wwauto.
 Qed.

 Let spec_ww_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|]+[|y|]+1.
 Proof.
  refine (spec_ww_add_carry_c w_0 w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c
   w_digits w_to_Z _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_succ : forall x, [|succ x|] = ([|x|] + 1) mod wwB.
 Proof.
  refine (spec_ww_succ w_W0 ww_1 w_succ_c w_succ w_digits w_to_Z _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB.
 Proof.
  refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);auto.
 Qed.

 Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB.
 Proof.
  refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ
  w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1.
 Proof.
  refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z
   _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|].
 Proof.
  refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c
   w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1.
 Proof.
  refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c
   w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_pred : forall x, [|pred x|] = ([|x|] - 1) mod wwB.
 Proof.
  refine (spec_ww_pred w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_pred w_digits w_to_Z
   _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wwB.
 Proof.
  refine (spec_ww_sub w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_opp
   w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_sub_carry : forall x y, [|sub_carry x y|]=([|x|]-[|y|]-1) mod wwB.
 Proof.
  refine (spec_ww_sub_carry w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c
   w_sub_carry_c w_pred w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_mul_c : forall x y, [[mul_c x y ]] = [|x|] * [|y|].
 Proof.
  refine (spec_ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry w_digits
   w_to_Z _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_ww_karatsuba_c : forall x y, [[karatsuba_c x y ]] = [|x|] * [|y|].
 Proof.
 refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
          _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
  unfold w_digits; apply spec_more_than_1_digit; auto.
  exact (spec_compare op_spec).
 Qed.

 Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB.
 Proof.
  refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _);
  wwauto.
 Qed.

 Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|].
 Proof.
  refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add
   add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_w_div32 : forall a1 a2 a3 b1 b2,
       wB / 2 <= (w_to_Z b1) ->
       [|WW a1 a2|] < [|WW b1 b2|] ->
       let (q, r) := div32 a1 a2 a3 b1 b2 in
       (w_to_Z a1) * wwB + (w_to_Z a2) * wB + (w_to_Z a3) =
       (w_to_Z q) * ((w_to_Z b1)*wB + (w_to_Z b2)) + [|r|] /\
       0 <= [|r|] < (w_to_Z b1)*wB + w_to_Z b2.
 Proof.
  refine (spec_w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c
   w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z
   _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  unfold w_Bm2, w_to_Z, w_pred, w_Bm1.
  rewrite (spec_pred op_spec);rewrite (spec_Bm1 op_spec).
  unfold w_digits;rewrite Zmod_small. ring.
  assert (H:= wB_pos(znz_digits w_op)). omega.
  exact (spec_compare op_spec).
  exact (spec_div21 op_spec).
 Qed.

 Let spec_ww_div21 : forall a1 a2 b,
      wwB/2 <= [|b|] ->
      [|a1|] < [|b|] ->
      let (q,r) := div21 a1 a2 b in
      [|a1|] *wwB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
  refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z
   _ _ _ _ _ _ _);wwauto.
 Qed.

 Let spec_add2: forall x y,
  [|w_add2 x y|] = w_to_Z x + w_to_Z y.
  unfold w_add2.
  intros xh xl; generalize (spec_add_c op_spec xh xl).
  unfold w_add_c; case znz_add_c; unfold interp_carry; simpl ww_to_Z.
    intros w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0.
  unfold w_0; rewrite spec_0; simpl; auto with zarith.
  intros w0; rewrite Zmult_1_l; simpl.
  unfold w_to_Z, w_1; rewrite spec_1; auto with zarith.
  rewrite Zmult_1_l; auto.
 Qed.

 Let spec_low: forall x,
  w_to_Z (low x) = [|x|] mod wB.
  intros x; case x; simpl low.
    unfold ww_to_Z, w_to_Z, w_0; rewrite (spec_0 op_spec); simpl.
    rewrite Zmod_small; auto with zarith.
    split; auto with zarith.
    unfold wB, base; auto with zarith.
  intros xh xl; simpl.
  rewrite Zplus_comm; rewrite Z_mod_plus; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  unfold wB, base; auto with zarith.
 Qed.

 Let spec_ww_digits:
  [|_ww_zdigits|] = Zpos (xO w_digits).
 Proof.
 unfold w_to_Z, _ww_zdigits.
 rewrite spec_add2.
 unfold w_to_Z, w_zdigits, w_digits.
 rewrite spec_zdigits; auto.
 rewrite Zpos_xO; auto with zarith.
 Qed.

 Let spec_ww_head00  : forall x,  [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits.
 Proof.
 refine (spec_ww_head00 w_0 w_0W
                w_compare w_head0 w_add2 w_zdigits _ww_zdigits
                w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto.
 exact (spec_compare op_spec).
 exact (spec_head00 op_spec).
 exact (spec_zdigits op_spec).
 Qed.

 Let spec_ww_head0  : forall x,  0 < [|x|] ->
	 wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB.
 Proof.
  refine (spec_ww_head0 w_0 w_0W w_compare w_head0
           w_add2 w_zdigits _ww_zdigits
   w_to_Z _ _ _ _ _ _ _);wwauto.
  exact (spec_compare op_spec).
  exact (spec_zdigits op_spec).
 Qed.

 Let spec_ww_tail00  : forall x,  [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits.
 Proof.
 refine (spec_ww_tail00 w_0 w_0W
                w_compare w_tail0 w_add2 w_zdigits _ww_zdigits
                w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); wwauto.
 exact (spec_compare op_spec).
 exact (spec_tail00 op_spec).
 exact (spec_zdigits op_spec).
 Qed.

 Let spec_ww_tail0  : forall x,  0 < [|x|] ->
  exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|].
 Proof.
  refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0
           w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto.
  exact (spec_compare op_spec).
  exact (spec_zdigits op_spec).
 Qed.

 Lemma spec_ww_add_mul_div : forall x y p,
       [|p|] <= Zpos _ww_digits ->
       [| add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB.
 Proof.
 refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div
              sub w_digits w_zdigits low w_to_Z
           _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact (spec_zdigits op_spec).
 Qed.

 Let spec_ww_div_gt : forall a b,
      [|a|] > [|b|] -> 0 < [|b|] ->
      let (q,r) := div_gt a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|].
 Proof.
refine
(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0
   w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt
   w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
 _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
).
  exact (spec_0 op_spec).
  exact (spec_to_Z op_spec).
  wwauto.
  wwauto.
  exact (spec_compare op_spec).
  exact (spec_eq0 op_spec).
  exact (spec_opp_c op_spec).
  exact (spec_opp op_spec).
  exact (spec_opp_carry op_spec).
  exact (spec_sub_c op_spec).
  exact (spec_sub op_spec).
  exact (spec_sub_carry op_spec).
  exact (spec_div_gt op_spec).
  exact (spec_add_mul_div op_spec).
  exact (spec_head0 op_spec).
  exact (spec_div21 op_spec).
  exact spec_w_div32.
  exact (spec_zdigits op_spec).
  exact spec_ww_digits.
  exact spec_ww_1.
  exact spec_ww_add_mul_div.
 Qed.

 Let spec_ww_div : forall a b, 0 < [|b|] ->
      let (q,r) := div a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
  refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto.
 Qed.

 Let spec_ww_mod_gt : forall a b,
      [|a|] > [|b|] -> 0 < [|b|] ->
      [|mod_gt a b|] = [|a|] mod [|b|].
 Proof.
  refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0
   w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt
   w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div
   w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _ _ _);wwauto.
  exact (spec_compare op_spec).
  exact (spec_div_gt op_spec).
  exact (spec_div21 op_spec).
  exact (spec_zdigits op_spec).
  exact spec_ww_add_mul_div.
 Qed.

 Let spec_ww_mod :  forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|].
 Proof.
  refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);auto.
 Qed.

 Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] ->
      Zis_gcd [|a|] [|b|] [|gcd_gt a b|].
 Proof.
  refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _
    w_0 w_0 w_eq0 w_gcd_gt _ww_digits
  _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
  refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
   w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
  exact (spec_compare op_spec).
  exact (spec_div21 op_spec).
  exact (spec_zdigits op_spec).
  exact spec_ww_add_mul_div.
  refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
   _ _);auto.
 exact (spec_compare op_spec).
 Qed.

 Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|].
 Proof.
  refine (@spec_ww_gcd w w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt
  _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto.
  refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp
   w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0
   w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z
   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _   _ _ _ _ _);wwauto.
  exact (spec_compare op_spec).
  exact (spec_div21 op_spec).
  exact (spec_zdigits op_spec).
  exact spec_ww_add_mul_div.
  refine (@spec_gcd_cont w w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare
   _ _);auto.
  exact (spec_compare op_spec).
 Qed.

 Let spec_ww_is_even : forall x,
      match is_even x with
         true => [|x|] mod 2 = 0
      | false => [|x|] mod 2 = 1
      end.
 Proof.
 refine (@spec_ww_is_even w w_is_even w_0 w_1 w_Bm1 w_digits _ _ _ _ _); auto.
 exact (spec_is_even op_spec).
 Qed.

 Let spec_ww_sqrt2 : forall x y,
       wwB/ 4 <= [|x|] ->
       let (s,r) := sqrt2 x y in
          [[WW x y]] = [|s|] ^ 2 + [+|r|] /\
          [+|r|] <= 2 * [|s|].
 Proof.
 intros x y H.
 refine (@spec_ww_sqrt2 w w_is_even w_compare w_0 w_1 w_Bm1
               w_0W w_sub w_square_c w_div21 w_add_mul_div w_digits w_zdigits
               _ww_zdigits
               w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div
                _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
 exact (spec_zdigits op_spec).
 exact (spec_more_than_1_digit op_spec).
 exact (spec_is_even op_spec).
 exact (spec_compare op_spec).
 exact (spec_div21 op_spec).
 exact (spec_ww_add_mul_div).
 exact (spec_sqrt2 op_spec).
 Qed.

 Let spec_ww_sqrt : forall x,
       [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2.
 Proof.
 refine (@spec_ww_sqrt w w_is_even w_0 w_1 w_Bm1
           w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits
               w_sqrt2 pred add_mul_div head0 compare
            _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto.
 exact (spec_zdigits op_spec).
 exact (spec_more_than_1_digit op_spec).
 exact (spec_is_even op_spec).
 exact (spec_ww_add_mul_div).
 exact (spec_sqrt2 op_spec).
 Qed.

 Lemma mk_znz2_spec : znz_spec mk_zn2z_op.
 Proof.
  apply mk_znz_spec;auto.
  exact spec_ww_add_mul_div.

  refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW
           w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z
       _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact (spec_pos_mod op_spec).
  exact (spec_zdigits op_spec).
  unfold w_to_Z, w_zdigits.
  rewrite (spec_zdigits op_spec).
  rewrite <- Zpos_xO; exact spec_ww_digits.
 Qed.

 Lemma mk_znz2_karatsuba_spec : znz_spec mk_zn2z_op_karatsuba.
 Proof.
  apply mk_znz_spec;auto.
  exact spec_ww_add_mul_div.
  refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW
           w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z
       _ _ _ _ _ _ _ _ _ _ _ _);wwauto.
  exact (spec_pos_mod op_spec).
  exact (spec_zdigits op_spec).
  unfold w_to_Z, w_zdigits.
  rewrite (spec_zdigits op_spec).
  rewrite <- Zpos_xO; exact spec_ww_digits.
 Qed.

End Z_2nZ.

Section MulAdd.

  Variable w: Type.
  Variable op: znz_op w.
  Variable sop: znz_spec op.

  Definition mul_add:= w_mul_add (znz_0 op) (znz_succ op) (znz_add_c op) (znz_mul_c op).

  Notation "[| x |]" := (znz_to_Z op x)  (at level 0, x at level 99).

  Notation "[|| x ||]" :=
   (zn2z_to_Z (base (znz_digits op)) (znz_to_Z op) x)  (at level 0, x at level 99).

  Lemma spec_mul_add: forall x y z,
     let (zh, zl) := mul_add x y z in
  [||WW zh zl||] = [|x|] * [|y|] + [|z|].
  Proof.
  intros x y z.
   refine (spec_w_mul_add _ _ _ _ _ _ _ _ _ _ _ _ x y z); auto.
  exact (spec_0 sop).
  exact (spec_to_Z sop).
  exact (spec_succ sop).
  exact (spec_add_c sop).
  exact (spec_mul_c sop).
  Qed.

End MulAdd.

(** Modular versions of DoubleCyclic *)

Module DoubleCyclic (C:CyclicType) <: CyclicType.
 Definition w := zn2z C.w.
 Definition w_op := mk_zn2z_op C.w_op.
 Definition w_spec := mk_znz2_spec C.w_spec.
End DoubleCyclic.

Module DoubleCyclicKaratsuba (C:CyclicType) <: CyclicType.
 Definition w := zn2z C.w.
 Definition w_op := mk_zn2z_op_karatsuba C.w_op.
 Definition w_spec := mk_znz2_karatsuba_spec C.w_spec.
End DoubleCyclicKaratsuba.


Require Import List.
Import ListNotations.

From ASUB Require Import Utils.

Definition t (A: Type) := (A * list A)%type.

Definition hd {A: Type} (ne: t A) : A :=
  let '(v, l) := ne in v.

Definition tl {A: Type} (ne: t A) : list A :=
  let '(v, l) := ne in l.

Definition to_list {A: Type} (ne: t A) : list A :=
  let '(v, l) := ne in
  v :: l.

Definition from_list {A: Type} (l: list A) : option (t A) :=
  match l with
  | [] => None
  | a :: l => Some (a, l)
  end.

Definition map {A B: Type} (f: A -> B) (ne: t A) : t B :=
  let '(x, l) := ne in
  (f x, List.map f l).

Definition fold_left {A B: Type} (f: A -> B -> A) (ne: t B) (init: A) : A :=
  List.fold_left f (to_list ne) init.

Definition anyf {A: Type} (f: A -> bool) (ne: t A) : bool :=
  list_anyf f (to_list ne).


Require Coq.Init.Peano.
Require Export HoTT.Classes.interfaces.canonical_names.
Require Import HProp.

Generalizable Variables A B f g x y.

(*
For various structures we omit declaration of substructures. For example, if we
say:

Class Setoid_Morphism :=
  { setoidmor_a :> Setoid A
  ; setoidmor_b :> Setoid B
  ; sm_proper :> Proper ((=) ==> (=)) f }.

then each time a Setoid instance is required, Coq will try to prove that a
Setoid_Morphism exists. This obviously results in an enormous blow-up of the
search space. Moreover, one should be careful to declare a Setoid_Morphisms
as a substructure. Consider [f t1 t2], now if we want to perform setoid rewriting
in [t2] Coq will first attempt to prove that [f t1] is Proper, for which it will
attempt to prove [Setoid_Morphism (f t1)]. If many structures declare
Setoid_Morphism as a substructure, setoid rewriting will become horribly slow.
*)

(* An unbundled variant of the former CoRN CSetoid. We do not
  include a proof that A is a Setoid because it can be derived. *)
Class IsApart A {Aap : Apart A} : Type :=
  { apart_set :> IsHSet A
  ; apart_mere :> is_mere_relation _ apart
  ; apart_symmetric :> Symmetric (≶)
  ; apart_cotrans :> CoTransitive (≶)
  ; tight_apart : forall x y, ~x ≶ y <-> x = y }.

Instance apart_irrefl `{IsApart A} : Irreflexive (≶).
Proof.
intros x ap.
apply (tight_apart x x).
- reflexivity.
- assumption.
Qed.

Arguments tight_apart {A Aap IsApart} _ _.

Section setoid_morphisms.
  Context {A B} {Aap : Apart A} {Bap : Apart B} (f : A -> B).

  Class StrongExtensionality := strong_extensionality : forall x y, f x ≶ f y -> x ≶ y.
End setoid_morphisms.

(* HOTT TODO check if this is ok/useful *)
Hint Extern 4 (?f _ = ?f _) => eapply (ap f) : core.

Section setoid_binary_morphisms.
  Context {A B C} {Aap: Apart A}
    {Bap : Apart B} {Cap : Apart C} (f : A -> B -> C).

  Class StrongBinaryExtensionality := strong_binary_extensionality
    : forall x₁ y₁ x₂ y₂, f x₁ y₁ ≶ f x₂ y₂ -> hor (x₁ ≶ x₂) (y₁ ≶ y₂).
End setoid_binary_morphisms.

(*
Since apartness usually only becomes relevant when considering fields (e.g. the
real numbers), we do not include it in the lower part of the algebraic hierarchy
(as opposed to CoRN).
*)
Section upper_classes.
  Universe i.
  Context (A : Type@{i}).

  Local Open Scope mc_mult_scope.

  Class IsSemiGroup {Aop: SgOp A} :=
    { sg_set :> IsHSet A
    ; sg_ass :> Associative (.*.) }.

  Class IsCommutativeSemiGroup {Aop : SgOp A} :=
    { comsg_sg :> @IsSemiGroup (.*.)
    ; comsg_comm :> Commutative (.*.) }.

  Class IsSemiLattice {Aop : SgOp A} :=
    { semilattice_sg :> @IsCommutativeSemiGroup (.*.)
    ; semilattice_idempotent :> BinaryIdempotent (.*.)}.

  Class IsMonoid {Aop : SgOp A} {Aunit : MonUnit A} :=
    { monoid_semigroup :> IsSemiGroup
    ; monoid_left_id :> LeftIdentity (.*.) mon_unit
    ; monoid_right_id :> RightIdentity (.*.) mon_unit }.

  Class IsCommutativeMonoid {Aop : SgOp A} {Aunit : MonUnit A} :=
    { commonoid_mon :> @IsMonoid (.*.) Aunit
    ; commonoid_commutative :> Commutative (.*.) }.

  Class IsGroup {Aop : SgOp A} {Aunit : MonUnit A} {Anegate : Negate A} :=
    { group_monoid :> @IsMonoid (.*.) Aunit
    ; negate_l :> LeftInverse (.*.) (-) mon_unit
    ; negate_r :> RightInverse (.*.) (-) mon_unit }.

  Class IsBoundedSemiLattice {Aop : SgOp A} {Aunit : MonUnit A} :=
    { bounded_semilattice_mon :> @IsCommutativeMonoid (.*.) Aunit
    ; bounded_semilattice_idempotent :> BinaryIdempotent (.*.)}.

  Class IsAbGroup {Aop : SgOp A} {Aunit : MonUnit A} {Anegate : Negate A} :=
    { abgroup_group :> @IsGroup (.*.) Aunit Anegate
    ; abgroup_commutative :> Commutative (.*.) }.

  Close Scope mc_mult_scope.

  Context {Aplus : Plus A} {Amult : Mult A} {Azero : Zero A} {Aone : One A}.

  Class IsSemiRing :=
    { semiplus_monoid :> @IsCommutativeMonoid plus_is_sg_op zero_is_mon_unit
    ; semimult_monoid :> @IsCommutativeMonoid mult_is_sg_op one_is_mon_unit
    ; semiring_distr :> LeftDistribute (.*.) (+)
    ; semiring_left_absorb :> LeftAbsorb (.*.) 0 }.

  Context {Anegate : Negate A}.

  Class IsRing :=
    { ring_group :> @IsAbGroup plus_is_sg_op zero_is_mon_unit _
    ; ring_monoid :> @IsCommutativeMonoid mult_is_sg_op one_is_mon_unit
    ; ring_dist :> LeftDistribute (.*.) (+) }.

  (* For now, we follow CoRN/ring_theory's example in having Ring and SemiRing
    require commutative multiplication. *)

  Class IsIntegralDomain :=
    { intdom_ring : IsRing
    ; intdom_nontrivial : PropHolds (not (1 = 0))
    ; intdom_nozeroes :> NoZeroDivisors A }.

  (* We do not include strong extensionality for (-) and (/)
    because it can de derived *)
  Class IsField {Aap: Apart A} {Arecip: Recip A} :=
    { field_ring :> IsRing
    ; field_apart :> IsApart A
    ; field_plus_ext :> StrongBinaryExtensionality (+)
    ; field_mult_ext :> StrongBinaryExtensionality (.*.)
    ; field_nontrivial : PropHolds (1 ≶ 0)
    ; recip_inverse : forall x, x.1 // x = 1 }.

  (* We let /0 = 0 so properties as Injective (/),
    f (/x) = / (f x), / /x = x, /x * /y = /(x * y)
    hold without any additional assumptions *)
  Class IsDecField {Adec_recip : DecRecip A} :=
    { decfield_ring :> IsRing
    ; decfield_nontrivial : PropHolds (1 <> 0)
    ; dec_recip_0 : /0 = 0
    ; dec_recip_inverse : forall x, x <> 0 -> x / x = 1 }.

  Class FieldCharacteristic@{j} {Aap : Apart@{i j} A} (k : nat) : Type@{j}
    := field_characteristic : forall n : nat, Peano.lt 0 n ->
      iff@{j j j} (forall m : nat, not@{j j} (paths@{Set} n (Peano.mult k m)))
        (@apart A Aap (Peano.nat_iter n (1 +) 0) 0).

End upper_classes.

(* Due to bug #2528 *)
Hint Extern 4 (PropHolds (1 <> 0)) =>
  eapply @intdom_nontrivial : typeclass_instances.
Hint Extern 5 (PropHolds (1 ≶ 0)) =>
  eapply @field_nontrivial : typeclass_instances.
Hint Extern 5 (PropHolds (1 <> 0)) =>
  eapply @decfield_nontrivial : typeclass_instances.

(*
For a strange reason IsRing instances of Integers are sometimes obtained by
Integers -> IntegralDomain -> Ring and sometimes directly. Making this an
instance with a low priority instead of using intdom_ring:> IsRing forces Coq to
take the right way
*)
Hint Extern 10 (IsRing _) => apply @intdom_ring : typeclass_instances.

Arguments recip_inverse {A Aplus Amult Azero Aone Anegate Aap Arecip IsField} _.
Arguments dec_recip_inverse
  {A Aplus Amult Azero Aone Anegate Adec_recip IsDecField} _ _.
Arguments dec_recip_0 {A Aplus Amult Azero Aone Anegate Adec_recip IsDecField}.

Section lattice.
  Context A {Ajoin: Join A} {Ameet: Meet A} {Abottom : Bottom A} {Atop : Top A}.

  Class IsJoinSemiLattice :=
    join_semilattice :> @IsSemiLattice A join_is_sg_op.
  Class IsBoundedJoinSemiLattice :=
    bounded_join_semilattice :> @IsBoundedSemiLattice A
      join_is_sg_op bottom_is_mon_unit.
  Class IsMeetSemiLattice :=
    meet_semilattice :> @IsSemiLattice A meet_is_sg_op.
  Class IsBoundedMeetSemiLattice :=
    bounded_meet_semilattice :> @IsBoundedSemiLattice A
      meet_is_sg_op top_is_mon_unit.

  Class IsLattice :=
    { lattice_join :> IsJoinSemiLattice
    ; lattice_meet :> IsMeetSemiLattice
    ; join_meet_absorption :> Absorption (⊔) (⊓)
    ; meet_join_absorption :> Absorption (⊓) (⊔)}.

  Class IsBoundedLattice :=
    { boundedlattice_join :> IsBoundedJoinSemiLattice
    ; boundedlattice_meet :> IsBoundedMeetSemiLattice
    ; boundedjoin_meet_absorption :> Absorption (⊔) (⊓)
    ; boundedmeet_join_absorption :> Absorption (⊓) (⊔)}.

  Class IsDistributiveLattice :=
    { distr_lattice_lattice :> IsLattice
    ; join_meet_distr_l :> LeftDistribute (⊔) (⊓) }.
End lattice.

Section morphism_classes.

  Section sgmorphism_classes.
  Context {A B : Type} {Aop : SgOp A} {Bop : SgOp B}
    {Aunit : MonUnit A} {Bunit : MonUnit B}.

  Local Open Scope mc_mult_scope.

  Class IsSemiGroupPreserving (f : A -> B) :=
    preserves_sg_op : forall x y, f (x * y) = f x * f y.

  Class IsUnitPreserving (f : A -> B) :=
    preserves_mon_unit : f mon_unit = mon_unit.

  Class IsMonoidPreserving (f : A -> B) :=
    { monmor_sgmor :> IsSemiGroupPreserving f
    ; monmor_unitmor :> IsUnitPreserving f }.
  End sgmorphism_classes.

  Section ringmorphism_classes.
  Context {A B : Type} {Aplus : Plus A} {Bplus : Plus B}
    {Amult : Mult A} {Bmult : Mult B} {Azero : Zero A} {Bzero : Zero B}
    {Aone : One A} {Bone : One B}.

  Class IsSemiRingPreserving (f : A -> B) :=
    { semiringmor_plus_mor :> @IsMonoidPreserving A B
        plus_is_sg_op plus_is_sg_op zero_is_mon_unit zero_is_mon_unit f
    ; semiringmor_mult_mor :> @IsMonoidPreserving A B
        mult_is_sg_op mult_is_sg_op one_is_mon_unit one_is_mon_unit f }.

  Context {Aap : Apart A} {Bap : Apart B}.
  Class IsSemiRingStrongPreserving (f : A -> B) :=
    { strong_semiringmor_sr_mor :> IsSemiRingPreserving f
    ; strong_semiringmor_strong_mor :> StrongExtensionality f }.
  End ringmorphism_classes.

  Section latticemorphism_classes.
  Context {A B : Type} {Ajoin : Join A} {Bjoin : Join B}
    {Ameet : Meet A} {Bmeet : Meet B}.

  Class IsJoinPreserving (f : A -> B) :=
    join_slmor_sgmor :> @IsSemiGroupPreserving A B join_is_sg_op join_is_sg_op f.

  Class IsMeetPreserving (f : A -> B) :=
    meet_slmor_sgmor :> @IsSemiGroupPreserving A B meet_is_sg_op meet_is_sg_op f.

  Context {Abottom : Bottom A} {Bbottom : Bottom B}.
  Class IsBoundedJoinPreserving (f : A -> B) := bounded_join_slmor_monmor
      :> @IsMonoidPreserving A B join_is_sg_op join_is_sg_op
         bottom_is_mon_unit bottom_is_mon_unit f.

  Class IsLatticePreserving (f : A -> B) :=
    { latticemor_join_mor :> IsJoinPreserving f
    ; latticemor_meet_mor :> IsMeetPreserving f }.
  End latticemorphism_classes.
End morphism_classes.

Section jections.
  Context {A B} (f : A -> B).

  Class IsInjective := injective : forall x y, f x = f y -> x = y.

  Lemma isinjective_ne `{!IsInjective} x y :
    x <> y -> f x <> f y.
  Proof.
    intros E1 E2. apply E1.
    apply injective.
    assumption.
  Qed.
End jections.

Section strong_injective.
  Context {A B} {Aap : Apart A} {Bap : Apart B} (f : A -> B) .
  Class IsStrongInjective :=
    { strong_injective : forall x y, x ≶ y -> f x ≶ f y
    ; strong_injective_mor : StrongExtensionality f }.
End strong_injective.

Section extras.

Class CutMinusSpec A (cm : CutMinus A) `{Zero A} `{Plus A} `{Le A} := {
  cut_minus_le : forall x y, y ≤ x -> x ∸ y + y = x ;
  cut_minus_0 : forall x y, x ≤ y -> x ∸ y = 0
}.

Global Instance ishprop_issemigrouppreserving `{Funext} {A B : Type} `{IsHSet B}
  `{SgOp A} `{SgOp B} {f : A -> B} : IsHProp (IsSemiGroupPreserving f).
Proof.
  unfold IsSemiGroupPreserving; exact _.
Defined.

Definition issig_IsMonoidPreserving {A B : Type} `{SgOp A} `{SgOp B}
  `{MonUnit A} `{MonUnit B} {f : A -> B} : _ <~> IsMonoidPreserving f
  := ltac:(issig).

Global Instance ishprop_ismonoidpreserving `{Funext} {A B : Type} `{SgOp A}
  `{SgOp B} `{IsHSet B} `{MonUnit A} `{MonUnit B} (f : A -> B)
  : IsHProp (IsMonoidPreserving f).
Proof.
  serapply (trunc_equiv' _ issig_IsMonoidPreserving).
  serapply (trunc_equiv' _ (equiv_sigma_prod0 _ _)^-1).
  serapply trunc_prod.
  unfold IsUnitPreserving.
  exact _.
Defined.

Definition issig_issemigroup x y : _ <~> @IsSemiGroup x y := ltac:(issig).

Global Instance ishprop_issemigroup `{Funext}
  : forall x y, IsHProp (@IsSemiGroup x y).
Proof.
  intros x y a b.
  rewrite <- (eisretr (issig_issemigroup x y) a).
  rewrite <- (eisretr (issig_issemigroup x y) b).
  set (a' := (issig_issemigroup x y)^-1 a).
  set (b' := (issig_issemigroup x y)^-1 b).
  clearbody a' b'; clear a b.
  serapply (contr_equiv _ (ap (issig_issemigroup x y))).
  rewrite <- (eissect (equiv_sigma_prod0 _ _) a').
  rewrite <- (eissect (equiv_sigma_prod0 _ _) b').
  set (a := equiv_sigma_prod0 _ _ a').
  set (b := equiv_sigma_prod0 _ _ b').
  clearbody a b; clear a' b'.
  serapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)).
  serapply (contr_equiv _ (equiv_path_prod _ _)).
  serapply contr_prod.
  destruct a as [a' a], b as [b' b].
  do 3 (ntc_refine (contr_equiv' _ (@equiv_path_forall H _ _ _ _));
  ntc_refine (@contr_forall H _ _ _); intro).
  exact _.
Defined.

Definition issig_ismonoid x y z : _ <~> @IsMonoid x y z := ltac:(issig).

Global Instance ishprop_ismonoid `{Funext} x y z : IsHProp (@IsMonoid x y z).
Proof.
  intros a b.
  rewrite <- (eisretr (issig_ismonoid x y z) a).
  rewrite <- (eisretr (issig_ismonoid x y z) b).
  set (a' := (issig_ismonoid x y z)^-1 a).
  set (b' := (issig_ismonoid x y z)^-1 b).
  clearbody a' b'; clear a b.
  serapply (contr_equiv _ (ap (issig_ismonoid x y z))).
  rewrite <- (eissect (equiv_sigma_prod0 _ _) a').
  rewrite <- (eissect (equiv_sigma_prod0 _ _) b').
  set (a := equiv_sigma_prod0 _ _ a').
  set (b := equiv_sigma_prod0 _ _ b').
  clearbody a b; clear a' b'.
  serapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)).
  serapply (contr_equiv _ (equiv_path_prod _ _)).
  serapply contr_prod.
  destruct a as [a' a], b as [b' b]; cbn.
  rewrite <- (eissect (equiv_sigma_prod0 _ _) a).
  rewrite <- (eissect (equiv_sigma_prod0 _ _) b).
  set (a'' := equiv_sigma_prod0 _ _ a).
  set (b'' := equiv_sigma_prod0 _ _ b).
  clearbody a'' b''; clear a b.
  serapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)).
  serapply (contr_equiv _ (equiv_path_prod _ _)).
  destruct a'' as [a a''], b'' as [b b'']; cbn.
  serapply contr_prod.
  all: serapply contr_paths_contr.
  all: serapply contr_inhabited_hprop.
  all: serapply trunc_forall.
Defined.

Definition issig_isgroup w x y z : _ <~> @IsGroup w x y z := ltac:(issig).

Global Instance ishprop_isgroup `{Funext} w x y z : IsHProp (@IsGroup w x y z).
Proof.
  intros a b.
  rewrite <- (eisretr (issig_isgroup w x y z) a).
  rewrite <- (eisretr (issig_isgroup w x y z) b).
  set (a' := (issig_isgroup w x y z)^-1 a).
  set (b' := (issig_isgroup w x y z)^-1 b).
  clearbody a' b'; clear a b.
  serapply (contr_equiv _ (ap (issig_isgroup w x y z))).
  rewrite <- (eissect (equiv_sigma_prod0 _ _) a').
  rewrite <- (eissect (equiv_sigma_prod0 _ _) b').
  set (a := equiv_sigma_prod0 _ _ a').
  set (b := equiv_sigma_prod0 _ _ b').
  clearbody a b; clear a' b'.
  serapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)).
  serapply (contr_equiv _ (equiv_path_prod _ _)).
  serapply contr_prod.
  destruct a as [a' a], b as [b' b]; cbn.
  rewrite <- (eissect (equiv_sigma_prod0 _ _) a).
  rewrite <- (eissect (equiv_sigma_prod0 _ _) b).
  set (a'' := equiv_sigma_prod0 _ _ a).
  set (b'' := equiv_sigma_prod0 _ _ b).
  clearbody a'' b''; clear a b.
  serapply (contr_equiv _ (ap (equiv_sigma_prod0 _ _)^-1)).
  serapply (contr_equiv _ (equiv_path_prod _ _)).
  destruct a'' as [a a''], b'' as [b b'']; cbn.
  serapply contr_prod.
  all: serapply contr_paths_contr.
  all: serapply contr_inhabited_hprop.
  all: serapply trunc_forall.
Defined.

End extras.


From Velus Require Import Common.
From Velus Require Import Operators.
From Velus Require Import Clocks.
From Velus Require Import CoreExpr.CESyntax.
From Velus Require Import NLustre.NLSyntax.
From Velus Require Import CoreExpr.CEIsFree.
From Coq Require Import List.

(** * Free variables *)

(**

The predicate [Is_free x t : Prop] states that the variable [x] is
used in the term [t]. If [t] is an equation, this collects the
variables in the right-hand side of the equation. In particular, if
[t] is [x = v0 fby x], [x] will (perhaps confusingly) be free.

 *)

Module Type ISFREE
       (Ids          : IDS)
       (Op           : OPERATORS)
       (Import CESyn : CESYNTAX     Op)
       (Import Syn   : NLSYNTAX Ids Op CESyn)
       (Import CEIsF : CEISFREE Ids Op CESyn).

  Inductive Is_free_in_eq : ident -> equation -> Prop :=
  | FreeEqDef:
      forall x ck ce i,
        Is_free_in_caexp i ck ce ->
        Is_free_in_eq i (EqDef x ck ce)
  | FreeEqApp:
      forall x f ck les i,
        Is_free_in_aexps i ck les ->
        Is_free_in_eq i (EqApp x ck f les None)
  | FreeEqReset:
      forall x f ck les i r ck_r,
        Is_free_in_aexps i ck les \/ r = i \/ Is_free_in_clock i ck_r ->
        Is_free_in_eq i (EqApp x ck f les (Some (r, ck_r)))
  | FreeEqFby:
      forall x v ck le i,
        Is_free_in_aexp i ck le ->
        Is_free_in_eq i (EqFby x ck v le).

  Hint Constructors Is_free_in_clock Is_free_in_exp
       Is_free_in_aexp Is_free_in_aexps Is_free_in_cexp
       Is_free_in_caexp Is_free_in_eq.

  (** * Decision procedure *)

  Fixpoint free_in_equation (eq: equation) (fvs: PS.t) : PS.t :=
    match eq with
    | EqDef _ ck cae      => free_in_caexp ck cae fvs
    | EqApp _ ck f laes r =>
      let fvs := free_in_aexps ck laes fvs in
      match r with
      | Some (x, ck_r) => PS.add x (free_in_clock ck_r fvs)
      | None => fvs
      end
    | EqFby _ ck v lae    => free_in_aexp ck lae fvs
    end.

  (** * Specification lemmas *)

  Lemma free_in_equation_spec:
    forall x eq m, PS.In x (free_in_equation eq m)
                   <-> (Is_free_in_eq x eq \/ PS.In x m).
  Proof.
    Local Ltac aux :=
      repeat (match goal with
              | H:Is_free_in_eq _ _ |- _ => inversion_clear H
              | H:PS.In _ (free_in_equation _ _) |- _ =>
                apply free_in_caexp_spec in H
                || apply free_in_aexp_spec in H
                || apply free_in_aexps_spec in H
              | |- PS.In _ (free_in_equation _ _) =>
                apply free_in_caexp_spec
                || apply free_in_aexp_spec
                || apply free_in_aexps_spec
              | _ => intuition; eauto
              end).

    destruct eq; split; intro H; aux.
    - destruct o as [(?&?)|]; aux.
      simpl in H.
      apply PS.add_spec in H as [|].
      + subst; left; eauto.
      + apply free_in_clock_spec in H as [|]; eauto.
        apply free_in_aexps_spec in H as [|]; aux.
    - destruct o; aux; simpl; apply PS.add_spec;
        rewrite free_in_clock_spec, free_in_aexps_spec; intuition.
    - subst; simpl. now apply PSF.add_1.
    - destruct o; aux; simpl; apply PS.add_spec;
        rewrite free_in_clock_spec, free_in_aexps_spec; intuition.
    - simpl; destruct o as [(?&?)|];
        try apply PS.add_spec; try rewrite free_in_clock_spec; try rewrite free_in_aexps_spec;
          auto.
  Qed.

  Lemma free_in_equation_spec':
    forall x eq, PS.In x (free_in_equation eq PS.empty)
               <-> Is_free_in_eq x eq.
  Proof.
    intros; rewrite (free_in_equation_spec x eq PS.empty).
    intuition.
  Qed.

End ISFREE.

Module IsFreeFun
       (Ids   : IDS)
       (Op    : OPERATORS)
       (CESyn : CESYNTAX     Op)
       (Syn   : NLSYNTAX Ids Op CESyn)
       (CEIsF : CEISFREE Ids Op CESyn)
       <: ISFREE Ids Op CESyn Syn CEIsF.
  Include ISFREE Ids Op CESyn Syn CEIsF.
End IsFreeFun.