(** * Introduction *)

(**  Can we trim the import list (perhaps adding some thing to
   QuickChick.v)?
 *)
Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

From QuickChick Require Import QuickChick.
Require Import List ZArith. Import ListNotations.
(*
Import QcDefaultNotation. Open Scope qc_scope.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

Import ListNotations.
*)

(* ################################################################# *)
(** * A First Taste of Testing *)

(** Consider the following definition of a function [remove], which
    takes a natural number [x] and a list of nats [l] and removes [x]
    from the list. *)

Fixpoint remove (x : nat) (l : list nat) : list nat :=
  match l with
    | []   => []
    | h::t => if beq_nat h x then t else h :: remove x t
  end.

(** One possible specification for [remove] might be this property... *)

Conjecture removeP : forall x l,  ~ (In x (remove x l)).

(** ...which says that [x] never occurs in the result of [remove x l]
    for any [x] and [l].

    ([Conjecture foo...] means the same as [Theorem foo... Admitted.]
    Formally, [foo] is treated as an axiom in what follows.) *)

(** Sadly, this property is false, as we would (eventually) discover
    if we were to try to prove it. *)

(** A different -- possibly much more efficient -- way to discover
    the discrepancy between the definition and specification is
    to _test_ it: *)

(* QuickChick removeP. *)

(** The [QuickChick] command takes a property (which must be
    "executable" -- we'll see later exactly what this means) and
    attempts to falsify it by running it on many randomly
    generated inputs, resulting in output like this:

    0
    [0, 0]
    Failed! After 17 tests and 12 shrinks

    This means that, if run [remove] with [x] being [0] and [l]
    the two-element list containing two zeros, then the property
    [removeP] fails. *)

(** With this example in hand, we can see that the [then] branch
    of [remove] fails to make a recursive call, which means that only
    one occurence of [x] will be deleted. The last line of the output
    records that it took 17 tests to identify some fault-inducing
    input and 12 "shrinks" to reduce it to a minimal
    counterexample. *)

(** **** Exercise: 1 star (insert)  *)
(** Here is a somewhat mangled definition of a function for inserting a
   new element into a sorted list of numbers: *)

Fixpoint insert x l :=
  match l with
  | [] => [x]
  | y::t => if y <? x then insert x t else y::t
  end.

(** Write a property that says "inserting a number [x] into a list [l]
    always yields a list containing [x]."  Make sure QuickChick finds
    a counterexample. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 3 stars (insert2)  *)
(** Write a property that says "inserting a number [x] into a list [l]
    yields a list containing every member of [l]."  Make sure
    QuickChick finds a counterexample. (N.b. There is a way to do this
    using just what we've seen, though it's arguably not the best
    way.) *)

(* FILL IN HERE *)
(** [] *)

(* ################################################################# *)
(** * Overview *)

(** Property-based random testing involves four basic ingredients:

    - an _executable property_ like [removeP],
    - _generators_ for random elements of the types of the inputs to
      the property (here, numbers and lists of numbers),
    - _printers_ for converting data structures like numbers and lists
      to strings when reporting counterexamples, and
    - _shrinkers_, which are used to minimize counterexamples. *)

(** We will delve into each of these in detail later on, but first we
    need to make a digression to explain Coq's support for
    _typeclasses_, which QuickChick uses extensively both internally
    and in its programmatic interface to users.  This is
    [Typeclasses].

    Next ([QC]) we'll cover the core concepts and features of
    QuickChick itself.

    The [TImp] chapter develops a small case study around a typed
    variant of the Imp language.

    Finally, a larger case study on property-based testing of a small
    compiler appears as the [CompilerTest] chapter of the [vminus]
    volume. *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This file provides classical logic and functional choice; this
    especially provides both indefinite descriptions and choice functions
    but this is weaker than providing epsilon operator and classical logic
    as the indefinite descriptions provided by the axiom of choice can
    be used only in a propositional context (especially, they cannot
    be used to build choice functions outside the scope of a theorem
    proof) *)

(** This file extends ClassicalUniqueChoice.v with full choice.
    As ClassicalUniqueChoice.v, it implies the double-negation of
    excluded-middle in [Set] and leads to a classical world populated
    with non computable functions. Especially it conflicts with the
    impredicativity of [Set], knowing that [true<>false] in [Set].  *)

Require Export ClassicalUniqueChoice.
Require Export RelationalChoice.
Require Import ChoiceFacts.

Set Implicit Arguments.

Definition subset (U:Type) (P Q:U->Prop) : Prop := forall x, P x -> Q x.

Theorem singleton_choice :
  forall (A : Type) (P : A->Prop),
  (exists x : A, P x) -> exists P' : A->Prop, subset P' P /\ exists! x, P' x.
Proof.
intros A P H.
destruct (relational_choice unit A (fun _ => P) (fun _ => H)) as (R',(Hsub,HR')).
exists (R' tt); firstorder.
Qed.

Theorem choice :
 forall (A B : Type) (R : A->B->Prop),
   (forall x : A, exists y : B, R x y) ->
    exists f : A->B, (forall x : A, R x (f x)).
Proof.
intros A B.
apply description_rel_choice_imp_funct_choice.
exact (unique_choice A B).
exact (relational_choice A B).
Qed.


Set Implicit Arguments.
Require Import TLC.LibTactics.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
(* We re-use the methodology of Procrastination, and thus some of the definition
   and tactics *)
Require Export Procrastination.Procrastination.
(* Load the BigO library. *)
Require Export Filter.
Require Export Monotonic.
Require Export Dominated.
Require Export LibFunOrd.
Require Export UltimatelyGreater.
Require Export LibZExtra.
Require Export DominatedNary.
Require Export FilterNary.
Require Export LimitNary.
Require Export Generic.
Require Export TLC.LibIntTactics.
Require Export HeapTactics.
Require Export MathTactics.
Require Export elia.
Require Export PolTac.PolTac.

(********************************************************************)

Record specO
       (A : filterType) (le : A -> A -> Prop)
       (spec : (A -> Z) -> Prop)
       (bound : A -> Z) :=
  SpecO {
      cost : A -> Z;
      spec : spec cost;
      cost_nonneg : forall x, 0 <= cost x;
      cost_monotonic : monotonic le Z.le cost;
      cost_dominated : dominated A cost bound
    }.

(********************************************************************)

(** Properties of the cost function in a specO, as separate lemmas. *)

Lemma monotonic_specO_cost :
  forall A le spec bound (S : @specO A le spec bound),
  monotonic le Z.le (cost S).
Proof.
  intros. apply cost_monotonic.
Qed.

Hint Extern 1 (monotonic _ _ (fun _ => cost ?S _)) =>
  match type of S with
  | @specO _ ?leS _ _ =>
     apply Monotonic.monotonic_comp with (leB := leS)
  end : monotonic.

Hint Extern 1 (monotonic _ _ (cost ?S)) =>
  match type of S with
  | @specO ?AS _ _ _ =>
    apply monotonic_specO_cost with (A := AS)
  end : monotonic.

Lemma monotonic_specO_nonneg :
  forall A le spec bound (S : @specO A le spec bound) x,
  0 <= cost S x.
Proof.
  intros. apply cost_nonneg.
Qed.

Hint Resolve monotonic_specO_nonneg : zarith.

Hint Resolve cost_dominated : dominated.

Instance Le_cost
  (A:filterType) le spec bound (S: specO A le spec bound) (x:A) :
  Le 0 (cost S x).
Proof. apply cost_nonneg. Qed.

(* to debug, should work but doesn't seem to. Maybe try later with typeclasses
   eauto? *)
(* Hint Extern 2 (dominated _ (fun _ => cost ?S _) _) => *)
(*       eapply dominated_transitive; *)
(*       [ apply dominated_comp with (f := cost S); *)
(*         [ apply cost_dominated | .. ] *)
(*       | ]. *)

(** *)

Inductive pack_provide_specO (A:Type) (V:A) : Prop :=
  | provide_specO : pack_provide_specO V.

(** *)

(********************************************************************)
(** rew_cost *)

Ltac rew_cost :=
  (* rew_int: FIXME *)
  repeat (
    rewrite
      ?Z.max_id,
      ?Z.add_0_l, ?Z.add_0_r,
      ?Z.mul_0_l, ?Z.mul_0_r,
      ?Zmax_0_l, ?Zmax_0_r
    by (solve [auto with zarith])
  ).

(********************************************************************)

(* Contravariant specs (wrt the cost function).

   If the spec can be proved contravariant, then the [cost_nonneg] field of
   [specO] can be proved automatically. *)

Definition spec_is_contravariant {A} (spec : (A -> Z) -> Prop) :=
  forall (cost1 cost2 : A -> Z),
  (forall x, cost1 x <= cost2 x) ->
  (spec cost1 -> spec cost2).

(* Tactic that tries to prove that a CFML spec is contravariant.

   It is generally the case for the specs with credits we consider, where the
   cost functions is used once and only in the precondition.

   More precisely, this tactic works with specifications of the form:
   [fun cost -> forall ...., app _ (\$cost (..) \* _) _] or
   [fun cost -> forall ...., app _ (\$cost (..)) _]
*)

Lemma spec_is_contravariant_lemma1 :
  forall A (cost cost' : int) (F: ~~A) Q,
  F (\$ cost') Q ->
  (cost' <= cost) ->
  is_local F ->
  F (\$ cost) Q.
Proof.
  introv HH Hcost L. xapply HH. hsimpl_credits. hsimpl. math.
Qed.

Lemma spec_is_contravariant_lemma2 :
  forall A (cost cost' : int) (F: ~~A) H Q,
  F (\$ cost' \* H) Q ->
  (cost' <= cost) ->
  is_local F ->
  F (\$ cost \* H) Q.
Proof.
  introv HH Hcost L. xapply HH. hsimpl_credits. hsimpl. math.
Qed.

Ltac spec_is_contravariant :=
  match goal with
  | |- spec_is_contravariant _ =>
    let cost1 := fresh "cost" in
    let cost2 := fresh "cost" in
    let Hcosts := fresh "Hcosts" in
    let spec_cost1 := fresh "spec_cost1" in
    intros cost1 cost2 Hcosts spec_cost1;
    intros;
    (first [
        eapply spec_is_contravariant_lemma1; [ | | xlocal]
      | eapply spec_is_contravariant_lemma2; [ | | xlocal]
      ]);
    [ | solve [ apply Hcosts ] ];
    apply spec_cost1; auto
  end.

(********************************************************************)
Definition tagged_cost_fun A (f : A -> Z) : A -> Z :=
  fun x => ⟨ f x ⟩.

(********************************************************************)
Definition cleanup_cost
           {A : filterType} (le : A -> A -> Prop)
           (cost : A -> Z)
           (bound : A -> Z) (spec : (A -> Z) -> Prop)
  :=
  sigT (fun cost_clean_eq =>
  sigT (fun cost_clean =>
    monotonic le Z.le cost_clean_eq *
    dominated A cost_clean bound *
    (spec_is_contravariant spec + (forall x, 0 <= cost_clean_eq x)) *
    dominated A cost_clean_eq cost_clean *
    (forall x, cost x = cost_clean_eq x)))%type.

Lemma cleanup_cost_tagged {A : filterType} le cost bound spec:
  @cleanup_cost A le cost bound spec ->
  @cleanup_cost A le (tagged_cost_fun cost) bound spec.
Proof.
  intros (cce & cc & [[[[? ?] ?] ?] ?]). unfold tagged_cost_fun.
  exists cce cc. split~. intros. rewrite credits_refine_eq. auto.
Qed.

Lemma cleanup_cost_alt :
  forall (A: filterType) le cost bound spec,
  @cleanup_cost A le cost bound spec ->
  monotonic le Z.le cost *
  dominated A cost bound *
  (spec cost -> specO A le spec bound).
Proof.
  intros ? ? cost.
  introv (cost_clean_eq & cost_clean & H).
  repeat (destruct H as (H & ?)).
  assert (monotonic le Z.le cost).
  { eapply Monotonic.monotonic_eq; eauto. }
  assert (dominated A cost bound).
  { eapply dominated_eq_l. eapply dominated_transitive; eauto. auto. }

  repeat split; auto; []. intro S.
  match goal with H : _ + _ |- _ => destruct H as [contra | N] end.
  { eapply SpecO with (fun x => Z.max 0 (cost x)).
    - eapply contra with cost; auto with zarith.
    - auto with zarith.
    - Monotonic.monotonic.
    - dominated. }
  { eapply SpecO with cost; auto.
    intros. match goal with H : _ |- _ => rewrite H end. auto. }
Qed.

Lemma cleanup_cost_eq : forall (A: filterType) le cost0 cost1 bound spec,
  (forall (x:A), cost0 x = cost1 x) ->
  cleanup_cost le cost1 bound spec ->
  cleanup_cost le cost0 bound spec.
Proof.
  intros * Hcost [cost_clean_eq [cost_clean [[[? ?] ?] ?]]].
  unfold cleanup_cost. exists cost_clean_eq cost_clean. split~.
  intros. rewrite Hcost. auto.
Qed.

(* TODO: implement using setoid-rewrite? *)
Ltac dominated_cleanup_cost :=
  first [
      apply dominated_sum;
      [ | | dominated_cleanup_cost | dominated_cleanup_cost];
      simpl;
      solve [ ultimately_greater_trysolve ]
    | apply dominated_max;
      [ | | dominated_cleanup_cost | dominated_cleanup_cost];
      simpl;
      solve [ ultimately_greater_trysolve ]
    | apply dominated_big_sum;
      [ | | dominated_cleanup_cost ];
      simpl;
      solve [ ultimately_greater_trysolve ]
    | apply dominated_mul_cst_l_1; dominated_cleanup_cost
    | apply dominated_mul_cst_l_2; dominated_cleanup_cost
    | apply cost_dominated; dominated_cleanup_cost
    | eapply dominated_comp;
      [ apply cost_dominated | limit ]
    | apply dominated_reflexive
    ].

(* workaround because ring_simplify apparently sometimes chokes on
   evars. *)
Ltac hide_evars_then cont :=
  match goal with
    |- context [ ?X ] =>
    is_evar X;
    let hide_X := fresh in
    set (hide_X := X);
    hide_evars_then cont;
    subst hide_X
  | _ =>
    cont tt
  end.

Ltac simple_cleanup_cost :=
  simpl; hide_evars_then ltac:(fun _ => ring_simplify).

Ltac simple_cleanup_cost_eq :=
  simpl; simple_cleanup_cost.

Ltac destruct_pair x :=
  let ty := type of x in
  let ty := eval cbv in ty in
  lazymatch ty with
  | (_ * _)%type =>
    let x1 := fresh "x" in
    let x2 := fresh "x" in
    destruct x as [x1 x2]; destruct_pair x1
  | _ => idtac
  end.

Ltac intro_destructs :=
  let x := fresh "x" in
  intro x; destruct_pair x.

(********************************************************************)

(* body is expected to be a uconstr *)
Ltac intro_cost_expr_1 A cost_name body :=
  simple refine (let cost_name := (fun (x:A) => body) : A -> Z in _); [ shelve .. | ].

(* body is expected to be a uconstr *)
Ltac intro_cost_expr_2 A cost_name body :=
  (* Ugly hack. See https://github.com/coq/coq/issues/6643 *)
  (* Was:
     refine (let cost_name := (fun '(x, y) => body) : A -> Z in _).
   *)
  let pat := fresh "pat" in
  match goal with |- ?G =>
    simple refine (let cost_name := (fun pat => let '(x,y) := pat in body) : A -> Z in _);
    try clear pat;
    [ shelve .. | ]
  end.

(* body is expected to be a uconstr *)
Ltac intro_cost_expr A cost_name body :=
  let A_sort := constr:(Filter.sort A) in
  let A_sort' := (eval compute in A_sort) in
  (* TODO: handle more arities *)
  lazymatch A_sort' with
  | (_ * _)%type => intro_cost_expr_2 A cost_name body
  | _ => intro_cost_expr_1 A cost_name body
  end.

Ltac eexists_cost_expr A :=
  let cost_name := fresh in
  intro_cost_expr A cost_name uconstr:(_);
  exists cost_name;
  subst cost_name.

(********************************************************************)
Definition close_cost (P : Type) := P.
Definition ellipsis {A} (x: A) := x.
(********************************************************************)

Ltac try_prove_nonnegative :=
  first [
      solve [ left; unfold ellipsis; spec_is_contravariant ]
    | right
    ].

Ltac cleanup_cost :=
  try apply cleanup_cost_tagged;
  match goal with |- @cleanup_cost ?A _ ?cost _ _ =>
    unfold cleanup_cost; do 2 (eexists_cost_expr A);
    try subst cost;
    split; [| intro_destructs;
              simple_cleanup_cost_eq;
              reflexivity ];
    split; [| eapply dominated_eq_r;
              [ dominated_cleanup_cost |];
              intro_destructs;
              simple_cleanup_cost;
              reflexivity ];
    split; [ split | try_prove_nonnegative ]
  end.

(********************************************************************)

Lemma specO_prove :
  forall (A : filterType) (le : A -> A -> Prop)
         (cost : A -> Z)
         (bound : A -> Z)
         (spec : (A -> Z) -> Prop),
    spec cost ->
    (spec_is_contravariant spec + (forall x, 0 <= cost x)) ->
    monotonic le Z.le cost ->
    dominated A cost bound ->
    specO A le spec bound.
Proof.
  introv S N M D.
  destruct N as [spec_contra | N].
  { pose (cost' := fun x => Z.max 0 (cost0 x)).
    apply SpecO with (cost := cost'); subst cost'.
    - eapply spec_contra with cost0; auto. math_lia.
    - math_lia.
    - Monotonic.monotonic.
    - dominated. }
  { apply SpecO with (cost := cost0); auto. }
Qed.

Lemma specO_refine_straight_line :
  forall (A : filterType) (le : A -> A -> Prop)
         (cost bound : A -> Z)
         (spec : (A -> Z) -> Prop),
    spec cost ->
    cleanup_cost le cost bound (ellipsis spec) ->
    specO A le spec bound.
Proof.
  introv H1 H2.
  forwards [[? ?] H]: cleanup_cost_alt H2.
  unfold ellipsis in *. apply~ H.
Qed.

Lemma specO_refine_recursive :
  forall (A : filterType) (le : A -> A -> Prop)
         (bound : A -> Z)
         (spec : (A -> Z) -> Prop)
         P P',
    (forall cost,
       monotonic le Z.le cost ->
       dominated A cost bound ->
       Marker.group (P cost) ->
       spec cost) ->
    close_cost
      (ellipsis ((forall cost, P' cost -> P cost) *
       sigT (fun cost =>
         P' cost *
         cleanup_cost le cost bound (ellipsis spec))))%type ->
    specO A le spec bound.
Proof.
  introv H1 H2.
  unfold close_cost in H2.
  destruct H2 as (? & cost & ? & c).
  forwards [[? ?] H]: cleanup_cost_alt c.
  unfold ellipsis in *.
  pose proof Marker.group_fold.
  apply~ H.
Qed.

Ltac close_cost :=
  unfold close_cost; unfold ellipsis;
  split; [ solve [ introv_rec; hnf; cleanup_conj_goal_core ] |];
  hnf.

Ltac xspecO_explicit_cost cost_expr :=
  match goal with |- specO ?A _ _ _ =>
    apply (@specO_prove A _ (cost_expr : A -> Z) _ _);
    [ | try_prove_nonnegative | .. ]
  end.

Ltac xspecO_refine_recursive :=
  eapply specO_refine_recursive.

(** Straight-line case *)

Ltac xspecO_refine_straight_line cost_name :=
  match goal with
    |- specO ?A ?le _ _ =>
    intro_cost_expr A cost_name uconstr:(_);
    eapply (@specO_refine_straight_line A le (@tagged_cost_fun A cost_name));
    [ unfold tagged_cost_fun, cost_name | ]
  end.

Tactic Notation "xspecO" uconstr(cost_expr) :=
  xspecO_explicit_cost cost_expr.

Tactic Notation "xspecO_refine" "straight_line" ident(cost_name) :=
  xspecO_refine_straight_line cost_name.

Tactic Notation "xspecO_refine" "straight_line" :=
  let costf := fresh "costf" in
  xspecO_refine_straight_line costf.

Tactic Notation "xspecO_refine" "recursive" :=
  xspecO_refine_recursive.

Notation "'(...)'" := (ellipsis _) (at level 0).

(* Notations for common [specO]s *)

Notation "'specZ' [ X '\in_O' f ] E" :=
  (specO Z_filterType Z.le (fun X => E) f)
    (X ident, f at level 90, E at level 0,
     format "'[v' 'specZ'  [ X  '\in_O'  f ]  '/'  E ']'", at level 60).

Notation "'spec1' [ X ] E" :=
  (specO unit_filterType eq (fun X => E) (fun tt => 1))
    (X ident, E at level 0,
     format "'[v' 'spec1'  [ X ]  '/'  E ']'", at level 60).

(* Custom CF rules and tactics ************************************************)

(** *)

Class GetCreditsEvar (h h' : hprop) (c : int) :=
  MkGetCreditsEvar : h = h' \* \$ c.

Instance GetCreditsEvar_inst : forall h h' h'' c,
  HeapPreprocessCredits h h' ->
  GetCreditsExpr h' ⟨c⟩ h'' ->
  GetCreditsEvar h h'' c.
Proof.
  intros.
  unfold HeapPreprocessCredits, GetCreditsExpr,
    GetCreditsEvar in *.
  rewrite credits_refine_eq in *.
  now subst.
Qed.

Ltac tryif_refine_cost_goal ifyes ifno :=
  first [
    match goal with |- _ ?pre _ =>
      let H := fresh "HGCE" in
      eassert (GetCreditsEvar pre _ _) as H;
      [ once (typeclasses eauto) | ];
      once (ifyes H);
      clear H
    end
  | once (ifno tt)
  ].

(** *)

(* Custom xspec to fetch specO specifications *)

(* FIXME: copy-pasted from CFML *)
Ltac xspec_core_base f :=
  first [ xspec_for_record f
        | xspec_in_hyps_core f
        (* FUTURE: | xspec_in database_spec_credits f *)
        | xspec_in_core database_spec f
        | xspec_app_in_hyps f
        | fail 1 "xspec cannot find specification" ].

(* TODO? S might start with some forall/hypothesis before the specO --
   turn these into evars/subgoals using
   refine (fun X => _ (X _)); swap 1 2; [..|clear X; loop...]
*)
Ltac spec_of_specO :=
  lazymatch goal with
  | |- pack_provide_specO ?S -> _ =>
    intros _; generalize (spec S)
  end.

Ltac xspec_core f ::=
  xspec_core_base f; try spec_of_specO.

(* weaken **************)

Inductive weaken_arg :=
| Auto : weaken_arg
| Expr : int -> weaken_arg.

Class WeakenFindArg (h1 : hprop) (arg : weaken_arg) (h2 : hprop) (c : int) :=
  MkWeakenFindArg : GetCreditsExpr h1 c h2.

Instance WeakenFindArg_auto_unique: forall h h' c,
  HasSingleCreditsExpr h h' c ->
  WeakenFindArg h Auto h' c.
Proof. now unfold HasSingleCreditsExpr, GetCreditsExpr. Qed.

Instance WeakenFindArg_auto_refine: forall h h' c,
  GetCreditsExpr h ⟨c⟩ h' ->
  WeakenFindArg h Auto h' c.
Proof.
  intros. unfold WeakenFindArg. now rewrite credits_refine_eq in *. Qed.

Instance WeakenFindArg_expr: forall h h' c,
  GetCreditsExpr h c h' ->
  WeakenFindArg h (Expr c) h' c.
Proof. now unfold GetCreditsExpr. Qed.

(* weaken

   Applies to a goal with some credit cost, and turns it into a goal where the
   number of credits is an evar (so that the _refine tactics can apply).
   Produces a side-condition requiring that the evar cost is less than the
   original cost.

   Is also useful if the original number of credits _is_ an evar, but with a
   context that doesn't allow directly instanting it. Calling this tactic
   introduces a new evar in the local context, plus a subgoal where the user can
   explain how to instantiate the evar with the restricted context.
*)
Lemma weaken_credits arg :
  forall A (cost_weakened cost : int) (F: ~~A) H H' Q,
  WeakenFindArg H arg H' cost ->
  F (\$ ⟨ cost_weakened ⟩ \* H') Q ->
  (cost_weakened <= cost) ->
  is_local F ->
  F H Q.
Proof.
  introv -> HH Hcost L.
  xapply HH.
  { hsimpl_credits. }
  { hsimpl. rewrite credits_refine_eq. math. }
Qed.

Ltac weaken_core arg :=
  eapply (@weaken_credits arg);
  [ once (typeclasses eauto) | | | xlocal ].

Tactic Notation "weaken" := weaken_core Auto.
Tactic Notation "weaken" uconstr(arg) :=
  let earg := uconstr:(Expr arg) in
  weaken_core earg.

(** *)

(* stop_refine

   The opposite operation of refine: instantiates the evar for the number of
   credits with 0. *)

Lemma stop_refine_credits :
  forall A (F: ~~A) c H H' Q,
  GetCreditsEvar H H' c ->
  c = 0 ->
  F H' Q ->
  is_local F ->
  F H Q.
Proof.
  introv ? ? HH ?.
  unfold Unify, GetCreditsEvar in *. subst.
  rewrite credits_zero_eq. xapply~ HH.
Qed.

Ltac stop_refine :=
  eapply stop_refine_credits; [
    once (typeclasses eauto)
  | reflexivity | | xlocal ].

(* cutO *)

Lemma cutO_refine :
  forall (A : filterType) le B (bound : A -> Z) (F: ~~B) H Q (a: A),
  forall S : specO A le (fun cost => forall a, F (\$ cost a \* H) Q) bound,
  F (\$ ⟨(cost S) a⟩ \* H) Q.
Proof.
  introv. rewrite credits_refine_eq. destruct S. simpl. auto.
Qed.

(* hsimpl *****************************)

(** refine credits *)

Class GetFrame (h1 h2 frame : hprop) :=
  MkGetFrame : h1 = h2 \* frame.

Class GetFrame' (h1 h2 frame : hprop) :=
  MkGetFrame' : GetFrame h1 h2 frame.

Instance GetFrame_of': forall h1 h2 frame,
  GetFrame' h1 h2 frame ->
  GetFrame h1 h2 frame.
Proof. eauto. Qed.

Hint Mode GetFrame' ! - - : typeclass_instances.

Instance GetFrame'_star_l : forall h1 h1' h2 h1'h2 frame,
  GetFrame h1 h1' frame ->
  Star h1' h2 h1'h2 ->
  GetFrame' (h1 \* h2) h1'h2 frame.
Proof.
  introv -> <-. unfold GetFrame', GetFrame.
  now rewrite <-!star_assoc, (star_comm frame).
Qed.

Instance GetFrame'_star_r: forall h1 h2 h2' h1h2' frame,
  GetFrame h2 h2' frame ->
  Star h1 h2' h1h2' ->
  GetFrame' (h1 \* h2) h1h2' frame.
Proof.
  introv -> <-. unfold GetFrame', GetFrame.
  now rewrite star_assoc.
Qed.

Instance GetFrame_frame: forall h,
  IsEvar h ->
  GetFrame h \[] h.
Proof. introv _. unfold GetFrame. now rewrite star_neutral_l. Qed.

Class SplitFrameIfPresent (lhs hsource htarget hsource' htarget' : hprop) :=
  MkSplitFrameIfPresent : hsource \* htarget = hsource' \* htarget'.

Instance SplitFrameIfPresent_has_frame_lhs_emp: forall lhs hs hs' f ht htf,
  IsNotEvar lhs ->
  Unify lhs \[] ->
  GetFrame hs hs' f ->
  Star ht f htf ->
  SplitFrameIfPresent lhs hs ht hs' htf.
Proof.
  introv _ ->. unfold GetFrame. intros ->. unfold Star. intros <-.
  unfold SplitFrameIfPresent.
  now rewrite <-star_assoc, (star_comm f).
Qed.

Instance SplitFrameIfPresent_hasframe: forall lhs hs hs' f H1 H2 ht hs'H1 htH2,
  GetFrame hs hs' f ->
  Unify f (H1 \* H2) ->
  Star hs' H1 hs'H1 ->
  Star ht H2 htH2 ->
  SplitFrameIfPresent lhs hs ht hs'H1 htH2
| 20.
Proof.
  introv -> ->. unfold Star. introv <- <-. unfold SplitFrameIfPresent.
  now rewrite <-!star_assoc, (star_comm H2).
Qed.

Instance SplitFrameIfPresent_noframe: forall lhs hs ht,
  SplitFrameIfPresent lhs hs ht hs ht | 100.
Proof. reflexivity. Qed.

Class SplitGCIfPresent (hsource htarget hsource' htarget' : hprop) :=
  MkSplitGCIfPresent : hsource \* htarget = hsource' \* htarget'.

Instance SplitGCIfPresent_hasGC: forall hs hs' ht htGC,
  RemoveGC hs hs' ->
  Star ht \GC htGC ->
  SplitGCIfPresent hs ht hs htGC.
Proof.
  introv -> <-. unfolds.
  now rewrite <-!star_assoc, (star_comm _ \GC), (star_assoc \GC), GCGC_eq_GC.
Qed.

Instance SplitGCIfPresent_noGC: forall hs ht,
  SplitGCIfPresent hs ht hs ht | 100.
Proof. reflexivity. Qed.

Lemma himpl_credits_subgoal: forall h1 h1' h2 h2' h2'' h2''' l1 l2 hc1 hc2 hc2' hc2'',
  GetCredits h1 h1' l1 ->
  GetCredits h2 h2' l2 ->
  CreditsHeap l1 hc1 ->
  CreditsHeap l2 hc2 ->
  SplitFrameIfPresent h1' h2' hc2 h2'' hc2' ->
  SplitGCIfPresent h2'' hc2' h2''' hc2'' ->
  h1' ==> h2''' ->
  hc1 ==> hc2'' ->
  h1 ==> h2.
Proof.
  introv -> -> -> -> -> -> HH1 HH2. hchange HH1. hchange HH2. hsimpl.
Qed.

(* Fail if the goal does not contain credits, instead of producing a trivial
   subgoal *)
Ltac himpl_credits_subgoal :=
  match goal with |- _ ==> _ =>
  match goal with |- context [ \$ _ ] =>
    eapply himpl_credits_subgoal; [ once (typeclasses eauto) .. | | ]
  end end.

(********************)

(* These cleanup tactics are a bit ad-hoc. Maybe all of [hsimpl_cleanup] should
   be implemented in this style, instead of trying to minimize the diff and
   match the input expected by the existing tactics. *)

Lemma cleanup_emp: forall h1 h1' h2 h2',
  CleanupEmp h1 h1' ->
  CleanupEmp h2 h2' ->
  h1' ==> h2' ->
  h1 ==> h2.
Proof. introv -> ->. eauto. Qed.

Ltac cleanup_emp tt :=
  eapply cleanup_emp; [ once (typeclasses eauto) .. |].

(* This is because HasGC might split the frame evar to introduce a \GC, and we
   might want to get rid of it afterwards.. *)

Lemma hsimpl_cancel_GC_lhs : forall HL HL' HA HR,
  RemoveGC HL HL' ->
  HL' ==> (\GC \* HA) \* HR -> (* keep \GC *)
  HL ==> HA \* \GC \* HR.
Proof.
  introv -> HH. hchange HH.
  rewrite (star_assoc _ \GC), (star_comm _ \GC), <-!star_assoc.
  rewrite (star_assoc \GC), GCGC_eq_GC.
  hsimpl.
Qed.

Ltac hsimpl_cancel_GC_lhs tt :=
  eapply hsimpl_cancel_GC_lhs; [ once (typeclasses eauto) |].

(* TEMPORARY TODO: put into CFML *)
Ltac hsimpl_hook H ::=
  match H with
  | \GC => hsimpl_cancel_GC_lhs tt
  end.

(* Terminates goals of the form:

  H ==> H
  ... ==> ?H  (by instantiating H with the left-hand side)
  ... ==> \GC  (by potentially producing "affine .." subgoals)

  and does nothing on other goals.
*)
Ltac hsimpl_cleanup_trysolve :=
  try apply pred_incl_refl;
  try hsimpl_hint_remove tt;
  try remove_empty_heaps_right tt;
  try remove_empty_heaps_left tt;
  try apply hsimpl_gc;
  try affine.

Ltac hsimpl_cleanup tt ::=
  try apply hsimpl_stop;
  try apply hsimpl_stop;
  try cleanup_emp tt;
  try himpl_credits_subgoal;
  match goal with
  | |- context [ \$ ⟨ _ ⟩ ] =>
    (* Avoid instantiating the frame with the credits in that case, and keep
       them in a separate goal (propagating the \$ ⟨_⟩ in the frame is rarely
       something that we want to do). *)
       idtac
  | |- _ ==> _ =>
    hsimpl_cleanup_trysolve
  | _ =>
    idtac
  end.

Goal forall H1 H2 c2, exists c1 H3,
  H1 \* \$ ⟨c1⟩ ==> H2 \* \$ c2 \* H3.
Proof.
  intros. do 2 eexists. hsimpl.
Abort.

Goal forall H1 c2, exists c1 H3,
  H1 \* \$ ⟨c1⟩ ==> H1 \* \$ c2 \* H3.
Proof.
  intros. do 2 eexists. hsimpl; [].
Abort.

(*************************)

(* Tactics on heap implications with credits *)

Lemma piggybank_inst_with_expr x : forall h1 h2 h1' h2' p,
  GetCreditsEvar h1 h1' p ->
  GetCreditsExpr h2 x h2' ->
  Unify p x ->
  h1' ==> h2' ->
  h1 ==> h2.
Proof. introv -> -> -> HH. xchange HH. hsimpl. Qed.

Ltac piggybank_inst_with_expr x :=
  eapply (@piggybank_inst_with_expr x); [ once (typeclasses eauto) .. |].

Tactic Notation "piggybank:" uconstr(x) :=
  piggybank_inst_with_expr x.

Lemma piggybank_refine_with_expr x : forall h1 h2 h1' h2' p p',
  GetCreditsEvar h1 h1' p ->
  GetCreditsExpr h2 x h2' ->
  Unify p (x + p') ->
  \$ ⟨p'⟩ \* h1' ==> h2' ->
  h1 ==> h2.
Proof.
  introv -> -> -> HH. rewrite credits_split_eq, <-(credits_refine_eq p').
  now xchange HH.
Qed.

Ltac piggybank_refine_with_expr x :=
  eapply (@piggybank_refine_with_expr x); [ once (typeclasses eauto) .. |].

Tactic Notation "piggybank+" uconstr(x) :=
  piggybank_refine_with_expr x.

Definition Piggybank (c : int) := c.

Ltac set_Piggybank :=
  match goal with |- context [ Piggybank ?x ] =>
    let p := fresh "p" in
    set (p := x)
  end.

Class ChooseIneqOrEq (rhs: hprop) (cmp: int -> int -> Prop) :=
  MkChooseIneqOrEq : (rhs = rhs \* \GC /\ cmp = Z.le) \/ (cmp = eq).

Instance ChooseIneqOrEq_ineq: forall rhs,
  HasGC rhs ->
  ChooseIneqOrEq rhs Z.le.
Proof. intros. unfolds. left~. Qed.

Instance ChooseIneqOrEq_eq: forall rhs,
  ChooseIneqOrEq rhs eq | 100.
Proof. intros. right~. Qed.

Lemma piggybank_credits_ineq: forall h1 h2 l1 l2 h1' h1'' h2' p l1' c1 c2 cmp,
  ChooseIneqOrEq h2 cmp ->
  GetCreditsEvar h1 h1' p ->
  GetCredits h1' h1'' l1 ->
  GetCredits h2 h2' l2 ->
  AddIntList l2 c2 ->
  Snoc l1 (Piggybank ⟨p⟩) l1' ->
  AddIntList l1' c1 ->
  cmp c2 c1 ->
  h1'' ==> h2' ->
  h1 ==> h2.
Proof.
  introv Hcmp -> -> -> -> -> -> Hc HH. unfold ChooseIneqOrEq in Hcmp.
  rewrite big_add_snoc in Hc. unfold heap_is_credits_list in *. hchange HH.
  unfold Piggybank in *. rewrite credits_refine_eq in Hc.
  destruct Hcmp as [ [-> ->] | -> ].
  { hsimpl_credits. math. }
  { rewrite Hc. hsimpl_credits. }
Qed.

Lemma piggybank_inst_0_credits_ineq: forall h1 h2 l1 l2 h1' h1'' h2' p c1 c2 cmp,
  ChooseIneqOrEq h2 cmp ->
  GetCreditsEvar h1 h1' p ->
  Unify p 0 ->
  GetCredits h1' h1'' l1 ->
  GetCredits h2 h2' l2 ->
  AddIntList l2 c2 ->
  AddIntList l1 c1 ->
  cmp c2 c1 ->
  h1'' ==> h2' ->
  h1 ==> h2.
Proof.
  introv Hcmp -> -> -> -> -> -> Hc HH. unfold ChooseIneqOrEq in Hcmp.
  unfold heap_is_credits_list in *. hchange HH. rewrite credits_zero_eq.
  destruct Hcmp as [[-> ->] | ->].
  { hsimpl_credits. math. }
  { rewrite Hc. hsimpl_credits. }
Qed.

(* This is because HasGC might split the frame evar to introduce a \GC, and we
   might want to get rid of it afterwards.. *)
Lemma cleanup_GC_star_evar: forall h1 h2,
  h1 ==> h2 ->
  h1 ==> \GC \* h2.
Proof.
  introv HH. hchange HH. hsimpl.
Qed.

Ltac cleanup_GC_star_evar :=
  match goal with |- _ ==> \GC \* ?h =>
    is_evar h;
    apply cleanup_GC_star_evar
  end.

Ltac piggybank_credits_ineq :=
  eapply piggybank_credits_ineq;
  [ once (typeclasses eauto) ..
  | set_Piggybank
  | try cleanup_GC_star_evar;
    hsimpl_cleanup_trysolve
  ].

Tactic Notation "piggybank:" "*" :=
  piggybank_credits_ineq.

Ltac solve_trivial_ineq :=
  match goal with
  | |- 0 <= 0 => apply Z.le_refl
  | |- 0 = 0 => apply eq_refl
  end.

Ltac piggybank_inst_0_credits_ineq :=
  eapply piggybank_inst_0_credits_ineq;
  [ once (typeclasses eauto) ..
  | try solve_trivial_ineq
  | try cleanup_GC_star_evar; hsimpl_cleanup_trysolve ].

Tactic Notation "piggybank:" "*0" :=
  piggybank_inst_0_credits_ineq.

(* TODO: also handle inequalities (x <= y + Piggybank p) *)
Lemma piggybank_credits_ineq_done : forall x p,
  p = x ->
  x <= Piggybank ⟨p⟩.
Proof. introv ->. rewrite credits_refine_eq. reflexivity. Qed.

Lemma piggybank_credits_eq_done : forall x p,
  p = x ->
  x = Piggybank ⟨p⟩.
Proof. introv ->. rewrite credits_refine_eq. reflexivity. Qed.

Ltac piggybank_credits_ineq_done :=
  match goal with |- context [ Piggybank ?p ] => subst p end;
  first [ apply piggybank_credits_ineq_done
        | apply piggybank_credits_eq_done ];
  reflexivity.

Tactic Notation "piggybank:" "*" "done" :=
  piggybank_credits_ineq_done.

(*********************************)

(* "Pay with piggybank" (riskier):
   ⟨?c⟩ \* H1 ==> \$ a \* \$ b \* H2  ~>  c := a + b

   even if there are other credits in the left-hand side
*)

Lemma pay_with_piggybank: forall h1 h1' h2 h2' c1 l2 c2,
  GetCreditsEvar h1 h1' c1 ->
  GetCredits h2 h2' l2 ->
  AddIntList l2 c2 ->
  Unify c1 c2 ->
  h1' ==> h2' ->
  h1 ==> h2.
Proof.
  introv -> -> -> -> H. xchange H. hsimpl.
Qed.

Ltac piggybank_pay_rhs :=
  eapply pay_with_piggybank; [ once (typeclasses eauto) .. |];
  hsimpl_cleanup_trysolve.

Tactic Notation "piggybank:" "*rhs" :=
  piggybank_pay_rhs.

(** current hsimpl_credits: join the lhs, substract the rhs *)

Lemma substract_left_right_credits: forall h1 h1' h2 h2' l1 l2 c1 c1c2,
  GetCredits h1 h1' l1 ->
  GetCredits h2 h2' l2 ->
  AddIntList l1 c1 ->
  SubIntList c1 l2 c1c2 ->
  \$ c1c2 \* h1' ==> h2' ->
  h1 ==> h2.
Proof.
  introv -> -> -> -> HH.
  rewrite big_sub_big_add in HH.
  unfold heap_is_credits_list.
  assert (big_add l1 = (big_add l1 - big_add l2) + big_add l2) as -> by math.
  rewrite credits_split_eq.
  hchange HH. hsimpl.
Qed.

Ltac substract_credits :=
  match goal with |- context [ \$ _ ] =>
    eapply substract_left_right_credits; [ once (typeclasses eauto) .. |];
    hsimpl_cleanup_trysolve
  end.

(* TEMPORARY we can redefine hsimpl_credits as follows: *)

Ltac hsimpl_credits_core ::=
  hsimpl; try substract_credits.

(*****************************************)

Ltac hcancel_autorefine_credits :=
  hcancel; try piggybank: *rhs.

Ltac hsimpl_autorefine_credits :=
  hsimpl; try piggybank: *rhs.

Ltac xapp_xapply_with_simpl K ::=
  first
  [ applys K  (* useful for specifications that are CF *)
  | xapply_core K ltac:(fun _ => hsimpl_autorefine_credits) ltac:(fun _ => try xok) ].

Ltac xapplys_base H ::=
  xpull_check_not_needed tt;
  xapply_core H ltac:(fun tt => hcancel_autorefine_credits) ltac:(fun tt => hsimpl_autorefine_credits).

(* FIXME FIXME: fix xchange instead *)
Ltac xopen_core t ::=
  let C1 := xopen_constr t in
  ltac_database_get database_xopen C1;
  let K := fresh "TEMP" in
  intros K; xchange_base ltac:(fun tt => hsimpl; hsimpl_cleanup_trysolve) (K t) __; clear K.

Ltac xclose_core args ::=
  let args := list_boxer_of args in
  let C1 := xclose_constr args in
  ltac_database_get database_xclose C1;
  let K := fresh "TEMP" in
  intros K;
  let E := constr:((boxer K)::args) in
  xchange_base ltac:(fun tt => hsimpl; hsimpl_cleanup_trysolve) E __;
  clear K.

(* xcf ******************************************)

(* This is to ensure that credits are put at the head of the precondition. *)

Ltac xcf_post tt ::=
  cbv beta;
  remove_head_unit tt;
  hclean.

(* xpay *****************************************)

Lemma xpay_refine :
  forall A (F: hprop -> (A -> hprop) -> Prop),
  forall cost cost' H H' Q,
  is_local F ->
  GetCreditsEvar H H' cost ->
  cost = 1 + cost' ->
  F (\$ ⟨cost'⟩ \* H') Q ->
  (Pay_ ;; F) H Q.
Proof.
  introv L -> -> HH. rewrite credits_refine_eq in *.
  xpay_start tt.
  { unfold pay_one. rewrite credits_split_eq. hsimpl. }
  xapplys HH.
Qed.

Ltac xpay_refine_core HGCE :=
  eapply xpay_refine; [ xlocal | apply HGCE | reflexivity | xtag_pre_post ].

Ltac standard_xpay tt :=
  (xpay_start tt; [ unfold pay_one; hsimpl | xtag_pre_post ]).

Ltac xpay_core tt ::=
  tryif_refine_cost_goal
    xpay_refine_core
    standard_xpay.

(* xapply *****************************)

(* This is useful for cases where the goal is

     [F (\$ ⟨?c⟩ \* H) (Q \* \$ x)]

   and we do xapp/xapply: we want to split ?c to be able to pay for [\$ x]
   later...
*)

Lemma local_frame_gc_with_credits :
  forall B H1 H2 (Q1: B->hprop) (F:~~B) H H' Q c c1 c2,
  GetCreditsEvar H H' c ->
  c = c1 + c2 ->
  is_local F ->
  F H1 Q1 ->
  \$ ⟨c1⟩ \* H' ==> H1 \* H2 ->
  Q1 \*+ (\$ ⟨c2⟩ \* H2) ===> Q \*+ \GC ->
  F H Q.
Proof.
  introv -> -> L F1 HI1 HI2. rewrite credits_refine_eq in *.
  rewrite credits_split_eq.
  xapply F1. xchange HI1. hsimpl. xchange HI2. hsimpl.
Qed.

Ltac cfml_postcondition_contains_credits tt :=
  let Q := cfml_get_postcondition tt in
  lazymatch Q with
  | context [ \$ _ ] => constr:(true : bool)
  | _ => constr:(false : bool)
  end.

Ltac xapply_refine_core H cont1 cont2 HGCE :=
  forwards_nounfold_then H ltac:(fun K =>
    match cfml_postcondition_is_evar tt with
    | true => eapply local_frame; [ xlocal | sapply K | cont1 tt | try xok ]
    | false =>
      match cfml_postcondition_contains_credits tt with
      | true =>
        eapply local_frame_gc_with_credits;
        [ apply HGCE | reflexivity | xlocal | sapply K | cont1 tt | cont2 tt ]
      | false =>
        eapply local_frame_gc; [ xlocal | sapply K | cont1 tt | cont2 tt ]
      end
    end).

Ltac xapply_standard_core H cont1 cont2 tt :=
  forwards_nounfold_then H ltac:(fun K =>
  match cfml_postcondition_is_evar tt with
  | true => eapply local_frame; [ xlocal | sapply K | cont1 tt | try xok ]
  | false => eapply local_frame_gc; [ xlocal | sapply K | cont1 tt | cont2 tt ]
  end).

Ltac xapply_core H cont1 cont2 ::=
  tryif_refine_cost_goal
    ltac:(xapply_refine_core H cont1 cont2)
    ltac:(xapply_standard_core H cont1 cont2).

(* xret *******************************)

Lemma refine_zero_credits : forall A (F:~~A) H H' c (Q : A -> hprop),
  GetCreditsEvar H H' c ->
  c = 0 ->
  local F H' Q ->
  local F H Q.
Proof.
  introv -> -> HH. now rewrite credits_zero_eq, star_neutral_r.
Qed.

Ltac refine_zero_credits HGCE :=
  eapply refine_zero_credits; [ apply HGCE | reflexivity | ].

Ltac try_refine_zero_credits :=
  tryif_refine_cost_goal ltac:(refine_zero_credits) ltac:(fun _ => idtac).

Ltac xret_apply_lemma tt ::=
  try_refine_zero_credits;
  first [ apply xret_lemma_unify
        | apply xret_lemma ].

Ltac xret_no_gc_core tt ::=
  try_refine_zero_credits;
  first [ apply xret_lemma_unify
        | eapply xret_no_gc_lemma ].

(* xseq *******************************)

Lemma xseq_refine :
  forall (A : Type) cost cost1 cost2 F1 F2 H H' (Q : A -> hprop),
  GetCreditsEvar H H' cost ->
  cost = cost1 + cost2 ->
  is_local F1 ->
  is_local F2 ->
  (exists Q',
    F1 (\$ ⟨cost1⟩ \* H') Q' /\
    F2 (\$ ⟨cost2⟩ \* Q' tt) Q) ->
  (F1 ;; F2) H Q.
Proof.
  introv -> -> L1 L2 (Q' & H1 & H2). rewrite credits_refine_eq in *.
  xseq_pre tt. apply local_erase. eexists. split.
  { xapply H1. credits_split. hsimpl. }
  { xapply H2. hsimpl. hsimpl. }
Qed.

Ltac xseq_refine_core HGCE :=
  eapply xseq_refine; [ apply HGCE | reflexivity | xlocal | xlocal | ].

Ltac xseq_standard_core tt :=
  apply local_erase.

Ltac xseq_core cont0 cont1 ::=
  (tryif_refine_cost_goal xseq_refine_core xseq_standard_core);
  cont0 tt;
  split; [ | cont1 tt ];
  xtag_pre_post.

(* xlet *****************************************)

Lemma xlet_refine :
  forall
    (A B : Type) cost cost1 cost2
    (F1 : hprop -> (A -> hprop) -> Prop)
    (F2 : A -> hprop -> (B -> hprop) -> Prop)
    (H H' : hprop) (Q : B -> hprop),
  GetCreditsEvar H H' cost ->
  cost = cost1 + cost2 ->
  is_local F1 ->
  (forall x, is_local (F2 x)) ->
  (exists (Q' : A -> hprop),
    F1 (\$ ⟨cost1⟩ \* H') Q' /\
    (forall r, F2 r (\$ ⟨cost2⟩ \* Q' r) Q)) ->
  cf_let F1 F2 H Q.
Proof.
  introv -> -> L1 L2 (Q' & H1 & H2). rewrite credits_refine_eq in *.
  unfold cf_let.
  eexists. split.
  { xapply H1. credits_split. hsimpl. }
  { intro r. specializes L2 r. xapply H2; hsimpl. }
Qed.

Ltac xlet_refine_core cont0 cont1 cont2 HGCE :=
  apply local_erase;
  match goal with |- cf_let ?F1 (fun x => _) ?H ?Q =>
    eapply xlet_refine; [ apply HGCE | reflexivity | xlocal | intro; xlocal | ];
    cont0 tt;
    split; [ | cont1 x; cont2 tt ];
    xtag_pre_post
  end.

Ltac xlet_standard_core cont0 cont1 cont2 tt :=
  apply local_erase;
  match goal with |- cf_let ?F1 (fun x => _) ?H ?Q =>
    cont0 tt;
    split; [ | cont1 x; cont2 tt ];
    xtag_pre_post
  end.

Ltac xlet_core cont0 cont1 cont2 ::=
  tryif_refine_cost_goal
    ltac:(xlet_refine_core cont0 cont1 cont2)
    ltac:(xlet_standard_core cont0 cont1 cont2).

(* xif ********************************)

Lemma xif_refine : forall (A: Type) cost cost1 cost2 cond (F1 F2: ~~A) H H' Q,
  GetCreditsEvar H H' cost ->
  cost = Z.max cost1 cost2 ->
  is_local F1 ->
  is_local F2 ->
  ((cond = true -> F1 (\$ ⟨cost1⟩ \* H') Q) /\
   (cond = false -> F2 (\$ ⟨cost2⟩ \* H') Q)) ->
  (If_ cond Then F1 Else F2) H Q.
Proof.
  introv -> -> L1 L2 (H1 & H2). rewrite credits_refine_eq in *.
  apply local_erase.
  split; intro; [xapply~ H1 | xapply~ H2]; hsimpl_credits;
  math_lia.
Qed.

Ltac xif_refine_core HGCE :=
  eapply xif_refine; [ apply HGCE | reflexivity | xlocal | xlocal | ].

Ltac xif_standard_core tt :=
  xuntag tag_if; apply local_erase.

Ltac xif_base cont1 cont2 ::=
  xpull_check_not_needed tt;
  xif_check_post_instantiated tt;
  let cont tt :=
    tryif_refine_cost_goal xif_refine_core xif_standard_core;
    split; [ cont1 tt | cont2 tt ];
    xtag_pre_post
  in
  match cfml_get_tag tt with
  | tag_if => cont tt
  | tag_let => xlet; [ cont tt | instantiate ]
  end.

(* xif_guard: prototype *)

Lemma xif_guard_refine :
  forall (A: Type) cost cost1 cost2 (cond cond': bool) (F1 F2: ~~A) H H' Q,
  GetCreditsEvar H H' cost ->
  (cost = If cond' then cost1 else cost2) ->
  (cond = cond') ->
  is_local F1 ->
  is_local F2 ->
  ((cond = true -> F1 (\$ ⟨cost1⟩ \* H') Q) /\
   (cond = false -> F2 (\$ ⟨cost2⟩ \* H') Q)) ->
  (If_ cond Then F1 Else F2) H Q.
Proof.
  introv -> -> costE L1 L2 (H1 & H2). rewrite credits_refine_eq in *.
  apply local_erase. rewrite costE.
  split; intro C; rewrite C; cases_if; [xapply~ H1 | xapply~ H2].
Qed.

Ltac xif_guard_refine_core cont HGCE :=
  eapply xif_guard_refine;
  [ apply HGCE | reflexivity | try reflexivity | xlocal | xlocal | ];
  [ .. | split; cont tt; xtag_pre_post ].

Ltac xif_guard_core H :=
  tryif_refine_cost_goal
    ltac:(xif_guard_refine_core ltac:(fun _ => intro H; xif_post H))
    ltac:(fun tt => fail 100 "No credit evar found").

Tactic Notation "xif_guard" "as" ident(H) :=
  xif_guard_core H.
Tactic Notation "xif_guard" :=
  let H := fresh "C" in xif_guard as H.

(* xguard ***************************************)

Lemma xguard_refine :
  forall A (cost cost' : int) (F: ~~A) (G: Prop) H H' Q,
  GetCreditsEvar H H' cost ->
  (cost = If G then cost' else 0) ->
  G ->
  F (\$ ⟨cost'⟩ \* H') Q ->
  F H Q.
Proof.
  introv -> -> HG HH. rewrite credits_refine_eq in *. cases_if.
  now rewrite star_comm.
Qed.

Ltac xguard G :=
  tryif_refine_cost_goal
    ltac:(fun HGCE =>
      eapply xguard_refine; [ apply HGCE | reflexivity | eexact G | ])
    ltac:(fun tt =>
      fail 100 "No credit evar found").

(* xfor *****************************************)

(* TODO: prove using xfor_inv_case_lemma_refine instead of directly *)
Lemma xfor_inv_lemma_pred_refine :
  forall
    (I : int -> hprop)
    cost (cost_body : int -> int)
    (a : int) (b : int) (F : int-> ~~unit) H H1 H',
  GetCreditsEvar H H1 cost ->
  cost = cumul a b cost_body ->
  (a <= b) ->
  (forall i, a <= i < b -> F i (\$ ⟨cost_body i⟩ \* I i) (# I(i+1))) ->
  (H1 ==> I a \* H') ->
  (forall i, is_local (F i)) ->
  (For i = a To (b - 1) Do F i Done_)
    H
    (# I b \* H').
Proof.
Admitted. (* TODO *)

Lemma xfor_inv_case_lemma_refine : forall (I:int->hprop),
   forall (cost : int) (cost_body : int -> int),
   forall (a:int) (b:int) (F:int->~~unit) H H1 (Q:unit->hprop),
   GetCreditsEvar H H1 cost ->
   ((a <= b) -> exists H',
          (H1 ==> I a \* H')
       /\ (forall i, is_local (F i))
       /\ (forall i, a <= i <= b -> F i (\$ ⟨cost_body i⟩ \* I i) (# I(i+1)))
       /\ (cost = cumul a b cost_body)
       /\ (I (b+1) \* H' ==> Q tt \* \GC)) ->
   ((a > b) ->
          (cost = 0)
       /\ (H1 ==> Q tt \* \GC)) ->
   (For i = a To b Do F i Done_) H Q.
Proof.
Admitted. (* TODO *)

Lemma xfor_inv_lemma_refine : forall (I:int->hprop),
  forall cost (cost_body : int -> int),
  forall (a:int) (b:int) (F:int->~~unit) H H1 H',
  GetCreditsEvar H H1 cost ->
  (cost = cumul a (b + 1) cost_body) ->
  (a <= b+1) ->
  (forall i, a <= i <= b -> F i (\$ ⟨cost_body i⟩ \* I i) (# I(i+1))) ->
  (H1 ==> I a \* H') ->
  (forall i, is_local (F i)) ->
  (For i = a To b Do F i Done_)
    H
    (# I (b+1) \* H').
Proof using.
Admitted. (* TODO *)

Lemma xfor_inv_void_lemma_refine :
  forall (a:int) (b:int) (F:int->~~unit) H H' (cost : int),
  GetCreditsEvar H H' cost ->
  cost = 0 ->
  (a > b) ->
  (For i = a To b Do F i Done_) H (# H').
Proof using.
Admitted. (* TODO *)

Ltac xfor_inv_refine_core I HGCE :=
  first [
      eapply (@xfor_inv_lemma_pred_refine I)
    | eapply (@xfor_inv_lemma_refine I) ];
  [ apply HGCE | reflexivity | | xtag_pre_post | | intro; xlocal ].

Ltac xfor_inv_standard_core I tt :=
  first [
      apply (@xfor_inv_lemma_pred I)
    | apply (@xfor_inv_lemma I) ];
  [ | xtag_pre_post | | intro; xlocal ].

Ltac xfor_inv_core I ::=
  xfor_pre_ensure_evar_post ltac:(fun _ =>
    tryif_refine_cost_goal
      ltac:(xfor_inv_refine_core I)
      ltac:(xfor_inv_standard_core I)).

Ltac xfor_inv_void_core tt ::=
  xfor_pre_ensure_evar_post ltac:(fun _ =>
    tryif_refine_cost_goal
      ltac:(fun HGCE =>
        eapply (@xfor_inv_void_lemma_refine);
        [ apply HGCE | reflexivity ])
      ltac:(fun tt =>
        apply (@xfor_inv_void_lemma))).

(* TODO: xfor_inv_case *)

(* xcase ****************************************)

Lemma cf_max_credits_weaken_l :
  forall B (F : ~~B) H Q c1 c2,
    is_local F ->
    F (\$ ⟨c1⟩ \* H) Q ->
    F (\$ Z.max c1 c2 \* H) Q.
Proof.
  introv ? HH. rewrite credits_refine_eq in *. xapply HH. hsimpl_credits.
  hsimpl. math_lia.
Qed.

Lemma cf_max_credits_weaken_r :
  forall B (F : ~~B) H Q c1 c2,
    is_local F ->
    F (\$ ⟨c2⟩ \* H) Q ->
    F (\$ Z.max c1 c2 \* H) Q.
Proof.
  introv ? HH. rewrite credits_refine_eq in *. xapply HH. hsimpl_credits.
  hsimpl. math_lia.
Qed.

Lemma xcase_refine :
  forall (B:Type) (Case1 Case2: ~~B) c c1 c2 H H' (Q: B -> hprop),
    GetCreditsEvar H H' c ->
    c = Z.max c1 c2 ->
    (Case1 (\$ c \* H') Q) ->
    (Case2 (\$ c \* H') Q) ->
    (tag tag_case (local (fun H Q => Case1 H Q /\ Case2 H Q))) H Q.
Proof.
  introv -> -> HT HF. unfold tag. apply local_erase.
  now rewrite star_comm.
Qed.

Ltac xcase_refine_sidecondition_1 :=
  eapply cf_max_credits_weaken_l; [ xlocal |].

Ltac xcase_refine_sidecondition_2 :=
  eapply cf_max_credits_weaken_r; [ xlocal |].

Ltac xcase_core H cont1 cont2 ::=
  tryif_refine_cost_goal
    ltac:(fun HGCE =>
      eapply xcase_refine; [
        apply HGCE | reflexivity
      | introv H; xcase_refine_sidecondition_1; cont1 tt
      | introv H; xcase_refine_sidecondition_2; xtag_negpat H; cont2 tt ];
      xtag_pre_post)
    ltac:(fun tt =>
      (* original CFML implementation *)
      xuntag tag_case; apply local_erase; split;
      [ introv H; cont1 tt
      | introv H; xtag_negpat H; cont2 tt ];
      xtag_pre_post).

Ltac xcase_no_intros_core cont1 cont2 ::=
  tryif_refine_cost_goal
    ltac:(fun HGCE =>
      eapply xcase_refine; [
        apply HGCE | reflexivity
      | pose ltac_mark; introv ?; xcase_refine_sidecondition_1; gen_until_mark;
        cont1 tt
      | pose ltac_mark; introv ?; xcase_refine_sidecondition_2; gen_until_mark;
        cont2 tt
      ];
      xtag_pre_post)
    ltac:(fun tt =>
      (* original CFML implementation *)
      xuntag tag_case; apply local_erase; split;
      [ cont1 tt
      | cont2 tt ];
      xtag_pre_post).

Ltac xcase_post_cfml H :=
  (* original CFML implementation *)
  try solve [ discriminate | false; congruence ];
  try (symmetry in H; inverts H; xclean_trivial_eq tt).

(* Use backtracking to instantiate the goal with zero credits only if we manage
   to prove it afterwards *)
Ltac xcase_post H ::=
  tryif_refine_cost_goal
    ltac:(fun HGCE =>
      first [
        refine_zero_credits HGCE;
        solve [ xcase_post_cfml H ]
      | xcase_post_cfml H ])
    ltac:(fun tt =>
      xcase_post_cfml H).

(* xfail ****************************************)

Ltac xfail_core tt ::=
  xpull_check_not_needed tt;
  xuntag tag_fail;
  try_refine_zero_credits;
  apply local_erase;
  xtag_pre_post.

(* xdone ****************************************)

(* Unfortunately, this is not enough: we cannot override the previous uses of
   the notation. This is why we also need to redefine the tactics that were
   using xdone... (see below). *)

Tactic Notation "xdone" :=
  xuntag tag_done;
  try_refine_zero_credits;
  apply local_erase; split.

Ltac xmatch_case_core cont_case ::=
  match cfml_get_tag tt with
  | tag_done => xdone
  | tag_fail => xfail
  | tag_case => cont_case tt
  | _ => fail 100 "unexpected tag in xmatch_case"
  end.

Ltac xstep_once tt :=
  match cfml_get_tag tt with
  | tag_ret => xret
  | tag_apply => xapp
  | tag_none_app => xapp
  | tag_record_new => xapp
  | tag_val => xval
  | tag_fun => xfun
  | tag_let => xlet
  | tag_match => xmatch
  | tag_case => xcase
  | tag_fail => xfail
  | tag_done => xdone
  | tag_alias => xalias
  | tag_seq => xseq
  | tag_if => xif
  | tag_for => fail 1
  | tag_while => fail 1
  | tag_assert => xassert
  | tag_pay => xpay
  | _ =>
     match goal with
     | |- _ ==> _ => first [ xsimpl | fail 2 ]
     | |- _ ===> _ => first [ xsimpl | fail 2 ]
     end
  end.

(*******************)

(* TODO: move to CFML *)

Tactic Notation "xapp_spec_no_simpl" constr(H) :=
  xapp_no_simpl_core H (>>) ltac:(fun _ => idtac).
Tactic Notation "xapp_spec_no_simpl" constr(H) constr(E) :=
  xapp_no_simpl_core H E ltac:(fun _ => idtac).


(* ** Imports and settings *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import word_ssrZ.
Require Export type expr sem_type.
Require Export flag_combination.
Import Utf8.

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

Definition sem_sop1_typed (o: sop1) :
  let t := type_of_op1 o in
  sem_t t.1 → sem_t t.2 :=
  match o with
  | Oword_of_int sz => wrepr sz
  | Oint_of_word sz => wunsigned
  | Osignext szo szi => @sign_extend szo szi
  | Ozeroext szo szi => @zero_extend szo szi
  | Onot => negb
  | Olnot sz => wnot
  | Oneg Op_int => Z.opp
  | Oneg (Op_w sz) => (-%R)%R
  end.

Arguments sem_sop1_typed : clear implicits.

Definition zlsl (x i : Z) : Z :=
  if (0 <=? i)%Z then (x * 2^i)%Z
  else (x / 2^(-i))%Z.

Definition zasr (x i : Z) : Z :=
  zlsl x (-i).

Definition sem_shift (shift:forall {s}, word s -> Z -> word s) s (v:word s) (i:u8) :=
  let i :=  wunsigned (wand i (x86_shift_mask s)) in
  shift v i.

Definition sem_shr {s} := @sem_shift (@wshr) s.
Definition sem_sar {s} := @sem_shift (@wsar) s.
Definition sem_shl {s} := @sem_shift (@wshl) s.
Definition sem_ror {s} := @sem_shift (@wror) s.
Definition sem_rol {s} := @sem_shift (@wrol) s.

Definition sem_vadd (ve:velem) {ws:wsize} := (lift2_vec ve +%R ws).
Definition sem_vsub (ve:velem) {ws:wsize} := (lift2_vec ve (fun x y => x - y)%R ws).
Definition sem_vmul (ve:velem) {ws:wsize} := (lift2_vec ve *%R ws).

Definition sem_vshr (ve:velem) {ws:wsize} (v : word ws) (i:u8) :=
  lift1_vec ve (fun x => wshr x (wunsigned i)) ws v.

Definition sem_vsar (ve:velem) {ws:wsize} (v : word ws) (i:u8) :=
  lift1_vec ve (fun x => wsar x (wunsigned i)) ws v.

Definition sem_vshl (ve:velem) {ws:wsize} (v : word ws) (i:u8) :=
  lift1_vec ve (fun x => wshl x (wunsigned i)) ws v.

Definition signed {A:Type} (fu fs:A) s :=
  match s with
  | Unsigned => fu
  | Signed => fs
  end.

Definition mk_sem_divmod sz o (w1 w2: word sz) : exec (word sz) :=
  if ((w2 == 0) || ((wsigned w1 == wmin_signed sz) && (w2 == -1)))%R then type_error
  else ok (o w1 w2).

Definition mk_sem_sop2 (t1 t2 t3: Type) (o:t1 -> t2 -> t3) v1 v2 : exec t3 :=
  ok (o v1 v2).

Definition sem_sop2_typed (o: sop2) :
  let t := type_of_op2 o in
  sem_t t.1.1 → sem_t t.1.2 → exec (sem_t t.2) :=
  match o with
  | Obeq => mk_sem_sop2 (@eq_op [eqType of bool])
  | Oand => mk_sem_sop2 andb
  | Oor  => mk_sem_sop2 orb

  | Oadd Op_int      => mk_sem_sop2 Z.add
  | Oadd (Op_w s)    => mk_sem_sop2 +%R
  | Omul Op_int      => mk_sem_sop2 Z.mul
  | Omul (Op_w s)    => mk_sem_sop2 *%R
  | Osub Op_int      => mk_sem_sop2 Z.sub
  | Osub (Op_w s)    => mk_sem_sop2 (fun x y =>  x - y)%R
  | Odiv Cmp_int     => mk_sem_sop2 Z.div
  | Odiv (Cmp_w u s) => @mk_sem_divmod s (signed wdiv wdivi u)
  | Omod Cmp_int     => mk_sem_sop2 Z.modulo
  | Omod (Cmp_w u s) => @mk_sem_divmod s (signed wmod wmodi u)

  | Oland s       => mk_sem_sop2 wand
  | Olor  s       => mk_sem_sop2 wor
  | Olxor s       => mk_sem_sop2 wxor
  | Olsr s        => mk_sem_sop2 sem_shr
  | Olsl Op_int   => mk_sem_sop2 zlsl
  | Olsl (Op_w s) => mk_sem_sop2 sem_shl
  | Oasr Op_int   => mk_sem_sop2 zasr
  | Oasr (Op_w s) => mk_sem_sop2 sem_sar
  | Oror s        => mk_sem_sop2 sem_ror
  | Orol s        => mk_sem_sop2 sem_rol

  | Oeq Op_int    => mk_sem_sop2 Z.eqb
  | Oeq (Op_w s)  => mk_sem_sop2 eq_op
  | Oneq Op_int   => mk_sem_sop2 (fun x y => negb (Z.eqb x y))
  | Oneq (Op_w s) => mk_sem_sop2 (fun x y => (x != y))

  (* Fixme use the "new" Z *)
  | Olt Cmp_int   => mk_sem_sop2 Z.ltb
  | Ole Cmp_int   => mk_sem_sop2 Z.leb
  | Ogt Cmp_int   => mk_sem_sop2 Z.gtb
  | Oge Cmp_int   => mk_sem_sop2 Z.geb

  | Olt (Cmp_w u s) => mk_sem_sop2 (wlt u)
  | Ole (Cmp_w u s) => mk_sem_sop2 (wle u)
  | Ogt (Cmp_w u s) => mk_sem_sop2 (fun x y => wlt u y x)
  | Oge (Cmp_w u s) => mk_sem_sop2 (fun x y => wle u y x)
  | Ovadd ve ws     => mk_sem_sop2 (sem_vadd ve)
  | Ovsub ve ws     => mk_sem_sop2 (sem_vsub ve)
  | Ovmul ve ws     => mk_sem_sop2 (sem_vmul ve)
  | Ovlsr ve ws     => mk_sem_sop2 (sem_vshr ve)
  | Ovlsl ve ws     => mk_sem_sop2 (sem_vshl ve)
  | Ovasr ve ws     => mk_sem_sop2 (sem_vsar ve)
  end.

Arguments sem_sop2_typed : clear implicits.

Section WITH_PARAMS.

Context {cfcd : FlagCombinationParams}.

Definition sem_combine_flags
  (o : combine_flags) (bof bcf bsf bzf : bool) : exec bool :=
  let '(n, cfc) := cf_tbl o in
  let b := cfc_xsem negb andb orb (fun x y => x == y) bof bcf bsf bzf cfc in
  ok (if n then ~~ b else b).

Definition sem_opN_typed (o: opN) :
  let t := type_of_opN o in
  sem_prod t.1 (exec (sem_t t.2)) :=
  match o with
  | Opack sz pe => curry (A := sint) (sz %/ pe) (λ vs, ok (wpack sz pe vs))
  | Ocombine_flags o => sem_combine_flags o
  end.

End WITH_PARAMS.


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 X Y Z1 Z2 I : Universe, ((wd_ Z1 I /\ (wd_ I Z2 /\ (wd_ Z1 Z2 /\ (col_ X I Y /\ (col_ Z1 I Z2 /\ (col_ Y Z1 Z2 /\ col_ X Z1 Z2)))))) -> col_ X Y Z2)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj24synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (plus (mult lv0 (plus lv1 Zero)) lv1) lv0)) (plus (mult lv0 lv2) lv2)).
Admitted.
QuickChick conj24synthconj3.


Require Import ssreflect.
From Tweetnacl.Libs Require Import Export.
From Tweetnacl.Libs Require Import HeadTailRec.
From Tweetnacl.Gen Require Import Get_abcdef.
From Tweetnacl.Gen Require Import AMZubSqSel.
From Tweetnacl.Gen Require Import ABCDEF.
From Tweetnacl.Gen Require Import montgomery_step_gen.
From Tweetnacl.Gen Require Import montgomery_rec.
From Tweetnacl.Gen Require Import step_gen.
From Tweetnacl.Gen Require Import abstract_rec.
From Tweetnacl.Gen Require Import abstract_rec_rev.
From Tweetnacl.Gen Require Import abstract_fn_rev.
From Tweetnacl.Gen Require Import abstract_rec_rev_eq.

Open Scope Z.

Section Montgomery_Rec_Eq.

Context {T : Type}.
Context {T' : Type}.
Context {Mod : T -> T}.
Context {O : Ops T T' Mod}.

Theorem montgomery_rec_eq: forall n z a b c d e f x,
  montgomery_rec n z a b c d e f x =
  abstract_rec n z a b c d e f x.
Proof.
induction n ; intros.
reflexivity.
simpl.
apply IHn.
Qed.

Theorem montgomery_rec_eq_rev: forall n z a b c d e f x,
  montgomery_rec (S n) z a b c d e f x =
  abstract_rec_rev (S n) n z a b c d e f x.
Proof.
intros.
rewrite montgomery_rec_eq.
rewrite abstract_rec_equiv_rec_fn.
rewrite abstract_rec_rev_equiv_rec_fn_S_n.
apply Tail_Head_equiv.
Qed.

Theorem montgomery_rec_eq_fn_rev: forall n z a b c d e f x,
  0 <= n ->
  montgomery_rec (S (Z.to_nat n)) z a b c d e f x =
  abstract_fn_rev (n + 1) n z a b c d e f x.
Proof.
intros.
rewrite montgomery_rec_eq_rev.
replace (S (Z.to_nat n)) with (Z.to_nat (n + 1)).
2: rewrite -Z2Nat.inj_succ ; change (Z.succ n) with (n + 1).
rewrite abstract_fn_rev_eq.
reflexivity.
all: omega.
Qed.

End Montgomery_Rec_Eq.

Close Scope Z.


Parameter A : Set.
Definition Eq : A -> A -> Prop :=
  (fun a b => forall P : A -> Prop, P a -> P b)
.

Lemma Eq_eq : forall x y, Eq x y <-> x = y.
Proof.
  intros.
  unfold Eq.
  intuition auto.

  apply H.
  reflexivity.

  rewrite <-H.
  apply H0.

Qed.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier ProofIrrelevance FunctionalExtensionality Psatz.
Require Import Coq.omega.Omega.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.
Global Set Bullet Behavior "Strict Subproofs".

Section rec_convert_unary.
Variable X: eqType.
Variable size: X → R.
Variable A A' B : X → finType.
Variable ΩT: ∀ x, distrib (A x).
Variable ΩT': ∀ x, distrib (A' x).
Variable Ωh: ∀ x, distrib (B x).
Variable T: ∀ x: X, rrvar (ΩT x).
Variable T': ∀ x: X, rrvar (ΩT' x).
Variable h: ∀ x: X, rvar (Ωh x) X.
Variable P: X → Prop.
Variable hP: ∀ x n, P x → P  ((h x) n).
Variable G: R → R.
Variable a: R → R.

Lemma eq_dist_unary_rec_gt:
  (∀ z, P z → eq_dist (T' z) (T z)) →
  (∀ z r, P z → pr_gt (T z) r <= \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_gt (rvar_comp (T (sval x')) G) (r - a (size z))))
                        →
  ∀ z r,
  P z →
  pr_gt (T' z) r <= \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_gt (rvar_comp (T' (sval x')) G) (r - a (size z))).
Proof.
  intros Heq_dist Hrec z r HP. rewrite (proj1 (eq_dist_pr_gt _ _) (Heq_dist _ HP)).
  etransitivity; first apply Hrec; auto.
  right.
  apply eq_bigr => i ?. f_equal.
  apply (proj1 (eq_dist_pr_gt (rvar_comp (T (sval i)) G)
                                 (rvar_comp (T' (sval i)) G))).
  apply: eq_dist_comp.
  intros r'.
  rewrite ?Heq_dist //.
  destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
  destruct Hin as (x&<-). by apply hP.
Qed.

Variable Trec:
  ∀ x r, P x → pr_eq (T x) r = \big[Rplus/0]_(x' : imgT (h x))
                        (pr_eq (h x) (sval x') * pr_eq (rvar_comp (T (sval x')) G)
                                                       (r - a (size x))).

Lemma img_Trec_unary b z x:
  P z →
  pr_eq (rvar_comp (T x) G) b ≠ 0 →
  x \in img (h z) →
  pr_eq (h z) x ≠ 0 →
  b + a (size z) \in img (T z).
Proof.
  intros HP Hneq0 Hin Hneq0'. apply pr_img.
  specialize (Rmult_neq_0_compat _ _ Hneq0 Hneq0'). intros.
  enough (Hneq: pr_eq (T z) (b + a (size z)) ≠ 0).
  { move:Hneq. rewrite /pr_eq.
    intros. edestruct (ge_pr_0 (rvar_dist (T z))) as [|Heq0]; first eauto.
    rewrite Heq0 in Hneq. congruence. }
  rewrite Trec; last done.
  intros Hfalse.
  symmetry in Hfalse.
  enough (Hfalse': ∀ x', x' \in img (h z) → pr_eq (h z) x' *
                  (pr_eq (rvar_comp (T x') G)
                     (b + a (size z) - a (size z))) = 0).
  { specialize (Hfalse' x). move:Hfalse'.
    rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r.
    rewrite Rmult_comm. auto.
  }
  intros x' Hin'. edestruct (Req_dec) as [Heq|Hneq]; first apply Heq.
  exfalso. eapply Rlt_not_eq; last apply Hfalse.
  apply Rlt_0_bigr.
  - intros. replace 0 with (0 * 0) by nra. apply Rmult_le_compat; try nra.
    * apply Rge_le, ge_pr_0.
    * apply Rge_le, ge_pr_0.
  - exists (exist _ x' Hin'); repeat split; auto.
    rewrite //=.
    specialize (pr_eq_ge_0 (h z) x').
    specialize (pr_eq_ge_0 (rvar_comp (T x') G)
                           (b + a (size z) - a (size z))).
    clear -Hneq. rewrite //=. intros ??.  rewrite //= in Hneq. nra.
Qed.

Lemma eq_dist_unary_rec:
  (∀ z, P z → eq_dist (T' z) (T z)) →
  ∀ z r,
  P z →
  pr_eq (T' z) r = \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_eq (rvar_comp (T' (sval x')) G) (r - a (size z))).
Proof.
  intros Heq_dist z r HP. rewrite Heq_dist // Trec //.
  apply eq_bigr => i ?. f_equal.
  apply: eq_dist_comp.
  intros r'.
  rewrite ?Heq_dist //.
  destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
  destruct Hin as (x&<-). by apply hP.
Qed.

Lemma rec_pr_rec_gt_unary z r:
  P z →
  pr_gt (T z) r ≤ \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') *
                         pr_gt (rvar_comp (T (sval x')) G) (r - a (size z))).
Proof.
  rewrite /pr_gt pr_gt_alt3.
  etransitivity.
  { right. eapply eq_bigr => ? _. by apply Trec. }
  rewrite //=.
  rewrite exchange_big //=.
  apply Rle_bigr => x'.
  rewrite -big_distrr //=.
  set (Trec' := rvar_comp (T (sval x')) G);
    rewrite -/Trec'.
  transitivity (pr_eq (h z) (sval x') *
                \big[Rplus/0]_(i : imgT (A:=A z) (T z)
                              | (Rgt_dec (sval i) r) && (pr_eq Trec' ((sval i) - a (size z)) != 0))
                 pr_eq Trec' ((sval i) - a (size z))).
  {
    right. symmetry.
    eapply Rmult_eq_0_inv_r => Hneq //=. rewrite /index_enum.
    apply (@sum_reidx_map  [finType of imgT (T z)] _ _ _ _ _ (λ x, x)); auto.
    - rewrite /id //=. intros ??. move/andP=>[? ?].
      split; auto. rewrite mem_filter. apply /andP.
      split; auto.
    - intros b Hin' HQ Hfalse.
      case (Req_dec (pr_eq Trec' (sval b - a (size z))) 0); auto.
      intros Hneq0. exfalso. eapply Hfalse.
      exists b. rewrite mem_filter in Hin'. move /andP in Hin'. destruct Hin' as [-> ->].
      split; auto. rewrite //=. split; auto.
      move: Hneq0. move /eqP => -> //.
    - rewrite -enumT. apply enum_uniq.
    - rewrite -enumT. apply filter_uniq => //=. apply: enum_uniq.
  }
  transitivity (pr_eq (h z) (sval x') * pr_gt Trec' (r - a (size z))).
  {
    right.
    eapply Rmult_eq_0_inv_r => Hneq.
    rewrite /pr_gt. rewrite pr_gt_alt3.
    rewrite -(big_map sval (λ x, (Rgt_dec x r) && (pr_eq _ (x - _) != 0))
                           (λ i, pr_eq Trec' (i - a (size z)))).
    rewrite -(big_map sval (λ x, true) (λ i, pr_eq Trec' i)).
    eapply (@sum_reidx_map _ _ _ _ _ _ (λ x, x - a (size z))); auto.
    - intros a0 ?. move/andP => [Hgt HPr]. split; last done.
      move:Hgt. intros Hlt'.
      rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
      rewrite mem_filter. apply /andP. split.
      ** rewrite //=. do 2 destruct (Rgt_dec) => //=; nra.
      ** apply /mapP.
           assert (Hpf: a0 - a (size z) \in img Trec').
           { apply pr_img. edestruct (ge_pr_0 (rvar_dist Trec')) as [Hgt|Heq]; first apply Hgt.
             move /eqP in HPr. rewrite /pr_eq in HPr. rewrite //= in Heq. }
           exists (exist _ (a0 - a (size z)) Hpf); last by done.
           rewrite [Finite.enum]unlock //=. apply img_fin_mem.
  - intros b.
    rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
    rewrite mem_filter.  move /andP =>[Hgt Hin'] _ Hfalse.
    case (Req_dec (pr_eq Trec' b) 0); auto.
    intros Hneq'.
    exfalso; apply Hfalse.
    exists (b + a (size z)).
    repeat split.
    * assert (b + a (size z) \in img (T z)) as Hin.
      { eapply img_Trec_unary; eauto. destruct x'; auto. }
      rewrite -mem_undup. rewrite img_alt'.
      exists (exist _ (b + a (size z)) Hin).
      rewrite //=.
    * apply /andP; split.
      ** do 2 destruct (Rgt_dec) => //=. nra.
      ** rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply /eqP. done.
    * rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply /eqP. done.
  - rewrite /index_enum//=. rewrite [Finite.enum]unlock //= img_fin_enum_sval_comp.
    apply undup_uniq.
  - rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
    apply filter_uniq. rewrite /index_enum//=.
    rewrite [Finite.enum]unlock //= img_fin_enum_sval_comp.
    apply undup_uniq.
  - intros ??. intros. nra.
  }
  apply Rmult_le_compat_l; first by apply Rge_le, ge_pr_0.
  rewrite /Trec'//=. reflexivity.
Qed.

End rec_convert_unary.

Section rec_convert.
Variable X: eqType.
Variable size: X → R.
Variable A A' B : X → finType.
Variable ΩT: ∀ x, distrib (A x).
Variable ΩT': ∀ x, distrib (A' x).
Variable Ωh: ∀ x, distrib (B x).
Variable T: ∀ x: X, rrvar (ΩT x).
Variable T': ∀ x: X, rrvar (ΩT' x).
Variable h: ∀ x: X, rvar (Ωh x) [eqType of X * X]%type.
Variable P: X → Prop.
Variable hP: ∀ x n, P x → P (fst ((h x) n)) ∧ P (snd ((h x) n)).
Variable G: R * R → R.
Variable a: R → R.

Lemma eq_dist_rec_gt:
  (∀ z, P z → eq_dist (T' z) (T z)) →
  (∀ z r, P z → pr_gt (T z) r <= \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_gt (rvar_comp (rvar_pair (T (fst (sval x')))
                                                                          (T (snd (sval x'))))
                                       G) (r - a (size z)))) →
  ∀ z r,
  P z →
  pr_gt (T' z) r <= \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_gt (rvar_comp (rvar_pair (T' (fst (sval x')))
                                                                          (T' (snd (sval x'))))
                                       G) (r - a (size z))).
Proof.
  intros Heq_dist Hrec z r HP. rewrite (proj1 (eq_dist_pr_gt _ _) (Heq_dist _ HP)).
  etransitivity; first apply Hrec; auto.
  right.
  apply eq_bigr => i ?. f_equal.
  apply (proj1 (eq_dist_pr_gt (rvar_comp (rvar_pair (T (sval i).1) (T (sval i).2)) G)
                              (rvar_comp (rvar_pair (T' (sval i).1) (T' (sval i).2)) G))).
  apply: eq_dist_comp.
  intros (r1&r2).
  rewrite ?pr_eq_rvar_pair ?Heq_dist //.
  - destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
    destruct Hin as (x&<-). by apply hP.
  - destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
    destruct Hin as (x&<-). by apply hP.
Qed.

Variable Trec:
  ∀ x r, P x → pr_eq (T x) r = \big[Rplus/0]_(x' : imgT (h x))
                        (pr_eq (h x) (sval x') * pr_eq (rvar_comp (rvar_pair (T (fst (sval x')))
                                                                          (T (snd (sval x'))))
                                       G) (r - a (size x))).

Lemma img_Trec_work b z x:
  P z →
  pr_eq (rvar_comp (rvar_pair (T x.1) (T x.2)) G) b ≠ 0 →
  x \in img (h z) →
  pr_eq (h z) x ≠ 0 →
  b + a (size z) \in img (T z).
Proof.
  intros HP Hneq0 Hin Hneq0'. apply pr_img.
  specialize (Rmult_neq_0_compat _ _ Hneq0 Hneq0'). intros.
  enough (Hneq: pr_eq (T z) (b + a (size z)) ≠ 0).
  { move:Hneq. rewrite /pr_eq.
    intros. edestruct (ge_pr_0 (rvar_dist (T z))) as [|Heq0]; first eauto.
    rewrite Heq0 in Hneq. congruence. }
  rewrite Trec; last done.
  intros Hfalse.
  symmetry in Hfalse.
  enough (Hfalse': ∀ x', x' \in img (h z) → pr_eq (h z) x' *
                  (pr_eq (rvar_comp (rvar_pair (T x'.1) (T x'.2)) G)
                     (b + a (size z) - a (size z))) = 0).
  { specialize (Hfalse' x). move:Hfalse'.
    rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r.
    rewrite Rmult_comm. auto.
  }
  intros x' Hin'. edestruct (Req_dec) as [Heq|Hneq]; first apply Heq.
  exfalso. eapply Rlt_not_eq; last apply Hfalse.
  apply Rlt_0_bigr.
  - intros. replace 0 with (0 * 0) by nra. apply Rmult_le_compat; try nra.
    * apply Rge_le, ge_pr_0.
    * apply Rge_le, ge_pr_0.
  - exists (exist _ x' Hin'); repeat split; auto.
    rewrite //=.
    specialize (pr_eq_ge_0 (h z) x').
    specialize (pr_eq_ge_0 (rvar_comp (rvar_pair (T (fst x')) (T (snd x'))) G)
                           (b + a (size z) - a (size z))).
    clear -Hneq. rewrite //=. intros ??.  rewrite //= in Hneq. nra.
Qed.

Lemma eq_dist_rec:
  (∀ z, P z → eq_dist (T' z) (T z)) →
  ∀ z r,
  P z →
  pr_eq (T' z) r = \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_eq (rvar_comp (rvar_pair (T' (fst (sval x')))
                                                                          (T' (snd (sval x'))))
                                       G) (r - a (size z))).
Proof.
  intros Heq_dist z r HP. rewrite Heq_dist // Trec //.
  apply eq_bigr => i ?. f_equal.
  apply: eq_dist_comp.
  intros (r1&r2).
  rewrite ?pr_eq_rvar_pair ?Heq_dist //.
  - destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
    destruct Hin as (x&<-). by apply hP.
  - destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
    destruct Hin as (x&<-). by apply hP.
Qed.

Lemma rec_pr_rec_gt z r:
  P z →
  pr_gt (T z) r ≤ \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') *
                         pr_gt (rvar_comp (rvar_pair (T (fst (sval x'))) (T (snd (sval x'))))
                                                     G) (r - a (size z))).
Proof.
  rewrite /pr_gt pr_gt_alt3.
  etransitivity.
  { right. eapply eq_bigr => ? _. by apply Trec. }
  rewrite //=.
  rewrite exchange_big //=.
  apply Rle_bigr => x'.
  rewrite -big_distrr //=.
  set (Trecpair := rvar_comp (rvar_pair (T (sval x').1) (T (sval x').2)) G);
    rewrite -/Trecpair.
  transitivity (pr_eq (h z) (sval x') *
                \big[Rplus/0]_(i : imgT (A:=A z) (T z)
                              | (Rgt_dec (sval i) r) && (pr_eq Trecpair ((sval i) - a (size z)) != 0))
                 pr_eq Trecpair ((sval i) - a (size z))).
  {
    right. symmetry.
    eapply Rmult_eq_0_inv_r => Hneq //=. rewrite /index_enum.
    apply (@sum_reidx_map  [finType of imgT (T z)] _ _ _ _ _ (λ x, x)); auto.
    - rewrite /id //=. intros ??. move/andP=>[? ?].
      split; auto. rewrite mem_filter. apply /andP.
      split; auto.
    - intros b Hin' HQ Hfalse.
      case (Req_dec (pr_eq Trecpair (sval b - a (size z))) 0); auto.
      intros Hneq0. exfalso. eapply Hfalse.
      exists b. rewrite mem_filter in Hin'. move /andP in Hin'. destruct Hin' as [-> ->].
      split; auto. rewrite //=. split; auto.
      move: Hneq0. move /eqP => -> //.
    - rewrite -enumT. apply enum_uniq.
    - rewrite -enumT. apply filter_uniq => //=. apply: enum_uniq.
  }
  transitivity (pr_eq (h z) (sval x') * pr_gt Trecpair (r - a (size z))).
  {
    right.
    eapply Rmult_eq_0_inv_r => Hneq.
    rewrite /pr_gt. rewrite pr_gt_alt3.
    rewrite -(big_map sval (λ x, (Rgt_dec x r) && (pr_eq _ (x - _) != 0))
                           (λ i, pr_eq Trecpair (i - a (size z)))).
    rewrite -(big_map sval (λ x, true) (λ i, pr_eq Trecpair i)).
    eapply (@sum_reidx_map _ _ _ _ _ _ (λ x, x - a (size z))); auto.
    - intros a0 ?. move/andP => [Hgt HPr]. split; last done.
      move:Hgt. intros Hlt'.
      rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
      rewrite mem_filter. apply /andP. split.
      ** rewrite //=. do 2 destruct (Rgt_dec) => //=; nra.
      ** apply /mapP.
           assert (Hpf: a0 - a (size z) \in img Trecpair).
           { apply pr_img. edestruct (ge_pr_0 (rvar_dist Trecpair)) as [Hgt|Heq]; first apply Hgt.
             move /eqP in HPr. rewrite /pr_eq in HPr. rewrite //= in Heq. }
           exists (exist _ (a0 - a (size z)) Hpf); last by done.
           rewrite [Finite.enum]unlock //=. apply img_fin_mem.
  - intros b.
    rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
    rewrite mem_filter.  move /andP =>[Hgt Hin'] _ Hfalse.
    case (Req_dec (pr_eq Trecpair b) 0); auto.
    intros Hneq'.
    exfalso; apply Hfalse.
    exists (b + a (size z)).
    repeat split.
    * assert (b + a (size z) \in img (T z)) as Hin.
      { eapply img_Trec_work; eauto. destruct x'; auto. }
      rewrite -mem_undup. rewrite img_alt'.
      exists (exist _ (b + a (size z)) Hin).
      rewrite //=.
    * apply /andP; split.
      ** do 2 destruct (Rgt_dec) => //=. nra.
      ** rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply /eqP. done.
    * rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply /eqP. done.
  - rewrite /index_enum//=. rewrite [Finite.enum]unlock //= img_fin_enum_sval_comp.
    apply undup_uniq.
  - rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
    apply filter_uniq. rewrite /index_enum//=.
    rewrite [Finite.enum]unlock //= img_fin_enum_sval_comp.
    apply undup_uniq.
  - intros ??. intros. nra.
  }
  apply Rmult_le_compat_l; first by apply Rge_le, ge_pr_0.
  rewrite /Trecpair//=. reflexivity.
Qed.

End rec_convert.


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

Require Export Ring.
Require Import ZArith_base.
Require Import Zpow_def.

Import InitialRing.

Set Implicit Arguments.

Ltac Zcst t :=
  match isZcst t with
    true => t
  | _ => constr:NotConstant
  end.

Ltac isZpow_coef t :=
  match t with
  | Zpos ?p => isPcst p
  | Z0 => constr:true
  | _ => constr:false
  end.

Definition N_of_Z x :=
 match x with
 | Zpos p => Npos p
 | _ => N0
 end.

Ltac Zpow_tac t :=
 match isZpow_coef t with
 | true => constr:(N_of_Z t)
 | _ => constr:NotConstant
 end.

Ltac Zpower_neg :=
  repeat match goal with
  | [|- ?G] =>
    match G with
    | context c [Zpower _ (Zneg _)] =>
      let t := context c [Z0] in
      change t
    end
  end.

Add Ring Zr : Zth
  (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc],
   power_tac Zpower_theory [Zpow_tac],
    (* The two following option are not needed, it is the default chose when the set of
        coefficiant is usual ring Z *)
    div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)),
   sign get_signZ_th).


Require Import FunctionalExtensionality.
Require Export Schema.
Require Import Common.

(* There is a category [Set], where the objects are sets and the morphisms are set morphisms *)
Section SSet.
  Local Ltac t_set :=
    unfold id in *; t_with t'; hnf; intros; simpl in *; etransitivity; eauto;
      repeat (apply functional_extensionality_dep; intro; simpl in *); t_with t';
        match goal with
          | [ |- ?f ?x = ?g ?x ] => cut (f = g);
            assumption ||
              solve [ let H := fresh in intro H; rewrite H; reflexivity ]
        end.

  Definition TypeSch : Schema.
    refine {| Vertex := Type;
      Edge := (fun s d => s -> d);
      PathsEquivalent := (fun _ _ p p' => compose _ (fun _ _ => id) p = compose _ (fun _ _ => id) p')
    |};
    abstract t_set.
  Defined.

  Definition SetSch : Schema.
    refine {| Vertex := Set;
      Edge := (fun s d => s -> d);
      PathsEquivalent := (fun _ _ p p' => compose _ (fun _ _ => id) p = compose _ (fun _ _ => id) p')
    |};
    abstract t_set.
  Defined.

  Definition PropSch : Schema.
    refine {| Vertex := Prop;
      Edge := (fun s d => s -> d);
      PathsEquivalent := (fun _ _ p p' => compose _ (fun _ _ => id) p = compose _ (fun _ _ => id) p')
    |};
    abstract t_set.
  Defined.
End SSet.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ABCequalsCBA.
Require Export lemma__NCorder.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__equalanglestransitive.
Require Export logic.
Require Export proposition__04.
Require Export proposition__27B.
Require Export proposition__29B.
Definition proposition__33 : forall A B C D M, (euclidean__defs.Par A B C D) -> ((euclidean__axioms.Cong A B C D) -> ((euclidean__axioms.BetS A M D) -> ((euclidean__axioms.BetS B M C) -> ((euclidean__defs.Par A C B D) /\ (euclidean__axioms.Cong A C B D))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro M.
intro H.
intro H0.
intro H1.
intro H2.
assert (exists a b c d m, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B a) /\ ((euclidean__axioms.Col A B b) /\ ((euclidean__axioms.neq a b) /\ ((euclidean__axioms.Col C D c) /\ ((euclidean__axioms.Col C D d) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS a m d) /\ (euclidean__axioms.BetS c m b))))))))))) as H3 by exact H.
destruct H3 as [a H4].
destruct H4 as [b H5].
destruct H5 as [c H6].
destruct H6 as [d H7].
destruct H7 as [m H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
assert (* Cut *) (euclidean__axioms.Col B M C) as H29.
- right.
right.
right.
right.
left.
exact H2.
- assert (* Cut *) (euclidean__axioms.Col B C M) as H30.
-- assert (* Cut *) ((euclidean__axioms.Col M B C) /\ ((euclidean__axioms.Col M C B) /\ ((euclidean__axioms.Col C B M) /\ ((euclidean__axioms.Col B C M) /\ (euclidean__axioms.Col C M B))))) as H30.
--- apply (@lemma__collinearorder.lemma__collinearorder B M C H29).
--- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H37.
-- assert (* Cut *) (~(euclidean__axioms.Col B C A)) as H31.
--- intro H31.
assert (* Cut *) (euclidean__axioms.Col A B C) as H32.
---- assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H32.
----- apply (@lemma__collinearorder.lemma__collinearorder B C A H31).
----- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H37.
---- assert (* Cut *) (C = C) as H33.
----- apply (@logic.eq__refl Point C).
----- assert (* Cut *) (euclidean__axioms.Col C D C) as H34.
------ right.
left.
exact H33.
------ assert (* Cut *) (euclidean__defs.Meet A B C D) as H35.
------- exists C.
split.
-------- exact H9.
-------- split.
--------- exact H11.
--------- split.
---------- exact H32.
---------- exact H34.
------- apply (@H25 H35).
--- assert (* Cut *) (euclidean__axioms.TS A B C D) as H32.
---- exists M.
split.
----- exact H1.
----- split.
------ exact H30.
------ apply (@euclidean__tactics.nCol__notCol B C A H31).
---- assert (* Cut *) (euclidean__defs.CongA A B C B C D) as H33.
----- apply (@proposition__29B.proposition__29B A D B C H H32).
----- assert (* Cut *) (~(euclidean__axioms.Col B C D)) as H34.
------ intro H34.
assert (* Cut *) (euclidean__axioms.Col C D B) as H35.
------- assert (* Cut *) ((euclidean__axioms.Col C B D) /\ ((euclidean__axioms.Col C D B) /\ ((euclidean__axioms.Col D B C) /\ ((euclidean__axioms.Col B D C) /\ (euclidean__axioms.Col D C B))))) as H35.
-------- apply (@lemma__collinearorder.lemma__collinearorder B C D H34).
-------- destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H38.
------- assert (* Cut *) (B = B) as H36.
-------- apply (@logic.eq__refl Point B).
-------- assert (* Cut *) (euclidean__axioms.Col A B B) as H37.
--------- right.
right.
left.
exact H36.
--------- assert (* Cut *) (euclidean__defs.Meet A B C D) as H38.
---------- exists B.
split.
----------- exact H9.
----------- split.
------------ exact H11.
------------ split.
------------- exact H37.
------------- exact H35.
---------- apply (@H25 H38).
------ assert (* Cut *) (euclidean__defs.CongA B C D D C B) as H35.
------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B C D).
--------apply (@euclidean__tactics.nCol__notCol B C D H34).

------- assert (* Cut *) (euclidean__defs.CongA A B C D C B) as H36.
-------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive A B C B C D D C B H33 H35).
-------- assert (* Cut *) (euclidean__axioms.Cong B C B C) as H37.
--------- apply (@euclidean__axioms.cn__congruencereflexive B C).
--------- assert (* Cut *) (euclidean__axioms.nCol A B C) as H38.
---------- assert (* Cut *) (euclidean__axioms.nCol B C A) as H38.
----------- apply (@euclidean__tactics.nCol__notCol B C A H31).
----------- assert (* Cut *) ((euclidean__axioms.nCol C B A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol B A C) /\ (euclidean__axioms.nCol A C B))))) as H39.
------------ apply (@lemma__NCorder.lemma__NCorder B C A H38).
------------ destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H44.
---------- assert (* Cut *) (euclidean__axioms.Cong B A C D) as H39.
----------- assert (* Cut *) ((euclidean__axioms.Cong B A D C) /\ ((euclidean__axioms.Cong B A C D) /\ (euclidean__axioms.Cong A B D C))) as H39.
------------ apply (@lemma__congruenceflip.lemma__congruenceflip A B C D H0).
------------ destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H42.
----------- assert (* Cut *) (euclidean__axioms.Cong B C C B) as H40.
------------ assert (* Cut *) ((euclidean__axioms.Cong C B C B) /\ ((euclidean__axioms.Cong C B B C) /\ (euclidean__axioms.Cong B C C B))) as H40.
------------- apply (@lemma__congruenceflip.lemma__congruenceflip B C B C H37).
------------- destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
exact H44.
------------ assert (* Cut *) ((euclidean__axioms.Cong A C D B) /\ ((euclidean__defs.CongA B A C C D B) /\ (euclidean__defs.CongA B C A C B D))) as H41.
------------- apply (@proposition__04.proposition__04 B A C C D B H39 H40 H36).
------------- assert (* Cut *) (euclidean__axioms.nCol A C B) as H42.
-------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A C B) /\ (euclidean__axioms.nCol C B A))))) as H46.
--------------- apply (@lemma__NCorder.lemma__NCorder A B C H38).
--------------- destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
exact H53.
-------------- assert (* Cut *) (euclidean__defs.CongA A C B B C A) as H43.
--------------- destruct H41 as [H43 H44].
destruct H44 as [H45 H46].
apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA A C B H42).
--------------- assert (* Cut *) (euclidean__defs.CongA A C B C B D) as H44.
---------------- destruct H41 as [H44 H45].
destruct H45 as [H46 H47].
apply (@lemma__equalanglestransitive.lemma__equalanglestransitive A C B B C A C B D H43 H47).
---------------- assert (* Cut *) (euclidean__axioms.Cong A C B D) as H45.
----------------- destruct H41 as [H45 H46].
destruct H46 as [H47 H48].
assert (* Cut *) ((euclidean__axioms.Cong C A B D) /\ ((euclidean__axioms.Cong C A D B) /\ (euclidean__axioms.Cong A C B D))) as H49.
------------------ apply (@lemma__congruenceflip.lemma__congruenceflip A C D B H45).
------------------ destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H53.
----------------- assert (* Cut *) (euclidean__axioms.Col C B M) as H46.
------------------ destruct H41 as [H46 H47].
destruct H47 as [H48 H49].
assert (* Cut *) ((euclidean__axioms.Col C B M) /\ ((euclidean__axioms.Col C M B) /\ ((euclidean__axioms.Col M B C) /\ ((euclidean__axioms.Col B M C) /\ (euclidean__axioms.Col M C B))))) as H50.
------------------- apply (@lemma__collinearorder.lemma__collinearorder B C M H30).
------------------- destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
exact H51.
------------------ assert (* Cut *) (euclidean__axioms.nCol C B A) as H47.
------------------- destruct H41 as [H47 H48].
destruct H48 as [H49 H50].
assert (* Cut *) ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol C B A) /\ ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol A B C) /\ (euclidean__axioms.nCol B C A))))) as H51.
-------------------- apply (@lemma__NCorder.lemma__NCorder A C B H42).
-------------------- destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
exact H54.
------------------- assert (* Cut *) (euclidean__axioms.TS A C B D) as H48.
-------------------- exists M.
split.
--------------------- exact H1.
--------------------- split.
---------------------- exact H46.
---------------------- exact H47.
-------------------- assert (* Cut *) (euclidean__defs.Par A C B D) as H49.
--------------------- destruct H41 as [H49 H50].
destruct H50 as [H51 H52].
apply (@proposition__27B.proposition__27B A D C B H44 H48).
--------------------- split.
---------------------- exact H49.
---------------------- exact H45.
Qed.


(**************************************************************************)
(*  This is part of EXCEPTIONS, it is distributed under the terms of the  *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Prerequistes Terms Decorations.
Set Implicit Arguments.

Module Make(Import M: Prerequistes.T).
  Module Export AxiomsExp := Decorations.Make(M).

 Reserved Notation "x == y" (at level 80).
 Reserved Notation "x ~ y" (at level 80).

 Definition pure_id X Y (x y: term X Y) := EPURE x /\ x = y.
 Definition idem    X Y (x y: term X Y) := x = y.
 Definition not_ (A:Prop) := A -> False.

 Inductive strong: forall X Y, relation (term X Y) :=
 | refl: forall X Y (f: term X Y), f == f
 | sym: forall X Y, Symmetric (@strong X Y)
 | trans: forall X Y, Transitive (@strong X Y)
 | replsubs: forall X Y Z, Proper (@strong X Y ==> @strong Y Z ==> @strong X Z) comp
 | ids: forall X Y (f: term X Y), f o id == f
 | idt: forall X Y (f: term X Y), id o f == f
 | assoc: forall X Y Z T (f: term X Y) (g: term Y Z) (h: term Z T), f o (g o h) == (f o g) o h
 | wtos: forall  X Y (f g: term X Y), PPG f -> PPG g -> f ~ g -> f == g
 | s_lcopair_eq: forall X X' Y (f1: term Y X) (f2: term Y X'), PPG f1 -> (copair f1 f2) o in2 == f2
 | eeffect: forall X Y (f g: term Y X), (f o (@empty X) == g o (@empty X)) -> f ~ g -> f == g (* effect measure - Dumas et al.'12 *)
 | elocal_global: forall X (f g: term X Empty_set), (forall t: EName, f o tag t ~ g o tag t) -> f == g (* dual to observation *)
 | tcomp: forall X Y Z (f: Z -> Y) (g: Y -> X), tpure (compose g f) == tpure g o tpure f
 with weak: forall X Y, relation (term X Y) :=
 | wsym: forall X Y, Symmetric (@weak X Y)
 | wtrans: forall X Y, Transitive (@weak X Y)
 | wrepl : forall A B C, Proper (@idem C B ==> @weak B A ==> @weak C A) comp
 | pwsubs : forall A B C, Proper (@weak C B ==> @pure_id B A ==> @weak C A) comp
 | stow: forall  X Y (f g: term X Y), f == g -> f ~ g
 | w_lcopair_eq: forall X X' Y (f1: term Y X) (f2: term Y X'), PPG f1 -> (copair f1 f2) o in1 ~ f1
 | w_empty: forall X (f: term X Empty_set), f ~ (@empty X)
 | w_downcast: forall X Y (f: term X Y), f ~ (@downcast X Y f)
 | eax1: forall t: EName, untag t o tag t ~ (@id (Val t))
 | eax2: forall t1 t2: EName, t1 <> t2 -> untag t2 o tag t1 ~ (@empty (Val t2)) o tag t1
 | lcopair_ueq: forall  X X' Y (f g: term Y (X+X')), (f o in1 ~ g o in1) -> (f o in2 ~ g o in2) -> f ~ g
   where "x == y" := (strong x y)
   and "x ~ y" := (weak x y).

 Instance strong_is_equivalence X Y: Equivalence (@strong X Y).
 Proof. constructor; intro. apply refl. apply sym. apply trans. Qed.

 Instance weak_is_equivalence X Y: Equivalence (@weak X Y).
 Proof. constructor; intro. apply stow. apply refl. intros. apply wsym. assumption. apply wtrans. Qed.

 Instance strong_is_weak_equivalence: forall X Y, subrelation (@strong X Y) (@weak X Y).
 Proof. constructor. apply stow,sym. assumption. Qed.

 Lemma s_empty: forall X (f: term X Empty_set), (PPG f) -> f == (@empty X).
 Proof. intros X f H. apply wtos; [exact H| edecorate| apply w_empty]. Qed.

 Existing Instance wrepl.
 Existing Instance pwsubs.
 Existing Instance replsubs.

 Goal forall X Y Z (g: term Z Y) (f f': term Y X), f ~ f' -> g o f ~ g o f'.
 Proof. intros X Y Z g f f' H0. setoid_rewrite <- H0. reflexivity. Qed.

 Goal forall X Y Z (g: term Y X) (f f': term Z Y), f ~ f' -> EPURE g -> f o g ~ f' o g.
 Proof.  intros X Y Z g f f' H0 H1. apply pwsubs. exact H0. unfold pure_id. split. exact H1. reflexivity. Qed.

 Reserved Notation "x *== y" (at level 80).

 Inductive pl_strong: forall X Y, relation (termpl X Y) :=
 | pl_refl: forall X Y (f: termpl X Y), f *== f
 | pl_assoc: forall X Y Z T (f: termpl X Y) (g: termpl Y Z) (h: termpl Z T), f O (g O h) *== (f O g) O h
 | pl_ids: forall X Y (f: termpl X Y), f O pl_id  *== f
 | pl_idt: forall X Y (f: termpl X Y), pl_id O f  *== f
 | pl_s_empty: forall X (f: termpl X Empty_set), f  *== (@pl_empty X)
 | pl_replsubs: forall X Y Z, Proper (@pl_strong X Y ==> @pl_strong Y Z  ==> @pl_strong X Z) (pl_comp)
     (*for throw and try/catch*)
 | ppt : forall X Y e (a: termpl X Y), a O (@throw Y e)  *== (@throw X e)
 | rcv : forall X Y e (u1 u2: termpl (Val e) Y), (@throw X e) O u1  *== (@throw X e) O u2 -> u1  *== u2
 | try : forall X Y e (a1 a2: termpl X Y) (b: termpl X (Val e)), a1 *== a2 -> try_catch e a1 b  *== try_catch e a2 b (* FIXED *)
(* | try: forall X Y e, Proper (@pl_strong X Y  ==> @pl_strong X (Val e)  ==> @pl_strong X Y) (try_catch e) *)
 | try0: forall X Y e (u: termpl X Y) (b: termpl X (Val e)), PL_EPURE u -> try_catch e u b  *== u
 | try1: forall X Y e (u: termpl (Val e) Y) (b: termpl X (Val e)), PL_EPURE u ->
 		try_catch e ((@throw X e) O u) b  *== b O u
 | try2: forall X Y e f (u: termpl (Val f) X) (b: termpl Y (Val e)),  e <> f -> PL_EPURE u ->
 		try_catch e ((@throw Y f) O u) b  *== (@throw Y f) O u
 | pl_sym: forall X Y, Symmetric (@pl_strong X Y)
 | pl_trans: forall X Y, Transitive (@pl_strong X Y)
 | pl_tcomp: forall X Y Z (f: Z -> Y) (g: Y -> X), pl_tpure (compose g f) *== pl_tpure g O pl_tpure f
   where "x  *== y" := (pl_strong x y).

 Instance pl_strong_is_equivalence X Y: Equivalence (@pl_strong X Y).
 Proof. constructor; intro. apply pl_refl. apply pl_sym. apply pl_trans. Qed.

 Existing Instance pl_replsubs.
 (*Existing Instance try.*)

End Make.