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

Set Warnings "-notation-overwritten, -parsing".
From mathcomp Require Import ssrnat eqtype seq.
Set Bullet Behavior "Strict Subproofs".

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

Section Lemmas. 

  Lemma semProdSizeOpt_bicupNone A s (S : set A) :
    \bigcup_(x in [:: returnEnum (@None A)]) semProdSizeOpt x s \subset S.
  Proof.
    intros x Hin. inv Hin. inv H. inv H0.
    - inv H1. congruence.
      inv H.
    - inv H.
  Qed.

  Lemma list_subset_cons {A} (h : A) (t : seq A) (s : set A)  :
    s h ->
    t \subset s ->
    (h :: t) \subset s.
  Proof.
    intros H1 H2 x Hin. inv Hin; eauto.
  Qed.

  Lemma list_subset_nil {A} (s : set A)  :
    [::] \subset s.
  Proof. intros x Hin. inv Hin. Qed.


  Lemma exists_oneOf_hd A (x : A) g' (g : nat -> E A) (l : nat -> seq (E 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 -> E A) (l : nat -> seq (E 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_bind A B (x : A) (g : E B) (f : nat -> B -> E 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 (bindEnum 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 E ProducerEnum _ 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 (returnEnum x) x.
  Proof.
    exists 0. eapply (@semReturn E _ ProducerSemanticsEnum); reflexivity.
  Qed.

  Lemma exists_bind_Sized_alt A B
        (g : nat -> E B) (f : B -> nat -> E 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 (bindEnum (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 E ProducerEnum _ 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 -> E 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_enum_hd A (g : nat -> E (option A)) (gs : nat -> list (E (option A))) x : 
    (exists s, semProdOpt (g s) x) ->
    exists s, semProdOpt (enumerate (g s :: gs s)) x.
  Proof.
    intros [s He].
    exists s.
    eapply (@enumerate_correct_opt A).
    eexists. split. now left. eassumption.
  Qed.

  Lemma exists_enum_tl A (g : nat -> E (option A)) (gs : nat -> list (E (option A))) x : 
    (exists s, semProdOpt (enumerate (gs s)) x) ->
    exists s, semProdOpt (enumerate (g s :: gs s)) x.
  Proof.
    intros [s He].
    exists s.
    eapply (@enumerate_correct_opt A).
    eapply (@enumerate_correct_opt A) in He. destruct He as [z [Hin Hsem]].
    eexists. split. now right; eauto. eassumption.
  Qed.


  Lemma exists_bind_Opt A B (x : A) (g : E B) (f : B -> nat -> E (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 (bindEnum 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 E ProducerEnum _ 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 (returnEnum (Some x)) x.
  Proof.
    exists 0. eapply (@semReturn E _ ProducerSemanticsEnum); reflexivity.
  Qed.

  Lemma exists_bindOpt_Opt A B (x : A) (g : E (option B)) (f : B -> nat -> E (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 E _ _ B); eauto with typeclass_instances.

    eexists. split; eassumption.
  Qed.

  Lemma exists_bindOpt_Opt_Sized A B (x : A) (g : nat -> E (option B)) (f : B -> nat -> E (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 E _ _ 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 -> E (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
                  | Some false => failEnum
                  | None => returnEnum 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 exists_match_DecOpt_neg {B} P {_ : DecOpt P} (k : nat -> E (option B)) z :
    DecOptSizeMonotonic P ->
    DecOptCompleteNeg P -> 
    SizedMonotonicOpt k ->
    ~ P ->
    (exists s, semProdOpt (k s) z) ->
    exists (s : nat),
      semProdOpt (match decOpt s.+1 with
                  | Some false => k s
                  | Some true => failEnum
                  | None => returnEnum 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 : E (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. 


  Global Instance SizeMonotonicOpt_failEnum A :
    @SizeMonotonicOpt A E _ failEnum.
  Proof.
    intros s1 s2 Hleq.
    eapply subset_refl.
  Qed.

  Lemma semProdOpt_failEnum A :
    semProdOpt failEnum <--> (@set0 A). 
  Proof.
    intro x; split; intros H1.
    inv H1. inv H. now inv H1.
    now inv H1. 
  Qed.

  Lemma semProdOpt_return_None {A} :
    semProdOpt (returnEnum None) <--> (@set0 A).
  Proof.
    intro x; split; intro H; inv H.
    inv H0. inv H1. congruence. inv H0.
  Qed.

  Lemma SizeMonotonicOptFP_proof A (g : nat -> E (option A)) :
    (forall s s1 s2,
        (s1 <= s2)%coq_nat ->
        (* monotonic Opt *) 
        (semProdSizeOpt (g s1) s \subset semProdSizeOpt (g s2) s) /\
        (* sizeFP *)
        (~ semProdSize (g s1) s None ->
         semProdSize (g s1) s <--> semProdSize (g s2) s) /\
        (* Antimonotonic None *) 
        (isNone :&: semProdSize (g s2) s \subset isNone :&: semProdSize (g s1) s)) ->
    SizedMonotonicOptFP g.
  Proof.
    intros H. constructor.
    intro; intros. eapply H; eauto. 
    intro; intros. eapply H; eauto. 
    intro; intros. eapply H; eauto. 
  Qed.

End Lemmas.

Ltac2 guarded_subset_refl (_ : unit) :=
  match! goal with
  | [ |- ?s \subset ?s ] => now eapply subset_refl
  end.

(** ** Enum **)

Ltac2 simpl_minus_enumSized (_ : unit) :=
  ltac1:(with_strategy opaque [enumSized] simplstar).

Ltac2 simpl_enumSized (_ : unit) :=
  unfold enumSized; simpl_minus_enumSized (). 


Ltac2 find_size_mon_inst (_ : unit) :=
  first [ tci
        | eapply sizedSizeMonotonicOpt; tci
        | eapply sizedSizeMonotonic; tci ].

(*** Sized Monotonicity *)

Ltac2 rec enum_sized_mon (ih : ident) :=
  first
    [ (* ret *)
      guarded_subset_refl ()
    | (* bind *)
    eapply (@semBindSize_subset_compat _ _ ProducerSemanticsEnum) >
    [ 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; enum_sized_mon ih
    ]
    ].

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


Ltac2 base_case_size_mon (_ : unit) :=
  destruct s2 > 
  [ guarded_subset_refl () | simpl_enumSized (); first [ guarded_subset_refl ()
                                                       | rewrite !&Hone; now find_enum () ] ]. 


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

Ltac2 ind_case_sized_mon (_ : unit) :=
  destruct s2 > 
  [ now ssromega | simpl_enumSized (); first [ now enum_sized_mon @IHs1
                                             | rewrite !&Hone; now enums_sized_mon @IHs1 ] ]. 


Ltac2 derive_enum_SizedMonotonic (_ : unit) :=
    assert (Hone := @semOneofSize E _ ProducerSemanticsEnum);
    
    match! goal with
    | [ |- @SizedMonotonic ?t _ _ (@enumSized _ ?inst) ] =>
      (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 monotonicity *) 

Ltac2 rec enum_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; enum_size_mon ih
      ]
    ].

Ltac2 rec enums_size_mon (t : constr) (ih : ident) :=
  first
    [ now eapply (@list_subset_nil (E $t))
    | eapply (@list_subset_cons (E $t)) > 
      [ now enum_size_mon ih
      | enums_size_mon t ih ] ]. 

Ltac2 derive_enum_SizeMonotonic (_ : unit) :=
  intros s;
    match! goal with
    | [ |- @SizeMonotonic ?t _ _ _ ] =>
      induction s as [ | s IHs ];
        simpl_enumSized ();
        first [ eapply oneofMonotonic >  
                [ tci
                | now enum_size_mon @IHs
                | now enums_size_mon t @IHs ]
              | now enum_size_mon @IHs ]
    end.

(*** Correct *) 

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

Ltac2 solve_sized_mon (hs : ident) :=
  (* let t := Fresh.in_goal (id_of_string "t") in *)
  (* 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 hleq := Fresh.in_goal (id_of_string "Hleq") in *)
  intros ? ? ? ? ?; now enum_sized_mon hs.      

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

Ltac2 if_exists tac :=
  match! goal with
  | [|- exists s, semProd _ _ ] => tac
  end.

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

Ltac2 destructIH (_ : unit) :=
  match! goal with
  | [ h : (exists s, semProd _ _) |- _ ] =>
    let h' := Control.hyp h in destruct $h'
  end.


Ltac2 rec try_solve_correct (_ : unit) :=
  first
    [ eapply exists_oneOf_hd; now enum_size_correct ()
    | eapply exists_oneOf_tl; try_solve_correct ()
    ].

Ltac2 derive_enum_Correct (_ : unit) := 
  match! goal with
  | [ |- @CorrectSized ?typ _ _ ?en ] =>  
    simpl_enumSized ();
    match! goal with
    | [ |- @CorrectSized _ _ _ ?en_simpl ] =>
      (* get the enum body *)
      set (_aux_enum := ltac2:(exact $en_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_enumSized ();
      first [ enum_size_correct () | try_solve_correct () ]
    end
  end.


(** ** EnumST **) 


Ltac2 simpl_minus_enumSizeST (_ : unit) :=
  ltac1:(with_strategy opaque [enumSizeST enum decOpt enumSizeST] simplstar).

Ltac2 simpl_enumSizeST (_ : unit) :=
  unfold enumSizeST; simpl_minus_enumSizeST (). 

Ltac2 get_ty (e : constr) :=
  match Constr.Unsafe.kind e with
  | Constr.Unsafe.Lambda b app =>
    match Constr.Unsafe.kind app with
    | Constr.Unsafe.App ty args  => ty
    | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application"))))
    end
  | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a function"))))
  end.

Ltac2 get_args (pred : constr) :=
  match Constr.Unsafe.kind pred with
  | Constr.Unsafe.Lambda b app =>
    match Constr.Unsafe.kind app with
    | Constr.Unsafe.App ty args  =>
      List.filter (fun x =>
                     match Constr.Unsafe.kind x with
                     | Constr.Unsafe.Rel _ => (* the arg we are enumeting *)
                       false
                     | Constr.Unsafe.Var _ => (* other args *) 
                       true
                     | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Internal error : args must be free or bound vars"))))
                     end) (Array.to_list args)
                           
    | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting an application"))))
    end
  | _ => Control.throw (Tactic_failure (Some (Message.of_string ("Expecting a function"))))
  end.

Ltac2 revert_params (pred : constr) :=
  let args := get_args pred in 
  let l := constrs_to_idents args in
  List.iter (fun x => try (revert $x)) l. 

Ltac2 intro_params (pred : constr) :=
  let args := get_args pred in 
  let l := constrs_to_idents args in
  List.iter (fun x => try (intro $x)) (List.rev l).


          
(*** Sized monotonic *) 

Ltac2 rec enumST_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 ] ]) > [ enumST_sized_mon ih | ssromega ])
        | rewrite (@semReturnSizeOpt_None E _ ProducerSemanticsEnum); now eapply sub0set ]
      end
     | (* input matching *) 
      match! goal with
      | [ |- semProdSizeOpt (match ?p with _ => _ end) _ \subset _ ] =>
        destruct $p; enumST_sized_mon ih
      end
    | (* bindOpt *)
      eapply (@semBindOptSizeOpt_subset_compat E _ ProducerSemanticsEnum) >
      [ 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
        intros $x; enumST_sized_mon ih
      ]
    | (* bind *)
      eapply (@semBindSizeOpt_subset_compat E _ ProducerSemanticsEnum) >
      [ now eapply subset_refl 
      | let x := Fresh.in_goal (id_of_string "x") in
        intros $x; enumST_sized_mon ih
      ]
    | ()
    ].

Ltac2 rec find_enumST (ih : ident) :=
  first
    [ now eapply incl_bigcup_list_nil
    | now eapply semProdSizeOpt_bicupNone
    | eapply incl_bigcup_compat_list > [ (now enumST_sized_mon ih)  | find_enumST ih ]
    | eapply incl_bigcup_list_tl; find_enumST ih
    ].

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

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

Ltac2 derive_enumST_SizedMonotonic (_ : unit) :=
  match! goal with
  | [ |- SizedMonotonicOpt (@enumSizeST ?typ ?pred ?inst) ] =>
    (* assert (Henum := @enumerate_correct_size $typ); *)
      
    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_enumSizeST ();
      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; revert_params pred;
        (induction $s1' as [| $s1 $ihs1 ]; intro_params pred; intros $s $s2 $s1i $s2i $hleqi $hleq) >
        [ base_case_st_size_mon s2' | ind_case_st_sized_mon s2' ihs1 ]
  end.


Ltac2 rec enumST_antimon (ih : ident) :=
  first
    [ (* ret *)
      guarded_subset_refl ()
    | (* dec matching *)
      match! goal with
      | [ |- _ :&: semProdSize (match @decOpt _ _ ?s2 with _ => _ end) _ \subset
             _ :&: semProdSize (match  @decOpt ?p ?i ?s1 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 ] ]) >
          [ enumST_antimon ih | ssromega ]
        |  now eapply semProdSize_return_None  ]
    end
  | (* input matching *)
    match! goal with
    | [ |- _ :&: semProdSize (match ?p with _ => _ end) _ \subset _ ] =>
      destruct $p; enumST_antimon ih
    end
 | (* bindOpt *)
    eapply semBindOptSize_isNone_subset_compat >
    [ first
        [ intros; now eapply subset_refl (* for calls to enum *)
        | let ih' := Control.hyp ih in (* for recursive calls *)
          eapply $ih'; now ssromega ]
    | first
        [ intros; 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
      intros $x; enumST_antimon ih
    ]
    (* | (* bind *) *)
    (*   eapply (@semBindSizeOpt_subset_compat E _ ProducerSemanticsEnum) > *)
    (*   [ now eapply subset_refl *)
    (*   | let x := Fresh.in_goal (id_of_string "x") in *)
    (*     intros $x; enumST_sized_mon ih *)
    (*   ] *)
 | () ].

Ltac2 rec base_case_antimon (_ : unit) :=
  match! goal with
  | [|- ?s1 :&: ?s2 \subset ?s3 :&: (@bigcup ?t ?u (seq_In (cons _ (cons _ _))) ?g)] =>
    eapply (@incl_bigcup_list_tl_inter $t $u); base_case_antimon ()
   | [|- _ \subset _  :&: (@bigcup ?t ?u (seq_In (cons _ nil)) _)] =>
     eapply semProdSize_bigcup_isNone
end.

Ltac2 rec ind_case_antimon (ih : ident) :=
  match! goal with
  | [|- ?s1 :&: ?s2 \subset ?s3 :&: (@bigcup ?t ?u (@seq_In _ (@nil _)) _)] =>
    now eapply subset_refl
  | [|- ?s1 :&: ?s2 \subset ?s3 :&: (@bigcup ?t ?u _ _)] =>
    eapply (@incl_bigcup_compat_list_inter $t $u) > [ enumST_antimon ih | ind_case_antimon ih ]
  end.

Ltac2 rec base_case_fp (_ : unit) :=
  match! goal with
  | [|- (@bigcup ?t ?u (seq_In (cons _ (cons _ _))) ?g) _] =>
    eapply (@in_bigcup_list_tl $t $u); base_case_fp ()
   | [|- (@bigcup ?t ?u (seq_In (cons _ nil)) _) _] =>
     eapply in_bigcup_list_hd; eapply semReturnSizeEnum; reflexivity
end.

Ltac2 rewrite_eqs (eqs: constr list) :=
  List.iter (fun eq => try (rewrite $eq)) eqs.


Ltac2 rec pick_enum (cnt : int) :=
  if Int.equal cnt 0 then
    (eapply in_bigcup_list_hd)
  else
    (eapply in_bigcup_list_tl; pick_enum (Int.sub cnt 1)).

Ltac2 rec find_none (eqs : constr list) (binds : constr list) :=
  first
    [ (* ret *)
      eapply semReturnSizeEnum; reflexivity
    | (* dec matching *) 
      match! goal with
      | [ |- semEnumSize (match  @decOpt ?p ?i ?s1 with _ => _ end) _ _ ] =>
        rewrite_eqs eqs; simpl_minus_methods (); find_none eqs binds
      end
    (* | (* input matching *) () *)
      (* match! goal with *)
      (* | [ |- _ :&: semProdSize (match ?p with _ => _ end) _ \subset _ ] => *)
      (*   destruct $p; enumST_antimon ih *)
      (* end *)
    | (* bindOpt *)
      first
        [ eapply semProdSize_bindOpt_1; eassumption 
        | eapply semProdSize_bindOpt_2 > [ let h := List.hd binds in eapply $h
                                         | simpl_minus_methods (); find_none eqs (List.tl binds) ] ] 
    | ()
    ].

Ltac2 rec solve_ih_hyp (hnin : constr) (cnt : int) (typ : constr) (eqs : constr list) (binds : constr list) :=
  let hc := Fresh.in_goal (id_of_string "Hc") in intros $hc;
  eapply $hnin; eapply (@enumerate_correct_size' $typ);
  pick_enum cnt; simpl_minus_methods (); find_none eqs binds.

Ltac2 rec enumST_fp (ih : constr) (hnin: constr) (cnt : int) (typ : constr) (eqs : constr list) (binds : constr list) :=
  first
    [ (* ret *)
      reflexivity
    | (* dec matching *)
      match! goal with
      | [ |- semEnumSize (match @decOpt ?p ?i ?s1 with _ => _ end) _ <-->
             semEnumSize (match @decOpt _ _ ?s2 with _ => _ end) _ ] =>
        let hdec := Fresh.in_goal (id_of_string "Hdec") in
        (* destruct decOpt *)
        destruct (@decOpt $p $i $s1) eqn:$hdec (* ; simpl_minus_methods () *) >
        [ (* is Some *)
          (erewrite (@CheckerProofs.mon $p $i _ $s1 $s2) > [ | | first [ eassumption | ssromega ] ]) >
          [ let hdec := Control.hyp hdec in enumST_fp ih hnin cnt typ (hdec :: eqs) binds | ssromega ]
        | (* is None *)
          let hdec := Control.hyp hdec in
          exfalso; eapply $hnin;
          match! goal with
          | [ |- semEnumSize (enumerate ?lst) ?s _ ] =>
            eapply (@enumerate_correct_size' _ $lst $s); pick_enum cnt; find_none (hdec :: eqs) (List.rev binds)
          end        
        ]
      end
    | (* input matching *)
      match! goal with
      | [ |-  semEnumSize (match ?p with _ => _ end) _ <--> _ ] =>
        destruct $p; simpl_minus_methods (); enumST_fp ih hnin cnt typ eqs binds
      end
    | (* bindOpt *)
       (eapply semBindOptSize_subset_compat_eq; simpl_minus_methods ()) >
       [ first [ eapply $ih > [ lia |  lia | solve_ih_hyp hnin cnt typ eqs (List.rev binds) ]
               | reflexivity ]
       | let x := Fresh.in_goal (id_of_string "x") in
         let hin := Fresh.in_goal (id_of_string "Hin") in intros $x $hin;
         let hin := Control.hyp hin in
         enumST_fp ih hnin cnt typ eqs (hin :: binds)
       ]  
    | ()
    ].

Ltac2 rec ind_case_fp (ih : constr) (hnin : constr) (cnt : int) (typ : constr) :=
  match! goal with
  | [|- (@bigcup ?t ?u (seq_In (cons _ _)) ?g) <--> _] =>
    eapply incl_bigcup_compat_list_eq >
    [ simpl_minus_methods (); enumST_fp ih hnin cnt typ [] [] | ind_case_fp ih hnin (Int.add cnt 1) typ ]
  | [|- (@bigcup ?t ?u (seq_In nil)) _ <--> _ ] =>
    reflexivity
  end.

Ltac2 derive_enumST_SizedMonotonicFP (_ : unit) :=
  match! goal with
  | [ |- SizedMonotonicOptFP (@enumSizeST ?typ ?pred ?inst) ] => 
    eapply SizeMonotonicOptFP_proof;
    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_enumSizeST (); 
    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 5 7; generalize $s1' at 1 3 5 7 9;
    revert $s $s2; revert_params pred;

    (induction $s1' as [| $s1 $ihs1 ]; intro_params pred; intros $s $s2 $s1i $s2i $hleqi $hleq) >
                      [ (* base cases *)
                        split >
                        [ | split ] >
                          [ (* mon *)
                            now base_case_st_size_mon s2'
                          | (* fp *)
                            let hnin := Fresh.in_goal (id_of_string "hnin") in
                            intros $hnin;
                            first [ destruct $s2'; reflexivity
                                  | exfalso;
                                    let hnin' := Control.hyp hnin in eapply $hnin';
                                    eapply (@enumerate_correct_size' $typ); base_case_fp ()
                                  | let hnin' := Control.hyp hnin in
                                    let dummy := Control.hyp hnin in
                                    (* XXX says not focused when using ; after destruct *)
                                    destruct $s2'>  [ rewrite !enumerate_correct_size';
                                                      ind_case_fp dummy hnin' 0 typ
                                                    | rewrite !enumerate_correct_size';
                                                      ind_case_fp dummy hnin' 0 typ ] ]
                                  (* | () ] *)
                          | (* antimon *)
                            first [ destruct $s2'; now eapply subset_refl
                                  | rewrite !enumerate_correct_size'; now base_case_antimon ()
                                  | destruct $s2' >
                                    [ rewrite !enumerate_correct_size'; ind_case_antimon @dummy | rewrite !enumerate_correct_size'; ind_case_antimon @dummy ]
]
                          ]
                      | (* inuctive cases *)
                        split >
                        [ | split ] >
                          [ (* mon *)
                            ind_case_st_sized_mon s2' ihs1
                          | (* fp *)
                            let hnin := Fresh.in_goal (id_of_string "hnin") in
                            intros $hnin;
                            destruct $s2' >
                            [ lia | let hnin' := Control.hyp hnin in
                                    let ihs1' := Control.hyp ihs1 in
                                    rewrite !enumerate_correct_size'; now ind_case_fp ihs1' hnin' 0 typ ]
                          | (* antimon *)
                            destruct $s2' >
                            [ lia | rewrite !enumerate_correct_size'; ind_case_antimon ihs1 ]
                          ]
                      ]
end.

(* Size Monotonicity *) 
 
Ltac2 rec enumST_size_mon (ih : ident) :=
  first
    [ (* fail *)
      eapply SizeMonotonicOpt_failEnum; tci
    | (* ret *)
      eapply returnGenSizeMonotonicOpt; tci
    | (* bindOpt *)
      eapply bindOptMonotonicOpt >
      [ tci
      | first
          [ (* for calls to enum in params *)
            tci
          | (* for call to existing enum 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; enumST_size_mon ih
      ]
    | (* bind *)
      eapply bindMonotonicOpt >
      [ tci
      | first
          [ (* for calls to enum in params *)
            tci 
          | (* for call to existing enum 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; enumST_size_mon ih
      ]
    | (* input/dec matching *)
      match! goal with
      | [ |- SizeMonotonicOpt (match ?p with _ => _ end) ] =>
        destruct $p; enumST_size_mon ih
      end
    | ()
    ].

Ltac2 rec enumsST_size_mon (ih : ident) (t : constr) :=
  first
    [ now eapply (@list_subset_nil (E (option $t)))
    | eapply (@list_subset_cons (E (option $t))) > 
      [ enumST_size_mon ih
      | enumsST_size_mon ih t ] ]. 


Ltac2 derive_enumST_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 (@enumSizeST ?typ ?pred ?inst _) ] =>   
    simpl_enumSizeST (); generalize $s' at 1; revert_params pred;
    induction $s' as [ | $s $ihs ]; intro_params pred; intros $si;
    eapply enumerate_SizeMonotonicOpt; enumsST_size_mon @IHs typ
  end.


(* Size Monotonicity + FP *) 

                                                           
Ltac2 rec enumST_size_fp (ih : ident) (typ : constr) :=
  first
    [ (* ret *)
      eapply returnGenSizeFP; tci
    | (* fail *)
      eapply (@SizeFP_failEnum $typ)
    | (* bindOpt.  *)
      match! goal with
       |[|- SizeFP (@bindOpt _ _ ?a ?b _ _) ] =>
        eapply (@bindOptSizeFP $a $b) >
        [ first
            [ tci
            | eapply sizedSizeFP; tci
            | let ih' := Control.hyp ih in
              eapply $ih' ]
        | let x := Fresh.in_goal (id_of_string "x") in
          intros $x; enumST_size_fp ih typ ]
      end
    | (* input/dec matching *)
      match! goal with
      | [ |- SizeFP (match ?p with _ => _ end) ] =>
        destruct $p; enumST_size_fp ih typ
      end
    | ()
    ].

Ltac2 rec enumsST_size_fp (ih : ident) (t : constr) :=
  first
    [ now eapply (@list_subset_nil (E (option $t)))
    | eapply (@list_subset_cons (E (option $t))) > 
      [ enumST_size_fp ih t
      | enumsST_size_fp ih t ] ]. 

Ltac2 derive_enumST_SizeMonotonicFP (_ : 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
  | [ |- SizeMonotonicOptFP (@enumSizeST ?typ ?pred ?inst _) ] =>   
    simpl_enumSizeST (); generalize $s' at 1; revert_params pred;
    (induction $s' as [ | $s $ihs ]; intro_params pred; intros $si;
    eapply enumerate_SizeMonFP) >
    [ enumsST_size_fp ihs typ | enumsST_size_mon ihs typ
    | enumsST_size_fp ihs typ  | enumsST_size_mon ihs typ ]
  end.

(** Correctness *)


(* TODO duplicate *)

Ltac2 make_prod (bs : constr array) (c : constr) :=
  let bs := Array.map (fun b => let t := Constr.type b in
                                Constr.Binder.make (Some (constr_to_ident b)) t) bs in
  
  Array.fold_left (fun t b => Constr.Unsafe.make (Constr.Unsafe.Prod b t)) c bs.


(* To derive monotonicity inside the correctness proof *)



Ltac2 rec enumST_sound (ty : constr) (ih : ident) :=
  match! goal with
  (* match decOpt pos *)
  | [ 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 enumST_sound ty ih (* return None *) ];
    let b' := Control.hyp b in
    destruct $b' > [ | now eapply semProdOpt_failEnum in $h; inv $h ];
    eapply (@CheckerProofs.sound $p) in $hdec > [ | tci ]; enumST_sound ty ih
  (* match decOpt neg *)
  | [ 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 enumST_sound ty ih (* return None *) ];
    let b' := Control.hyp b in
    destruct $b' > [ now eapply semProdOpt_failEnum in $h; inv $h | ];
    eapply (@CheckerProofs.sound_neg $p) in $hdec > [ | tci ]; enumST_sound ty ih
  (* match input *)
  | [ h : semProdOpt (match ?n with _ => _ end) ?x |- _ ] =>
    destruct $n; try (now eapply semProdOpt_failEnum in $h; inv $h); enumST_sound ty ih
  (* return Some *)   
  | [ h : semProdOpt (returnEnum (Some _)) _ |- _ ] =>
    eapply (@semReturnOpt E _ _) in $h; inv $h; first [ now (pose $ty; eauto) | now (pose $ty; eauto 20) ]
  (* return None*)   
  | [ h : semProdOpt (returnEnum (@None ?a)) _ |- _ ] =>
    eapply (@semProdOpt_return_None $a) in $h; inv $h
  (* fail *)    
  | [ h : semProdOpt failEnum _ |- _ ] =>
    eapply semProdOpt_failEnum in $h; inv $h 
  (* bindOpt *)    
  | [ h : semProdOpt (bindOpt _ _) _ |- _ ] =>
    eapply (@semOptBindOpt E _ _) in $h >
                                     [ let h' := Control.hyp h in
                                       destruct $h' as [? [$h ?]];
                                       first [ let ih' := Control.hyp ih in eapply $ih' in $h
                                             | match! goal with
                                               | [h : semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ |- _ ] =>
                                                 eapply (@SuchThatCorrectOfBoundedEnum $t $pred $inst) in $h > [ | tci | tci | tci ]
                                               end                     
                                             | match! goal with
                                               | [h : semProdOpt enum _ |- _ ] => clear $h
                                               end ]; enumST_sound ty ih
                                     | find_size_mon_inst ()
                                     | intro; now enumST_size_mon @Hmon ]
  (* bind *)  
  | [ h : semProdOpt (bindEnum _ _) _ |- _ ] =>
    eapply (@semOptBind E _ _) in $h >
                                  [ let h' := Control.hyp h in
                                    destruct $h' as [? [? ?]]; enumST_sound ty ih
                                  | find_size_mon_inst ()
                                  | intro; now enumST_size_mon @Hmon ]

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

Ltac2 rec sound_enums (ty : constr) (ih : ident) :=
  match! goal with
  | [ h : (\bigcup_(x in (seq_In (_ :: _))) _) _ |- _ ] =>
    eapply in_bigcup_list_cons in $h;
    let h' := Control.hyp h in
    destruct $h' as [ | ] > [ enumST_sound ty ih | sound_enums ty ih  ]
  | [ h : (\bigcup_(x in seq_In Datatypes.nil) _) _ |- _ ] =>
    apply bigcup_nil_set0 in $h; inv $h
  end. 

Ltac2 derive_sound_enumST (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; revert_params pred; generalize $x; induction $s' as [ | $s $ihs]; intro;
     intro_params pred;
     intros $si $hgen;
     eapply &Henum in $hgen) > [ sound_enums ty ihs | sound_enums ty ihs  ]
  end.

Definition empty_enum {A} : E (option A) := MkEnum (fun _ => LazyList.lnil).

Ltac2 make_semEnum (t : constr) (enum : constr) (s : constr) :=
  let c := constr:(@semProdSizeOpt E _ ltac2:(exact $t) empty_enum 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 enumerate_SizeMonotonicOpt; now enumsST_size_mon ihs tapp
        | ];

        (* 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_semEnum tapp (aux_app s1' s1 1) s) (make_semEnum tapp (aux_app s2' s2 1) s))
        in
                                                                                             
        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_enumSizeST ();
          let s1' := Control.hyp s1 in
          (induction $s1' as [| $s1 $ihs1 ]; intros $s2 ? ? ? ? ? ; Array.iter (fun _ => intro) inps) >
          [ let s2' := Control.hyp s2 in EnumProofs.base_case_st_size_mon s2'
          | let s2' := Control.hyp s2 in EnumProofs.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 destructIH_opt (_ : unit) :=
  match! goal with
  | [ h : (exists s, semProdOpt _ _) |- _ ] =>
    let h' := Control.hyp h in destruct $h' as [ ? $h]; destruct $h' as [? [? $h]]
  end.



(* Ltac2 rec enumST_complete (ty : constr):= *)
(*   let hmons := Control.hyp @_Hmons in *)
(*   first *)
(*     [ (* return *)  *)
(*       now eapply exists_return_Opt *)
(*     | (* match decOpt *) *)
(*       (eapply (@exists_match_DecOpt $ty) > [ | | | | enumST_complete ty ]) >  *)
(*       [ (* decOpt mon *) now eauto with typeclass_instances *)
(*       | (* decOpt complete *) now eauto with typeclass_instances *)
(*       | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons  *)
(*       | (* P *) now eauto ] *)
(*     | (* bindOpt rec call *) *)
(*       (eapply exists_bindOpt_Opt_Sized > [ | | | | | enumST_complete ty ]) > *)
(*       [ (* sizedMon *)  *)
(*         intro; intros; eapply $hmons; ssromega *)
(*       | (* sizeMon *) now find_size_mon_inst () *)
(*       | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons *)
(*       | (* sizeMon *) intros ? ?; now enumST_size_mon @_Hmon *)
(*       | eexists; eexists; split > [ reflexivity *)
(*                                   | eapply $hmons > [ eapply Peano.le_n | | eassumption ]; ssromega ] ] *)
(*     | (* bindOpt sized *) *)
(*       (eapply exists_bindOpt_Opt_Sized > [ | | | | | enumST_complete ty ]) >  *)
(*       [ now eauto with typeclass_instances *)
(*       | intros _; now find_size_mon_inst () *)
(*       | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons *)
(*       | (* sizeMon *) intros ? ?; now enumST_size_mon @_Hmon *)
(*       | match! goal with *)
(*       | [ |- exists _, semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ ] => *)
(*         exists 0; eapply (@size_CorrectST $t $pred E _ _) > [ | | | eassumption ]; *)
(*         now eauto with typeclass_instances *)
(*         end ] *)
(*     | (* bind *) *)
(*       match! goal with *)
(*       |  [ |- exists _ : nat, semProdOpt (bindEnum enum _) _ ] =>  *)
(*          (eapply exists_bind_Opt > [ | | | enumST_complete ty ]) > *)
(*          [ now eauto with typeclass_instances *)
(*          | now find_size_mon_inst () *)
(*          | intros ? ?; now enumST_size_mon @_Hmon ] *)
(*       end *)

(*     | ( ) ].  *)

Ltac2 rec enumST_complete (ty : constr):=
  let hmons := Control.hyp @_Hmons in simpl_minus_methods ();
  first
    [ (* return *)
      subst; now eapply exists_return_Opt
    | (* match decOpt for eq *)
      (eapply (@exists_match_DecOpt $ty) > [ | | | ltac1:(now eapply Logic.eq_refl) | enumST_complete ty ]) >
      [ (* decOpt mon *) tci
      | (* decOpt complete *) tci
      | (* sizedMon *) intros ? ? ? ?; enumST_sized_mon @_Hmons
      | enumST_complete ty ]
    | (* match decOpt *)
      (eapply (@exists_match_DecOpt $ty) > [ | | | | enumST_complete ty ]) >
      [ (* decOpt mon *) tci
      | (* decOpt complete *) tci
      | (* sizedMon *) intros ? ? ? ?; enumST_sized_mon @_Hmons
      | (* P *) now eauto ]
    | (* match decOpt neg *)
      (eapply (@exists_match_DecOpt_neg $ty) > [ | | | | enumST_complete ty ]) >
      [ (* decOpt mon *) tci
      | (* decOpt complete *) tci
      | (* sizedMon *) intros ? ? ? ?; enumST_sized_mon @_Hmons
      | (* ~ P *) now eauto ]
    | (* bindOpt rec call *)
      (eapply exists_bindOpt_Opt_Sized > [ | | | | | now enumST_complete ty ]) >
      [ (* sizedMon *)
        intro; intros; eapply $hmons; ssromega
      | (* sizeMon *) now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon
      | eexists; eexists; split > [ reflexivity
                                  | eapply $hmons > [ eapply Peano.le_n | | eassumption ]; ssromega ]
      ]
    | (* bindOpt rec call alt *)
      eapply exists_bindOpt_Opt_Sized >
      [ (* sizedMon *)
        intro; intros; eapply $hmons; ssromega
      | (* sizeMon *) now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon
      | eexists; eexists; split > [ reflexivity
                                  | eapply $hmons > [ eapply Peano.le_n | | eassumption ]; ssromega ]
      | now enumST_complete ty ]
    | (* bindOpt sized eq *)
      eapply exists_bindOpt_Opt_Sized >
      [ tci
      | intros _; now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon
      | match! goal with
      | [ |- exists _, semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ ] =>
        exists 0; eapply (@size_CorrectST $t $pred E _ _) > [ | | | ltac1:(now eapply Logic.eq_refl) ]; tci
        end
      | now enumST_complete ty
      ]
    | (* bindOpt sized *)
      (eapply exists_bindOpt_Opt_Sized > [ | | | | | now enumST_complete ty ]) >
      [ tci
      | intros _; now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon
      | match! goal with
        | [ |- exists _, semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ ] =>
           exists 0; eapply (@size_CorrectST $t $pred E _ _) > [ | | | first [ eassumption | reflexivity ] ]; tci
        end
      ]
    | (* bindOpt sized simple *)
      (eapply exists_bindOpt_Opt_Sized > [ | | | | | now enumST_complete ty ]) >
      [ tci
      | intros _; now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon
      | match! goal with
        | [ |- exists _, semProdOpt enum _ ] =>
          exists 0; eapply enumOptCorrect > [ tci | reflexivity ]
        end
      ]
    | (* bindOpt sized alt *)
      eapply exists_bindOpt_Opt_Sized >
      [ tci
      | intros _; now find_size_mon_inst ()
      | (* sizedMon *) intros ? ? ? ? ?; now enumST_sized_mon @_Hmons
      | (* sizeMon *) intros ? ?; enumST_size_mon @_Hmon
      | match! goal with
      | [ |- exists _, semProdOpt (sizedEnum (@enumSizeST ?t ?pred ?inst)) _ ] =>
        exists 0; eapply (@size_CorrectST $t $pred E _ _) > [ | | | first [ eassumption | reflexivity ] ]; tci
        end
      | now enumST_complete ty
      ]
    | (* bind *)
      match! goal with
      | [ |- exists _ : nat, semProdOpt (bindEnum enum _) _ ] =>
         eapply exists_bind_Opt >
         [ tci
         | now find_size_mon_inst ()
         | intros ? ?; enumST_size_mon @_Hmon | now enumST_complete ty ]
           (* LTAC2 feature request branch grouping *)
      | [ |- exists _ : nat, semProdOpt (bindEnum (sizedEnum enumSized) _) _ ] =>
         eapply exists_bind_Opt >
         [ tci
         | now find_size_mon_inst ()
         | intros ? ?; enumST_size_mon @_Hmon | now enumST_complete ty ]
      end
    | ( ) ].


Ltac2 rec try_solve_complete (ty : constr) :=
  first [ eapply exists_enum_hd; now enumST_complete ty 
        | eapply exists_enum_tl; try_solve_complete ty ].

Ltac2 derive_complete_enumST (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_enumST_Correct (_ : unit) := 
  match! goal with
  | [ |- CorrectSizedST _ (@enumSizeST ?tapp ?pred ?inst) ] =>
    assert (Henum := @enumerate_correct_opt $tapp);
      
    simpl_enumSizeST ();

    (* 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_enumST ty pred | derive_complete_enumST tapp inst ]
  end.



(* Ltac tactics *)
Ltac derive_enum_SizeMonotonic := ltac2:(derive_enum_SizeMonotonic ()).
Ltac derive_enum_SizedMonotonic :=  ltac2:(derive_enum_SizedMonotonic ()).
Ltac derive_enum_Correct := ltac2:(derive_enum_Correct ()).


Ltac derive_enumST_SizeMonotonic := ltac2:(derive_enumST_SizeMonotonic ()).
Ltac derive_enumST_SizedMonotonic :=  ltac2:(derive_enumST_SizedMonotonic ()).
Ltac derive_enumST_Correct := ltac2:(derive_enumST_Correct ()).

Ltac derive_enumST_SizeMonotonicFP := ltac2:(derive_enumST_SizeMonotonicFP ()).
Ltac derive_enumST_SizedMonotonicFP :=  ltac2:(derive_enumST_SizedMonotonicFP ()).
