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

removed check_star parameter from exec, moved test to main.ml and added comments

master
julia 3 years ago
parent
ee70571a26
commit
d05913111d
4 changed files with 82 additions and 110 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. 83
      ocaml/Resolution.ml
  2. 8
      ocaml/StellarCircuits.ml
  3. 44
      ocaml/Unification.ml
  4. 47
      ocaml/main.ml

83
ocaml/Resolution.ml
Unescape View File

@ -12,6 +12,10 @@ type star = ray list
type constellation = star list type constellation = star list
type graph = (int * int) * (ray * ray) 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 *) (* List monad *)
let return x = [x] (*plongement dans la monade de liste*) let return x = [x] (*plongement dans la monade de liste*)
let (>>=) xs k = List.flatten (List.map k xs) 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 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 = let remove_double list =
List.fold_left (fun l a -> if not(List.mem a l) then (a::l) else l) [] 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 if pol = Neg then "-" ^ id
else 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 = let rec ray_to_term r =
match r with match r with
| Var id -> (Var(id) : term) | Var id -> (Var(id) : term)
@ -121,6 +130,7 @@ let rec const_to_string const =
(*print a constellation*) (*print a constellation*)
let print_const const = let print_const const =
print_string (const_to_string const) print_string (const_to_string const)
(* ======================================== (* ========================================
Constellation graph 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) | ((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 ;;
(* Convert an equation list (which is a link without the index) to a string *)
let eq_to_string eq = let eq_to_string eq =
let rec aux dgl = let rec aux dgl =
match dgl with match dgl with
@ -153,10 +164,11 @@ 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) | ((r1, r2))::t -> ("(" ^ term_to_string (ray_to_term r1) ^ " = " ^ term_to_string (ray_to_term r2) ^ ")") ^ "\n" ^ (aux t)
in aux eq;; in aux eq;;
(* print an equation list*)
let print_eq eq = let print_eq eq =
print_string (eq_to_string eq) print_string (eq_to_string eq)
(* remove empty list from a dgraph *)
let clean_dgraph g = let clean_dgraph g =
List.filter (fun a -> a <> []) g List.filter (fun a -> a <> []) g
@ -169,34 +181,6 @@ let print_dgraph dg =
| h::t -> (link_to_string h) ^ "\n" ^ aux t | h::t -> (link_to_string h) ^ "\n" ^ aux t
in print_string (aux (clean_dgraph dg));; 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 = let get_star const i =
List.nth const i List.nth const i
@ -215,61 +199,52 @@ let star_filter const ((i, j),(ri,rj)) prob =
let link_to_eq prob = let link_to_eq prob =
List.map (fun (ra, rb) -> (ray_to_term (inv_pol_ray ra)), ray_to_term rb) 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 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) && not(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 =
let links = List.filter (fun ((i, _),(_, _)) -> i = n_star) graph in 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 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 -> | ((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)])) [])*)(dual_check ri rj) then 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 ) (i::checked_stars_aux) aux tl ((fam, j)::tokl) ([(ri, rj)]::prob_aux) ( (( star_filter const ((i, j),(ri,rj)) [] ))::star_aux )
else None else None
else 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*) 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 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 None
in if links = [] then Some (toklist,prob,fstar,n_star::checked_stars,fam) in if links = [] then Some (toklist,prob,fstar,fam)
else aux links toklist prob fstar checked_stars 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 *) (* 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*) (* 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) = (*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 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 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, 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 ))
end end
(*in let ((i,_),(_,_)) = (List.hd graph)*)
in if start_star_list = [] then in if start_star_list = [] then
failwith "star_star_list is empty" failwith "star_star_list is empty"
else else
let i = List.hd start_star_list 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) -> in List.map (fun (fam_star, a) ->
let fam_prob = List.nth probf fam_star 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 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 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 ;;*)

8
ocaml/StellarCircuits.ml
Unescape View File

@ -1,6 +1,5 @@
(*open Circuits open Circuits
open Resolution open Resolution
*)
(* ============================================ (* ============================================
Stellar Circuits Stellar Circuits
============================================ *) ============================================ *)
@ -54,8 +53,3 @@ 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];;

44
ocaml/Unification.ml
Unescape View File

@ -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 *) 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) ((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 *) 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)] [] ;;
*)

47
ocaml/main.ml
Unescape View File

@ -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;;
Write Preview
Loading…
Cancel
Save