-(** demodulation, when the target is a theorem *)
-let rec demodulation_theorem newmeta env table theorem =
- let module C = Cic in
- let module S = CicSubstitution in
- let module M = CicMetaSubst in
- let module HL = HelmLibraryObjects in
- let metasenv, context, ugraph = env in
- let maxmeta = ref newmeta in
- let term, termty, metas = theorem in
- let metasenv' = metas in
-
- let build_newtheorem (t, subst, menv, ug, (eq_found, eq_URI)) =
- let pos, equality = eq_found in
- let (_, proof', (ty, what, other, _), menv',id) =
- Equality.open_equality equality in
- let what, other = if pos = Utils.Left then what, other else other, what in
- let newterm, newty =
- let bo = Utils.guarded_simpl context (apply_subst subst (S.subst other t)) in
-(* let bo' = apply_subst subst t in *)
-(* let name = C.Name ("x_DemodThm_" ^ (string_of_int !demod_counter)) in*)
- incr demod_counter;
+(*****************************************************************************)
+(** OPERATIONS ON GOALS **)
+(** **)
+(** DEMODULATION_GOAL & SUPERPOSITION_LEFT **)
+(*****************************************************************************)
+
+(* new: demodulation of non_equality terms *)
+let build_newg bag context goal rule expansion =
+ let goalproof,_,_ = goal in
+ let (t,subst,menv,ug,eq_found) = expansion in
+ let pos, equality = eq_found in
+ let (_, proof', (ty, what, other, _), menv',id) =
+ Equality.open_equality equality in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let newterm, newgoalproof =
+ let bo =
+ Utils.guarded_simpl context
+ (apply_subst subst (CicSubstitution.subst other t))
+ in
+ let name = Cic.Name "x" in
+ let pred = apply_subst subst (Cic.Lambda (name,ty,t)) in
+ let newgoalproofstep = (rule,pos,id,subst,pred) in
+ bo, (newgoalproofstep::goalproof)
+ in
+ let newmetasenv = (* Founif.filter subst *) menv in
+ (newgoalproof, newmetasenv, newterm)
+;;
+
+let rec demod bag env table goal =
+ let goalproof,menv,t = goal in
+ let _, context, ugraph = env in
+ let res = demodulation_aux bag menv context ugraph table 0 t (~typecheck:true)in
+ match res with
+ | Some newt ->
+ let newg =
+ build_newg bag context goal Equality.Demodulation newt
+ in
+ let _,_,newt = newg in
+ if Equality.meta_convertibility t newt then
+ false, goal
+ else
+ true, snd (demod bag env table newg)
+ | None ->
+ false, goal
+;;
+
+let open_goal g =
+ match g with
+ | (proof,menv,Cic.Appl[(Cic.MutInd(uri,0,_)) as eq;ty;l;r]) ->
+ (* assert (LibraryObjects.is_eq_URI uri); *)
+ proof,menv,eq,ty,l,r
+ | _ -> assert false
+
+let ty_of_goal (_,_,ty) = ty ;;
+
+(* checks if two goals are metaconvertible *)
+let goal_metaconvertibility_eq g1 g2 =
+ Equality.meta_convertibility (ty_of_goal g1) (ty_of_goal g2)
+;;
+
+(* when the betaexpand_term function is called on the left/right side of the
+ * goal, the predicate has to be fixed
+ * C[x] ---> (eq ty unchanged C[x])
+ * [posu] is the side of the [unchanged] term in the original goal
+ *)
+
+let fix_expansion goal posu (t, subst, menv, ug, eq_f) =
+ let _,_,eq,ty,l,r = open_goal goal in
+ let unchanged = if posu = Utils.Left then l else r in
+ let unchanged = CicSubstitution.lift 1 unchanged in
+ let ty = CicSubstitution.lift 1 ty in
+ let pred =
+ match posu with
+ | Utils.Left -> Cic.Appl [eq;ty;unchanged;t]
+ | Utils.Right -> Cic.Appl [eq;ty;t;unchanged]
+ in
+ (pred, subst, menv, ug, eq_f)
+;;
+
+(* ginve the old [goal], the side that has not changed [posu] and the
+ * expansion builds a new goal *)
+let build_newgoal bag context goal posu rule expansion =
+ let goalproof,_,_,_,_,_ = open_goal goal in
+ let (t,subst,menv,ug,eq_found) = fix_expansion goal posu expansion in
+ let pos, equality = eq_found in
+ let (_, proof', (ty, what, other, _), menv',id) =
+ Equality.open_equality equality in
+ let what, other = if pos = Utils.Left then what, other else other, what in
+ let newterm, newgoalproof =
+ let bo =
+ Utils.guarded_simpl context
+ (apply_subst subst (CicSubstitution.subst other t))
+ in
+ let name = Cic.Name "x" in
+ let pred = apply_subst subst (Cic.Lambda (name,ty,t)) in
+ let newgoalproofstep = (rule,pos,id,subst,pred) in
+ bo, (newgoalproofstep::goalproof)
+ in
+ let newmetasenv = (* Founif.filter subst *) menv in
+ (newgoalproof, newmetasenv, newterm)
+;;
+
+(**
+ superposition_left
+ returns a list of new clauses inferred with a left superposition step
+ the negative equation "target" and one of the positive equations in "table"
+*)
+let superposition_left bag (metasenv, context, ugraph) table goal maxmeta =
+ let names = Utils.names_of_context context in
+ let proof,menv,eq,ty,l,r = open_goal goal in
+ let c = !Utils.compare_terms l r in
+ let newgoals =
+ if c = Utils.Incomparable then
+ begin
+ let expansionsl, _ = betaexpand_term menv context ugraph table 0 l in
+ let expansionsr, _ = betaexpand_term menv context ugraph table 0 r in
+ (* prerr_endline "incomparable";
+ prerr_endline (string_of_int (List.length expansionsl));
+ prerr_endline (string_of_int (List.length expansionsr));
+ *)