(* Generator of app-free well-typed terms of type tau *)
(* Generator of well-typed terms of type tau. [fst p] is the maximum number of applications *)
Program Fixpoint gen_term_size (p : nat * type) {wf lt_pair p} : env -> G term :=
fun (e : env) => (* apparently with this trick we get a more manageable term *)
match p with
| (0, tau) => gen_term_no_app tau e
| (S n', tau) =>
match vars_with_type e tau with
| [] =>
oneOf_ (gen_term_no_app tau e)
[ (do! tau' <- gen_type;
do! m <- choose (0, n');
do! m' <- choose (n' -  m, n');
liftGen2 App (@gen_term_size (n' - m, (Arrow tau' tau)) _ e)
(@gen_term_size (n' - m', tau') _ e));
(match tau with
| N => liftGen Const arbitrary
| Arrow tau1 tau2 =>
liftGen Abs (@gen_term_size (S n', tau2) _ (tau1 :: e))
end)]
| def :: vars =>
oneOf_ (gen_term_no_app tau e)
[ (do! tau' <- gen_type;
do! m <- choose (0, n');
do! m' <- choose (n' - m, n');
liftGen2 App (@gen_term_size (n' - m, (Arrow tau' tau)) _ e)
(@gen_term_size (n' - m', tau') _ e));
(match tau with
| N => liftGen Const arbitrary
| Arrow tau1 tau2 =>
liftGen Abs (@gen_term_size (S n', tau2) _ (tau1 :: e))
end);
elems_ def (def :: vars) ]
end
end.
Solve Obligations with
program_simpl; unfold lt_pair; apply left_lex; omega.
Solve Obligations with
program_simpl; unfold lt_pair; apply right_lex; unfold lt_type; simpl; omega.
Next Obligation.
unfold MR. apply wf_inverse_image. apply wf_lt_pair.
Defined.
Definition gen_term_size_unfold (p : nat * type) (e : env) : G term :=
match p with
| (0, tau) => gen_term_no_app tau e
| (S n', tau) =>
match vars_with_type e tau with
| [] =>
oneOf_ (gen_term_no_app tau e)
[ (do! tau' <- gen_type;
do! m <- choose (0, n');
do! m' <- choose (n' - m, n');
liftGen2 App (gen_term_size (n' - m, (Arrow tau' tau)) e)
(gen_term_size (n' - m', tau') e));
(match tau with
| N => liftGen Const arbitrary
| Arrow tau1 tau2 =>
liftGen Abs (@gen_term_size (S n', tau2) (tau1 :: e))
end)]
| def :: vars =>
oneOf_ (gen_term_no_app tau e)
[ (do! tau' <- gen_type;
do! m <- choose (0, n');
do! m' <- choose (n' - m, n');
liftGen2 App (gen_term_size (n' - m, (Arrow tau' tau)) e)
(@gen_term_size (n' - m', tau') e));
(match tau with
| N => liftGen Const arbitrary
| Arrow tau1 tau2 =>
liftGen Abs (gen_term_size (S n', tau2) (tau1 :: e))
end);
elems_ def (def :: vars) ]
end
end.

(* Specifications: *)
Lemma gen_term_size_eq (e : env) (p : nat * type) :
gen_term_size p e =
gen_term_size_unfold p e.