You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
123 lines
3.2 KiB
123 lines
3.2 KiB
type polarity = Pos | Neg | Null |
|
|
|
let string_of_polarity = function |
|
| Pos -> "+" |
|
| Neg -> "-" |
|
| Null -> "" |
|
|
|
let string_of_polsym (p, f) = (string_of_polarity p) ^ f |
|
|
|
module StellarSig = struct |
|
type idvar = string |
|
type idfunc = polarity * string |
|
let concat = (^) |
|
let compatible f g = |
|
match f, g with |
|
| (Pos, f), (Neg, g) |
|
| (Neg, f), (Pos, g) when f = g -> true |
|
| (Null, f), (Null, g) when f = g -> true |
|
| _ -> false |
|
let string_of_idfunc = string_of_polsym |
|
end |
|
|
|
module StellarRays = Unification.Make(StellarSig) |
|
|
|
open StellarSig |
|
open StellarRays |
|
open Tools |
|
|
|
(* --------------------------------------- |
|
Stars and Constellations |
|
--------------------------------------- *) |
|
|
|
type ray = term |
|
type star = ray list |
|
type constellation = star list |
|
|
|
let to_var x = Var x |
|
let to_func (pf, ts) = Func (pf, ts) |
|
|
|
let pos f = (Pos, f) |
|
let neg f = (Neg, f) |
|
let null f = (Null, f) |
|
|
|
let pfunc f ts = Func (pos f, ts) |
|
let nfunc f ts = Func (neg f, ts) |
|
let func f ts = Func (null f, ts) |
|
let var x = Var x |
|
let pconst f = pfunc f [] |
|
let nconst f = nfunc f [] |
|
let const f = func f [] |
|
|
|
let rec is_polarised r : bool = |
|
let aux = (function |
|
| (Pos, _) | (Neg, _) -> true |
|
| (Null, _) -> false) |
|
in exists_term_func aux r |
|
|
|
(* --------------------------------------- |
|
Display |
|
--------------------------------------- *) |
|
|
|
let rec string_of_list printer sep = function |
|
| [] -> "" |
|
| [x] -> printer x |
|
| h::t -> |
|
(printer h) ^ sep ^ (string_of_list printer sep t) |
|
|
|
let rec string_of_ray = function |
|
| Var x -> x |
|
| Func (pf, []) -> string_of_polsym pf |
|
| Func ((Null, "."), [r1; r2]) -> |
|
(string_of_ray r1) ^ " · " ^ (string_of_ray r2) |
|
| Func (pf, ts) -> string_of_polsym pf ^ |
|
"(" ^ (string_of_list string_of_ray ", " ts) ^ ")" |
|
|
|
let string_of_subst sub = |
|
"{" ^ |
|
(List.fold_left ( |
|
fun acc (x, r) -> x ^ "->" ^ (string_of_ray r) |
|
) "" sub) ^ |
|
"}" |
|
|
|
let string_of_star s = "[" ^ (string_of_list string_of_ray ", " s) ^ "]" |
|
|
|
let string_of_constellation cs = |
|
if cs = [] then "{}" else string_of_list string_of_star " + " cs |
|
|
|
let string_of_intspace (cs, space) = |
|
(string_of_constellation cs) ^ " |- " ^ (string_of_constellation space) |
|
|
|
(* --------------------------------------- |
|
Interactive execution |
|
--------------------------------------- *) |
|
|
|
let raymatcher ?(withloops=true) r r' : substitution option = |
|
if is_polarised r && is_polarised r' then |
|
solution ~withloops [(r, r')] |
|
else |
|
None |
|
|
|
let interaction ?(withloops=true) (s : star) i j (cs : constellation) : constellation = |
|
cs >>= fun i' s' -> |
|
let s = List.map (extends_vars i) s in |
|
let s' = List.map (extends_vars i') s' in |
|
s' >>= fun j' r' -> |
|
match raymatcher ~withloops (List.nth s j) r' with |
|
| None -> [] |
|
| Some sub -> |
|
let s1 = without j s in |
|
let s2 = without j' s' in |
|
return (List.map (subst sub) (s1@s2)) |
|
|
|
let intspace ?(withloops=true) cs space : constellation = |
|
List.flatten ( |
|
space >>= fun i s -> |
|
s >>= fun j _ -> |
|
return (interaction ~withloops s i j (cs@space)) |
|
) |
|
|
|
let rec intexec ?(withloops=true) (cs, space) : constellation = |
|
let result = intspace ~withloops cs space in |
|
if result = [] then space |
|
else intexec ~withloops (cs, result) |