Module StateProdPosMap := FMapAVL.Make StateProdPosOrderedType.
(** Nullable predicate for symbols and list of symbols. **)
Definition nullable_symb (symbol:symbol) :=
match symbol with
| NT nt => nullable_nterm nt
| _ => false
end.
Definition nullable_word (word:list symbol) :=
forallb nullable_symb word.
(** First predicate for non terminal, symbols and list of symbols, given as FSets. **)
Definition first_nterm_set (nterm:nonterminal) :=
fold_left (fun acc t => TerminalSet.add t acc)
(first_nterm nterm) TerminalSet.empty.
Definition first_symb_set (symbol:symbol) :=
match symbol with
| NT nt => first_nterm_set nt
| T t => TerminalSet.singleton t
end.
Fixpoint first_word_set (word:list symbol) :=
match word with
| [] => TerminalSet.empty
| t::q =>
if nullable_symb t then
TerminalSet.union (first_symb_set t) (first_word_set q)
else
first_symb_set t
end.
(** Small helper for finding the part of an item that is after the dot. **)
Definition future_of_prod prod dot_pos : list symbol :=
(fix loop n lst :=
match n with
| O => lst
| S x => match loop x lst with [] => [] | _::q => q end
end)
dot_pos (rev' (prod_rhs_rev prod)).
(** We build a fast map to store all the items of all the states. **)
Definition items_map (_:unit): StateProdPosMap.t TerminalSet.t :=
fold_left (fun acc state =>
fold_left (fun acc item =>
let key := (state, prod_item item, dot_pos_item item) in
let data := fold_left (fun acc t => TerminalSet.add t acc)
(lookaheads_item item) TerminalSet.empty
in
let old :=
match StateProdPosMap.find key acc with
| Some x => x | None => TerminalSet.empty
end
in
StateProdPosMap.add key (TerminalSet.union data old) acc
) (items_of_state state) acc
) all_list (StateProdPosMap.empty TerminalSet.t).
(** We need to avoid computing items_map each time we need it. To that purpose, we declare a typeclass specifying that some map is equal to items_map. *)
Class IsItemsMap m := is_items_map : m = items_map ().
(** Accessor. **)
Definition find_items_map items_map state prod dot_pos : TerminalSet.t :=
match StateProdPosMap.find (state, prod, dot_pos) items_map with
| None => TerminalSet.empty
| Some x => x
end.
Definition state_has_future state prod (fut:list symbol) (lookahead:terminal) :=
exists dot_pos:nat,
fut = future_of_prod prod dot_pos /\
TerminalSet.In lookahead (find_items_map (items_map ()) state prod dot_pos).
(** Iterator over items. **)
Definition forallb_items items_map (P:state -> production -> nat -> TerminalSet.t -> bool): bool:=
StateProdPosMap.fold (fun key set acc =>
match key with (st, p, pos) => (acc && P st p pos set)%bool end
) items_map true.
(** Typeclass instances for synthetizing the validator. *)
Instance is_validator_subset S1 S2 :
IsValidator (TerminalSet.Subset S1 S2) (TerminalSet.subset S1 S2).
(* We do not declare this lemma as an instance, and use [Hint Extern] instead, because the typeclass mechanism has trouble instantiating some evars if we do not explicitely call [eassumption]. *)
Hint Extern 2 (IsValidator (state_has_future _ _ _ _) _) =>
eapply is_validator_state_has_future_subset; [eassumption|eassumption || reflexivity|]
: typeclass_instances.
(* As said previously, we manipulate lookahead terminal sets instead of lookahead individually. Hence, when we quantify over a lookahead set in the specification, we do not do anything in the executable validator.  This instance is used for [non_terminal_closed]. *)
Instance is_validator_forall_lookahead_set lset P b:
(forall lookahead, TerminalSet.In lookahead lset -> IsValidator (P lookahead) b) ->
IsValidator (forall lookahead, TerminalSet.In lookahead lset -> P lookahead) b.
Hint Extern 100 (IsValidator _ _) =>
match goal with
| H : TerminalSet.In ?lookahead ?lset |- _ =>
eapply (is_validator_iterate_lset _ (fun lookahead => _) _ _ H); clear H
end
: typeclass_instances.

(* We often quantify over all the items of all the states of the automaton. This lemma and the accompanying [Hint Resolve] declaration allow generating the corresponding executable validator.  Note that it turns out that, in all the uses of this pattern, the first thing we do for each item is pattern-matching over the future. This lemma also embbed this pattern-matching, which makes it possible to get the hypothesis [fut' = future_of_prod prod (S pos)] in the non-nil branch.  Moreover, note, again, that while the specification quantifies over lookahead terminals individually, the code provides lookahead sets instead. *)
Lemma is_validator_forall_items P1 b1 P2 b2 im :
IsItemsMap im ->
(forall st prod lookahead lset pos,
TerminalSet.In lookahead lset ->
[] = future_of_prod prod pos ->
IsValidator (P1 st prod lookahead) (b1 st prod pos lset)) ->
(forall st prod pos lookahead lset s fut',
TerminalSet.In lookahead lset ->
fut' = future_of_prod prod (S pos) ->
IsValidator (P2 st prod lookahead s fut') (b2 st prod pos lset s fut')) ->
IsValidator (forall st prod fut lookahead,
state_has_future st prod fut lookahead ->
match fut with
| [] => P1 st prod lookahead
| s :: fut' => P2 st prod lookahead s fut'
end)
(forallb_items im (fun st prod pos lset =>
match future_of_prod prod pos with
| [] => b1 st prod pos lset
| s :: fut' => b2 st prod pos lset s fut'
end)).