+(* returns all the 1 step demodulations *)
+module C = Cic;;
+module S = CicSubstitution;;
+let rec demodulation_all_aux
+ metasenv context ugraph table lift_amount term
+=
+ let candidates =
+ get_candidates ~env:(metasenv,context,ugraph) Matching table term
+ in
+ match term with
+ | C.Meta _ -> []
+ | _ ->
+ let termty, ugraph = C.Implicit None, ugraph in
+ let res =
+ find_all_matches
+ ~unif_fun:Founif.matching ~demod:true
+ metasenv context ugraph lift_amount term termty candidates
+ in
+ match term with
+ | C.Appl l ->
+ let res, _, _ =
+ List.fold_left
+ (fun (res,l,r) t ->
+ res @
+ List.map
+ (fun (rel, s, m, ug, c) ->
+ (Cic.Appl (l@[rel]@List.tl r), s, m, ug, c))
+ (demodulation_all_aux
+ metasenv context ugraph table lift_amount t),
+ l@[List.hd r], List.tl r)
+ (res, [], List.map (S.lift 1) l) l
+ in
+ res
+ | t -> res
+;;
+
+let demod_all steps bag env table goal =
+ let _, context, ugraph = env in
+ let is_visited l (_,_,t) =
+ List.exists (fun (_,_,s) -> Equality.meta_convertibility s t) l
+ in
+ let rec aux steps visited bag = function
+ | _ when steps = 0 -> visited, bag, []
+ | [] -> visited, bag, []
+ | goal :: rest when is_visited visited goal -> aux steps visited bag rest
+ | goal :: rest ->
+ let visited = goal :: visited in
+ let _,menv,t = goal in
+ let res = demodulation_all_aux menv context ugraph table 0 t in
+ let steps = if res = [] then steps-1 else steps in
+ let new_goals =
+ List.map (build_newg bag context goal Equality.Demodulation) res
+ in
+ let visited, bag, res = aux steps visited bag (new_goals @ rest) in
+ visited, bag, goal :: res
+ in
+ aux steps [] bag [goal]
+;;
+
+
+let solve_demodulating bag env table initgoal steps =
+ let proof,menv,eq,ty,left,right = open_goal initgoal in
+ let uri =
+ match eq with
+ | Cic.MutInd (u,_,_) -> u
+ | _ -> assert false
+ in
+ let _, context, ugraph = env in
+ let v1, bag, l_demod = demod_all steps bag env table ([],menv,left) in
+ let v2, bag, r_demod = demod_all steps bag env table ([],menv,right) in
+ let is_solved left right ml mr =
+ let m = ml @ (List.filter
+ (fun (x,_,_) -> not (List.exists (fun (y,_,_) -> x=y)ml)) mr)
+ in
+ try
+ let s,_,_ =
+ Founif.unification [] m context left right CicUniv.empty_ugraph in
+ Some (bag, m,s,Equality.Exact (Equality.refl_proof uri ty left))
+ with CicUnification.UnificationFailure _ ->
+ let solutions =
+ unification_all env table (Equality.mk_tmp_equality
+ (0,(Cic.Implicit None,left,right,Utils.Incomparable),m))
+ in
+ if solutions = [] then None
+ else
+ let s, e, swapped = List.hd solutions in
+ let _,p,(ty,l,r,_),me,id = Equality.open_equality e in
+ let bag, p =
+ if swapped then Equality.symmetric bag ty l id uri me else bag, p
+ in
+ Some (bag, m,s, p)
+ in
+ let newgoal =
+ HExtlib.list_findopt
+ (fun (pr,mr,r) _ ->
+ try
+ let pl,ml,l,bag,m,s,p =
+ match
+ HExtlib.list_findopt (fun (pl,ml,l) _ ->
+ match is_solved l r ml mr with
+ | None -> None
+ | Some (bag,m,s,p) -> Some (pl,ml,l,bag,m,s,p)
+ ) l_demod
+ with Some x -> x | _ -> raise Not_found
+ in
+ let pl =
+ List.map
+ (fun (rule,pos,id,subst,pred) ->
+ let pred =
+ match pred with
+ | Cic.Lambda (name,src,tgt) ->
+ Cic.Lambda (name,src,
+ Cic.Appl[eq;ty;tgt;CicSubstitution.lift 1 right])
+ | _ -> assert false
+ in
+ rule,pos,id,subst,pred)
+ pl
+ in
+ let pr =
+ List.map
+ (fun (rule,pos,id,subst,pred) ->
+ let pred =
+ match pred with
+ | Cic.Lambda (name,src,tgt) ->
+ Cic.Lambda (name,src,
+ Cic.Appl[eq;ty;CicSubstitution.lift 1 l;tgt])
+ | _ -> assert false
+ in
+ rule,pos,id,subst,pred)
+ pr
+ in
+ Some (bag,pr@pl@proof,m,s,p)
+ with Not_found -> None)
+ r_demod
+ in
+ newgoal
+;;
+
+
+