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.
250 lines
10 KiB
250 lines
10 KiB
open Unification |
|
|
|
(* ======================================== |
|
Definitions |
|
======================================== *) |
|
|
|
type pol = Pos | Neg | Npol |
|
type ray = Var of id | Func of (id * pol * ray list) |
|
(* alternative ray definition using terms *) |
|
(* type ray = PR of id * pol * ray | NR of term *) |
|
type star = ray list |
|
type constellation = star list |
|
type graph = (int * int) * (ray * ray) list |
|
|
|
(* token is a couple of a family number and a star number in the constellation *) |
|
type token = int * int |
|
type process = token list |
|
|
|
(* List monad *) |
|
let return x = [x] (*plongement dans la monade de liste*) |
|
let (>>=) xs k = List.flatten (List.map k xs) |
|
let guard c x = if c then return x else [] |
|
|
|
(* ======================================== |
|
Useful functions |
|
======================================== *) |
|
|
|
let make_const_pol pol c = Func (c, pol, []) |
|
let make_const c = make_const_pol Npol c |
|
|
|
|
|
(* Takes a list and remove doubles from it *) |
|
let remove_double list = |
|
List.fold_left (fun l a -> if not(List.mem a l) then (a::l) else l) [] list |
|
|
|
(* Convert a pol and an id to a string, adding + or - before the id *) |
|
let pol_to_string pol id = |
|
if pol = Pos then "+" ^ id |
|
else if pol = Neg then "-" ^ id |
|
else id |
|
|
|
(* Convert a ray (which is polarized) to a term (which isn't)*) |
|
let rec ray_to_term r = |
|
match r with |
|
| Var id -> (Var(id) : term) |
|
| Func(id, pol, raylist) -> (Func(pol_to_string pol id, List.map ray_to_term raylist) : term) |
|
|
|
(* Invert polarization of a pol*) |
|
let inv_pol pol = |
|
if pol = Pos then Neg |
|
else if pol = Neg then Pos |
|
else pol |
|
|
|
(* Invert the polarization of a ray to allow an easier Unification writing *) |
|
let rec inv_pol_ray ray = |
|
match ray with |
|
| Func(id, pol, raylist) -> Func(id, inv_pol pol, List.map inv_pol_ray raylist) |
|
| _ -> ray |
|
|
|
(* Checks if a ray is polarised *) |
|
let rec is_polarised r = |
|
match r with |
|
| Var id -> false |
|
| Func(_, p, r) -> (p <> Npol) || (List.fold_left (fun acc b -> (is_polarised b) || acc) false r) |
|
|
|
(* Checks if two rays are dual, meaning that after inverting polarization of one ray, the two rays can be unified *) |
|
let dual_check r1 r2 = |
|
if (is_polarised r1 && is_polarised r2) then |
|
(solve [(extends_varname (ray_to_term (inv_pol_ray r1)) "0"), (extends_varname ((ray_to_term r2)) "1")] []) |
|
else None |
|
|
|
(* Create an index for a constellation *) |
|
let index_constellation const = |
|
List.combine (List.init (List.length const) (fun a -> a)) const |
|
|
|
(* apply_ray applies a substitution to a var of a ray*) |
|
let apply_ray id sub = |
|
let (_,s) = try List.find (fun (a,_) -> a = id ) sub with Not_found -> (id,Var(id)) in (s :ray) |
|
|
|
(* substit_ray applies all possible substition from an environment to a ray *) |
|
let rec substit_ray ray sub = |
|
match ray with |
|
| Var id -> apply_ray id sub |
|
| Func(f, p, tl) -> Func(f, p, List.map (fun a -> substit_ray a sub) tl) |
|
|
|
(* substit_star applies all possible substition from an environment to a star *) |
|
let substit_star star sub = |
|
List.map (fun a -> substit_ray a sub) star |
|
|
|
(* substit_const applies all possible substition from an environment to a constellation *) |
|
let substit_const const sub = |
|
List.map (fun a -> substit_star a sub) const |
|
|
|
(* extends_varname adds suffix to all var names of a ray *) |
|
let rec extends_varname_ray t ext = |
|
match t with |
|
| Var id -> Var(id ^ ext) |
|
| Func(f, p, tl) -> Func(f, p, List.map (fun a -> extends_varname_ray a ext) tl) |
|
|
|
(* extends_varname adds suffix to all var names of a star *) |
|
let extends_varname_star const ext = |
|
List.map (fun a -> extends_varname_ray a ext) const |
|
|
|
(* extends_varname adds suffix to all var names of a constellation based on each star number after being indexed *) |
|
let extends_varname_const const = |
|
List.map (fun (i,a) -> extends_varname_star a (string_of_int i)) (index_constellation const) |
|
|
|
(* convert a term to a ray *) |
|
let rec term_to_ray (term : term) = |
|
match term with |
|
| Var id -> (Var(id) : ray) |
|
| Func(f, r) -> Func(f, Npol, List.map (fun a -> term_to_ray a) r) |
|
|
|
(* convert a star to a string*) |
|
let rec star_to_string star = |
|
match star with |
|
| [] -> "" |
|
| h::t -> term_to_string (ray_to_term h) ^ "\n" ^ (star_to_string t) |
|
|
|
(*print a star*) |
|
let print_star star = |
|
print_string (star_to_string star) |
|
|
|
(*convert a constellation to a string*) |
|
let rec const_to_string const = |
|
match const with |
|
| [] -> "" |
|
| h::t -> (star_to_string h) ^ "---------- \n" ^ (const_to_string t) |
|
|
|
(*print a constellation*) |
|
let print_const const = |
|
print_string (const_to_string const) |
|
|
|
(* ======================================== |
|
Constellation graph |
|
======================================== *) |
|
|
|
(* Makes a dgraph from a constellation *) |
|
let dgraph const = |
|
let indexed_const = index_constellation const in |
|
indexed_const >>= fun (i, il) -> |
|
indexed_const >>= fun (j, jl) -> |
|
il >>= fun r1 -> |
|
jl >>= fun r2 -> |
|
guard (j >= i) ( let uni = dual_check r1 r2 in |
|
if Option.is_some uni then [((i,j),(r1,r2))] |
|
else []) |
|
|
|
(* Convert a link to a string to be printable *) |
|
let link_to_string dg = |
|
let rec aux dgl = |
|
match dgl with |
|
| [] -> "" |
|
| ((i,j),(r1, r2))::[] -> ("(" ^ string_of_int i ^ ", " ^ string_of_int j ^ ")" ^ "," ^ "(" ^ term_to_string (ray_to_term r1) ^ ", " ^ term_to_string (ray_to_term r2) ^ ")") |
|
| ((i,j),(r1, r2))::t -> ("(" ^ string_of_int i ^ ", " ^ string_of_int j ^ ")" ^ "," ^ "(" ^ term_to_string (ray_to_term r1) ^ ", " ^ term_to_string (ray_to_term r2) ^ ")") ^ "+" ^ (aux t) |
|
in aux dg ;; |
|
|
|
(* Convert an equation list (which is a link without the index) to a string *) |
|
let eq_to_string eq = |
|
let rec aux dgl = |
|
match dgl with |
|
| [] -> "" |
|
| ((r1, r2))::[] -> ("(" ^ term_to_string (ray_to_term r1) ^ " = " ^ term_to_string (ray_to_term r2) ^ ")") |
|
| ((r1, r2))::t -> ("(" ^ term_to_string (ray_to_term r1) ^ " = " ^ term_to_string (ray_to_term r2) ^ ")") ^ "\n" ^ (aux t) |
|
in aux eq;; |
|
|
|
(* print an equation list*) |
|
let print_eq eq = |
|
print_string (eq_to_string eq) |
|
|
|
(* remove empty list from a dgraph *) |
|
let clean_dgraph g = |
|
List.filter (fun a -> a <> []) g |
|
|
|
(* Print a dgraph *) |
|
let print_dgraph dg = |
|
let rec aux dgl = |
|
match dgl with |
|
| [] -> "" |
|
| h::[] -> (link_to_string h) |
|
| h::t -> (link_to_string h) ^ "\n" ^ aux t |
|
in print_string (aux (clean_dgraph dg));; |
|
|
|
(* get a star using its number in the list from a constellation *) |
|
let get_star const i = |
|
List.nth const i |
|
|
|
(* Takes a constellation, a ray and a (ray,ray) list and extracts rays from stars number i (respectively j) that are not ri (respectively rj) when ri (respectively rj) isn't in the prob list *) |
|
let star_filter const ((i, j),(ri,rj)) prob = |
|
let (prob_a, prob_b) = List.split prob in |
|
(if List.mem ri prob_a then [] |
|
else (List.filter (fun a -> a <> ri) (get_star const i)) |
|
)@( |
|
if List.mem rj prob_b then [] |
|
else (List.filter (fun a -> a <> rj) (get_star const j)) |
|
) |
|
|
|
(* convert the (ray,ray) list part of a link to an equation, converting its rays to terms *) |
|
let link_to_eq prob = |
|
List.map (fun (ra, rb) -> (ray_to_term (inv_pol_ray ra)), ray_to_term rb) prob |
|
|
|
(* removes rays from prob from the star *) |
|
let star_postfilter star prob = |
|
let (prob_a, prob_b) = List.split prob in |
|
List.filter (fun a -> not(List.mem a prob_a) && not(List.mem a prob_b )) star |
|
|
|
(* takes a token, a graph and a constellation and returns the list of tokens to check next and a list of solvable equation *) |
|
let divide_token (fam, n_star) toklist graph const prob fstar = |
|
let links = List.filter (fun ((i, _),(_, _)) -> i = n_star) graph in |
|
let rec aux l tokl prob_aux star_aux = |
|
match l with |
|
[] -> Some (tokl,prob_aux,star_aux,fam) |
|
| ((i, j),(ri,rj))::tl -> |
|
if fam > (List.length prob_aux) || prob_aux = [] then (* We check if the family number is the same as the number of equations lists in prob. If it's superior, we add a new list in prob instead of filling the first equation list because it means we're treating a new family *) |
|
if Option.is_some (dual_check ri rj) then |
|
aux tl ((fam, j)::tokl) ([(ri, rj)]::prob_aux) ( (( star_filter const ((i, j),(ri,rj)) [] ))::star_aux ) |
|
else None |
|
else |
|
if Option.is_some (solve (link_to_eq ((ri, rj)::(List.nth prob_aux fam))) []) then (* We made sure prob_aux head would not be empty*) |
|
|
|
aux tl ((fam, j)::tokl) (((ri, rj)::(List.hd prob_aux))::(List.tl prob_aux)) ( (( star_filter const ((i, j),(ri,rj)) (List.hd prob_aux) )@(List.hd star_aux))::(List.tl star_aux) ) (*We use List.hd because the current family we're working on should be the current first*) |
|
else |
|
None |
|
in if links = [] then Some (toklist,prob,fstar,fam) |
|
else aux links toklist prob fstar |
|
|
|
(* should be deterministic exec, graph shouldn't be empty, takes a constellation and a list of stars that are gonna be beginning points *) |
|
(* Start_star_list, the second argument, should not be empty*) |
|
let exec const start_star_list = |
|
let const_ext = extends_varname_const const in |
|
let graph = List.flatten (clean_dgraph (dgraph const_ext)) in |
|
let max_fam = List.length start_star_list in |
|
let rec aux (toklist,prob,star,current_fam) = (*toklist is a list of tokens (int of family number and the number of a star), prob is the current list of equations, current_fam is the current family number *) |
|
begin match toklist with |
|
| [] -> |
|
if current_fam = max_fam-1 then star,prob |
|
else aux ([(current_fam+1, List.nth start_star_list (current_fam+1))], prob, star, current_fam+1) |
|
| h::t -> aux (Option.get (divide_token h t graph const_ext prob star )) |
|
end |
|
in if start_star_list = [] then |
|
failwith "star_star_list is empty" |
|
else |
|
let i = List.hd start_star_list |
|
in let (constf, prob_tmp) = aux ([(0,i)],[],[],0) |
|
in let probf = List.rev prob_tmp |
|
in let indexed_final_const = index_constellation constf |
|
in List.map (fun (fam_star, a) -> |
|
let fam_prob = List.nth probf fam_star |
|
in let substit_list = (List.map (fun (i,b) -> (i,term_to_ray b)) (Option.get (solve (link_to_eq fam_prob) []))) |
|
in substit_star (remove_double (star_postfilter a fam_prob)) substit_list) indexed_final_const |