]> matita.cs.unibo.it Git - fireball-separation.git/blob - ocaml_new/lambda4.ml
95dec1f94b22220f1dd2eaec5ca60325ec8de363
[fireball-separation.git] / ocaml_new / lambda4.ml
1 open Util
2 open Util.Vars
3 open Pure
4 open Num
5
6 (* exceptions *)
7 exception Pacman
8 exception Bottom
9 exception Lambda
10 exception Backtrack of string
11
12 (* verbosity *)
13 let _very_verbose = true;;
14 (** Display measure of every term when printing problem *)
15 let _measure_of_terms = false;;
16
17 let verbose s =
18  if _very_verbose then prerr_endline s
19 ;;
20
21 type problem =
22  { freshno: int
23  ; div: i_var
24  ; conv: i_var list (* the inerts that must converge *)
25  ; sigma: (int * nf) list (* the computed substitution *)
26  ; initialSpecialK: int
27  ; label : string
28  ; var_names : string list (* names of the original free variables *)
29 } ;;
30
31 let label_of_problem {label} = label;;
32
33 let string_of_var l x =
34  try
35   List.nth l x
36  with Failure "nth" -> "`" ^ string_of_int x
37 ;;
38 let string_of_term p t = print ~l:p.var_names (t :> nf);;
39
40
41 let first args p var f =
42  let rec aux = function
43  | [] ->
44    raise (Backtrack ("no more alternatives for " ^ string_of_var p.var_names var))
45  | i::is -> try
46     f p i
47    with Backtrack s ->
48 prerr_endline (">>>>>> BACKTRACK (reason: " ^ s ^") measure=$ ");
49 prerr_endline("Now trying var="^string_of_var p.var_names var^" i="^string_of_int (i+1));
50      aux is
51  in aux args
52
53 let all_terms p = p.div :: p.conv ;;
54
55 let measure_of_term, measure_of_terms =
56  let rec aux = function
57  | `Bottom | `Pacman -> 0
58  | `Var(_,ar) -> if ar = min_int then 0 else max 0 ar (*assert (ar >= 0); ar*)
59  | `Lam(_,t) -> aux t
60  | `I(v,args) -> aux (`Var v) + aux_many (Listx.to_list args :> nf list)
61  and aux_many tms = List.fold_right ((+) ++ aux) tms 0 in
62  (fun t -> aux (t :> nf)), (fun l -> aux_many (l :> nf list))
63 ;;
64
65 let sum_arities p = measure_of_terms (all_terms p)
66
67 let problem_measure p = sum_arities p;;
68 let string_of_measure = string_of_int;;
69
70 let string_of_problem label ({freshno; div; conv} as p) =
71  let aux_measure_terms t = if _measure_of_terms then "(" ^ string_of_int (measure_of_term t) ^ ") " else "" in
72  let l = p.var_names in
73  String.concat "\n" ([
74   "";
75   "# DISPLAY PROBLEM (" ^ label ^ ") " ^ "measure=" ^ string_of_measure (problem_measure p);
76   "#";
77   "$" ^ p.label;
78   "D " ^ aux_measure_terms div ^ print ~l (div :> nf);
79   ]
80   @ List.map (fun t -> "C " ^ aux_measure_terms t ^ print ~l (t :> nf)) conv
81   @ [""])
82 ;;
83
84
85 let failwithProblem p reason =
86  print_endline (string_of_problem "FAIL" p);
87  failwith reason
88 ;;
89
90 let make_fresh_var p arity =
91  let freshno = p.freshno + 1 in
92  {p with freshno}, `Var(freshno,arity)
93 ;;
94
95 let make_fresh_vars p arities =
96  List.fold_right
97   (fun arity (p, vars) -> let p, var = make_fresh_var p arity in p, var::vars)
98   arities
99   (p, [])
100 ;;
101
102
103 let fixpoint f =
104  let rec aux x = let x' = f x in if x <> x' then aux x' else x in aux
105 ;;
106
107
108 let subst_in_problem x inst ({div; conv} as p) =
109 prerr_endline ("# INST0: " ^ string_of_var p.var_names x ^ " := " ^ string_of_term p inst);
110  let aux t = match t with
111  | #i_var as t -> t
112  | `Lam _ | `Bottom | `Pacman -> assert false (* ??? *) in
113  let div = (aux ++ (subst false false x inst)) (div :> nf) in
114  let conv = List.map (subst false false x inst) (conv :> nf list) in
115  let conv = List.filter (function `Lam _ -> false | _ -> true) conv in
116  let conv = List.map aux conv in
117  {p with div; conv}
118 ;;
119
120 exception Dangerous;;
121
122 let arity_of arities hd =
123  let pos,_,nargs = List.find (fun (_,hd',_) -> hd=hd') arities in
124  nargs + if pos = -1 then - 1 else 0
125 ;;
126
127 (* let rec dangerous arities showstoppers =
128  function
129     `N _
130   | `Var _
131   | `Lam _
132   | `Pacman -> ()
133   | `Match(t,_,liftno,bs,args) ->
134       (* CSC: XXX partial dependency on the encoding *)
135       (match t with
136           `N _ -> List.iter (dangerous arities showstoppers) args
137         | `Match _ as t -> dangerous arities showstoppers t ; List.iter (dangerous arities showstoppers) args
138         | `Var(x,_) -> dangerous_inert arities showstoppers x args 2
139         | `I((x,_),args') -> dangerous_inert arities showstoppers x (Listx.to_list args' @ args) 2
140       )
141   | `I((k,_),args) -> dangerous_inert arities showstoppers k (Listx.to_list args) 0
142
143 and dangerous_inert arities showstoppers k args more_args =
144  List.iter (dangerous arities showstoppers) args ;
145  if List.mem k showstoppers then raise Dangerous else
146  try
147   let arity = arity_of arities k in
148   if List.length args + more_args > arity then raise Dangerous else ()
149  with
150   Not_found -> ()
151
152 (* cut & paste from above *)
153 let rec dangerous_conv p arities showstoppers =
154  function
155   | `N _
156   | `Var _
157   | `Lam _
158   | `Pacman -> ()
159   | `Match(t,_,liftno,bs,args) -> (
160       (* CSC: XXX partial dependency on the encoding *)
161        try (match t with
162         | `N _ -> List.iter (dangerous_conv p arities showstoppers) args
163         | `Match _ as t -> dangerous_conv p arities showstoppers t; List.iter (dangerous_conv p arities showstoppers) args
164         | `Var(x,_) -> dangerous_inert_conv p arities showstoppers x [] args 2
165         | `I((x,_),args') -> dangerous_inert_conv p arities showstoppers x (Listx.to_list args') args 2
166         ) with TriggerMatchReduction x -> (
167            match Util.find_opt (fun (n, t) -> if hd_of (List.nth p.ps n) = Some x then Some t else None) !bs with
168             | None -> ()
169             | Some t -> (
170                match t with
171                 | `Bottom -> raise Dangerous
172                 | #nf_nob as t -> dangerous_conv p arities showstoppers t
173                )
174            )
175        )
176   | `I((k,_),args) -> dangerous_inert_conv p arities showstoppers k (Listx.to_list args) [] 0
177
178 and dangerous_inert_conv p arities showstoppers k args match_args more_args =
179  let all_args = args @ match_args in
180  List.iter (dangerous_conv p arities showstoppers) all_args;
181  let all_args = (all_args :> nf list) in
182  if List.mem k showstoppers then raise Dangerous else
183   try
184    let arity = arity_of arities k in
185 prerr_endline ("dangerous_inert_conv: ar=" ^ string_of_int arity ^ " k="^string_of_var p.var_names k ^ " listlenargs=" ^ (string_of_int (List.length args)) ^ " more_args=" ^ string_of_int more_args);
186    if more_args > 0 (* match argument*) && List.length args = arity then raise (TriggerMatchReduction k)
187     else if List.length all_args + more_args > arity then raise Dangerous else ()
188   with
189    Not_found -> ()
190
191 (* inefficient algorithm *)
192 let rec edible p arities showstoppers =
193  let rec aux f showstoppers tms = function
194    | [] -> showstoppers
195    | x::xs when List.exists (fun y -> hd_of x = Some y) showstoppers ->
196       (* se la testa di x e' uno show-stopper *)
197       let new_showstoppers = sort_uniq (showstoppers @ free_vars (x :> nf)) in
198       (* aggiungi tutte le variabili libere di x *)
199       if List.length showstoppers <> List.length new_showstoppers then
200        aux f new_showstoppers tms tms
201       else
202        aux f showstoppers tms xs
203    | x::xs ->
204       match hd_of x with
205          None -> aux f showstoppers tms xs
206        | Some h ->
207           try
208            f showstoppers (x :> nf_nob) ;
209            aux f showstoppers tms xs
210           with
211            Dangerous ->
212             aux f (sort_uniq (h::showstoppers)) tms tms
213   in
214    let showstoppers = sort_uniq (aux (dangerous arities) showstoppers p.ps p.ps) in
215    let dangerous_conv = sort_uniq (aux (dangerous_conv p arities) showstoppers p.conv p.conv) in
216
217 (* prerr_endline ("dangerous_conv lenght:" ^ string_of_int (List.length dangerous_conv));
218 List.iter (fun l -> prerr_endline (String.concat " " (List.map (string_of_var p.var_names) l))) dangerous_conv; *)
219
220     let showstoppers' = showstoppers @ dangerous_conv in
221     let showstoppers' = sort_uniq (match p.div with
222      | None -> showstoppers'
223      | Some div ->
224        if List.exists ((=) (hd_of_i_var div)) showstoppers'
225        then showstoppers' @ free_vars (div :> nf) else showstoppers') in
226     if showstoppers <> showstoppers' then edible p arities showstoppers' else showstoppers', dangerous_conv
227 ;;
228
229 let precompute_edible_data {ps; div} xs =
230  let aux t = match t with `Var _ -> 0 | `I(_, args) -> Listx.length args | `N _ -> assert false in
231  (fun l -> match div with
232   | None -> l
233   | Some div -> (-1, hd_of_i_var div, aux div) :: l)
234   (List.map (fun hd ->
235    let i, tm = Util.findi (fun y -> hd_of y = Some hd) ps in
236     i, hd, aux tm
237    ) xs)
238 ;;
239
240 (** Returns (p, showstoppers_step, showstoppers_eat) where:
241     - showstoppers_step are the heads occurring twice
242       in the same discriminating set
243     - showstoppers_eat are the heads in ps having different number
244       of arguments *)
245 let critical_showstoppers p =
246   let p = super_simplify p in
247   let hd_of_div = match p.div with None -> [] | Some t -> [hd_of_i_var t] in
248   let showstoppers_step =
249   concat_map (fun bs ->
250     let heads = List.map (fun (i,_) -> List.nth p.ps i) !bs in
251     let heads = List.sort compare (hd_of_div @ filter_map hd_of heads) in
252     snd (split_duplicates heads)
253     ) p.deltas @
254      if List.exists (fun t -> [hd_of t] = List.map (fun x -> Some x) hd_of_div) p.conv
255      then hd_of_div else [] in
256   let showstoppers_step = sort_uniq showstoppers_step in
257   let showstoppers_eat =
258    let heads_and_arities =
259     List.sort (fun (k,_) (h,_) -> compare k h)
260      (filter_map (function `Var(k,_) -> Some (k,0) | `I((k,_),args) -> Some (k,Listx.length args) | _ -> None ) p.ps) in
261    let rec multiple_arities =
262     function
263        []
264      | [_] -> []
265      | (x,i)::(y,j)::tl when x = y && i <> j ->
266          x::multiple_arities tl
267      | _::tl -> multiple_arities tl in
268    multiple_arities heads_and_arities in
269
270   let showstoppers_eat = sort_uniq showstoppers_eat in
271   let showstoppers_eat = List.filter
272     (fun x -> not (List.mem x showstoppers_step))
273     showstoppers_eat in
274   List.iter (fun v -> prerr_endline ("DANGEROUS STEP: " ^ (string_of_var p.var_names) v)) showstoppers_step;
275   List.iter (fun v -> prerr_endline ("DANGEROUS EAT: " ^ (string_of_var p.var_names) v)) showstoppers_eat;
276   p, showstoppers_step, showstoppers_eat
277   ;;
278
279 let eat p =
280   let ({ps} as p), showstoppers_step, showstoppers_eat = critical_showstoppers p in
281   let showstoppers = showstoppers_step @ showstoppers_eat in
282   let heads = List.sort compare (filter_map hd_of ps) in
283   let arities = precompute_edible_data p (uniq heads) in
284   let inedible, showstoppers_conv = edible p arities showstoppers in
285   let l = List.filter (fun (_,hd,_) -> not (List.mem hd inedible)) arities in
286   let p =
287   List.fold_left (fun p (pos,hd,nargs) -> if pos = -1 then p else
288    let v = `N pos in
289    let inst = make_lams v nargs in
290 prerr_endline ("# [INST_IN_EAT] eating: " ^ string_of_var p.var_names hd ^ " := " ^ string_of_term p inst);
291    { p with sigma = p.sigma @ [hd,inst] }
292    ) p l in
293   (* to avoid applied numbers in safe positions that
294      trigger assert failures subst_in_problem x inst p*)
295  let ps =
296   List.map (fun t ->
297    try
298     let j,_,_ = List.find (fun (_,hd,_) -> hd_of t = Some hd) l in
299     `N j
300    with Not_found -> t
301   ) ps in
302  let p = match p.div with
303   | None -> p
304   | Some div ->
305    if List.mem (hd_of_i_var div) inedible
306    then p
307    else
308     let n = match div with `I(_,args) -> Listx.length args | `Var _ -> 0 in
309     let x = hd_of_i_var div in
310     let inst = make_lams `Bottom n in
311     subst_in_problem x inst p in
312 (*let dangerous_conv = showstoppers_conv in
313 prerr_endline ("dangerous_conv lenght:" ^ string_of_int (List.length dangerous_conv));
314 List.iter (fun l -> prerr_endline (String.concat " " (List.map (string_of_var p.var_names) l))) dangerous_conv; *)
315  let conv =
316    List.map (function t ->
317     try
318      if let hd = hd_of t in hd <> None && not (List.mem (Util.option_get hd) showstoppers_conv) then t else (
319      (match t with | `Var _ -> raise Not_found | _ -> ());
320      let _ = List.find (fun h -> hd_of t = Some h) inedible in
321       t)
322     with Not_found -> match hd_of t with
323      | None -> assert (t = convergent_dummy); t
324      | Some h ->
325       prerr_endline ("FREEZING " ^ string_of_var p.var_names h);
326       convergent_dummy
327    ) p.conv in
328  List.iter
329   (fun bs ->
330     bs :=
331      List.map
332       (fun (n,t as res) ->
333         match List.nth ps n with
334            `N m -> m,t
335          | _ -> res
336       ) !bs
337   ) p.deltas ;
338  let old_conv = p.conv in
339  let p = { p with ps; conv } in
340  if l <> [] || old_conv <> conv
341   then prerr_endline (string_of_problem "eat" p);
342  if List.for_all (function `N _ -> true | _ -> false) ps && p.div = None then
343   `Finished p
344  else
345   `Continue p
346
347
348 let safe_arity_of_var p x =
349  (* Compute the minimum number of arguments when x is in head
350     position at p.div or p.ps *)
351  let aux = function
352  | `Var(y,_) -> if x = y then 0 else max_int
353  | `I((y,_),args) -> if x = y then Listx.length args else max_int
354  | _ -> max_int in
355  let tms = ((match p.div with None -> [] | Some t -> [(t :> i_n_var)]) @ p.ps) in
356  List.fold_left (fun acc t -> Pervasives.min acc (aux t)) max_int tms
357 ;; *)
358
359 let instantiate p x perm =
360  let n = (prerr_endline ("WARNING: using constant initialSpecialK=" ^ string_of_int p.initialSpecialK)); p.initialSpecialK in
361  let arities = Array.to_list (Array.make (n+1) min_int) in
362  let p,vars = make_fresh_vars p arities in
363  (* manual lifting of vars by perm in next line *)
364  let vars = List.map (function `Var (n,ar) -> `Var (n+perm,ar)) vars in
365  (* other_vars are the variables which are delayed and re-applied to the match *)
366  let other_vars = Array.mapi (fun n () -> `Var(n+1,min_int)) (Array.make (perm-1) ()) in
367  let other_vars = Array.to_list other_vars in
368  (* 666, since it will be replaced anyway during subst: *)
369  (* let inst = `Match(`I((0,min_int),args),(x,-666),perm,bs,other_vars) in *)
370  let inst = `I((0,min_int),Listx.from_list (vars @ other_vars)) in (* FIXME *)
371  (* Add a number of 'perm' leading lambdas *)
372  let inst = Array.fold_left (fun t () -> `Lam(false, t)) inst (Array.make perm ()) in
373  let p = {p with sigma=(x,inst)::p.sigma} in
374  subst_in_problem x inst p
375 ;;
376
377 let compute_special_k tms =
378  let rec aux k (t: nf) = Pervasives.max k (match t with
379  | `Lam(b,t) -> aux (k + if b then 1 else 0) t
380  | `I(n, tms) -> Listx.max (Listx.map (aux 0) (tms :> nf Listx.listx))
381  | `Bottom
382  | `Pacman
383  | `Var _ -> 0
384  ) in
385  let rec aux' top t = match t with
386  | `Lam(_,t) -> aux' false t
387  | `I((_,ar), tms) -> max ar
388      (Listx.max (Listx.map (aux' false) (tms :> nf Listx.listx)))
389  | `Bottom
390  | `Pacman
391  | `Var _ -> 0 in
392  Listx.max (Listx.map (aux 0) tms) + Listx.max (Listx.map (aux' true) tms)
393 ;;
394
395 (* let choose_step p =
396  let p, showstoppers_step, showstoppers_eat = critical_showstoppers p in
397  let x =
398   match showstoppers_step, showstoppers_eat with
399   | [], y::_ ->
400      prerr_endline ("INSTANTIATING (critical eat) : " ^ string_of_var p.var_names y); y
401   | x::_, _ ->
402      prerr_endline ("INSTANTIATING (critical step): " ^ string_of_var p.var_names x); x
403   | [], [] ->
404      let heads =
405       (* Choose only variables still alive (with arity > 0) *)
406       List.sort compare (filter_map (
407        fun t -> match t with `Var _ -> None | x -> if arity_of_hd x <= 0 then None else hd_of x
408       ) ((match p.div with Some t -> [(t :> i_n_var)] | _ -> []) @ p.ps)) in
409      (match heads with
410       | [] ->
411          (try
412            fst (List.find (((<) 0) ++ snd) (concat_map free_vars' (p.conv :> nf list)))
413           with
414            Not_found -> assert false)
415       | x::_ ->
416          prerr_endline ("INSTANTIATING TO EAT " ^ string_of_var p.var_names x);
417          x) in
418  let arity_of_x = Util.option_get (max_arity_tms x (all_terms p)) in
419  let safe_arity_of_x = safe_arity_of_var p x in
420  x, min arity_of_x safe_arity_of_x
421 ;; *)
422
423 let intersect l1 l2 =
424  let rec aux n l1 l2 = match l1, l2 with
425  | [], _ -> []
426  | _, [] -> assert false
427  | x::xs, y::ys -> if x <> y then n :: aux (n+1) xs ys else aux (n+1) xs ys
428  in aux 1 (Listx.to_list l1) (Listx.to_list l2);;
429
430 exception Difference of int list;;
431 let eat p =
432  let hd, args, n = match p.div with `Var _ -> assert false | `I((x,_), l) -> x, l, Listx.length l in
433  let rec aux = function
434  | `Var _ | `Lam _ -> ()
435  | `Pacman | `Bottom -> assert false
436  | `I((x,_),args') ->
437      if x = hd then
438       if Listx.length args' >= n then
439        (let diff = intersect args args' in
440        if diff <> [] then raise (Difference diff));
441      List.iter aux ((Listx.to_list args') :> nf list) in
442  try
443   List.iter aux (p.conv :> nf list) ;
444   `Finished {p with sigma=(hd,make_lams `Bottom n)::p.sigma}
445  with
446   Difference l -> `Continue (hd, l)
447 ;;
448
449 let rec auto_eat p =
450  prerr_endline (string_of_problem "auto_eat" p);
451  prerr_endline "{{{{{{{{ Computing measure before auto_instantiate }}}}}}";
452  match eat p with
453  | `Finished p -> prerr_endline "finished"; p
454  | `Continue (x,positions) ->
455  let m = problem_measure p in
456  first positions p x (fun p j ->
457   let p = instantiate p x j in
458   prerr_endline "{{{{{{{{ Computing measure inafter auto_instantiate }}}}}}";
459   let delta = problem_measure p - m in
460   if delta >= 0
461    then
462     (prerr_endline
463     ("Measure did not decrease (+=" ^ string_of_int delta ^ ")"))
464    else prerr_endline ("$ Measure decreased: " ^ string_of_int delta);
465    auto_eat p)
466 ;;
467
468 (******************************************************************************)
469 let env_of_sigma freshno sigma =
470  let rec aux n =
471   if n > freshno then
472    []
473   else
474    let e = aux (n+1) in
475    (try
476     e,Pure.lift (-n-1) (snd (List.find (fun (i,_) -> i = n) sigma)),[]
477    with
478     Not_found -> ([],Pure.V n,[]))::e
479  in aux 0
480 ;;
481 (* ************************************************************************** *)
482
483 type response = [
484  | `CompleteSeparable of string
485  | `CompleteUnseparable of string
486  | `Uncomplete
487 ]
488
489 type result = [
490  `Complete | `Uncomplete
491 ] * [
492  | `Separable of (int * Num.nf) list
493  | `Unseparable of string
494 ]
495
496
497 let run p =
498  Console.print_hline();
499  prerr_endline (string_of_problem "main" p);
500  let p_finale = auto_eat p in
501  let freshno,sigma = p_finale.freshno, p_finale.sigma in
502  prerr_endline ("------- <DONE> ------ measure=. \n ");
503  List.iter (fun (x,inst) -> prerr_endline (string_of_var p_finale.var_names x ^ " := " ^ string_of_term p_finale inst)) sigma;
504
505  prerr_endline "---------<PURE>---------";
506  let scott_of_nf t = ToScott.scott_of_nf (t :> nf) in
507  let div = scott_of_nf p.div in
508  let conv = List.map scott_of_nf p.conv in
509
510  let sigma' = List.map (fun (x,inst) -> x, ToScott.scott_of_nf inst) sigma in
511  let e' = env_of_sigma freshno sigma' in
512
513  prerr_endline "--------<REDUCE>---------";
514  (* print_endline (Pure.print div); *)
515  let t = Pure.mwhd (e',div,[]) in
516  prerr_endline ("*:: " ^ (Pure.print t));
517  assert (t = Pure.B);
518  List.iter (fun n ->
519    (* verbose ("_::: " ^ (Pure.print n)); *)
520    let t = Pure.mwhd (e',n,[]) in
521    verbose ("_:: " ^ (Pure.print t));
522    assert (t <> Pure.B)
523  ) conv ;
524  prerr_endline "-------- </DONE> --------";
525  p_finale.sigma
526 ;;
527
528 let solve (p, todo) =
529  let completeness, to_run =
530   match todo with
531    | `CompleteUnseparable s -> `Complete, `False s
532    | `CompleteSeparable _ -> `Complete, `True
533    | `Uncomplete -> `Uncomplete, `True in
534  completeness, match to_run with
535   | `False s -> `Unseparable s
536   | `True ->
537       try
538        `Separable (run p)
539       with
540        Backtrack _ -> `Unseparable "backtrack"
541 ;;
542
543 let no_bombs_pacmans p =
544     not (List.exists (eta_subterm `Bottom) p.conv)
545  && not (eta_subterm `Pacman p.div)
546 ;;
547
548 let check p =
549  if not (List.exists (eta_subterm p.div) p.conv) && no_bombs_pacmans p
550   then `CompleteSeparable "no bombs, pacmans and div"
551   (* il check seguente e' spostato nel parser e lancia un ParsingError *)
552  (* else if false (* TODO bombs or div fuori da lambda in ps@conv *)
553   then `CompleteUnseparable "bombs or div fuori da lambda in ps@conv" *)
554  else `Uncomplete
555 ;;
556
557 let problem_of (label, div, conv, var_names) =
558  (* TODO: replace div with bottom in problem??? *)
559  let all_tms = div :: conv in
560  if all_tms = [] then failwith "problem_of: empty problem";
561  let initialSpecialK = compute_special_k (Listx.from_list (all_tms :> nf list)) in
562  let freshno = List.length var_names in
563  let sigma = [] in
564  let p = {freshno; div; conv; sigma; initialSpecialK; var_names; label} in
565  p, check p
566 ;;