Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrbool ssrnat eqtype.
Require Import Show Sets GenLow GenHigh RoseTrees Checker Classes.

Import GenLow GenHigh QcNotation.

Definition resultSuccessful (r : Result) : bool :=
  match r with
    | MkResult (Some res) expected _ _ _ _ _ =>
      res == expected
    | _ => true
  end.

Definition successful qp :=
  match qp with
    | MkProp (MkRose res _) => resultSuccessful res
  end.

(* Maps a Checker to a Prop *)

(* begin semCheckerSize *)
Definition semCheckerSize (c : Checker) (s : nat): Prop :=
  successful @: semGenSize c s \subset [set true].
(* end semCheckerSize *)

(* ZP: Do we want to define semChecker in terms of semCheckerSize? *)

(* begin semChecker *)
Definition semChecker (c : Checker) : Prop := forall s, semCheckerSize c s.
(* end semChecker *)

(* Maps a Checkable to a Prop i.e. gives an equivalent proposition to the
   property under test *)

(* begin semCheckableSize *)
Definition semCheckableSize {A} `{Checkable A} (a : A) (s : nat) : Prop :=
  semCheckerSize (checker a) s.
(* end semCheckableSize *)

(* begin semCheckable *)
Definition semCheckable {A} `{Checkable A} (a : A) : Prop := semChecker (checker a).
(* end semCheckable *)

(* another characterization of semChecker *)
Lemma semChecker_def2 c :
  semChecker c <-> (forall qp, semGen c qp -> successful qp = true).
