Include HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig.
(* end hide *)
End Atom.
(** We make [atom], [fresh], [fresh_not_in] and [atom_fresh_for_list] available without qualification. *)
Notation atom := Atom.atom.
Notation fresh := Atom.fresh.
Notation fresh_not_in := Atom.fresh_not_in.
Notation atom_fresh_for_list := Atom.atom_fresh_for_list.
(* Automatically unfold Atom.eq *)
Global Arguments Atom.eq /.
(** It is trivial to declare an instance of [EqDec] for [atom]. *)
Instance EqDec_atom : @EqDec atom eq eq_equivalence.
(* ********************************************************************** *)
(** * Tactic support for picking fresh atoms *)
(* begin hide *)
(** The auxiliary tactic [simplify_list_of_atom_sets] takes a list of finite sets of atoms and unions everything together, returning the resulting single finite set. *)
Ltac simplify_list_of_atom_sets L :=
let L := eval simpl in L in
let L := ltac_remove_dups L in
let L := eval simpl in (List.fold_right union empty L) in
match L with
| context C [union ?E empty] => context C [ E ]
end.
(* end hide *)
(** [gather_atoms_with F] returns the union of all the finite sets [F x] where [x] is a variable from the context such that [F x] type checks. *)
Ltac gather_atoms_with F :=
let apply_arg x :=
match type of F with
| _ -> _ -> _ -> _ => constr:(@F _ _ x)
| _ -> _ -> _ => constr:(@F _ x)
| _ -> _ => constr:(@F x)
end in
let rec gather V :=
match goal with
| H : _ |- _ =>
let FH := apply_arg H in
match V with
| context [FH] => fail 1
| _ => gather (union FH V)
end
| _ => V
end in
let L := gather empty in eval simpl in L.
(** [beautify_fset V] assumes that [V] is built as a union of finite sets and returns the same set cleaned up: empty sets are removed and items are laid out in a nicely parenthesized way. *)
Ltac beautify_fset V :=
let rec go Acc E :=
match E with
| union ?E1 ?E2 => let Acc2 := go Acc E2 in go Acc2 E1
| empty => Acc
| ?E1 => match Acc with
| empty => E1
| _ => constr:(union E1 Acc)
end
end
in go empty V.
(** The tactic [pick fresh Y for L] takes a finite set of atoms [L] and a fresh name [Y], and adds to the context an atom with name [Y] and a proof that [~ In Y L], i.e., that [Y] is fresh for [L]. The tactic will fail if [Y] is already declared in the context.  The variant [pick fresh Y] is similar, except that [Y] is fresh for "all atoms in the context."  This version depends on the tactic [gather_atoms], which is responsible for returning the set of "all atoms in the context."  By default, it returns the empty set, but users are free (and expected) to redefine it. *)
Ltac gather_atoms :=
constr:(empty).
Tactic Notation "pick" "fresh" ident(Y) "for" constr(L) :=
let Fr := fresh "Fr" in
let L := beautify_fset L in
(destruct (atom_fresh L) as [Y Fr]).
Tactic Notation "pick" "fresh" ident(Y) :=
let L := gather_atoms in
pick fresh Y for L.
Ltac pick_fresh y :=
pick fresh y.
(** Example: We can redefine [gather_atoms] to return all the "obvious" atoms in the context using the [gather_atoms_with] thus giving us a "useful" version of the "[pick fresh]" tactic. *)
Ltac gather_atoms ::=
let A := gather_atoms_with (fun x : atoms => x) in
let B := gather_atoms_with (fun x : atom => singleton x) in
constr:(union A B).

(* Specifications: *)
Lemma example_pick_fresh_use : forall (x y z : atom) (L1 L2 L3: atoms), True.