From Coq Require Import String Lia List ssreflect ssrfun ssrbool.
Import ListNotations.
From Ltac2 Require Import Ltac2.

Set Warnings "-notation-overwritten, -parsing".
From mathcomp Require Import ssrnat eqtype seq.
Set Bullet Behavior "Strict Subproofs".
Set SsrOldRewriteGoalsOrder.  (* change Set to Unset when porting the file, then remove the line when requiring MathComp >= 2.6 *)

From QuickChick Require Import Tactics TacticsUtil Instances Classes DependentClasses Sets
        Producer Generators EnumProofs Checker Decidability CheckerProofs.
Local Open Scope set_scope.

Section Lemmas. 

  
  Lemma exists_oneOf_hd A (x : A) g' (g : nat -> G A) (l : nat -> seq (G A)) :
    (exists s : nat, semProd (g s) x) ->
    exists s : nat, semProd (oneOf_ g' ((g s) :: (l s))) x.
  Proof.
    intros Hin. inv Hin.
    eexists. eapply semOneof. now eauto with typeclass_instances.
    eexists. split; eauto. now left. 
  Qed.

  Lemma exists_oneOf_tl A (x : A) g' (g : nat -> G A) (l : nat -> seq (G A)) :
    (exists s : nat, match l s with
                     | nil => False
                     | g1 :: gs => semProd (oneOf_ g' (g1 :: gs)) x
                     end) ->
    exists s : nat, semProd (oneOf_ g' ((g s) :: (l s))) x.
  Proof.
    intros Hin. inv Hin.
    eexists. eapply semOneof. 
    now eauto with typeclass_instances.
    destruct (l x0)  eqn:Heq.
    - exfalso; eauto.
    - eapply semOneof in H > [ | now eauto with typeclass_instances ].
      rewrite Heq. inv H. destruct H0. eexists. split > [ | eassumption ].
      now right; eauto.
  Qed.

  Lemma exists_freq_hd A (x : A) g' (g : nat -> G A) (l : nat -> seq (nat * G A)) n :
    (exists s : nat, semProd (g s) x) ->
    exists s : nat, semProd (freq_ g' ((S n, g s) :: (l s))) x.
  Proof.
    intros Hin. inv Hin.
    eexists. eapply (@semFrequency A). simpl.
    eexists. split; eauto. now left. eassumption.
  Qed.

  Lemma exists_freq_tl A (x : A) g' (g : nat -> G A) (l : nat -> seq (nat * G A)) n :
    (exists s : nat, match l s with
                     | (S n, g1) :: gs => semProd (freq_ g' ((S n, g1) :: gs)) x
                     | _ => False                                                  
                     end) ->
    exists s : nat, semProd (freq_ g' ((S n, g s) :: (l s))) x.
  Proof.
    intros Hin. inv Hin.
    eexists. eapply (@semFrequency A). simpl.
    destruct (l x0)  eqn:Heq.
    - exfalso; eauto.
    - destruct p. destruct n0; try (now (exfalso; eauto)).
      eapply (@semFrequency A) in H.
      rewrite Heq. simpl in H. inv H. destruct H0. eexists. split > [ | eassumption ].
      now right; eauto.
  Qed.

  Lemma exists_bind A B (x : A) (g : G B) (f : nat -> B -> G A) :
    Correct B g ->
    SizeMonotonic g ->
    (forall a s, SizeMonotonic (f a s)) ->

    (exists z s, semProd (f s z) x) ->  
    exists s : nat, semProd (bindGen g (f s)) x.
  Proof.
    intros Hc Hs1 Hs2 He. inv He. inv H. inv H0.
    inv H.
    assert (Hin : [set : B] x0) by reflexivity.
    eapply Hc in Hin. inv Hin. inv H.
    exists x1, (Nat.max x2 x3). split. reflexivity.
    eapply (@semBindSize G ProducerGen _ B A).
    eexists. split.

    eapply Hs1 > [ | eassumption ]. now ssromega.
    eapply Hs2 > [ | eassumption ]. now ssromega.
  Qed.

  Lemma exists_return A (x : A) :
    exists s : nat, semProd (returnGen x) x.
  Proof.
    exists 0. eapply (@semReturn G _ ProducerSemanticsGen); reflexivity.
  Qed.

  Lemma exists_bind_Sized_alt A B
        (g : nat -> G B) (f : B -> nat -> G A)
        (x : A) (z : B) (s' : nat) :
    SizedMonotonic g ->
    (forall s, SizeMonotonic (g s)) ->

    (forall a, SizedMonotonic (f a)) ->
    (forall a s, SizeMonotonic (f a s)) ->

    semProd (g s') z ->
    (exists s, semProd (f z s) x) ->  
    exists s : nat, semProd (bindGen (g s) (fun x => f x s)) x.
  Proof.
    intros Hs Hs' Hsf Hsf' Hprod Hex. inv Hex. inv Hprod.
    inv H. destruct H0.
    exists (Nat.max s' x0). inv H1.
    exists (Nat.max x1 x2).
    
    split. reflexivity.
    
    eapply (@semBindSize G ProducerGen _ B A).

    eexists. split.
    eapply Hs > [ | eapply Hs' > [ | eassumption ] ]. ssromega. ssromega.

    eapply Hsf > [ | eapply Hsf' > [ | eassumption ] ]. ssromega. ssromega.
  Qed.

  Lemma semProd_mon {A} (g : nat -> G A) {_ : SizedMonotonic g} :
    forall s1 s2,
      (s1 <= s2)%coq_nat ->
      semProd (g s1) \subset semProd (g s2).
  Proof.
    intros s1 s2 Hleq.
    intros x Hin. inv Hin. inv H0.
    eexists x0. split; eauto.
    eapply H > [ | eassumption ].
    destruct (leqP s1 s2); eauto.
  Qed.


  Lemma exists_gen_hd A (g : nat -> G (option A)) (gs : nat -> list (nat * G (option A))) x n : 
    (exists s, semProdOpt (g s) x) ->
    exists s, semProdOpt (backtrack ((S n, g s) :: gs s)) x.
  Proof.
    intros [s He].
    exists s.
    eapply (@backtrack_correct_opt A).
    eexists. split. split. now left. simpl. lia. eassumption.
  Qed.

  Lemma exists_gen_tl A (g : nat -> G (option A)) (gs : nat -> list (nat * G (option A))) x n : 
    (exists s, semProdOpt (backtrack (gs s)) x) ->
    exists s, semProdOpt (backtrack ((n, g s) :: gs s)) x.
  Proof.
    intros [s He].
    exists s.
    eapply (@backtrack_correct_opt A).
    eapply (@backtrack_correct_opt A) in He. destruct He as [z [Hin Hsem]].
    inv Hin. eexists. split. split. now right; eauto. eassumption. eassumption.
  Qed.


  Lemma exists_bind_Opt A B (x : A) (g : G B) (f : B -> nat -> G (option A)) z :
    Correct B g ->
    SizeMonotonic g ->
    (forall a s, SizeMonotonicOpt (f a s)) ->

    (exists s, semProdOpt (f z s) x) ->  
    exists s : nat, semProdOpt (bindGen g (fun x => f x s)) x.
  Proof.
    intros Hc Hs1 Hs2 He. inv He. inv H. inv H0.
    inv H.
    assert (Hin : [set : B] z) by reflexivity.
    eapply Hc in Hin. inv Hin. inv H.
    exists x0, (Nat.max x1 x2). split. reflexivity.
    eapply (@semBindSize G ProducerGen _ B).
    eexists. split.

    eapply Hs1 > [ | eassumption ]. now ssromega.
    eapply Hs2 > [ | eassumption ]. now ssromega.
  Qed.

  Lemma exists_return_Opt A (x : A) :
    exists s : nat, semProdOpt (returnGen (Some x)) x.
  Proof.
    exists 0. eapply (@semReturn G _ ProducerSemanticsGen); reflexivity.
  Qed.

  Lemma exists_bindOpt_Opt A B (x : A) (g : G (option B)) (f : B -> nat -> G (option A)) z :
    SizeMonotonicOpt g ->
    (forall a s, SizeMonotonicOpt (f a s)) ->

    semProdOpt g z ->
    (exists s, semProdOpt (f z s) x) ->  
    exists s : nat, semProdOpt (bindOpt g (fun x => f x s)) x.
  Proof.
    intros Hc Hs1 Hs2 He. destruct He as [s1 He].
    exists s1.
    eapply (@semOptBindOpt G _ _ B); eauto with typeclass_instances.

    eexists. split; eassumption.
  Qed.

  Lemma exists_bindOpt_Opt_Sized A B (x : A) (g : nat -> G (option B)) (f : B -> nat -> G (option A)) z :
    SizedMonotonicOpt g ->
    (forall s, SizeMonotonicOpt (g s)) ->

    (forall a, SizedMonotonicOpt (f a)) ->
    (forall a s, SizeMonotonicOpt (f a s)) ->

    (exists s, semProdOpt (g s) z) ->
    (exists s, semProdOpt (f z s) x) ->  
    exists s : nat, semProdOpt (bindOpt (g s) (fun z => f z s)) x.
  Proof.
    intros Hs1 Hs1' Hs2 Hs2' Hg Hf. destruct Hg as [s1 He].
    destruct Hf.
    exists (max x0 s1).
    eapply (@semOptBindOpt G _ _ B); eauto with typeclass_instances.
    inv He. inv H. inv H0. inv H1. 
    eexists. split. 
    eexists. split. reflexivity.
    eapply Hs1 > [ | eassumption ]. ssromega.
    eexists. split. reflexivity.
    eapply Hs2 > [ | eassumption ]. ssromega.  
  Qed.

  

  Lemma exists_match_DecOpt {B} P {_ : DecOpt P} (k : nat -> G (option B)) z :
    DecOptSizeMonotonic P ->
    DecOptCompletePos P -> 
    SizedMonotonicOpt k ->
    P ->
    (exists s, semProdOpt (k s) z) ->
    exists (s : nat),
      semProdOpt (match decOpt s.+1 with
                  | Some true => k s
                  | _ => returnGen None
                  end) z.
  Proof.
    intros Hmon Hcom Hmonk Hp [s1 [s [_ He]]].
    eapply Hcom in Hp. destruct Hp as [s2 Hdec].
    eexists (max s1 s2).
    eapply Hmon in Hdec. rewrite Hdec.

    eexists. split. reflexivity. eapply Hmonk > [ | eassumption ].
    ssromega. ssromega.
  Qed.

  Lemma semProdSizeOpt_semProdOpt {A} {G : Type -> Type} {_ : Producer G} (e1 e2 : G (option A)) :
    (forall s, semProdSizeOpt e1 s \subset semProdSizeOpt e2 s) ->
    semProdOpt e1 \subset semProdOpt e2.
  Proof.
    intros H x Hin. inv Hin. inv H0. eexists. split; eauto. eapply H. eassumption.
  Qed. 

  Lemma incl_bigcup_compat_list_pair (T K U : Type) (h1 h2 : T) (t1 : list T)
        (t2 : list (K * T)) (F : T -> set U) (G : K * T -> set U) k :
    F h1 \subset G (k, h2) ->
    \bigcup_(x in t1) F x \subset \bigcup_(x in t2) G x ->
    \bigcup_(x in h1 :: t1) F x \subset \bigcup_(x in (k, h2) :: t2) G x.
  Proof.
    intros Hs1 Hs2.
    intros x Hin. inv Hin. inv H. inv H0.
    - eexists. split. now left. eauto.
    - edestruct Hs2.
      eexists. split; eauto.
      destruct H0. eexists. split. now right; eauto.
      eassumption.
  Qed.

End Lemmas.

(** Examples *)

(** ** Enum **)

Ltac2 simpl_minus_arbitrarySized (_ : unit) :=
  ltac1:(with_strategy opaque [arbitrarySized] simplstar).

Ltac2 simpl_arbitrarySized (_ : unit) :=
  unfold arbitrarySized; simpl_minus_arbitrarySized (). 

(*** Sized Monotonicity *)

Ltac2 rec gen_sized_mon (ih : ident) :=
  first
    [ (* ret *)
      guarded_subset_refl ()
    | (* bind *)
    eapply (@semBindSize_subset_compat _ _ ProducerSemanticsGen) >
    [ let x := Fresh.in_goal (id_of_string "x") in
      intros $x;
    first
      [ now eapply subset_refl (* for calls to enum *)
      | let ih' := Control.hyp ih in (* for recursive calls *)
        eapply $ih'; now ssromega ]
    | let x := Fresh.in_goal (id_of_string "x") in
      let s := Fresh.in_goal (id_of_string "s") in
      intros $x $s; gen_sized_mon ih
    ]
    ].

Ltac2 rec find_gen (_ : unit) :=
  first
    [ now eapply incl_bigcup_list_nil
    | eapply incl_bigcup_compat_list_pair > [ now eapply subset_refl  | find_gen () ]
    | eapply incl_bigcup_list_hd; now eapply subset_refl
    | eapply incl_bigcup_list_tl; find_gen ()
    ].


Ltac2 base_case_size_mon (_ : unit) :=
  destruct s2 > 
  [ guarded_subset_refl () | simpl_arbitrarySized (); first [ guarded_subset_refl ()
                                                            | rewrite !&Hone, !&Hfreq; now find_gen () ] ]. 

Ltac2 rec gens_sized_mon (ih : ident) :=
  first
    [ now eapply incl_bigcup_list_nil
    | eapply incl_bigcup_compat_list > [ now gen_sized_mon @IHs1 | gens_sized_mon ih ] ].

Ltac2 ind_case_sized_mon (_ : unit) :=
  destruct s2 > 
  [ now ssromega | simpl_arbitrarySized (); first [ now gen_sized_mon @IHs1
                                                  | rewrite !&Hfreq; now gens_sized_mon @IHs1 ] ]. 


Ltac2 derive_gen_SizedMonotonic (_ : unit) :=
    assert (Hone := @semOneofSize G _ ProducerSemanticsGen);
    
    match! goal with
    | [ |- @SizedMonotonic ?t _ _ (@arbitrarySized _ ?inst) ] =>
      assert (Hfreq := (@semFrequencySize $t));
      (intros s s1; revert s; induction s1 as [| s1 IHs1 ];
      intros s s2 Hleq) > [ now base_case_size_mon () | now ind_case_sized_mon () ]
    end. 


(* Size Mon *)

Ltac2 rec gen_size_mon (ih : ident) :=
  first
    [ (* ret *)
      eapply returnGenSizeMonotonic; tci
    | (* bind *)
      eapply bindMonotonic >
      [ tci
      | first
          [ now find_size_mon_inst ()  (* for calls to enum *)
          | let ih' := Control.hyp ih in (* for recursive calls *)
            eapply $ih'; now ssromega ]
      | let x := Fresh.in_goal (id_of_string "x") in
        intros $x; gen_size_mon ih
      ]
    ].

Ltac2 rec gens_size_mon (t : constr) (ih : ident) :=
  first
    [ now eapply (@list_subset_nil (G $t))
    | eapply (@list_subset_cons (G $t)) > 
      [ now gen_size_mon ih
      | gens_size_mon t ih ] ]. 

Ltac2 rec gens_size_mon_pair (t : constr) (ih : ident) :=
  first
    [ now eapply (@list_subset_nil (nat * G $t))
    | eapply (@list_subset_cons (nat * G $t)) >
      [ now gen_size_mon ih
      | gens_size_mon_pair t ih ] ].

Ltac2 derive_gen_SizeMonotonic (_ : unit) :=
  intros s;
    match! goal with
    | [ |- @SizeMonotonic ?t _ _ _ ] =>
      induction s as [ | s IHs ];
        simpl_arbitrarySized ();
        first [ eapply oneofMonotonic >  
                [ tci
                | now gen_size_mon @IHs
                | now gens_size_mon t @IHs ]
              | now gen_size_mon @IHs
              | eapply (@frequencySizeMonotonic_alt $t) >  
                [ now gen_size_mon @IHs
                | now gens_size_mon_pair t @IHs ] ]
    end.


(* Correct *)

Ltac2 find_corr_inst (_ : unit) :=
  first [ tci
        | match! goal with
          | [ |- Correct ?ty (sizedGen arbitrarySized) ] =>
            eapply (@GenCorrectOfSized $ty _) >
            [ tci
            | now find_size_mon_inst ()
            | tci ]
          end ].

Ltac2 solve_sized_mon (hs : ident) :=
  intros ? ? ? ? ?; now gen_sized_mon hs.      

Ltac2 solve_size_mon (hs : ident) :=
  intros ? ?; now gen_size_mon hs.      


Ltac2 rec gen_size_correct (_ : unit) :=
  first
    [ (* return *)
      now eapply exists_return; eauto
                                  
    | (* bind non rec *)
      match! goal with
      |  [ |- exists _ : nat, semProd (bindGen (* enum *) _ _) _ ] => 
         eapply exists_bind > [ now find_corr_inst ()
                              | now find_size_mon_inst ()
                              | now solve_size_mon @Hsize
                              | now eexists; gen_size_correct () ]
      end
    | (* bind rec *)
      match! goal with
      | [|- exists z, semProd (bindGen (_ _) _) _  ] =>
        eapply exists_bind_Sized_alt >
        [ tci
        | now find_size_mon_inst ()
        | now solve_sized_mon @Hsized
        | now solve_size_mon @Hsize
        |
        | now gen_size_correct () ]; eassumption
      end
    ]. 


Ltac2 rec try_solve_correct (_ : unit) :=
  first
    [ eapply exists_freq_hd; now gen_size_correct ()
    | eapply exists_freq_tl; try_solve_correct ()
    ].

Ltac2 derive_gen_Correct (_ : unit) := 
  match! goal with
  | [ |- @CorrectSized ?typ _ _ ?en ] =>  
    simpl_enumSized ();
    match! goal with
    | [ |- @CorrectSized _ _ _ ?gen_simpl ] =>
      (* get the enum body *)
      set (_aux_gen := ltac2:(exact $gen_simpl));
      let hsize := Fresh.in_goal (id_of_string "Hsize") in
      let hsized := Fresh.in_goal (id_of_string "Hsized") in
      let ind := Fresh.in_goal (id_of_string "t") in
      (* Derive monotonicity instances *)
      assert ($hsized : SizedMonotonic $en) > [ tci | ];
      assert ($hsize : forall s, SizeMonotonic ($en s)) > [ tci | ];
      econstructor; intro $ind; split > [ intro; exact I | intros _ ];
      let ind' := Control.hyp ind in
      induction $ind'; eapply exists_Sn; repeat (destructIH ()); simpl_arbitrarySized ();
      first [ gen_size_correct () | try_solve_correct () ]
    end
  end.


(* GenST *)


Ltac2 simpl_minus_arbitrarySizeST (_ : unit) :=
  ltac1:(with_strategy opaque [arbitrarySizeST arbitrary decOpt] simplstar).

Ltac2 simpl_arbitrarySizeST (_ : unit) :=
  unfold arbitrarySizeST; simpl_minus_arbitrarySizeST (). 

(*** Sized monotonic *) 

Lemma incl_bigcup_compat_list_P (T U : Type) (h1 h2 : T) (t1 t2 : list T) (F G : T -> set U) (P : T -> Prop) :
    F h1 \subset G h2 ->
    P h1 -> P h2 ->
    \bigcup_(x in t1 :&: P) F x \subset \bigcup_(x in t2 :&: P) G x ->
    \bigcup_(x in (h1 :: t1) :&: P) F x \subset \bigcup_(x in (h2 :: t2) :&: P) G x.
Proof.
  intros Hs1 Hp1 Hp2 Hs2.
  intros x Hin. inv Hin. inv H. inv H0. inv H.
  - eexists. split. constructor. now left. eauto. eauto.
  - edestruct Hs2.
    eexists. split; eauto.
    split. eassumption. eassumption. inv H. inv H3. 
    eexists. split. constructor. now right; eauto.
    eassumption. eassumption.
Qed.

Lemma incl_bigcup_list_nil_P (T U : Type) (G : T -> set U) s (P : T -> Prop) :
    \bigcup_(x in [::] :&: P) G x \subset s.
Proof. 
  intros x Hin. inv Hin. inv H. inv H0. inv H.
Qed.

Lemma incl_bigcup_list_tl_P (T U : Type) (h : T) (t : list T) (G : T -> set U) s (P : T -> Prop) :
    s \subset \bigcup_(x in t :&: P) G x ->
    s \subset \bigcup_(x in (h :: t) :&: P) G x.
Proof.
  intros Hyp x Hin. eapply Hyp in Hin.
  inv Hin. inv H. inv H0.
  eexists. split. split. now right; eauto. eauto. eauto.
Qed.

Lemma in_bigcup_list_tl_P (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) (P : T -> Prop) :
  (\bigcup_(x in t :&: P) G x) z -> (\bigcup_(x in (h :: t) :&: P) G x) z.
Proof.
  intros Hin. destruct Hin. inv H. inv H0.
  eexists. split. split. right. eassumption. eassumption. eassumption. 
Qed.

Lemma in_bigcup_list_cons_P (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U)  (P : T -> Prop) :
  (\bigcup_(x in ((h :: t) :&: P)) G x) z ->
  G h z /\ P h \/ (\bigcup_(x in t :&: P) G x) z.
Proof.
  intros Hin. inv Hin. inv H. inv H0; eauto. inv H; eauto.
  right. eexists; split; eauto. split; eauto.
Qed.

Lemma bigcup_nil_set0_P (T U : Type) (F : T -> set U) (P : T -> Prop) : 
  \bigcup_(x in [::] :&: P) F x <--> set0.
Proof.
  split; intros Hin; inv Hin; eauto.
  inv H. inv H0. inv H.
Qed.


Ltac2 rec genST_sized_mon (ih : ident) :=
  first
    [ (* ret *)
      guarded_subset_refl ()
    | (* dec matching *)
      match! goal with
      | [ |- semProdSizeOpt (match @decOpt ?p ?i ?s1 with _ => _ end) _ \subset
             semProdSizeOpt (match decOpt ?s2 with _ => _ end) _ ] =>
        let hdec := Fresh.in_goal (id_of_string "Hdec") in 
        destruct (@decOpt $p $i $s1) eqn:$hdec >
        [ ((erewrite (@CheckerProofs.mon $p $i _ $s1 $s2) > [ | | first [ eassumption | ssromega ] ]) > [ genST_sized_mon ih | ssromega ])
        | rewrite (@semReturnSizeOpt_None G _ ProducerSemanticsGen); now eapply sub0set ]
      end
     | (* input matching *) 
      match! goal with
      | [ |- semProdSizeOpt (match ?p with _ => _ end) _ \subset _ ] =>
        destruct $p; genST_sized_mon ih
      end
    | (* bindOpt *)
      eapply (@semBindOptSizeOpt_subset_compat G _ ProducerSemanticsGen) >
      [ first
          [ now eapply subset_refl (* for calls to gen *)
          | let ih' := Control.hyp ih in (* for recursive calls *)
            eapply $ih'; now ssromega ]
      | let x := Fresh.in_goal (id_of_string "x") in
        intros $x; genST_sized_mon ih
      ]
    | (* bind *)
      eapply (@semBindSizeOpt_subset_compat G _ ProducerSemanticsGen) >
      [ now eapply subset_refl 
      | let x := Fresh.in_goal (id_of_string "x") in
        intros $x; genST_sized_mon ih
      ]
    | ()
    ].

Ltac2 rec find_genST (ih : ident) :=
  first
    [ now eapply incl_bigcup_list_nil_P
    | eapply incl_bigcup_compat_list_P >
      [ simpl_minus_arbitrarySizeST (); now genST_sized_mon ih | simpl; ssromega | simpl; ssromega  | find_genST ih ]
    | eapply incl_bigcup_list_tl_P; find_genST ih
    ].

Ltac2 base_case_st_size_mon (s2 : constr) :=
  destruct $s2 > 
  [ first [ guarded_subset_refl () | rewrite !backtrack_correct_size_opt; simpl_minus_arbitrarySizeST (); find_genST @dummy ]
  | rewrite !backtrack_correct_size_opt; find_genST @dummy ]. 

Ltac2 ind_case_st_sized_mon (s2 : constr) (ih : ident) :=
  destruct $s2 > 
  [ now ssromega |  rewrite !backtrack_correct_size_opt; simpl_minus_arbitrarySizeST (); find_genST ih ]. 

Ltac2 derive_genST_SizedMonotonic (_ : unit) :=
  match! goal with
  | [ |- SizedMonotonicOpt (@arbitrarySizeST ?typ ?pred ?inst) ] =>
      
    let s := Fresh.in_goal (id_of_string "s") in
    let s1 := Fresh.in_goal (id_of_string "s1") in
    let s2 := Fresh.in_goal (id_of_string "s2") in
    let s1i := Fresh.in_goal (id_of_string "s1i") in
    let s2i := Fresh.in_goal (id_of_string "s2i") in
    let hleq := Fresh.in_goal (id_of_string "Hleq") in
    let hleqi := Fresh.in_goal (id_of_string "Hleqi") in
    let ihs1 := Fresh.in_goal (id_of_string "ihs1") in
    intros $s $s1 $s2 $hleq; simpl_arbitrarySizeST ();
      let hleq' := Control.hyp hleq in
      let s1' := Control.hyp s1 in
      let s2' := Control.hyp s2 in
      assert ($hleqi := $hleq');
      revert $hleqi $hleq;
      generalize $s2' at 1 3; generalize $s1' at 1 3; revert $s $s2; EnumProofs.revert_params pred;
        (induction $s1' as [| $s1 $ihs1 ]; EnumProofs.intro_params pred; intros $s $s2 $s1i $s2i $hleqi $hleq) >
        [ base_case_st_size_mon s2' | ind_case_st_sized_mon s2' ihs1 ]
  end.



(* Size Monotonicity *)


Ltac2 rec genST_size_mon (ih : ident) :=
  first
    [ (* ret *)
      eapply returnGenSizeMonotonicOpt; tci
    | (* bindOpt *)
      eapply bindOptMonotonicOpt >
      [ tci
      | first
          [ (* for calls to gen in params *)
            tci
          | (* for call to existing gen instances. XXX not sure why typeclass resulotion doesn't work *)
            eapply sizedSizeMonotonicOpt; tci 
          | (* for recursive calls *)
             let ih' := Control.hyp ih in 
            eapply $ih' ]
      | let x := Fresh.in_goal (id_of_string "x") in
        intros $x; genST_size_mon ih
      ]
    | (* bind *)
      eapply bindMonotonicOpt >
      [ tci
      | first
          [ (* for calls to gen in params *)
            tci 
          | (* for call to existing gen instances. XXX not sure why typeclass resulotion doesn't work *)
            eapply sizedSizeMonotonic; tci 
          | (* for recursive calls *)
             let ih' := Control.hyp ih in 
            eapply $ih' ]
      | let x := Fresh.in_goal (id_of_string "x") in
        intros $x; genST_size_mon ih
      ]
    | (* input/dec matching *)
      match! goal with
      | [ |- SizeMonotonicOpt (match ?p with _ => _ end) ] =>
        destruct $p; genST_size_mon ih
      end
    | ()
    ].

Ltac2 rec gensST_size_mon (t : constr) (ih : ident) :=
  first
    [ now eapply (@list_subset_nil (nat * G (option $t)))
    | eapply (@list_subset_cons (nat * G (option $t))) > 
      [ simpl_minus_arbitrarySizeST (); genST_size_mon @ih
      | gensST_size_mon t ih ] ]. 


Ltac2 derive_genST_SizeMonotonic (_ : unit) :=
  let s := Fresh.in_goal (id_of_string "s") in
  let ihs := Fresh.in_goal (id_of_string "Ihs") in
  let si := Fresh.in_goal (id_of_string "si") in
  intro $s;
  let s' := Control.hyp s in 

  match! goal with
  | [ |- SizeMonotonicOpt (@arbitrarySizeST ?typ ?pred ?inst _) ] =>   
    simpl_arbitrarySizeST (); generalize $s' at 1; EnumProofs.revert_params pred;
    induction $s' as [ | $s $ihs ]; EnumProofs.intro_params pred; intros $si;
    eapply backtrack_SizeMonotonicOpt; gensST_size_mon typ @IHs
  end.


(* Correctness *)

Definition empty_gen {A} : G (option A) := MkGen (fun _ _ => None).

Ltac2 make_semGen (t : constr) (enum : constr) (s : constr) :=
  let c := constr:(@semProdSizeOpt G _ ltac2:(exact $t) empty_gen ltac2:(exact $s)) in
  match Constr.Unsafe.kind c with
  | Constr.Unsafe.App sem sargs => 
    let sargs' := Array.copy sargs in
    let _ := Array.set sargs' 3 enum in
    Constr.Unsafe.make (Constr.Unsafe.App sem sargs')
  | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application"))))
  end.


Ltac2 mon_expr (tapp : constr) (inst : constr) :=
  match! goal with
  | [ |- CorrectSizedST _ ?f ] =>
    match Constr.Unsafe.kind f with
    | Constr.Unsafe.Lambda b app =>
      match Constr.Unsafe.kind app with
      | Constr.Unsafe.App aux args =>

        let len := Int.sub (Array.length args) 2 in
        let inps := Array.sub args 2 len in

        let args' (s1 : constr) (s2 : constr) (offs : int) :=
            let ind := Array.mapi (fun i _ => Constr.Unsafe.make (Constr.Unsafe.Rel (Int.add i offs))) inps in
            let a := Array.make 2 s1 in
            Array.set a 1 s2; Array.append a ind
        in

        let aux_app s1 s2 offs := Constr.Unsafe.make (Constr.Unsafe.App aux (args' s1 s2 offs)) in


        (* SizeMonotonic *) 
        let dummy_app s1 s2 :=
            let args' := Array.copy args in
            let _ := Array.set args' 0 s1 in
            let _ := Array.set args' 1 s1 in
            Constr.Unsafe.make (Constr.Unsafe.App aux args')
        in

        let dummy_term := constr:(SizeMonotonicOpt (ltac2:(let t := dummy_app '0 '0 in exact $t))) in

        let make_term s1 s2 :=
            match Constr.Unsafe.kind dummy_term with
            | Constr.Unsafe.App mon margs =>
              let margs' := Array.copy margs in
              Array.set margs' 3 (aux_app s1 s2 1);
              make_prod inps (Constr.Unsafe.make (Constr.Unsafe.App mon margs'))
            | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application"))))
            end
        in 
        
        assert (_Hmon : forall (_s1 _s2 : nat), ltac2:(let s1 := Control.hyp @_s1 in
                                                      let s2 := Control.hyp @_s2 in
                                                      let t := make_term s1 s2  in exact $t)) >
        [  let s := Fresh.in_goal (id_of_string "s") in 
           let si := Fresh.in_goal (id_of_string "si") in 
           let ihs := Fresh.in_goal (id_of_string "IHs") in 
           intros $si $s;
           let s' := Control.hyp s in revert $si;
           induction $s' as [ | $s $ihs ]; intros $si;
           Array.iter (fun _ => intro) inps; eapply backtrack_SizeMonotonicOpt; now gensST_size_mon tapp ihs
        | ];

        (* SizedMonotonic, generalized *)          
        let subset (t1 : constr) (t2 : constr) :=
            let dummy := constr:(set_incl (@set0 (ltac2:(exact $tapp))) set0) in
            match Constr.Unsafe.kind dummy with
            | Constr.Unsafe.App sub sargs =>
              let sargs' := Array.copy sargs in
              let _ := Array.set sargs' 1 t1 in
              let _ := Array.set sargs' 2 t2 in
              Constr.Unsafe.make (Constr.Unsafe.App sub sargs')
            | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application"))))
            end
        in
        let mon s1 s2 s1' s2' s :=
            make_prod inps (subset (make_semGen tapp (aux_app s1' s1 1) s) (make_semGen tapp (aux_app s2' s2 1) s))
        in
        
        (* print_constr (mon '1 '2 '3 '4); set (s := ltac2:(let t := mon '1 '2 '3 '4 in exact $t)); () *)
                                                                                      
        assert (_Hmons : forall (s1 s2 s2' s1' s: nat), (s1 <= s2)%coq_nat -> (s1' <= s2')%coq_nat ->
                                                       ltac2:(let s1 := Control.hyp @s1 in
                                                              let s1' := Control.hyp @s1' in
                                                              let s2 := Control.hyp @s2 in
                                                              let s2' := Control.hyp @s2' in 
                                                              let s' := Control.hyp @s in 
                                                              let t := mon s1 s2 s1' s2' s' in exact $t)) >
        [ let s1 := Fresh.in_goal (id_of_string "s1") in
          let s2 := Fresh.in_goal (id_of_string "s2_") in
          let ihs1 := Fresh.in_goal (id_of_string "ihs1") in
          intros $s1; simpl_arbitrarySizeST ();
          let s1' := Control.hyp s1 in
          (induction $s1' as [| $s1 $ihs1 ]; intros $s2 ? ? ? ? ? ; Array.iter (fun _ => intro) inps) >
          [ let s2' := Control.hyp s2 in base_case_st_size_mon s2' | let s2' := Control.hyp s2 in ind_case_st_sized_mon s2' ihs1 ]
        | ]
    | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application"))))
    end
  | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a function"))))
  end
end.



Ltac2 rec genST_sound (ty : constr) (ih : ident) :=    
  match! goal with
  (* match decOpt *) 
  | [ h : semProdOpt (match @decOpt ?p ?i ?s with _ => _ end) ?x |- _ ] =>
    let hdec := Fresh.in_goal (id_of_string "Hdec") in 
    let b := Fresh.in_goal (id_of_string "b") in 
    destruct (@decOpt $p $i $s) as [ $b | ] eqn:$hdec > [ | now eapply (@semReturnOpt_None G _ _) in $h; inv $h ];
    let b' := Control.hyp b in                                                            
    destruct $b' > [ | now eapply (@semReturnOpt_None G _ _) in $h; inv $h ];
    eapply (@CheckerProofs.sound $p) in $hdec > [ | tci ]; genST_sound ty ih

 (* match input *) 
  | [ h : semProdOpt (match ?n with _ => _ end) ?x |- _ ] =>
    destruct $n; try (now eapply (@semReturnOpt_None G _ _) in $h; inv $h); genST_sound ty ih
  | (* return *)
    [ h : semProdOpt (returnGen _) _ |- _ ] =>
    eapply (@semReturnOpt G _ _) in $h; inv $h;  now (pose $ty; eauto 20)
  | (* bindOpt *)
    [ h : semProdOpt (bindOpt _ _) _ |- _ ] =>
    eapply (@semOptBindOpt G _ _) in $h >
                                     [ let h' := Control.hyp h in
                                       (* let x := Fresh.in_goal (id_of_string "_x") in *)
                                       (* let hin1 := Fresh.in_goal (id_of_string "_Hin1") in *)
                                       (* let hin2 := Fresh.in_goal (id_of_string "_Hin2") in *)
                                       (* XXX there seems to be a bug in fresh, and it fails to freshen after a while.
                                         P     icking ? for now *) 
                                       destruct $h' as [? [$h ?]];
                                        
                                       first [ let ih' := Control.hyp ih in eapply $ih' in $h
                                             | match! goal with
                                               | [h : semProdOpt (sizedGen (@arbitrarySizeST ?t ?pred ?inst)) _ |- _ ] =>
                                                 eapply (@SuchThatCorrectOfBounded $t $pred $inst) in $h > [ | tci | tci | tci ]
                                               end ];
                                       genST_sound ty ih
                                     | find_size_mon_inst ()
                                     | intro; now genST_size_mon @Hmon ]


  | (* bind *)
    [ h : semProdOpt (bindGen _ _) _ |- _ ] =>
    eapply (@semOptBind G _ _) in $h >
                                  [ let h' := Control.hyp h in
                                    destruct $h' as [? [? ?]]; genST_sound ty ih
                                  | find_size_mon_inst ()
                                  | intro; now genST_size_mon @Hmon ]

  | [ |- _ ] => ()
  end.

Ltac2 rec sound_gens (ty : constr) (ih : ident) :=
  match! goal with
  | [ h : (\bigcup_(x in ((seq_In (_ :: _)) :&: _)) _) _ |- _ ] =>
    eapply in_bigcup_list_cons_P in $h; simpl_minus_arbitrarySizeST ();
    let h' := Control.hyp h in
    destruct $h' as [ [? ?] | ] > [ genST_sound ty ih | sound_gens ty ih  ]
  | [ h : (\bigcup_(x in seq_In Datatypes.nil :&: _) _) _ |- _ ] =>
    apply bigcup_nil_set0_P in $h; inv $h
  end. 

Ltac2 derive_sound_genST (ty : constr) (pred : constr) :=
  let s := Fresh.in_goal (id_of_string "s") in
  let si := Fresh.in_goal (id_of_string "si") in
  let ihs := Fresh.in_goal (id_of_string "ihs") in
  let hgen := Fresh.in_goal (id_of_string "Hgen") in
  intros [$s $hgen]; revert $hgen;

  let s' := Control.hyp s in

  match! goal with
    [ |- semProdOpt _ ?x -> _ ] => 
    (generalize $s' at 1; EnumProofs.revert_params pred; revert x; induction $s' as [ | $s $ihs]; intro;
     EnumProofs.intro_params pred;
     intros $si $hgen;
     eapply &Hback in $hgen) > [ sound_gens ty ihs | sound_gens ty ihs  ]
  end.

Ltac2 rec genST_complete (ty : constr):=
  let hmons := Control.hyp @_Hmons in
  first
    [ (* return *)
      subst; now eapply exists_return_Opt
    | (* match decOpt for eq *)
      (eapply (@exists_match_DecOpt $ty) > [ | | | ltac1:(now eapply Logic.eq_refl) | genST_complete ty ]) >
      [ (* decOpt mon *) tci
      | (* decOpt complete *) tci
      | (* sizedMon *) intros ? ? ? ?; genST_sized_mon @_Hmons
      | genST_complete ty ]
    | (* match decOpt *)
      (eapply (@exists_match_DecOpt $ty) > [ | | | | genST_complete ty ]) >
      [ (* decOpt mon *) tci
      | (* decOpt complete *) tci
      | (* sizedMon *) intros ? ? ? ?; genST_sized_mon @_Hmons
      | (* P *) now eauto ]
    | (* bindOpt rec call *)
      (eapply exists_bindOpt_Opt_Sized > [ | | | | | now genST_complete ty ]) >
      [ (* sizedMon *)
        intro; intros; eapply $hmons; ssromega
      | (* sizeMon *) now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now genST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; genST_size_mon @_Hmon
      | eexists; eexists; split > [ reflexivity
                                  | eapply $hmons > [ eapply Peano.le_n | | eassumption ]; ssromega ]
      ]
    | (* bindOpt sized eq *)
      eapply exists_bindOpt_Opt_Sized >
      [ tci
      | intros _; now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now genST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; genST_size_mon @_Hmon
      | match! goal with
      | [ |- exists _, semProdOpt (sizedGen (@arbitrarySizeST ?t ?pred ?inst)) _ ] =>
        exists 0; eapply (@size_CorrectST $t $pred G _ _) > [ | | | ltac1:(now eapply Logic.eq_refl) ]; tci
        end
      | now genST_complete ty
      ]
    | (* bindOpt sized *)
      (eapply exists_bindOpt_Opt_Sized > [ | | | | | now genST_complete ty ]) >
      [ tci
      | intros _; now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now genST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; genST_size_mon @_Hmon
      | match! goal with
      | [ |- exists _, semProdOpt (sizedGen (@arbitrarySizeST ?t ?pred ?inst)) _ ] =>
        exists 0; eapply (@size_CorrectST $t $pred G _ _) > [ | | | eassumption ]; tci
        end
      ]
    | (* bind *)
      match! goal with
      |  [ |- exists _ : nat, semProdOpt (bindGen arbitrary _) _ ] =>
         eapply exists_bind_Opt >
         [ tci
         | now find_size_mon_inst ()
         | intros ? ?; genST_size_mon @_Hmon | now genST_complete ty ]
      end

    | ( ) ].

Ltac2 rec try_solve_complete (ty : constr) :=
  first [ eapply exists_gen_hd; now genST_complete ty 
        | eapply exists_gen_tl; try_solve_complete ty ].


Ltac2 derive_complete_genST (ty : constr) (inst : constr) := 
  let ind := Fresh.in_goal (id_of_string "ind") in 
  intros $ind; let ind' := Control.hyp ind in induction $ind';
  eapply exists_Sn; repeat (destructIH_opt ()); try_solve_complete ty. 


Ltac2 derive_genST_Correct (_ : unit) := 
  match! goal with
  | [ |- CorrectSizedST _ (@arbitrarySizeST ?tapp ?pred ?inst) ] =>
    assert (Hback := @backtrack_correct_opt $tapp);
      
    simpl_arbitrarySizeST ();

    (* derive monotonicity *) 
    mon_expr tapp inst;

    let ty := get_ty pred in
    let x := Fresh.in_goal (id_of_string "x") in
    split; intros $x; split >
      [ derive_sound_genST ty pred | derive_complete_genST tapp inst  ]
  end.



(* Ltac tactics *)
Ltac derive_gen_SizeMonotonic := ltac2:(derive_gen_SizeMonotonic ()).
Ltac derive_gen_SizedMonotonic :=  ltac2:(derive_gen_SizedMonotonic ()).
Ltac derive_gen_Correct := ltac2:(derive_gen_Correct ()).


Ltac derive_genST_SizeMonotonic := ltac2:(derive_genST_SizeMonotonic ()).
Ltac derive_genST_SizedMonotonic :=  ltac2:(derive_genST_SizedMonotonic ()).
Ltac derive_genST_Correct := ltac2:(derive_genST_Correct ()).
