diff --git a/ocaml/Resolution.ml b/ocaml/Resolution.ml index 4a49b18..1e5ff1b 100644 --- a/ocaml/Resolution.ml +++ b/ocaml/Resolution.ml @@ -12,6 +12,10 @@ 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) @@ -21,6 +25,11 @@ 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 @@ -30,7 +39,7 @@ let pol_to_string pol id = else if pol = Neg then "-" ^ id else id -(* Convert a ray (which is polarized) to a term *) +(* 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) @@ -121,6 +130,7 @@ let rec const_to_string const = (*print a constellation*) let print_const const = print_string (const_to_string const) + (* ======================================== Constellation graph ======================================== *) @@ -145,6 +155,7 @@ let link_to_string dg = | ((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 @@ -153,14 +164,15 @@ let eq_to_string eq = | ((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 *) +(* Print a dgraph *) let print_dgraph dg = let rec aux dgl = match dgl with @@ -169,38 +181,10 @@ let print_dgraph dg = | h::t -> (link_to_string h) ^ "\n" ^ aux t in print_string (aux (clean_dgraph dg));; -(* _________ Examples _________ *) -let make_const_pol pol c = Func (c, pol, []) -let make_const c = make_const_pol Npol c - -let y = Var("y") -let x = Var("x") -let z = Var("z") -let r = Var("r") -let zero = make_const "0" -let s x = Func("s", Npol, [x]) -let add p x y z = Func("add", p, [x;y;z]) - -(* Convert int to term *) -let rec enat i = - if i = 0 then zero else s (enat (i-1)) - -(* makes the constellation corresponding to an addition *) -let make_const_add n m = - [[add Pos zero y y]; [add Neg x y z; add Pos (s x) y (s z)]; [add Neg (enat n) (enat m) r; r]] - -let constellation = make_const_add 1 3 ;; - -(*print_dgraph (dgraph constellation) ;;*) - -(* token is a couple of a family number and a star number in the constellation *) -type token = int * int -type process = token list - -(* get a star using its number in the list from a constellation *) + (* 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 @@ -215,61 +199,52 @@ let star_filter const ((i, j),(ri,rj)) prob = let link_to_eq prob = List.map (fun (ra, rb) -> (ray_to_term (inv_pol_ray ra)), ray_to_term rb) prob -(* removes prob rays from stars *) +(* 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 checked_stars = +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 checked_stars_aux = + let rec aux l tokl prob_aux star_aux = match l with - [] -> Some (tokl,prob_aux,star_aux,checked_stars_aux,fam) + [] -> 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 (*((solve (link_to_eq [(ri, rj)])) [])*)(dual_check ri rj) then - aux tl ((fam, j)::tokl) ([(ri, rj)]::prob_aux) ( (( star_filter const ((i, j),(ri,rj)) [] ))::star_aux ) (i::checked_stars_aux) + 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*) - let _ = Printf.printf "ri=%s rj=%s \n" (term_to_string (ray_to_term ri)) (term_to_string (ray_to_term rj)) in - 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) ) (i::checked_stars_aux) (*We use List.hd because the current family we're working on should be the current first*) + + 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 - let _ = Printf.printf "equation list= \n %s \n last added equation: \n%s = %s" (eq_to_string((ri, rj)::(List.nth prob_aux fam))) (term_to_string (ray_to_term ri)) (term_to_string (ray_to_term rj)) in None - in if links = [] then Some (toklist,prob,fstar,n_star::checked_stars,fam) - else aux links toklist prob fstar checked_stars + 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*) -(* checked_stars is probabbly now be useless, to be removed*) 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,checked_stars,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 *) + 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 - | [] -> (*let gen_token = List.filter (fun ((i,_),(_,_)) -> not( List.mem i checked_stars)) graph in *) + | [] -> if current_fam = max_fam-1 then star,prob - else aux ([(current_fam+1, List.nth start_star_list (current_fam+1))], prob, star, checked_stars, current_fam+1) - | h::t -> aux (Option.get (divide_token h t graph const_ext prob star checked_stars)) + 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 let ((i,_),(_,_)) = (List.hd graph)*) 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 (constf, prob_tmp) = aux ([(0,i)],[],[],0) in let probf = List.rev prob_tmp - (*in let _ = Printf.printf "prob = %s \n" (eq_to_string (List.hd probf))*) 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 - -(* test constellation non-cyclique déterministe *) -let test = [ [Func("c", Neg, [x]); x] ; [Func("c", Pos, [Func("f", Npol, [y])]) ; Func("c", Npol, [x]) ] ] ;; -(*print_dgraph (dgraph test);; -exec test ;;*) \ No newline at end of file + in substit_star (remove_double (star_postfilter a fam_prob)) substit_list) indexed_final_const \ No newline at end of file diff --git a/ocaml/StellarCircuits.ml b/ocaml/StellarCircuits.ml index 4de4bac..1bb36c4 100644 --- a/ocaml/StellarCircuits.ml +++ b/ocaml/StellarCircuits.ml @@ -1,6 +1,5 @@ -(*open Circuits +open Circuits open Resolution -*) (* ============================================ Stellar Circuits ============================================ *) @@ -53,9 +52,4 @@ let prop_logic : constellation = [ [call_cor Pos (make_const "0") (make_const "1") (make_const "1")]; [call_cor Pos (make_const "1") (make_const "0") (make_const "1")]; [call_cor Pos (make_const "1") (make_const "1") (make_const "1")] -] - -let test2 = (const_of_circuit (make_em_circ 1));; -let testprop = ((const_of_circuit (make_em_circ 1))@[[Func("or", Pos, [Func("0", Npol, []); Func("1", Npol, []); Func("1", Npol, [])])];[Func("neg",Pos, [Func("1", Npol, []); Func("0", Npol, [])])]]);; - -let extest2 = exec test2 [0];; \ No newline at end of file +] \ No newline at end of file diff --git a/ocaml/Unification.ml b/ocaml/Unification.ml index e1877b5..9f6f1a3 100644 --- a/ocaml/Unification.ml +++ b/ocaml/Unification.ml @@ -90,47 +90,3 @@ and elim id term eq sub = if occurs id term then (*failwith (Printf.sprintf "id=%s is in term" id)*) None (* If that's the case, we would have something like x = f(x) which can't be solved *) else let sigma_xy = [(id, term)] in solve (List.map (fun (a,b) -> (substit a sigma_xy, substit b sigma_xy)) eq) ((List.map (fun (i, t) -> (i, substit t sigma_xy)) sub)@sigma_xy) (* We apply the sigma_xy substitution to the equations and the solution list and we add it to the solution list *) - - (* ======================================== - Tests - ======================================== *) -(* -let x = Var("x") -let v = Var("v") -let z = Var("z") -let y = Var("y") - -let f x y z = Func("f", [x; y; z]);; - -let terme = Func("f",[x; v; Func("g",[z; y])]) ;; - -let terme2 = Func("g",[z; Func("h",[x; v; y]); y]) ;; - -let subd = [("x", Func("Malenia",[y])); ("y", Func("Ranni",[z]))];; - - -print_term terme ;; -print_term terme2 ;; - -compare_term terme terme2 ;; -compare_term terme2 terme ;; -compare_term terme terme ;; - -print_term (extends_varname terme "cc") ;; - -occurs "x" terme ;; - -vars terme ;; -apply "x" subd ;; -print_term terme ;; -print_term (substit terme subd) ;; - -let melina = Var("Melina") -let sieg = Var("Sieg") -let hyetta = Var("Hyetta") -let adeline = Var("Adeline") - -let terme3 = Func("f",[ melina ; sieg; Func("g",[Func("h",[hyetta]); adeline])]) ;; - -solve [(terme,terme3)] [] ;; -*) \ No newline at end of file diff --git a/ocaml/main.ml b/ocaml/main.ml new file mode 100644 index 0000000..2a79e96 --- /dev/null +++ b/ocaml/main.ml @@ -0,0 +1,47 @@ +open Resolution +open Circuits +open StellarCircuits + + (* ======================================== + Tests + ======================================== *) + +(* _________ Tests on Resolution _________ *) +let y = Var("y") +let x = Var("x") +let z = Var("z") +let r = Var("r") +let zero = make_const "0" +let s x = Func("s", Npol, [x]) +let add p x y z = Func("add", p, [x;y;z]) + +(* Convert int to term *) +let rec enat i = + if i = 0 then zero else s (enat (i-1)) + +(* makes the constellation corresponding to an addition *) +let make_const_add n m = + [[add Pos zero y y]; [add Neg x y z; add Pos (s x) y (s z)]; [add Neg (enat n) (enat m) r; r]] + +let constellation = make_const_add 1 3 ;; + +print_dgraph (dgraph constellation) ;; + +(* determinist constellation test*) +let test = [ [Func("c", Neg, [x]); x] ; [Func("c", Pos, [Func("f", Npol, [y])]) ; Func("c", Npol, [x]) ] ] ;; +print_dgraph (dgraph test);; +exec test ;; + +(* _________ Tests on exec using Stellar Circuits _________ *) + +(* Constellation of excluded middle without boolean doors *) +let excl_mid_no_prop = (const_of_circuit (make_em_circ 1));; + +(* Constellation of excluded middle with boolean doors *) +let excl_mid_prop = ((const_of_circuit (make_em_circ 1))@[[Func("or", Pos, [Func("0", Npol, []); Func("1", Npol, []); Func("1", Npol, [])])];[Func("neg",Pos, [Func("1", Npol, []); Func("0", Npol, [])])]]);; + +let exec_exmid_noprop = exec excl_mid_no_prop [0];; +(* should return 1*) +let exec_exmid_prop = exec excl_mid_prop [0];; + +print_const exec_exmid_prop;; \ No newline at end of file