engboris
/
large-star-collider
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

working deterministic exec, push before cleaning code

master
julia 3 years ago
parent
0d10ff76be
commit
ee70571a26
3 changed files with 81 additions and 75 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 126
      ocaml/Resolution.ml
  2. 9
      ocaml/StellarCircuits.ml
  3. 17
      ocaml/Unification.ml

126
ocaml/Resolution.ml
Unescape View File

@ -21,6 +21,9 @@ let guard c x = if c then return x else []
Useful functions Useful functions
======================================== *) ======================================== *)
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 *) (* Convert a pol and an id to a string, adding + or - before the id *)
let pol_to_string pol id = let pol_to_string pol id =
if pol = Pos then "+" ^ id if pol = Pos then "+" ^ id
@ -99,6 +102,25 @@ let rec term_to_ray (term : term) =
| Var id -> (Var(id) : ray) | Var id -> (Var(id) : ray)
| Func(f, r) -> Func(f, Npol, List.map (fun a -> term_to_ray a) r) | 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 Constellation graph
======================================== *) ======================================== *)
@ -123,18 +145,30 @@ 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) | ((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 ;; in aux dg ;;
(* Print a dgraph *) let eq_to_string eq =
let print_dgraph dg =
let rec aux dgl = let rec aux dgl =
match dgl with match dgl with
| [] -> "" | [] -> ""
| h::[] -> (link_to_string h) | ((r1, r2))::[] -> ("(" ^ term_to_string (ray_to_term r1) ^ " = " ^ term_to_string (ray_to_term r2) ^ ")")
| h::t -> (link_to_string h) ^ "\n" ^ aux t | ((r1, r2))::t -> ("(" ^ term_to_string (ray_to_term r1) ^ " = " ^ term_to_string (ray_to_term r2) ^ ")") ^ "\n" ^ (aux t)
in print_string (aux dg);; in aux eq;;
let print_eq eq =
print_string (eq_to_string eq)
let clean_dgraph g = let clean_dgraph g =
List.filter (fun a -> a <> []) 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));;
(* _________ Examples _________ *) (* _________ Examples _________ *)
let make_const_pol pol c = Func (c, pol, []) let make_const_pol pol c = Func (c, pol, [])
let make_const c = make_const_pol Npol c let make_const c = make_const_pol Npol c
@ -157,7 +191,7 @@ let make_const_add n m =
let constellation = make_const_add 1 3 ;; let constellation = make_const_add 1 3 ;;
print_dgraph (dgraph constellation) ;; (*print_dgraph (dgraph constellation) ;;*)
(* token is a couple of a family number and a star number in the constellation *) (* token is a couple of a family number and a star number in the constellation *)
type token = int * int type token = int * int
@ -184,7 +218,7 @@ let link_to_eq prob =
(* removes prob rays from stars *) (* removes prob rays from stars *)
let star_postfilter star prob = let star_postfilter star prob =
let (prob_a, prob_b) = List.split prob in let (prob_a, prob_b) = List.split prob in
List.filter (fun a -> not(List.mem a prob_a || List.mem a prob_b )) star 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 *) (* 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 checked_stars =
@ -194,82 +228,48 @@ let divide_token (fam, n_star) toklist graph const prob fstar checked_stars =
[] -> Some (tokl,prob_aux,star_aux,checked_stars_aux,fam) [] -> Some (tokl,prob_aux,star_aux,checked_stars_aux,fam)
| ((i, j),(ri,rj))::tl -> | ((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 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)])) []) then 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) aux tl ((fam, j)::tokl) ([(ri, rj)]::prob_aux) ( (( star_filter const ((i, j),(ri,rj)) [] ))::star_aux ) (i::checked_stars_aux)
else None else None
else else
if Option.is_some (solve (link_to_eq ((ri, rj)::(List.hd prob_aux))) []) then (* We made sure prob_aux head would not be empty*) 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) ) (i::checked_stars_aux) (*We use List.hd because the current family we're working on should be the current first*)
else None 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) in if links = [] then Some (toklist,prob,fstar,n_star::checked_stars,fam)
else aux links toklist prob fstar checked_stars else aux links toklist prob fstar checked_stars
(* should be deterministic exec, graph shouldn't be empty, takes a constellation and a list of stars that are gonna be beginning points *) (* 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 exec const start_star_list =
let const_ext = extends_varname_const const in let const_ext = extends_varname_const const in
let graph = List.flatten (clean_dgraph (dgraph const_ext)) in let graph = List.flatten (clean_dgraph (dgraph const_ext)) in
let max_fam = List.length start_star_list in let max_fam = List.length start_star_list in
let rec aux (toklist,prob,star,checked_stars,current_fam) = 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 *)
begin match toklist with begin match toklist with
| [] -> (*let gen_token = List.filter (fun ((i,_),(_,_)) -> not( List.mem i checked_stars)) graph in *) | [] -> (*let gen_token = List.filter (fun ((i,_),(_,_)) -> not( List.mem i checked_stars)) graph in *)
if current_fam = max_fam then star,prob 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) 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)) | h::t -> aux (Option.get (divide_token h t graph const_ext prob star checked_stars))
end end
in let ((i,_),(_,_)) = (List.hd graph) (*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 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 let indexed_final_const = index_constellation constf
in List.map (fun (fam_star, a) -> let fam_prob = List.nth probf fam_star in List.map (fun (fam_star, a) ->
in substit_star (star_postfilter a fam_prob) (List.map (fun (i,b) -> (i,term_to_ray b)) (Option.get (solve (link_to_eq fam_prob) [])))) indexed_final_const 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 *) (* test constellation non-cyclique déterministe *)
let test = [ [Func("c", Neg, [x]); x] ; [Func("c", Pos, [Func("f", Npol, [y])]) ; Func("c", Npol, [x]) ] ] ;; let test = [ [Func("c", Neg, [x]); x] ; [Func("c", Pos, [Func("f", Npol, [y])]) ; Func("c", Npol, [x]) ] ] ;;
print_dgraph (dgraph test);; (*print_dgraph (dgraph test);;
exec test ;; exec test ;;*)
(* TODO :
faire un filtre post application, const_filter
*)
(* not flattened graph ver. :
(* 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) graph const =
let rec aux g toklist prob fstar checked_stars =
match g with
| [] -> Some (toklist,prob,fstar,checked_stars,fam)
| h::t -> let links = List.filter (fun ((i, _),(_, _)) -> i = n_star) h in
let rec aux2 l tokl prob2 star2 checked_stars2 =
match l with
| [] -> Some (tokl,prob2,star2,checked_stars2,fam)
| ((i, j),(ri,rj))::tl ->
if fam > (List.length prob2) || prob2 = [] 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 *)
if Option.is_some ((solve (link_to_eq [(ri, rj)])) []) then
aux2 tl ((fam, j)::tokl) ([(ri, rj)]::prob2) ( (( star_filter const ((i, j),(ri,rj)) [] ))::star2 ) (i::checked_stars2)
else None
else
if Option.is_some (solve (link_to_eq ((ri, rj)::(List.hd prob2))) []) then (* *)
aux2 tl ((fam, j)::tokl) (((ri, rj)::(List.hd prob2))::(List.tl prob2)) ( (( star_filter const ((i, j),(ri,rj)) (List.hd prob2) )@(List.hd star2))::(List.tl star2) ) (i::checked_stars2) (*We use List.hd becasue the current family we're working on should be the current first*)
else None
in if links = [] then aux t toklist prob fstar checked_stars else aux2 links toklist prob fstar checked_stars
in aux graph [] [] [] []
(* should be deterministic exec, graph shouldn't be empty *)
let exec const =
let const_ext = extends_varname_const const in
let graph = clean_dgraph (dgraph const_ext) in
let rec aux (toklist,prob,star,checked_stars,current_fam) =
begin match toklist with
| [] -> let gen_token = List.filter (fun ((i,_),(_,_)) -> not( List.mem i checked_stars)) (List.flatten graph) in
if gen_token = [] then star,prob
else let ((i,_),(_,_)) = (List.hd gen_token) in aux ([(current_fam+1,i)],prob,star,checked_stars,current_fam+1)
| h::t -> aux (Option.get (divide_token h graph const_ext))
end
in let ((i,_),(_,_)) = (List.hd (List.hd graph))
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 substit_star (star_postfilter a fam_prob) (List.map (fun (i,b) -> (i,term_to_ray b)) (Option.get (solve (link_to_eq fam_prob) [])))) indexed_final_const
*)

9
ocaml/StellarCircuits.ml
Unescape View File

@ -1,6 +1,6 @@
open Circuits (*open Circuits
open Resolution open Resolution
*)
(* ============================================ (* ============================================
Stellar Circuits Stellar Circuits
============================================ *) ============================================ *)
@ -54,3 +54,8 @@ let prop_logic : constellation = [
[call_cor Pos (make_const "1") (make_const "0") (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")] [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];;

17
ocaml/Unification.ml
Unescape View File

@ -13,12 +13,13 @@ type equation = term * term
let rec term_to_string t = let rec term_to_string t =
match t with match t with
| Var id -> id | Var id -> id
| Func(f, []) -> f
| Func(f, tl) -> f ^ "(" ^ | Func(f, tl) -> f ^ "(" ^
let rec aux2 vl = let rec aux2 vl =
match vl with match vl with
| [] -> "" | [] -> ""
| h::[] -> term_to_string h | h::[] -> term_to_string h
| h::t -> (term_to_string h) ^ "," ^ (aux2 t) | h::t -> (term_to_string h) ^ "," ^ (aux2 t)
in (aux2 tl) ^ ")" in (aux2 tl) ^ ")"
let print_term t = let print_term t =
@ -83,12 +84,12 @@ let rec solve eq sub =
| [] -> Some sub | [] -> Some sub
| (Var(x), term)::t -> if Var(x) = term then (solve t sub) else (elim x term t sub) (* If x = x it's a useless equation *) | (Var(x), term)::t -> if Var(x) = term then (solve t sub) else (elim x term t sub) (* If x = x it's a useless equation *)
| (term, Var(x))::t -> (elim x term t sub) (*It's useless to check if term = Var(x) because it would be the same case as above *) | (term, Var(x))::t -> (elim x term t sub) (*It's useless to check if term = Var(x) because it would be the same case as above *)
| (Func(f, fs), Func(g, gs))::t -> if f = g then (solve ((List.combine fs gs)@t) sub) else None (* If f and g are not equal, the equation can't be solved *) | (Func(f, fs), Func(g, gs))::t -> if f = g then (solve ((List.combine fs gs)@t) sub) else (*failwith (Printf.sprintf "f=%s g=%s" f g)*) None (* If f and g are not equal, the equation can't be solved *)
and elim id term eq sub = and elim id term eq sub =
if occurs id term then None (* If that's the cas, we would have something like x = f(x) which can't be solved *) 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 else let sigma_xy = [(id, term)] in
(solve (List.map (fun (a,b) -> (substit a sigma_xy, substit b sigma_xy)) eq) (sigma_xy@sub)) (* We apply the sigma_xy substitution and we add it to the solution list *) 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 Tests

Write Preview
Loading…
Cancel
Save