(** * QuickChickInterface: QuickChick Reference Manual *)

From QuickChick Require Import QuickChick.
Require Import ZArith Strings.Ascii Strings.String.

From ExtLib.Structures Require Import Functor Applicative.

(** QuickChick provides a large collection of combinators and
    notations for writing property-based random tests.  This file
    documents the entire public interface (the module type
    [QuickChickSig]). *)

Module Type QuickChickSig.

(* ################################################################# *)
(** * The [Show] Typeclass *)

(** [Show] typeclass allows the test case to be printed as a string. *)
(**
    Class Show (A : Type) : Type :=
      {
        show : A -> string
      }.
*)

(** Here are some [Show] instances for some basic types: *)
Declare Instance showNat    : Show nat.
Declare Instance showBool   : Show bool.
Declare Instance showZ      : Show Z.
Declare Instance showString : Show string.

Declare Instance showList :
  forall {A : Type} `{Show A}, Show (list A).
Declare Instance showPair :
  forall {A B : Type} `{Show A} `{Show B}, Show (A * B).
Declare Instance showOpt :
  forall {A : Type} `{Show A}, Show (option A).
Declare Instance showEx :
  forall {A} `{Show A} P, Show ({x : A | P x}).

(** When defining [Show] instance for your own datatypes, you sometimes need to
    start a new line for better printing. [nl] is a shorthand for it. *)
Definition nl : string := String (ascii_of_nat 10) EmptyString.

(* ################################################################# *)
(** * Generators *)

(* ================================================================= *)
(** ** Fundamental Types *)

(** A [RandomSeed] represents a particular starting point in a
    pseudo-random sequence. *)
Parameter RandomSeed : Type.

(** [G A] is the type of random generators for type [A]. *)
Parameter G : Type -> Type.

(** Run a generator with a size parameter (a natural number denoting
    the maximum depth of the generated A) and a random seed. *)
Parameter run  : forall {A : Type}, G A -> nat -> RandomSeed -> A.

(** The semantics of a generator is its set of possible outcomes. *)
Parameter semGen : forall {A : Type} (g : G A), set A.
Parameter semGenSize : forall {A : Type} (g : G A) (size : nat), set A.

(* ================================================================= *)
(** ** Structural Combinators *)

(** Generators are also instances of several generic typeclasses.
    Many handy generator combinators can be found in the [Monad],
    [Functor], [Applicative], [Foldable], and [Traversable] modules in
    the [ExtLib.Structures] library from [coq-ext-lib]. *)

Declare Instance Monad_G : Monad G.
Declare Instance Functor_G : Functor G.
Declare Instance Applicative_G : Applicative G.

(** A variant of monadic bind where the continuation also takes a
    _proof_ that the value received is within the set of outcomes of
    the first generator. *)
Parameter bindGen' : forall {A B : Type} (g : G A),
    (forall (a : A), (a \in semGen g) -> G B) -> G B.

(** A variant of bind for the [(G (option --))] monad.  Useful for
    chaining generators that can fail / backtrack. *)
Parameter bindGenOpt : forall {A B : Type},
    G (option A) -> (A -> G (option B)) -> G (option B).

(* ================================================================= *)
(** ** Basic Generator Combinators *)

(** The [listOf] and [vectorOf] combinators construct generators for
    [list A], provided a generator [g] for type [A]: [listOf g] yields
    an arbitrary-sized list (which might be empty), while [vectorOf n
    g] yields a list of fixed size [n]. *)
Parameter listOf : forall {A : Type}, G A -> G (list A).
Parameter vectorOf : forall {A : Type}, nat -> G A -> G (list A).

(** [elems_ a l] constructs a generator from a list [l] and a
    default element [a]. If [l] is non-empty, the generator picks an
    element from [l] uniformly; otherwise it always yields [a]. *)
Parameter elems_ : forall {A : Type}, A -> list A -> G A.

(** Similar to [elems_], instead of choosing from a list of [A]s,
    [oneOf_ g l] returns [g] if [l] is empty; otherwise it uniformly
    picks a generator for [A] in [l]. *)
Parameter oneOf_ : forall {A : Type}, G A -> list (G A) -> G A.

(** We can also choose generators with distributions other than the
    uniform one. [freq_ g l] returns [g] if [l] is empty;
    otherwise it chooses a generator from [l], where the first field
    indicates the chance that the second field is chosen. For example,
    [freq_ z [(2, x); (3, y)]] has 40%% probability of choosing
    [x] and 60%% probability of choosing [y]. *)
Parameter freq_ :
  forall {A : Type}, G A -> list (nat * G A) -> G A.

(** Try all generators until one returns a [Some] value or all failed once with
    [None]. The generators are picked at random according to their weights
    (like [frequency]), and each one is run at most once. *)
Parameter backtrack :
  forall {A : Type}, list (nat * G (option A)) -> G (option A).

(** Internally, the G monad hides a [size] parameter that can be accessed by
    generators. The [sized] combinator provides such access. The [resize]
    combinator sets it. *)
Parameter sized : forall {A: Type}, (nat -> G A) -> G A.
Parameter resize : forall {A: Type}, nat -> G A -> G A.

(** Generate-and-test approach to generate data with preconditions. *)
Parameter suchThatMaybe :
  forall {A : Type}, G A -> (A -> bool) -> G (option A).
Parameter suchThatMaybeOpt :
  forall {A : Type}, G (option A) -> (A -> bool) -> G (option A).

(** The [elems_], [oneOf_], and [freq_] combinators all take
    default values; these are only used if their list arguments are
    empty, which should not normally happen. The [QcDefaultNotation]
    sub-module exposes notation (without the underscores) to hide this default.
*)

Module QcDefaultNotation.

  (** [elems] is a shorthand for [elems_] without a default argument. *)
  Notation " 'elems' [ x ] " :=
    (elems_ x (cons x nil)) : qc_scope.
  Notation " 'elems' [ x ; y ] " :=
    (elems_ x (cons x (cons y nil))) : qc_scope.
  Notation " 'elems' [ x ; y ; .. ; z ] " :=
    (elems_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'elems' ( x ;; l ) " :=
    (elems_ x (cons x l)) (at level 1, no associativity) : qc_scope.

  (** [oneOf] is a shorthand for [oneOf_] without a default argument. *)
  Notation " 'oneOf' [ x ] " :=
    (oneOf_ x (cons x nil)) : qc_scope.
  Notation " 'oneOf' [ x ; y ] " :=
    (oneOf_ x (cons x (cons y nil))) : qc_scope.
  Notation " 'oneOf' [ x ; y ; .. ; z ] " :=
    (oneOf_ x (cons x (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'oneOf' ( x ;; l ) " :=
    (oneOf_ x (cons x l))  (at level 1, no associativity) : qc_scope.

  (** [freq] is a shorthand for [freq_] without a default argument. *)
  Notation " 'freq' [ x ] " :=
    (freq_ x (cons x nil)) : qc_scope.
  Notation " 'freq' [ ( n , x ) ; y ] " :=
    (freq_ x (cons (n, x) (cons y nil))) : qc_scope.
  Notation " 'freq' [ ( n , x ) ; y ; .. ; z ] " :=
    (freq_ x (cons (n, x) (cons y .. (cons z nil) ..))) : qc_scope.
  Notation " 'freq' ( ( n , x ) ;; l ) " :=
    (freq_ x (cons (n, x) l)) (at level 1, no associativity) : qc_scope.

End QcDefaultNotation.

(** The original version of QuickChick used [elements], [oneof] and [frequency]
    as the default-argument versions of the corresponding combinators.
    These have since been deprecated in favor of a more consistent
    naming scheme.
*)

(* ================================================================= *)
(** ** Choosing from Intervals *)

(** The combinators above allow us to generate elements by enumeration
    and lifting. However, for numeric data types, we sometimes hope to
    choose from an interval without writing down all the possible
    values.

    Such intervals can be defined on ordered data types, instances of
    [OrdType], whose ordering [leq] satisfies reflexive, transitive,
    and antisymmetric predicates. *)

Existing Class OrdType.

Declare Instance OrdBool : OrdType bool.
Declare Instance OrdNat  : OrdType nat.
Declare Instance OrdZ    : OrdType Z.

(** We also expect the random function to be able to pick every element in any
    given interval. *)

Existing Class ChoosableFromInterval.

(** QuickChick has provided some instances for ordered data types that are
    choosable from intervals, including [bool], [nat], and [Z]. *)
Declare Instance ChooseBool : ChoosableFromInterval bool.
Declare Instance ChooseNat : ChoosableFromInterval nat.
Declare Instance ChooseZ : ChoosableFromInterval Z.

(** [choose l r] generates a value between [l] and [r], inclusive the two
    extremes. It causes a runtime error if [r < l]. *)
Parameter choose :
  forall {A : Type} `{ChoosableFromInterval A}, (A * A) -> G A.

(* ================================================================= *)
(** ** The [Gen] and [GenSized] Typeclasses *)

(** [GenSized] and [Gen] are typeclasses whose instances can be generated
    randomly. More specifically, [GenSized] depends on a generator for any given
    natural number that indicate the size of output. *)
(**
    Class GenSized (A : Type) := { arbitrarySized : nat -> G A }.
    Class Gen (A : Type) := { arbitrary : G A }.
*)

(** Given an instance of [GenSized], we can convert it to [Gen] automatically,
    using [sized] function. *)
Declare Instance GenOfGenSized {A} `{GenSized A} : Gen A.

(** Here are some basic instances for generators: *)
Declare Instance genBoolSized : GenSized bool.
Declare Instance genNatSized  : GenSized nat.
Declare Instance genZSized    : GenSized Z.

Declare Instance genListSized :
  forall {A : Type} `{GenSized A}, GenSized (list A).
Declare Instance genList :
  forall {A : Type} `{Gen A}, Gen (list A).
Declare Instance genOption :
  forall {A : Type} `{Gen A}, Gen (option A).
Declare Instance genPairSized :
  forall {A B : Type} `{GenSized A} `{GenSized B}, GenSized (A*B).
Declare Instance genPair :
  forall {A B : Type} `{Gen A} `{Gen B}, Gen (A * B).

(* ================================================================= *)
(** ** Generators for Data Satisfying Inductive Predicates *)

(** Just as QuickChick provides the [GenSized] and [Gen] typeclasses
    for generators of type [A], it provides constrained variants for
    generators of type [A] such that [P : A -> Prop] holds of all
    generated values.  Since it is not guaranteed that any such [A]
    exist, these generators are partial.  *)
(**
     Class GenSizedSuchThat (A : Type) (P : A -> Prop) :=
       {
         arbitrarySizeST : nat -> G (option A)
       }.

     Class GenSuchThat (A : Type) (P : A -> Prop) :=
       {
         arbitraryST : G (option A)
       }.
*)

(** So, for example, if you have a typing relation
    [has_type : exp -> type -> Prop] for some language, you could,
    given some type [T] as input, write (or derive as we will see later on)
    an instance of [GenSizedSuchThat (fun e => has_type e T)], that produces
    an expression of with type [T].

    Calling [arbitraryST] through such an instance would require
    making an explicit application to [@arbitraryST] as follows:

    @arbitraryST _ (fun e => has_type e T) _
]]
    where the first placeholder is the type of expressions [exp]
    and the second placeholder is the actual instance to be inferred.

    To avoid this, QuickChick also provides convenient notation to call
    by providing only the predicate [P] that constraints the generation.
    The typeclass constraint is inferred. *)

