74 lines
3 KiB
Text
74 lines
3 KiB
Text
import .prover_state
|
||
open monad expr list tactic
|
||
|
||
namespace super
|
||
|
||
private meta def find_components : list expr → list (list (expr × ℕ)) → list (list (expr × ℕ))
|
||
| (e::es) comps :=
|
||
let (contain_e, do_not_contain_e) :=
|
||
partition (λc : list (expr × ℕ), c↣exists_ $ λf,
|
||
(abstract_local f↣1 e↣local_uniq_name)↣has_var) comps in
|
||
find_components es $ list.join contain_e :: do_not_contain_e
|
||
| _ comps := comps
|
||
|
||
meta def get_components (hs : list expr) : list (list expr) :=
|
||
(find_components hs (hs↣zip_with_index↣for $ λh, [h]))↣for $ λc,
|
||
(sort_on (λh : expr × ℕ, h↣2) c)↣for $ λh, h↣1
|
||
|
||
example (i : Type) (p q : i → Prop) (H : ∀x y, p x → q y → false) : true := by do
|
||
h ← get_local `H >>= clause.of_classical_proof,
|
||
(op, lcs) ← h↣open_constn h↣num_binders,
|
||
guard $ (get_components lcs)↣length = 2,
|
||
triv
|
||
|
||
example (i : Type) (p : i → i → Prop) (H : ∀x y z, p x y → p y z → false) : true := by do
|
||
h ← get_local `H >>= clause.of_classical_proof,
|
||
(op, lcs) ← h↣open_constn h↣num_binders,
|
||
guard $ (get_components lcs)↣length = 1,
|
||
triv
|
||
|
||
meta def extract_assertions : clause → prover (clause × list expr) | c :=
|
||
if c↣num_lits = 0 then return (c, [])
|
||
else if c↣num_quants ≠ 0 then do
|
||
qf ← ♯ c↣open_constn c↣num_quants,
|
||
qf_wo_as ← extract_assertions qf↣1,
|
||
return (qf_wo_as↣1↣close_constn qf↣2, qf_wo_as↣2)
|
||
else do
|
||
hd ← return $ c↣get_lit 0,
|
||
hyp_opt ← get_sat_hyp_core hd↣formula hd↣is_neg,
|
||
match hyp_opt with
|
||
| some h := do
|
||
wo_as ← extract_assertions (c↣inst h),
|
||
return (wo_as↣1, h :: wo_as↣2)
|
||
| _ := do
|
||
op ← ♯c↣open_const,
|
||
op_wo_as ← extract_assertions op↣1,
|
||
return (op_wo_as↣1↣close_const op↣2, op_wo_as↣2)
|
||
end
|
||
|
||
meta def mk_splitting_clause' (empty_clause : clause) : list (list expr) → tactic (list expr × expr)
|
||
| [] := return ([], empty_clause↣proof)
|
||
| ([p] :: comps) := do p' ← mk_splitting_clause' comps, return (p::p'↣1, p'↣2)
|
||
| (comp :: comps) := do
|
||
(hs, p') ← mk_splitting_clause' comps,
|
||
hnc ← mk_local_def `hnc (imp (pis comp empty_clause↣local_false) empty_clause↣local_false),
|
||
p'' ← return $ app hnc (lambdas comp p'),
|
||
return (hnc::hs, p'')
|
||
|
||
meta def mk_splitting_clause (empty_clause : clause) (comps : list (list expr)) : tactic clause := do
|
||
(hs, p) ← mk_splitting_clause' empty_clause comps,
|
||
return $ { empty_clause with proof := p }↣close_constn hs
|
||
|
||
@[super.inf]
|
||
meta def splitting_inf : inf_decl := inf_decl.mk 30 $ take given, do
|
||
lf ← flip monad.lift state_t.read $ λst, st↣local_false,
|
||
op ← ♯ given↣c↣open_constn given↣c↣num_binders,
|
||
if list.bor (given↣c↣get_lits↣for $ λl, (is_local_not lf l↣formula)↣is_some) then return () else
|
||
let comps := get_components op↣2 in
|
||
if comps↣length < 2 then return () else do
|
||
splitting_clause ← ♯ mk_splitting_clause op↣1 comps,
|
||
ass ← collect_ass_hyps splitting_clause,
|
||
add_sat_clause (splitting_clause↣close_constn ass) given↣sc↣sched_default,
|
||
remove_redundant given↣id []
|
||
|
||
end super
|