249 lines
8.5 KiB
Text
249 lines
8.5 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 init.meta.tactic .utils .trim
|
||
open expr list tactic monad decidable
|
||
|
||
namespace super
|
||
|
||
meta def is_local_not (local_false : expr) (e : expr) : option expr :=
|
||
match e with
|
||
| (pi _ _ a b) := if b = local_false then some a else none
|
||
| _ := if local_false = ```(false) then is_not e else none
|
||
end
|
||
|
||
meta structure clause :=
|
||
(num_quants : ℕ)
|
||
(num_lits : ℕ)
|
||
(proof : expr)
|
||
(type : expr)
|
||
(local_false : expr)
|
||
|
||
namespace clause
|
||
|
||
meta def num_binders (c : clause) : ℕ := num_quants c + num_lits c
|
||
|
||
meta def inst (c : clause) (e : expr) : clause :=
|
||
(if num_quants c > 0
|
||
then mk (num_quants c - 1) (num_lits c)
|
||
else mk 0 (num_lits c - 1))
|
||
(app (proof c) e) (instantiate_var (binding_body (type c)) e) c^.local_false
|
||
|
||
meta def instn (c : clause) (es : list expr) : clause :=
|
||
foldr (λe c', inst c' e) c es
|
||
|
||
meta def open_const (c : clause) : tactic (clause × expr) := do
|
||
n ← mk_fresh_name,
|
||
b ← return $ local_const n (binding_name (type c)) (binding_info (type c)) (binding_domain (type c)),
|
||
return (inst c b, b)
|
||
|
||
meta def open_meta (c : clause) : tactic (clause × expr) := do
|
||
b ← mk_meta_var (binding_domain (type c)),
|
||
return (inst c b, b)
|
||
|
||
meta def close_const (c : clause) (e : expr) : clause :=
|
||
match e with
|
||
| local_const uniq pp info t :=
|
||
let abst_type' := abstract_local (type c) (local_uniq_name e) in
|
||
let type' := pi pp binder_info.default t (abstract_local (type c) uniq) in
|
||
let abs_prf := abstract_local (proof c) uniq in
|
||
let proof' := lambdas [e] c^.proof in
|
||
if num_quants c > 0 ∨ has_var abst_type' then
|
||
{ c with num_quants := c^.num_quants + 1, proof := proof', type := type' }
|
||
else
|
||
{ c with num_lits := c^.num_lits + 1, proof := proof', type := type' }
|
||
| _ := ⟨0, 0, default expr, default expr, default expr⟩
|
||
end
|
||
|
||
meta def open_constn : clause → ℕ → tactic (clause × list expr)
|
||
| c 0 := return (c, nil)
|
||
| c (n+1) := do
|
||
(c', b) ← open_const c,
|
||
(c'', bs) ← open_constn c' n,
|
||
return (c'', b::bs)
|
||
|
||
meta def open_metan : clause → ℕ → tactic (clause × list expr)
|
||
| c 0 := return (c, nil)
|
||
| c (n+1) := do
|
||
(c', b) ← open_meta c,
|
||
(c'', bs) ← open_metan c' n,
|
||
return (c'', b::bs)
|
||
|
||
meta def close_constn : clause → list expr → clause
|
||
| c [] := c
|
||
| c (b::bs') := close_const (close_constn c bs') b
|
||
|
||
private meta def parse_clause (local_false : expr) : expr → expr → tactic clause
|
||
| proof (pi n bi d b) := do
|
||
lc_n ← mk_fresh_name,
|
||
lc ← return $ local_const lc_n n bi d,
|
||
c ← parse_clause (app proof lc) (instantiate_var b lc),
|
||
return $ c^.close_const $ local_const lc_n n binder_info.default d
|
||
| proof ```(not %%formula) := parse_clause proof ```(%%formula → false)
|
||
| proof type :=
|
||
if type = local_false then do
|
||
return { num_quants := 0, num_lits := 0, proof := proof, type := type, local_false := local_false }
|
||
else do
|
||
univ ← infer_univ type,
|
||
not_type ← return $ imp type local_false,
|
||
parse_clause (lam `H binder_info.default not_type $ app (mk_var 0) proof) (imp not_type local_false)
|
||
|
||
meta def of_proof_and_type (local_false proof type : expr) : tactic clause :=
|
||
parse_clause local_false proof type
|
||
|
||
meta def of_proof (local_false proof : expr) : tactic clause := do
|
||
type ← infer_type proof,
|
||
of_proof_and_type local_false proof type
|
||
|
||
meta def of_classical_proof (proof : expr) : tactic clause :=
|
||
of_proof ```(false) proof
|
||
|
||
meta def inst_mvars (c : clause) : tactic clause := do
|
||
proof' ← instantiate_mvars (proof c),
|
||
type' ← instantiate_mvars (type c),
|
||
return { c with proof := proof', type := type' }
|
||
|
||
meta inductive literal
|
||
| left : expr → literal
|
||
| right : expr → literal
|
||
|
||
namespace literal
|
||
|
||
meta instance : decidable_eq literal := by mk_dec_eq_instance
|
||
|
||
meta def formula : literal → expr
|
||
| (left f) := f
|
||
| (right f) := f
|
||
|
||
meta def is_neg : literal → bool
|
||
| (left _) := tt
|
||
| (right _) := ff
|
||
|
||
meta def is_pos (l : literal) : bool := bnot l^.is_neg
|
||
|
||
meta def to_formula (l : literal) : expr :=
|
||
if l^.is_neg
|
||
then app (const ``not []) l^.formula
|
||
else formula l
|
||
|
||
meta def type_str : literal → string
|
||
| (literal.left _) := "left"
|
||
| (literal.right _) := "right"
|
||
|
||
meta instance : has_to_tactic_format literal :=
|
||
⟨λl, do
|
||
pp_f ← pp l^.formula,
|
||
return $ to_fmt l^.type_str ++ " (" ++ pp_f ++ ")"⟩
|
||
|
||
end literal
|
||
|
||
private meta def get_binding_body : expr → ℕ → expr
|
||
| e 0 := e
|
||
| e (i+1) := get_binding_body e^.binding_body i
|
||
|
||
meta def get_binder (e : expr) (i : nat) :=
|
||
binding_domain (get_binding_body e i)
|
||
|
||
meta def validate (c : clause) : tactic unit := do
|
||
concl ← return $ get_binding_body c^.type c^.num_binders,
|
||
unify concl c^.local_false
|
||
<|> (do pp_concl ← pp concl, pp_lf ← pp c^.local_false,
|
||
fail $ to_fmt "wrong local false: " ++ pp_concl ++ " =!= " ++ pp_lf),
|
||
type' ← infer_type c^.proof,
|
||
unify c^.type type' <|> (do pp_ty ← pp c^.type, pp_ty' ← pp type',
|
||
fail (to_fmt "wrong type: " ++ pp_ty ++ " =!= " ++ pp_ty'))
|
||
|
||
meta def get_lit (c : clause) (i : nat) : literal :=
|
||
let bind := get_binder (type c) (num_quants c + i) in
|
||
match is_local_not c^.local_false bind with
|
||
| some formula := literal.right formula
|
||
| none := literal.left bind
|
||
end
|
||
|
||
meta def lits_where (c : clause) (p : literal → bool) : list nat :=
|
||
list.filter (λl, p (get_lit c l)) (range (num_lits c))
|
||
|
||
meta def get_lits (c : clause) : list literal :=
|
||
list.map (get_lit c) (range c^.num_lits)
|
||
|
||
private meta def tactic_format (c : clause) : tactic format := do
|
||
c ← c^.open_metan c^.num_quants,
|
||
pp (do l ← c.1^.get_lits, [l^.to_formula])
|
||
|
||
meta instance : has_to_tactic_format clause := ⟨tactic_format⟩
|
||
|
||
meta def is_maximal (gt : expr → expr → bool) (c : clause) (i : nat) : bool :=
|
||
list.empty (list.filter (λj, gt (get_lit c j)^.formula (get_lit c i)^.formula) (range c^.num_lits))
|
||
|
||
meta def normalize (c : clause) : tactic clause := do
|
||
opened ← open_constn c (num_binders c),
|
||
lconsts_in_types ← return $ contained_lconsts_list (list.map local_type opened.2),
|
||
quants' ← return $ list.filter (λlc, rb_map.contains lconsts_in_types (local_uniq_name lc))
|
||
opened.2,
|
||
lits' ← return $ list.filter (λlc, ¬rb_map.contains lconsts_in_types (local_uniq_name lc))
|
||
opened.2,
|
||
return $ close_constn opened.1 (quants' ++ lits')
|
||
|
||
meta def whnf_head_lit (c : clause) : tactic clause := do
|
||
atom' ← whnf $ literal.formula $ get_lit c 0,
|
||
return $
|
||
if literal.is_neg (get_lit c 0) then
|
||
{ c with type := ```(%%atom' → %%(binding_body c^.type)) }
|
||
else
|
||
{ c with type := ```(not %%atom' → %%(c^.type^.binding_body)) }
|
||
|
||
end clause
|
||
|
||
meta def unify_lit (l1 l2 : clause.literal) : tactic unit :=
|
||
if clause.literal.is_pos l1 = clause.literal.is_pos l2 then
|
||
unify (clause.literal.formula l1) (clause.literal.formula l2) transparency.none
|
||
else
|
||
fail "cannot unify literals"
|
||
|
||
-- FIXME: this is most definitely broken with meta-variables that were already in the goal
|
||
meta def sort_and_constify_metas : list expr → tactic (list expr)
|
||
| exprs_with_metas := do
|
||
inst_exprs ← mapm instantiate_mvars exprs_with_metas,
|
||
metas ← return $ inst_exprs >>= get_metas,
|
||
match list.filter (λm, ¬has_meta_var (get_meta_type m)) metas with
|
||
| [] :=
|
||
if metas^.empty then
|
||
return []
|
||
else do
|
||
for' metas (λm, do trace (expr.to_string m), t ← infer_type m, trace (expr.to_string t)),
|
||
fail "could not sort metas"
|
||
| ((mvar n t) :: _) := do
|
||
c ← infer_type (mvar n t) >>= mk_local_def `x,
|
||
unify c (mvar n t),
|
||
rest ← sort_and_constify_metas metas,
|
||
c ← instantiate_mvars c,
|
||
return ([c] ++ rest)
|
||
| _ := failed
|
||
end
|
||
|
||
namespace clause
|
||
|
||
meta def meta_closure (metas : list expr) (qf : clause) : tactic clause := do
|
||
bs ← sort_and_constify_metas metas,
|
||
qf' ← clause.inst_mvars qf,
|
||
clause.inst_mvars $ clause.close_constn qf' bs
|
||
|
||
private meta def distinct' (local_false : expr) : list expr → expr → clause
|
||
| [] proof := ⟨ 0, 0, proof, local_false, local_false ⟩
|
||
| (h::hs) proof :=
|
||
let (dups, rest) := partition (λh' : expr, h^.local_type = h'^.local_type) hs,
|
||
proof_wo_dups := foldl (λproof (h' : expr),
|
||
instantiate_var (abstract_local proof h'^.local_uniq_name) h)
|
||
proof dups in
|
||
(distinct' rest proof_wo_dups)^.close_const h
|
||
|
||
meta def distinct (c : clause) : tactic clause := do
|
||
(qf, vs) ← c^.open_constn c^.num_quants,
|
||
(fls, hs) ← qf^.open_constn qf^.num_lits,
|
||
return $ (distinct' c^.local_false hs fls^.proof)^.close_constn vs
|
||
|
||
end clause
|
||
|
||
end super
|