Notation "'genST' x" := (@arbitraryST _ x _) (at level 70).

(* ################################################################# *)
(** * Shrinking *)

(* ================================================================= *)
(** ** The [Shrink] Typeclass *)

(** [Shrink] is a typeclass whose instances have an operation for
    shrinking larger elements to smaller ones, allowing QuickChick to
    search for a minimal counter example when errors occur. *)
(**
    Class Shrink (A : Type) :=
      {
        shrink : A -> list A
      }.
*)

(** Default shrinkers for some basic datatypes: *)
Declare Instance shrinkBool : Shrink bool.
Declare Instance shrinkNat : Shrink nat.
Declare Instance shrinkZ : Shrink Z.

Declare Instance shrinkList {A : Type} `{Shrink A} : Shrink (list A).
Declare Instance shrinkPair {A B} `{Shrink A} `{Shrink B} : Shrink (A * B).
Declare Instance shrinkOption {A : Type} `{Shrink A} : Shrink (option A).

(* ================================================================= *)
(** ** The [Arbitrary] Typeclass *)

(** The [Arbitrary] typeclass combines generation and shrinking. *)
(**
    Class Arbitrary (A : Type) `{Gen A} `{Shrink A}.
*)

(* ================================================================= *)
(** ** The Generator Typeclass Hierarchy *)

(**
                            GenSized
                               |
                               |
                              Gen   Shrink
                                \    /
                                 \  /
                               Arbitrary
*)

(** If a type has a [Gen] and a [Shrink] instance, it automatically gets
    an [Arbitrary] one. *)
Declare Instance ArbitraryOfGenShrink :
  forall {A} `{Gen A} `{Shrink A}, Arbitrary A.

(* ################################################################# *)
(** * Checkers *)

(* ================================================================= *)
(** ** Basic Definitions *)

(** [Checker] is the opaque type of QuickChick properties. *)
Parameter Checker : Type.

(** The [Checkable] class indicates we can check a type A. *)
(**
    Class Checkable (A : Type) : Type :=
      {
        checker : A -> Checker
      }.
*)

(** Boolean checkers always pass or always fail. *)
Declare Instance testBool : Checkable bool.

(** The unit checker is always discarded (that is, it represents a
    useless test).  It is used, for example, in the implementation of
    the "implication [Checker]" combinator [==>]. *)
Declare Instance testUnit : Checkable unit.

(** Given a generator for showable [A]s, construct a [Checker]. *)
Parameter forAll :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A)  (pf : A -> prop), Checker.

(** A variant of [forAll] that provides evidence that the generated
    values are members of the semantics of the generator. (Such evidence
    can be useful when constructing dependently typed data, such as
    bounded integers.) *)
Parameter forAllProof :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A)  (pf : forall (x : A), semGen gen x -> prop), Checker.

(** Given a generator and a shrinker for showable [A]s, construct a
    [Checker]. *)
Parameter forAllShrink :
  forall {A prop : Type} `{Checkable prop} `{Show A}
         (gen : G A) (shrinker : A -> list A) (pf : A -> prop), Checker.

(** Lift ([Show], [Gen], [Shrink]) instances for [A]
    to a [Checker] for functions [A] -> prop.  This is what makes it
    possible to write (for some example property [foo := fun x => x >?
    0], say) [QuickChick foo] instead of [QuickChick (forAllShrink
    arbitrary shrink foo)]. *)
Declare Instance testFun :
  forall {A prop : Type} `{Show A} `{Arbitrary A} `{Checkable prop},
    Checkable (A -> prop).

(** Lift products similarly. *)
Declare Instance testProd :
  forall {A : Type} {prop : A -> Type} `{Show A} `{Arbitrary A}
         `{forall x : A, Checkable (prop x)},
    Checkable (forall (x : A), prop x).

(** Lift polymorphic functions by instantiating to 'nat'. :-) *)
Declare Instance testPolyFun :
  forall {prop : Type -> Type} `{Checkable (prop nat)},
    Checkable (forall T, prop T).

(* ================================================================= *)
(** ** Checker Combinators *)

(** Print a specific string if the property fails. *)
Parameter whenFail :
  forall {prop : Type} `{Checkable prop} (str : string), prop -> Checker.

(** Record an expectation that a property should fail, i.e.
    the property will fail if all the tests succeed. *)
Parameter expectFailure :
  forall {prop: Type} `{Checkable prop} (p: prop), Checker.

(** Collect statistics across all tests. *)
Parameter collect :
  forall {A prop : Type} `{Show A} `{Checkable prop} (x : A),
    prop -> Checker.

(** Set the reason for failure.  Will only count shrinks as valid if
    they preserve the tag. *)
Parameter tag :
  forall {prop : Type} `{Checkable prop} (t : string), prop -> Checker.

(** Form the conjunction / disjunction of a list of checkers. *)
Parameter conjoin : forall (l : list Checker), Checker.
Parameter disjoin : forall (l : list Checker), Checker.

(** Define a checker for a conditional property. Invalid generated
    inputs (ones for which the antecedent fails) are discarded. *)
Parameter implication :
  forall {prop : Type} `{Checkable prop} (b : bool) (p : prop), Checker.

(** Notation for implication. Clashes with many other notations in
    other libraries, so it lives in its own module. Note that this
    includes the notations for the generator combinators above
    to avoid needing to import two modules.
 *)
Module QcNotation.
  Export QcDefaultNotation.

  Notation "x ==> y" :=
    (implication x y) (at level 55, right associativity)
    : Checker_scope.
End QcNotation.

(* ################################################################# *)
(** * Decidability *)

(* ================================================================= *)
(** ** The [Dec] Typeclass *)
(** Decidability typeclass using ssreflect's 'decidable'. *)
(**
     Class Dec (P : Prop) : Type := { dec : decidable P }.
*)

(** Decidable properties are Checkable. *)
Declare Instance testDec {P} `{H : Dec P} : Checkable P.

(** Logic Combinator instances. *)
Declare Instance Dec_neg {P} {H : Dec P} : Dec (~ P).
Declare Instance Dec_conj {P Q} {H : Dec P} {I : Dec Q} : Dec (P /\ Q).
Declare Instance Dec_disj {P Q} {H : Dec P} {I : Dec Q} : Dec (P \/ Q).

(** A convenient notation for coercing a decidable proposition to a [bool]. *)
Notation "P '?'" := (match (@dec P _) with
                     | left _ => true
                     | right _ => false
                     end) (at level 100).

(* ================================================================= *)
(** ** The [Dec_Eq] Typeclass *)