Proof.
  rewrite /semChecker /semCheckerSize /semGen. split; intro H.
  - intros. destruct H0 as [s [H0 Ho']]. symmetry; eapply (H s). eexists.
    split; eauto.  reflexivity.
  - intros n b [qp [H1 H2]]. symmetry in H2.
    rewrite H2. symmetry. apply H.
    eexists; eauto. split; eauto. reflexivity.
Qed.

(* CH: This is the definition of Checker I would like to use *)
(* ZP : For now semCheckerSize has a similar definition and
        semChecker is defined in terms of semCheckerSize *)
Lemma semChecker_def3 c :
  semChecker c <-> (successful @: semGen c \subset [set true]).
Proof.
  rewrite semChecker_def2. split; intro H.
(*  CH: why can't I rewrite with semFmap directly? See tentative instances below *)
  - intros b H'. unfold imset, bigcup in H'.
    destruct H' as [qp [H1 H2]]. apply H in H1. by rewrite H1 in H2.
  - intros. specialize (H (successful qp)).
    unfold set1 in H. symmetry. apply: H.
    by eapply imset_in.
Qed.

Definition genChecker c := fmap successful c.

Class UnsizedChecker (c : Checker) :=
  {
    unsizedChecker :
      forall s1 s2 : nat, semGenSize (genChecker c) s1 <--> semGenSize (genChecker c) s2
  }.

Class SizeMonotonicChecker (c : Checker) :=
  {
    monotonicChecker :
      forall s1 s2, s1 <= s2 ->
                    semGenSize (genChecker c) s1 \subset semGenSize (genChecker c) s2

  }.

Lemma unsizedChecker_alt_def (c : Checker) `{UnsizedChecker c} :
  forall s1 s2, semCheckerSize c s1 <-> semCheckerSize c s2.
Proof.
  rewrite /semCheckerSize => s1 s2; split;
  move : H => [/(_ s1 s2) H];
  rewrite /genChecker in H; setoid_rewrite semFmapSize in H;
  by rewrite H.
Qed.

Lemma monotonicChecker_alt_def (c : Checker) `{SizeMonotonicChecker c} :
  forall s1 s2, s1 <= s2 -> semCheckerSize c s2 -> semCheckerSize c s1.
Proof.
  rewrite /semCheckerSize => s1 s2 Hle.
  move : H => [/(_ s1 s2 Hle) /= H].
  rewrite /genChecker in H; setoid_rewrite semFmapSize in H.
  move => H1 b H2. apply H1. eauto.
Qed.

Program Instance unsizedMonotonicChecker (c : Checker) `{UnsizedChecker c} :
  SizeMonotonicChecker c.
Next Obligation.
    rewrite unsizedChecker. move => b Hb. by eauto.
Qed.

Lemma mapTotalResult_idSize {C} `{Checkable C} (f : Result -> Result) (c : C) s :
    (forall res, resultSuccessful res = resultSuccessful (f res)) ->
    (semCheckerSize (mapTotalResult f c) s <-> semCheckableSize c s).
Proof.
  move=> eq_res.
  rewrite /mapTotalResult /mapRoseResult /mapProp/semCheckableSize /semCheckerSize.
  split; rewrite semFmapSize.
  - move => H1 b [[[res l]] /= [H2 H3]].
    rewrite -H3 eq_res. apply H1.
    repeat (eexists; split; eauto).
  - move => /= H1 b [[[res l]] /= [[[[res' l'] [/= H2 [H3 H4]]] H5]]]; subst.
    rewrite <- H5, <- eq_res in *.  apply H1.
    eexists. split; eauto. reflexivity.
Qed.

Lemma mapTotalResult_id {C} `{Checkable C} (f : Result -> Result) (c : C) :
    (forall res, resultSuccessful res = resultSuccessful (f res)) ->
    (semChecker (mapTotalResult f c) <-> semCheckable c).
Proof.
  move=> eq_res; split => H' s; eapply mapTotalResult_idSize; eauto.
  by apply H'.
Qed.

Lemma semCallback_idSize {C} `{Checkable C} (cb : Callback) (c : C) (s : nat) :
    semCheckerSize (callback cb c) s <-> semCheckableSize c s.
Proof.
  rewrite /callback.
  split; move => H'.
  - apply mapTotalResult_idSize in H' => //;
    by move => [? ? ? ? ? ?].
  - apply mapTotalResult_idSize => //;
    by move => [? ? ? ? ? ?].
Qed.

Lemma semCallback_id {C} `{Checkable C} (cb : Callback) (c : C) :
    semChecker (callback cb c) <-> semCheckable c.
Proof.
  split => H' s; eapply semCallback_idSize; eauto.
  by apply H'.
Qed.

Lemma semWhenFail_idSize {C} `{Checkable C} (str : String.string) (c : C) s :
    semCheckerSize (whenFail str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /whenFail semCallback_idSize.
Qed.

Lemma semWhenFail_id {C} `{Checkable C} (str : String.string) (c : C) :
    semChecker (whenFail str c) <-> semCheckable c.
Proof.
  by rewrite /whenFail semCallback_id.
Qed.

Lemma semPrintTestCase_idSize {C} `{Checkable C} (str : String.string) (c : C) s :
    semCheckerSize (printTestCase str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /printTestCase semCallback_idSize.
Qed.

Lemma semPrintTestCase_id {C} `{Checkable C} (str : String.string) (c : C) :
    semChecker (printTestCase str c) <-> semCheckable c.
Proof.
  by rewrite /printTestCase semCallback_id.
Qed.

Lemma semShrinking_idSize {C A} {HCheck : Checkable C}
         (sh : A -> list A) (x : A) (pf : A -> C) (s : nat) :
    semCheckerSize (shrinking sh x pf) s <->
    semCheckableSize (pf x) s.
Proof.
  unfold semCheckableSize, shrinking, semCheckerSize, semGenSize, props.
  have [n <-] : exists n, S n  = 1000 by eexists; reflexivity.
  split.
  - move => H b [[[res [l]]] [/= [seed Hgen] H']]; subst.
    + suff :
        successful
          (run
             (fmap
                (fun x0 => {| unProp := joinRose (fmapRose unProp x0) |})
                (promote (@props' _ _ HCheck (S n) pf sh x))) s seed).
      setoid_rewrite runFmap.
      rewrite runPromote. simpl. rewrite Hgen -H' /=.
      move => -> //.
      rewrite <- H => //. eexists. split; try by reflexivity.
      eexists. reflexivity.
  - move => H b [[[r [l]]] /= [[seed H1] <-]]. apply H.
    rewrite runFmap runPromote /= in H1.
    destruct ((run (checker (pf x)) s seed)) as [[res [l']]] eqn:Heq=> //=.
    simpl in *. move : H1 => [H1 H2]; subst.
    eexists. eexists. exists seed. reflexivity. rewrite Heq. reflexivity.
Qed.

Lemma semShrinking_id {C A} {HCheck : Checkable C}
         (sh : A -> list A) (x : A) (pf : A -> C)  :
    semChecker (shrinking sh x pf) <->
    semCheckable (pf x).
Proof.
  split; move => H s; eapply semShrinking_idSize; first by eauto.
  by apply H.
Qed.

(* Program Instance shrinkingUnsized {C A} `{Checkable C} *)
(*         (sh : A -> list A) (x : A) (pf : A -> C)  *)
(*         `{UnsizedChecker (checker (pf x))} : UnsizedChecker (shrinking sh x pf). *)
(* Next Obligation.  *)
(* Abort. *)

Lemma semCover_idSize {C} `{Checkable C} (b: bool) (n: nat)
      (str : String.string) (c : C) (s : nat) :
  semCheckerSize (cover b n str c) s <-> semCheckableSize c s.
Proof.
  split.
  - rewrite /cover. case: b => //.
    move => H1. apply mapTotalResult_idSize in H1 => //.
      by move => [? ? ? ? ? ?].
  - move => H1. rewrite /cover. case: b => //.
    apply mapTotalResult_idSize => //.
      by move => [? ? ? ? ? ?].
Qed.

Lemma semCover_id {C} `{Checkable C} (b: bool) (n: nat)
      (str : String.string) (c : C) :
  semChecker (cover b n str c) <-> semCheckable c.
Proof.
  split; move => H' s; eapply semCover_idSize; first by eauto.
  by apply H'.
Qed.

Lemma semClassify_idSize {C} `{Checkable C} (b: bool) (str : String.string)
          (c : C) (s : nat) :
    semCheckerSize (classify b str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /classify semCover_idSize.
Qed.

Lemma semClassify_id {C} `{Checkable C} (b: bool) (str : String.string) (c : C) :
    semChecker (classify b str c) <-> semCheckable c.
Proof.
  by rewrite /classify semCover_id.
Qed.

Lemma semLabel_idSize {C} `{Checkable C} (str : String.string) (c : C) (s : nat) :
    semCheckerSize (label str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /label semClassify_idSize.
Qed.

Lemma semLabel_id {C} `{Checkable C} (str : String.string) (c : C) :
    semChecker (label str c) <-> semCheckable c.
Proof.
  by rewrite /label semClassify_id.
Qed.

Lemma semCollect_idSize {C} `{Checkable C} (str : String.string) (c : C) (s : nat) :
    semCheckerSize (collect str c) s <-> semCheckableSize c s.
Proof.
  by rewrite /collect semLabel_idSize.
Qed.

Lemma semCollect_id {C} `{Checkable C} (str : String.string) (c : C) :
    semChecker (collect str c) <-> semCheckable c.
Proof.
  by rewrite /collect semLabel_id.
Qed.

Open Scope Checker_scope.

Lemma semImplicationSize {C} `{Checkable C} (c : C) (b : bool) s :
  semCheckerSize (b ==> c) s <-> (b -> semCheckableSize c s).
Proof.
  case: b; split=> //=; first by move/(_ refl_equal).
  by move => _ b [x [/semReturnSize <- <-]].
Qed.

(* begin semImplication *)
Lemma semImplication {C} `{Checkable C} (c : C) (b : bool) :
  semChecker (b ==> c) <-> (b -> semCheckable c).
(* end semImplication *)
Proof.
  split; [move => H1 b' s' | move => H1 s b'];
  eapply semImplicationSize; try by eauto.
  move => b''. by apply H1.
Qed.

Program Instance implicationUnsized
        {C} `{Checkable C} b (c : C) `{UnsizedChecker (checker c)} :
  UnsizedChecker (b ==> c).
Next Obligation.
  move : H0 => [/(_ s1 s2) H0].
  rewrite /genChecker in H0 *. rewrite -> !semFmapSize in H0.
  rewrite !semFmapSize.
  rewrite /implication. case : b; eauto.
  apply imset_eq. rewrite !semReturnSize. reflexivity.
Qed.

Program Instance implicationMonotonic
        {C} `{Checkable C} b (c : C) `{SizeMonotonicChecker (checker c)} :
  SizeMonotonicChecker (b ==> c).
Next Obligation.
  move : H0 => [/(_ s1 s2 H1) H0].
  rewrite /genChecker in H0 *. rewrite -> !semFmapSize in H0.
  rewrite !semFmapSize.
  rewrite /implication. case : b; eauto.
  apply imset_incl. rewrite !semReturnSize. by move => ? ?; eauto.
Qed.

(* equivalences for other combinators *)

Lemma semReturnGenSize (qp : QProp) (s: nat) :
    semCheckerSize (returnGen qp) s <-> semCheckableSize qp s.
Proof.
  rewrite /semCheckerSize. split.
  - move =>  H qp' [x [H1 H2]]. apply H. eexists; split; eauto.
  - move => H b [x [H1 H2]] //. apply H => //=. eexists; split; eauto.
Qed.

Lemma semReturnGen (qp : QProp) :
    semChecker (returnGen qp) <-> semCheckable qp.
Proof.
  split; move => H s.
  - by move /(_ s) /semReturnGenSize : H => //.
  - apply semReturnGenSize; eauto. by apply H.
Qed.

Lemma semBindGenSize {A} (gen : G A) (f : A -> Checker) (s: nat):
    semCheckerSize (bindGen gen f) s <->
    forall a, semGenSize gen s a -> semCheckerSize (f a) s.
Proof.
  unfold semCheckerSize. split.
  - move => H a Hsize b [qp [H1 <-]]. apply H.
    exists qp; split => //=. apply semBindSize. eexists; split; eauto.
  - move => H b [qp [/semBindSize [a [H1 H2]] <-]]. eapply H; try eassumption.
    eexists; split => //; eauto.
Qed.

Lemma semBindGenUsinzed1 {A} (gen : G A) (f : A -> Checker) `{Unsized _ gen} :
    (semChecker (bindGen gen f) <->
     forall a, semGen gen a -> semChecker (f a)).
Proof.
  split; move => Hgen a.
  - move => [s [_ H']] s'. eapply unsized in H'.
    by eapply semBindGenSize in Hgen; eauto.
  - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto.
Qed.

Lemma semBindGenUsinzed2 {A} (gen : G A) (f : A -> Checker)
      `{forall a, UnsizedChecker (f a)} :
    (semChecker (bindGen gen f) <->
     forall a, semGen gen a -> semChecker (f a)).
Proof.
  split; move => Hgen a.
  - move => [s [_ H']] s'.
    eapply semBindGenSize in Hgen; last by eauto.
    eapply unsizedChecker_alt_def; eauto.
  - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto.
Qed.

Lemma semBindGenSizeMonotonic {A} (gen : G A) (f : A -> Checker)
  `{SizeMonotonic _ gen}
  `{forall a, SizeMonotonicChecker (f a)} :
  (semChecker (bindGen gen f) <->
   forall a, semGen gen a -> semChecker (f a)).
Proof.
  split; move => Hgen a.
  - move => [s [_ H']] s'. case_eq (s <= s') => [Hleq |
                                                 /leP/Compare_dec.not_le/ltP/ltnW Hleq].
    + specialize (Hgen s').
      eapply semBindGenSize in Hgen; eauto.
      eapply monotonic; eauto.
    + specialize (Hgen s). eapply semBindGenSize in Hgen; eauto.
      eapply monotonicChecker_alt_def; eauto.
  - by eapply semBindGenSize; intros; apply Hgen; eexists; split => //; eauto.
Qed.

Lemma semPredQPropSize (c : Checker) (s : nat) :
    semCheckableSize c s <-> (semCheckerSize c s).
Proof.
  rewrite /semCheckableSize /checker
          /testChecker /checker /testProp /semCheckerSize.
  split; move => Hqp qp Hsize; auto.
Qed.

Lemma semPredQProp (c : Checker) :
    semCheckable c <-> semChecker c.
Proof.
  split => H s; eapply semPredQPropSize; eauto.
Qed.

Instance forAllMonotonic {A C} {_ : Checkable C} `{Show A} (g : G A) (f : A -> C)
        `{SizeMonotonic _ g} `{forall x, SizeMonotonicChecker (checker (f x))} :
  SizeMonotonicChecker (forAll g f).
Admitted.

Lemma semForAllSize {A C} `{Show A, Checkable C} (g : G A) (f : A -> C) (s:nat) :
  semCheckerSize (forAll g f) s <->
  forall (a : A), a \in semGenSize g s -> semCheckableSize (f a) s.
Proof.
  split=> H'.
  - rewrite /forAll in H'. move/semBindGenSize : H' => H' a /H' Hgen.
      by apply semPrintTestCase_idSize in Hgen.
  - rewrite /forAll in H' *. apply semBindGenSize => g' Hgen.
    rewrite semPrintTestCase_idSize. by apply H'.
Qed.

Lemma semForAllUnsized1 {A C} `{Show A, Checkable C} (g : G A) (f : A -> C)
      `{Unsized _ g} :
  (semChecker (forAll g f) <->
   forall (a : A), a \in semGen g -> semCheckable (f a)).
Proof.
  split=> H'.
  - move => a [s' [_ Hgen]] s. specialize (H' s).
    eapply semForAllSize in H'; first by eauto.
    eapply unsized; eauto.
  - move => s; eapply semForAllSize; move => a Hgen.
    apply H'; eexists; split => //; eauto.
Qed.

Lemma semForAllUnsized2 {A C} `{Show A, Checkable C} (g : G A) (f : A -> C)
      `{forall a, UnsizedChecker (checker (f a))} :
  (semChecker (forAll g f) <->
   forall (a : A), a \in semGen g -> semCheckable (f a)).
Proof.
  split=> H'.
  - move => a [s' [_ Hgen]] s. specialize (H' s').
    eapply semForAllSize in H'; last by eauto.
    by eapply unsizedChecker_alt_def; eauto.
  - move => s; eapply semForAllSize; move => a Hgen.
    apply H'; eexists; split => //; eauto.
Qed.

(* begin semForAllSizeMonotonic *)
Lemma semForAllSizeMonotonic {A C} `{Show A, Checkable C} (g : G A) (f : A -> C)
    `{SizeMonotonic _ g} `{forall a, SizeMonotonicChecker (checker (f a))} :
  (semChecker (forAll g f) <-> forall (a:A), a \in semGen g -> semCheckable (f a)).
(* end semForAllSizeMonotonic *)
Proof.
  split; move => Hcheck a.
  - move => [s [_ H']] s'. case_eq (s <= s') => [Hleq |
                                                 /leP/Compare_dec.not_le/ltP/ltnW Hleq].
    + specialize (Hcheck s').
      rewrite -> semForAllSize in Hcheck. apply Hcheck.
      eapply monotonic; eauto.
    + specialize (Hcheck s). eapply semForAllSize in Hcheck; eauto.
      by eapply monotonicChecker_alt_def; eauto.
  - by eapply semForAllSize; intros; apply Hcheck; eexists; split => //; eauto.
Qed.

Lemma unsized_printTestCase {A C} `{Checkable C} `{Show A} (c : A -> C) :
  (forall a, Unsized (checker (c a))) ->
  (forall a, Unsized (printTestCase (String.append (Show.show a) newline) (c a))).
Proof.
(*   rewrite /UnsizedChecker /unsized. setoid_rewrite semFmapSize. *)
(*   move => H' a s1 s2. specialize (H' a s1 s2). *)
(*   by do 2 rewrite semPrintTestCase_idSize. *)
(* Qed. *)
Abort.

(* alternative definitions
Definition unsizedChecker (c : Checker) : Prop :=
  forall s1 s2, semCheckerSize c s1 <-> semCheckerSize c s2.

(* another characterization of unsizedChecker *)
Lemma unsizedChecker_def2 {A : Type} : forall (c : Checker),
  unsizedChecker c ->
  forall s, semCheckerSize c s <-> semChecker c.
Proof.
  intros. split; intro H'.
  - intro s'. rewrite H. eassumption.
  - by apply H'.
Qed.
*)

(* CH: We could create a super class UCheckable that includes the
       unsized assumption. And we could use sections to hide all the
       type class stuff from the paper. *)
(* CH: This will be affected by upcoming refactoring;
       proving it like this only because it appears in ITP submission *)

Require Import FunctionalExtensionality.

Lemma curry_uncurry {A B C : Type} (f : A -> B -> C) :
  curry (uncurry f) = f.
Proof. apply functional_extensionality => x. reflexivity. Qed.

Lemma uncurry_curry {A B C : Type} (f : A * B -> C) :
  uncurry (curry f) = f.
Proof. apply functional_extensionality. by intros [a b]. Qed.

Lemma mergeBinds' :
  forall A B C (ga : G A) (gb : G B) (f : A * B -> G C),
    semGen (bindGen ga (fun x => bindGen gb ((curry f) x))) <-->
    semGen (bindGen (genPair ga gb) f).
Proof. setoid_rewrite mergeBinds. by setoid_rewrite uncurry_curry. Qed.

Lemma eq_to_impl : forall (a b : Prop), a = b -> a -> b.
Proof. move => a b H. by rewrite H. Qed.

(* CH: could we get rid of this in the RBTree example if we used
   semBindSizeMonotonic instead of semBindUnsized2?  *)
(* CH: The problem with proving this is the silly print in the middle of things.
   There are also some technical problems with setoid_rewriting taking ages,
   and requiring an useless split beforehand.
   ZP: Got rid of setoid_rewrite. The proof goes through instantly now.
*)
Lemma mergeForAlls {A B C : Type} `{Checkable C} `{Show A} `{Show B}
         (ga : G A) (gb : G B) (f : A -> B -> C) :
     semChecker (forAll ga (fun a => forAll gb (f a))) <->
     semChecker (forAll (genPair ga gb) (uncurry f)).
Proof.
  (* ZP : I know that this proof lacks nice point-free reasoning, but it is
          significantly smaller and typechecks much faster that the previous one *)
  split.
  - move => HforAll s. apply semForAllSize;
    move  => [a b] /= /semLiftGen2Size [[a' b'] [[/= Hg1 Hg2] [Heq1 Heq2]]]; subst.
    specialize (HforAll s). eapply semForAllSize in HforAll.
    by eapply semForAllSize in HforAll; eauto. by eauto.
  - move => HforAll s. apply semForAllSize => a Hgena.
    apply semForAllSize => b Hgenb.
    specialize (HforAll s).
    move /semForAllSize/(_ (a, b)) : HforAll => /= HforAll. apply HforAll.
    apply semLiftGen2Size. exists (a, b); split => //; eauto.
Qed.

Lemma semForAllShrinkSize:
  forall {A C} `{Checkable C} `{Show A}
         (gen : G A) (f : A -> C) shrinker (size: nat),
    semCheckerSize (forAllShrink gen shrinker f) size <->
    forall a : A, semGenSize gen size a -> semCheckableSize (f a) size.
Proof.
  move => A C H show gen pf shrink. split.
  - rewrite /forAllShrink semBindGenSize.
    move=> H' a /H' Hgen. setoid_rewrite semShrinking_idSize in Hgen.
    setoid_rewrite semPredQPropSize in Hgen.
    by apply semPrintTestCase_idSize in Hgen.
  - move=> H'. rewrite /forAllShrink semBindGenSize. move => a g.
    rewrite semShrinking_idSize. apply semPredQPropSize.
    rewrite semPrintTestCase_idSize. by auto.
Qed.

Lemma semForAllShrinkUnsized1 :
  forall {A C} `{Checkable C} `{Show A}
         (gen : G A) (f : A -> C) shrinker `{Unsized _ gen},
    (semChecker (forAllShrink gen shrinker f) <->
     forall a : A, semGen gen a -> semCheckable (f a)).
Proof.
  split=> H'.
  - move => a [s' [_ Hgen]] s. specialize (H' s).
    eapply semForAllShrinkSize in H'; first by eauto.
    eapply H1; eauto.
 - move => s; eapply semForAllShrinkSize; move => a Hgen.
    apply H'; eexists; split => //; eauto.
Qed.

Lemma semForAllShrinkUnsized2 :
  forall {A C} `{Checkable C} `{Show A}
         (gen : G A) (f : A -> C) shrinker
  `{forall a, UnsizedChecker (checker (f a))},
  (semChecker (forAllShrink gen shrinker f) <->
     forall a : A, semGen gen a -> semCheckable (f a)).
Proof.
  split=> H'.
  - move => a [s' [_ Hgen]] s. specialize (H' s').
    eapply semForAllShrinkSize in H'; last by eauto.
    eapply unsizedChecker_alt_def; eauto.
  - move => s; eapply semForAllShrinkSize; move => a Hgen.
    apply H'; eexists; split => //; eauto.
Qed.

Lemma semForAllShrinkMonotonic :
  forall {A C} `{Checkable C} `{Show A}
         (gen : G A) (f : A -> C) shrinker `{SizeMonotonic _ gen},
  (forall a, SizeMonotonicChecker (checker (f a))) ->
  (semChecker (forAllShrink gen shrinker f) <->
     forall a : A, semGen gen a -> semCheckable (f a)).
Proof.
  move => A C H1 H2 gen f sh Hmon1 Hmon2.
  split; move => Hcheck a.
  - move => [s [_ H']] s'. case_eq (s <= s') => [Hleq |
                                                 /leP/Compare_dec.not_le/ltP/ltnW Hleq].
    + specialize (Hcheck s').
      rewrite -> semForAllShrinkSize in Hcheck. apply Hcheck.
      by eapply Hmon1; eauto.
    + specialize (Hcheck s). eapply semForAllShrinkSize in Hcheck; eauto.
      by eapply monotonicChecker_alt_def; eauto.
  - by eapply semForAllShrinkSize; intros; apply Hcheck; eexists; split => //; eauto.
Qed.

Lemma bool_successful :
  forall b, resultSuccessful (liftBool b) = b.
Proof.
  intros. destruct b; auto.
Qed.

Lemma semCheckableBoolSize (b : bool) size : semCheckableSize b size <-> b.
Proof.
  rewrite /semCheckableSize /semCheckerSize /checker /testBool.
  split.
  - move => /(_ b) H.
    suff : [set true] b by move => <- //.
    eapply H. eexists (MkProp (MkRose (liftBool b) (lazy nil))).
    split => //=. by rewrite -> (semReturnSize _ _ _). by eapply bool_successful.
  - move => Hb b' [qp [/semReturnSize <- <-]] /=.
    by rewrite bool_successful.
Qed.

(* begin semCheckableBool *)
Lemma semCheckableBool (b : bool) : semCheckable b <-> b.
(* end semCheckableBool *)
Proof.
  (* CH: brute-force, please fix
     ZP : better now? We do case analysis on b bun in a lemma;
          I don't think we can avoid it *)
  split; [move => /(_ 0) H | move => H s]; eapply semCheckableBoolSize; eauto.
Qed.

Program Instance boolUnsized (b : bool) : UnsizedChecker (checker b).
Next Obligation.
  rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Lemma semCheckableResultSize:
  forall (res: Result) (size: nat),
    semCheckableSize res size <-> resultSuccessful res.
Proof.
  rewrite /semCheckableSize /checker /testResult /=.
  move => res size. split.
  - move => /(_ (resultSuccessful res)) H.
    suff : [set true] (resultSuccessful res) by move <-.
    apply H. eexists. split; first by apply semReturnSize.
    reflexivity.
  - move => H b [qp' [/semReturnSize <- <-]] //=.
Qed.

Lemma semCheckableResult :
  forall (res: Result),
    semCheckable res  <-> resultSuccessful res.
Proof.
  split; [move => /(_ 0) H | move => H s]; eapply semCheckableResultSize; eauto.
Qed.

Program Instance resultUnsized (r : Result) : UnsizedChecker (checker r).
Next Obligation.
  rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Lemma semCheckableUnitSize (t : unit) size : semCheckableSize t size <-> True.
Proof.
  split => // _ qp [qp' [/semReturnSize <- <-]] //.
Qed.

Lemma semCheckableUnit (t : unit) : semCheckable t <-> True.
Proof.
  split; [move => /(_ 0) H | move => H s]; eapply semCheckableUnitSize; eauto.
Qed.

Program Instance unitUnsized : UnsizedChecker (checker tt).
Next Obligation.
  rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Lemma semCheckableQPropSize (qp : QProp) size :
  semCheckableSize qp size <-> successful qp.
Proof.
  rewrite /semCheckableSize /checker /testProp.
  split.
  - move => /(_ (successful qp)) H.
    suff : ([set true] (successful qp)) by move => <-.
    apply H. eexists. split ; last by reflexivity.
    by apply semReturnSize.
  - move => H b [qp' [/semReturnSize <- <-]] //=.
Qed.

Lemma semCheckableQProp (qp : QProp) :
  semCheckable qp  <-> successful qp.
Proof.
  split; [move => /(_ 0) H | move => H s]; eapply semCheckableQPropSize; eauto.
Qed.

Program Instance qpUnsized (qp : QProp) : UnsizedChecker (checker qp).
Next Obligation.
  rewrite !semFmapSize !semReturnSize. apply imset_eq. reflexivity.
Qed.

Lemma semCheckableGenSize:
  forall (P : Type) {H : Checkable P} (gen: G P) (size : nat),
    (semCheckableSize gen size) <->
    (forall p, semGenSize gen size p -> semCheckableSize p size).
Proof.
  move=> P H gen s. rewrite /semCheckableSize /checker /testGenProp. split.
  - move => /semBindGenSize Hcheck p Hgen //=; eauto.
  - move => Hcheck. apply semBindGenSize => a Hgen; eauto.
Qed.

Lemma semCheckableFunSize:
  forall {A C} {H1 : Show A} `{H2 : Arbitrary A} {H3 : Checkable C}
         (f : A -> C) (size: nat),
    semCheckableSize f size <->
    forall (a : A), semGenSize arbitrary size a -> semCheckableSize (f a) size.
Proof.
  move=> A C H1 H2 H3 f.
  rewrite /semCheckable /checker /testFun.
  split.
  - move => /semForAllShrinkSize H' a' /H' Gen. by auto.
  - move => H'. apply semForAllShrinkSize => a' /H' Hgen. by auto.
Qed.

Lemma semCheckablePolyFunSize:
  forall {C : Type -> Type} {H : Checkable (C nat)} (f : forall T, C T)
         (size : nat),
    (semCheckableSize f size) <-> (semCheckableSize (f nat) size).
Proof.
  move => C H f s. rewrite /semCheckableSize {2}/checker /testPolyFun.
  by rewrite semPrintTestCase_idSize.
Qed.

Lemma semCheckablePolyFunSetSize:
  forall {C : Set -> Type} {H : Checkable (C nat)} (f : forall T, C T) (size: nat),
    (semCheckableSize f size) <->  (semCheckableSize (f nat) size).
Proof.
  move => C H f s. rewrite /semCheckableSize {2}/checker /testPolyFun.
  by rewrite semPrintTestCase_idSize.
Qed.

Program Instance uncurryUsized {A B} (f : A -> B -> Checker) p
        `{UnsizedChecker (f (fst p) (snd p))} : UnsizedChecker (uncurry f p).
Next Obligation. by apply unsizedChecker. Qed.

(* A typeclass so we can automate the application of the previous theorems
   and get a readable Prop *)

Class Provable (A : Type) {H: Checkable A} : Type :=
 {
    proposition : nat -> A -> Prop;
    proposition_equiv : forall a s, proposition s a <-> semCheckableSize a s
  }.

Program Instance proveResult : Provable Result :=
  {|
    proposition s r := resultSuccessful r
  |}.
Next Obligation.
  by rewrite semCheckableResultSize.
Qed.

Program Instance proveUnit : Provable unit :=
  {|
    proposition := fun _ _ => True
  |}.
Next Obligation.
  by rewrite semCheckableUnitSize.
Qed.

Program Instance proveQProp : Provable QProp :=
  {|
    proposition s qp := successful qp = true
  |}.
Next Obligation.
  by rewrite semCheckableQPropSize.
Qed.

Program Instance proveBool : Provable bool :=
  {|
    proposition s b :=  b = true
  |}.
Next Obligation.
  by rewrite semCheckableBoolSize.
Qed.

Program Instance proveGenProp {C} `{Provable C} :
  Provable (G C) :=
  {|
    proposition s g := (forall p, semGenSize g s p -> proposition s p)
  |}.
Next Obligation.
  destruct H0 as [semP proof]. rewrite /proposition. split.
  - move => H'. apply semCheckableGenSize => p Hgen. apply proof. eapply H'. eassumption.
  - move => /semCheckableGenSize H' p Hgen. eapply proof. apply H'. by auto.
Qed.

Program Instance proveChecker : Provable Checker :=
  {|
    proposition s g := semCheckerSize g s
  |}.
Next Obligation.
  split; intros H; by apply semPredQPropSize.
Qed.

Program Instance proveFun {A C: Type} `{Arbitrary A} `{Show A}
        `{Provable C}: Provable (A -> C) :=
  {|
    proposition s p :=
      (forall a,
         semGenSize arbitrary s a ->
         proposition s (p a))
  |}.
Next Obligation.
  match goal with
    | [ Hyp : Provable _ |- _ ] => destruct Hyp as [semP proof]
  end. rewrite /proposition. split.
  - move=> H'. apply semCheckableFunSize => a' /H' Hgen.
    by apply proof.
  - move=> H' a' Hgen. apply proof. by apply semCheckableFunSize.
Qed.

Program Instance provePolyFun {C : Type -> Type} `{Provable (C nat)} :
  Provable (forall T, C T) :=
  {
    proposition s f := proposition s (f nat)
  }.
Next Obligation.
  destruct H0 as [semP proof]. rewrite /proposition. split.
  - move=> /proof H'. by apply semCheckablePolyFunSize.
  - move=> /semCheckablePolyFunSize H'. by apply proof.
Qed.

Program Instance provePolyFunSet {C : Set -> Type} `{Provable (C nat)} :
  Provable (forall T, C T) :=
  {
    proposition s f := proposition s (f nat)
  }.
Next Obligation.
  destruct H0 as [semP proof]. rewrite /proposition. split.
  - move=> /proof H'. by apply semCheckablePolyFunSetSize.
  - move=> /semCheckablePolyFunSetSize H'. by apply proof.
Qed.


(*
 ============================================================================
 Project     : Nominal A, AC and C Unification
 File        : Equiv_Tuples.v
 Authors     : Washington Luis R. de Carvalho Segundo and
               Mauricio Ayala Rincon
               Universidade de Brasilia (UnB) - Brazil
               Group of Theory of Computation

 Description : This file contains preliminaries results about
               tuples and the relation ~aacc .

 Last Modified On: Sep 17, 2018.
 ============================================================================
 *)

Require Export Equiv Omega.

Lemma aacc_equiv_TPlength : forall C t1 t2 E n,
 C |- t1 ~aacc t2 -> TPlength t1 E n = TPlength t2 E n.
Proof.
  intros. induction H; trivial. simpl; auto.

  case (nat_pair_eqdec (E0,n0) (E,n)); intro H1. inverts H1.
  autorewrite with tuples; trivial.
  rewrite 2 TPlength_Fc_diff; trivial.

  case (nat_pair_eqdec (0,n0) (E,n)); intro H2. inverts H2.
  autorewrite with tuples.
  case (nat_eqdec (TPlength t 0 n) 1); case (nat_eqdec (TPlength t' 0 n) 1);
  intros H2 H3; try omega.
  rewrite TPithdel_TPlength_1 in H1;
  autorewrite with tuples; try omega.
  rewrite TPithdel_Fc_eq in H1; try omega. inverts H1.
  rewrite TPithdel_Fc_eq in H1; try omega.
  rewrite TPithdel_TPlength_1 with (t:=Fc 0 n t') in H1;
  autorewrite with tuples; try omega. inverts H1.
  rewrite 2 TPithdel_Fc_eq in IHequiv2; try omega.
  autorewrite with tuples in IHequiv2;
  rewrite 2 TPlength_TPithdel in IHequiv2; try omega.
  rewrite 2 TPlength_Fc_diff; trivial.

  case (nat_pair_eqdec (1,n0) (E,n)); intro H2. inverts H2.
  autorewrite with tuples.
  case (nat_eqdec (TPlength t 1 n) 1); case (nat_eqdec (TPlength t' 1 n) 1);
  intros H2 H3; try omega.
  rewrite TPithdel_TPlength_1 in H1;
  autorewrite with tuples; try omega.
  rewrite TPithdel_Fc_eq in H1; try omega. inverts H1.
  rewrite TPithdel_Fc_eq in H1; try omega.
  rewrite TPithdel_TPlength_1 with (t:=Fc 1 n t') in H1;
  autorewrite with tuples; try omega. inverts H1.
  rewrite 2 TPithdel_Fc_eq in IHequiv2; try omega.
  autorewrite with tuples in IHequiv2;
  rewrite 2 TPlength_TPithdel in IHequiv2; try omega.
  rewrite 2 TPlength_Fc_diff; trivial.

  case (nat_pair_eqdec (2,n0) (E,n)); intro H2. inverts H2.
  autorewrite with tuples. simpl. omega.
  rewrite 2 TPlength_Fc_diff; trivial.

  case (nat_pair_eqdec (2,n0) (E,n)); intro H2. inverts H2.
  autorewrite with tuples. simpl. omega.
  rewrite 2 TPlength_Fc_diff; trivial.

Qed.

Lemma aacc_equiv_TPith_l1 : forall C t t' E n, C |- t ~aacc t' ->
                         exists j, j > 0 /\ j <= TPlength t' E n /\
                         C |- TPith 1 t E n ~aacc TPith j t' E n /\
                         C |- TPithdel 1 t E n ~aacc TPithdel j t' E n.
Proof.
 intros. induction H; intros.

 exists 1. simpl; split~. exists 1. simpl; split~.

 generalize H. intro H'.
 apply aacc_equiv_TPlength with (E:=E) (n:=n) in H'.
 case IHequiv1; trivial. intros j Hj. clear IHequiv1 IHequiv2.
 destruct Hj. destruct H2. destruct H3. exists j.
 simpl TPlength. rewrite 2 TPith_Pr_le; try omega; auto.
 case (nat_eqdec (TPlength t1' E n) 1); intro H5.
 rewrite 2 TPithdel_t1_Pr; try omega. repeat split~; try omega; trivial.
 rewrite 2 TPithdel_Pr_le; try omega; trivial.
 repeat split~; try omega; auto.

 destruct IHequiv. destruct H1. destruct H2. destruct H3.
 generalize H0; intro H0'.
 apply aacc_equiv_TPlength with (E:=E) (n:=n) in H0.
 case (nat_pair_eqdec (E0,n0) (E,n)); intro H5. inverts H5. exists x.
 autorewrite with tuples. repeat split~; trivial.
 case (nat_eqdec (TPlength t E n) 1); intro H5.
 rewrite 2 TPithdel_TPlength_1; autorewrite with tuples; try omega; auto.
 rewrite 2 TPithdel_Fc_eq; try omega; auto.
 destruct H. apply equiv_Fc. left~. trivial.
 destruct H. rewrite H in *|-*. apply equiv_Fc_c; trivial.
 exists 1. rewrite TPlength_Fc_diff; trivial.
 rewrite 2 TPith_Fc_diff; trivial.
 rewrite 2 TPithdel_TPlength_1; try rewrite TPlength_Fc_diff; trivial.
 repeat split~; auto.

 exists 1. simpl; split~. exists 1. simpl; split~.
 exists 1. simpl; split~.

 exists 1. clear IHequiv1 IHequiv2.
 case (nat_pair_eqdec (0,n0) (E,n)); intro H2. inverts H2.
 autorewrite with tuples in *|-*. repeat split~; try omega; trivial.
 rewrite TPlength_Fc_diff; trivial. rewrite 2 TPith_Fc_diff; trivial.
 rewrite 2 TPithdel_Fc_diff; trivial. repeat split~; try omega; auto.

 case (nat_pair_eqdec (1,n0) (E,n)); intro H2. inverts H2.
 case (nat_eqdec i 0); intro H2.
 exists 1. rewrite H2 in *|-; rewrite TPith_0 in *|-; rewrite TPithdel_0 in *|-.
 autorewrite with tuples in *|-*. repeat split~; try omega; trivial.
 case (le_dec i (TPlength t' 1 n)); intro H3.
 exists i. autorewrite with tuples in *|-*. repeat split~; try omega; trivial.
 exists (TPlength t' 1 n).
 rewrite TPith_overflow with (i:=i) in H0; autorewrite with tuples in *|-*; try omega.
 rewrite TPithdel_overflow with (i:=i) in H1; autorewrite with tuples in * |-*; try omega.
 repeat split~; try omega; trivial.
 exists 1. rewrite TPlength_Fc_diff in *|-*; trivial. rewrite 2 TPith_Fc_diff; trivial.
 rewrite 2 TPithdel_Fc_diff; trivial. repeat split~; try omega; auto.
 apply equiv_AC with (i:=i); trivial.

 case (nat_pair_eqdec (2,n0) (E,n)); intro H2. inverts H2.
 generalize H0. intro H'.
 apply aacc_equiv_TPlength with (E:=2) (n:=n) in H'.
 case IHequiv1; trivial. intros j Hj. clear IHequiv1 IHequiv2.
 destruct Hj. destruct H3. destruct H4.
 exists j. autorewrite with tuples. simpl TPlength.
 rewrite 2 TPith_Pr_le; try omega; auto.
 rewrite 2 TPithdel_Fc_eq. repeat split~; try omega.
 case (nat_eqdec (TPlength s0 2 n) 1); intros H6.
 assert (Q:j=1). omega. rewrite Q in *|-*; trivial.
 rewrite 2 TPithdel_t1_Pr; try omega.
 apply equiv_Fc_c; trivial.
 rewrite 2 TPithdel_Pr_le; try omega. apply equiv_C1; trivial.
 assert (Q0 : TPlength t1 2 n >= 1). auto. simpl; try omega.
 assert (Q1 : TPlength s1 2 n >= 1). auto. simpl; try omega.
 exists 1. rewrite TPlength_Fc_diff; trivial.
 rewrite 2 TPith_Fc_diff; trivial.
 rewrite 2 TPithdel_TPlength_1;
 try rewrite TPlength_Fc_diff; trivial.
 try omega. repeat split~.

 case (nat_pair_eqdec (2,n0) (E,n)); intro H2. inverts H2.
 generalize H0. intro H'.
 apply aacc_equiv_TPlength with (E:=2) (n:=n) in H'.
 case IHequiv1; trivial. intros j Hj. clear IHequiv1 IHequiv2.
 destruct Hj. destruct H3. destruct H4.
 exists (TPlength t0 2 n + j). autorewrite with tuples. simpl TPlength.
 rewrite TPith_Pr_le; try omega; auto.
 rewrite TPith_Pr_gt; try omega; auto.
 replace (TPlength t0 2 n + j - TPlength t0 2 n) with j; try omega.
 rewrite 2 TPithdel_Fc_eq. repeat split~; try omega.
 case (nat_eqdec (TPlength s0 2 n) 1); intros H6.
 assert (Q:j=1). omega. rewrite Q in *|-*; trivial.
 rewrite TPithdel_t1_Pr; try omega.
 rewrite TPithdel_t2_Pr; try omega.
 apply equiv_Fc_c; trivial.
 rewrite TPithdel_Pr_le; try omega.
 rewrite TPithdel_Pr_gt; try omega.
 replace (TPlength t0 2 n + j - TPlength t0 2 n) with j; try omega.
 apply equiv_C2; trivial.
 assert (Q0 : TPlength t0 2 n >= 1). auto. simpl; try omega.
 assert (Q1 : TPlength s1 2 n >= 1). auto. simpl; try omega.
 exists 1. rewrite TPlength_Fc_diff; trivial.
 rewrite 2 TPith_Fc_diff; trivial.
 rewrite 2 TPithdel_TPlength_1;
 try rewrite TPlength_Fc_diff; trivial.
 try omega. repeat split~.

Qed.

Lemma aacc_equiv_TPith_E_diff_1_2 : forall C t t' i E n,
                 ~ set_In E (1::|[2]|) -> C |- t ~aacc t' ->
                 (C |- TPith i t E n ~aacc TPith i t' E n /\
                  C |- TPithdel i t E n ~aacc TPithdel i t' E n).
Proof.
 intros. gen i. induction H0; intro.
 simpl; split~. simpl; split~.

 generalize H0_ H0_0. intros H0' H0_0'.
 apply aacc_equiv_TPlength with (E:=E) (n:=n) in H0_.
 apply aacc_equiv_TPlength with (E:=E) (n:=n) in H0_0.

 case (le_dec i (TPlength t1 E n)); intro H1.
 rewrite 2 TPith_Pr_le; try omega.
 case (nat_eqdec (TPlength t1 E n) 1); intro H2.
 rewrite 2 TPithdel_t1_Pr; try omega.
 split~; trivial. apply IHequiv1.
 rewrite 2 TPithdel_Pr_le; try omega.
 split~. apply IHequiv1. apply equiv_Pr; trivial. apply IHequiv1.
 rewrite 2 TPith_Pr_gt; try omega.
 case (nat_eqdec (TPlength t2 E n) 1); intro H2.
 rewrite TPithdel_t2_Pr; try omega. rewrite H0_.
 rewrite TPithdel_t2_Pr; try omega.
 split~; trivial. apply IHequiv2.
 rewrite 2 TPithdel_Pr_gt; try omega.
 rewrite H0_. split~. apply IHequiv2.
 apply equiv_Pr; trivial. apply IHequiv2.

 generalize H1; intro H1'.
 apply aacc_equiv_TPlength with (E:=E) (n:=n) in H1.
 case (nat_pair_eqdec (E0,n0) (E,n)); intro H2. inverts H2.
 autorewrite with tuples in *|-*.  split~. apply IHequiv.
 case (nat_eqdec (TPlength t E n) 1); intro H2.
 rewrite 2 TPithdel_TPlength_1;
 autorewrite with tuples; try omega; auto.
 rewrite 2 TPithdel_Fc_eq; try omega. destruct H0.
 apply equiv_Fc; trivial. left~. apply IHequiv. destruct H0.
 rewrite H0 in *|-*. apply equiv_Fc_c. apply IHequiv.
 rewrite 2 TPithdel_TPlength_1; try rewrite TPlength_Fc_diff; trivial.
 rewrite 2 TPith_Fc_diff; trivial. split~; auto.

 simpl; split~. simpl; split~. simpl; split~.

 clear H0 IHequiv1.
 case (nat_pair_eqdec (0,n0) (E,n)); intro H1. inverts H1. clear H.
 case (le_dec i 1); intro H2. case (nat_eqdec i 0); intro H3; try rewrite H3;
 repeat rewrite TPith_0; repeat rewrite TPithdel_0. split~; trivial.
 assert (Qi:i=1). omega. rewrite Qi. split~; trivial.
 autorewrite with tuples in *|-*.
 assert (Q: C |- Fc 0 n t ~aacc Fc 0 n t').
  apply equiv_A; simpl set_In; try omega; autorewrite with tuples; trivial.
 apply aacc_equiv_TPlength with (E:=0) (n:=n) in Q.
 autorewrite with tuples in Q. case (nat_eqdec (TPlength t 0 n) 1); intro H1.
 rewrite 2 TPithdel_TPlength_1;
 try rewrite 2 TPith_overflow with (i:=i);
 autorewrite with tuples; try omega. rewrite <- Q. rewrite H1; split~; trivial.

 rewrite 2 TPithdel_Fc_eq in *|-*; try omega.

 case (le_dec i (TPlength t 0 n)); intro H3.

 assert (Q1: C |- TPith (i-1) (Fc 0 n (TPithdel 1 t 0 n)) 0 n ~aacc
                 TPith (i-1) (Fc 0 n (TPithdel 1 t' 0 n)) 0 n /\
            C |- TPithdel (i-1) (Fc 0 n (TPithdel 1 t 0 n)) 0 n ~aacc
                 TPithdel (i-1) (Fc 0 n (TPithdel 1 t' 0 n)) 0 n).
 apply IHequiv2. clear IHequiv2.
 destruct Q1. autorewrite with tuples in H.
 rewrite 2 TPith_TPithdel_geq in H; try omega.
 replace (i - 1 + 1) with i in H; try omega; trivial.
 split~; trivial. apply equiv_A; simpl set_In; try omega.
 autorewrite with tuples. rewrite 2 TPith_TPithdel_lt; try omega; trivial.
 case (nat_eqdec (TPlength t 0 n) 2); intro H4.
 rewrite 2 TPithdel_TPlength_1; auto; autorewrite with tuples;
 try rewrite TPlength_TPithdel; try omega.
 rewrite 2 TPithdel_Fc_eq in *|-*; autorewrite with tuples;
 try rewrite TPlength_TPithdel; try omega.
 rewrite TPithdel_lt_comm; try omega.
 rewrite TPithdel_lt_comm with (i:=1); try omega; trivial.

 assert (Q1: C |- TPith (TPlength t 0 n -1) (Fc 0 n (TPithdel 1 t 0 n)) 0 n ~aacc
                 TPith (TPlength t 0 n -1) (Fc 0 n (TPithdel 1 t' 0 n)) 0 n /\
            C |- TPithdel (TPlength t 0 n -1) (Fc 0 n (TPithdel 1 t 0 n)) 0 n ~aacc
                 TPithdel (TPlength t 0 n -1) (Fc 0 n (TPithdel 1 t' 0 n)) 0 n).
 apply IHequiv2. clear IHequiv2. destruct Q1.
 rewrite 2 TPith_overflow with (i:=i); try omega.
 rewrite 2 TPithdel_overflow with (i:=i); autorewrite with tuples; try omega.
 autorewrite with tuples in H.
 assert (Q1: TPlength t 0 n >= 1 /\ TPlength t 0 n >= 1). auto. destruct Q1.
 rewrite 2 TPith_TPithdel_geq in H; try omega.
 replace (TPlength t 0 n - 1 + 1) with (TPlength t 0 n) in H; try omega; trivial.
 rewrite <- Q. split~; trivial. apply equiv_A; simpl set_In; try omega.
 autorewrite with tuples. rewrite 2 TPith_TPithdel_lt; try omega; trivial.
 case (nat_eqdec (TPlength t 0 n) 2); intro H6.
 rewrite 2 TPithdel_TPlength_1; auto; autorewrite with tuples;
 try rewrite TPlength_TPithdel; try omega.
 rewrite 2 TPithdel_Fc_eq in *|-*; autorewrite with tuples;
 try rewrite TPlength_TPithdel; try omega.
 rewrite 2 TPithdel_lt_comm with (i:=1); try omega; trivial.

 rewrite 2 TPith_Fc_diff; trivial. rewrite 2 TPithdel_Fc_diff; trivial.
 split~; auto. apply equiv_A; simpl set_In; try omega; trivial.

 assert (Q:(1,n0) <> (E,n)). intro H'. inverts H'.
 simpl in H. apply H. right~.
 rewrite 2 TPith_Fc_diff; trivial. rewrite 2 TPithdel_Fc_diff; trivial.
 split~. apply equiv_AC with (i:=i); simpl set_In; try omega; trivial.

 case (nat_pair_eqdec (2,n0) (E,n)); intro H1. inverts H1.
 simpl in H. false. apply H. right~.
 rewrite 2 TPith_Fc_diff; trivial.
 rewrite 2 TPithdel_TPlength_1; try rewrite TPlength_Fc_diff; trivial.
 split~; auto.

 case (nat_pair_eqdec (2,n0) (E,n)); intro H1. inverts H1.
 simpl in H. false. apply H. right~.
 rewrite 2 TPith_Fc_diff; trivial.
 rewrite 2 TPithdel_TPlength_1; try rewrite TPlength_Fc_diff; trivial.
 split~; auto.

Qed.

Lemma aacc_equiv_Fc : forall C t t' E n, C |- t ~aacc t' ->
                                        C |- Fc E n t ~aacc Fc E n t'.
Proof.
  intros. gen_eq l : (TPlength t E n); intro H0.
  gen t t' H0 H. induction l using peano_induction; intros.
  case (set_In_dec nat_eqdec E (0 :: 1 :: (|[2]|))); intro H2.

  Focus 2.
  (* 2:{ *) apply equiv_Fc. left~. trivial. (* } *)

  generalize H1; intro H1'.
  apply aacc_equiv_TPlength with (E:=E) (n:=n) in H1'.

  assert (Q: TPlength t E n >= 1). auto.
  simpl in H2. destruct H2.

  rewrite <- H2 in *|-*. clear H2.
  apply aacc_equiv_TPith_E_diff_1_2 with
  (E:=0) (n:=n) (i:=1) in H1; try omega.
  destruct H1. apply equiv_A; simpl set_In; try omega; trivial.
  autorewrite with tuples; trivial.
  case (nat_eqdec (TPlength t 0 n) 1); intro H3.
  rewrite 2 TPithdel_TPlength_1; autorewrite with tuples; auto; try omega.
  rewrite 2 TPithdel_Fc_eq; try omega.
  apply H with (m:=TPlength (TPithdel 1 t 0 n) 0 n); trivial.
  rewrite TPlength_TPithdel; try omega.

  simpl. intro. omega. destruct H2.

  rewrite <- H2 in *|-*. clear H2.
  apply aacc_equiv_TPith_l1 with (E:=1) (n:=n) in H1.
  destruct H1. destruct H1. destruct H2. destruct H3.
  apply equiv_AC with (i:=x); simpl set_In;
  repeat split~; try omega; trivial.
  autorewrite with tuples; trivial.
  case (nat_eqdec (TPlength t 1 n) 1); intro H5.
  rewrite 2 TPithdel_TPlength_1;
  autorewrite with tuples; try omega; auto.
  rewrite 2 TPithdel_Fc_eq; try omega.
  apply H with (m:=TPlength (TPithdel 1 t 1 n) 1 n); trivial.
  rewrite TPlength_TPithdel; try omega.

  destruct H2; try contradiction.
  rewrite <- H2. apply equiv_Fc_c; trivial.

Qed.

Lemma aacc_equiv_Fc_A_TPith : forall C t t' n,
                 TPlength t 0 n = TPlength t' 0 n ->
                 (forall i, i <= TPlength t 0 n ->
                 C |- TPith i t 0 n ~aacc TPith i t' 0 n) ->
                 C |- Fc 0 n t  ~aacc Fc 0 n t' .
Proof.
  intros. gen_eq l : (TPlength t 0 n). intro H1.
  gen t t' H1 H H0. induction l using peano_induction; intros.
  assert (Q : TPlength t 0 n >= 1). auto.
  apply equiv_A. left~. rewrite 2 TPith_Fc_eq. apply H2. omega.
  case (nat_eqdec l 1); intro H3.
  rewrite 2 TPithdel_TPlength_1;
    try rewrite TPlength_Fc_eq; try omega; auto.
  rewrite 2 TPithdel_Fc_eq; try omega.
  apply H with (m := TPlength (TPithdel 1 t 0 n) 0 n); trivial.
  rewrite H1. rewrite TPlength_TPithdel; try omega.
  rewrite 2 TPlength_TPithdel; omega.
  intros. case (le_dec i 1); intro H5.
  rewrite 2 TPith_TPithdel_leq_1; try omega.
  apply H2; try omega.
  rewrite TPlength_TPithdel in H4; try omega.
  rewrite 2 TPith_TPithdel_geq; try omega.
  apply H2. omega.
Qed.


Require Import trees.

Definition tree_to_list_loop :=
  SWhile ("s" <> 0)
  {{"sn" <- "s"
   ;"tn"<- "sn"->>"val"
   ;"s" <- "s"->>"next"
   ;HDealloc "sn"
   ;SIf ("tn"->>"left" <> 0)
     {{"sn" <- EAlloc
      ;"sn"<<- build_node ("tn"->>"left") "s"
      ;"s"  <- "sn"
      }} Skip
   ;SIf ("tn"->>"right"<>0)
     {{"sn"<- EAlloc;"sn"<<- build_node "tn" "s";"s"  <- "sn"
      ;"sn"<- EAlloc;"sn"<<- build_node ("tn"->>"right") "s";"s" <- "sn"
      ;"tn"<<- build_tree ("tn"->>"val") 0 0
      }}
     {{"ln" <- EAlloc;"ln"<<- build_node ("tn"->>"val") "l";"l"<-"ln"
      ;HDealloc "tn"}}
   }}.
Definition tree_to_list_def := FunDef "tree_to_list" ["t"]
 {{SIf ("t"=0) (SReturn 0) Skip
  (* Start the list *)
  ;Decl "l";"l" <- 0
  (* An explicit stack of trees we are processing *)
  ;Decl "s";"s" <- EAlloc; "s" <<- build_node "t" 0
  ;Decl "sn";Decl "tn";Decl "ln"
  ;tree_to_list_loop
  ;SReturn "l"}}.

Fixpoint tree2List t :=
  match t with
    | Leaf => nil
    | Node v l r => tree2List l ++ v :: tree2List r
  end.
Fixpoint trees2List ts :=
  match ts with
    | nil => nil
    | t :: ts => tree2List t ++ trees2List ts
  end.
Inductive tree_to_list_spec : Spec kcfg :=
  loop_claim : forall ts t l s tn lv ln sn, heap_loop tree_to_list_spec
    tree_to_list_def 0 ("t" s|-> KInt t :* "l" s|-> KInt l :* "s" s|-> KInt s
                :* "tn" s|-> tn :* "ln" s|-> ln :* "sn" s|-> sn)
    (rep_prop_list (fun t p => constraint (p <> 0) :* rep_tree t p) ts s :* rep_list lv l)
    (rep_list (trees2List (rev ts) ++ lv))
| tree_to_list_claim : forall t p, heap_fun tree_to_list_spec nil
    tree_to_list_def [Int p] (rep_tree t p) (rep_list (tree2List t)).

Lemma trees2List_app : forall l1 l2, trees2List (l1 ++ l2) = trees2List l1 ++ trees2List l2.
Proof. induction l1;intros;[|simpl;rewrite IHl1, app_ass];reflexivity. Qed.
Hint Rewrite trees2List_app : trans_simpl.

Lemma tree_to_list_proof : sound kstep tree_to_list_spec.
Proof. tree_solver;
simpl in * |- *;simplify_pat_hyps;subst;tree_run.
Qed.


From mathcomp Require Import ssrnat ssrbool fintype.
Require Export prosa.analysis.facts.behavior.all.

(** This file provides an operation that transforms a finite prefix of
    a given schedule by applying a point-wise transformation to each
    instant up to a given horizon. *)

Section SchedulePrefixMap.

  (** For any type of jobs and... *)
  Context {Job : JobType}.

  (** ... any given type of processor states ... *)
  Context {PState: eqType}.
  Context `{ProcessorState Job PState}.

  (** ... we define a procedure that applies a given function to every
     point in a given finite prefix of the schedule.

     The point-wise transformation f is given a schedule and the point
     to transform, and must yield a transformed schedule that is used
     in subsequent operations. *)
  Fixpoint prefix_map
           (sched: schedule PState)
           (f: schedule PState -> instant -> schedule PState)
           (horizon: instant) :=
    match horizon with
    | 0 => sched
    | S t =>
      let
        prefix := prefix_map sched f t
      in f prefix t
    end.

  (** We provide a utility lemma that establishes that, if the
      point-wise transformation maintains a given property of the
      original schedule, then the prefix_map does so as well. *)
  Section PropertyPreservation.

    (** Given any property of schedules... *)
    Variable P: schedule PState -> Prop.

    (** ...and a point-wise transformation [f],... *)
    Variable f: schedule PState -> instant -> schedule PState.

    (** ...if [f] maintains property [P],... *)
    Hypothesis H_f_maintains_P: forall sched t, P sched -> P (f sched t).

    (** ...then so does a prefix map of [f]. *)
    Lemma prefix_map_property_invariance:
      forall sched h, P sched -> P (prefix_map sched f h).
    Proof.
      move=> sched h P_sched.
      induction h; first by rewrite /prefix_map.
      rewrite /prefix_map -/prefix_map.
      by apply: H_f_maintains_P.
    Qed.

  End PropertyPreservation.

  (** Next, we consider the case where the point-wise transformation
      establishes a new property step-by-step. *)
  Section PointwiseProperty.

    (** Given any property of schedules [P],... *)
    Variable P: schedule PState -> Prop.

    (** ...any point-wise property [Q],... *)
    Variable Q: schedule PState -> instant -> Prop.

    (** ...and a point-wise transformation [f],... *)
    Variable f: schedule PState -> instant -> schedule PState.

    (** ...if [f] maintains [P]... *)
    Hypothesis H_f_maintains_P:
      forall sched t_ref,
        P sched -> P (f sched t_ref).

    (** ...and establishes [Q] (provided that [P] holds)... *)
    Hypothesis H_f_grows_Q:
      forall sched t_ref,
        P sched ->
        (forall t', t' <  t_ref -> Q sched t') ->
        forall t', t' <= t_ref -> Q (f sched t_ref) t'.

    (** ...then the prefix-map operation will "grow" [Q] up to the horizon. *)
    Lemma prefix_map_pointwise_property:
      forall sched horizon,
        P sched ->
        forall t,
          t < horizon ->
          Q (prefix_map sched f horizon) t.
    Proof.
      move=> sched h P_holds.
      induction h as [|h Q_holds_before_h]; first by rewrite /prefix_map.
      rewrite /prefix_map -/prefix_map => t.
      rewrite ltnS => LE_t_h.
      apply H_f_grows_Q => //.
      by apply prefix_map_property_invariance.
    Qed.

  End PointwiseProperty.

End SchedulePrefixMap.


(* Kernel test (head term is a constant) *)
Check (fun a : S = S => a : S = fun x => S x).

(* Kernel test (head term is a variable) *)
Check (fun (f:nat->nat) (a : f = f) => a : f = fun x => f x).

(* Test type inference  (head term is syntactically rigid) *)
Check (fun (a : list = list) => a : list = fun A => _ A).

(* Test type inference (head term is a variable) *)
(* This one is still to be done...
Check (fun (f:nat->nat) (a : f = f) => a : f = fun x => _ x).
*)

(* Test tactic unification *)
Goal (forall f:nat->nat, (fun x => f x) = (fun x => f x)) -> S = S.
intro H; apply H.
Qed.


From Coq Require Import ssreflect Extraction OrderedType Orders.
From Equations Require Import Equations.

Lemma CompareSpec_Proper : Proper (iff ==> iff ==> iff ==> Logic.eq ==> iff) CompareSpec.
Proof.
  intros A A' HA B B' HB C C' HC c c' [].
  destruct c; split; inversion 1; constructor; intuition.
Qed.

Definition compare_cont (c : comparison) (d : comparison) : comparison :=
  match c with
  | Datatypes.Lt => Datatypes.Lt
  | Datatypes.Eq => d
  | Datatypes.Gt => Datatypes.Gt
  end.
Extraction Inline compare_cont.

Local Notation " c ?? y " := (compare_cont c y) (at level 100).

Lemma compare_cont_CompOpp p q : CompOpp (compare_cont p q) = compare_cont (CompOpp p) (CompOpp q).
Proof.
  destruct p, q; cbn => //.
Qed.

Definition comparison_trans p q :=
  match p, q with
  | Datatypes.Eq, c => Some c
  | c, Datatypes.Eq => Some c
  | Datatypes.Lt, Datatypes.Gt => None
  | Datatypes.Gt, Datatypes.Lt => None
  | c, _ => Some c
  end.

Lemma compare_cont_trans {A} (cmp : A -> A -> comparison) :
  (forall c x y z, cmp x y = c -> cmp y z = c -> cmp x z = c) ->
  (forall x y, cmp x y = Datatypes.Eq -> x = y) ->
  forall c x y z q q' q'',
  (forall c, q = c -> q' = c -> q'' = c) ->
  compare_cont (cmp x y) q = c -> compare_cont (cmp y z) q' = c -> compare_cont (cmp x z) q'' = c.
Proof.
  intros Hc He c x y z q q' q'' Hqs.
  destruct (cmp x y) eqn:e.
  apply He in e. subst y.
  cbn. intros ->.
  destruct (cmp x z) eqn:e'; cbn.
  apply He in e'. subst z. now apply Hqs.
  all:auto.

  cbn. intros <-.
  destruct (cmp y z) eqn:e'; cbn.
  apply He in e'. subst z. rewrite e /= //. intros _.
  rewrite (Hc _ _ _ _ e e') /= //.
  discriminate. cbn. intros <-.
  destruct (cmp y z) eqn:e'; cbn => //.
  eapply He in e'; subst. intros ->. rewrite e //.
  intros _. rewrite (Hc _ _ _ _ e e') //.
Qed.

(** Facts about booleans, characters and strings *)

Module BoolOT <: UsualOrderedType.
  Definition t := bool.

  Definition compare (x y : bool) : comparison :=
    if x then if y then Eq else Gt else if y then Lt else Eq.

  Definition lt (x y : bool) :=
    if x then False else y = true.

  Definition compare_spec (x y : bool) : CompareSpec (x = y) (lt x y) (lt y x) (compare x y).
  Proof.
    destruct x, y.
    - constructor 1. reflexivity.
    - constructor 3. reflexivity.
    - constructor 2. reflexivity.
    - constructor 1. reflexivity.
  Defined.

  Definition eq : t -> t -> Prop := eq.
  Definition eq_equiv : Equivalence eq := _.

  Definition eq_dec (l1 l2 : t) : {l1 = l2}+{l1 <> l2}.
  Proof.
    decide equality.
  Defined.

  Definition lt_strorder : StrictOrder lt.
  Proof.
    constructor.
    - intros []; cbn; unfold lt, complement; congruence.
    - intros x y z.
      destruct x, y, z; cbn; try congruence; auto.
  Qed.

  Definition lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    intros x y e z t e'. unfold eq in *; subst. reflexivity.
  Qed.

  (* Bonus *)
  Definition eqb (l1 l2 : t) : bool
    := match compare l1 l2 with Eq => true | _ => false end.

  Definition eq_leibniz (x y : t) : eq x y -> x = y := id.

End BoolOT.

Notation bool_compare := BoolOT.compare.

Local Ltac trd := cbn in *; try reflexivity; try discriminate.

Module ListOrderedType (A : UsualOrderedType) <: UsualOrderedType.
  Definition t := list A.t.
  Import List. Import ListNotations.

  Fixpoint compare (l1 l2 : t) : comparison :=
    match l1, l2 with
    | [], [] => Eq
    | hd :: tl, hd' :: tl' => compare_cont (A.compare hd hd') (compare tl tl')
    | [], _ :: _ => Lt
    | _, [] => Gt
    end.

  Definition eq : t -> t -> Prop := eq.
  Definition eq_equiv : Equivalence eq := _.

  Inductive lt_ : t -> t -> Prop :=
  | lt_nil_cons hd tl : lt_ [] (hd :: tl)
  | lt_cons_cons_hd hd tl hd' tl' : A.lt hd hd' -> lt_ (hd :: tl) (hd' :: tl')
  | lt_cons_cons_tl hd tl tl' : lt_ tl tl' -> lt_ (hd :: tl) (hd :: tl').
  Derive Signature for lt_.
  Local Hint Constructors lt_ : core.

  Definition lt := lt_.

  Global Instance lt_strorder : StrictOrder lt.
  Proof.
    constructor.
    - intros x X. depind X.
      * now eapply irreflexivity in H.
      * now apply IHX.
    - intros x y z.
      induction 1 in z |- *.
      * intros H; depelim H; constructor.
      * intros H'; depelim H'; constructor; auto.
        now transitivity hd'.
      * intros H'; depelim H'.
        + constructor; auto.
        + constructor 3. now apply IHlt_.
  Qed.

  Global Instance lt_compat : Proper (eq ==> eq ==> iff) lt.
  Proof.
    intros x y e z t e'. unfold eq in *; subst. reflexivity.
  Qed.

  Definition compare_spec :
    forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y).
  Proof.
    induction x; destruct y; repeat constructor.
    cbn.
    destruct (A.compare_spec a t0); subst.
    - cbn. eapply CompareSpec_Proper.
      5: eapply IHx. 4: reflexivity.
      intuition auto; congruence.
      * intuition auto.
        { depelim H; auto. now apply irreflexivity in H. }
        { now constructor 3. }
      * intuition auto.
        { depelim H; auto. now apply irreflexivity in H. }
        { constructor 3; auto. }
    - cbn. repeat constructor; auto.
    - cbn. repeat constructor; auto.
  Qed.

  Lemma compare_eq x y : compare x y = Eq -> x = y.
  Proof.
    destruct (compare_spec x y); auto; congruence.
  Qed.

  Lemma compare_refl x : compare x x = Eq.
  Proof. destruct (compare_spec x x); auto; now apply irreflexivity in H. Qed.

  Lemma compare_sym x y : compare x y = CompOpp (compare y x).
  Proof.
    destruct (compare_spec x y);
    destruct (compare_spec y x); simpl; auto; subst; try congruence.
    all:try now apply irreflexivity in H.
    all:try now apply irreflexivity in H0.
    pose proof (transitivity H H0). now apply irreflexivity in H1.
    pose proof (transitivity H H0). now apply irreflexivity in H1.
  Qed.

  Lemma compare_lt_lt x y : compare x y = Lt <-> lt x y.
  Proof.
    split.
    - destruct (compare_spec x y); subst; try congruence.
    - intros hlt.
      destruct (compare_spec x y); subst; auto.
      * now apply irreflexivity in hlt.
      * eapply transitivity in H; eauto. now apply irreflexivity in H.
  Qed.

  Lemma compare_trans x y z c : compare x y = c -> compare y z = c -> compare x z = c.
  Proof.
    destruct (compare_spec x y); subst; intros <-;
    destruct (compare_spec y z); subst; try congruence.
    eapply transitivity in H0. 2:eassumption. intros _; now apply compare_lt_lt.
    eapply transitivity in H. 2:eassumption.
    apply compare_lt_lt in H. rewrite compare_sym H //.
  Qed.

  (* Bonus *)
  Definition eqb (l1 l2 : t) : bool
    := match compare l1 l2 with Eq => true | _ => false end.

  Definition eq_leibniz (x y : t) : eq x y -> x = y := id.

  Program Definition eqb_dec (x y : t) : { x = y } + { x <> y } :=
    match eqb x y with
    | true => left _
    | false => right _
    end.
  Next Obligation.
    unfold eqb in Heq_anonymous.
    destruct (compare x y) eqn:hc; try congruence.
    now eapply compare_eq in hc.
  Qed.
  Next Obligation.
    unfold eqb in Heq_anonymous.
    rewrite compare_refl in Heq_anonymous. now discriminate.
  Qed.

  Global Instance eq_dec : EqDec t := { eq_dec := eqb_dec }.

End ListOrderedType.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

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

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

From Coq Require Import Reals List ZArith Psatz.
From Flocq Require Import Zaux.
From Coquelicot Require Import Coquelicot.

Require Import Sig.
Require Import Interval_helper.
Require Import Integral_helper.
Require Import Plot_helper.
Require Import Float_full.

Inductive interval_tac_parameters : Set :=
  | i_prec (p : positive)
  | i_bisect (v : R)
  | i_autodiff (v : R)
  | i_taylor (v : R)
  | i_degree (d : nat)
  | i_depth (d : nat)
  | i_fuel (f : positive)
  | i_width (w : Z)
  | i_relwidth (w : positive)
  | i_native_compute
  | i_size (w : positive) (h : positive)
  | i_delay.

Require Tactic_float.

Module IntervalTactic (F : FloatOps with Definition sensible_format := true with Definition radix := radix2).

Module Private.

Module I1 := FloatIntervalFull F.
Module IT1 := IntegralTacticAux F I1.
Module PT1 := PlotTacticAux F I1.
Module I2 := FloatIntervalFull Tactic_float.Float.
Module IT2 := IntegralTacticAux Tactic_float.Float I2.
Module PT2 := PlotTacticAux Tactic_float.Float I2.

Ltac do_interval_parse params depth :=
  let rec aux fvar bvars prec degree depth native nocheck itm params :=
    lazymatch params with
    | nil => constr:((fvar, bvars, prec, degree, depth, native, nocheck, itm))
    | cons (i_prec ?p) ?t => aux fvar bvars (Some p) degree depth native nocheck itm t
    | cons (i_degree ?d) ?t => aux fvar bvars prec d depth native nocheck itm t
    | cons (i_bisect ?x) ?t => aux fvar (cons x bvars) prec degree depth native nocheck itm t
    | cons (i_autodiff ?x) ?t => aux (Some x) bvars prec degree depth native nocheck itm_autodiff t
    | cons (i_taylor ?x) ?t => aux (Some x) bvars prec degree depth native nocheck itm_taylor t
    | cons (i_depth ?d) ?t => aux fvar bvars prec degree d native nocheck itm t
    | cons i_native_compute ?t => aux fvar bvars prec degree depth true nocheck itm t
    | cons i_delay ?t => aux fvar bvars prec degree depth native true itm t
    | cons ?h _ => fail 100 "Unknown tactic parameter" h
    end in
  aux (@None R) (@nil R) (@None positive) 10%nat depth false false itm_naive params.

Ltac do_interval params :=
  match do_interval_parse params 15%nat with
  | (?fvar, ?bvars, ?prec, ?degree, ?depth, ?native, ?nocheck, ?itm) =>
    lazymatch prec with
    | Some ?p =>
      let prec := eval vm_compute in (F.PtoP p) in
      IT1.IH.do_interval fvar bvars prec degree depth native nocheck itm
    | None =>
      let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in
      IT2.IH.do_interval fvar bvars prec degree depth native nocheck itm
    end
  end.

Ltac do_interval_intro t extend params :=
  match do_interval_parse params 5%nat with
  | (?fvar, ?bvars, ?prec, ?degree, ?depth, ?native, ?nocheck, ?itm) =>
    lazymatch prec with
    | Some ?p =>
      let prec := eval vm_compute in (F.PtoP p) in
      IT1.IH.do_interval_intro t extend fvar bvars prec degree depth native nocheck itm
    | None =>
      let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in
      IT2.IH.do_interval_intro t extend fvar bvars prec degree depth native nocheck itm
    end
  end.

Ltac do_integral_parse params :=
  let rec aux prec degree fuel width native nocheck params :=
    lazymatch params with
    | nil => constr:((prec, degree, fuel, width, native, nocheck))
    | cons (i_prec ?p) ?t => aux (Some p) degree fuel width native nocheck t
    | cons (i_degree ?d) ?t => aux prec d fuel width native nocheck t
    | cons (i_fuel ?f) ?t => aux prec degree f width native nocheck t
    | cons (i_width ?w) ?t => aux prec degree fuel (w, false) native nocheck t
    | cons (i_relwidth ?w) ?t => aux prec degree fuel (Zneg w, true) native nocheck t
    | cons i_native_compute ?t => aux prec degree fuel width true nocheck t
    | cons i_delay ?t => aux prec degree fuel width native true t
    | cons ?h _ => fail 100 "Unknown tactic parameter" h
    end in
  aux (@None positive) 10%nat 100%positive (Zneg 10, true) false false params.

Ltac do_integral params :=
  match do_integral_parse params with
  | (?prec, ?degree, ?fuel, _, ?native, ?nocheck) =>
    lazymatch prec with
    | Some ?p =>
      let prec := eval vm_compute in (F.PtoP p) in
      IT1.do_integral prec degree fuel native nocheck
    | None =>
      let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in
      IT2.do_integral prec degree fuel native nocheck
    end
  end.

Ltac do_integral_intro y extend params :=
  match do_integral_parse params with
  | (?prec, ?degree, ?fuel, ?width, ?native, ?nocheck) =>
    lazymatch prec with
    | Some ?p =>
      let prec := eval vm_compute in (F.PtoP p) in
      IT1.do_integral_intro y extend prec degree fuel width native nocheck
    | None =>
      let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in
      IT2.do_integral_intro y extend prec degree fuel width native nocheck
    end
  end.

Ltac do_plot_parse params :=
  let rec aux prec degree width height native params :=
    lazymatch params with
    | nil => constr:((prec, degree, width, height, native))
    | cons (i_prec ?p) ?t => aux (Some p) degree width height native t
    | cons (i_degree ?d) ?t => aux prec d width height native t
    | cons (i_size ?w ?h) ?t => aux prec degree w h native t
    | cons i_native_compute ?t => aux prec degree width height true t
    | cons ?h _ => fail 100 "Unknown tactic parameter" h
    end in
  aux (@None positive) 10%nat 512%positive 384%positive false params.

Ltac do_plot t x1 x2 params :=
  match do_plot_parse params with
  | (?prec, ?degree, ?width, ?height, ?native) =>
    lazymatch prec with
    | Some ?p =>
      let prec := eval vm_compute in (F.PtoP p) in
      PT1.do_plot t x1 x2 prec degree width height native
    | None =>
      let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in
      PT2.do_plot t x1 x2 prec degree width height native
    end
  end.

Ltac do_plot_y t x1 x2 y1 y2 params :=
  match do_plot_parse params with
  | (?prec, ?degree, ?width, ?height, ?native) =>
    lazymatch prec with
    | Some ?p =>
      let prec := eval vm_compute in (F.PtoP p) in
      PT1.do_plot_y t x1 x2 y1 y2 prec degree width height native
    | None =>
      let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in
      PT2.do_plot_y t x1 x2 y1 y2 prec degree width height native
    end
  end.

End Private.

Import Private.

Tactic Notation "interval" :=
  do_interval (@nil interval_tac_parameters).

Tactic Notation "interval" "with" constr(params) :=
  do_interval ltac:(tuple_to_list params (@nil interval_tac_parameters)).

Tactic Notation "interval_intro" constr(t) :=
  do_interval_intro t ie_none (@nil interval_tac_parameters) ; intro.

Tactic Notation "interval_intro" constr(t) "lower" :=
  do_interval_intro t ie_upper (@nil interval_tac_parameters) ; intro.

Tactic Notation "interval_intro" constr(t) "upper"  :=
  do_interval_intro t ie_lower (@nil interval_tac_parameters) ; intro.

Tactic Notation "interval_intro" constr(t) "with" constr(params) :=
  do_interval_intro t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro.

Tactic Notation "interval_intro" constr(t) "lower" "with" constr(params) :=
  do_interval_intro t ie_upper ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro.

Tactic Notation "interval_intro" constr(t) "upper" "with" constr(params) :=
  do_interval_intro t ie_lower ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro.

Tactic Notation "interval_intro" constr(t) "as" simple_intropattern(H) :=
  do_interval_intro t ie_none (@nil interval_tac_parameters) ; intros H.

Tactic Notation "interval_intro" constr(t) "lower" "as" simple_intropattern(H) :=
  do_interval_intro t ie_upper (@nil interval_tac_parameters) ; intros H.

Tactic Notation "interval_intro" constr(t) "upper" "as" simple_intropattern(H)  :=
  do_interval_intro t ie_lower (@nil interval_tac_parameters) ; intros H.

Tactic Notation "interval_intro" constr(t) "with" constr(params) "as" simple_intropattern(H) :=
  do_interval_intro t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H.

Tactic Notation "interval_intro" constr(t) "lower" "with" constr(params) "as" simple_intropattern(H) :=
  do_interval_intro t ie_upper ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H.

Tactic Notation "interval_intro" constr(t) "upper" "with" constr(params) "as" simple_intropattern(H) :=
  do_interval_intro t ie_lower ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H.

Tactic Notation "integral" :=
  do_integral (@nil interval_tac_parameters).

Tactic Notation "integral" "with" constr(params) :=
  do_integral ltac:(tuple_to_list params (@nil interval_tac_parameters)).

Tactic Notation "integral_intro" constr(t) :=
  do_integral_intro t ie_none (@nil interval_tac_parameters) ; intro.

Tactic Notation "integral_intro" constr(t) "lower" :=
  do_integral_intro t ie_upper (@nil interval_tac_parameters) ; intro.

Tactic Notation "integral_intro" constr(t) "upper"  :=
  do_integral_intro t ie_lower (@nil interval_tac_parameters) ; intro.

Tactic Notation "integral_intro" constr(t) "with" constr(params) :=
  do_integral_intro t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro.

Tactic Notation "integral_intro" constr(t) "lower" "with" constr(params) :=
  do_integral_intro t ie_upper ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro.

Tactic Notation "integral_intro" constr(t) "upper" "with" constr(params) :=
  do_integral_intro t ie_lower ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro.

Tactic Notation "integral_intro" constr(t) "as" simple_intropattern(H) :=
  do_integral_intro t ie_none (@nil interval_tac_parameters) ; intros H.

Tactic Notation "integral_intro" constr(t) "lower" "as" simple_intropattern(H) :=
  do_integral_intro t ie_upper (@nil interval_tac_parameters) ; intros H.

Tactic Notation "integral_intro" constr(t) "upper" "as" simple_intropattern(H)  :=
  do_integral_intro t ie_lower (@nil interval_tac_parameters) ; intros H.

Tactic Notation "integral_intro" constr(t) "with" constr(params) "as" simple_intropattern(H) :=
  do_integral_intro t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H.

Tactic Notation "integral_intro" constr(t) "lower" "with" constr(params) "as" simple_intropattern(H) :=
  do_integral_intro t ie_upper ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H.

Tactic Notation "integral_intro" constr(t) "upper" "with" constr(params) "as" simple_intropattern(H) :=
  do_integral_intro t ie_lower ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H.

Tactic Notation "plot" constr(t) constr(x1) constr(x2) :=
  do_plot t x1 x2 (@nil interval_tac_parameters).

Tactic Notation "plot" constr(t) constr(x1) constr(x2) "with" constr(params) :=
  do_plot t x1 x2 ltac:(tuple_to_list params (@nil interval_tac_parameters)).

Tactic Notation "plot" constr(t) constr(x1) constr(x2) constr(y1) constr(y2) :=
  do_plot_y t x1 x2 y1 y2 (@nil interval_tac_parameters).

Tactic Notation "plot" constr(t) constr(x1) constr(x2) constr(y1) constr(y2) "with" constr(params) :=
  do_plot_y t x1 x2 y1 y2 ltac:(tuple_to_list params (@nil interval_tac_parameters)).

End IntervalTactic.

Require Import Specific_bigint.
Require Import Specific_ops.
Module SFBI2 := SpecificFloat BigIntRadix2.
Module IT := IntervalTactic SFBI2.
Export IT.


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

  Getting the heap really right including issues of searching
  through the heap, assigning into the heap and getting an
  address in the heap.

  Alpha conversion can probably be ignored here.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export Tacticals.

Require Export TestUtilities.

Example assign_int :
 S (H.ctxt x  (i_e (i_i 0)) hdot)
   (seq (e_s (assign (p_e x []) (i_e (i_i 1)))) (retn (p_e x [])))
   (H.ctxt x  (i_e (i_i 1)) hdot)
   (seq (e_s (i_e (i_i 1))) (retn (p_e x []))).
Proof.
  apply S_seq_3_10.
  apply S_exp_3_9_1.
  eapply R_assign_3_2;
  eauto with Chapter3.
Qed.

Example assign_int_no_nils :
 S (H.ctxt x  (i_e (i_i 0)) hdot)
   (seq (e_s (assign (p_e x []) (i_e (i_i 1)))) (retn (p_e x [])))
   (H.ctxt x  (i_e (i_i 1)) hdot)
   (seq (e_s (i_e (i_i 1))) (retn (p_e x []))).
Proof.
 eauto 20 with Chapter3.
Qed.

Example assign_x_gets_address_y :
 S (H.ctxt x  (i_e (i_i 0)) (H.ctxt y (i_e (i_i 0)) hdot))
   (e_s (assign (p_e x []) (amp (p_e y []))))
   (H.ctxt x  (amp (p_e y [])) (H.ctxt y (i_e (i_i 0)) hdot))
   (e_s (amp (p_e y []))).
Proof.
  apply S_exp_3_9_1.
  eapply R_assign_3_2;
    eauto 20 with Chapter3.
Qed.

(* TODO make this a statement not a right hand side. *)
Example return_address_of_y :
 S (H.ctxt x (amp (p_e y []))  (H.ctxt y (i_e (i_i 0)) hdot))
   (e_s (p_e x []))
   (H.ctxt x (amp (p_e y []))  (H.ctxt y (i_e (i_i 0)) hdot))
   (e_s (amp (p_e y []))).
Proof.
  apply S_exp_3_9_1.
  eapply R_get_3_1;
  (try reflexivity;
   eauto 20 with Chapter3).
Qed.

Example return_ptr_to_y:
 S
   (H.ctxt x (amp (p_e y []))  (H.ctxt y (i_e (i_i 0)) hdot))
   (e_s (star (p_e x [])))
   (H.ctxt x (amp (p_e y []))  (H.ctxt y (i_e (i_i 0)) hdot))
   (e_s (star (amp (p_e y [])))).
Proof.
  (* eauto 20 with Chapter3. *)
  apply S_exp_3_9_1.
  apply R_star_3_10_1.
  eapply R_get_3_1.
  try reflexivity.
  try reflexivity.
  Focus 2.
  eauto 20 with Chapter3.
  Focus 2.
  eauto 20 with Chapter3.
  apply get_pdot.
  eauto 20 with Chapter3.
Qed.

Example return_contents_of_y :
 S  (H.ctxt x (amp (p_e y []))  (H.ctxt y (i_e (i_i 0)) hdot))
    (e_s (star (amp (p_e y []))))
    (H.ctxt x (amp (p_e y []))  (H.ctxt y (i_e (i_i 0)) hdot))
    (e_s (p_e y [])).
Proof.
  eauto 20 with Chapter3.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Basic definitions: float and rounding property *)
Require Import Fcore_Raux.

Section Def.

(** Definition of a floating-point number *)
Record float (beta : radix) := Float { Fnum : Z ; Fexp : Z }.

Arguments Fnum [beta] _.
Arguments Fexp [beta] _.

Variable beta : radix.

Definition F2R (f : float beta) :=
  (Z2R (Fnum f) * bpow beta (Fexp f))%R.

(** Requirements on a rounding mode *)
Definition round_pred_total (P : R -> R -> Prop) :=
  forall x, exists f, P x f.

Definition round_pred_monotone (P : R -> R -> Prop) :=
  forall x y f g, P x f -> P y g -> (x <= y)%R -> (f <= g)%R.

Definition round_pred (P : R -> R -> Prop) :=
  round_pred_total P /\
  round_pred_monotone P.

End Def.

Arguments Fnum [beta] _.
Arguments Fexp [beta] _.
Arguments F2R [beta] _.

Section RND.

(** property of being a round toward -inf *)
Definition Rnd_DN_pt (F : R -> Prop) (x f : R) :=
  F f /\ (f <= x)%R /\
  forall g : R, F g -> (g <= x)%R -> (g <= f)%R.

Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_DN_pt F x (rnd x).

(** property of being a round toward +inf *)
Definition Rnd_UP_pt (F : R -> Prop) (x f : R) :=
  F f /\ (x <= f)%R /\
  forall g : R, F g -> (x <= g)%R -> (f <= g)%R.

Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_UP_pt F x (rnd x).

(** property of being a round toward zero *)
Definition Rnd_ZR_pt (F : R -> Prop) (x f : R) :=
  ( (0 <= x)%R -> Rnd_DN_pt F x f ) /\
  ( (x <= 0)%R -> Rnd_UP_pt F x f ).

Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_ZR_pt F x (rnd x).

(** property of being a round to nearest *)
Definition Rnd_N_pt (F : R -> Prop) (x f : R) :=
  F f /\
  forall g : R, F g -> (Rabs (f - x) <= Rabs (g - x))%R.

Definition Rnd_N (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_N_pt F x (rnd x).

Definition Rnd_NG_pt (F : R -> Prop) (P : R -> R -> Prop) (x f : R) :=
  Rnd_N_pt F x f /\
  ( P x f \/ forall f2 : R, Rnd_N_pt F x f2 -> f2 = f ).

Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_NG_pt F P x (rnd x).

Definition Rnd_NA_pt (F : R -> Prop) (x f : R) :=
  Rnd_N_pt F x f /\
  forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f2 <= Rabs f)%R.

Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) :=
  forall x : R, Rnd_NA_pt F x (rnd x).

End RND.


Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.HList.
Require Export Parser.Cast.

Lemma cast_head_tail:
  forall T1 T2 TS1 TS2 (t: T1) (ts: hlist TS1) HT (HTS: TS1 = TS2) H,
    exists H',
    HCons
      (eq_rect T1 (fun T => T) t T2 HT)
      (eq_rect (hlist TS1) (fun T => T) ts (hlist TS2) H) =
    eq_rect _ (fun T => T) (HCons t ts) _ H'.
Proof.
  repeat light || eq_dep || exists eq_refl.
Qed.

Lemma h_map_ext:
  forall T l (F1 F2: T -> Type) (f1: forall t, F1 t) (f2: forall t, F2 t) H,
    (forall x, In x l -> exists Hx, f1 x = cast Hx (f2 x)) ->
    h_map f1 l = eq_rect _ (fun T => T) (h_map f2 l) _ H.
Proof.
  induction l;
    repeat light || eq_dep.

  pose proof (H0 a); lights.
  unshelve epose proof (IHl F1 F2 f1 f2 _ _);
    repeat light.
  - f_equal. apply map_ext_in; lights.
    pose proof (H0 a0); lights.
  - rewrite H1. rewrite H2.
    match goal with
    | |- context[HCons (eq_rect ?T1 _ ?t ?T2 ?HT) (eq_rect (hlist ?TS1) _ ?ts (hlist ?TS2) ?H)] =>
      unshelve epose proof (cast_head_tail T1 T2 TS1 TS2 t ts HT _ H)
    end; lights.
    + apply map_ext_in; lights.
      pose proof (H0 a0); lights.
    + rewrite_any; proof_irrelevance; lights.
Qed.

Lemma cast_hcons:
  forall A B b H1 H2,
    eq_rect
      (hlist (A :: nil))
      (fun T : Type => T)
      (HCons (eq_rect B (fun T : Type => T) b A H1) HNil)
      (hlist (B :: nil))
      H2 =
    HCons b HNil.
Proof.
  lights;
    repeat eq_dep || cbn || f_equal.
Qed.

Lemma cast_hcons2:
  forall A A' B B' b b' H1 H1' H2,
    eq_rect
      (hlist (A :: A' :: nil))
      (fun T : Type => T)
      (HCons (eq_rect B (fun T : Type => T) b A H1)
        (HCons (eq_rect B' (fun T: Type => T) b' A' H1')
          HNil))
      (hlist (B :: B' :: nil))
      H2 =
    HCons b (HCons b' HNil).
Proof.
  lights;
    repeat eq_dep || cbn || f_equal.
Qed.