66bc3c796a
We also removed the notation (♯tac) since it is not needed anymore. @gebner, the comment at elaborator.cpp explains why you had to use the ♯ notation. The workaround is a little bit hackish, but I think it is worth it. We will use monad lifts in many different places.
92 lines
3.4 KiB
Text
92 lines
3.4 KiB
Text
/-
|
|
Copyright (c) 2016 Gabriel Ebner. All rights reserved.
|
|
Released under Apache 2.0 license as described in the file LICENSE.
|
|
Authors: Gabriel Ebner
|
|
-/
|
|
import .clause .prover_state
|
|
open tactic monad
|
|
|
|
namespace super
|
|
|
|
private meta def try_subsume_core : list clause.literal → list clause.literal → tactic unit
|
|
| [] _ := skip
|
|
| small large := first $ do
|
|
i ← small^.zip_with_index, j ← large^.zip_with_index,
|
|
return $ do
|
|
unify_lit i.1 j.1,
|
|
try_subsume_core (small^.remove_nth i.2) (large^.remove_nth j.2)
|
|
|
|
-- FIXME: this is incorrect if a quantifier is unused
|
|
meta def try_subsume (small large : clause) : tactic unit := do
|
|
small_open ← clause.open_metan small (clause.num_quants small),
|
|
large_open ← clause.open_constn large (clause.num_quants large),
|
|
guard $ small^.num_lits ≤ large^.num_lits,
|
|
try_subsume_core small_open.1^.get_lits large_open.1^.get_lits
|
|
|
|
meta def does_subsume (small large : clause) : tactic bool :=
|
|
(try_subsume small large >> return tt) <|> return ff
|
|
|
|
meta def does_subsume_with_assertions (small large : derived_clause) : prover bool := do
|
|
if small^.assertions^.subset_of large^.assertions then do
|
|
does_subsume small^.c large^.c
|
|
else
|
|
return ff
|
|
|
|
meta def any_tt {m : Type → Type} [monad m] (active : rb_map clause_id derived_clause) (pred : derived_clause → m bool) : m bool :=
|
|
active^.fold (return ff) $ λk a cont, do
|
|
v ← pred a, if v then return tt else cont
|
|
|
|
meta def any_tt_list {m : Type → Type} [monad m] {A} (pred : A → m bool) : list A → m bool
|
|
| [] := return ff
|
|
| (x::xs) := do v ← pred x, if v then return tt else any_tt_list xs
|
|
|
|
@[super.inf]
|
|
meta def forward_subsumption : inf_decl := inf_decl.mk 20 $
|
|
take given, do active ← get_active,
|
|
sequence' $ do a ← active^.values,
|
|
guard $ a^.id ≠ given^.id,
|
|
return $ do
|
|
ss ← does_subsume a^.c given^.c,
|
|
if ss
|
|
then remove_redundant given^.id [a]
|
|
else return ()
|
|
|
|
meta def forward_subsumption_pre : prover unit := preprocessing_rule $ λnew, do
|
|
active ← get_active, filter (λn, do
|
|
do ss ← any_tt active (λa,
|
|
if a^.assertions^.subset_of n^.assertions then do
|
|
does_subsume a^.c n^.c
|
|
else
|
|
-- TODO: move to locked
|
|
return ff),
|
|
return (bnot ss)) new
|
|
|
|
meta def subsumption_interreduction : list derived_clause → prover (list derived_clause)
|
|
| (c::cs) := do
|
|
-- TODO: move to locked
|
|
cs_that_subsume_c ← filter (λd, does_subsume_with_assertions d c) cs,
|
|
if ¬cs_that_subsume_c^.empty then
|
|
-- TODO: update score
|
|
subsumption_interreduction cs
|
|
else do
|
|
cs_not_subsumed_by_c ← filter (λd, lift bnot (does_subsume_with_assertions c d)) cs,
|
|
cs' ← subsumption_interreduction cs_not_subsumed_by_c,
|
|
return (c::cs')
|
|
| [] := return []
|
|
|
|
meta def subsumption_interreduction_pre : prover unit :=
|
|
preprocessing_rule $ λnew,
|
|
let new' := list.sort_on (λc : derived_clause, c^.c^.num_lits) new in
|
|
subsumption_interreduction new'
|
|
|
|
meta def keys_where_tt {m} {K V : Type} [monad m] (active : rb_map K V) (pred : V → m bool) : m (list K) :=
|
|
@rb_map.fold _ _ (m (list K)) active (return []) $ λk a cont, do
|
|
v ← pred a, rest ← cont, return $ if v then k::rest else rest
|
|
|
|
@[super.inf]
|
|
meta def backward_subsumption : inf_decl := inf_decl.mk 20 $ λgiven, do
|
|
active ← get_active,
|
|
ss ← keys_where_tt active (λa, does_subsume given^.c a^.c),
|
|
sequence' $ do id ← ss, guard (id ≠ given^.id), [remove_redundant id [given]]
|
|
|
|
end super
|