(**
     Class Dec_Eq (A : Type) :=
       {
         dec_eq : forall (x y : A), decidable (x = y)
       }.
*)

(** Automation and conversions for Dec. *)
Declare Instance Eq__Dec {A} `{H : Dec_Eq A} (x y : A) : Dec (x = y).

(** Since deciding equalities is a very common requirement in testing,
    QuickChick provides a tactic that can define instances of the form
    [Dec (x = y)].
*)
(**
     Ltac dec_eq.
*)

(** QuickChick also lifts common decidable instances to the [Dec] typeclass. *)
Declare Instance Dec_eq_bool (x y : bool) : Dec (x = y).
Declare Instance Dec_eq_nat (m n : nat) : Dec (m = n).
Declare Instance Dec_eq_opt (A : Type) (m n : option A)
`{_ : forall (x y : A), Dec (x = y)} : Dec (m = n).
Declare Instance Dec_eq_prod (A B : Type) (m n : A * B)
`{_ : forall (x y : A), Dec (x = y)}
`{_ : forall (x y : B), Dec (x = y)}
: Dec (m = n).
Declare Instance Dec_eq_list (A : Type) (m n : list A)
`{_ : forall (x y : A), Dec (x = y)} : Dec (m = n).

Declare Instance Dec_ascii (m n : Ascii.ascii) : Dec (m = n).
Declare Instance Dec_string (m n : string) : Dec (m = n).

(* ################################################################# *)
(** * Automatic Instance Derivation *)

(** QuickChick allows the automatic derivation of typeclass instances
    for simple types:

       Derive <class> for T.

    Here [<class>] must be one of [GenSized], [Shrink], [Arbitrary],
    or [Show], and [T] must be an inductive defined datatype (think
    Haskell/OCaml).

    To derive multiple classes at once, write:

       Derive (<class>,...,<class>) for T.
*)

(** QuickChick also allows for the automatic derivation of generators
    satisfying preconditions in the form of inductive relations:

     Derive ArbitrarySizedSuchThat for (fun x => P x1 ... x .... xn).

    <P> must be an inductively defined relation.
    <x> is the function to be generated.
    <x1...xn> are (implicitly universally quantified) variable names.
*)

(** QuickChick also allows automatic derivations of proofs of
    correctness of its derived generators! For more, look
    at:

    - A paper on deriving QuickChick generators for a large class of
      inductive relations.
      http://www.cis.upenn.edu/~llamp/pdf/GeneratingGoodGenerators.pdf

    - Leo's PhD dissertation.
      https://lemonidas.github.io/pdf/Leo-PhD-Thesis.pdf

    - examples/DependentTest.v

*)

(* ################################################################# *)
(** * Top-level Commands and Settings *)

(** QuickChick provides a series of toplevel commands to sample
    generators, test properties, and derive useful typeclass
    instances. *)

(** The [Sample] command samples a generator. The argument [g] needs
    to have type [G A] for some showable type [A]. *)
(**
    Sample g.
*)

(** The main testing command, [QuickChick], runs a test. The argument
    [prop] must belong to a type that is an instance of [Checkable]. *)
(**
     QuickChick prop.
*)

(** QuickChick uses arguments to customize execution. *)
Record Args :=
  MkArgs
    {
      (* Re-execute a test. *)
      (* Default: None *)
      replay     : option (RandomSeed * nat);
      (* Maximum number of successful tests to run. *)
      (* Default: 10000 *)
      maxSuccess : nat;
      (* Maximum number of discards to accept. *)
      (* Default: 20000 *)
      maxDiscard : nat;
      (* Maximum number of shrinks to perform before terminating. *)
      (* Default : 1000 *)
      maxShrinks : nat;
      (* Maximum size of terms to generate (depth). *)
      (* Default : 7 *)
      maxSize    : nat;
      (* Verbosity. Note: Doesn't do much... *)
      (* Default true. *)
      chatty     : bool
    }.

(** Instead of record updates, you should overwrite extraction constants. *)
(**
   Extract Constant defNumTests    => "10000".
   Extract Constant defNumDiscards => "(2 * defNumTests)".
   Extract Constant defNumShrinks  => "1000".
   Extract Constant defSize        => "7".
*)

(* ################################################################# *)
(** * The [quickChick] Command-Line Tool *)

(** QuickChick comes with a command-line tool that supports:
      - Batch processing, compilation and execution of tests
      - Mutation testing
      - Sectioning of tests and mutants

    Comments that begin with an exclamation mark are special to the
    QuickChick command-line tool parser and signify a test, a section,
    or a mutant. *)

(* ================================================================= *)
(** ** Test Annotations *)

(** A test annotation is just a [QuickChick] command wrapped inside
    a comment with an exclamation mark.

    (*! QuickChick prop. *)

   Only tests that are annotated this way will be processed. Only property
   names are allowed. *)

(* ================================================================= *)
(** ** Mutant Annotations *)

(** A mutant annotation consists of 4 components. First an anottation
    that signifies the beginning of the mutant [(*! *)]. That is followed
    by the actual code. Then, we can include an optional annotation
    (in a comment with double exclamation marks) that corresponds to
    the mutant names. Finally, we can add a list of mutations inside
    normal annotated comments. Each mutant should be able to be
    syntactically substituted in for the normal code.

    (*! *)
    Normal code
    (*!! mutant-name *)
    (*! mutant 1 *)
    (*! mutant 2 *)
    ... etc ...
*)

(* ================================================================= *)
(** ** Section Annotations *)

(** To organize larger developments better, we can group together
    different tests and mutants in sections. A section annotation is
    a single annotation that defines the beginning of the section
    (which lasts until the next section or the end of the file).

      (*! Section section-name *)

    Optionally, one can include an extends clause

      (*! Section section-name *)(*! extends other-section-name *)

   This signifies that the section being defined also
   contains all tests and mutants from [other-section-name].
*)

(* ================================================================= *)
(** ** Command-Line Tool Flags *)

(** The QuickChick command line tool can be passed the following options:
    - [-s <section>]: Specify which sections properties and mutants to test
    - [-v]: Verbose mode for debugging
    - [-failfast]: Stop as soon as a problem is detected
    - [-color]: Use colors on an ANSI-compatible terminal
    - [-cmd <command>]: What compile command is used to compile the current directory
      if it is not [make]
    - [-top <name>]: Specify the name of the top-level logical module. That should
      be the same as the [-Q] or [-R] directive in [_CoqProject] or [Top]
      which is the default
    - [-ocamlbuild <args>]: Any arguments necessary to pass to ocamlbuild when
      compiling the extracted code (e.g. linked libraries)
    - [-nobase]: Pass this option to not test the base mutant
    - [-m <number>]: Pass this to only test a mutant with a specific id number
    - [-tag <name>]: Pass this to only test a mutant with a specific tag
    - [-include <name>]: Specify a to include in the compilation
    - [-exclude <names>]: Specify files to be excluded from compilation. Must be the last argument passed.
*)

(* ################################################################# *)
(** * Deprecated Features *)

(** The following features are retained for backward compatibility,
    but their use is deprecated. *)

(** Use the monad notations from [coq-ext-lib] instead of the
    [QcDoNotation] sub-module: *)
Module QcDoNotation.
  Notation "'do!' X <- A ; B" :=
    (bindGen A (fun X => B))
    (at level 200, X ident, A at level 100, B at level 200).
  Notation "'do\'' X <- A ; B" :=
    (bindGen' A (fun X H => B))
    (at level 200, X ident, A at level 100, B at level 200).
  Notation "'doM!' X <- A ; B" :=
    (bindGenOpt A (fun X => B))
    (at level 200, X ident, A at level 100, B at level 200).
End QcDoNotation.

End QuickChickSig.

(* Tue Oct 9 11:47:31 EDT 2018 *)


Require Export Functions.

Axiom Replacement :
  forall f X, M X ->  Un f -> M (Image f X).

Theorem cap_set X Y (X_ : M X)  :
    M (X ∩ Y).
Proof.
  pose (fun p => exists x, p = <|x,x|> /\ x ∈ X /\ x ∈ Y) as H0.
  pose ({| H0 |}) as f.
  have Un_f : Un f.
    rewrite /Un => x y z x_ y_ z_ xy_f xz_f.
    have xy_ : M <|x,y|> by apply orderd_set.
    have xz_ : M <|x,z|> by apply orderd_set.
    move /(in_cls _ _ xy_) : xy_f => [x0 [xyxx [xX xY]]].
    move /(in_cls _ _ xz_) : xz_f => [z0 [xzxx [_ zY]]].
    have x0_ : M x0 by is_set.
    have z0_ : M z0 by is_set.
    move /(orderd_eq x y x0 x0 x_ y_ x0_ x0_) : xyxx => [l r]; subst x y.
    move /(orderd_eq x0 z z0 z0 x0_ z_ z0_ z0_) : xzxx => [l r]; subst x0 z.
    done.
  have XY_imfX : X ∩ Y = Image f X.
    equal => i.
    rewrite in_cap.
    split => [[iX iY]|H]; have i_ : M i by is_set.
    + rewrite in_image => //.
      exists i; split => //; split => //.
      rewrite in_cls.
      by exists i.
      by apply orderd_set.
    + move /(in_image f X i i_) : H => [x [x_ [xX xi_f]]].
      have xi_ : M <|x,i|> by (apply orderd_set).
      move /(in_cls _ _ xi_) : xi_f => [j [xijj [jX jY]]].
      have j_ : M j by is_set.
      move /(orderd_eq x i j j x_ i_ j_ j_) : xijj => [xj ij]; subst i.
      done.
  + by rewrite XY_imfX; apply Replacement.
Qed.

Theorem sub_set x y (y_ : M y):
  x ⊂ y -> M x.
Proof.
  move => xy.
  suff x_xy : x = y ∩ x.
    rewrite x_xy.
    by apply cap_set.
  equal => i.
  rewrite in_cap.
  split => [ix | [iy ix]] => //.
  split => //.
  apply xy => //.
Qed.

Definition Separation X P :=
  {| fun x => x ∈ X /\ P x|}.
Notation "{: X | P :}" := (Separation X P) (at level 10).

Theorem in_sep {X P x} :
  x ∈ ({: X | P :}) <-> x ∈ X /\ P x.
Proof.
  split => [H | [xX Px]]; have x_ : M x by is_set.
  + move /in_cls : H; auto.
  + by apply in_cls.
Qed.

Theorem sep_sub X P :
  {: X | P:} ⊂ X.
Proof.
  move => x.
  rewrite in_sep.
  by case.
Qed.

Theorem sep_set X P :
  M X -> M ({: X | P :}).
Proof.
  move => X_.
  apply sub_set with (y := X) => //.
  apply sep_sub.
Qed.

Theorem dom_set f (f_ : M f):
    M (Dom f).
Proof.
  apply sub_set with (y := ⊔ ⊔ f).
  + by apply cups_set; apply cups_set.
  + move => i H.
    have i_ : M i by is_set.
    move /(in_dom _ _ i_) : H => [y [y_ iy_f]].
    rewrite in_cups.
    exists (Single i ); split.
    apply single_refl => //.
    apply in_cups.
    exists <|i,y|>; split => //.
    apply in_orderd => //.
    apply single_set => //.
    left => //.
Qed.

Theorem ran_set f (f_ : M f) :
    M (Ran f).
Proof.
  apply sub_set with (y := ⊔ ⊔ f).
  + by apply cups_set; apply cups_set.
  + move => i H.
    have i_ : M i by is_set.
    move /(in_ran f i i_) : H => [x [x_ xi_f]].
    apply in_cups.
    exists (Pair x i); split.
    apply in_pair => //; right => //.
    apply in_cups.
    exists <|x,i|>; split => //.
    apply in_orderd => //.
    apply pair_set => //.
    right => //.
Qed.

Theorem cup_set x y (x_ : M x) (y_ : M y):
  M (x ∪ y).
Proof.
  apply sub_set with (y := ⊔ (Pair x y)).
  + by apply cups_set; apply pair_set.
  + move => i H.
    move /in_cup : H => H.
    apply in_cups.
    case H => [ix | iy].
    - exists x; split => //.
      apply in_pair => //; left => //.
    - exists y; split => //.
      apply in_pair => //; right => //.
Qed.

Theorem product_set x y (x_ : M x) (y_ : M y) :
    M (x × y).
Proof.
  apply sub_set with (y := Power (Power (x ∪ y))).
  + by apply pow_set; apply pow_set; apply cup_set.
  + move => i H.
    have i_ : M i by is_set.
    move /(in_prod x y i) : H => [x0 [y0 [x0_ [y0_ [i_xy [xx yy]]]]]].
    apply in_pow => //.
    move => j ji.
    apply in_pow => //; is_set.
    move => k kj.
    apply in_cup.
    subst i.
    have j_ : M j by  is_set.
    have k_ : M k by is_set.
    move /(in_orderd x0 y0 j x0_ y0_ j_) : ji => [jxx | jxy]; subst j.
    - by move /(in_single x0 k k_) : kj ->; left.
    - by case /(in_pair x0 y0 k k_) : kj => [kx|ky]; [left|right]; subst k.
Qed.

Theorem not_empty x :
  x <> ∅ <-> exists y, y ∈ x.
Proof.
  split => [Hx|[y yx] Hx].
  + apply NNPP => F.
    move /not_ex_all_not : F => H.
    apply Hx.
    equal => i.
    split => [ix | F].
    - case ((H i) ix).
    - suff i0 : ~ i ∈ ∅.
        case (i0 F).
      apply notin_empty; is_set.
  + suff F : (~ y ∈ ∅).
      by apply F; subst x.
    apply notin_empty; is_set.
Qed.

Theorem caps_set X :
  X <> ∅ -> M (⊓ X).
Proof.
  move /not_empty => [x xX].
  apply sub_set with (y := x).
  + is_set.
  + move => i H.
    have i_ : M i by is_set.
    by move /(in_caps X i i_) : H ; apply.
Qed.

Definition Inverse f :=
  {: (Ran f) × (Dom f) |
   fun u => exists x y, M x /\ M y /\ u = <|x,y|> /\ <|y,x|> ∈ f
  :}.

Theorem in_inv f u :
  u ∈ Inverse f <-> exists x y, M x /\ M y /\ u = <|x,y|> /\ <|y,x|> ∈ f.
Proof.
  split => [H | [x [y [x_ [y_ [u_xy yx_f]]]]]].
  + have u_ : M u by is_set.
    move /(in_cls _ u u_) : H => [H [x [y [x_ [y_ [u_xy yx_f]]]]]].
    by exists x; exists y.
  + rewrite in_cls => //.
    * split.
      - rewrite in_prod.
        exists x; exists y.
        split => //; split => //; split => //; split.
        apply in_ran => //; exists y => //.
        apply in_dom => //; exists x => //.
      - by exists x; exists y.
    * subst u; apply orderd_set => //.
Qed.

Definition Un₁ X := Un X /\ Un (Inverse X).

Definition Value f x :=
  ⊓ {| fun y => <|x,y|> ∈ f|}.
Notation "f [ x ]" := (Value f x) (at level 5).

Theorem value_set f x :
  x ∈ Dom f -> M f[x].
Proof.
  move => H.
  apply caps_set.
  apply not_empty.
  have x_ : M x by is_set.
  move /(in_dom f x x_) : H => [y [y_ xy_f]].
  exists y; apply in_cls => //.
Qed.

Goal forall x, M x -> ⊓ (Single x) = x.
Proof.
  move => x x_.
  equal => i.
  split => [H|H]; have i_ :  M i by is_set.
  + move /(in_caps (Single x) i i_) : H.
    apply.
    apply single_refl => //.
  + apply in_caps => //.
    move => y y_xx.
    have y_ : M y by is_set.
    move /(in_single x y y_) : y_xx -> => //.
Qed.

Theorem in_value f x y (y_ : M y):
  Un f -> x ∈ Dom f -> <|x, y|> ∈ f <-> y = f[x].
Proof.
  move => unf x_domf.
  have H : forall z, M z -> <|x,z|> ∈ f -> z = f[x].
    move => z z_ zx_f.
    equal => i.
    split => [iz|i_fx]; have i_ : M i by is_set.
    - rewrite in_cls => //.
      move => j Hj.
      have j_ : M j by is_set.
      move /(in_cls _ j j_) : Hj => xj_f.
      suff yj : z = j.
        by subst z.
      apply unf with (x := x) => // ; is_set.
    - move /(in_cls _ i i_) : i_fx.
      apply.
      apply in_cls => //.
- split => [xy_f|y_fx].
  + apply H => //.
  + subst y.
    have x_ : M x by is_set.
    case /(in_dom f x x_) : x_domf => [z [z_ xz_f]].
    by move : (H z z_ xz_f) <-.
Qed.

Theorem value_in f x :
  Un f -> x ∈ Dom f -> <|x, f[x]|> ∈ f.
Proof.
  move =>  unf x_domf.
  have x_ : M x by is_set.
  have H0 : exists y, M y /\ <|x,y|> ∈ f.
    move /(in_dom f x x_) : x_domf  => [y [y_ xy_f]].
    by exists y.
  move : H0 => [y [y_ xy_f]].
  suff y_fx : y = f[x].
    by subst y.
  apply in_value => //.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export representant_unitaire.
Set Implicit Arguments.
Unset Strict Implicit.
#[export] Hint Resolve distance_non_nulle scalaire_positif: geo.

Definition distance (A B : PO) := sqrt (scalaire (vec A B) (vec A B)).

Lemma distance_pos : forall A B : PO, distance A B >= 0.
unfold distance in |- *; intros; auto with geo real.
Qed.

Lemma distance_sym : forall A B : PO, distance A B = distance B A.
unfold distance in |- *; intros; auto.
VReplace (vec B A) (mult_PP (-1) (vec A B)).
Simplscal.
replace (-1 * -1 * scalaire (vec A B) (vec A B)) with
 (scalaire (vec A B) (vec A B)); try ring.
Qed.

Lemma distance_refl : forall A B : PO, distance A B = 0 <-> A = B.
unfold distance in |- *; intros; red in |- *.
split; [ idtac | try assumption ].
intros H; try assumption.
apply distance_nulle.
RReplace 0 (0 * 0).
rewrite <- H; auto.
symmetry  in |- *.
apply def_sqrt; auto with geo real.
intros.
rewrite <- H; auto.
VReplace (vec A A) (mult_PP (-0) (vec A B)).
Simplscal.
replace (-0 * -0 * scalaire (vec A B) (vec A B)) with 0; try ring.
try exact sqrt_0.
Qed.

Lemma distance_refl1 : forall A B : PO, distance A B = 0 :>R -> A = B :>PO.
intros.
elim (distance_refl A B); auto.
Qed.

Lemma distance_refl2 : forall A B : PO, A = B :>PO -> distance A B = 0 :>R.
intros.
elim (distance_refl A B); auto.
Qed.
#[export] Hint Resolve distance_refl1 distance_refl2: geo.

Lemma caract_representant_unitaire :
 forall A B C : PO,
 A <> B ->
 vec A C = representant_unitaire (vec A B) ->
 vec A C = mult_PP (/ distance A B) (vec A B).
unfold distance in |- *; intros.
cut
 (alignes A B C /\
  scalaire (vec A C) (vec A C) = 1 /\ scalaire (vec A B) (vec A C) >= 0);
 intros.
elim H1; intros H2 H3; elim H3; intros H4 H5; try clear H3 H1; try exact H5.
halignes H2 k.
rewrite H1 in H4.
cut (/ scalaire (vec A B) (vec A B) = k * k); intros.
cut (k = sqrt (/ scalaire (vec A B) (vec A B))); intros.
rewrite H1; rewrite H6.
rewrite sqrt_Rinv; auto with geo real.
apply inversion_sqr; auto with geo real.
rewrite H1 in H5.
replace k with
 (k * scalaire (vec A B) (vec A B) * / scalaire (vec A B) (vec A B)).
replace (k * scalaire (vec A B) (vec A B)) with
 (scalaire (vec A B) (mult_PP k (vec A B))).
apply Rmult_pos; auto with geo real.
Simplscal.
field; auto with geo.
replace (/ scalaire (vec A B) (vec A B)) with
 (1 * / scalaire (vec A B) (vec A B)).
rewrite <- H4.
Simplscal.
field; auto with geo.
field; auto with geo.
apply def_representant_unitaire2; auto.
Qed.

Lemma distance_vecteur :
 forall A B : PO,
 A <> B -> vec A B = mult_PP (distance A B) (representant_unitaire (vec A B)).
unfold distance in |- *; intros.
elim existence_representant_unitaire with (A := A) (B := B);
 [ intros C H0; try clear existence_unitaire; try exact H0 | auto ].
rewrite <- H0; auto.
rewrite (caract_representant_unitaire (A:=A) (B:=B) (C:=C)); auto.
unfold distance in |- *.
cut (sqrt (scalaire (vec A B) (vec A B)) <> 0); intros.
Fieldvec (sqrt (scalaire (vec A B) (vec A B))).
auto with *.
Qed.

Lemma dist_non_nulle : forall A B : PO, distance A B <> 0 -> A <> B.
unfold distance in |- *; red in |- *; intros.
apply H.
rewrite H0.
replace (scalaire (vec B B) (vec B B)) with 0.
rewrite sqrt_0; ring.
replace (vec B B) with (mult_PP 0 (vec A B)).
Simplscal.
Ringvec.
Qed.
#[export] Hint Resolve distance_pos dist_non_nulle: geo.

Lemma distincts_dist_non_nulle : forall A B : PO, A <> B -> distance A B <> 0.
unfold distance in |- *; intros; red in |- *; intros.
apply H.
apply distance_nulle.
rewrite <- (def_sqrt (scalaire (vec A B) (vec A B))); auto with geo.
rewrite H0; ring.
Qed.
#[export] Hint Resolve distincts_dist_non_nulle: geo.

Lemma isometrie_distinct :
 forall A B A' B' : PO, A <> B -> distance A B = distance A' B' -> A' <> B'.
intros.
apply dist_non_nulle; rewrite <- H0; auto with geo.
Qed.

Lemma carre_scalaire_distance :
 forall A B : PO, scalaire (vec A B) (vec A B) = distance A B * distance A B.
unfold distance in |- *; intros.
rewrite def_sqrt; auto with geo.
Qed.

Lemma carre_egalite_distance :
 forall A B C D : PO,
 distance A B * distance A B = distance C D * distance C D ->
 distance A B = distance C D.
intros.
apply resolution; auto with geo.
Qed.

Lemma distance_carre :
 forall A B C D : PO,
 Rsqr (distance A B) = Rsqr (distance C D) -> distance A B = distance C D.
unfold Rsqr in |- *; intros.
apply carre_egalite_distance; auto with geo.
Qed.
#[export] Hint Resolve carre_egalite_distance distance_carre: geo.

Lemma carre_scalaire_egalite_distance :
 forall A B C D : PO,
 scalaire (vec A B) (vec A B) = scalaire (vec C D) (vec C D) ->
 distance A B = distance C D.
intros.
apply carre_egalite_distance.
repeat rewrite <- carre_scalaire_distance; auto with geo.
Qed.

Lemma unitaire_distincts2 : forall A B : PO, distance A B = 1 -> A <> B.
intros.
apply dist_non_nulle.
rewrite H.
discrR.
Qed.
#[export] Hint Resolve unitaire_distincts2: geo.

Lemma distance_1_representant :
 forall A B : PO,
 distance A B = 1 -> vec A B = representant_unitaire (vec A B).
intros.
apply def_representant_unitaire; auto with geo.
rewrite carre_scalaire_distance; rewrite H; ring.
Qed.

Lemma distance_1_carre_scalaire :
 forall A B : PO, distance A B = 1 -> scalaire (vec A B) (vec A B) = 1.
intros.
rewrite carre_scalaire_distance.
rewrite H; ring.
Qed.

Lemma carre_scalaire_1_distance :
 forall A B : PO, scalaire (vec A B) (vec A B) = 1 -> distance A B = 1.
intros.
unfold distance in |- *.
rewrite H.
rewrite sqrt_1; auto with geo.
Qed.
#[export] Hint Resolve carre_scalaire_1_distance distance_1_carre_scalaire
  distance_1_representant: geo.

Lemma milieu_distance :
 forall A B I : PO, I = milieu A B -> distance I A = distance I B.
intros.
apply carre_scalaire_egalite_distance.
rewrite <- (milieu_vecteur (A:=A) (B:=B) (M:=I)); auto with geo.
replace (vec I A) with (mult_PP (-1) (vec A I)); [ idtac | Ringvec ].
Simplscal.
Qed.
#[export] Hint Resolve milieu_distance: geo.

Lemma egalite_vecteur_distance :
 forall A B C D : PO, vec A B = vec C D -> distance A B = distance C D :>R.
intros.
apply carre_scalaire_egalite_distance.
rewrite H; auto.
Qed.

Lemma colinearite_distance :
 forall (k : R) (A B C D : PO),
 vec C D = mult_PP k (vec A B) :>PP -> distance C D = Rabs k * distance A B.
unfold distance in |- *; intros.
rewrite H; Simplscal.
replace (k * k) with (Rsqr k); auto with real.
rewrite sqrt_mult; auto with real geo.
rewrite sqrt_Rsqr_abs; ring.
Qed.
#[export] Hint Resolve colinearite_distance: geo.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import RobustTraceProperty.
Require Import UcoRobustPreservation.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section RobustSafetyPreservation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  Variable T_evs S_evs : Events.
  Variable T_end S_end : Endstates.

  Local Definition trace__S := @trace S_evs S_end.
  Local Definition finpref__S := @finpref S_evs S_end.
  Local Definition trace__T := @trace T_evs T_end.
  Local Definition finpref__T := @finpref T_evs T_end.

  Local Definition prop__S := prop trace__S.
  Local Definition Safety__S := @Safety S_evs S_end.
  Local Definition prop__T := prop trace__T.
  Local Definition Safety__T := @Safety T_evs T_end.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition sat__S := sat Source_Semantics.
  Local Definition sat__T := sat Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  Variable σ : prop__T -> prop__S.
  Variable τ : prop__S -> prop__T.

  Local Definition σRP := σRP compilation_chain
                              Source_Semantics Target_Semantics
                              σ.

  Definition Cl_τRP := τRP compilation_chain
                           Source_Semantics Target_Semantics
                           (Cl ∘ τ).

  Theorem σSafetyP_Cl_τTP :
    (Adjunction_law τ σ) ->
    ( (forall P (π__T : prop__T), Safety π__T -> σRP P π__T) <->
      (forall P (π__S : prop__S), Cl_τRP P π__S)).
  Proof.
    move => H_adj.
    setoid_rewrite <- (@uco_adjuncts _ _ _ _ _ _ _ σ τ safety_uco).
    rewrite -Safety_Cl_prop.
    reflexivity.
    assumption.
  Qed.

End RobustSafetyPreservation.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


(* Logically atomic triple *)

From iris.base_logic Require Export fancy_updates.
From iris.program_logic Require Export hoare weakestpre.
From iris.prelude Require Export coPset.
Import uPred.

Section atomic.
  Context `{irisG Λ Σ} {A: Type}.

  (* TODO RJ: IMHO it would make more sense to have the outer mask first, after all, that's what the shifts "starts" with. *)
  (* logically atomic triple: <x, α> e @ E_i, E_o <v, β x v> *)
  Definition atomic_triple
             (α: A → iProp Σ) (* atomic pre-condition *)
             (β: A → val _ → iProp Σ) (* atomic post-condition *)
             (Ei Eo: coPset) (* inside/outside masks *)
             (e: expr _) : iProp Σ :=
    (∀ P Q, (P ={Eo, Ei}=> ∃ x:A,
                       α x ∗
                       ((α x ={Ei, Eo}=∗ P) ∧
                        (∀ v, β x v ={Ei, Eo}=∗ Q v))
     ) -∗ {{ P }} e @ ⊤ {{ Q }})%I.
End atomic.


Require Import Coq.Lists.List.
Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.Rbasic_fun.
Require Import Coq.Reals.Rtrigo_def.
Require Import Coq.Reals.Ranalysis1.
Require Import Coq.micromega.Psatz.
Require Import ExtLib.Structures.Applicative.
Require Import ChargeCore.Logics.ILogic.
Require Import ChargeCore.Logics.ILEmbed.
Require Import ChargeCore.Tactics.Tactics.
Require Import ChargeCore.Tactics.Lemmas.
Require Import SLogic.Logic.
Require Import SLogic.Instances.
Require Import SLogic.BasicProofRules.
Require Import SLogic.Continuous.
Require Import SLogic.ContinuousInstances.
Require Import SLogic.BoundingFunctions.
Require Import SLogic.RobustnessISS.
Require Import SLogic.Lifting.
Require Import SLogic.LTLNotation.
Require Import SLogic.Tactics.
Require Import SLogic.Util.
Require Import SLogic.Arithmetic.

Local Open Scope R_scope.
Local Open Scope LTL_scope.

Set SMT Solver "z3".

Record state : Type :=
  { v : R; (* Actual velocity *)
    v_sense : R; (* Velocity used by the monitor *)
    a : R; (* Actual acceleration *)
    dv : R; (* Disturbance from velocity sensor *)
    t : R; (* Time *)
    T : R (* Timer *)
  }.

Section VelocityMonitor.

  (* Time between executions of the monitor. *)
  Variable delta : R.
  Axiom delta_gt_0 : (delta > 0)%R.
  (* The monitor enforces an upper bound of 0. *)

  (* Monitor logic *)
  Definition Monitor : StateProp state :=
    a `* pure delta `+ v_sense `<= pure 0.

  (* Sensor error *)
  Definition Sense : StateProp state :=
    v_sense `= v `+ dv.

  (* Reset the timer when the discrete transition runs. *)
  Definition ResetTimer : StateProp state :=
    T `= t.

  (* Full discrete transition *)
  Definition Discr : ActionProp state :=
    (Sense //\\ Monitor //\\ ResetTimer)! //\\
    Unchanged (v :: t :: nil).

  (* Evolution predicate *)
  Definition w : SimpleDiffProp state (v :: a :: t :: nil) :=
    D v `= (fun _ => a) //\\ D a `= pure 0 //\\
    D t `= pure 1 //\\ (fun _ => t `- T `<= pure delta).

  (* Continuous transition *)
  Definition World : ActionProp state :=
    SimpleContinuous state w //\\
    Unchanged (dv :: v_sense :: T :: nil).

  (* Full system transition *)
  Definition Next : ActionProp state :=
    Discr \\// World.

  (* Inductive invariant *)
  Definition IndInv : StateProp state :=
    a `* ((pure delta) `- (t `- T)) `<= `- (v `+ dv).

  (* Full system specification. *)
  Definition Spec : TraceProp state :=
    [!IndInv] //\\ [][Next].

  (* The following seems to be necessary for breaking the
     abstraction. It would be nice if we didn't need to do
     this. *)
  Local Transparent ILInsts.ILFun_Ops.
  Local Transparent ILInsts.ILPre_Ops.

  (* Proof that our inductive invariant is in fact
     an invariant. *)
  Lemma Spec_IndInv :
    Spec |-- [][!IndInv].
  Proof.
    eapply discrete_induction.
    { charge_assumption. }
    { charge_assumption. }
    { charge_clear. apply always_tauto.
      rewrite next_starts_pre. reason_action_tac.
      destruct pre_st as [v1 v_sense1 a1 dv1 t1 T1].
      destruct post_st as [v2 v_sense2 a2 dv2 t2 T2].
      unfold IndInv, Next, World, Discr, Monitor, Sense,
      Unchanged, ResetTimer, pre, post, _liftn.
      simpl. intros. destruct H0.
      { decompose [and] H0. clear H0. subst.
        psatzl R. }
      { decompose [and] H0. clear H0. subst.
        assert (v2 = v1 + a1 * (t2 - t1)) by admit.
        assert (a2 = a1) by admit.
        psatz R. } }
  Admitted.

  (* Essentially states that the initial condition
     always holds. *)
  Lemma Spec_always :
    Spec |-- []Spec.
  Proof.
    unfold Spec. rewrite <- always_and. charge_split.
    { apply Spec_IndInv. }
    { rewrite always_idemp. charge_assumption. }
  Qed.

  (* Our bounding functions. *)
  Definition mu : R -> R -> R :=
    fun d t => Rabs d * exp (-t/delta).
  Definition gamma : R -> R := Ranalysis1.id.

  (* Spec satisfies [robust]. *)
  Lemma Spec_robust :
    Spec |-- robust state (lift2 Rmax (`-dv) `0)
                          (`Rmax v `0)
                          t mu gamma.
  Proof.
    unfold Spec, robust.
    repeat charge_split.
    { apply embedPropR. apply KL_fun_abs_exp.
      pose proof delta_gt_0. apply RIneq.Rinv_0_lt_compat.
      psatzl R. }
    { apply embedPropR. apply K_inf_fun_id. }
    { exists_val_now OC_0. exists_val_now t_0.
      { charge_intros.
        charge_assert ([][!IndInv]).
        { rewrite Spec_IndInv. charge_assumption. }
        charge_intros. eapply discrete_induction.
        { clear_not_always. repeat rewrite always_and.
          charge_assumption. }
        { (* Base case *)
          reason_action_tac.
          destruct pre_st as [v1 v_sense1 a1 dv1 t1 T1].
          destruct post_st as [v2 v_sense2 a2 dv2 t2 T2].
          unfold IndInv, Monitor, Sense, ResetTimer,
          pre, _liftn, gamma, mu, id.
          simpl. intros. subst.
          rewrite RIneq.Rminus_diag_eq; [ | reflexivity ].
          rewrite RIneq.Ropp_0. unfold Rdiv.
          rewrite RIneq.Rmult_0_l. rewrite exp_0.
          rewrite RIneq.Rmult_1_r.
          rewrite Rabs_pos_eq; [ | apply Rmax_r ].
          rewrite <- Rmax_r in H3. psatzl R. }
        { (* Inductive step *)
          charge_clear. apply always_tauto. charge_intros.
          unfold Next. rewrite <- starts_or.
          repeat rewrite land_lor_distr_L. apply lorL.
          { (* Discrete transition *)
            repeat rewrite next_starts_pre.
            repeat rewrite starts_and.
            reason_action_tac.
            destruct pre_st as [v1 v_sense1 a1 dv1 t1 T1].
            destruct post_st as [v2 v_sense2 a2 dv2 t2 T2].
            unfold Discr, Sense, Monitor, ResetTimer,
            Unchanged, pre, post, _liftn, id. simpl. intros.
            intuition congruence. }
          { (* Continuous transition *)
            repeat rewrite next_starts_pre.
            repeat rewrite starts_and.
            reason_action_tac.
            destruct pre_st as [v1 v_sense1 a1 dv1 t1 T1].
            destruct post_st as [v2 v_sense2 a2 dv2 t2 T2].
            unfold IndInv, World, Unchanged,
            pre, post, _liftn, mu, gamma, id.
            simpl. intros.
            assert (v2 = v1 + a1 * (t2 - t1)) by admit.
            assert (a2 = a1) by admit.
            assert (t1 <= t2) by admit.
            assert (T1 <= t1) by admit.
            assert (t2 - T1 <= delta) by admit.
            decompose [and] H. subst.
            apply Rmax_case_strong; intros.
            { pose proof delta_gt_0.
              pose proof H8.
              rewrite <- Rmax_l in H8.
              rewrite <- Rmax_r in H6.
              assert (x <= v1 \/ v1 < x)
                as Hsgn by psatzl R.
              destruct Hsgn as [Hsgn | Hsgn].
              { rewrite Rmax_left in H5; [ | psatzl R ].
                assert (exp (-(t2 - t_0)/delta) =
                        exp (-(t1 - t_0)/delta)*
                        exp(-(t2 - t1)/delta))
                  as Hexp.
                { rewrite <- Exp_prop.exp_plus. f_equal.
                  z3_prove. }
                rewrite Hexp. clear Hexp.
                transitivity
                  ((v1 - x) * exp (- (t2-t1) / delta)
                   + x).
                { pose proof
                       (x_plus_1_le_exp (-(t2-t1)/delta)).
                  admit.
                  (* Some version of Z3 handled this. *) }
                { pose proof
                       (Exp_prop.exp_pos (-(t2-t1)/delta)).
                  psatz R. } }
              { transitivity x.
                { admit.
                  (* Some version of Z3 handled this. *) }
                { pose proof (Rabs_pos OC_0).
                  pose proof
                       (Exp_prop.exp_pos (-(t2-t_0)/delta)).
                  psatz R. } } }
            { rewrite <- Rmax_r in H8. rewrite <- H8.
              pose proof
                   (Exp_prop.exp_pos (-(t2-t_0)/delta)).
              pose proof (Rabs_pos OC_0).
              psatz R. } } } } }
  Admitted.

  (* Our main robustness theorem. *)
  Theorem Spec_robust2 :
    Spec |-- robust2 state (lift2 Rmax (`-dv) `0)
                          (`Rmax v `0)
                          t mu gamma.
  Proof.
    apply robust_robust2.
    { apply Spec_robust. }
    { apply Spec_always. }
  Qed.

  (* An attempt at a proof of Tabuada robustness. *)
  (*
  Definition time_left : StateVal state R :=
    pure delta `- (t `- T).

  Definition IndInv : StateProp state :=
    v `+ a `* time_left `<= dv.

  Theorem next_robust :
    [][Next] |-- robust state (`Rmax (`-dv) `0)
                              (`Rmax v (`0))
                              t.
  Proof.
    rewrite <- robust2_robust.
    apply robust2_no_texists.
    { admit. }
    { exists (fun d => 2*d).
      exists (fun d t => Rabs d * exp (-t/2)).
      exists 0.
      split; [ | split; [ | split ] ].
      { apply K_fun_scale; [ apply K_fun_id | psatzl R ]. }
      { apply KLD_fun_abs_exp. psatzl R. }
      { reflexivity. }
      { rewrite_focusT. eapply discrete_induction.
        { clear_not_always. charge_revert_all.
          charge_intros. repeat rewrite always_and.
          charge_assumption. }
        { (* Base case. *) admit. }
        { (* Inductive step. *)
          charge_clear. apply always_tauto. charge_intros.
          unfold Next. rewrite focusA_or.
          rewrite <- starts_or.
          repeat rewrite land_lor_distr_L.
          apply lorL.
          { rewrite next_starts_pre. reason_action_tac.
            destruct pre_st
              as [[d1 td1] [v1 v_sense1 a1 dv1 t1 T1]].
            destruct post_st
              as [[d2 td2] [v2 v_sense2 a2 dv2 t2 T2]].
            Local Transparent ILInsts.ILFun_Ops.
            Local Transparent ILInsts.ILPre_Ops.
            unfold focusA, Discr, Sense, Monitor,
            ResetTimer, Unchanged, acc_dist2,
            bounded2, pre, post, dist2, PreFun.compose,
            _liftn, focusS. simpl. intros.
            assert (Rabs d1 <= d2).
            { admit. }
            assert (d1 <= Rabs d1) by apply Rle_abs.
            intuition. subst. psatzl R. }
          { rewrite next_starts_pre. reason_action_tac.
            destruct pre_st
              as [[d1 td1] [v1 v_sense1 a1 dv1 t1 T1]].
            destruct post_st
              as [[d2 td2] [v2 v_sense2 a2 dv2 t2 T2]].
            Local Transparent ILInsts.ILFun_Ops.
            Local Transparent ILInsts.ILPre_Ops.
            unfold focusA, World, Unchanged, acc_dist2,
            bounded2, pre, post, dist2, PreFun.compose,
            _liftn, focusS. simpl. intros.
            assert (v2 = v1 + a1 * (t2 - t1)) by admit.
            assert (a2 = a1) by admit.
            decompose [and] H1. subst. clear H1 H4.
   *)

(**** Old Stuff ****)
(*
Record state : Type :=
  { v : R; (* Actual velocity *)
    v_sense : R; (* Velocity used by the monitor *)
    a : R; (* Actual acceleration *)
    a_output : R; (* Desired acceleration of the monitor *)
    dv : R; (* Disturbance from velocity sensor *)
    da : R; (* Disturbance from actuator error *)
    t : R; (* Time *)
    T : R (* Timer *)
  }.

Section VelocityMonitor.

  (* Time between executions of the monitor. *)
  Variable delta : R.
  Axiom delta_gt_0 : (delta > 0)%R.
  (* Upper bound that the monitor enforces. *)
  Variable ub : R.

  (* Monitor logic *)
  Definition Monitor : StateProp state :=
    a_output `* pure delta `+ v_sense `<= pure ub.

  (* Sensor error *)
  Definition Sense : StateProp state :=
    v_sense `= v `+ dv.

  (* Actuator error *)
  Definition Output : StateProp state :=
    a `= a_output `+ da.

  (* Reset the timer when the discrete transition runs. *)
  Definition ResetTimer : StateProp state :=
    T `= t.

  (* Full discrete transition *)
  Definition Discr : ActionProp state :=
    (Sense //\\ Monitor //\\ Output //\\ ResetTimer)! //\\
    Unchanged (v :: t :: nil).

  (* Evolution predicate *)
  Definition w : SimpleDiffProp state (v :: a :: t :: nil) :=
    D v `= (fun _ => a) //\\ D a `= pure 0 //\\
    D t `= pure 1 //\\ (fun _ => t `- T `<= pure delta).

  (* Continuous transition *)
  Definition World : ActionProp state :=
    SimpleContinuous state w //\\
    Unchanged (dv :: da :: nil).

  (* Full system transition *)
  Definition Next : ActionProp state :=
    Discr \\// World.

  (* Is the monitor robust? *)
  Theorem monitor_robust :
    (* Do we need an initial condition? *)
    [][Next] |-- robust state ((*`Rabs dv `+ *)`Rabs da)
                              (`Rmax (v `- `ub) (`0))
                              t.
  Proof.
    rewrite <- robust2_robust.
    apply robust2_no_texists.
    { admit. }
    { exists (fun x => delta * x). (* gamma *)
      exists (fun d t => Rabs d * exp (-t)). (* mu *)
      exists R0. (* rho *)
      split; [ | split; [ | split ] ].
      { split.
        { prove_continuity. }
        { unfold strict_increasing_bound, Ranalysis1.id.
          split.
          { intros. pose proof delta_gt_0. psatz R. }
          { psatzl R. } } }
      { split.
        { unfold KL_fun. split.
          { unfold K_fun. split.
            { prove_continuity. }
            { split.
              { unfold strict_increasing_bound. intros.
                pose proof (Exp_prop.exp_pos (-t0)).
                repeat (rewrite Rabs_right;
                        [ | solve [psatzl R ] ]).
                psatz R. }
              { rewrite Rabs_R0. psatzl R. } } }
          { unfold L_fun. intros. split.
            { prove_continuity.
              apply continuity_comp with (f1:=Ropp)
                                           (f2:=exp);
                prove_continuity. }
            { split.
              { unfold decreasing_bound. intros.
                destruct H0. destruct H1.
                { pose proof
                       (Rpower.exp_increasing (-y) (-x)).
                  pose proof (Rabs_pos c).
                  assert (- y < - x) by psatzl R.
                  pose proof (Exp_prop.exp_pos (-y)).
                  intuition.
                (* I don't understand
                     how this solves the goal. *) }
                { rewrite H1. intuition. } }
              { unfold limit_pos_inf. intros.
                admit. (* Need some limit lemmas. *) } } } }
        { intros. split.
          { rewrite RIneq.Ropp_0. rewrite exp_0.
            rewrite RIneq.Rmult_1_r.
            apply Rabs_pos_eq; assumption. }
          { intros. rewrite RIneq.Ropp_plus_distr.
            rewrite Exp_prop.exp_plus. rewrite Rabs_mult.
            rewrite Rabs_involutive.
            rewrite Rabs_pos_eq with (x:=exp (-s));
              [ | left; apply Exp_prop.exp_pos ].
            psatzl R. } } }
        { psatzl R. }
        { rewrite_focusT. eapply discrete_induction.
          { clear_not_always. charge_revert_all.
            charge_intros. repeat rewrite always_and.
            charge_assumption. }
          { (* Base case. *) admit. }
          { (* Inductive step. *) charge_clear.
            apply always_tauto. charge_intros.
            unfold Next. rewrite focusA_or.
            rewrite <- starts_or.
            repeat rewrite land_lor_distr_L.
            apply lorL.
            { (* Discrete transition *)
              rewrite next_starts_pre.
              reason_action_tac.
              destruct pre_st
                as [[d1 td1]
                      [v1 v_sense1 a1 a_output1
                          dv1 da1 t1 T1]].
              destruct post_st
                as [[d2 td2]
                      [v2 v_sense2 a2 a_output2
                          dv2 da2 t2 T2]].
              Local Transparent ILInsts.ILFun_Ops.
              Local Transparent ILInsts.ILPre_Ops.
              unfold focusA, Discr, Monitor, Output,
              ResetTimer, UnchangedDiscr, acc_dist2,
              bounded2, pre, post, dist2, PreFun.compose,
              _liftn. simpl.
              intros.
              assert (Rabs d1 <= d2).
              { admit. }
              assert (d1 <= Rabs d1) by apply Rle_abs.
              intuition. subst. psatzl R. }
            { rewrite next_starts_pre.
              reason_action_tac.
              destruct pre_st
                as [[d1 td1]
                      [v1 v_sense1 a1 a_output1
                          dv1 da1 t1 T1]].
              destruct post_st
                as [[d2 td2]
                      [v2 v_sense2 a2 a_output2
                          dv2 da2 t2 T2]].
              Local Transparent ILInsts.ILFun_Ops.
              Local Transparent ILInsts.ILPre_Ops.
              unfold focusA, World, Monitor, Output,
              ResetTimer, UnchangedDiscr, acc_dist2,
              bounded2, pre, post, dist2, PreFun.compose,
              _liftn. simpl. intros.

            (* This is unprovable. The proof needs to be by
               induction. *) admit. }
          { admit. } } }
  Admitted.
*)
End VelocityMonitor.


Require Import Coq.PArith.BinPosDef.
Require Import Crypto.Algebra.Field.
Require Import Crypto.Spec.MontgomeryCurve Crypto.Curves.Montgomery.Affine.
Require Import Crypto.Spec.WeierstrassCurve Crypto.Curves.Weierstrass.Affine.
Require Import Crypto.Curves.Weierstrass.AffineProofs.
Require Import Crypto.Curves.Montgomery.AffineProofs.
Require Import Coq.Classes.RelationClasses.

Module M.
  Section MontgomeryCurve.
    Import BinNat.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {Feq_dec:Decidable.DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "- x" := (Fopp x).
    Local Notation "x ^ 2" := (x*x) (at level 30).
    Local Notation "0" := Fzero.
    Local Notation "1" := Fone.
    Local Notation "4" := (1+1+1+1).

    Global Instance MontgomeryWeierstrassIsomorphism
           {a b: F}
           (b_nonzero : b <> 0)
           (discriminant_nonzero: a^2 - 4 <> 0)
           {char_ge_3:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 3}
           {char_ge_12:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 12}
           {char_ge_28:@Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul 28} (* XXX: this is a workaround for nsatz assuming arbitrary characteristic *)
      :
      @Group.isomorphic_commutative_groups
        (@W.point F Feq Fadd Fmul _ _)
        W.eq
        (@W.add F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv field _ char_ge_3 _ _)
        W.zero
        (@W.opp F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv _ _ field _)

        (@M.point F Feq Fadd Fmul a b)
        M.eq
        (M.add(char_ge_3:=char_ge_3)(b_nonzero:=b_nonzero))
        M.zero
        (M.opp(b_nonzero:=b_nonzero))

        (M.of_Weierstrass(Haw:=reflexivity _)(Hbw:=reflexivity _)(b_nonzero:=b_nonzero))
        (M.to_Weierstrass(Haw:=reflexivity _)(Hbw:=reflexivity _)(b_nonzero:=b_nonzero)).
    Proof.
      eapply @AffineProofs.M.MontgomeryWeierstrassIsomorphism; try assumption; cbv [id]; fsatz.
    Qed.
  End MontgomeryCurve.
End M.


Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.SubstTT.Base.
Require Export Iron.Language.SystemF2Effect.Type.Operator.SubstTT.LiftTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.SubstTT.LowerTT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.SubstTT.EquivT.

(********************************************************************)
(* Commuting substitutions. *)
Lemma substTT_substTT
 :  forall n m t1 t2 t3
 ,  substTT (n + m) t3 (substTT n t2 t1)
 =  substTT n (substTT (n + m) t3 t2)
              (substTT (1 + n + m) (liftTT 1 n t3) t1).
Proof.
 intros. gen n m t2 t3.
 induction t1; intros;
  try (solve [simpl; f_equal; rewritess; norm]).

 Case "TVar".
  repeat (simpl; split_match; repeat norm_nat_compare);
   first [omega | burn].

 Case "TForall".
  simpl.
  rewrite (IHt1 (S n) m).
  rewrite (liftTT_substTT_1 0 (n + m)).
  rewrite (liftTT_liftTT_11 0 n).
  burn.
Qed.

(********************************************************************)
(* Substitution of types in types preserves kinding.
   Must also subst new new type into types in env higher than ix
   otherwise indices that reference subst type are broken, and
   the resulting type env would not be well formed *)
Theorem subst_type_type_ix
 :  forall ix ke sp t1 k1 t2 k2
 ,  get ix ke = Some k2
 -> KindT ke sp t1 k1
 -> KindT (delete ix ke) sp t2 k2
 -> KindT (delete ix ke) sp (substTT ix t2 t1) k1.
Proof.
 intros. gen ix ke sp t2 k1 k2.
 induction t1; intros; simpl; inverts_kind; eauto.

 Case "TVar".
  fbreak_nat_compare.
  SCase "n = ix".
   rewrite H in H5.
   inverts H5. auto.

  SCase "n < ix".
   apply KiVar. rewrite <- H5.
   apply get_delete_above; auto.

  SCase "n > ix".
   apply KiVar. rewrite <- H5.
   destruct n.
    burn.
    simpl. nnat. apply get_delete_below. omega.

 Case "TForall".
  apply KiForall.
  rewrite delete_rewind.
  eapply IHt1; eauto.
   apply kind_kienv_weaken; auto.

 Case "TCon2".
  eapply KiCon2.
  destruct tc. simpl in *. inverts H4.
  destruct t.  simpl in *. eauto.
  eauto.
  destruct tc. simpl in *. inverts H4.
  eauto.
Qed.

Theorem subst_type_type
 :  forall ke sp t1 k1 t2 k2
 ,  KindT (ke :> k2) sp t1 k1
 -> KindT ke         sp t2 k2
 -> KindT ke sp (substTT 0 t2 t1) k1.
Proof.
 intros.
 unfold substTT.
 rrwrite (ke = delete 0 (ke :> k2)).
 eapply subst_type_type_ix; burn.
Qed.

(* If two types are equivalent, and we substitute some third type
   into both, then the result is also equivalent. *)
Lemma substTT_EquivT
 :  forall  ke sp t1 t2 t3 k3 k
 ,  KindT    ke sp t3 k3
 -> EquivT (ke :> k3) sp t1 t2 k
 -> EquivT  ke sp (substTT 0 t3 t1) (substTT 0 t3 t2) k.
Proof.
 intros ke sp t1 t2 t3 k3 k HK HE.
 have HK1: (KindT (ke :> k3) sp t1 k).
 have HK2: (KindT (ke :> k3) sp t2 k).
 remember (ke :> k3) as X.
 induction HE; subst.

 - Case "EqRefl".
   eapply EqRefl;
    eauto using subst_type_type.

 - Case "EqSym".
   eapply EqSym;
    eauto using subst_type_type.

 - Case "EqTrans".
   eapply EqTrans with (t2 := substTT 0 t3 t2); eauto.

 - Case "EqSumCong".
   eapply EqSumCong; fold substTT. auto.
   eauto using subst_type_type.
   eauto using subst_type_type.

 - Case "EqSumBot".
   apply EqSumBot; fold substTT. auto.
   eauto using subst_type_type.

 - Case "EqSumIdemp".
   eapply EqSumIdemp. auto.
   eauto using subst_type_type.

 - Case "EqSumComm".
   eapply EqSumComm; fold substTT. auto.
   eauto using subst_type_type.
   eauto using subst_type_type.

 - Case "EqSumAssoc".
   eapply EqSumAssoc; fold substTT. auto.
   eauto using subst_type_type.
   eauto using subst_type_type.
   eauto using subst_type_type.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C M Cprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ M A /\ (wd_ M B /\ (wd_ M C /\ (wd_ C Cprime /\ (wd_ M Cprime /\ (wd_ A Cprime /\ (wd_ B Cprime /\ (col_ B C Cprime /\ (col_ M A B /\ col_ M C Cprime)))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

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

Print Assumptions freeze.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Cprime Aprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (col_ A B C /\ (col_ Aprime B C /\ col_ Cprime A B))))))))) -> col_ A B Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.