facile-1.1/0000755005005300001440000000000010117553006013375 5ustar barnierusers00000000000000facile-1.1/src/0000755005005300001440000000000010117553006014164 5ustar barnierusers00000000000000facile-1.1/src/Makefile0000644005005300001440000000410710117553006015626 0ustar barnierusers00000000000000# $Id: Makefile,v 1.73 2004/09/01 12:33:49 barnier Exp $ OCAMLC = ocamlc.opt -g OCAMLMLI = ocamlc.opt OCAMLOPT = ocamlopt -unsafe -noassert -inline 10 OCAMLDEP = ocamldep INCLUDES = OPTOPT = OCAMLLIB := $(shell echo `ocamlc -where`) FACILELIB = $(OCAMLLIB)/facile CSTR= fcl_debug.ml fcl_misc.ml fcl_domain.ml fcl_setDomain.ml fcl_float.ml fcl_stak.ml fcl_data.ml fcl_cstr.ml fcl_var.ml fcl_invariant.ml fcl_reify.ml fcl_boolean.ml fcl_linear.ml fcl_nonlinear.ml fcl_expr.ml fcl_arith.ml fcl_conjunto.ml fcl_goals.ml fcl_fdArray.ml fcl_gcc.ml fcl_opti.ml fcl_alldiff.ml fcl_sorting.ml fcl_interval.ml fcl_genesis.ml facile.ml # fcl_binary.ml fcl_ac6.ml CSTRCMO = $(CSTR:.ml=.cmo) CSTRCMX = $(CSTR:.ml=.cmx) # Default target: libraries and toplevel all : facile.cma facile.cmxa facile # Libraries facile.cma : $(CSTRCMO) $(OCAMLC) -o $@ -a $(CSTRCMO) facile.cmxa : $(CSTRCMX) $(OCAMLOPT) -o $@ -a $(CSTRCMX) # Version of the library to be linked with the -p (profiler) option facile.p.cmxa : $(CSTR) rm -fr $(CSTRCMX) make facile.cmxa OPTOPT=-p rm -fr $(CSTRCMX) mv facile.cmxa $@ mv facile.a facile.p.a # Toplevel (to be run with the "-I +facile" option) facile : facile.cma ocamlmktop -o $@ facile.cma # Experimental: to get inlining of functors using preprocessing: # Does not work with many modules (e.g. containing class expressions facile.exp.cmxa : $(CSTR) rm -fr $(CSTRCMX) make fcl_stak.cmx fcl_cstr.cmx fcl_inv.cmx fcl_reify.cmx fcl_arith.cmx fcl_goals.cmx fcl_fdArray.cmx fcl_gcc.cmx fcl_alldiff.cmx fcl_sorting.cmx fcl_interval.cmx facile.cmx make facile.cmxa OPTOPT="-pp inline_functors" rm -fr $(CSTRCMX) mv facile.cmxa $@ mv facile.a facile.exp.a .SUFFIXES: .SUFFIXES: .ml .mli .mly .mll .cmi .cmo .cmx .p.cmx .s .ml.cmo : $(OCAMLC) $(INCLUDES) $(INCLUDES) -c $< .mli.cmi : $(OCAMLMLI) $(INCLUDES) -c $< .ml.cmx : $(OCAMLOPT) $(OPTOPT) $(INCLUDES) -c $< .ml.s : $(OCAMLOPT) $(OPTOPT) $(INCLUDES) -S -c $< .mly.ml : ocamlyacc $< .mll.ml : ocamllex $< clean: \rm -f *.cm* *.annot *.o *.a *~ .depend facile .depend: $(OCAMLDEP) $(INCLUDES) *.mli *.ml > $@ include .depend facile-1.1/src/fcl_debug.ml0000644005005300001440000000236610117553006016437 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) let level = ref (try Sys.getenv "FACILEDEBUG" with Not_found -> "");; let log = ref stdout;; let call lev f = assert(if !level = "*" || String.contains !level lev then begin f !log ;flush !log end; true);; let internal_error mesg = failwith (Printf.sprintf "Internal error (%s). Please send a bug report to facile@recherche.enac.fr" mesg) let fatal_error mesg = failwith (Printf.sprintf "Fatal error: %s" mesg) let print_in_assert pred mesg = pred || (Printf.fprintf stderr "Fatal error: %s" mesg; flush stderr; false) facile-1.1/src/fcl_misc.ml0000644005005300001440000000563210117553006016303 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_misc.ml,v 1.15 2004/05/10 12:51:19 barnier Exp $ *) let last_and_length l = let rec ll n = function [] -> Fcl_debug.internal_error "Fcl_misc.last_and_length: empty list" | [x] -> (x, n) | _::xs -> ll (n+1) xs in ll 1 l let extremum_array comp f xs = let extrem = ref 0 and extrem_v = ref (f xs.(0)) in for i = 1 to Array.length xs - 1 do let fxi = f xs.(i) in if comp fxi !extrem_v then begin extrem := i; extrem_v := fxi end done; (!extrem, !extrem_v) let arg_min_array t = extremum_array (<) t let arg_max_array t = extremum_array (>) t let gen_int_fun () = let count = ref (-1) in fun () -> incr count; !count let int_overflow x = Fcl_debug.print_in_assert (float max_int > x && float min_int < x) "integer overflow\n" module Operators = struct let ( * ) x y = assert (int_overflow (float x *. float y)); x * y let (+) x y = assert (int_overflow (float x +. float y)); x + y let (-) x y = assert (int_overflow (float x -. float y)); x - y let (+) = Pervasives.(+) let (-) = Pervasives.(-) let ( * ) = Pervasives.( * ) let (=+) x y = x := !x + y let (=+.) x y = x := !x +. y let min (a : int) b = if a <= b then a else b let max (a : int) b = if a <= b then b else a let sign x = if x < 0 then (-1) else if x = 0 then 0 else 1 let (/+) x y = let xy = x / y in if x mod y = 0 then xy else if sign x * sign y >= 0 then xy + 1 else xy let (/-) x y = let xy = x / y in if x mod y = 0 then xy else if sign x * sign y >= 0 then xy else xy - 1 end let rec iter f n z = if n = 0 then z else f (iter f (n-1) z) let rec goedel f n z = if n = 0 then z else f (n-1) (goedel f (n-1) z) let flags = (ref [] : (string * bool ref) list ref) let assoc_or_add n = try List.assoc n !flags with Not_found -> let f = ref false in flags := (n, f) :: !flags; f let protect name f = let already_in = assoc_or_add name in if !already_in then Fcl_debug.fatal_error (Printf.sprintf "%s not reentrant" name); already_in := true; try let x = f () in already_in := false; x with exc -> already_in := false; raise exc facile-1.1/src/fcl_domain.ml0000644005005300001440000003002210117553006016606 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_domain.ml,v 1.32 2004/06/24 16:34:56 barnier Exp $ *) (* Un domaine est une liste triée d'intervalles et de valeurs Sont attachés au domaine sa taille et son maximum (significatif si size<>0) *) open Fcl_misc.Operators type elt = int type elt_list = N | C of int * int * elt_list let rec list_iter f = function N -> () | C(x,y,l) -> f x y; list_iter f l type t = {domain : elt_list; size : int; max : int; min : int} let empty = { domain=N; size=0; max=min_int; min=max_int} let boolean = { domain=C(0,1,N); size=2; max=1; min=0} let iter f = function {domain = l} -> list_iter (fun mi ma -> for i = mi to ma do f i done) l let interval_iter f {domain = l} = list_iter f l let fprint_elt c x = Printf.fprintf c "%d" x let fprint c d = let print_one mi ma = if mi <> ma then Printf.fprintf c "%d-%d" mi ma else Printf.fprintf c "%d" mi in let rec pr = function N -> Printf.fprintf c "]" | C(x,y,xs) -> print_one x y; match xs with N -> Printf.fprintf c "]" | _ -> Printf.fprintf c ";"; pr xs in Printf.fprintf c "["; pr d.domain let sprint d = let print_one = fun mi ma -> if mi <> ma then Printf.sprintf "%d-%d" mi ma else Printf.sprintf "%d" mi in let rec pr = function N -> "]" | C(x,y,xs) -> print_one x y ^ match xs with N -> "]" | _ -> ";" ^ pr xs in "[" ^ pr d.domain let c mi ma reste = C(mi,ma,reste) let cons mi ma reste = if mi <= ma then C(mi,ma,reste) else reste let process_max l = let rec pm m = function N -> m | C(_, x, es) -> pm x es in pm min_int l let get_min = function N -> Fcl_debug.internal_error "Domain.get_min" | C(m, _,_) -> m let process_size l = let rec ps s = function N -> s | C(mi,ma,es) -> ps (ma-mi+1 + s) es in ps 0 l let size d = d.size let min d = assert (d.domain <> N); d.min let max d = assert (d.domain <> N); d.max let min_max d = assert (d.domain <> N); (d.min, d.max) let member x = function {domain = l;max = m} -> x = m || (x < m && let rec member = function N -> false | C(mi,ma,es) -> if x <= ma then x >= mi else member es in member l) let mem = member let rec remove_sorted_duplicates = function [] -> [] | (x : int)::(y::_xs as tail) when x=y -> remove_sorted_duplicates tail | x::xs -> x :: remove_sorted_duplicates xs let unsafe_create d = match d with [] -> empty | x::xs -> let max,size = Fcl_misc.last_and_length d in let rec make mi last = function [] -> C(mi,last,N) | n::ns -> assert(Fcl_debug.print_in_assert (n > last) "Bad usage of \"Domain.unsafe_create\""); if n = last+1 then make mi (last+1) ns else C(mi,last,make n n ns) in {domain=make x x xs;size=size;max=max; min = x} let int_compare (x : int) y = if x < y then (-1) else if x = y then 0 else 1 let create d = let d = List.sort int_compare d in let d = remove_sorted_duplicates d in unsafe_create d let interval_unsafe min max = {domain=C(min,max,N);size=max-min+1;max=max; min = min} let interval min max = if min > max then invalid_arg "Domain.interval: min > max"; interval_unsafe min max let int = interval_unsafe (min_int/3) (max_int/3) let is_empty d = d.size = 0 let remove x d = match d with {domain = l;max = m; size = s; min = min_d} -> if x < min_d or x > m then d else begin let rec remo = function N -> raise Not_found | C(mi,ma,es) -> if x <= ma then if x >= mi then (cons mi (x-1) (cons (x+1) ma es)) else raise Not_found else C(mi,ma,remo es) in try let newl = remo l in if newl = N then empty else let newm = if x = m then process_max newl else m in let result = {domain=newl;max=newm;size=s-1; min=get_min newl} in result with Not_found -> d end (* Removes values stricly less than x *) let remove_low x = function {domain = l;max = m; size = s;min=min_d} as d -> if x <= min_d then d else if x = m then {domain=C(m,m,N);max=m;size=1;min=m} else if x > m then empty else if s = m - min_d + 1 then interval_unsafe x m else (* Something is removed and the max remains *) let rec rem_low size = function N -> Fcl_debug.internal_error "remove_low" | C (mi,ma,es) as ees -> if x <= ma then if x > mi then (c x ma es, size - (x-mi)) else (ees, size) else rem_low (size-(ma-mi+1)) es in let (newl, new_size) = rem_low s l in {domain = newl; max = m; size = new_size; min=get_min newl} (* Removes values stricly greater than x *) let remove_up x ({domain = l;max = m; size = s;min=min_d} as d) = if x >= m then d else if x < min_d then empty else if s = m - min_d + 1 then interval_unsafe min_d x else let rec rem = function N -> Fcl_debug.internal_error "Domain.remove_up" | C (mi,ma,es) -> if mi <= x then if x < ma then c mi x N else C (mi, ma, rem es) else N in let newl = rem l in {domain = newl; max = process_max newl; size = process_size newl;min=min_d} let remove_low_up low up d = remove_up up (remove_low low d) let remove_closed_inter min max ({domain = l;max = ma; min=mi} as d) = if min > max then d else if min <= mi then remove_low (max+1) d else if max >= ma then remove_up (min-1) d else (* mi < min <= max < ma *) let rec rem = function N -> N | C(mi,ma,es) -> if min <= mi & ma <= max then rem es else if mi <= max & max <= ma or mi <= min & min <= ma then cons mi (min-1) (cons (max+1) ma (rem es)) else C(mi,ma,rem es) in let newl = rem l in {d with domain = newl; size = process_size newl} let values d = let rec enum_and_conc mi ma tail = if mi > ma then tail else mi::(enum_and_conc (mi+1) ma tail) in let rec loop = function N -> [] | C(mi,ma,es) -> enum_and_conc mi ma (loop es) in loop d.domain let intersection ({domain=l1;size=s1} as dom1) ({domain=l2;size=s2} as dom2) = let rec loop l1 l2 = match l1, l2 with N, _ | _, N -> N | C(mi1,ma1,e1s) as c1, (C(mi2,ma2,e2s) as c2)-> let mi = Fcl_misc.Operators.max mi1 mi2 and ma = Fcl_misc.Operators.min ma1 ma2 in cons mi ma (if ma2 > ma1 then loop e1s c2 else loop c1 e2s) in if dom1 == dom2 then dom1 else match loop l1 l2 with N -> empty | l -> let s = process_size l in if s = s1 then dom1 else if s = s2 then dom2 else {domain=l;size=s; max=process_max l;min=get_min l} (* On suppose que l'un des domaines est contenu dans l'autre. *) let difference ({domain = l1} as d1) {domain = l2; size = s2} = let rec loop l1 l2 = match l1, l2 with l, N -> l | C(mi1, ma1, e1s), C(mi2, ma2, e2s) -> if ma1 < mi2 then C(mi1, ma1, loop e1s l2) else cons mi1 (mi2 - 1) (loop (cons (ma2 + 1) ma1 e1s) e2s) | N, C(_, _, _) -> invalid_arg "Domain.difference" in if s2 = 0 then d1 else match loop l1 l2 with N -> empty | l -> {domain=l;size=process_size l; max=process_max l;min=get_min l} let diff s1 s2 = difference s1 (intersection s1 s2) let union d1 d2 = let rec loop l1 l2 = match l1, l2 with N, _ -> l2 | _, N -> l1 | C(mi1,ma1,r1), C(mi2,ma2,r2) -> if ma1 < mi2 - 1 then C(mi1,ma1,loop r1 l2) else if ma2 < mi1 - 1 then C(mi2,ma2,loop l1 r2) else if ma1 > ma2 then loop (C(Fcl_misc.Operators.min mi1 mi2, ma1, r1)) r2 else loop (C(Fcl_misc.Operators.min mi1 mi2, ma2, r2)) r1 in match loop d1.domain d2.domain with N -> empty | l -> {domain=l;size=process_size l; max=process_max l;min=get_min l} let add x d = union (create [x]) d let remove_min d = match d.domain with N -> invalid_arg "Domain.remove_min : empty domain" | C(mi,ma,xs) when mi = ma -> begin match xs with N -> empty | C(new_mi,_,_) -> {domain=xs;max=d.max;size=d.size-1;min=new_mi} end | C(mi,ma,xs) -> let new_mi = mi + 1 in {domain=C(new_mi,ma,xs);max=d.max;size=d.size-1;min=new_mi} let remove_max d = let rec loop = function N -> invalid_arg "Domain.remove_max : empty domain" | C(mi, ma, N) -> assert(ma = d.max); cons mi (ma-1) N | C(mi, ma, xs) -> C(mi, ma, loop xs) in match loop d.domain with N -> empty | l -> {domain=l; size = d.size - 1; max=process_max l; min = d.min} let included d1 d2 = let rec loop l1 l2 = match l1, l2 with N, _ -> true | _, N -> false | C(mi1,ma1,r1), C(mi2,ma2,r2) -> mi1 >= mi2 && ma1 <= ma2 && loop r1 l2 || loop l1 r2 in d1.size <= d2.size && d1.max <= d2.max && loop d1.domain d2.domain let minus {domain=d; size=s; max=m;min=min_dom} = let rec loop l = function N -> l | C(x, y, r) -> loop (C (-y,-x, l)) r in {domain = loop N d; size = s; max = - min_dom; min = - m} let plus ({domain=d; size=s; max=m;min=min_dom} as dom) b = if b = 0 then dom else let rec loop = function N -> N | C(x, y, r) -> C(x+b, y+b, loop r) in {domain = loop d; size = s; max = m + b; min = min_dom+b} (* not tested *) let times ({domain=d; size=s; max=m;min=min_dom} as dom) = function 1 -> dom | 0 -> {domain = C(0, 0, N); size = 1; max = 0; min = 0} | k when k > 0 -> let rec loop = function N -> N | C(x, y, r) -> C(k*x, k*y, loop r) in {domain = loop d; size = k*s; max = k*m; min = k*min_dom} | k when k < 0 -> let rec loop l = function N -> l | C(x, y, r) -> loop (C (k*y, k*x, l)) r in {domain = loop N d; size = k*s; max = k*min_dom; min = k*m} | _ -> Fcl_debug.internal_error "times" let smallest_geq {domain=d; max=maxi} c = let rec loop = function N -> Fcl_debug.internal_error "first_geq_value" | C(x, y, r) -> if x >= c then x else if y >= c then c else loop r in if maxi < c then raise Not_found else if maxi = c then c else loop d let greatest_leq {domain=d; max=maxi; min=mini} c = let rec loop last = function N -> Fcl_debug.internal_error "first_leq_value" | C(x, y, r) -> if x > c then last else if y < c then loop y r else c in if mini > c then raise Not_found else if maxi < c then maxi else loop mini d let largest_hole_around {domain=d; max=maxi; min=mini} c = let rec loop last = function N -> Fcl_debug.internal_error "largest_hole_around" | C(x, y, r) -> if c < x then (last, x) else if y < c then loop y r else (c, c) in if mini <= c && c <= maxi then if c = maxi then (c, c) else loop mini d else raise Not_found let choose order d = if size d = 0 then raise Not_found else let best = ref (min d) in iter (fun x -> if order x !best then best := x) d; !best let strictly_inf (x:int) y = x < y let compare_elt (x : int) y = compare x y let compare d1 d2 = let rec loop = function N, N -> 0 | N, _ -> -1 | _, N -> failwith "Fcl_domain.compare" | C(x1, y1, l1), C(x2, y2, l2) -> let cx = compare x1 x2 in if cx = 0 then let cy = compare y2 y1 in if cy = 0 then loop (l1, l2) else cy else cx in let cs = compare d1.size d2.size in if cs = 0 then loop (d1.domain, d2.domain) else cs let disjoint {domain=l1; max=ma1} {domain=l2; max=ma2} = let rec loop l1 l2 = match l1, l2 with (N, _ | _, N) -> true | C(mi1,ma1,e1s) as c1, (C(mi2,ma2,e2s) as c2)-> let mi = Fcl_misc.Operators.max mi1 mi2 and ma = Fcl_misc.Operators.min ma1 ma2 in mi > ma && if ma2 > ma1 then loop e1s c2 else loop c1 e2s in (* if l1 and l2 are empty: max1 = max2 *) l1 = N || l2 = N || (ma1 <> ma2 && loop l1 l2) facile-1.1/src/fcl_setDomain.ml0000644005005300001440000000535610117553006017276 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_setDomain.ml,v 1.1 2004/08/09 14:40:01 barnier Exp $ *) (* Renaming of Fcl_domain *) module S = struct include Fcl_domain let subset = included let cardinal = size let choose = min let max_elt = max let min_elt = min let elements = values let equal x y = x = y let inter = intersection let singleton x = create [x] end type elt = S.t type t = { glb : elt; lub : elt} let empty = {glb = S.empty; lub = S.empty} let unsafe_interval glb lub = assert(S.subset glb lub); { glb = glb; lub = lub } let interval glb lub = if not (S.subset glb lub) then invalid_arg "SetDomain.interval: min > max"; { glb = glb; lub = lub } let elt_of_list l = List.fold_right S.add l S.empty let size d = S.cardinal d.lub - S.cardinal d.glb + 1 let min s = s.glb let max s = s.lub let min_max d = (min d, max d) let mem s d = S.subset d.glb s && S.subset s d.lub let included d1 d2 = S.subset d2.glb d1.glb && S.subset d1.lub d2.lub (* EXPONENTIAL *) let iter f d = let diff = S.diff d.lub d.glb in let rec loop current possibles = if S.is_empty possibles then f current else let x = S.choose possibles in let rest = S.remove x possibles in loop (S.add x current) rest; loop current rest in loop d.glb diff (* EXPONENTIAL *) let values d = let l = ref [] in iter (fun x -> l := x :: !l) d; !l open Printf let fprint_elt c s = fprintf c "{ "; S.iter (fun i -> fprintf c "%d " i) s; fprintf c "}" let fprint c d = fprint_elt c d.glb; fprintf c ".."; fprint_elt c d.lub let intersection = S.inter let strictly_inf a b = S.cardinal a < S.cardinal b let compare_elt = S.compare let remove_low x d = if S.subset x d.glb then d else if S.subset d.lub x then empty else if S.subset x d.lub then {glb = x; lub = d.lub} else Fcl_debug.fatal_error "Setdomain.remove_low" let remove_up x d = if S.subset d.lub x then d else if S.subset x d.glb then empty else if S.subset d.glb x then {glb = d.glb; lub = x} else Fcl_debug.fatal_error "Setdomain.remove_up" facile-1.1/src/fcl_float.ml0000644005005300001440000000337010117553006016452 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_float.ml,v 1.3 2003/06/11 14:43:58 barnier Exp $ *) let epsilon = 1e-3 type elt = float type t = { min : float; max : float } let fprint_elt c x = Printf.fprintf c "%.3f(%f)" x epsilon let fprint c x = Printf.fprintf c "%.3f..%.3f" x.min x.max let size x = truncate ((x.max -. x.min) /. epsilon) let min x = x.min let max x = x.max let min_max x = (x.min, x.max) let mem x f = f.min < x && x < f.max let interval x y = if (y -. x) /. epsilon >= 2. ** 30. then Fcl_debug.fatal_error "FloatDomain.interval: range too big"; { min = x ; max = y } let included x y = y.min < x.min && x.max < y.max let strictly_inf x y = x < y let zero x = abs_float x < epsilon let compare_elt = compare (* ca va pas du tout : il faudrait un constructeur pour le cas nul *) let empty = {min = max_float; max = min_float} let remove_low x d = if x < d.min then d else if d.max < x then empty else {min = x; max = d.max} let remove_up x d = if x > d.max then d else if d.min > x then empty else {min = d.min; max = x} facile-1.1/src/fcl_stak.ml0000644005005300001440000001044010117553006016303 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_stak.ml,v 1.23 2004/07/30 10:37:13 barnier Exp $ *) type gl = { name : string; call : unit -> gl option } type level = int let older = ((<=) : level -> level -> bool) exception Empty_stack exception Level_not_found of int type cont = Alive of gl list | Cut type lev = { level: level; mutable success: cont; mutable failure: stack; (* mutability only used by cut_bottom *) last_level : stack } and stack = Level of lev | Empty | Trail of (unit -> unit) * stack let gen_int = Fcl_misc.gen_int_fun () let stack = ref Empty let top_level = ref !stack let nb_levels = ref 0 let nb_choice_points = ref 0 let reset () = stack := Empty; top_level := Empty; nb_levels := 0 let bottom_level = gen_int () let save x = let l = gen_int () in stack := Level {level=l; success=Alive x; failure = !stack; last_level = !top_level}; top_level := !stack; incr nb_levels; incr nb_choice_points; l let level () = let rec c = function Level {success=Cut; last_level=st} -> c st | Level {level=l} -> l | Empty -> bottom_level | Trail (_, _) -> Fcl_debug.internal_error "Stak.level" in c !top_level let levels () = let rec c = function Level {success=Cut; last_level=st} -> c st | Level {last_level=st; level=l} -> l :: c st | Empty -> [bottom_level] | Trail (_, _) -> Fcl_debug.internal_error "Stak.level" in c !top_level let backtrack () = let rec bt = function Level {success=Cut; failure=s} -> bt s (* level was cut *) | Level {success=Alive x; failure=s; last_level=l} -> stack := s; top_level := l; decr nb_levels; x | Empty -> reset (); raise Empty_stack | Trail (undo, s) -> undo (); bt s in bt !stack let backtrack_all () = let rec bt = function Level {failure=s} -> bt s | Empty -> reset () | Trail (undo, s) -> undo (); bt s in bt !stack let size () = let rec count n = function Level {failure=s} -> count n s | Empty -> n | Trail (_undo, s) -> count (n+1) s in count 0 !stack let depth () = !nb_levels let trail undo = if !stack <> Empty then stack := Trail (undo, !stack) let cut level = if level = bottom_level then reset () else let rec c to_cut = function Level {level=l} when l = level -> List.iter (fun ll -> ll.success <- Cut) to_cut; nb_levels := !nb_levels - List.length to_cut | Level {success=Cut; last_level=last} -> c to_cut last | Level ({last_level=last} as ll) -> Fcl_debug.call 'S' (fun f -> Printf.fprintf f "cut %d-1\n" !nb_levels); c (ll :: to_cut) last | Empty -> raise (Level_not_found level) | Trail _ -> Fcl_debug.internal_error "cut" in c [] !top_level let cut_bottom level = if level <> bottom_level then let rec c = function Level ({level=l} as ll) when l = level -> ll.failure <- Empty; ll.success <- Cut | Level {last_level=last} -> incr nb_levels; c last | Empty -> raise (Level_not_found level) | Trail _ -> Fcl_debug.internal_error "cut_bottom" in nb_levels := 0; c !top_level type 'a ref = {mutable contents : 'a; mutable timestamp : int} let get x = x.contents let unsafe_set r x = r.contents <- x let ref x = {contents = x; timestamp = level ()} let set refb value = let {contents = old; timestamp = os } = refb in refb.contents <- value; match !top_level with Level {level=l} when os <> l -> refb.timestamp <- l; assert(!stack <> Empty); stack := Trail ((fun () -> refb.contents <- old), !stack) | _ -> () exception Fail of string let fail x = raise (Fail x) let nb_choice_points () = !nb_choice_points facile-1.1/src/fcl_data.ml0000644005005300001440000000262710117553006016262 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) module Array = struct let set t i v = let old = t.(i) in t.(i) <- v; Fcl_stak.trail (fun () -> t.(i) <- old) end module Hashtbl = struct type ('a, 'b) t = ('a, 'b) Hashtbl.t let create = Hashtbl.create let get h = h let add h k d = Hashtbl.add h k d; Fcl_stak.trail (fun () -> Hashtbl.remove h k) let remove h k = let d = Hashtbl.find h k in Hashtbl.remove h k; Fcl_stak.trail (fun () -> Hashtbl.add h k d) let find = Hashtbl.find let replace h k d = let od = Hashtbl.find h k in Hashtbl.replace h k d; Fcl_stak.trail (fun () -> Hashtbl.replace h k od) let mem = Hashtbl.mem let iter = Hashtbl.iter let fold = Hashtbl.fold end facile-1.1/src/fcl_cstr.ml0000644005005300001440000002136610117553006016325 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_cstr.ml,v 1.43 2004/09/03 13:23:11 barnier Exp $ *) open Printf exception DontKnow type priority = int let nb_priorities = 3 let immediate = 0 let normal = 1 let later = 2 type t = { id : int; name: string; priority : priority; solved : bool array; woken : bool array; nb_solved : int Fcl_stak.ref; fprint : out_channel -> unit; update : int -> unit; init : unit -> unit; check : unit -> bool; delay : t -> unit; not : unit -> t } let gen_int = Fcl_misc.gen_int_fun () let array_set_true t i = t.(i) <- true; Fcl_stak.trail (fun () -> t.(i) <- false) let create ?(name = "anonymous") ?(nb_wakings = 1) ?fprint ?(priority = normal) ?init ?check ?not update delay = if nb_wakings < 1 then begin let msg = "Cstr.create: nb_wakings must be greater or equal to 1" in Fcl_debug.fatal_error msg end; let solved = Array.create nb_wakings false and nb_solved = Fcl_stak.ref 0 in let update i = if update i then if Pervasives.not solved.(i) then begin Fcl_stak.set nb_solved (Fcl_stak.get nb_solved + 1); array_set_true solved i end in { id = gen_int (); name = name; priority = priority; update = update; delay = delay; solved = solved; woken = Array.create nb_wakings false; nb_solved = nb_solved; fprint = (match fprint with Some f -> f | None -> fun c -> fprintf c "%s" name); init = (match init with Some i -> i (* For not breaking constraints that don't use waking ids and rely on being woken at post time. If update must not be called at post time (e.g. because it is suspended to on_subst and the code rely on the fact that the variable really is instantiated) and waking ids are not used, init must be defined. *) | None when nb_wakings = 1 -> fun () -> ignore (update 0) (* otherwise we do nothing *) | _ -> fun () -> ()); check = (match check with Some c -> c | None -> fun () -> Fcl_debug.fatal_error (name ^ ": check callback undefined")); not = (match not with Some n -> n | None -> fun () -> Fcl_debug.fatal_error (name ^ ": not callback undefined")) } let fprint chan ct = Printf.fprintf chan "%d: " ct.id; ct.fprint chan let self_delay c = c.delay let check c = c.check () let solved c = c.solved let is_solved ct = Fcl_stak.get ct.nb_solved = Array.length ct.woken let queue = Array.create nb_priorities [] and already_in_wake = ref false and next_priority = ref nb_priorities let reset_queue () = for i = 0 to nb_priorities -1 do queue.(i) <- [] done; next_priority := nb_priorities; already_in_wake := false;; let assert_empty_queue () = assert( try for i = 0 to nb_priorities -1 do if queue.(i) <> [] then raise Exit done; !next_priority = nb_priorities && not !already_in_wake with Exit -> false);; exception Wake_all let wake_all () = if not !already_in_wake then begin already_in_wake := true; try while !next_priority < nb_priorities do match queue.(!next_priority) with [] -> incr next_priority | (c, i) :: cs -> queue.(!next_priority) <- cs; Fcl_debug.call 'c' (fun s -> fprintf s "%s(%d)#update(%d)\n" c.name c.id i); if not c.solved.(i) then c.update i; Fcl_debug.call 'c' (fun s -> fprintf s "%s(%d)#updated(%d)%s\n" c.name c.id i (if is_solved c then "*" else "")); c.woken.(i) <- false (* not trailed *) done; already_in_wake := false (* To avoid being in a state where already_in_wake = true after an uncaught exception during the while loop. *) with e -> reset_queue (); raise e end let schedule_one_cstr ((cstr, i) as c) = Fcl_debug.call 'c' (fun s -> fprintf s "%s(%d)#scheduled(%d) - (woken:%b, solved:%b)\n" cstr.name cstr.id i cstr.woken.(i) cstr.solved.(i)); if not (cstr.woken.(i) || cstr.solved.(i)) then begin Fcl_debug.call 'c' (fun s -> fprintf s "wake %d(%d): " cstr.id i; cstr.fprint s; fprintf s "\n"); let p = cstr.priority in queue.(p) <- c :: queue.(p); next_priority := Fcl_misc.Operators.min !next_priority p; array_set_true cstr.woken i end (* Management of active contraints *) module Store = struct let size_store = 1024 let store = ref (Weak.create size_store) let next_free = ref 0 let compress_or_extend () = let size = Weak.length !store in let rec look_for_free from to_ = if to_ < size then match Weak.get !store to_ with None -> copy (max (to_ + 1) from) to_ | Some _ -> look_for_free from (to_ + 1) else size (* Full *) and copy from to_ = assert(from > to_); if from < size then match Weak.get !store from with None -> copy (from + 1) to_ | some_c -> Weak.set !store to_ some_c; Weak.set !store from None; look_for_free (from + 1) (to_ + 1) else to_ in next_free := look_for_free 0 0; if !next_free > size / 2 then begin let old_store = !store in store := Weak.create (size * 2); Weak.blit old_store 0 (!store) 0 size; end let add = fun c -> if not (is_solved c) then begin let size = Weak.length !store in if !next_free >= size then begin assert(!next_free = size); compress_or_extend () (* Set next_free *) end; Weak.set !store !next_free (Some c); incr next_free; let id = c.id in Fcl_stak.trail (fun () -> (* le weak pointer de c a ete eventuellement supprime par le GC et la compression *) match Weak.get !store (!next_free - 1) with Some c' when c'.id <> id -> () | _ -> decr next_free) end let active_store () = let rec loop active i = if i < !next_free then loop (match Weak.get !store i with None -> active | Some c -> if is_solved c then active else (c::active)) (i+1) else active in loop [] 0 end let active_store = Store.active_store let post c = Fcl_debug.call 'c' (fun s -> fprintf s "post: "; c.fprint s; fprintf s "\n"); let current_status = !already_in_wake in already_in_wake := true; (* Because #init may wake constraints and we want to schedule them correctly *) begin try (* Because #init may fail or raise any other exception *) c.init () with e -> reset_queue (); raise e end; if not (is_solved c) then begin c.delay c; Store.add c; end; already_in_wake := current_status; wake_all () (* post pour les démons *) let init c = c.init (); c.delay c;; let rec one () = let delay _ = () and check () = true and update _ = true and not = zero in create ~priority:immediate ~name:"one" ~check ~not update delay and zero () = let delay _ = () and check () = false and update _ = Fcl_stak.fail "zero" and not = one in create ~priority:immediate ~name:"zero" ~check ~not update delay let one = one () let zero = one.not () let id c = c.id let name c = c.name let priority c = c.priority (* Un objet avec des contraintes qui lui sont attachées *) type event = (t * int) list Fcl_stak.ref let new_event () = Fcl_stak.ref [] let schedule (event : event) = List.iter schedule_one_cstr (Fcl_stak.get event) let register event ?(waking_id=0) cstr = let nb_wakings = Array.length cstr.woken in if waking_id >= nb_wakings then begin let msg = Printf.sprintf "nb_wakings less one (%d) must be equal to maximum waking_id (here %d) in constraint %s" (nb_wakings - 1) waking_id cstr.name in Fcl_debug.fatal_error msg end; let current = Fcl_stak.get event in if not (is_solved cstr) then Fcl_stak.set event ((cstr, waking_id) :: current) let registered = Fcl_stak.get let delay events ?waking_id c = List.iter (fun event -> register event ?waking_id c) events let conjunction = function [] -> one | [cstr] -> cstr | cstrs -> let update _ = true and delay _ = () and init () = List.iter (fun c -> post c) cstrs and fprint chan = List.iter (fun c -> Printf.fprintf chan "%a\n" fprint c) cstrs in create ~fprint ~init ~name:"conjunction" update delay let not ct = ct.not () facile-1.1/src/fcl_var.ml0000644005005300001440000002650410117553006016141 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_var.ml,v 1.49 2004/09/03 13:25:55 barnier Exp $ *) module C = Fcl_cstr module type DOMAIN = sig type elt type t val compare_elt : elt -> elt -> int val fprint_elt : out_channel -> elt -> unit val fprint : out_channel -> t -> unit val min : t -> elt val max : t -> elt val mem : elt -> t -> bool val interval : elt -> elt -> t val remove_low : elt -> t -> t val remove_up : elt -> t -> t val included : t -> t -> bool val min_max : t -> elt * elt val size : t -> int val strictly_inf : elt -> elt -> bool (* [strictly_inf x1 x2] checks if [x1 < x2] when it is already known that [x1 <= x2] *) end type 'a attr = { dom : 'a Fcl_stak.ref; on_refine : Fcl_cstr.event; on_min : Fcl_cstr.event; on_max : Fcl_cstr.event; on_subst : Fcl_cstr.event; id : int; name : string } let gen_int = Fcl_misc.gen_int_fun () module MakeAttr(Dom : DOMAIN) = struct module Domain = Dom type elt = Domain.elt type domain = Domain.t type t = Domain.t attr let create ?(name = "") domain = let id = gen_int () in let name = if name = "" then Printf.sprintf "_%d" id else name in { dom = Fcl_stak.ref domain; on_refine = Fcl_cstr.new_event (); on_min = Fcl_cstr.new_event (); on_max = Fcl_cstr.new_event (); on_subst = Fcl_cstr.new_event (); id = id; name = name } let dom a = Fcl_stak.get a.dom let fprint c a = Printf.fprintf c "%s%a" a.name Domain.fprint (Fcl_stak.get a.dom) let min a = Domain.min (Fcl_stak.get a.dom) let max a = Domain.max (Fcl_stak.get a.dom) let member a y = Domain.mem y (Fcl_stak.get a.dom) let id a = a.id let count_cstrs l = let n = List.length l in let h = Hashtbl.create n in List.iter (fun (c, _) -> if not (C.is_solved c) then Hashtbl.replace h (C.id c) ()) l; Hashtbl.fold (fun _ _ r -> 1 + r) h 0 let constraints_number a = (* Not all constraints are suspended on on_subst (e.g. <~), so all the constraints lists have to be taken into account *) let cstrs_subst = C.registered a.on_subst and cstrs_min = C.registered a.on_min and cstrs_max = C.registered a.on_max and cstrs_refine = C.registered a.on_refine in let cstrs = List.concat [cstrs_subst; cstrs_min; cstrs_max; cstrs_refine] in count_cstrs cstrs type event = t -> Fcl_cstr.event let on_refine a = a.on_refine let on_subst a = a.on_subst let on_min a = a.on_min let on_max a = a.on_max let size a = Domain.size (Fcl_stak.get a.dom) end module type CONCRETEATTR = sig module Domain : DOMAIN type t = Domain.t attr type event val create : ?name:string -> Domain.t -> t val dom : t -> Domain.t val on_refine : event val on_subst : event val on_min : event val on_max : event val fprint : out_channel -> t -> unit val min : t -> Domain.elt val max : t -> Domain.elt val member : t -> Domain.elt -> bool val id : t -> int val constraints_number : t -> int val size : t -> int end module type ATTR = sig type elt type domain type t type event val dom : t -> domain val on_refine : event val on_subst : event val on_min : event val on_max : event val fprint : out_channel -> t -> unit val min : t -> elt val max : t -> elt val member : t -> elt -> bool val id : t -> int val constraints_number : t -> int val size : t -> int end module Attr = MakeAttr(Fcl_domain) module SetAttr = MakeAttr(Fcl_setDomain) module FloatAttr = MakeAttr(Fcl_float) type ('a, 'b) concrete = Unk of 'a | Val of 'b module MakeFd(Attr : CONCRETEATTR) = struct module D = Attr.Domain type attr = Attr.t type event = Attr.event type domain = D.t type elt = D.elt type t = (attr, elt) concrete Fcl_stak.ref let elt i = Fcl_stak.ref (Val i) let int = elt let create ?name domain = Fcl_stak.ref (match D.size domain with 0 -> Fcl_stak.fail "Var.XxxFd.create: empty initial domain" | 1 -> Val (D.min domain) | _ -> Unk (Attr.create ?name domain)) let interval ?name min max = create ?name (D.interval min max) let array ?name n min max = let dom = D.interval min max in let name_elt = match name with None -> fun _i -> None | Some n -> fun i -> Some (Printf.sprintf "%s_%d" n i) in Array.init n (fun i -> create ?name:(name_elt i) dom) let subst v new_v = match Fcl_stak.get v with Unk a -> if D.mem new_v (Attr.dom a) then begin Fcl_stak.set v (Val new_v); Fcl_cstr.schedule a.on_subst; Fcl_cstr.schedule a.on_refine; Fcl_cstr.schedule a.on_min; Fcl_cstr.schedule a.on_max; Fcl_cstr.wake_all () end else Fcl_stak.fail "Var.XxxFd.subst" | Val _ -> Fcl_debug.fatal_error "XxxFd.subst: bound variable (use XxxFd.unify on possibly bound variable)" let value (v : t) = Fcl_stak.get v let fprint c v = match Fcl_stak.get v with Val t -> D.fprint_elt c t | Unk a -> Attr.fprint c a let refine v new_a = match value v with Unk a -> let vala = Attr.dom a in Fcl_debug.call 't' (fun s -> Printf.fprintf s "refine %a with %a\n" fprint v D.fprint new_a); assert (D.included new_a vala); let new_size = D.size new_a in begin match new_size with 0 -> Fcl_stak.fail "Var.XxxFd.refine" | 1 -> subst v (D.min new_a) | _ -> if new_size <> D.size vala then begin Fcl_stak.set a.dom new_a; Fcl_cstr.schedule a.on_refine; if D.strictly_inf (D.min vala) (D.min new_a) then Fcl_cstr.schedule a.on_min; if D.strictly_inf (D.max new_a) (D.max vala) then Fcl_cstr.schedule a.on_max; Fcl_cstr.wake_all () end end | Val v -> if not (D.mem v new_a) then Fcl_stak.fail "Var.XxxFd.refine" let unify (v : t) new_v = match Fcl_stak.get v with Val v -> if not (v = new_v) then Fcl_stak.fail "Var.XxxFd.unify" | Unk _a -> subst v new_v let unify_cstr var value = let update _ = unify var value; true and delay _ = () in (* Solved when posted *) Fcl_cstr.create ~name:"unify_cstr" ~priority:Fcl_cstr.immediate update delay (* refinements shortcuts to avoid explicit Fd.value matchings *) let refine_up x x_max = match value x with Val x -> if D.compare_elt x x_max > 0 then Fcl_stak.fail "Var.XxxFd.refine_up" | Unk a -> refine x (D.remove_up x_max (Attr.dom a)) let refine_low x x_min = match value x with Val x -> if D.compare_elt x x_min < 0 then Fcl_stak.fail "Var.XxxFd.refine_low" | Unk a -> refine x (D.remove_low x_min (Attr.dom a)) let refine_low_up z z_min z_max = Fcl_debug.call 'v' (fun s -> Printf.fprintf s "Var.XxxFd.refine_min_max: %a %a\n" D.fprint_elt z_min D.fprint_elt z_max); match value z with Val x -> if D.compare_elt x z_min < 0 || D.compare_elt x z_max > 0 then Fcl_stak.fail "Var.XxxFd.refine_low_up" | Unk a -> refine z (D.remove_up z_max (D.remove_low z_min (Attr.dom a))) let fprint_array c vs = let n = Array.length vs in Printf.fprintf c "[|"; for i = 0 to n - 2 do Printf.fprintf c "%a; " fprint vs.(i) done; if n = 0 then Printf.fprintf c "|]" else Printf.fprintf c "%a|]" fprint vs.(n-1) let min v = match Fcl_stak.get v with Val t -> t | Unk a -> D.min (Fcl_stak.get a.dom) let max v = match Fcl_stak.get v with Val t -> t | Unk a -> Attr.max a let min_max v = match Fcl_stak.get v with Val t -> (t,t) | Unk a -> D.min_max (Fcl_stak.get a.dom) let is_var v = match Fcl_stak.get v with Val _x -> false | Unk _a -> true let is_bound v = not (is_var v) let elt_value v = match Fcl_stak.get v with Val x -> x | Unk a -> Fcl_debug.fatal_error ("Var.XxxFd.elt_value: unbound variable: " ^ a.name) let int_value = elt_value let id v = match Fcl_stak.get v with Val _x -> Fcl_debug.fatal_error "Var.XxxFd.id: bound variable" | Unk a -> a.id let name v = match Fcl_stak.get v with Val _x -> Fcl_debug.fatal_error "Var.XxxFd.name: bound variable" | Unk a -> a.name let member v x = match Fcl_stak.get v with Val v -> v = x | Unk a -> Attr.member a x let compare v1 v2 = match Fcl_stak.get v1, Fcl_stak.get v2 with (Val n1, Val n2) -> compare n1 n2 | (Val _, Unk _) -> -1 | (Unk _, Val _) -> 1 | (Unk a1, Unk a2) -> compare (Attr.id a1) (Attr.id a2) let equal v1 v2 = compare v1 v2 = 0 let on_refine = Attr.on_refine let on_subst = Attr.on_subst let on_min = Attr.on_min let on_max = Attr.on_max let delay es x ?waking_id c = match value x with Val _ -> () | Unk a -> Fcl_cstr.delay (List.map (fun e -> e a) es) ?waking_id c let size v = match Fcl_stak.get v with Val _ -> 1 | Unk a -> Attr.size a end module type BASICFD = sig type t type elt type domain type attr type event val create : ?name:string -> domain -> t val interval : ?name:string -> elt -> elt -> t val array : ?name:string -> int -> elt -> elt -> t array val elt : elt -> t val is_var : t -> bool val is_bound : t -> bool val value : t -> (attr, elt) concrete val min : t -> elt val max : t -> elt val min_max : t -> elt * elt val elt_value : t -> elt val int_value : t -> elt val size : t -> int val member : t -> elt -> bool val id : t -> int val name : t -> string val compare : t -> t -> int val equal : t -> t -> bool val fprint : out_channel -> t -> unit val fprint_array : out_channel -> t array -> unit val unify : t -> elt -> unit val refine : t -> domain -> unit val refine_low : t -> elt -> unit val refine_up : t -> elt -> unit val refine_low_up : t -> elt -> elt -> unit val on_refine : event val on_subst : event val on_min : event val on_max : event val delay : event list -> t -> ?waking_id:int -> Fcl_cstr.t -> unit val int : elt -> t val subst : t -> elt -> unit val unify_cstr : t -> elt -> Fcl_cstr.t end module type FD = sig include BASICFD val remove : t -> elt -> unit val values : t -> elt list val iter : (elt -> unit) -> t -> unit end module BasicFd = MakeFd(Attr) module Fd = struct include BasicFd let values v = match Fcl_stak.get v with Val t -> [t] | Unk a -> Fcl_domain.values (Attr.dom a) let iter f v = match Fcl_stak.get v with Val x -> f x | Unk a -> Fcl_domain.iter f (Attr.dom a) let remove x a = match value x with Val v -> if D.compare_elt v a = 0 then Fcl_stak.fail "Var.XxxFd.remove" | Unk attr -> refine x (Fcl_domain.remove a (Attr.dom attr)) end module SetFd = MakeFd(SetAttr) module FloatInterval = MakeFd(FloatAttr) (* Deprecated *) type concrete_fd = (Fd.attr, Fd.elt) concrete let delay = Fd.delay facile-1.1/src/fcl_invariant.ml0000644005005300001440000002105510117553006017340 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_invariant.ml,v 1.2 2004/08/12 15:22:07 barnier Exp $ *) type ('a, 'b) t = { x : 'a Fcl_stak.ref; event : Fcl_cstr.event; id : int; name : string } type setable type unsetable type 'a setable_t = ('a, setable) t type 'a unsetable_t = ('a, unsetable) t let gen_int = Fcl_misc.gen_int_fun () let create ?(name = "") v = let id = gen_int () in let name = if name = "" then Printf.sprintf "_%d" id else name in { x = Fcl_stak.ref v; event = Fcl_cstr.new_event (); id = id; name = name } let constant = create let get r = Fcl_stak.get r.x let event r = r.event let name r = r.name let id r = r.id let fprint c ?(printer = (fun _ _ -> ())) r = Printf.fprintf c "%s%a" r.name printer (get r) let set r v = let old = Fcl_stak.get r.x in if old <> v then begin Fcl_stak.set r.x v; Fcl_cstr.schedule r.event; Fcl_cstr.wake_all () end let unary ?(name = "Invariant.unary") f x = let yname = Printf.sprintf "%s(%s)" name x.name in let y = create ~name:yname (f (get x)) in let update _ = set y (f (get x)); false and delay c = Fcl_cstr.register (event x) c in Fcl_cstr.post (Fcl_cstr.create ~name update delay); y let sum array = let name = "Invariant.sum" in let n = Array.length array in if n = 0 then raise (Invalid_argument name); let rname = Printf.sprintf "sum(%s...%s)" array.(0).name array.(n-1).name in let r = create ~name:rname (Array.fold_left (fun r x -> get x + r) 0 array) and lasts = Array.map get array in let update i = let new_ai = get array.(i) in set r (get r - lasts.(i) + new_ai); Fcl_data.Array.set lasts i new_ai; false and delay c = Array.iteri (fun i ai -> Fcl_cstr.register (event ai) ~waking_id:i c) array in let c = Fcl_cstr.create ~name ~nb_wakings:n update delay in Fcl_cstr.post c; r let prod array = let name = "Invariant.prod" in let n = Array.length array in if n = 0 then raise (Invalid_argument name); let rname = Printf.sprintf "prod(%s...%s)" array.(0).name array.(n-1).name in let r = create (Array.fold_left (fun r x -> get x * r) 1 array) and lasts = Array.map get array in let update i = let new_ai = get array.(i) in if lasts.(i) <> 0 then set r (get r / lasts.(i) * new_ai) else begin assert(new_ai <> 0); set r (Array.fold_left (fun r x -> get x * r) 1 array) end; Fcl_data.Array.set lasts i new_ai; false and delay c = Array.iteri (fun i ai -> Fcl_cstr.register (event ai) ~waking_id:i c) array in let c = Fcl_cstr.create ~name ~nb_wakings:n update delay in Fcl_cstr.post c; r let binary ?(name = "Invariant.binary") f x y = let zname = Printf.sprintf "%s_%s" x.name y.name in let z = create ~name:zname (f (get x) (get y)) in let update _ = set z (f (get x) (get y)); false and delay c = Fcl_cstr.register (event x) c; Fcl_cstr.register (event y) c; in Fcl_cstr.post (Fcl_cstr.create ~name update delay); z let ternary ?(name = "Invariant.ternary") f x y t = let zname = Printf.sprintf "%s_%s_%s" x.name y.name t.name in let z = create ~name:zname(f (get x) (get y) (get t)) in let update _ = set z (f (get x) (get y) (get t)); false and delay c = Fcl_cstr.register (event x) c; Fcl_cstr.register (event y) c; Fcl_cstr.register (event t) c in Fcl_cstr.post (Fcl_cstr.create ~name update delay); z module Array = struct let argmin array f = let name = "Invariant.Array.argmin" in let n = Array.length array in if n = 0 then raise (Invalid_argument name); let idxname = Printf.sprintf "argmin(%s...%s)" array.(0).name array.(n-1).name in if n = 1 then constant ~name:idxname 0 else let values = Array.map (fun ai -> f (get ai)) array in let module Ord = struct type t = int let compare i j = compare (values.(i), i) (values.(j), j) end in let module S = Set.Make(Ord) in let s = Fcl_stak.ref (Fcl_misc.goedel S.add n S.empty) in let idx_min = create (S.min_elt (Fcl_stak.get s)) in let update i = let last_idx_min = get idx_min in let last_min = values.(last_idx_min) in let s' = S.remove i (Fcl_stak.get s) in Fcl_data.Array.set values i (f (get array.(i))); let s'' = S.add i s' in Fcl_stak.set s s''; if (values.(i), i) < (last_min, last_idx_min) then set idx_min i else if i = last_idx_min then set idx_min (S.min_elt s''); false and delay c = Array.iteri (fun i ai -> Fcl_cstr.register (event ai) ~waking_id:i c) array in Fcl_cstr.post (Fcl_cstr.create ~name:"Invariant.Array.argmin" ~nb_wakings:n update delay); idx_min let unary_get a idx = let name = "Invariant.Array.unary_get" in let n = Array.length a in if n = 0 then raise (Invalid_argument name); let rname = Printf.sprintf "unary_get(%s...%s).(%s)" a.(0).name a.(n-1).name idx.name in let r = create ~name:rname (get a.(get idx)) in let update _ = set r (get a.(get idx)); false and delay c = Fcl_cstr.register (event idx) c in Fcl_cstr.post (Fcl_cstr.create ~name update delay); r let min a f = unary_get a (argmin a f) let get array idx = let name = "Invariant.Array.get" in let n = Array.length array in if n = 0 then raise (Invalid_argument name); let rname = Printf.sprintf "get(%s...%s).(%s)" array.(0).name array.(n-1).name idx.name in let r = create ~name:rname (get array.(get idx)) in let update i = let nidx = get idx in assert(0 <= nidx && nidx < n); if i = n then set r (get array.(nidx)) else if i = nidx then set r (get array.(nidx)); false and delay c = Array.iteri (fun i ai -> Fcl_cstr.register (event ai) ~waking_id:i c) array; Fcl_cstr.register (event idx) ~waking_id:n c in let c = Fcl_cstr.create ~name ~nb_wakings:(n + 1) update delay in Fcl_cstr.post c; r end module type FD = sig type fd type elt val min : fd -> elt unsetable_t val max : fd -> elt unsetable_t val size : fd -> int unsetable_t val is_var : fd -> bool unsetable_t val unary : ?name:string -> (fd -> 'a) -> fd -> 'a unsetable_t end module MakeFd(Fd : Fcl_var.BASICFD)(Attr : Fcl_var.ATTR with type event = Fd.event) = struct type fd = Fd.t type elt = Fd.elt let min v = let name = Printf.sprintf "fd_min(%s)" (Fd.name v) in let inv = create ~name (Fd.min v) in let update _ = set inv (Fd.min v); not (Fd.is_var v) and delay c = Fd.delay [Fd.on_min] v c in Fcl_cstr.post (Fcl_cstr.create ~name:"Invariant.XxxFd.min" update delay); inv let max v = let name = Printf.sprintf "fd_max(%s)" (Fd.name v) in let inv = create ~name (Fd.max v) in let update _ = set inv (Fd.max v); not (Fd.is_var v) and delay c = Fd.delay [Fd.on_max] v c in Fcl_cstr.post (Fcl_cstr.create ~name:"Invariant.XxxFd.max" update delay); inv let size v = let name = Printf.sprintf "fd_size(%s)" (Fd.name v) in let inv = create ~name (Fd.size v) in let update _ = set inv (Fd.size v); not (Fd.is_var v) and delay c = Fd.delay [Fd.on_refine] v c in Fcl_cstr.post (Fcl_cstr.create ~name:"Invariant.XxxFd.size" update delay); inv let is_var v = let name = Printf.sprintf "fd_is_var(%s)" (Fd.name v) in let inv = create ~name (Fd.is_var v) in let update _ = set inv (Fd.is_var v); not (Fd.is_var v) and delay c = Fd.delay [Fd.on_subst] v c in Fcl_cstr.post (Fcl_cstr.create ~name:"Invariant.XxxFd.is_var" update delay); inv let unary ?(name = "Invariant.XxxFd.unary") h v = let invname = Printf.sprintf "%s(%s)" name (Fd.name v) in let inv = create ~name:invname (h v) in let update _ = set inv (h v); not (Fd.is_var v) and delay c = Fd.delay [Fd.on_refine] v c in Fcl_cstr.post (Fcl_cstr.create ~name update delay); inv end module Fd = MakeFd(Fcl_var.Fd)(Fcl_var.Attr) module SetFd = MakeFd(Fcl_var.SetFd)(Fcl_var.SetAttr) facile-1.1/src/fcl_reify.ml0000644005005300001440000001004310117553006016456 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_reify.ml,v 1.21 2004/08/12 15:22:07 barnier Exp $ *) open Fcl_var module C = Fcl_cstr let reification c b on_not = let name = "reification" and fprint s = Printf.fprintf s "reification: "; C.fprint s c and delay x = C.self_delay c x; if on_not then (C.self_delay (C.not c)) x; delay [Fd.on_subst] b x and update _0 = match Fd.value b with Val vb -> Fcl_cstr.post (if vb = 0 then (C.not c) else c); true | Unk _ -> try if C.is_solved c || C.check c then begin Fd.unify b 1 end else begin Fd.unify b 0 end; true with Fcl_cstr.DontKnow -> false in C.create ~name ~fprint update delay let cstr ?(delay_on_negation = true) c b = reification c b delay_on_negation;; let boolean ?delay_on_negation c = let b = Fd.create Fcl_domain.boolean in let r = cstr ?delay_on_negation c b in Fcl_cstr.post r; b;; exception MyDontKnow;; let rec (||~~) c1 c2 = let update _0 = C.is_solved c1 || C.is_solved c2 || try if not (C.check c1) then begin (* if c1 is false, c2 must be true *) Fcl_cstr.post c2 end; true with Fcl_cstr.DontKnow -> try if not (C.check c2) then (* if c2 is false, c1 must be true *) Fcl_cstr.post c1; true with Fcl_cstr.DontKnow -> false and fprint s = Printf.fprintf s "("; C.fprint s c1; Printf.fprintf s ") ||~~ ("; C.fprint s c2; Printf.fprintf s ")" and delay c = C.self_delay c1 c; C.self_delay c2 c; C.self_delay (C.not c1) c; C.self_delay (C.not c2) c and check () = C.is_solved c1 || C.is_solved c2 || try (try C.check c1 with Fcl_cstr.DontKnow -> raise MyDontKnow) || C.check c2 with MyDontKnow -> C.check c2 || raise Fcl_cstr.DontKnow and not () = (&&~~) (C.not c1) (C.not c2) in Fcl_cstr.create ~name:"||~~" ~fprint:fprint ~not:not ~check:check update delay and (&&~~) c1 c2 = let update _ = Fcl_cstr.post c1; Fcl_cstr.post c2; true and fprint s = Printf.fprintf s "("; C.fprint s c1; Printf.fprintf s ") &&~~ ("; C.fprint s c2; Printf.fprintf s ")" and delay c = C.self_delay c1 c; C.self_delay c2 c; C.self_delay (C.not c1) c; C.self_delay (C.not c2) c and check () = (C.is_solved c1 || try C.check c1 with Fcl_cstr.DontKnow -> if C.check c2 then raise Fcl_cstr.DontKnow else false ) && (C.is_solved c2 || C.check c2) and not () = (||~~) (C.not c1) (C.not c2) in Fcl_cstr.create ~name:"&&~~" ~fprint:fprint ~not:not ~check:check update delay;; let (=>~~) c1 c2 = C.not c1 ||~~ c2 let rec eq_or_xor c1 c2 equiv = (* if [equiv] then (<=>~~) else (xor~~) *) let update _0 = try Fcl_cstr.post (if C.check c1 = equiv then c2 else C.not c2); true with Fcl_cstr.DontKnow -> (* c1 unknown *) try Fcl_cstr.post (if C.check c2 = equiv then c1 else C.not c1); true with Fcl_cstr.DontKnow -> (* c1 && c2 unknown *) false and delay c = C.self_delay c1 c; C.self_delay c2 c; C.self_delay (C.not c1) c; C.self_delay (C.not c2) c and check _0 = (C.check c1 = C.check c2) = equiv and not () = eq_or_xor c1 c2 (not equiv) in Fcl_cstr.create ~name:(if equiv then "<=>~~" else "xor~~") ~not:not ~check:check update delay;; let (<=>~~) c1 c2 = eq_or_xor c1 c2 true let xor c1 c2 = eq_or_xor c1 c2 false let not c = C.not c facile-1.1/src/fcl_boolean.ml0000644005005300001440000001021010117553006016753 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) open Fcl_var open Fcl_misc.Operators (* sum xi = v ou sum xi <> v*) let linear (terms : Fd.t array) v shared_min shared_max equal = let name = "Boolean.linear" in let monotonic_propagate subst = Array.fold_left (fun sum x -> match Fd.value x with Val 0 -> sum | Val 1 -> 1 + sum | Unk attr -> begin Fd.subst x subst; subst + sum end | _ -> Fcl_debug.internal_error (name ^ ": non boolean variable")) 0 terms in let delay c = Array.iter (fun x -> delay [Fd.on_subst] x c) terms; delay [Fd.on_min] v c; delay [Fd.on_max] v c and fprint c = Printf.fprintf c "%a %s(bool) " Fd.fprint v (if equal then "=" else "<>"); if Array.length terms > 0 then begin Fd.fprint c terms.(0); for i = 1 to Array.length terms - 1 do Printf.fprintf c "+%a" Fd.fprint terms.(i) done end; flush c and update _ = let shared_min = Fcl_stak.get shared_min and shared_max = Fcl_stak.get shared_max in if equal then (* if the maximum of v is reached, all other variables can be set to 0 *) if shared_min = Fd.max v then begin if monotonic_propagate 0 > Fd.max v then Fcl_stak.fail (name ^ ": monotonic_propagate > max"); Fd.unify v shared_min; true end (* and vice versa *) else if shared_max = Fd.min v then begin if monotonic_propagate 1 < Fd.min v then Fcl_stak.fail (name ^ ": monotonic_propagate < min"); Fd.unify v shared_max; true end else if shared_min = shared_max then begin Fd.unify v shared_min; true end else begin Fd.refine_low_up v shared_min shared_max; false end else begin (* not equal *) if shared_min = shared_max then begin begin match Fd.value v with Val x -> if x = shared_min then Fcl_stak.fail (name ^ ": (<>)") | Unk attr -> Fd.refine v (Fcl_domain.remove shared_min (Attr.dom attr)) end; true end else (shared_min > Fd.max v || shared_max < Fd.min v) end in Fcl_cstr.create ~name ~fprint update delay let set_cr op stakref = Fcl_stak.set stakref (op (Fcl_stak.get stakref) 1) let set_decr = set_cr (-) let set_incr = set_cr (+) let demon xs shared_min shared_max = let name = "Boolean.demon" in let delay c = Array.iteri (fun i xi -> delay [Fd.on_subst] xi ~waking_id:i c) xs and fprint c = Printf.fprintf c "%s: %a" name Fd.fprint_array xs and init () = () and update i = begin match Fd.value xs.(i) with Val 0 -> set_decr shared_max | Val 1 -> set_incr shared_min | _ -> Fcl_debug.internal_error "boolean_demon : variable is not ground or not boolean" end; true in Fcl_cstr.create ~name ~fprint ~init update ~nb_wakings:(Array.length xs) delay let is_boolean x = let min_x, max_x = Fcl_var.Fd.min_max x in min_x = 0 && max_x = 1 let is_boolean_array l = try Array.iter (fun b -> if not (is_boolean b) then raise Exit) l; true with Exit -> false let cstr bools sum = assert (is_boolean_array bools); let size = Array.length bools in let shared_min = Fcl_stak.ref 0 and shared_max = Fcl_stak.ref size in Fcl_cstr.init (demon bools shared_min shared_max); linear bools sum shared_min shared_max true let sum bools = assert (is_boolean_array bools); let size = Array.length bools in let shared_min = Fcl_stak.ref 0 and shared_max = Fcl_stak.ref size in Fcl_cstr.init (demon bools shared_min shared_max); let sum = Fd.create (Fcl_domain.interval 0 size) in Fcl_cstr.post (linear bools sum shared_min shared_max true); sum facile-1.1/src/fcl_linear.ml0000644005005300001440000004335110117553006016622 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) open Fcl_var open Fcl_misc.Operators open Printf module C = Fcl_cstr type operator = LessThan | Equal | Diff let string_of_op = function Equal -> "=" | LessThan -> "<=" | Diff -> "<>" let min_max_plus_inter a b c d = (a + c, b + d) let min_max_minus_inter a b c d = (a - d, b - c) (* x1 <= x2 + d *) (* specialized binary leq constraint *) let rec less_than x1 x2 d = let name = "less_than" in let update _ = match Fd.value x1, Fd.value x2 with Unk a1, Unk a2 -> let max1 = Attr.max a1 and max2d = Attr.max a2 + d in if max1 > max2d then Fd.refine x1 (Fcl_domain.remove_up max2d (Attr.dom a1)); let min2 = Attr.min a2 and min1d = Attr.min a1 - d in if min1d > min2 then Fd.refine x2 (Fcl_domain.remove_low min1d (Attr.dom a2)); Fd.max x1 <= Fd.min x2 + d | Val v1, Unk a2 -> let min2 = Attr.min a2 in if min2 < v1 - d then Fd.refine x2 (Fcl_domain.remove_low (v1-d) (Attr.dom a2)); true | Unk a1, Val v2 -> let max1 = Attr.max a1 in if max1 > v2+d then Fd.refine x1 (Fcl_domain.remove_up (v2+d) (Attr.dom a1)); true | Val v1, Val v2 -> v1 <= v2+d || Fcl_stak.fail name and check () = let min1, max1 = Fd.min_max x1 and min2, max2 = Fd.min_max x2 in max1 <= min2 + d || (if min1 > max2 + d then false else raise C.DontKnow) and not () = less_than x2 x1 (1-d) and delay ct = delay [Fd.on_min] x1 ct; delay [Fd.on_max] x2 ct and fprint f = Printf.fprintf f "%a <= %a + %d" Fd.fprint x1 Fd.fprint x2 d in C.create ~not ~check ~name ~fprint update delay (* x1 = k*x2 *) (* specialized binary eq and diff constraint *) (* propagations on domain bounds: less powerful than linear when k = 1 *) let rec equalc x1 k x2 = let bounds () = (Fd.min_max x1, Fd.min_max x2) in let name = "equalc" in let update _ = Fcl_debug.call 'a' (fun s -> fprintf s "equalc - before update: %a = %d * %a\n" Fd.fprint x1 k Fd.fprint x2); if k = 0 then begin Fd.unify x1 0; true end else let rec loop () = match Fd.value x1, Fd.value x2 with Unk a1, Unk a2 -> let cbounds = bounds () in let (c, d) = Fd.min_max x2 in let (kc, kd) = if k > 0 then (k*c, k*d) else (k*d, k*c) in Fd.refine_low_up x1 kc kd; let (a, b) = Fd.min_max x1 in let (ak, bk) = if k > 0 then (a /+ k, b /- k) else (b /+ k, a /- k) in Fd.refine_low_up x2 ak bk; if cbounds <> bounds () then loop () else false | Val v1, Unk _a2 -> Fd.unify x2 (v1/k); true | Unk _a1, Val v2 -> Fd.unify x1 (k*v2); true | Val v1, Val v2 -> v1 = k*v2 || Fcl_stak.fail name in loop () and check () = match Fd.value x1, Fd.value x2 with Unk a1, Unk a2 -> let (a, b) = Fd.min_max x1 in let (c, d) = Fd.min_max x2 in let (kc, kd) = if k > 0 then (k*c, k*d) else (k*d, k*c) in if a > kd || b < kc then false else raise C.DontKnow | Val v1, Unk a2 -> if not (Fcl_domain.member (v1/k) (Attr.dom a2)) then false else raise C.DontKnow | Unk a1, Val v2 -> if not (Fcl_domain.member (k*v2) (Attr.dom a1)) then false else raise C.DontKnow | Val v1, Val v2 -> v1 = k*v2 and not () = diffc x1 k x2 and delay ct = delay [Fd.on_min; Fd.on_max] x1 ct; delay [Fd.on_min; Fd.on_max] x2 ct and fprint f = Printf.fprintf f "%a = %d * %a" Fd.fprint x1 k Fd.fprint x2 in C.create ~name ~fprint ~not ~check update delay (* x1 <> k*x2 *) and diffc x1 k x2 = let name = "diffc" in let update _ = if k = 0 then match Fd.value x1 with Unk a1 -> Fd.refine x1 (Fcl_domain.remove 0 (Attr.dom a1)); true | Val v1 -> v1 <> 0 || Fcl_stak.fail name else match Fd.value x1, Fd.value x2 with Unk a1, Unk a2 -> let (c, d) = Fd.min_max x2 in let (kc, kd) = if k > 0 then (k*c, k*d) else (k*d, k*c) in let (a, b) = Fd.min_max x1 in (a > kd || b < kc) | Val v1, Unk a2 -> v1 mod k <> 0 || not (Fcl_domain.member (v1/k) (Attr.dom a2)) | Unk a1, Val v2 -> not (Fcl_domain.member (k*v2) (Attr.dom a1)) | Val v1, Val v2 -> v1 <> k*v2 || Fcl_stak.fail name and check () = match Fd.value x1, Fd.value x2 with Unk a1, Unk a2 -> let (a, b) = Fd.min_max x1 in let (c, d) = Fd.min_max x2 in let (kc, kd) = if k > 0 then (k*c, k*d) else (k*d, k*c) in (a > kd || b < kc) || raise C.DontKnow | Val v1, Unk a2 -> not (Fcl_domain.member (v1/k) (Attr.dom a2)) || raise C.DontKnow | Unk a1, Val v2 -> not (Fcl_domain.member (k*v2) (Attr.dom a1)) || raise C.DontKnow | Val v1, Val v2 -> v1 <> k*v2 and not () = equalc x1 k x2 and delay ct = delay [Fd.on_min; Fd.on_max] x1 ct; delay [Fd.on_min; Fd.on_max] x2 ct and fprint f = Printf.fprintf f "%a <> %d * %a" Fd.fprint x1 k Fd.fprint x2 in C.create ~name ~fprint ~not ~check update delay let remove_constants terms = let modif = ref false in let r = List.fold_left (fun (cst, vars) ((a, x) as ax) -> match Fd.value x with Unk _ -> (cst, ax::vars) | Val v -> modif := true; (cst+a*v, vars)) (0, []) terms in if !modif then r else raise Not_found let compute_inf_sup pos_terms neg_terms = let neg_inf_sum, neg_sup_sum = List.fold_left (fun (inf,sup) (c,x) -> let mi, ma = Fd.min_max x in (inf+c*ma, sup+c*mi)) (0, 0) neg_terms in List.fold_left (fun (inf,sup) (c,x) -> let mi,ma = Fd.min_max x in (inf+c*mi, sup+c*ma)) (neg_inf_sum, neg_sup_sum) pos_terms let part_pos_neg l = let rec loop pos neg = function [] -> (pos, neg) | (0, _) :: axs -> loop pos neg axs | (a, _x) as ax :: axs -> if a > 0 then loop (ax :: pos) neg axs else loop pos (ax :: neg) axs in loop [] [] l (* terms = c *) let linear_aux terms c = let (pos, neg) = part_pos_neg terms in let (a, b) = compute_inf_sup pos neg in let (ac, bc) = (a - c, b - c) in Fd.interval ac bc (* In case all terms are positive (resp. negative), one can try to refine individually each term before computing the expression bounds (e.g. avoids an integer overflow in huge magic sequences caused) *) let basic_refinements pos_terms neg_terms d op = if op <> Diff then if List.for_all (fun (_a, x) -> Fd.min x >= 0 ) pos_terms && List.for_all (fun (_a, x) -> Fd.max x <= 0 ) neg_terms then begin List.iter (fun (a, x) -> Fd.refine_up x (d/a)) pos_terms; List.iter (fun (a, x) -> Fd.refine_low x (d/a)) neg_terms end else if op = Equal && List.for_all (fun (_a, x) -> Fd.max x <= 0 ) pos_terms && List.for_all (fun (_a, x) -> Fd.min x >= 0 ) neg_terms then begin List.iter (fun (a, x) -> Fd.refine_low x (d/a)) pos_terms; List.iter (fun (a, x) -> Fd.refine_up x (d/a)) neg_terms end (* linear constraint a1*x1+...+an*xn=d *) let rec linear_cstr terms pos_terms neg_terms op d = let pos_terms = Fcl_stak.ref pos_terms and neg_terms = Fcl_stak.ref neg_terms and d = Fcl_stak.ref d in let name = "linear" in let delay c = List.iter (fun (a, x) -> match op with Diff -> delay [Fd.on_subst] x c | Equal -> delay [Fd.on_refine] x c | LessThan -> delay [if a > 0 then Fd.on_min else Fd.on_max] x c) terms in let fprint c = List.iter (fun (a,x) -> Printf.fprintf c " +%d.%a" a Fd.fprint x) (Fcl_stak.get pos_terms); List.iter (fun (a,x) -> Printf.fprintf c " %d.%a" a Fd.fprint x) (Fcl_stak.get neg_terms); Printf.fprintf c " %s %d" (string_of_op op) (Fcl_stak.get d); flush c in let not () = let terms = Fcl_stak.get pos_terms @ Fcl_stak.get neg_terms and d = Fcl_stak.get d in match op with Equal -> cstr terms Diff d | Diff -> cstr terms Equal d | LessThan -> cstr (List.map (fun (a,x) -> (-a, x)) terms) LessThan (-1 - d) and check () = let inf_sum, sup_sum = compute_inf_sup (Fcl_stak.get pos_terms) (Fcl_stak.get neg_terms) in let d = Fcl_stak.get d in match op with Equal -> if inf_sum = sup_sum then inf_sum = d else if sup_sum < d || inf_sum > d then false else raise C.DontKnow | Diff -> if inf_sum = sup_sum then inf_sum <> d else sup_sum < d || inf_sum > d || raise C.DontKnow | LessThan -> sup_sum <= d || (if inf_sum > d then false else begin Fcl_debug.call 'a' (fun s -> fprintf s "Dont know\n"); raise C.DontKnow end) and update i = Fcl_debug.call 'a' (fun s -> fprintf s "linear - before update:"; fprint s; Printf.fprintf s "\n"); assert(i = 0); begin try let (cst, new_pos_terms) = remove_constants (Fcl_stak.get pos_terms) in if cst <> 0 then Fcl_stak.set d (Fcl_stak.get d - cst); Fcl_stak.set pos_terms new_pos_terms with Not_found -> () end; (* No new constant positive term *) begin try let (cst, new_neg_terms) = remove_constants (Fcl_stak.get neg_terms) in if cst <> 0 then Fcl_stak.set d (Fcl_stak.get d - cst); Fcl_stak.set neg_terms new_neg_terms with Not_found -> () end; (* No new constant negative term *) let d = Fcl_stak.get d in match Fcl_stak.get pos_terms, Fcl_stak.get neg_terms with ([], []) -> begin match op with Diff when d <> 0 -> true | Equal when d = 0 -> true | LessThan when d >= 0 -> true | _ -> Fcl_stak.fail "linear[]" end | ([(a, x)],[]) when op = Equal -> if d mod a = 0 then begin Fd.subst x (d/a); true end else Fcl_stak.fail "linear[(a,x)]" | ([(a, x)],[]) when op = Diff -> if d mod a <> 0 then true else begin match Fd.value x with Unk attr -> Fd.refine x (Fcl_domain.remove (d/a) (Attr.dom attr)); true | Val _ -> Fcl_debug.internal_error "linear#update ([(a, x)],[]) when op = Diff" end | ([],[(a, x)]) when op = Equal -> if d mod (-a) = 0 then begin Fd.subst x (d/a); true end else Fcl_stak.fail "linear[(a,x)]" (* propagation on domains *) | ([(1, x1)], [(-1,x2)]) when op = Equal -> (* x1 = x2 + d *) (*** Printf.printf "x1 = x2 + d"; ***) begin match Fd.value x1, Fd.value x2 with Unk a1, Unk a2 -> let d1 = Attr.dom a1 and d2 = Attr.dom a2 in Fd.refine x1 (Fcl_domain.intersection d1 (Fcl_domain.plus d2 d)); Fd.refine x2 (Fcl_domain.intersection d2 (Fcl_domain.plus d1 (-d))) | _ -> Fcl_debug.internal_error "Arith 1 -1" end; false | ([(1, x1)], [(-1,x2)]) when op = LessThan -> (* x1 <= x2 + d *) begin match Fd.value x1, Fd.value x2 with Unk a1, Unk a2 -> let max1 = Attr.max a1 and min2 = Attr.min a2 and max2 = Attr.max a2 and min1 = Attr.min a1 in if max1 > max2 + d then Fd.refine x1 (Fcl_domain.remove_up (max2+d) (Attr.dom a1)); if min1 > min2 + d then Fd.refine x2 (Fcl_domain.remove_low (min1-d) (Attr.dom a2)); (Fd.max x1 <= Fd.min x2 + d) | _ -> Fcl_debug.internal_error "Arith 1 -1" end | ([], [(a, x)]) when op = Diff -> if d mod (-a) <> 0 then true else begin match Fd.value x with Unk attr -> Fd.refine x (Fcl_domain.remove (d/a) (Attr.dom attr)); true | Val _ -> Fcl_debug.internal_error "linear#update ([], [(a, x)]) when op = Diff" end | _ -> if op = Diff then false else begin (* waiting for instantiation *) let modif = ref true (* Only for Equal *) and instantiated = ref true and solved = ref false in while !modif || !instantiated do let last_modif = !modif in modif := false; instantiated := false; let inf_sum, sup_sum = compute_inf_sup (Fcl_stak.get pos_terms) (Fcl_stak.get neg_terms) in let d_inf_sum = d - inf_sum and d_sup_sum = d - sup_sum in if (op = LessThan && 0 <= d_sup_sum) || (d_sup_sum = 0 && d_inf_sum = 0) then solved := true else if 0 > d_inf_sum || (op = Equal && 0 < d_sup_sum) then Fcl_stak.fail "linear d_inf_sum" (* We stop here if only instantiated *) else if last_modif then begin (* Let's update bounds of variables *) let update_pos (a, x) = match Fd.value x with Unk ax -> let domx = Attr.dom ax in let mi = Fcl_domain.min domx and ma = Fcl_domain.max domx in let new_sup = min ma ((d_inf_sum + a*mi)/a) in if op = Equal then begin let new_inf = max mi ((d_sup_sum + a*ma) /+ a) in if new_sup < ma || new_inf > mi then begin modif:=true; Fd.refine_low_up x new_inf new_sup end end else begin if new_sup < ma then begin Fd.refine x (Fcl_domain.remove_up new_sup domx); if not (Fd.is_var x) then instantiated := true end end (* because it's maybe the last variable of the expression and the constraint is now solved *) | Val vx -> let new_sup = ((d_inf_sum + a*vx)/a) in if new_sup < vx then Fcl_stak.fail "Arith.update_pos sup"; if op = Equal then let new_inf = (d_sup_sum + a*vx) /+ a in if new_inf > vx then Fcl_stak.fail "Arith.update_pos inf" in List.iter update_pos (Fcl_stak.get pos_terms); let update_neg (a, x) = match Fd.value x with Unk ax -> let domx = Attr.dom ax in let mi = Fcl_domain.min domx and ma = Fcl_domain.max domx in let new_inf = max mi ((d_inf_sum + a*ma) /+ a) in if op = Equal then begin let new_sup = min ma ((d_sup_sum + a*mi)/a) in if new_sup < ma || new_inf > mi then begin modif:=true; Fd.refine_low_up x new_inf new_sup end end else begin if new_inf > mi then begin Fcl_debug.call 'a' (fun s -> fprintf s "linear#update, refine_low %d\n" new_inf); Fd.refine x (Fcl_domain.remove_low new_inf domx); if not (Fd.is_var x) then instantiated := true end end (* because it's maybe the last variable of the expression and the constraint is now solved *) | Val vx -> let new_inf = (d_inf_sum + a*vx) /+ a in if new_inf > vx then Fcl_stak.fail "Arith.update_neg inf"; if op = Equal then let new_sup = ((d_sup_sum + a*vx)/a) in if new_sup < vx then Fcl_stak.fail "Arith.update_neg sup" in List.iter update_neg (Fcl_stak.get neg_terms) end done; !solved end in let init () = basic_refinements (Fcl_stak.get pos_terms) (Fcl_stak.get neg_terms) (Fcl_stak.get d) op; ignore (update 0) in C.create ~init ~name ~fprint ~check ~not update delay and cstr (terms : (int*Fd.t) list) op dd = let pos_terms, neg_terms = part_pos_neg terms in match pos_terms, neg_terms, op, dd with [1, x1], [-1, x2], LessThan, d -> (* x1 <= x2 + d *) less_than x1 x2 d | [1, x1], [k, x2], Equal, 0 when k <> -1 -> (* x1 = -k * x2 *) equalc x1 (0 - k) x2 | [k, x1], [-1, x2], Equal, 0 when k <> 1 -> (* k * x1 = x2 *) equalc x2 k x1 | [1, x1], [k, x2], Diff, 0 when k <> -1 -> (* x1 <> -k * x2 *) diffc x1 (0 - k) x2 | [k, x1], [-1, x2], Diff, 0 when k <> 1 -> (* k * x1 <> x2 *) diffc x2 k x1 | _ -> linear_cstr terms pos_terms neg_terms op dd (*** Automatic handling of boolean sub-expressions ***) let boolsum_threshold = ref 5 let get_boolsum_threshold () = !boolsum_threshold let set_boolsum_threshold x = boolsum_threshold := x let is_boolean x = let min_x, max_x = Fcl_var.Fd.min_max x in min_x = 0 && max_x = 1 (* flatten : ('a * 'b) list -> ('a * 'b list) list -> ('a * 'b) list *) let rec flatten rest = function [] -> rest | (a, l) :: ls -> List.fold_left (fun r x -> (a,x)::r) (flatten rest ls) l (* Optimized boolean sums are used for boolean subexprs larger than boolsum only *) let cstr ?(boolsum = !boolsum_threshold) terms op d = let (bools, others) = List.partition (fun (_a, x) -> is_boolean x) terms in (* partition of bools by coefficient *) let h = Hashtbl.create 17 in let add (a, x) = try let refxs = Hashtbl.find h a in refxs := x :: !refxs with Not_found -> Hashtbl.add h a (ref [x]) in List.iter add bools; (* coefficients with less than boolsum_threshold variables are discarded, otherwise an optimized boolean sum is build and substituted to the whole term *) let bool_sums = ref [] and short_bools = ref [] in Hashtbl.iter (fun a refxs -> if List.length !refxs >= boolsum then begin let bools = Array.of_list !refxs in Fcl_debug.call 'a' (fun c -> Printf.fprintf c "boolean sum (size %d) optimized\n" (Array.length bools)); let sumxs = Fcl_boolean.sum bools in bool_sums := (a, sumxs) :: !bool_sums end else short_bools := (a, !refxs) :: !short_bools) h; let short_bools = flatten [] !short_bools in cstr (!bool_sums @ short_bools @ others) op d (* x1 = x2 + d *) let shift_cstr x1 x2 d = let update _ = match Fd.value x1, Fd.value x2 with Unk a1, Unk a2 -> let max1 = Attr.max a1 and max2d = Attr.max a2 + d in if max1 > max2d then Fd.refine x1 (Fcl_domain.remove_up max2d (Attr.dom a1)) else if max1 < max2d then Fd.refine x2 (Fcl_domain.remove_up (max1-d) (Attr.dom a2)); let min2 = Attr.min a2 and min1d = Attr.min a1 - d in if min1d < min2 then Fd.refine x1 (Fcl_domain.remove_low (min2+d) (Attr.dom a1)) else if min1d > min2 then Fd.refine x2 (Fcl_domain.remove_low min1d (Attr.dom a2)); max1 <= min2 + d | Val v1, Unk _ -> Fd.unify x2 (v1-d); true | Unk _, Val v2 -> Fd.unify x1 (v2+d); true | Val v1, Val v2 -> if v1 <> v2+d then Fcl_stak.fail "shift"; true and delay ct = delay [Fd.on_min; Fd.on_max] x1 ct; delay [Fd.on_max; Fd.on_min] x2 ct and fprint f = Printf.fprintf f "%a = %a + %d" Fd.fprint x1 Fd.fprint x2 d in C.create ~name:"shift" ~fprint update delay facile-1.1/src/fcl_nonlinear.ml0000644005005300001440000005464110117553006017341 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_nonlinear.ml,v 1.8 2004/08/12 15:22:07 barnier Exp $ *) open Fcl_var open Fcl_misc.Operators open Printf module C = Fcl_cstr module Linear = Fcl_linear (*** Bounds evaluation ***) (* signs differ with x <= y *) let diffsign x y = assert (x <= y); x < 0 && y > 0 let diffeqsign x y = assert (x <= y); x <= 0 && y >= 0 (* unsorted diffsign *) let udiffsign x y = if x <= y then diffsign x y else diffsign y x (* min_of_absmod for min_max_of_expr when bounds are already known AND positive *) let min_of_absmod_inter a b c d = assert (a >= 0 && c >= 0); if b < c then a else (* 0 *) (* on peut faire mieux quand c=d (i.e. x2 connu) *) if c = d then if c = 0 then Fcl_debug.fatal_error "Arith.min_of_absmod_inter: division_by_zero" else let amodc = a mod c in if b - a + amodc < c then amodc else 0 else 0 (* max_of_absmod for min_max_of_expr when bounds are already known AND positive *) let max_of_absmod_inter a b c d = assert (a >= 0 && c >= 0); if b < d then b else (* d - 1 *) (* we could do more when c=d (i.e. x2 known) *) if c = d then if c = 0 then Fcl_debug.fatal_error "Arith.max_of_absmod_inter: division_by_zero" else let bmodc = b mod c in if bmodc - (b - a) > 0 then bmodc else d - 1 else d - 1 (* Implementation of non-linear constraints (z = x*y, x^n, x/y, |x|, x%y) *) (*** monome constraint: z = x * y ***) let min_max_mult_inter a b c d = if diffeqsign a b || diffeqsign c d then (* one of the two domains contains 0 *) (min (a*d) (b*c), max (a*c) (b*d)) else if udiffsign a c then (* domains not on the same side of 0 *) if a > 0 then (b*c, a*d) else (a*d, b*c) else (* same side *) if a > 0 then (a*c, b*d) else (b*d, a*c) (* y = z[a,b] / x[c,d] *) (* compute bounds to refine y *) let min_max_of_div_for_mult z x = (* if 0 belongs to dom(x), no conclusion on y *) if Fd.member x 0 then (min_int, max_int) else let (a, b) = Fd.min_max z and (c, d) = Fd.min_max x in (* is this useful? only waken on min or max modif... *) if diffsign c d then (* c < 0 < d*) match Fd.value x with Unk xa -> let (c', d') = Fcl_domain.largest_hole_around (Attr.dom xa) 0 in (min (a /+ d') (b /+ c'), max (a /- c') (b /- d')) (* if x was ground, c*d >= 0 *) | _ -> Fcl_debug.internal_error "min_max_of_div_for_mult: x ground" (* 0 < c || d < 0 *) else if diffsign a b then (* a < 0 < b *) if c > 0 then (a /+ c, b /- c) else (b /+ d, a /- d) (* 0 does not belong to dom(z) or dom(x) *) else if a >= 0 then (* z >= 0 *) if c > 0 then (a /+ d, b /- c) else (b /+ d, a /- c) (* x pos or neg *) else (* z <= 0 *) if c < 0 then (b /+ c, a /- d) else (a /+ c, b /- d) (* x neg or pos *) (* z = x*y *) let monome z x y = let name = "monome" in let zero_removed = Fcl_stak.ref false in let update_val_unk a y = match Fd.value z with Val c -> (* a <> 0 *) if c mod a = 0 then (Fd.unify y (c / a); true) else Fcl_stak.fail (name ^ ": Val a, Unk _, Val c") | Unk _ -> C.post (Linear.cstr [(1, z); (-a, y)] Linear.Equal 0); true in let compute_bounds () = (Fd.min_max z, Fd.min_max x, Fd.min_max y) in let delay c = delay [Fd.on_min; Fd.on_max] z c; delay [Fd.on_min; Fd.on_max] x c; delay [Fd.on_min; Fd.on_max] y c and fprint c = Printf.fprintf c "%a = %a * %a" Fd.fprint z Fd.fprint x Fd.fprint y; flush c and update _ = Fcl_debug.call 'a' (fun s -> fprintf s "%s - before update : %a = %a * %a\n" name Fd.fprint z Fd.fprint x Fd.fprint y); let rec loop () = match Fd.value x, Fd.value y with Val a, Val b -> Fd.unify z (a * b); true | (Val 0, _ | _, Val 0) -> Fd.unify z 0; true | Val a, Unk _ -> update_val_unk a y | Unk _, Val b -> update_val_unk b x (* On pourrait aussi traiter le cas z = Val 1 (idem pour expn) *) | Unk xa, Unk ya -> match Fd.value z with Val 0 -> let xa_with_0 = Attr.member xa 0 and ya_with_0 = Attr.member ya 0 in if xa_with_0 then begin if not ya_with_0 then begin Fd.unify x 0; true end else false end else if ya_with_0 then begin Fd.subst y 0; true end else Fcl_stak.fail (name ^ ": Unk xa, Unk ya, Val c") | _z_val -> (* On essaie d'enlever d'abord 0 dans x et y sinon pas de propagation *) if not (Fcl_stak.get zero_removed) && not (Fd.member z 0) then begin Fcl_stak.set zero_removed true; Fd.refine x (Fcl_domain.remove 0 (Attr.dom xa)); Fd.refine y (Fcl_domain.remove 0 (Attr.dom ya)); (* x et y peuvent etre instanciées *) loop () end else begin let bounds = compute_bounds () in let (a, b) = Fd.min_max x and (c, d) = Fd.min_max y in let (z_min, z_max) = min_max_mult_inter a b c d in Fcl_debug.call 'a' (fun s -> fprintf s "%s - Unk xa, Unk ya, z : z_min=%d z_max=%d " name z_min z_max); Fd.refine_low_up z z_min z_max; let (y_min, y_max) = min_max_of_div_for_mult z x in Fcl_debug.call 'a' (fun s -> fprintf s "y_min=%d y_max=%d " y_min y_max); Fd.refine_low_up y y_min y_max; let (x_min, x_max) = min_max_of_div_for_mult z y in Fcl_debug.call 'a' (fun s -> fprintf s "x_min=%d x_max=%d\n" x_min x_max); Fd.refine_low_up x x_min x_max; (* On rappelle update pour atteindre le point fixe *) if bounds <> compute_bounds () then loop () else false end in let r = loop () in Fcl_debug.call 'a' (fun s -> fprintf s "%s - after update : %a = %a * %a\n" name Fd.fprint z Fd.fprint x Fd.fprint y); r in C.create ~name ~fprint update delay let min_max_abs_for_abs x = match Fd.value x with Val a -> let absa = abs a in (absa, absa) | Unk xa -> let a = Attr.min xa and b = Attr.max xa in if a >= 0 then (a, b) else if b <= 0 then (-b, -a) else (* x à cheval sur 0 *) let domx = Attr.dom xa in let a' = Fcl_domain.greatest_leq domx 0 and b' = Fcl_domain.smallest_geq domx 0 in (min (-a') b', max (-a) b) let absolute z x = let name = "absolute" in let delay c = (* We could delay on_refine for x *) delay [Fd.on_min; Fd.on_max] z c; delay [Fd.on_min; Fd.on_max] x c and fprint c = Printf.fprintf c "%a = |%a|" Fd.fprint z Fd.fprint x; flush c and update _ = Fcl_debug.call 'a' (fun s -> fprintf s "%s - before update : %a=|%a|\n" name Fd.fprint z Fd.fprint x); let r = match Fd.value x with Val a -> Fd.unify z (abs a); true | Unk xa -> if Attr.min xa >= 0 then begin C.post (Linear.cstr [(1, z); (-1, x)] Linear.Equal 0); true end else if Attr.max xa <= 0 then begin C.post (Linear.cstr [(1, z); (1, x)] Linear.Equal 0); true end else match Fd.value z with Val c -> begin Fd.refine x (Fcl_domain.intersection (Fcl_domain.create [-c; c]) (Attr.dom xa)); true end | Unk za -> begin let (z_min, z_max) = min_max_abs_for_abs x in Fd.refine_low_up z z_min z_max; let z_min, z_max = Fd.min_max z in assert (z_min >= 0); let d = Fcl_domain.remove_closed_inter (-z_min+1) (z_min-1) (Fcl_domain.remove_low_up (-z_max) z_max (Attr.dom xa)) in Fd.refine x d; false end in Fcl_debug.call 'a' (fun s -> fprintf s "%s - after update : %a=|%a|\n" name Fd.fprint z Fd.fprint x); r in C.create ~name ~fprint update delay (* z = x1 / x2 *) let min_max_div_inter a b c d = if c = d && c = 0 then Fcl_stak.fail "Arith.min_max_div_inter: division_by_zero" else (* Otherwise, we suppose that x2 won't be instantiated to 0 *) let c = if c = 0 then 1 else c and d = if d = 0 then -1 else d in if diffsign c d then (min a (0 - b), max (0 - a) b) else if diffsign a b then if c > 0 then (a/c, b/c) else (b/d, a/d) else if a >= 0 then (* x1 positive *) if c > 0 then (a/d, b/c) else (b/d, a/c) (* x2 positive ou negative *) else (* x1 negative *) if c < 0 then (b/c, a/d) else (a/c, b/d) (* x2 negative ou positive *) (* y = xr[a,b] / z[c,d] *) (* a = min (x-r) , b = max (x-r) *) let min_max_of_div_for_div a b z = (* if 0 belongs to dom(x), no conclusion on y *) if Fd.member z 0 then (min_int, max_int) else let (c, d) = Fd.min_max z in (* is this useful? only waken on min or max modif... *) if sign c * sign d < 0 then (* c < 0 < d *) match Fd.value z with Unk za -> let domz = Attr.dom za in let (c', d') = Fcl_domain.largest_hole_around domz 0 in (min (a /+ d') (b /+ c'), max (a /- c') (b /- d')) (* if z was ground, c*d >= 0 *) | _ -> Fcl_debug.internal_error "min_max_of_div_for_mult : z ground" (* 0 < c || d < 0 *) else if sign a * sign b < 0 then (* a < 0 < b *) if c > 0 then (a /+ c, b /- c) else (b /+ d, a /- d) else if a >= 0 then (* xr positive *) if c > 0 then (a /+ d, b /- c) else (b /+ d, a /- c) (* z positive or negative *) else (* xr negative *) if c < 0 then (b /+ c, a /- d) else (a /+ c, b /- d) (* z negative or positive *) (* z=x/y, x=y*z+r *) (* if x >= 0 then r >= 0 else r <= 0 *) let min_max_of_remainder x y = let r_abs_max = let min_y, max_y = Fd.min_max y in max (Pervasives.abs min_y) (Pervasives.abs max_y) - 1 in if Fd.min x >= 0 then (0, r_abs_max) else if Fd.max x <= 0 then ((0 - r_abs_max), 0) else ((0 - r_abs_max), r_abs_max) (* z = x / y *) let division z x y = let zero_removed = Fcl_stak.ref false in let min_max_r () = min_max_of_remainder x y in let compute_bounds () = (Fd.min_max z, Fd.min_max x, Fd.min_max y) in let name = "division" in let delay c = delay [Fd.on_min; Fd.on_max] z c; delay [Fd.on_min; Fd.on_max] x c; delay [Fd.on_min; Fd.on_max] y c and fprint c = Printf.fprintf c "%a = %a / %a" Fd.fprint z Fd.fprint x Fd.fprint y; flush c and update _ = Fcl_debug.call 'a' (fun s -> fprintf s "%s - before update : %a = %a / %a\n" name Fd.fprint z Fd.fprint x Fd.fprint y); if not (Fcl_stak.get zero_removed) then begin begin match Fd.value y with Unk ya -> Fd.refine y (Fcl_domain.remove 0 (Attr.dom ya)) | Val 0 -> Fcl_stak.fail (name ^ ": division by zero") | _ -> () end; Fcl_stak.set zero_removed true end; (* 0 does not belong to dom(y) *) let rec loop bounds = match Fd.value x, Fd.value y with Val a, Val b -> Fd.unify z (a / b); true | Val 0, _ -> Fd.unify z 0; true | _x_val, _y_val -> let (a, b) = Fd.min_max x and (c, d) = Fd.min_max y in let (z_min, z_max) = min_max_div_inter a b c d in Fcl_debug.call 'a' (fun s -> fprintf s "z_min=%d z_max=%d " z_min z_max); Fd.refine_low_up z z_min z_max; (* x = y*z + r *) let (a, b) = Fd.min_max y and (c, d) = Fd.min_max z in let (yz_min, yz_max) = min_max_mult_inter a b c d and (r_min, r_max) = min_max_r () in let (x_min, x_max) = Linear.min_max_plus_inter yz_min yz_max r_min r_max in Fcl_debug.call 'a' (fun s -> fprintf s "x_min=%d x_max=%d " x_min x_max); Fd.refine_low_up x x_min x_max; (* y = (x-r) / z *) let (r_min, r_max) = min_max_r () in let xr_min = Fd.min x - r_max and xr_max = Fd.max x - r_min in let (y_min, y_max) = min_max_of_div_for_div xr_min xr_max z in Fcl_debug.call 'a' (fun s -> fprintf s "y_min=%d y_max=%d\n" y_min y_max); Fd.refine_low_up y y_min y_max; let new_bounds = compute_bounds () in if bounds <> new_bounds then loop new_bounds else false in let r = loop (compute_bounds ()) in Fcl_debug.call 'a' (fun s -> fprintf s "%s - after update : %a = %a / %a\n" name Fd.fprint z Fd.fprint x Fd.fprint y); r in C.create ~name ~fprint update delay let min_max_abs_inter a b = if a >= 0 then (a, b) else if b <= 0 then (0 - b, 0 - a) else (0, max (0 - a) b) let min_max_mod_inter a b c d = let (c, d) = min_max_abs_inter c d in if a >= 0 then (* x1 >= 0 *) (min_of_absmod_inter a b c d, max_of_absmod_inter a b c d) else if b <= 0 then (* x1 <= 0 *) let (a, b) = min_max_abs_inter a b in (0 - max_of_absmod_inter a b c d, 0 - min_of_absmod_inter a b c d) else (0 - max_of_absmod_inter 0 (-a) c d, max_of_absmod_inter 0 b c d) (* y = (x-z) / (x/y) *) let min_max_of_div_for_mod a b c d = (* if 0 belongs to domain of x/y, no conclusion on y *) if c <= 0 && d >= 0 then (min_int, max_int) else (* x/y positive ou negative *) if sign a * sign b < 0 then (* xz à cheval sur 0 *) if c > 0 then (a /+ c, b /- c) else (b /+ d, a /- d) (* ni xz ni x/y à cheval sur 0 *) else if a >= 0 then (* xz positive *) if c > 0 then (a /+ d, b /- c) else (b /+ d, a /- c) (* x/y positive ou negative *) else (* xz negative *) if c < 0 then (b /+ c, a /- d) else (a /+ c, b /- d) (* x/y negative ou positive *) (* z = x % y *) let modulo z x y = let zero_removed = Fcl_stak.ref false in let min_max_of_xexp () = let (xa, xb) = Fd.min_max x and (yc, yd) = Fd.min_max y in let (xyc, xyd) = min_max_div_inter xa xb yc yd in let (yxya, yxyb) = min_max_mult_inter yc yd xyc xyd in let (zc, zd) = Fd.min_max z in let xmin, xmax = Linear.min_max_plus_inter yxya yxyb zc zd in let xmin = if zc >= 0 then max 0 xmin else xmin and xmax = if zd <= 0 then min 0 xmax else xmax in (xmin, xmax) in let min_max_of_yexp () = let (xa, xb) = Fd.min_max x and (zc, zd) = Fd.min_max z in let (xza, xzb) = Linear.min_max_minus_inter xa xb zc zd in let (yc, yd) = Fd.min_max y in let (xyc, xyd) = min_max_div_inter xa xb yc yd in min_max_of_div_for_mod xza xzb xyc xyd in (* when y is known and b-a < y, c actually is |c| *) let hole a b c = assert (c >= 0); if a >= 0 then (* x >= 0 *) let amodc = a mod c and bmodc = b mod c in if amodc <= bmodc then match Fd.value z with Val v -> (* a/c = b/c *) let xv = c * (a / c) + v in Fd.subst x xv; raise Exit | _ -> Fd.refine_low_up z amodc bmodc else match Fd.value z with Unk attrz -> let newdom = Fcl_domain.union (Fcl_domain.interval 0 bmodc) (Fcl_domain.interval amodc (c-1)) in Fd.refine z (Fcl_domain.intersection newdom (Attr.dom attrz)) | Val v -> let ab = (* a/c = b/c - 1 *) if v >= amodc && v < c then a else if v <= bmodc && v >= 0 then b else Fcl_stak.fail "Nonlinear.modulo" in let xv = c * (ab / c) + v in Fd.subst x xv; raise Exit else if b <= 0 then (* x <= 0 *) let amodc = a mod c and bmodc = b mod c in if amodc <= bmodc then match Fd.value z with Val v -> (* a/c = b/c *) let xv = c * (a / c) + v in Fd.subst x xv; raise Exit | _ -> Fd.refine_low_up z amodc bmodc else match Fd.value z with Unk attrz -> let newdom = Fcl_domain.union (* c >= 0 *) (Fcl_domain.interval amodc 0) (Fcl_domain.interval (1-c) bmodc) in Fd.refine z (Fcl_domain.intersection newdom (Attr.dom attrz)) | Val v -> let ab = (* b/c = a/c - 1 *) if v <= bmodc && v > -c then b else if v >= amodc && v <= 0 then a else Fcl_stak.fail "Nonlinear.modulo" in let xv = c * (ab / c) + v in Fd.subst x xv; raise Exit (* 0 strictly belongs to [a,b] so -|c| < a < 0 < b < |c| *) else Fd.refine_low_up z a b in let compute_bounds () = (Fd.min_max z, Fd.min_max x, Fd.min_max y) in let name = "modulo" in let delay c = delay [Fd.on_min; Fd.on_max] z c; delay [Fd.on_min; Fd.on_max] x c; delay [Fd.on_min; Fd.on_max] y c and fprint c = Printf.fprintf c "%a = %a %% %a" Fd.fprint z Fd.fprint x Fd.fprint y; flush c and update _ = Fcl_debug.call 'a' (fun s -> fprintf s "%s - before update : %a = %a %% %a\n" name Fd.fprint z Fd.fprint x Fd.fprint y); if not (Fcl_stak.get zero_removed) then begin begin match Fd.value y with Unk ya -> Fd.refine y (Fcl_domain.remove 0 (Attr.dom ya)) | Val 0 -> Fcl_stak.fail (name ^ ": division by zero") | _ -> () end; Fcl_stak.set zero_removed true end; (* 0 does not belong to dom(y) *) let rec loop bounds = match Fd.value x, Fd.value y with Val a, Val b -> Fd.unify z (a mod b); true | Val 0, _ -> Fd.unify z 0; true | _x_val, _y_val -> let (a, b) = Fd.min_max x and (c, d) = Fd.min_max y in if c = d && b - a < abs c then (* y known *) hole a b (abs c) else begin let (z_min, z_max) = min_max_mod_inter a b c d in Fcl_debug.call 'a' (fun s -> fprintf s "z_min=%d z_max=%d " z_min z_max); Fd.refine_low_up z z_min z_max end; (* x = y*(x/y) + z *) let (x_min, x_max) = min_max_of_xexp () in Fcl_debug.call 'a' (fun s -> fprintf s "x_min=%d x_max=%d " x_min x_max); Fd.refine_low_up x x_min x_max; (* y = (x-z) / (x/y) *) let (y_min, y_max) = min_max_of_yexp () in Fcl_debug.call 'a' (fun s -> fprintf s "y_min=%d y_max=%d\n" y_min y_max); Fd.refine_low_up y y_min y_max; let new_bounds = compute_bounds () in if bounds <> new_bounds then loop new_bounds else false in (* function hole raises Exit when the constraint is satisfied *) let r = try loop (compute_bounds ()) with Exit -> true in Fcl_debug.call 'a' (fun s -> fprintf s "%s - after update : %a = %a %% %a\n" name Fd.fprint z Fd.fprint x Fd.fprint y); r in C.create ~name ~fprint update delay let expn_int x n = if n < 0 then Fcl_debug.fatal_error "Arith.expn_int: negative exponent" else let rec loop = function 0 -> 1 | n -> let n2 = n / 2 in let xn2 = loop n2 in let xn = xn2 * xn2 in if n mod 2 = 0 then xn else xn * x in loop n let min_max_expn_inter a b n = assert (a <= b); if n < 0 then Fcl_debug.fatal_error "Nonlinear.min_max_expn_inter: negative exponent" else if n = 0 then (1, 1) else let an = expn_int a n and bn = expn_int b n in if n mod 2 = 0 then if a >= 0 then (an, bn) else if b <= 0 then (bn, an) else if an <= bn then (0, bn) else (0, an) else (an , bn) let min_max_of_expn x n = assert (n > 1); match Fd.value x with Unk xa -> let min_xa = Attr.min xa and max_xa = Attr.max xa in let min_xan = expn_int min_xa n and max_xan = expn_int max_xa n in if n mod 2 = 0 then (* even exponent *) if min_xa >= 0 then (min_xan, max_xan) (* positive domain *) else if max_xa <= 0 then (max_xan, min_xan) (* negative domain *) else let domx = Attr.dom xa in let min_neg = Fcl_domain.greatest_leq domx 0 and min_pos = Fcl_domain.smallest_geq domx 0 in let minn = if -min_neg < min_pos then expn_int min_neg n else expn_int min_pos n and maxn = max min_xan max_xan in (minn, maxn) (* L'exposant est impair *) else (min_xan, max_xan) | Val c -> let cn = expn_int c n in (cn, cn) let nth_root upper z n = (* Root of a negative number returns nan, so computation is done with the absolute value *) let az = abs z and sz = sign z in let znth = truncate (float az ** (1. /. float n)) in if expn_int znth n = az then sz * znth else (* float computation may return z^(1/n)-e, rounded by truncate to the preceding integer of the actual root *) let znmore = znth + 1 in if expn_int znmore n = az then sz * znmore else if upper then if z >= 0 then znmore else (0 - znth) else if z >= 0 then znth else (0 - znmore) let ( **/+) = nth_root true let ( **/-) = nth_root false let min_max_of_nth_root z n = (Fd.min z **/+ n, Fd.max z **/- n) let int_root z n = let az = abs z and sz = sign z in let znth = truncate (float az ** (1. /. float n)) in if expn_int znth n = az then sz * znth else let znmore = znth + 1 in if expn_int znmore n = az then sz * znmore else raise Not_found (* z = x^n *) let expn z x n = let even = n mod 2 = 0 and compute_bounds () = (Fd.min_max z, Fd.min_max x) in let name = "expn" in let delay c = delay [Fd.on_min; Fd.on_max] z c; delay [Fd.on_min; Fd.on_max] x c and fprint c = Printf.fprintf c "%a = %a ^ %d" Fd.fprint z Fd.fprint x n; flush c and update _ = Fcl_debug.call 'a' (fun s -> fprintf s "%s - before update : %a = %a ^ %d\n" name Fd.fprint z Fd.fprint x n); let rec loop bounds = match Fd.value x, Fd.value z with Val a, _ -> Fd.unify z (expn_int a n); true | Unk xa, Val c -> begin try let root = int_root c n in if even then Fd.refine x (Fcl_domain.intersection (Fcl_domain.create [-root; root]) (Attr.dom xa)) else Fd.subst x root; true with Not_found -> Fcl_stak.fail name end | Unk xa, Unk za -> let (z_min, z_max) = min_max_of_expn x n in Fcl_debug.call 'a' (fun s -> fprintf s "%s - Unk xa, Unk za : z_min=%d z_max=%d " name z_min z_max); Fd.refine z (Fcl_domain.remove_low_up z_min z_max (Attr.dom za)); let (x_min, x_max) = min_max_of_nth_root z n in Fcl_debug.call 'a' (fun s -> if even then fprintf s "%s (even) - Unk xa, za : x_neg=[%d,%d] x_pos=[%d,%d]\n" name (-x_max) (-x_min) x_min x_max else fprintf s "%s (odd) - Unk xa, Unk za : x_min=%d x_max=%d\n" name x_min x_max); if even then (* [-x_max_pos, -x_min_pos] U [x_min_pos, x_max_pos] *) let d = Fcl_domain.remove_closed_inter (-x_min+1) (x_min-1) (Fcl_domain.remove_low_up (-x_max) x_max (Attr.dom xa)) in Fd.refine x d else (* [x_min, x_max] *) Fd.refine x (Fcl_domain.remove_low_up x_min x_max (Attr.dom xa)); let new_bounds = compute_bounds () in if bounds <> new_bounds then loop new_bounds else false in let r = loop (compute_bounds ()) in Fcl_debug.call 'a' (fun s -> fprintf s "expn - after update : %a = %a ^ %d\n" Fd.fprint z Fd.fprint x n); r in C.create ~name ~fprint update delay let aux2 bounds x y = let (a, b) = Fd.min_max x and (c, d) = Fd.min_max y in let (z_min, z_max) = bounds a b c d in Fd.interval z_min z_max let monome_aux = aux2 min_max_mult_inter let division_aux = aux2 min_max_div_inter let modulo_aux = aux2 min_max_mod_inter let absolute_aux x = let (z_min, z_max) = min_max_abs_for_abs x in Fd.interval z_min z_max let expn_aux x n = assert (n > 0); if n = 1 then x else let (mini, maxi) = min_max_of_expn x n in Fd.interval mini maxi facile-1.1/src/fcl_expr.ml0000644005005300001440000005717210117553006016334 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) open Fcl_misc.Operators open Fcl_var (* operators *) type agg_op = Pluse | Multe type bin_op = Dive | Mode type un_op = Abse (* genuine or symbolic auxilliary variable *) type var = Var of Fd.t | Aux of int (* compiled expressions *) (* they are normalized by sorting unordered subexpressions according to compare_expr and compare_intexpr *) (* beware: convention for sums is Sigma (coef_i * exp_i) + cst whereas Fcl_linear functions and constraints assume that the constant is at the rhs : Sigma (coef_i * exp_i) = cst *) type t = (* sum : op * (coef * exp) list * cst *) (* prod : op * (exposant * exp) list * cst *) Agg of agg_op * (int * t) list * int | Bin of bin_op * t * t | Un of un_op * t | Inte of int | Fde of var let rec iter_last f last = function [] -> () | [x] -> last x | x :: xs -> begin f x; iter_last f last xs end let fprint_var c = function Var v -> Fd.fprint c v | Aux id -> Printf.fprintf c "vaux_%d" id type priority = PrioTop | PrioPlus | PrioMul | PrioExp let rec fprint prio c e = let left p = if p < prio then Printf.fprintf c "(" and right p = if p < prio then Printf.fprintf c ")" in match e with Agg (Pluse, es, ct) -> begin left PrioPlus; let print (coef, e) = match coef with 1 -> Printf.fprintf c "%a" (fprint PrioPlus) e | -1 -> Printf.fprintf c "-%a" (fprint PrioMul) e | _ -> Printf.fprintf c "%d*%a" coef (fprint PrioMul) e in begin match es with [] -> assert false | e::es -> print e; List.iter (fun e -> Printf.fprintf c " + "; print e) es end; if ct <> 0 then Printf.fprintf c " + %d" ct; right PrioPlus end | Agg (Multe, es, ct) -> begin left PrioMul; let print (coef, e) = if coef <> 1 then Printf.fprintf c "%a ^ %d" (fprint PrioExp) e coef else Printf.fprintf c "%a" (fprint PrioMul) e in begin match es with [] -> assert false | e::es -> print e; List.iter (fun e -> Printf.fprintf c " * "; print e) es end; if ct <> 1 then Printf.fprintf c " * %d" ct; right PrioMul end | Bin (op, e1, e2) -> let op = match op with Dive -> "/" | Mode -> "%" in left PrioMul; Printf.fprintf c "%a %s %a" (fprint PrioExp) e1 op (fprint PrioExp) e2; right PrioMul | Un (Abse, e) -> Printf.fprintf c "|%a|" (fprint PrioTop) e | Inte i -> Printf.fprintf c "%d" i | Fde v -> fprint_var c v let fprint = fprint PrioTop let rec min_max_of_expr = function Inte x -> (x, x) | Fde x -> begin match x with Var v -> Fd.min_max v | _ -> Fcl_debug.fatal_error "Expr.min_max_of_expr: symbolic variable" end | Bin (typ, x1, x2) -> begin let (a, b) = min_max_of_expr x1 and (c, d) = min_max_of_expr x2 in match typ with Dive -> Fcl_nonlinear.min_max_div_inter a b c d | Mode -> Fcl_nonlinear.min_max_mod_inter a b c d end | Un (Abse, x) -> let (a, b) = min_max_of_expr x in Fcl_nonlinear.min_max_abs_inter a b | Agg (Pluse, es, c) -> let (a, b) = List.fold_left (fun (acca, accb) (coef, e) -> let (a, b) = min_max_of_expr e in let (coefa, coefb) = Fcl_nonlinear.min_max_mult_inter a b coef coef in Fcl_linear.min_max_plus_inter coefa coefb acca accb) (0, 0) es in Fcl_linear.min_max_plus_inter c c a b | Agg (Multe, es, c) -> let (a, b) = List.fold_left (fun (acca, accb) (n, e) -> let (a, b) = min_max_of_expr e in let (coefa, coefb) = Fcl_nonlinear.min_max_expn_inter a b n in Fcl_nonlinear.min_max_mult_inter coefa coefb acca accb) (1, 1) es in Fcl_nonlinear.min_max_mult_inter a b c c let min_of_expr e = let (a, _) = min_max_of_expr e in a let max_of_expr e = let (_, b) = min_max_of_expr e in b let rec eval = function Inte x -> x | Fde x -> begin match x with Var v -> begin match Fd.value v with Unk _ -> let msg = Printf.sprintf "Expr.eval: variable %s unknown" (Fd.name v) in Fcl_debug.fatal_error msg | Val i -> i end | _ -> Fcl_debug.fatal_error "Expr.eval: symbolic variable" end | Bin (typ, x1, x2) -> begin let ex2 = eval x2 in if ex2 = 0 then Fcl_debug.fatal_error "Expr.eval: division by zero"; let ex1 = eval x1 in match typ with Dive -> ex1 / ex2 | Mode -> ex1 mod ex2 end | Un (Abse, x) -> abs (eval x) | Agg (typ, es, c) -> let (op, coef_op) = match typ with Pluse -> (( + ), ( * )) | Multe -> (( * ), Fcl_nonlinear.expn_int) in List.fold_left (fun acc (coef, se) -> op acc (coef_op (eval se) coef)) c es (* order on lists according to their size then to each element according to [cmp] *) let compare_list cmp lx ly = let rec comp_iter lx ly = match (lx, ly) with ([], []) -> 0 | (x :: xs, y :: ys) -> let cxy = cmp x y in if cxy <> 0 then cxy else comp_iter xs ys | _ -> assert false in let cs = compare (List.length lx) (List.length ly) in if cs <> 0 then cs else comp_iter lx ly let compare_var x y = match (x, y) with (Var x, Var y) -> Fd.compare x y | (Aux x, Aux y) -> compare x y | (Aux _, Var _) -> -1 | (Var _, Aux _) -> 1 (* order on compiled expressions *) let rec compare_expr x y = match (x, y) with (* same constructors *) (Inte x, Inte y) -> compare x y | (Fde x, Fde y) -> compare_var x y | (Un (opx, x), Un (opy, y)) -> let cop = compare opx opy in if cop <> 0 then cop else compare_expr x y | (Bin (opx, x1, x2), Bin (opy, y1, y2)) -> let cop = compare opx opy in if cop <> 0 then cop else let c1 = compare_expr x1 y1 in if c1 <> 0 then c1 else compare_expr x2 y2 | (Agg (opx, lx, cx), Agg (opy, ly, cy)) -> let cop = compare opx opy in if cop <> 0 then cop else let cc = compare cx cy in if cc <> 0 then cc else (* lx and ly are supposed to be already sorted *) (* let lx = List.sort compare_intexpr lx and ly = List.sort compare_intexpr ly in *) compare_list compare_intexpr lx ly (* different constructors *) | (Inte _, _) -> -1 | (_, Inte _) -> 1 | (Fde _, _) -> -1 | (_, Fde _) -> 1 | (Un _, _) -> -1 | (_, Un _) -> 1 | (Bin _, _) -> -1 | (_, Bin _) -> 1 (* order on (int * exp) couples *) and compare_intexpr (cx, ex) (cy, ey) = let cc = compare cx cy in if cc <> 0 then cc else compare_expr ex ey type exp = t (* module parameter for Hashtbl functor *) module Exp_for_H = struct type t = exp (* alternative representation of compiled expressions for hashing: variables domains are replaced by their id *) type varh = Varh of int | Auxh of int type th = Aggh of agg_op * (int * th) list * int | Binh of bin_op * th * th | Unh of un_op * th | Inteh of int | Fdeh of varh let rec t2th = function Agg (op, l, c) -> (* l is supposed to be already sorted *) (* let l = List.sort compare_intexpr l in*) let lh = List.map (fun (c, e) -> (c, t2th e)) l in Aggh (op, lh, c) | Bin (op, e1, e2) -> Binh (op, t2th e1, t2th e2) | Un (op, e) -> Unh (op, t2th e) | Inte c -> Inteh c | Fde x -> begin match x with Var v -> begin match Fd.value v with Unk _ -> Fdeh (Varh (Fd.id v)) | Val c -> Inteh c end | Aux i -> Fdeh (Auxh i) end let equal x y = compare_expr x y = 0 let hash e = Hashtbl.hash (t2th e) end (* Hashtbl on compiled expressions *) module HE = Hashtbl.Make(Exp_for_H) (* deprecated conversion function between former expressions representation and current one *) (* let rec user2exp = function Int i -> Inte i | Fd v -> begin match Fd.value v with Val i -> Inte i | _ -> Fde v end | Plus (e1, e2) -> let l = [(1, user2exp e1); (1, user2exp e2)] in let l = List.sort compare_intexpr l in Agg (Pluse, l, 0) | Mult (e1, e2) -> let l = [(1, user2exp e1); (1, user2exp e2)] in let l = List.sort compare_intexpr l in Agg (Multe, l, 1) | Minus e -> Agg (Pluse, [(-1, user2exp e)], 0) | Div (e1, e2) -> Bin (Dive, user2exp e1, user2exp e2) | Mod (e1, e2) -> Bin (Mode, user2exp e1, user2exp e2) | Abs e -> Un (Abse, user2exp e) *) let merge es = let coef_exps = HE.create 11 in let add_or_create (c, e) = try let oldc = HE.find coef_exps e in oldc := !oldc + c with Not_found -> HE.add coef_exps e (ref c) in List.iter add_or_create es; let l = HE.fold (fun e c acc -> if !c <> 0 then (!c, e) :: acc else acc) coef_exps [] in List.sort compare_intexpr l (* normalize expressions *) let rec reduce = function Inte _ as e -> e | Fde _ as e -> e | Bin (Dive, e1, e2) -> begin match (reduce e1, reduce e2) with (re1, Inte 0) -> Fcl_debug.fatal_error "Arith.reduce: division by zero" | (re1, Inte 1) -> re1 | (Inte 0 as re1, re2) -> re1 | (Inte i1, Inte i2) -> Inte (i1 / i2) | (re1, re2) -> Bin (Dive, re1, re2) end | Bin (Mode, e1, e2) -> begin match (reduce e1, reduce e2) with (re1, Inte 0) -> Fcl_debug.fatal_error "Arith.reduce: modulo by zero" | (_, Inte 1) -> Inte 0 | (Inte 0 as re1, re2) -> re1 | (Inte i1, Inte i2) -> Inte (i1 mod i2) | (re1, re2) -> Bin (Mode, re1, re2) end | Un (Abse, e) -> begin match reduce e with Inte i -> Inte (abs i) | re -> Un (Abse, re) end | Agg (typ, es, c) -> begin match agg_reduce typ es c with (0, _) when typ = Multe -> Inte 0 | (rc, []) -> Inte rc | (0, [(1, e)]) when typ = Pluse -> e | (1, [(1, e)]) when typ = Multe -> e (* type of aggregate is changed, so it is reduced once more *) | (rc, [(1, e)]) when typ = Multe -> reduce (Agg (Pluse, [(rc, e)], 0)) (* Pi res * rc -> Sum rc * (Pi res * 1) + 0 *) | (rc, res) when typ = Multe && rc <> 1 -> Agg (Pluse, [(rc, Agg (Multe, res, 1))], 0) | (rc, res) -> Agg (typ, res, rc) end and agg_reduce typ es c = let (op, coef_op) = match typ with Pluse -> (( + ), ( * )) | Multe -> (( * ), Fcl_nonlinear.expn_int) in let rec agg_reduce_rec new_es c = function [] -> (c, merge new_es) | (0, e) :: es -> agg_reduce_rec new_es c es | (coef, e) :: es -> begin match reduce e with (* Pi ... * 0 ^ coef * ... -> 0 *) Inte 0 as re when typ = Multe -> (0, []) | Inte i -> agg_reduce_rec new_es (op c (coef_op i coef)) es (* Sum ... + coef * (Sum ees + ec) + ... -> Sum ... *) (* Pi ... * (ec * Pi ees) ^ coef * ... -> Pi ... *) | Agg (etyp, ees, ec) when etyp = typ -> let new_ees = List.map (fun (eec, ee) -> (coef * eec, reduce ee)) ees in agg_reduce_rec (new_ees @ new_es) (op c (coef_op ec coef)) es (* Sum ... + coef * (ec * Pi ee) + ... -> Sum ... + coef * ec * ee + ... *) | Agg (Multe, [(1, ee)], ec) when typ = Pluse -> agg_reduce_rec ((coef * ec, ee) :: new_es) c es (* Sum ... + coef * (ec * Pi ees) + ... -> Sum ... + (coef * ec) * (Pi ee) + ... *) | Agg (Multe, ees, ec) when typ = Pluse -> agg_reduce_rec ((coef * ec, Agg (Multe, ees, 1)) :: new_es) c es (* Pi ... * (Sum ec * ee) ^ coef * ... -> Pi ... * ee ^ coef * ... * (c * ec ^ coef) *) | Agg (Pluse, [(ec, ee)], 0) when typ = Multe -> agg_reduce_rec ((coef, ee) :: new_es) (op c (coef_op ec coef)) es | re -> agg_reduce_rec ((coef, re) :: new_es) c es end in agg_reduce_rec [] c es (* compute intermediate equation and symbolic auxilliary variables *) let equations e = (* auxilliary variables are first only named (not created) to avoid computing useless expression bounds (allows Linear.basic_refinements to be used on plain sums) and variables (the last one for equality constraints) *) let gen_auxvar = Fcl_misc.gen_int_fun () in let eqs = HE.create 11 in let add e lhs = let vaux = gen_auxvar () in HE.add eqs e (vaux, lhs); Aux vaux in let rec process = function (* replace integers by variables inside intermediate equations *) Inte i -> Var (Fd.elt i) | Fde v -> v | e -> begin try let (ve, _eq) = HE.find eqs e in Aux ve with Not_found -> begin (* computation of intermediate variables and corresponding equations *) (* constraints are not posted yet *) match e with Un (Abse, se) -> let vse = process se in add e (Un (Abse, Fde vse)) | Bin (typ, se1, se2) -> let vse1 = process se1 and vse2 = process se2 in add e (Bin (typ, Fde vse1, Fde vse2)) | Agg (_, [], _) -> Fcl_debug.internal_error "Expr.equations: empty aggregate list" | Agg (Pluse, ses, c) -> begin let vses = List.map (fun (coef, se) -> (coef, Fde (process se))) ses in add e (Agg (Pluse, vses, c)) end | Agg (Multe, [(coef, se)], 1) -> begin assert (coef > 1); let vse = process se in add e (Agg (Multe, [(coef, Fde vse)], 1)) end | Agg (Multe, ses, 1) -> begin (* intermediate exponentiation *) let vses = List.map (function (1, se) as coef_se -> (process se, coef_se) | (coef, se) as coef_se -> let vse_coef = process (Agg (Multe, [(coef, se)], 1)) in (* couples with coef are kept for further hashing of partial products *) (vse_coef, coef_se)) ses in let vses = List.sort (fun (_, coef_se1) (_, coef_se2) -> compare_intexpr coef_se1 coef_se2) vses in let (vaux, _) = fold_multe vses in vaux end | Agg (Multe, _, c) -> Fcl_debug.internal_error "Expr.equations: non neutral product constant" | _ -> assert false end end and fold_multe = function [(vse, coef_se)] -> (vse, [coef_se]) | (vse, coef_se) :: rest -> begin let (acc_vaux, acc_exp) = fold_multe rest in let lhs_list = List.sort compare_intexpr [(1, Fde vse); (1, Fde acc_vaux)] in let lhs = Agg (Multe, lhs_list, 1) in let vses = coef_se :: acc_exp in let e = Agg (Multe, vses, 1) in let vaux = add e lhs in (vaux, vses) end | _ -> Fcl_debug.internal_error "Expr.fold_multe: empty list" in let vfinal = process e in (vfinal, eqs) let fprint_eqs c eqs = List.iter (fun (vaux, lhs) -> Printf.fprintf c "%a = %a\n" fprint_var (Aux vaux) fprint lhs) eqs let bintype2cstr = function Dive -> Fcl_nonlinear.division | Mode -> Fcl_nonlinear.modulo let bintype2aux = function Dive -> Fcl_nonlinear.division_aux | Mode -> Fcl_nonlinear.modulo_aux let emptyh h = try HE.iter (fun _ _ -> raise Exit) h; true with Exit -> false let interm eqs re = try let (_, term) = HE.find eqs re in term with Not_found -> re let get_var vars = function Var v -> v | Aux i -> Hashtbl.find vars i let intfde2intfd vars vses = List.map (function (coef, Fde vse) -> (coef, get_var vars vse) | _ -> assert false) vses let post_eqs eqs = let vars = Hashtbl.create 11 in let eqs_list = HE.fold (fun _ eq acc -> eq :: acc) eqs [] in (* equations must be sorted to generate auxilliary variables in the right order *) let eqs_sorted = List.sort (fun (i1, _) (i2, _) -> compare i1 i2) eqs_list in Fcl_debug.call 'a' (fun s -> Printf.fprintf s "to be posted:\n%a\n" fprint_eqs eqs_sorted); List.iter (fun (i, lhs) -> let cstr = match lhs with Un (Abse, Fde vse) -> begin let vse = get_var vars vse in let vaux = Fcl_nonlinear.absolute_aux vse in Hashtbl.add vars i vaux; Fcl_nonlinear.absolute vaux vse end | Bin (typ, Fde vse1, Fde vse2) -> begin let vse1 = get_var vars vse1 and vse2 = get_var vars vse2 in let vaux = (bintype2aux typ) vse1 vse2 in Hashtbl.add vars i vaux; (bintype2cstr typ) vaux vse1 vse2 end | Agg (Multe, [(coef, Fde vse)], 1) -> begin assert (coef > 1); let vse = get_var vars vse in let vaux = Fcl_nonlinear.expn_aux vse coef in Hashtbl.add vars i vaux; Fcl_nonlinear.expn vaux vse coef end | Agg (Pluse, vses, c) -> begin assert (match (vses, c) with ([(1, _)], 0) -> false | _ -> true); let vses = List.map (function (coef, Fde vse) -> (coef, get_var vars vse) | _ -> assert false) vses in let vaux = Fcl_linear.linear_aux vses (0 - c) in Hashtbl.add vars i vaux; Fcl_linear.cstr ((-1, vaux) :: vses) Fcl_linear.Equal (0 - c) end | Agg (Multe, [(1, Fde vse1); (1, Fde vse2)], 1) -> begin let vse1 = get_var vars vse1 and vse2 = get_var vars vse2 in let vaux = Fcl_nonlinear.monome_aux vse1 vse2 in Hashtbl.add vars i vaux; Fcl_nonlinear.monome vaux vse1 vse2 end | _ -> assert false in Fcl_cstr.post cstr) eqs_sorted; vars (* remove vse = ct when vse = a simple nonlinear equation *) let remove_basic_cstr1 eqs vse sre ct = match interm eqs sre with Un (Abse, Fde vsse) -> begin HE.remove eqs sre; let vars = post_eqs eqs in let vsse = get_var vars vsse in Fcl_nonlinear.absolute (Fcl_var.Fd.int ct) vsse end | Bin (typ, Fde vsse1, Fde vsse2) -> begin HE.remove eqs sre; let vars = post_eqs eqs in let vsse1 = get_var vars vsse1 and vsse2 = get_var vars vsse2 in (bintype2cstr typ) (Fcl_var.Fd.int ct) vsse1 vsse2 end | Agg (Multe, [(1, Fde vsse1); (1, Fde vsse2)], 1) -> begin HE.remove eqs sre; let vars = post_eqs eqs in let vsse1 = get_var vars vsse1 and vsse2 = get_var vars vsse2 in Fcl_nonlinear.monome (Fcl_var.Fd.int ct) vsse1 vsse2 end | Agg (Multe, [(coef, Fde vsse)], 1) -> begin HE.remove eqs sre; let vars = post_eqs eqs in let vsse = get_var vars vsse in Fcl_nonlinear.expn (Fcl_var.Fd.int ct) vsse coef end | _ -> let vars = post_eqs eqs in let vse = get_var vars vse in Fcl_linear.cstr [(1, vse)] Fcl_linear.Equal ct (* remove vse1 = vse2 when vse1 or vse2 = a simple nonlinear equation *) let remove_basic_cstr2 eqs vse1 vse2 sre1 sre2 = match (interm eqs sre1, interm eqs sre2) with (Un (Abse, Fde vsse1), _) -> begin HE.remove eqs sre1; let vars = post_eqs eqs in let vse2 = get_var vars vse2 and vsse1 = get_var vars vsse1 in Fcl_nonlinear.absolute vse2 vsse1 end | (_, Un (Abse, Fde vsse2)) -> begin HE.remove eqs sre2; let vars = post_eqs eqs in let vse1 = get_var vars vse1 and vsse2 = get_var vars vsse2 in Fcl_nonlinear.absolute vse1 vsse2 end | (Bin (typ, Fde vsse1, Fde vsse2), _) -> begin HE.remove eqs sre1; let vars = post_eqs eqs in let vsse1 = get_var vars vsse1 and vsse2 = get_var vars vsse2 and vse2 = get_var vars vse2 in (bintype2cstr typ) vse2 vsse1 vsse2 end | (_, Bin (typ, Fde vsse1, Fde vsse2)) -> begin HE.remove eqs sre2; let vars = post_eqs eqs in let vsse1 = get_var vars vsse1 and vsse2 = get_var vars vsse2 and vse1 = get_var vars vse1 in (bintype2cstr typ) vse1 vsse1 vsse2 end | (Agg (Multe, [(1, Fde vsse1); (1, Fde vsse2)], 1), _) -> begin HE.remove eqs sre1; let vars = post_eqs eqs in let vsse1 = get_var vars vsse1 and vsse2 = get_var vars vsse2 and vse2 = get_var vars vse2 in Fcl_nonlinear.monome vse2 vsse1 vsse2 end | (_, Agg (Multe, [(1, Fde vsse1); (1, Fde vsse2)], 1)) -> begin HE.remove eqs sre2; let vars = post_eqs eqs in let vsse1 = get_var vars vsse1 and vsse2 = get_var vars vsse2 and vse1 = get_var vars vse1 in Fcl_nonlinear.monome vse1 vsse1 vsse2 end | (Agg (Multe, [(coef, Fde vsse)], 1), _) -> begin HE.remove eqs sre1; let vars = post_eqs eqs in let vsse = get_var vars vsse and vse2 = get_var vars vse2 in Fcl_nonlinear.expn vse2 vsse coef end | (_, Agg (Multe, [(coef, Fde vsse)], 1)) -> begin HE.remove eqs sre2; let vars = post_eqs eqs in let vsse = get_var vars vsse and vse1 = get_var vars vse1 in Fcl_nonlinear.expn vse1 vsse coef end | _ -> let vars = post_eqs eqs in let vse1 = get_var vars vse1 and vse2 = get_var vars vse2 in Fcl_linear.cstr [(-1, vse1); (1, vse2)] Fcl_linear.Equal 0 let constrain e rel = (* e rel 0 *) let re = reduce e in (* vfinal = re, vfinal rel 0 *) let (vfinal, eqs) = equations re in (* termfinal rel 0 *) (* (Inte i) cannot appear in equations but may in [re] when eqs is empty *) (* get final equation: vfinal = termfinal *) let termfinal = interm eqs re in let cstr = match rel with Fcl_linear.Equal -> begin (* last equation is useless *) HE.remove eqs re; match termfinal with Inte 0 -> begin assert (emptyh eqs); Fcl_cstr.one end (* 0 = 0 *) | Inte i -> begin assert (emptyh eqs); Fcl_cstr.zero end (* i = 0 *) | Fde x -> let vars = post_eqs eqs in let v = get_var vars x in Fcl_linear.cstr [(1, v)] Fcl_linear.Equal 0 (* v = 0 *) | Un (Abse, Fde vse) -> (* |v| = 0 *) let vars = post_eqs eqs in let vse = get_var vars vse in Fcl_linear.cstr [(1, vse)] Fcl_linear.Equal 0 | Bin (typ, Fde vse1, Fde vse2) -> let vars = post_eqs eqs in let vse1 = get_var vars vse1 and vse2 = get_var vars vse2 in (bintype2cstr typ) (Fd.int 0) vse1 vse2 | Agg (Multe, [(1, Fde vse1); (1, Fde vse2)], 1) -> let vars = post_eqs eqs in let vse1 = get_var vars vse1 and vse2 = get_var vars vse2 in Fcl_nonlinear.monome (Fd.int 0) vse1 vse2 | Agg (Multe, [(coef, Fde vse)], 1) -> begin assert (coef > 1); (* only true exponentiation *) (* vse ^ n = 0 <=> vse = 0 *) let vars = post_eqs eqs in let vse = get_var vars vse in Fcl_linear.cstr [(1, vse)] Fcl_linear.Equal 0 end | Agg (Pluse, vses, ct) -> begin (* vse1 = vse2 or vse = ct here we can remove some useless equations if one of the two subexpressions is a simple non-linear expression *) match vses with [(-1, Fde vse1); (1, Fde vse2)] when ct = 0 -> begin match re with (* vse1 = sre1 and vse2 = sre2 *) Agg (Pluse, [(-1, sre1); (1, sre2)], 0) -> remove_basic_cstr2 eqs vse1 vse2 sre1 sre2 | _ -> assert false end | [(-1, Fde vse)] -> begin (* vse = ct *) match re with Agg (Pluse, [(-1, sre)], ct) -> remove_basic_cstr1 eqs vse sre ct | _ -> assert false end | [(1, Fde vse)] -> begin (* vse = ct *) match re with Agg (Pluse, [(1, sre)], ct) -> remove_basic_cstr1 eqs vse sre (0 - ct) | _ -> assert false end | _ -> (* no simplification *) let vars = post_eqs eqs in let vses = intfde2intfd vars vses in Fcl_linear.cstr vses Fcl_linear.Equal (0 - ct) end | _ -> assert false end | _ -> begin (* constraint is not =~ *) match termfinal with Inte i -> begin assert (emptyh eqs); (* no intermediate equations *) match rel with Fcl_linear.Diff -> if i = 0 then Fcl_cstr.zero else Fcl_cstr.one | Fcl_linear.LessThan -> if i <= 0 then Fcl_cstr.one else Fcl_cstr.zero | _ -> assert false end | Fde v -> begin assert (emptyh eqs); (* no intermediate equations *) let v = match v with Var v -> v | _ -> assert false in let cstr = Fcl_linear.cstr [(1, v)] rel 0 in cstr end | Agg (Pluse, vses, ct) -> begin (* final intermediate equation is removed because it can be directly returned *) HE.remove eqs re; let vars = post_eqs eqs in let vses = intfde2intfd vars vses in Fcl_linear.cstr vses rel (0 - ct) end | _ -> (* all other cases, but we could check if [termfinal] is well formed with an OR-pattern *) let vars = post_eqs eqs in let vfinal = get_var vars vfinal in Fcl_linear.cstr [(1, vfinal)] rel 0 end in Fcl_debug.call 'a' (fun s -> Printf.fprintf s "final constraint: %a\n" Fcl_cstr.fprint cstr); cstr facile-1.1/src/fcl_arith.ml0000644005005300001440000000621410117553006016454 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) open Fcl_misc.Operators open Fcl_var open Fcl_expr type t = Fcl_expr.t let fprint = Fcl_expr.fprint let eval = Fcl_expr.eval let min_of_expr = Fcl_expr.min_of_expr let max_of_expr = Fcl_expr.max_of_expr let min_max_of_expr = Fcl_expr.min_max_of_expr let i2e x = Inte x let fd2e x = match Fd.value x with Val i -> Inte i | _ -> Fde (Var x) let ( +~ ) x y = let l = List.sort compare_intexpr [(1, x); (1, y)] in Agg (Pluse, l, 0) let sum tx = let l = List.sort compare_intexpr (List.map (fun x -> (1, x)) (Array.to_list tx)) in Agg (Pluse, l, 0) let sum_fd tx = sum (Array.map fd2e tx) let ( *~ ) x y = let l = List.sort compare_intexpr [(1, x); (1, y)] in Agg (Multe, l, 1) let ( -~ ) x y = Agg (Pluse, [(-1, y); (1, x)], 0) let ( /~ ) x y = Bin (Dive, x, y) let ( %~ ) x y = Bin (Mode, x, y) let abs x = Un (Abse, x) let ( **~ ) x n = if n < 0 then Fcl_debug.fatal_error "**~ : negative exponent" else if n = 0 then Inte 1 else Agg (Multe, [(n, x)], 1) let prod es = let l = List.map (fun x -> (1, x)) (Array.to_list es) in let l = List.sort compare_intexpr l in Agg (Multe, l, 1) let prod_fd vs = prod (Array.map fd2e vs) let scalprod scals exps = if Array.length scals <> Array.length exps then Fcl_debug.fatal_error "Arith.scalprod : arrays have not the same length"; sum (Array.mapi (fun i ei -> ei *~ i2e scals.(i)) exps) let scalprod_fd ints vars = scalprod ints (Array.map fd2e vars) let (=~) e1 e2 = constrain (e1 -~ e2) Fcl_linear.Equal let (<>~) e1 e2 = constrain (e1 -~ e2) Fcl_linear.Diff let (<=~) e1 e2 = constrain (e1 -~ e2) Fcl_linear.LessThan let (>=~) e1 e2 = e2 <=~ e1 let (<~) e1 e2 = constrain (e1 -~ e2 +~ i2e 1) Fcl_linear.LessThan let (>~) e1 e2 = e2 <~ e1 let e2fd e = match reduce e with Inte x -> Fd.int x | Fde (Var v) -> v | Fde (Aux _) -> assert false | re -> begin let (a, b) = min_max_of_expr re in let v = Fd.interval a b in Fcl_cstr.post (fd2e v =~ re); v end let reify_bin op e1 e2 = fd2e (Fcl_reify.boolean (op e1 e2)) let (=~~) = reify_bin (=~) let (>=~~) = reify_bin (>=~) let (<=~~) = reify_bin (<=~) let (<~~) = reify_bin (<~) let (>~~) = reify_bin (>~) let (<>~~) = reify_bin (<>~) let shift x d = let (a, b) = Fd.min_max x in let y = Fd.interval (a + d) (b + d) in Fcl_cstr.post (Fcl_linear.shift_cstr y x d); y let get_boolsum_threshold = Fcl_linear.get_boolsum_threshold let set_boolsum_threshold = Fcl_linear.set_boolsum_threshold facile-1.1/src/fcl_conjunto.ml0000644005005300001440000003560510117553006017212 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_conjunto.ml,v 1.18 2004/08/12 15:22:07 barnier Exp $ *) open Fcl_var module S = Fcl_setDomain.S (* Gervet C., Interval Propagation to Reason about Sets: Definition and Implementation of a Practical Language, in CONSTRAINTS journal, ed. E.C. Freuder,1(3), pp 191-244, 1997 http://www.icparc.ic.ac.uk/~cg6/ *) let safe_refine ?(mess = "Conjunto.refine") d glb lub = if not (S.subset glb lub) then Fcl_stak.fail mess; SetFd.refine d (Fcl_setDomain.unsafe_interval glb lub) let refine_low_up x inf sup = match Fd.value x with Val v -> if v < inf || v > sup then Fcl_stak.fail "Conjunto.refine_low_up" | Unk ax -> Fd.refine x (Fcl_domain.remove_low_up inf sup (Attr.dom ax)) let size_cstr d cardinal = let update _x = let (m,n) = Fd.min_max cardinal and glb, lub = SetFd.min_max d in let glb_size = S.cardinal glb and lub_size = S.cardinal lub in (* Rule T12 *) let m' = max m glb_size and n' = min n lub_size in if n' < m' then Fcl_stak.fail "cardinal"; if m' <> m || n' <> n then refine_low_up cardinal m' n'; if glb_size = n' then begin (* Rule T13 *) SetFd.unify d glb; Fd.unify cardinal n'; (* + T12 *) true end else if lub_size = m' then begin (* Rule T14 *) SetFd.unify d lub; Fd.unify cardinal m'; (* + T12 *) true end else false and delay ct = delay [Fd.on_min;Fd.on_max] cardinal ct; SetFd.delay [SetFd.on_min;SetFd.on_max] d ct in Fcl_cstr.create ~name:"Conjunto.cardinal" update delay;; let cardinal d = let glb, lub = SetFd.min_max d in let glb_size = S.cardinal glb and lub_size = S.cardinal lub in let name = Printf.sprintf "card(%s)" (SetFd.name d) in let c = Fd.interval ~name glb_size lub_size in Fcl_cstr.post (size_cstr d c); c let inter_cstr d1 d2 d = let update _waking = Fcl_debug.call 's' (fun c -> Printf.fprintf c ">inter_cstr %a %a %a\n" SetFd.fprint d1 SetFd.fprint d2 SetFd.fprint d); let glb1, lub1 = SetFd.min_max d1 and glb2, lub2 = SetFd.min_max d2 and glb, lub = SetFd.min_max d in (* T7 *) let glb1' = S.union glb1 glb and lub1' = S.diff lub1 (S.diff glb2 lub) in safe_refine ~mess:"Conjunto.inter T7 1" d1 glb1' lub1'; let glb2' = S.union glb2 glb and lub2' = S.diff lub2 (S.diff glb1 lub) in safe_refine ~mess:"Conjunto.inter T7 2" d2 glb2' lub2'; (* T8 *) let glb' = S.inter glb1' glb2' (* glb is alredy in glb1' and glb2' *) and lub' = S.inter lub (S.inter lub1' lub2') in assert(S.subset glb' lub'); SetFd.refine d (Fcl_setDomain.interval glb' lub'); (* Fixpoint ? *) Fcl_debug.call 's' (fun c -> Printf.fprintf c " i then let glbj, lubj = SetFd.min_max ds.(j) in (* Rule T3 (T4) *) let lubj' = S.diff lubj glbi in if not (S.subset glbj lubj') then Fcl_stak.fail "Conjunto.disjoint"; SetFd.refine ds.(j) (Fcl_setDomain.interval glbj lubj') done; not (SetFd.is_var ds.(i)) and delay ct = SetFd.delay [SetFd.on_min] ds.(i) ct in Fcl_cstr.create ~name:"Conjunto.ith_diff_from_others" update delay;; let all_disjoint ds = Fcl_cstr.conjunction (Fcl_misc.goedel (fun i r -> ith_diff_from_others ds i :: r) (Array.length ds) []) let inside x d = let glb,lub = SetFd.min_max d in if not (S.mem x lub) then Fcl_stak.fail "inside"; if not (S.mem x glb) then SetFd.refine d (Fcl_setDomain.interval (S.add x glb) lub);; let outside x d = let glb,lub = SetFd.min_max d in if S.mem x glb then Fcl_stak.fail "outside"; if S.mem x lub then SetFd.refine d (Fcl_setDomain.interval glb (S.remove x lub));; let smallest_cstr d x = let update _ = let glb, lub = SetFd.min_max d in if S.is_empty lub then Fcl_debug.fatal_error "Conjunto.smallest: empty set"; if S.is_empty glb then refine_low_up x (max (Fd.min x) (S.min_elt lub)) (S.max_elt lub) else refine_low_up x (S.min_elt lub) (S.min_elt glb); let mi = Fd.min x in let lub' = S.remove_low mi lub in if lub <> lub' then SetFd.refine d (Fcl_setDomain.interval glb lub'); not (Fd.is_var x) and delay ct = SetFd.delay [SetFd.on_min; SetFd.on_max] d ct; Fd.delay [Fd.on_min] x ct in Fcl_cstr.create ~name:"Conjunto.smallest" update delay;; let smallest d = let lub = SetFd.max d in let x = Fd.interval (S.min_elt lub) (S.max_elt lub) in Fcl_cstr.post (smallest_cstr d x); x;; let disjoint d1 d2 = all_disjoint [|d1; d2|];; let subset d1 d2 = let update _ = let glb1, lub1 = SetFd.min_max d1 and glb2, lub2 = SetFd.min_max d2 in (* Rule T1: *) let lub1' = S.inter lub1 lub2 in safe_refine ~mess:"Conjunto.subset T1" d1 glb1 lub1'; (* Rule T2 *) let glb2' = S.union glb2 glb1 in safe_refine ~mess:"Conjunto.subset T2" d2 glb2' lub2; not (SetFd.is_var d1) || not (SetFd.is_var d2) and delay ct = SetFd.delay [SetFd.on_max] d1 ct; SetFd.delay [SetFd.on_min] d2 ct in Fcl_cstr.create ~name:"Conjunto.subset" update delay;; let mem_check x d () = let glb, lub = SetFd.min_max d in match Fd.value x with Val x -> if S.mem x glb then true else if not (S.mem x lub) then false else raise Fcl_cstr.DontKnow | Unk ax -> let domx = Attr.dom ax in if S.subset domx glb then true else if S.is_empty (S.inter domx lub) then false else raise Fcl_cstr.DontKnow let rec mem x d = let update _ = match Fd.value x with Val x -> inside x d; true | Unk ax -> Fd.refine x (S.inter (SetFd.max d) (Attr.dom ax)); not (Fd.is_var x) || not (SetFd.is_var d) and delay ct = SetFd.delay [SetFd.on_max] d ct; Fd.delay [Fd.on_refine] x ct and not () = not_mem x d in Fcl_cstr.create ~name:"Conjunto.mem" ~check:(mem_check x d) ~not:not update delay and not_mem x d = let update _ = match Fd.value x with Val x -> outside x d; true | Unk ax -> Fd.refine x (Fcl_domain.diff (Attr.dom ax) (SetFd.min d)); not (Fd.is_var x) || not (SetFd.is_var d) and delay ct = SetFd.delay [SetFd.on_min] d ct; Fd.delay [Fd.on_refine] x ct and check () = not (mem_check x d ()) and not () = mem x d in Fcl_cstr.create ~name:"Conjunto.not_mem" ~check:check ~not:not update delay (* Order based on the minimum element. The empty set is the smallest element. *) let inf_min d1 d2 = let update _ = let glb1, lub1 = SetFd.min_max d1 and glb2, lub2 = SetFd.min_max d2 in if S.is_empty lub1 then true else if S.is_empty lub2 && not (S.is_empty glb1) then Fcl_stak.fail "Conjunto.inf_min: d2 empty" else if not (S.is_empty glb1) && S.min_elt glb1 <= S.min_elt lub2 then true else if not (S.is_empty glb2) && S.min_elt lub1 > S.min_elt glb2 then Fcl_stak.fail "Conjunto.inf_min: d1 > d2" else if not (S.is_empty lub2) && S.min_elt lub2 < S.min_elt lub1 then begin let lub2' = S.remove_low (S.min_elt lub1) lub2 in SetFd.refine d2 (Fcl_setDomain.interval glb2 lub2'); false end else false and delay ct = SetFd.delay [SetFd.on_min; SetFd.on_max] d1 ct; SetFd.delay [SetFd.on_min; SetFd.on_max] d2 ct in Fcl_cstr.create ~name:"Conjunto.inf_min" update delay;; (* Order like Domain.compare *) let order_with_card d1 card1 d2 card2 = Fcl_cstr.post (Fcl_arith.(<=~) (Fcl_arith.fd2e card1) (Fcl_arith.fd2e card2)); let update _ = if Fd.max card1 < Fd.min card2 then true else match SetFd.value d1, SetFd.value d2 with Val v1, Val v2 -> begin (* equal cards : if d1 and d2 are ground, their cards too (priority later) and with the preceding test they should be equal (otherwise true or failure) *) assert (not (Fd.is_var card1 || Fd.is_var card2) && (Fd.elt_value card1 = Fd.elt_value card2)); S.compare v1 v2 <= 0 || Fcl_stak.fail "Conjunto.order" end | _, _ -> false and delay ct = SetFd.delay [SetFd.on_subst] d1 ct; SetFd.delay [SetFd.on_subst] d2 ct in Fcl_cstr.create ~name:"Conjunto.order" ~priority:Fcl_cstr.later update delay;; let order d1 d2 = let card1 = cardinal d1 and card2 = cardinal d2 in order_with_card d1 card1 d2 card2 (* Member *) let unicise l = let sl = List.sort S.compare l in let rec loop = function [] -> [] | [_] as le -> le | e1 :: ((e2 :: _) as e2r) -> if S.compare e1 e2 = 0 then loop e2r else e1 :: loop e2r in loop sl let filter glb lub sets = List.filter (fun set -> S.subset glb set && S.subset set lub) sets let member s sets = (* On pourrait faire l'intersection des sets pour rajouter des éléments dans glb et leur union pour en enlever dans lub, mais c'est coûteux - il faudrait la recalculer à chaque fois et on en a pas besoin pour la sectorisation *) let sets = unicise sets in let sets = Fcl_stak.ref sets in let update _ = match SetFd.value s with Val sv -> List.exists (fun set -> S.compare set sv = 0) (Fcl_stak.get sets) || Fcl_stak.fail "Conjunto.member" | Unk attr -> let glb = SetAttr.min attr and lub = SetAttr.max attr in let new_sets = filter glb lub (Fcl_stak.get sets) in match new_sets with [] -> Fcl_stak.fail "Conjunto.member" | [set] -> SetFd.unify s set; true | _ -> Fcl_stak.set sets new_sets; false and delay ct = SetFd.delay [SetFd.on_min; SetFd.on_max] s ct in Fcl_cstr.create ~name:"Conjunto.member" update delay (* sum_weight *) (* Un seul binding par clé et toutes les données positives *) let check_hash h = try Hashtbl.iter (fun k d -> match Hashtbl.find_all h k with [_] -> if d < 0 then raise Exit | _ -> raise Exit) h; true with Exit -> false let check_dom lub h = try S.iter (fun k -> ignore (Hashtbl.find h k)) lub; true with Not_found -> false let sum_weight_cstr s weights_list sum = let weights = Hashtbl.create (List.length weights_list) in List.iter (fun (k, d) -> Hashtbl.add weights k d) weights_list; (* s ne doit pas adresser d'éléments en dehors de weights et tous les poids doivent être positifs. De plus, les bindings doivent être unique dans weights. *) assert (let lub = SetFd.max s in check_dom lub weights && check_hash weights); let f d = (* S.fold pas encore implanté *) (* S.fold (fun i r -> Hashtbl.find weights i + r) d 0 in *) let fd = ref 0 in S.iter (fun i -> fd := !fd + Hashtbl.find weights i) d; !fd in let update _ = let m, n = Fd.min_max sum and a, b = SetFd.min_max s in let fa = f a and fb = f b in (* Rule I3 *) let m' = max m fa and n' = min n fb in if n' < m' then Fcl_stak.fail "Conjunto.sum_weight"; if m' <> m || n' <> n then refine_low_up sum m' n'; (* Rule I4 *) if n' = fa then begin SetFd.unify s a; Fd.unify sum fa; true end (* Rule I5 *) else if m' = fb then begin SetFd.unify s b; Fd.unify sum fb; true end else false and delay ct = SetFd.delay [SetFd.on_min; SetFd.on_max] s ct; Fd.delay [Fd.on_min; Fd.on_max] sum ct in Fcl_cstr.create ~name:"Conjunto.sum_weight" update delay let sum_weight s weights = let sum = Fd.create (Fcl_domain.int) in Fcl_cstr.post (sum_weight_cstr s weights sum); sum (* [sets] must have cardinality [c] must intersect pairwise in atmost one element *) let atmost1 sets c = let n = Array.length sets in let values = Array.fold_right (fun x r -> S.union (SetFd.max x) r) sets S.empty in let lubs = Array.map Fcl_invariant.SetFd.max sets and glbs = Array.map Fcl_invariant.SetFd.min sets in S.iter (fun a -> let cardS_a = Fcl_invariant.sum (Array.map (Fcl_invariant.unary (fun glbsi -> if S.mem a glbsi then 1 else 0)) glbs) and bigTa = Array.fold_right (Fcl_invariant.binary (fun lubsi r -> if S.mem a lubsi then S.union lubsi r else r)) lubs (Fcl_invariant.constant S.empty) in let maxa = Fcl_invariant.unary (fun x -> (S.cardinal x-1)/(c-1)) bigTa in ignore(Fcl_invariant.binary (fun maxa cardS_a -> Fcl_debug.call 's' (fun c -> Printf.fprintf c "atmost1 max%d=%d cardS_%d=%d\n" a maxa a cardS_a); if maxa < cardS_a then Fcl_stak.fail "atmost1"; if maxa = cardS_a then begin for i = 0 to n - 1 do let glbi = Fcl_invariant.get glbs.(i) in if not (S.mem a glbi) then begin Fcl_debug.call 's' (fun c -> Printf.fprintf c "atmost1 remove %d from %a\n" a SetFd.fprint sets.(i)); outside a sets.(i) end done end) maxa cardS_a)) values;; facile-1.1/src/fcl_goals.ml0000644005005300001440000002715010117553006016454 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_goals.ml,v 1.60 2004/08/12 15:22:07 barnier Exp $ *) open Fcl_var module C = Fcl_cstr type t = Fcl_stak.gl = { name : string; call : unit -> t option } exception Success let goal_stack = ref [];; let reset () = Fcl_stak.reset (); C.reset_queue ();; let while_true = fun _ -> () let name c = c.name let fprint c g = Printf.fprintf c "%s" g.name let create_rec ?(name = "create_rec") f = let rec g = { name = name; call = fun () -> Some (f g) } in g;; let create ?(name = "create") f a = { name = name; call = fun () -> Some (f a) } let atomic ?(name = "atomic") f = { name = name; call = fun () -> f (); None } let success = { name = "success"; call = fun () -> None } let fail = { name = "fail"; call = fun () -> Fcl_stak.fail "Goals.fail"} let (&&~) g1 g2 = { name = "&&~"; call = (fun () -> goal_stack := g2:: !goal_stack; Some g1) } let (||~) g1 g2 = { name = "||~"; call = (fun () -> ignore (Fcl_stak.save (g2 :: !goal_stack)); Some g1) } let on_choice_point = C.new_event () let and_loop () = while true do match !goal_stack with [] -> raise Success | goal::goals -> goal_stack := goals; begin match goal.call () with None -> () | Some g -> goal_stack := g :: !goal_stack end done let solve ?(control = while_true) goal = Fcl_debug.call 'g' (fun f -> Printf.fprintf f "|on_choice_point|=%d\n" (List.length (C.registered on_choice_point))); Fcl_stak.reset (); let backtracks = ref 0 in (* A choice point is systematically added before a search in order to get a correct backtrack on events (constraints, refinnments, ...) done before the first user choice point. This case occurs in minimize where a constraint attached to "choice_point" is posted before the search *) goal_stack := [goal ||~ fail]; try while true do (* OR loop *) try control !backtracks; C.schedule on_choice_point; C.wake_all (); C.assert_empty_queue (); and_loop () with Fcl_stak.Fail s -> Fcl_debug.call 'g' (fun f -> Printf.fprintf f "fail %s\n" s); goal_stack := Fcl_stak.backtrack (); (* May raise Empty_stack *) incr backtracks done; failwith "end of while true" with Fcl_stak.Empty_stack -> false | Success -> control !backtracks; true;; let indomain var = create_rec ~name:"indomain" (fun self -> match Fd.value var with Val _ -> success | Unk var_ -> let mini = Fcl_domain.min (Attr.dom var_) in atomic (fun () -> Fd.subst var mini) ||~ atomic (fun () -> Fd.refine var (Fcl_domain.remove mini (Attr.dom var_))) &&~ self);; (* can t use remove_min because min may have been changed in the choice point (Opti.minimize Continue does that) *) let dichotomic var = create_rec ~name:"dichotomic" (fun self -> match Fd.value var with Val _ -> success | Unk var_ -> let d = Attr.dom var_ in let mini = Fcl_domain.min d and maxi = Fcl_domain.max d in let middle = (maxi + mini) / 2 in (atomic (fun () -> Fd.refine var (Fcl_domain.remove_up middle d)) ||~ atomic (fun () -> Fd.refine var (Fcl_domain.remove_low (middle+1) d))) &&~ self) let instantiate choose var = create_rec ~name:"instantiate" (fun self -> match Fd.value var with Val _ -> success | Unk var_ -> let x = choose (Attr.dom var_) in atomic (fun () -> Fd.subst var x) ||~ atomic (fun () -> Fd.refine var (Fcl_domain.remove x (Attr.dom var_))) &&~ self);; let once goal = let l = ref (Fcl_stak.level ()) in atomic (fun () -> l := (Fcl_stak.level ())) &&~ goal &&~ atomic (fun () -> Fcl_stak.cut !l) let forto min max g = let rec la i = create (fun j -> if j <= max then g j &&~ la (j+1) else success) i in la min let foreachto min max g = if min > max then success else let rec la i = create (fun j -> if j < max then g j ||~ la (j+1) else g max) i in la min let fordownto max min g = forto min max (fun i -> g (max - i + min));; module Array = struct let fold_hi select lab_one a init = create_rec (fun self -> match try let i = select a in Some i with Not_found -> None with Some i -> lab_one i a.(i) self | None -> init) let foldi lab_one a init = let size = Array.length a in let rec la i = create (fun j -> if j < size then lab_one j a.(j) (la (j+1)) else init) i in la 0 let foralli ?select f a = match select with None -> foldi (fun i x r -> f i x &&~ r) a success | Some s -> fold_hi s (fun i x r -> f i x &&~ r) a success let forall ?select f a = foralli ?select (fun _ -> f) a let existsi ?select f a = match select with None -> foreachto 0 (Array.length a - 1) (fun i -> f i a.(i)) | Some s -> fold_hi s (fun i x r -> f i x ||~ r) a fail let exists ?select f a = existsi ?select (fun _ -> f) a let choose_index order tab = let n = Array.length tab in (* Recherche de la premiere variable libre *) let rec first_unbound i = if i < n then match Fd.value tab.(i) with Unk attr -> i, attr | Val _ -> first_unbound (i+1) else raise Not_found in let b, attr = first_unbound 0 in let best = ref b and attr_best = ref attr in (* Recherche de la meilleure variable pour le critere *) for i = b+1 to n - 1 do match Fd.value tab.(i) with Unk tabi -> if order tabi !attr_best then begin best := i; attr_best := tabi end | Val _ -> () done; !best let labeling (a : Fcl_var.Fd.t array) = forall indomain a exception Return of int let not_instantiated_fd fds = try Array.iteri (fun i fdsi -> if Fd.is_var fdsi then raise (Return i)) fds; raise Not_found with Return i -> i end module List = struct let rec fold fgoal l init = create (function [] -> init | x::xs -> fgoal x (fold fgoal xs init)) l let rec fold_h select fgoal l init = create (function [] -> init | _ -> let x,xs = select l in fgoal x (fold_h select fgoal xs init)) l let forall ?select f l = match select with None -> fold (fun x r -> f x &&~ r) l success | Some s -> fold_h s (fun x r -> f x &&~ r) l success let exists ?select f l = match select with None -> fold (fun x r -> f x ||~ r) l fail | Some s -> fold_h s (fun x r -> f x ||~ r) l fail let member v l = exists (fun x -> atomic (fun () -> Fd.unify v x)) l let labeling = forall indomain end let unify v x = atomic (fun () -> Fd.unify v x) let level g = create (fun () -> let l = Fcl_stak.level () in g l) () let sigma ?(domain = Fcl_domain.int) g = create (fun () -> g (Fd.create domain)) () let once g = level (fun l -> g &&~ atomic (fun () -> Fcl_stak.cut l)) let minimize_restart goal (cost : Fd.t) step compute_solution = let best_cost = ref 0 and once_more = ref true in (* +step because we constrain the cost before the search starts in the recursive goal *) atomic (fun () -> best_cost := Fd.max cost + step; once_more := true) &&~ create_rec (fun self -> if !once_more then begin (* First iteration or last one succeeded *) let loop_level = ref (Fcl_stak.level ()) in once_more := false; (* Stores the choice-point and constrains the cost *) ({ name = "restart_store"; call = fun () -> let ub = !best_cost - step in begin match Fd.value cost with Val c -> if c > ub then Fcl_stak.fail "Goals.minimize" | Unk a -> Fd.refine cost (Fcl_domain.remove_up ub (Attr.dom a)) end; loop_level := Fcl_stak.level (); Some goal} &&~ { name = "one_found"; (* One solution found *) call = fun () -> once_more := true; (* Dire dans la doc que goal doit obligatoirement instancier le cout *) let m = Fd.int_value cost in compute_solution m; best_cost := m; Fcl_stak.cut !loop_level; Fcl_stak.fail "Goals.minimize" }) ||~ self end (* Last try failed *) else Fcl_stak.fail "Goals.minimize") let minimize_continue goal (cost : Fd.t) step compute_solution = let best_cost = ref 0 in let rec bt_until l = (* Backtrack until lower bound better than current cost, staying above [l] *) let gs = Fcl_stak.backtrack () in if Fd.min cost <= !best_cost then ignore (Fcl_stak.save gs) else if Fcl_stak.older (Fcl_stak.level ()) l then Fcl_stak.fail "continue" else bt_until l in let restore_max = let update _ = (*** Printf.printf "cost=%a best_cost=%d\n" Fd.fprint cost !best_cost; flush stdout; ***) match Fd.value cost with Val v -> if v > !best_cost then Fcl_stak.fail "Goals.restore_max" else true | Unk attr -> Fd.refine cost (Fcl_domain.remove_up !best_cost (Attr.dom attr)); false and delay x = C.delay [on_choice_point] x in C.create ~name:"restore_cost" update delay in let found_one l = { name = "found_one"; call = fun () -> let c = Fd.int_value cost in compute_solution c; best_cost := c - step; bt_until l; Fcl_stak.fail "Goals.minimize_more" } in let init = { name = "continue_init"; call = fun () -> best_cost := Fd.max cost + 1; C.post restore_max; Some goal } in level (fun l -> init &&~ found_one l);; type bb_mode = Restart | Continue let minimize ?(step=1) ?(mode = Continue) g c cs = if step <= 0 then invalid_arg "Goals.minimize: step must be non negative"; match mode with Restart -> minimize_restart g c step cs | Continue -> minimize_continue g c step cs let lds ?(step = 1) goal = let lds_max = ref 0 and more = ref true and lds = Fcl_stak.ref 0 in let lds_check = let update _ = Fcl_stak.set lds (Fcl_stak.get lds + 1); if Fcl_stak.get lds > !lds_max then begin more := true; Fcl_stak.fail "Goals.lds_check" end else false and delay x = C.delay [on_choice_point] x and init _ = () in C.create ~name:"lds_check" ~init update delay in { name = "lds_init"; call = (fun () -> (* lds must be less than lds_max for lds_check not to fail when backtracking just before executing "self" *) lds_max := -step; more := true; Fcl_stak.set lds (!lds_max - 1); C.post lds_check; None) } &&~ (create_rec ~name:"lds_iterate" (fun self -> if not !more then Fcl_stak.fail "Goals.lds" else begin lds_max := !lds_max + step; more := false; Fcl_debug.call 'l' (fun f -> Printf.fprintf f "lds_max=%d\n" !lds_max); (atomic (fun () -> Fcl_stak.set lds 0; None) &&~ goal) ||~ self end)) module Conjunto = struct let indomain d = create_rec ~name:"Goals.Conjunto.indomain" (fun self -> match SetFd.value d with Val _ -> success | Unk a -> let glb = SetAttr.min a and lub = SetAttr.max a in let diff = Fcl_setDomain.S.diff lub glb in let x = Fcl_setDomain.S.choose diff in ( ( atomic (fun () -> Fcl_conjunto.outside x d) ||~ atomic (fun () -> Fcl_conjunto.inside x d)) &&~ self) ) end facile-1.1/src/fcl_fdArray.ml0000644005005300001440000002460710117553006016743 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_fdArray.ml,v 1.25 2004/08/12 15:22:07 barnier Exp $ *) open Fcl_var open Fcl_arith module C = Fcl_cstr let new_min_array xs x = let n = Array.length xs in let name = "FdArray.min" in let delay c = Array.iter (fun x -> delay [Fd.on_min; Fd.on_max] x c) xs; delay [Fd.on_min; Fd.on_max] x c and update _ = (* Try to decide which one is the smallest *) let smallest = ref 0 and min_smallest = ref (Fd.min xs.(0)) in for i = 1 to n - 1 do let min_i = Fd.min xs.(i) in if min_i < !min_smallest then begin smallest := i; min_smallest := min_i end done; let max_smallest = Fd.max xs.(!smallest) in try for i = 0 to n - 1 do if i <> !smallest && Fd.min xs.(i) < max_smallest then raise Exit done; Fcl_cstr.post (fd2e x =~ fd2e xs.(!smallest)); true with Exit -> (* All the xs are greater than the min of min *) let minx = Fd.min x in let x_ge_min xi = match Fd.value xi with Val v -> if minx > v then Fcl_stak.fail name | Unk a -> if minx > Attr.min a then Fd.refine xi (Fcl_domain.remove_low minx (Attr.dom a)) in Array.iter x_ge_min xs; (* smallest min of xs <= x <= smallest max of xs *) let smallest_max = Array.fold_left (fun r xi -> Fcl_misc.Operators.min (Fd.max xi) r) max_int xs in match Fd.value x with Val x -> if not (!min_smallest <= x && x <= smallest_max) then Fcl_stak.fail name else false | Unk a -> let d = Fcl_domain.remove_low_up !min_smallest smallest_max (Attr.dom a) in Fd.refine x d; false in C.create ~name update delay let new_max_array xs x = let n = Array.length xs in let name = "FdArray.max" in let delay c = Array.iter (fun x -> delay [Fd.on_min; Fd.on_max] x c) xs; delay [Fd.on_min; Fd.on_max] x c and update _ = (* Try to decide which one is the greatest *) let greatest = ref 0 and max_greatest = ref (Fd.max xs.(0)) in for i = 1 to n - 1 do let max_i = Fd.max xs.(i) in if max_i > !max_greatest then begin greatest := i; max_greatest := max_i end done; let min_greatest = Fd.min xs.(!greatest) in try for i = 0 to n - 1 do if i <> !greatest && Fd.max xs.(i) > min_greatest then raise Exit done; (* We have found the greatest element *) Fcl_cstr.post (fd2e x =~ fd2e xs.(!greatest)); true with Exit -> (* All the xs are smaller than the max of max *) let maxx = Fd.max x in let x_leq_max xi = match Fd.value xi with Val v -> if not (maxx >= v) then Fcl_stak.fail name | Unk a -> if not (Fd.max x >= Attr.max a) then Fd.refine xi (Fcl_domain.remove_up maxx (Attr.dom a)) in Array.iter x_leq_max xs; (* greatest min of xs <= x <= greatest max of xs *) let greatest_min = Array.fold_left (fun r xi -> Fcl_misc.Operators.max (Fd.min xi) r) min_int xs in begin match Fd.value x with Val x -> assert (x >= greatest_min) | Unk a -> let d = Fcl_domain.remove_low_up greatest_min (Fd.max xs.(!greatest)) (Attr.dom a) in Fd.refine x d end; false in C.create ~name update delay let min_cstr xs x = if Array.length xs = 0 then invalid_arg "FdArray.min_cstr"; (* To prevent array modifications by the user *) let xs = Array.copy xs in new_min_array xs x let min xs = if Array.length xs = 1 then xs.(0) else let x = Fd.create Fcl_domain.int in let c = min_cstr xs x in Fcl_cstr.post c; x let max_cstr xs x = if Array.length xs = 0 then invalid_arg "FdArray.max_cstr"; (* To prevent array modifications by the user *) let xs = Array.copy xs in new_max_array xs x let max xs = if Array.length xs = 1 then xs.(0) else let x = Fd.create Fcl_domain.int in let c = max_cstr xs x in Fcl_cstr.post c; x open Printf let domain_of var = match Fd.value var with Val x -> Fcl_domain.interval x x | Unk d -> Attr.dom d let new_element index array value = let n = Array.length array in let name = "FdArray.get" in let bound_index i = assert(i >= 0 && i < n); Fcl_debug.call 'e' (fun s -> fprintf s "%s: bound_index=%d\n" name i); Fcl_cstr.post (fd2e value =~ fd2e array.(i)); Fcl_debug.call 'e' (fun s -> fprintf s "value=%a\n" Fd.fprint value); true in let delay x = delay [Fd.on_refine] index x; delay [Fd.on_refine] value x; Array.iter (fun v -> delay [Fd.on_refine] v x) array and update _ = Fcl_debug.call 'e' (fun s -> fprintf s "[|%a|].(%a) = %a\n" (fun s -> Array.iter (fun v -> fprintf s "%a " Fd.fprint v)) array Fd.fprint index Fd.fprint value); let dom_value = domain_of value in let index_to_keep = ref [] and new_dom_value = ref Fcl_domain.empty in match Fd.value index with Val i -> bound_index i | Unk index_ -> Fcl_domain.iter (fun i -> let inter = Fcl_domain.intersection (domain_of array.(i)) dom_value in if not (Fcl_domain.is_empty inter) then begin index_to_keep := i :: !index_to_keep; new_dom_value := Fcl_domain.union inter !new_dom_value end) (Attr.dom index_); Fd.refine index (Fcl_domain.unsafe_create (List.rev !index_to_keep)); match Fd.value index with Val i -> bound_index i | Unk _index_ -> begin match Fd.value value with Val _ -> Fcl_debug.call 'e' (fun s -> fprintf s "After: [|%a|].(%a) = %a\n" (fun s -> Array.iter (fun v -> fprintf s "%a " Fd.fprint v)) array Fd.fprint index Fd.fprint value) (* Something more to do ? *) | Unk _ -> Fd.refine value !new_dom_value; Fcl_debug.call 'e' (fun s -> fprintf s "After: [|%a|].(%a) = %a\n" (fun s -> Array.iter (fun v -> fprintf s "%a " Fd.fprint v)) array Fd.fprint index Fd.fprint value) end; false in let init () = begin match Fd.value index with Val i -> if i >= 0 && i < n then ignore (bound_index i) else Fcl_stak.fail (name ^ ": index out of bound") | Unk index_attr -> Fd.refine index (Fcl_domain.intersection (Fcl_domain.interval 0 (n-1)) (Attr.dom index_attr)) end; ignore (update 0) in C.create ~name ~init update delay (* Acces to an array of integers *) let new_element_of_ints index array value = let n = Array.length array in assert(0 <= Fd.min index && Fd.max index < n); let bound_index i = assert(i >= 0 && i < n); Fcl_debug.call 'e' (fun s -> fprintf s "Element: bound_index=%d\n" i); Fd.unify value array.(i); Fcl_debug.call 'e' (fun s -> fprintf s "value=%a\n" Fd.fprint value); true in let index_size = Fcl_stak.ref 0 in let name = "FdArray.get_ints" and delay x = delay [Fd.on_refine] index x; delay [Fd.on_refine] value x and update _ = let index_has_changed = Fd.size index <> Fcl_stak.get index_size in Fcl_debug.call 'e' (fun s -> fprintf s "[|%a|].(%a) = %a\n" (fun s -> Array.iter (fun v -> fprintf s "%d " v)) array Fd.fprint index Fd.fprint value); let dom_value = domain_of value in match Fd.value index with Val i -> bound_index i | Unk index_ -> let index_to_keep = ref [] and new_values = ref [] in Fcl_domain.iter (fun i -> if Fcl_domain.member array.(i) dom_value then begin index_to_keep := i :: !index_to_keep; new_values := array.(i) :: !new_values end) (Attr.dom index_); let new_dom_index = Fcl_domain.unsafe_create (List.rev !index_to_keep) in Fd.refine index new_dom_index; Fcl_stak.set index_size (Fcl_domain.size new_dom_index); match Fd.value index with Val i -> bound_index i | Unk _index_ -> if index_has_changed then match Fd.value value with Val _ -> (* index already has the correct domain; finished*) Fcl_debug.call 'e' (fun s -> fprintf s "After: [|%a|].(%a) = %a\n" (fun s -> Array.iter (fun v -> fprintf s "%d " v)) array Fd.fprint index Fd.fprint value); true | Unk _ -> Fd.refine value (Fcl_domain.create !new_values); Fcl_debug.call 'e' (fun s -> fprintf s "After: [|%a|].(%a) = %a\n" (fun s -> Array.iter (fun v -> fprintf s "%d " v)) array Fd.fprint index Fd.fprint value); Fd.size value = 1 else false in let init () = begin match Fd.value index with Val i -> if i >= 0 && i < n then ignore (bound_index i) else Fcl_stak.fail (name ^ ": index out of bound") | Unk index_attr -> Fd.refine index (Fcl_domain.intersection (Fcl_domain.interval 0 (n-1)) (Attr.dom index_attr)) end; ignore (update 0) in C.create ~name ~init update delay let array_forall p a = let n = Array.length a in try for i = 0 to n-1 do if not (p a.(i)) then raise Exit done; true with Exit -> false let get_cstr array index value = let n = Array.length array in if n = 0 then invalid_arg "FdArray.get_cstr: empty array"; match Fd.value index with Val i -> if 0 <= i && i < n then fd2e value =~ fd2e array.(i) else Fcl_cstr.zero | _ -> if array_forall (fun x -> not (Fd.is_var x)) array then let ints = Array.map Fd.int_value array in (* Only integers *) if array_forall (fun x -> x = ints.(0)) ints then (* All equal ! *) Fcl_var.Fd.unify_cstr value ints.(0) else new_element_of_ints index ints value else new_element index array value let get array index = match Fd.value index with Val i -> (* Index connu *) if i >= 0 && i < Array.length array then array.(i) else Fcl_stak.fail "FdArray.get: index out of bound" | _ -> let (mi, ma) = Array.fold_left (fun (mi, ma) e -> (Pervasives.min mi (Fd.min e), Pervasives.max ma (Fd.max e))) (max_int, min_int) array in if mi = ma then Fd.int mi else let value = Fd.create (Fcl_domain.interval mi ma) in (* To prevent array modifications by the user *) let array = Array.copy array in Fcl_cstr.post (get_cstr array index value); value facile-1.1/src/fcl_gcc.ml0000644005005300001440000004423610117553006016107 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_gcc.ml,v 1.31 2004/08/12 15:22:07 barnier Exp $ *) module C = Fcl_cstr open Printf let print_int_list c l = List.iter (fun x -> Printf.fprintf c "%d " x) l;; let int_min (a : int) b = if a < b then a else b let tarjan nb_vertices successors root = let partition = ref [] and stack = ref [] and dfn = Array.create nb_vertices 0 and num = ref 0 in let push x = stack := x :: !stack and pop () = match !stack with [] -> Fcl_debug.internal_error "Gcc.tarjan.pop" | x::xs -> stack := xs; x in let rec visit vertex = push vertex; incr num; Fcl_debug.call 'T' (fun f -> fprintf f "visit %d: %d\n" vertex !num); dfn.(vertex) <- !num; let removed, succs = successors vertex in let head = List.fold_left (fun head succ -> if not (removed succ) then let mi = if dfn.(succ) = 0 then visit succ else dfn.(succ) in Fcl_debug.call 'T' (fun f -> fprintf f "tarjan: %d succ of %d\n" succ vertex); int_min mi head else head) dfn.(vertex) succs in Fcl_debug.call 'T' (fun f -> fprintf f "(%d:%d) head = %d\n" vertex dfn.(vertex) head); if head = dfn.(vertex) then begin let rec component () = let element = pop () in dfn.(element) <- max_int; if element = vertex then [vertex] else element :: component () in partition := component () :: !partition; end; head in ignore (visit root); !partition;; open Fcl_var module D = Fcl_domain type data_of_value = { card : Fd.t; mutable nb_pred : int; mutable tmp_pred : int; value : int } let domain_of var = match Fd.value var with Val x -> D.create [x] | Unk d -> Attr.dom d;; let none = min_int;; type level = Basic | Medium | High let new_gcc vars distribution index_of_value level = let k = Array.length vars and n = Array.length distribution in (* Rep duale des domaines des vars.(i) *) let bool_doms = Array.create_matrix k n false and size_bool_doms = Array.create k (-1) in let maj i = let bdi = bool_doms.(i) in for k = 0 to Array.length bdi - 1 do bdi.(k) <- false done; D.iter (fun vj -> bdi.(index_of_value vj) <- true) (domain_of vars.(i)); size_bool_doms.(i) <- Fd.size vars.(i) and flow = Array.create k none and data_values = Array.map (fun (c, v) -> {value=v;card=c;nb_pred=0;tmp_pred=none}) distribution and member_vars i v = bool_doms.(i).(index_of_value v) in let check_satisfied () = try for i = 0 to k - 1 do (* for all vars *) match Fd.value vars.(i) with Unk _ -> raise Exit | Val vi -> (* May occur after Tarjan refinements in case a variable appear in vars AND in cards (e.g. magic sequence): a refinement in cards remove the value of the computed feasible flow *) if vi <> flow.(i) then Fcl_stak.fail "Gcc.check_satisfied" done; true with Exit -> false in let name = "Gcc" and delay c = Array.iter (fun x -> delay [Fd.on_refine] x c) vars; Array.iter (fun (x,_) -> delay [Fd.on_min; Fd.on_max] x c) distribution and update _ = (* Vérification de l'ancien flow et suppression des aretes qui ne sont plus valables *) Fcl_debug.call 'd' (fun f -> Array.iteri (fun i v -> fprintf f "vars.(%d)=%a(%d) -> %d\n" i Fd.fprint v size_bool_doms.(i) flow.(i)) vars); Fcl_debug.call 'd' (fun f -> Array.iteri (fun i d -> fprintf f "card.(%d value=%d)=%a\n" i d.value Fd.fprint d.card) data_values); (* Mise à jour des rep. duales *) for i = 0 to k - 1 do let s = size_bool_doms.(i) in if Fd.size vars.(i) <> s then begin maj i; Fcl_stak.trail (fun () -> size_bool_doms.(i) <- -1) (*Tout est à refaire *) end; assert(D.iter (fun v -> if not bool_doms.(i).(index_of_value v) then Fcl_debug.internal_error ("bool_doms "^string_of_int i)) (domain_of vars.(i)); true); done; let data_of_value v = data_values.(index_of_value v) in (* On commence par vérifier si l'ancien flow n'est pas toujours correct Dans le même temps, on traite les variables instanciées *) for j = 0 to n - 1 do data_values.(j).nb_pred <- 0 done; let size_flow = ref k in (* O(k) *) for i = 0 to k - 1 do (* Pour toutes les variables *) begin match Fd.value vars.(i) with Val vi -> flow.(i) <- vi (* A tentative value which cannot be bad *) | Unk _ -> () end; if flow.(i) <> none && member_vars i flow.(i) then (* Previous flow still ok for this variable *) let d = data_of_value flow.(i) in if d.nb_pred = Fd.max d.card then begin (* Valeur deja saturée; on ne peut pas garder cette affectation pour cette variable *) Fcl_debug.call 'd' (fun f -> fprintf f "remove(sat) %d from vars.(%d)\n" flow.(i) i); flow.(i) <- none; decr size_flow; end else (* OK, on peut garder cette arete du flow *) d.nb_pred <- d.nb_pred + 1 else begin (* Affectation impossible *) Fcl_debug.call 'd' (fun f -> fprintf f "remove(dom) %d from vars.(%d)\n" flow.(i) i); flow.(i) <- none; decr size_flow end done; Fcl_debug.call 'd' (fun f -> fprintf f "Sizeflow=%d\n" !size_flow); (* On vérifie ensuite que chaque valeur possède assez de prédecesseurs; on accumule les valeurs qui ne respectent pas cette propriété dans [required_values] *) (* Le tableau des prédécesseurs *) let preds = Array.create n [] in let init_preds () = for i = 0 to k - 1 do D.iter (fun v -> let j = index_of_value v in preds.(j) <- i :: preds.(j)) (domain_of vars.(i)) done in init_preds (); let required_values = ref [] in (* valeurs a minimum non atteint *) for j = 0 to n - 1 do (* Pour toutes les valeurs *) let d = data_values.(j) in let v = d.value and mi = Fd.min d.card in if d.nb_pred < mi then begin (* On affecte mi predecesseurs supplementaires a cette valeur, eventuellement au detriments des precedentes qui vont devenir "required" pour un feasible flow *) (* On pourrait trier les predecesseurs pour mettre les none en tete *) let nb_necessaires = (mi - d.nb_pred) in let cpt = ref nb_necessaires in try List.iter (* Pour tous les prédécesseurs *) (fun i -> if flow.(i) <> v then begin (* sinon rien à changer *) if flow.(i) <> none then begin (* On reaffecte cette variable *) decr size_flow; let j1 = index_of_value flow.(i) in let d1 = data_values.(j1) in assert(if j1 < j && d1.nb_pred < Fd.min d1.card then List.mem d1.value !required_values else true); (* si j1 > j alors la valeur sera traitée plus tard *) if j1 < j && d1.nb_pred = Fd.min d1.card then required_values := d1.value :: !required_values; d1.nb_pred <- d1.nb_pred - 1 end; flow.(i) <- v; decr cpt; if !cpt = 0 then raise Exit end) preds.(j); Fcl_stak.fail "Gcc: not enough predecessors" with Exit -> (* OK pour cette valeur, elle a suffisamment de preds *) d.nb_pred <- mi; size_flow := !size_flow + nb_necessaires end done; Fcl_debug.call 'd' (fun f -> fprintf f "sizeflow=%d required_values=%a\n" !size_flow print_int_list !required_values); Fcl_debug.call 'd' (fun f -> Array.iteri (fun i fi -> fprintf f "flow.(%d)=%d\n" i fi) flow); if !size_flow < k then begin (* Compute a new flow : Voir feasible*) let target_in_domain targets i = let rec cherche = function [] -> raise Not_found | t::ts -> let d = data_of_value t in if t <> flow.(i) && (if d.tmp_pred = none then d.nb_pred < Fd.max d.card else true) && member_vars i t then t else cherche ts in cherche targets in (* target_in_domain *) let augment targets only_once = let tmp_flow = Array.create k none in for j = 0 to n - 1 do data_values.(j).tmp_pred <- none done; let rec longer targets only_once = Fcl_debug.call 'd' (fun f -> fprintf f "targets=%a\n" print_int_list targets); if targets = [] then Fcl_stak.fail "gcc: targets=[]"; (* Direct edge to a target *) let augmented = ref false in begin try for i = 0 to k - 1 do (* for all variables *) try if flow.(i) = none then begin let target = target_in_domain targets i in(* Not_found *) let rec flip_path v = Fcl_debug.call 'd' (fun f -> fprintf f "flip %d\n" v); let d = data_of_value v in if d.nb_pred < Fd.max d.card then begin (* bon pour une fin de chemin augmentant *) d.nb_pred <- d.nb_pred + 1 end else begin assert(flow.(d.tmp_pred) = v); flow.(d.tmp_pred) <- tmp_flow.(d.tmp_pred); flip_path flow.(d.tmp_pred); d.tmp_pred <- none (* Supression afin qu'il ne soit pas utilisé une seconde fois *) end in Fcl_debug.call 'd' (fun f -> fprintf f "flip from vars.(%d)\n" i); flip_path target; flow.(i) <- target; augmented := true; incr size_flow; if only_once then raise Exit end with Not_found -> () done; with Exit -> () (* On ne cherchait qu'un chemin *) end; if !augmented then begin () (* C'est fini, on a trouve (au moins) un chemin *) end else begin (* On cherche des chemins plus long *) let new_targets = ref [] in for i = 0 to k - 1 do (* for all variables *) try if flow.(i) <> none then begin let d = data_of_value flow.(i) in if d.tmp_pred = none then begin let target = target_in_domain targets i in (*Not_found *) Fcl_debug.call 'd' (fun f -> fprintf f "vars.(%d)=%a %d \\V %d\n" i Fd.fprint vars.(i) flow.(i) target); tmp_flow.(i) <- target; d.tmp_pred <- i; new_targets := flow.(i) :: !new_targets; end end with Not_found -> () (* Not reachable target *) done; longer !new_targets true end in (* longer *) longer targets only_once in (* augment *) (* Compute a feasible flow en cherchant des prédécesseurs aux valeurs n'en n'ayant pas assez *) let rec feasible = function [] -> () | v :: vs -> let d = data_of_value v in while d.nb_pred < Fd.min d.card do Fcl_debug.call 'd' (fun f -> fprintf f "unfeasible, need %d\n" v); (* On ne cherche qu'une seule augmentation a la fois pour donner une chance aux autres valeurs *) augment [v] true; Fcl_debug.call 'd' (fun f -> fprintf f "augmented to %d\n" !size_flow) done; feasible vs in feasible !required_values; (* Compute a maximum flow *) while !size_flow < k do (* Seules les valeurs non saturées sont candidates à être extrémité de chemin *) let targets = ref [] in for j = 0 to n - 1 do let d = data_values.(j) in if d.nb_pred < Fd.max d.card then targets := d.value :: !targets done; augment !targets false; Fcl_debug.call 'd' (fun s -> Printf.fprintf s"flow: %a" (fun s a -> Array.iter (fun x -> Printf.fprintf s "%d " x) a) flow; Printf.fprintf s "\n"; flush s); done end; if level > Basic then begin let vertex_of_index index = index + k in (* Processing the predecessors *) let successors_of_s = ref [] in for j = 0 to n - 1 do let d = data_values.(j) in if d.nb_pred < Fd.max d.card then successors_of_s := (vertex_of_index j) :: !successors_of_s; done; (* indices des vertex dans le graphe total [0,k-1] : variables [k,k+n-1] : values k+n : s k+n+1 : t *) let vertex_t = k + n + 1 and vertex_s = k + n in let is_a_var vertex = assert(0 <= vertex); (vertex < k) and is_a_value vertex = (k <= vertex && vertex < k+n) in let funfalse = fun _ -> false in let succ vertex = if vertex = vertex_t then (* Only useful as a start point, successor of nobody *) (funfalse, Fcl_misc.goedel (fun x y -> x::y) k []) else if vertex = vertex_s then (funfalse, !successors_of_s) else if is_a_var vertex then (funfalse, [vertex_of_index (index_of_value flow.(vertex))]) else (* value *) let d = data_values.(vertex - k) in let ps = preds.(vertex - k) and removed = (* remove the pred. in the flow from the predecessors *) fun i -> is_a_var i && index_of_value flow.(i) = vertex - k in (removed, if d.nb_pred > Fd.min d.card then vertex_s :: ps else ps) in let partition = tarjan (k+n+2) succ vertex_t in Fcl_debug.call 'd' (fun f -> fprintf f "partition: "; List.iter (fun c -> fprintf f "["; List.iter (fun x -> fprintf f "%d " x) c; fprintf f "] ") partition; fprintf f "\n"); let components = Array.create (k+n) (-1) in let num = ref 0 in List.iter (fun compo -> List.iter (fun vertex -> if is_a_var vertex || is_a_value vertex then components.(vertex) <- !num) compo; incr num) partition; for i = 0 to k - 1 do (* Pour toutes les variables *) match Fd.value vars.(i) with Val _ -> () | Unk domi -> let to_remove = ref [] in Fcl_domain.iter (fun v -> if v <> flow.(i) && components.(i) <> components.(vertex_of_index (index_of_value v)) then to_remove := v :: !to_remove) (Attr.dom domi); if !to_remove <> [] then Fd.refine vars.(i) (D.difference (Attr.dom domi) (D.create !to_remove)) done; if level > Medium then begin (* Mise a jour des cardinaux *) (* Variables affectées *) let known_values = Array.create n 0 in for i = 0 to k - 1 do match Fd.value vars.(i) with Val v -> let j = index_of_value v in known_values.(j) <- known_values.(j) + 1 | Unk _ -> () done; for j = 0 to n - 1 do let c = data_values.(j).card in if known_values.(j) > Fd.min c then begin Fcl_debug.call 'd' (fun f -> fprintf f "value %d updated\n" j); Fd.refine c (D.remove_low known_values.(j) (domain_of c)) end done; (* Pour toutes les composantes connexes, on obtient une equation sur les cardinaux *) List.iter (fun component -> let values_vertex = List.filter is_a_value component in let values_index = List.map (fun i -> i - k) values_vertex in let nb_predecessors, max_sum, min_sum = List.fold_left (fun (nb_preds, maxs, mins) index -> let d = data_values.(index) in (d.nb_pred + nb_preds, Fd.max d.card + maxs, Fd.min d.card + mins)) (0,0,0) values_index in Fcl_debug.call 'd' (fun f -> fprintf f "compo: %d -> %a\n" nb_predecessors print_int_list values_index); (* Il faudrait boucler sur l'iteration suivante jusqu'a atteindre un point fixe. Utile ??? *) List.iter (fun index -> let d = data_values.(index) in let new_min = nb_predecessors-(max_sum - Fd.max d.card) and new_max = nb_predecessors-(min_sum - Fd.min d.card) in match Fd.value d.card with Val d_card -> if d_card < new_min || new_max < d_card then Fcl_stak.fail "Gcc.d_card" | Unk d_card -> let domcard = domain_of d.card in if Attr.min d_card < new_min then Fd.refine d.card (D.remove_low new_min domcard); if new_max < Attr.max d_card then Fd.refine d.card (D.remove_up new_max domcard) ) values_index) partition end (* level > Basic *) end; (* level > Medium *) check_satisfied () in let init () = (* Cardinal nul pour les valeurs non présentes *) begin let union_di = Array.fold_left (fun acc vi -> D.union acc (domain_of vi)) D.empty vars in Array.iter (fun (c, v) -> if not (D.member v union_di) then Fd.unify c 0) distribution; let values = Array.map snd distribution in let domain = D.create (Array.to_list values) in Array.iter (fun v -> match Fd.value v with Val x -> if not (D.member x domain) then Fcl_stak.fail (Printf.sprintf "Gcc: value %d out of possible values %s" x (D.sprint domain)) | Unk d -> Fd.refine v (D.intersection (Attr.dom d) domain)) vars; (* Initialisation de la représentation duale des domaines *) for i = 0 to k - 1 do maj i done end; ignore (update 0) in C.create ~name ~init ~priority:C.later update delay open Fcl_arith let cstr ?(level = High) (vars : Fd.t array) (distribution : (Fd.t * int) array) = (* Redundant constraint: vars are exactly counted in the distribution *) let sum = (sum_fd (Array.map fst distribution) =~ i2e (Array.length vars)) in (* Sort and index values *) Array.stable_sort (fun (_,v1) (_,v2) -> compare v1 v2) distribution; begin try for i = 1 to Array.length distribution - 1 do if snd distribution.(i) = snd distribution.(i-1) then raise Exit done; with Exit -> invalid_arg "Gcc.cstr: values must be all different" end; let index_of_value = try (* valeurs contigues, hashtbl inutile *) for i = 1 to Array.length distribution - 1 do if not (snd distribution.(i) = snd distribution.(i-1) + 1) then raise Exit done; let shift = snd distribution.(0) in if shift = 0 then (fun v -> v) else (fun v -> v - shift) with Exit -> let size_hashtbl = Array.length distribution in let h = Hashtbl.create size_hashtbl in let index = ref 0 in Array.iter (fun (_c, v) -> Hashtbl.add h v !index; incr index) distribution; (fun v -> Hashtbl.find h v) in (* La contrainte *) let c = new_gcc vars distribution index_of_value level in Fcl_cstr.conjunction [c; sum];; facile-1.1/src/fcl_opti.ml0000644005005300001440000000474510117553006016327 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_opti.ml,v 1.11 2001/06/07 14:07:07 barnier Exp $ *) open Fcl_var open Fcl_arith open Fcl_goals let minimize_restart goal (cost : Fd.t) ?control step compute_solution = let solution = ref None and best_cost = ref (Fd.max cost + step) in try let bound = fun () -> Fcl_cstr.post (fd2e cost <=~ i2e (!best_cost - step)) in while solve ?control (atomic bound &&~ goal) do let m = Fd.int_value cost in solution := Some (compute_solution m); Fcl_stak.backtrack_all (); best_cost := m done; !solution with Exit -> !solution;; let minimize_continue goal (cost : Fd.t) ?(control = (fun _ -> ())) step compute_solution = let rec bt_until c = (* Backtrack until lower bound better than current cost *) let gs = Fcl_stak.backtrack () in if Fd.min cost < c then begin ignore (Fcl_stak.save gs) end else bt_until c in let solution = ref None and best_cost = ref (Fd.max cost) in let restore_max bt = control bt; match Fd.value cost with Val v -> if v > !best_cost then Fcl_stak.fail "restore_max" | Unk attr -> Fd.refine cost (Fcl_domain.remove_up !best_cost (Attr.dom attr)) in let found_one = Fcl_goals.atomic ~name:"found_one" (fun () -> let c = Fd.int_value cost in solution := Some (compute_solution c); best_cost := c - step; bt_until c; Fcl_stak.fail "Opti.minimize_more") in ignore (solve ~control:restore_max (goal &&~ found_one)); !solution type mode = Restart | Continue let minimize g c ?control ?(step = 1) ?(mode = Restart) cs = if step <= 0 then invalid_arg "Opti.minimize: step must be non negative"; match mode with Restart -> minimize_restart g c ?control step cs | Continue -> minimize_continue g c ?control step cs facile-1.1/src/fcl_alldiff.ml0000644005005300001440000001267310117553006016754 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_alldiff.ml,v 1.22 2004/08/12 15:22:07 barnier Exp $ *) module C = Fcl_cstr open Fcl_var let such_that f t = let n = Array.length t in let rec st acc i = if i >= 0 then st (if f t.(i) then (i::acc) else acc) (i-1) else acc in st [] (n-1);; let new_diff_from_others (vars : Fd.t array) = let name = "diff_from_others" and delay x = Array.iteri (fun i _vi -> delay [Fd.on_subst] vars.(i) ~waking_id:i x) vars and update i = match Fd.value vars.(i) with Unk _ -> false | Val x -> for j = 0 to Array.length vars - 1 do if i <> j then match Fd.value vars.(j) with Unk a -> Fd.refine vars.(j) (Fcl_domain.remove x (Attr.dom a)) | Val y -> if x = y then Fcl_stak.fail "diff_from_others" done; true in C.create ~name ~nb_wakings:(Array.length vars) ~priority:C.immediate update delay module Int = struct type t = int let equal (x : int) y = x = y let hash (x : int) = Hashtbl.hash x end module IntHashtbl = Hashtbl.Make(Int) let new_diff (vars : Fd.t array) on_event = let n = Array.length vars (* Une valeur en dehors des valeurs possibles *) and valout = Array.fold_left (fun acc v -> min acc (Fd.min v)) max_int vars - 1 in let matchingl = Array.create n valout in (* var -> value : not backtrackable *) let matchingr = IntHashtbl.create n in(* value -> var : not backtrackable *) let name = "Permut.diff" and delay x = Array.iter (fun v -> delay [on_event] v x) vars and update _ = let getmatchingr i = try IntHashtbl.find matchingr i with Not_found -> -1 in (* matching update (values have been removed from the domains) *) let lefts = ref [] in for i = n-1 downto 0 do (* downto to get lefts ordered *) if matchingl.(i) = valout then lefts := i :: !lefts else match Fd.value vars.(i) with Unk a -> if not (Fcl_domain.member matchingl.(i) (Attr.dom a)) then begin IntHashtbl.remove matchingr matchingl.(i); matchingl.(i) <- valout; lefts := i :: !lefts end | Val x -> if x <> matchingl.(i) then begin let y = getmatchingr x in if y <> -1 (* Value x was already used by y *) then begin matchingl.(y) <- valout; IntHashtbl.remove matchingr x; lefts := y :: !lefts end; if matchingl.(i) <> valout then (*=valout the first time*) IntHashtbl.remove matchingr matchingl.(i); matchingl.(i) <- x; assert(not (IntHashtbl.mem matchingr x)); IntHashtbl.add matchingr x i end done; if !lefts <> [] then begin let apath = IntHashtbl.create n in let getapath i = try IntHashtbl.find apath i with Not_found -> -1 in let reset_apath () = IntHashtbl.clear apath in let depth_first rights = let rec reverse right left = let r = matchingl.(left) in matchingl.(left) <- right; if r <> valout then begin let a = IntHashtbl.find apath r in assert(IntHashtbl.mem matchingr r); IntHashtbl.remove matchingr r; IntHashtbl.add matchingr r a; IntHashtbl.remove apath r; reverse r a end and check r = let ar = getapath r in ar <> -1 && (matchingl.(ar) = valout || check (matchingl.(ar))) in List.iter (fun r -> if getmatchingr r = -1 && check r then begin let a = IntHashtbl.find apath r in assert(not (IntHashtbl.mem matchingr r)); IntHashtbl.add matchingr r a; IntHashtbl.remove apath r; reverse r a end) rights in let rec breadth_first lefts = lefts <> [] && begin let ending = ref false and rights = ref [] and new_lefts = ref [] in List.iter (fun l -> try Fd.iter (fun r -> if getapath r = -1 then begin assert(not (IntHashtbl.mem apath r)); IntHashtbl.add apath r l; rights := r :: !rights; let mr = getmatchingr r in if mr = -1 then raise Exit else new_lefts := mr :: !new_lefts end) vars.(l) with Exit -> ending := true) lefts; if !ending then begin depth_first !rights; let lefts = such_that (fun xi -> xi = valout) matchingl in lefts = [] || (reset_apath (); breadth_first lefts) end else breadth_first !new_lefts end in if not (breadth_first !lefts) then Fcl_stak.fail "permut" end; false in C.create ~priority:C.later ~name update delay type algo = Lazy | Bin_matching of Attr.event let cstr ?(algo = Lazy) vars = (* vars is copied to prevent modifications by the user *) let vars = Array.copy vars in let n = Array.length vars in if n <= 1 then Fcl_cstr.one else let dfo = new_diff_from_others vars in match algo with Bin_matching on_event -> Fcl_cstr.conjunction [new_diff vars on_event; dfo] | Lazy -> dfo facile-1.1/src/fcl_sorting.ml0000644005005300001440000002527510117553006017042 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_sorting.ml,v 1.18 2004/08/12 15:22:07 barnier Exp $ *) (* From Narrowing a 2$n$-Block of Sorting in ${O}(n\log{n})$ Noelle Bleuzen Guernalec and Alain Colmerauer CP97 *) module C = Fcl_cstr open Fcl_var type tree = F of int | N of int * tree * tree let inverse p = let n = Array.length p in let inv = Array.create n (-1) in Array.iteri (fun i x -> inv.(x) <- i) p; inv;; let refine_interval ai inf sup = match Fd.value ai with Val x -> if x < inf || x > sup then Fcl_stak.fail "Narrow.refine_interval" | Unk ai_ -> let dom_ai = Fcl_domain.intersection (Attr.dom ai_) (Fcl_domain.interval inf sup) in Fd.refine ai dom_ai;; (* d = sort(a); a.(i) = d.(p.(i)) *) let new_sort a p d = let pi = Array.init (Array.length a) (fun x -> x) and pi' = Array.init (Array.length a) (fun x -> x) and n = Array.length a in assert(Array.length a = Array.length d); let name = "sort" and delay x = Array.iter (fun v -> delay [Fd.on_min; Fd.on_max] v x) a; Array.iter (fun v -> delay [Fd.on_min; Fd.on_max] v x) d and update _ = Fcl_debug.call 'S' (fun c -> Printf.fprintf c "Unsorted: "; Array.iter (fun v -> Printf.fprintf c "%a " Fd.fprint v) a; Printf.fprintf c "\n"; Printf.fprintf c "Sorted: "; Array.iter (fun v -> Printf.fprintf c "%a " Fd.fprint v) d; Printf.fprintf c "\n"); (* calcul de e (en place dans d) *) for i = 1 to n-1 do let min = Fd.min d.(i-1) and max = Fd.max d.(n-i) in if Fd.min d.(i) < min then begin match Fd.value d.(i) with Val _ -> Fcl_stak.fail "sort#update d.(i)#Fd.min" | Unk di_ -> Fd.refine d.(i) (Fcl_domain.remove_low min (Attr.dom di_)) end; if Fd.max d.(n-1-i) > max then begin match Fd.value d.(n-1-i) with Val _ -> Fcl_stak.fail "sort#update d.(n-1-i)#Fd.max" | Unk di_ -> Fd.refine d.(n-1-i) (Fcl_domain.remove_up max (Attr.dom di_)) end done; let e = Array.map (fun d -> (Fd.min d)) d and e' = Array.map (fun d -> (Fd.max d)) d in (* calcul de b et c *) let max_a = Array.map (fun x -> (Fd.max x)) a and min_a = Array.map (fun x -> (Fd.min x)) a in Array.sort (fun x y -> compare max_a.(x) max_a.(y)) pi; Array.sort (fun x y -> compare min_a.(x) min_a.(y)) pi'; let pi'_1 = inverse pi' and pi_1 = inverse pi in let c i = min_a.(pi'.(i)) and b' i = max_a.(pi.(i)) in (* calcul de s (infI, infI') et s' (supI, supI') *) let infI = Array.create n (-1) and supI = Array.create n (-1) in (* Calcul de s sans tri: On remarque que 1) e, e' et b' sont déjà triés 2) c est la version triée de b' par la permutation pi' o pi_1 c) il n'est pas nécessaire de merger c et e' mais seulement de les parcourir en // *) (* l: index in e' k: index in c ais: last values seen in c *) let rec compute_infI k l ais = if l = n then Fcl_stak.fail "Sorting: one min in 'a' is scrictly greater than the max of 'd'"; let set_infI ()=List.iter (fun i -> infI.(pi_1.(pi'.(i))) <- l) ais in if k < n then if e'.(l) < c k then begin set_infI (); compute_infI k (l+1) [] end else compute_infI (k+1) l (k :: ais) else set_infI () in compute_infI 0 0 []; (* l: index in e k: index in b' ais: last values seen in b' *) let rec compute_supI k l ais = if l < 0 then Fcl_stak.fail "Sorting: one max in 'a' is scrictly less than the min of 'd'"; let setSupI () = List.iter (fun i -> supI.(i) <- l) ais in if k >= 0 then if e.(l) > b' k then begin setSupI (); compute_supI k (l-1) [] end else compute_supI (k-1) l (k :: ais) else setSupI () in compute_supI (n-1) (n-1) []; let infI' = Array.create n (-1) and supI' = Array.create n (-1) in for i = 0 to n-1 do let pi_i = pi.(i) in if (infI.(i) > supI.(i)) then Fcl_stak.fail "Sorting: infI > supI"; begin match p with Some p -> refine_interval p.(pi_i) infI.(i) supI.(i) | None -> () end; let i' = n-1 - pi'_1.(pi_i) in infI'.(i') <- n-1 - supI.(i); supI'.(i') <- n-1 - infI.(i) done; let s (i,j) = infI.(i) <= j && j <= supI.(i) and s' (i,j) = infI'.(i) <= j && j <= supI'.(i) in (*** (* graphmin sets, version avec arbre binaire à la heap *) let graphmin inf sup = let t = Array.create (2*n-1) (-1) in let left k = 2*k+1 and right k = 2*k + 2 in let leaf k = left k >= 2*n-1 in let rec build_tree i k = (* remplir le sous-arbre k des valeurs >= i *) (* renvoyer la feuille la plus grande du sous-arbre *) if leaf k then begin t.(k) <- i; i end else begin let j = build_tree i (left k) in let j' = build_tree (j+1) (right k) in t.(k) <- j'; j' end in let n' = build_tree 0 0 in assert(n' = n - 1); let none = -1 in let pick inf sup = (* on cherche un element entre inf et sup *) let rec loop k = assert(t.(k) <> none); if leaf k then let x = t.(k) in if x <= sup then begin t.(k) <- none; (x, -1) end else (Printf.printf "."; flush stdout; Fcl_stak.fail "Narrow.sort.pick") else let l = left k and r = right k in match (t.(l), t.(r)) with (-1, -1) -> Fcl_debug.internal_error "Sorting: pick none none" | (-1, _) -> let (result, max) = loop r in t.(k) <- max; (result, max) | (_, -1) -> let (result, max) = loop l in t.(k) <- max; (result, max) | _ -> let x = t.(k) in let ll = t.(l) in if inf <= ll then let (result, max) = loop l in (result, x) else let r = right k in let (result, max) = loop r in t.(k) <- if max = -1 then t.(l) else max; (result, t.(k)) in loop 0 in Array.init n (fun i -> fst (pick inf.(i) sup.(i))) in ***) (* Version naive quadratique pour graphmin (30s vs 35s pour atfm) *) let graphmin inf sup = let b = Array.create n false and t = Array.create n (-1) in for i = 0 to n - 1 do let j = ref inf.(i) in while b.(!j) do incr j; if !j > sup.(i) then begin Fcl_stak.fail "graphmin" end done; t.(i) <- !j; b.(!j) <- true done; t in let gamma = graphmin infI supI and gamma' = graphmin infI' supI' in let gamma'' = Array.init n (fun i -> n-1 - gamma'.(n-1-i)) and gamma_1 = inverse gamma in (* Partitioning in stable and shiftable *) let decomp s gamma_1 = let shiftable k1 k2 = s (gamma_1.(k1), k2) in let rec one revx z = if z >= n then two revx z else match revx with [] -> one [z] (z+1) | x::_xs -> if shiftable x z then one (z::revx) (z+1) else two revx z and two revx z = if z >= n then [List.rev revx] else let rec remove_y y = function [] -> assert (y <> []); ([], y) | x::xs -> if shiftable x z then (x::xs, y) else remove_y (x::y) xs in let (rest_revx, y) = remove_y [] revx in y :: one rest_revx z in one [] 0 in let decomps = decomp s gamma_1 and decomps' = decomp s' (inverse gamma') in (* mapmin *) let classes decomp = let c = Array.create n [||] in List.iter (fun sety -> let arrayy = Array.of_list sety in List.iter (fun y -> c.(y) <- arrayy) sety) decomp; c in let classes_s = classes decomps and classes_s' = classes decomps' in let grandk i = ((classes_s).(gamma.(i))) and grandk' i = ((classes_s').(gamma'.(i))) in let mapmin (inf : int array) sup gk = Array.init n (fun i -> let t = gk i in let rec dicho jmin jmax = if t.(jmin) >= inf.(i) then jmin else if jmin + 1 = jmax then jmax else let j = (jmin + jmax) / 2 in if t.(j) >= inf.(i) then dicho jmin j else dicho j jmax in let j = dicho 0 (Array.length t - 1) in assert (inf.(i) <= t.(j) && t.(j) <= sup.(i)); t.(j)) in let phi = mapmin infI supI grandk and phi' = mapmin infI' supI' grandk' in let gamma''_1 = inverse gamma'' in for i = 0 to n - 1 do refine_interval a.(i) e.(phi.(pi_1.(i))) e'.(n-1 - phi'.(n-1-pi'_1.(i))); refine_interval d.(i) (c gamma''_1.(i)) (b' gamma_1.(i)) done; try Array.iter (fun ai -> match (Fd.value ai) with Unk _ -> raise Exit | _ -> ()) a; true with Exit -> false in C.create ~priority:C.later ~name update delay open Fcl_arith (* unification de deux variables du tableau et du tableau trié quand la permutation se précise *) let new_perm p a d = let delay x = Array.iteri (fun i p_i -> delay [Fd.on_subst] p_i ~waking_id:i x) p and name = "Sorting.perm" and update i = match Fd.value p.(i) with Val p_i -> Fcl_cstr.post (fd2e a.(i) =~ fd2e d.(p_i)); true | Unk _ -> false in C.create ~name ~nb_wakings:(Array.length p) ~priority:C.immediate update delay let cstr a ?(p = None) d = let n = Array.length a in if n <> Array.length d then invalid_arg "Sorting.cstr: arrays have not the same length"; if n = 0 then Fcl_cstr.one else begin begin match p with Some perm -> if Array.length perm <> n then invalid_arg "Sorting.cstr: arrays have not the same length"; Fcl_cstr.post (new_perm perm a d); Fcl_cstr.post (Fcl_gcc.cstr perm (Array.init n (fun i -> (Fd.int 1, i)))) | None -> () end; new_sort a p d; end let sortp a = let n = Array.length a in if n = 0 then ([||],[||]) else if n = 1 then (a, [|Fd.int 0|]) else let inf, sup = Array.fold_left (fun (inf, sup) x -> Pervasives.min (Fd.min x) inf, Pervasives.max (Fd.max x) sup) (max_int, min_int) a in let d = Fd.array n inf sup and p = Fd.array n 0 (n - 1) in Fcl_cstr.post (cstr a ~p:(Some p) d); (d, p);; let sort a = let n = Array.length a in if n <= 1 then a else let inf, sup = Array.fold_left (fun (inf, sup) x -> Pervasives.min (Fd.min x) inf, Pervasives.max (Fd.max x) sup) (max_int, min_int) a in let d = Fd.array n inf sup in Fcl_cstr.post (cstr a d); d;; facile-1.1/src/fcl_interval.ml0000644005005300001440000000440410117553006017170 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_interval.ml,v 1.14 2004/08/12 15:22:07 barnier Exp $ *) open Fcl_var open Fcl_arith let cstr v inf sup b = let init () = Fcl_cstr.post (fd2e b<=~i2e 1); Fcl_cstr.post (fd2e b>=~ i2e 0) in let delay x = delay [Fd.on_subst] b x; delay [Fd.on_refine] v x in let update _ = match Fd.value b with Val 0 -> begin match (Fd.value v) with Unk attr -> Fd.refine v (Fcl_domain.remove_closed_inter inf sup (Attr.dom attr)) | Val x -> if x >= inf && x <= sup then Fcl_stak.fail "Interval.cstr" end; true | Val 1 -> begin match (Fd.value v) with Unk attr -> Fd.refine v (Fcl_domain.intersection (Fcl_domain.interval inf sup) (Attr.dom attr)) | Val x -> if x < inf || x > sup then Fcl_stak.fail "Interval.cstr" end; true | Unk _attr -> begin match (Fd.value v) with Val x -> Fd.subst b (if x < inf || x > sup then 0 else 1); true | Unk v_attr -> if Attr.min v_attr > sup || Attr.max v_attr < inf then (Fd.subst b 0; true) (* on n'en fait pas plus pasque c'est trop couteux : on pourrait calculer l'intersection et si elle est vide b=0 *) else if Attr.min v_attr >= inf && Attr.max v_attr <= sup then (Fd.subst b 1; true) else false end | Val _ -> Fcl_debug.internal_error "Interval.cstr#update" in (* update *) Fcl_cstr.create ~init:init ~name:"Interval.cstr" update delay let is_member v inf sup = let b = Fd.create Fcl_domain.boolean in Fcl_cstr.post (cstr v inf sup b); b;; facile-1.1/src/fcl_genesis.ml0000644005005300001440000000431710117553006017004 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) let urbcsp var dom cstr nogood = let max_cstr = var * (var - 1) / 2 and max_ng = dom * dom in let round x = truncate (x +. 0.5) in let cstr = round (float (cstr * max_cstr) /. 100.) and nogood = round (float (nogood * (max_ng-1)) /. 100.) in if var < 2 then invalid_arg "Nombre de variables" else if dom < 2 then invalid_arg "Taille des domaines" else if cstr < 0 || cstr > max_cstr then invalid_arg "Nombre de contraintes" else if nogood < 0 || nogood > max_ng - 1 then invalid_arg "Nombre de nogoods" else (* Tous les couples de variables possibles (en cassant la symétrie) *) let cstr_array = Array.create max_cstr (0, 0) and i = ref 0 in for var1 = 0 to var - 2 do for var2 = var1 + 1 to var - 1 do cstr_array.(!i) <- (var1, var2); incr i done done; let ll = ref [] in for c = 0 to cstr - 1 do let r = c + Random.int (max_cstr - c) in let selected_cstr = cstr_array.(r) in cstr_array.(r) <- cstr_array.(c); cstr_array.(c) <- selected_cstr; let (var1, var2) = selected_cstr in (* Tous les couples de (0..dom-1)X(0..dom-1) *) let ng_array = Array.init max_ng (fun i -> i / dom, i mod dom) in let l = ref [] in for t = 0 to nogood - 1 do let rng = t + Random.int (max_ng - t) in let selected_ng = ng_array.(rng) in ng_array.(rng) <- ng_array.(t); ng_array.(t) <- selected_ng; l := selected_ng :: !l done; ll := (var1, var2, !l) :: !ll; done; !ll;; facile-1.1/src/facile.ml0000644005005300001440000000572010117553006015745 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: facile.ml,v 1.22 2004/08/09 14:45:41 barnier Exp $ *) module Data = Fcl_data module Cstr = Fcl_cstr module Genesis = Fcl_genesis module Reify = Fcl_reify module Alldiff = Fcl_alldiff module Debug = Fcl_debug module Goals = struct module GlArray = struct (* Deprecated, for backward compatibility *) include Fcl_goals.Array let iteri lab_one a = foralli (fun i x -> lab_one i x) a let iter f a = iteri (fun _i -> f) a let iter_hi h lab_one a = foralli ~select:h (fun i x -> lab_one i x) a let iter_h select lab_one a = iter_hi select (fun _ -> lab_one) a let iter2 f a b = iteri (fun i ai -> f ai b.(i)) a let labeling = forall Fcl_goals.indomain end module GlList = struct (* Deprecated, for backward compatibility *) include Fcl_goals.List let iter f l = forall f l let iter_h h = forall ~select:h let labeling = forall Fcl_goals.indomain end include Fcl_goals end module Sorting = Fcl_sorting module Boolean = Fcl_boolean module Expr = Fcl_expr module Arith = Fcl_arith module Domain = Fcl_domain module Interval = Fcl_interval module Stak = Fcl_stak module FdArray = Fcl_fdArray module Misc = Fcl_misc module Var = Fcl_var module Gcc = Fcl_gcc module Opti = Fcl_opti module Conjunto = Fcl_conjunto module SetDomain = Fcl_setDomain module Float = Fcl_float module Invariant = Fcl_invariant module Easy = struct let i2e = Arith.i2e let fd2e = Arith.fd2e let ( +~ ) = Arith.( +~ ) let ( *~ ) = Arith.( *~ ) let ( -~ ) = Arith.( -~ ) let ( /~ ) = Arith.( /~ ) let ( **~ ) = Arith.( **~ ) let ( %~ ) = Arith.( %~ ) let ( <=~ ) = Arith.( <=~ ) let ( <~ ) = Arith.( <~ ) let ( >~ ) = Arith.( >~ ) let ( =~ ) = Arith.( =~ ) let ( <>~ ) = Arith.( <>~ ) let ( >=~ ) = Arith.( >=~ ) let ( <=~~ ) = Arith.( <=~~ ) let ( <~~ ) = Arith.( <~~ ) let ( >~~ ) = Arith.( >~~ ) let ( =~~ ) = Arith.( =~~ ) let ( <>~~ ) = Arith.( <>~~ ) let ( >=~~ ) = Arith.( >=~~ ) let (&&~~) = Reify.(&&~~) let (||~~) = Reify.(||~~) let (=>~~) = Reify.(=>~~) let (<=>~~) = Reify.(<=>~~) let ( &&~ ) = Goals.( &&~ ) let ( ||~ ) = Goals.( ||~ ) module Fd = Var.Fd type ('a, 'b) concrete' = ('a, 'b) Var.concrete = Unk of 'a | Val of 'b type concrete_fd = (Fd.attr, Fd.elt) concrete' end facile-1.1/src/fcl_debug.mli0000644005005300001440000000332210117553006016601 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_debug.mli,v 1.9 2003/08/06 13:29:21 barnier Exp $ *) (* Module [Debug]: debugging facilities *) (* _Undocumented_ Already used characters : c : Cstr g : Goals d : Gcc a : Arith e : Element l : LDS *) val level : string ref (* _Undocumented_ Equals to environement variable FACILEDEBUG if set, else "" *) val log : out_channel ref (* _Undocumented_ Initialized to stdout *) val call : char -> (out_channel -> unit) -> unit (* _Undocumented_ [call lev f] if [lev] belongs to [!level] or [level]="*", function [f] is applied to [!log]. Discarded (if inlined) with the -noassert compiler option. *) val internal_error : string -> 'a (* Implementor's error *) val fatal_error : string -> 'a (* User's error *) val print_in_assert : bool -> string -> bool (* [print_in_assert pred mesg] If [pred] is false, prints an error message containing [mesg] on [stderr] and returns [false], otherwise returns [true]. To be called within [assert]s. *) facile-1.1/src/fcl_misc.mli0000644005005300001440000000620710117553006016453 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_misc.mli,v 1.12 2004/05/10 12:51:19 barnier Exp $ *) (* Module [Misc]: straightforwardly eponymous *) val last_and_length : 'a list -> 'a * int (* _Undocumented_ Returns the last element as well as the size of a list. Used by [Fcl_domain.make]. *) val gen_int_fun : unit -> (unit -> int) (* _Undocumented_ Returns a function generating unique integers (modulo [max_int - min_int]). Used to generate identification keys (increasing from 0). *) val arg_min_array : ('a -> 'b) -> 'a array -> (int * 'b) val arg_max_array : ('a -> 'b) -> 'a array -> (int * 'b) (* _Undocumented_ [arg_min_array f a] (resp. [arg_max_array f a]) returns the index of the first element of [a] that minimizes (resp. maximizes) [f] and the corresponding optimal value. *) val int_overflow : float -> bool (* _Undocumented_ [int_overflow x] returns [true] iff [float max_int < x] or [float min_int > x], [false] otherwise. Used in Operators and [Fcl_arith.expn_int]. *) module Operators : sig val (=+) : int ref -> int -> unit val (=+.) : float ref -> float -> unit (* _Undocumented_ [x =+ n] C-like increment operator. Equivalent to [x := !x+n]. *) val min : int -> int -> int (* _Undocumented_ Non-polymorphic [min] over integers. For optimization purpose. *) val max : int -> int -> int (* _Undocumented_ Non-polymorphic [max] over integers. For optimization purpose. *) val ( * ) : int -> int -> int val (+) : int -> int -> int val (-) : int -> int -> int (* _Undocumented_ Standard integer arithmetic operators with overflow checking raising an assert failure. Disabled if compiled with the -noassert flag. Used in [Fcl_arith]. *) val sign : int -> int val ( /+ ) : int -> int -> int val ( /- ) : int -> int -> int (* _Undocumented_ Used within arithmetic modules *) end val iter : ('a -> 'a) -> int -> 'a -> 'a (* _Undocumented_ [iter f n z] computes [(f (f ... n] times [... (f z)))]. Used in Fcl_arith.( **~). *) val goedel : (int -> 'a -> 'a) -> int -> 'a -> 'a (* _Undocumented_ [godel f n z] computes [(f (n-1) (f (n-2) ... n] times [... (f 0 z)))]. Used in [Fcl_gcc]. *) val protect : string -> (unit -> 'a) -> 'a (* _Undocumented_ [protect name f] calls [f] and controls that it is not called inside itself. Raises an exception using [name] if it is the case. Example: let my_fun my_arg = protect "my_fun" (fun () -> ...). *) facile-1.1/src/fcl_domain.mli0000644005005300001440000001610410117553006016764 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_domain.mli,v 1.48 2004/07/23 16:37:34 barnier Exp $ *) (** Domain Operations *) (** This module provides functions to create and handle domains, which are useful to build variables and perform propagation (i.e. domain filtering). *) type elt = int (** Type of element of domains (for generic interface, {% see~\ref{moduletype:Var.ATTR}%}). *) type t (** Type of finite domains of integers (functional: no in-place modifications, domains can be shared). Standard equality and comparison can be used on domains. *) (** {% \subsection{Building New Domains} %} *) val empty : t (** The empty domain. *) val create : elt list -> t (** [create l] builds a new domain containing the values of [l]. Removes duplicates and sorts values. Returns [empty] if [l] is empty. *) val unsafe_create : elt list -> t (** [unsafe_create l] builds a new domain containing the values of [l]. [l] must be sorted and must not contain duplicate values, otherwise the behaviour is unspecified. Returns [empty] if [l] is empty. It is a more efficient variant of [create]. *) val interval : elt -> elt -> t (** [interval inf sup] returns the domain of all integers in the closed interval [[inf..sup]]. Raise [Invalid_argument] if [inf > sup]. *) val int : t (** The largest representable domain. Handy to create variables for which bounds cannot be previously known. It is actually much smaller than [interval min_int max_int] (which really is the biggest one) to try to prevent overflows while computing bounds of expressions involving such variables. *) val boolean : t (** The domain containing [0] and [1]. *) (** {% \subsection{Access} %} *) val is_empty : t -> bool (** [is_empty d] tests whether the domain [d] is empty or not. *) val size : t -> elt (** [size d] returns the number of integers in [d]. *) val min : t -> elt val max : t -> elt (** [min d] (resp. [max d]) returns the lower (resp. upper) bound of [d]. If [d] is empty, the behaviour is unspecified (incorrect return value or exception raised). *) val min_max : t -> elt * elt (** [min_max d] returns both the lower and upper bound of [d]. If [d] is empty, the behaviour is unspecified (incorrect return value or exception raised). *) val iter : (elt -> unit) -> t -> unit (** [iter f d] successively applies function [f] to all element of [d] in increasing order. *) val interval_iter : (elt -> elt -> unit) -> t -> unit (** [interval_iter f d] successively applies function [f] to the bounds of all the disjoint intervals of [d] in increasing order. E.g. a suitable function [f] to print a domain can be defined as [fun mini maxi -> Printf.printf "%d..%d " mini maxi]. *) val mem : elt -> t -> bool val member : elt -> t -> bool (** [member n d] tests if [n] belongs to [d]. *) val values : t -> elt list (** [value d] returns the list of values of the domain [d] *) val fprint_elt : out_channel -> elt -> unit val fprint : out_channel -> t -> unit (** Pretty printing of elements and domains. *) val sprint : t -> string (** [sprint d] returns a string representation of [d]. *) val included : t -> t -> bool (** [included d1 d2] tests whether domain [d1] is included in domain [d2]. *) val smallest_geq : t -> elt -> elt val greatest_leq : t -> elt -> elt (** [smallest_geq dom val] (resp. [greatest_leq dom val]) returns the smallest (resp. greatest) value in [dom] greater (resp. smaller) than or equal to [val]. Raises [Not_found] if [max dom < val] (resp. [min dom > val]). *) val largest_hole_around : t -> elt -> elt * elt (** [largest_hole_around dom val] returns the largest hole (interval) in [dom] centred around [val]. Returns [(val, val)] if [val] belongs to [dom] and raises [Not_found] if [val] is outside [dom] bounds. Equivalent to [(greatest_leq dom val, smallest_geq dom val)] but faster. *) val choose : (elt -> elt -> bool) -> t -> elt (** [choose ord d] returns the mininum value of [d] for order [ord]. Raises [Not_found] if [d] is empty. *) (** {% \subsection{Operations} %} *) val add : elt -> t -> t (** [add n d] returns [d] {% $\cup$%} [{n}]. *) val remove : elt -> t -> t (** [remove n d] returns [d] {% $\setminus$ %} [{n}]. Returns [d] if [n] is not in [d]. *) val remove_up : elt -> t -> t val remove_low : elt -> t -> t (** [remove_up n d] (resp. [remove_low n d]) returns [d] {% $\setminus$ %} [[n+1..max_int]] (resp. [d] {% $\setminus$ %} [[min_int..n-1]]), i.e. removes values stricly greater (resp. less) than [n]. *) val remove_low_up : elt -> elt -> t -> t (** [remove_low_up low up d] is a shortcut for [remove_up up (remove_low low d)]. *) val remove_closed_inter : elt -> elt -> t -> t (** [remove_closed_inter inf sup d] returns [d] {% $\setminus$ %} [[inf..sup]], i.e. removes values greater than or equal to [inf] and less or equal to [sup] in [d]. Returns [d] if [inf > sup]. *) val remove_min : t -> t val remove_max : t -> t (** [remove_min d] (resp. [remove_max d]) returns [d] without its lower (resp. upper) bound. Raises [Invalid_argument] if [d] is empty. *) val intersection : t -> t -> t val union : t -> t -> t (** Intersection (resp. union) on domains. *) val difference : t -> t -> t (** [difference big small] returns [big] {% $\setminus$ %} [small]. [small] must be included in [big], otherwise the behaviour is unspecified (incorrect return value or exception raised). *) val diff : t -> t -> t (** [diff d1 d2] returns [d1] {% $\setminus$ %} [d2], i.e. domain of elements in [d1] which are not in [d2]. *) val minus : t -> t (** [minus d] returns the domain of opposite values of [d]. *) val plus : t -> elt -> t (** [plus d n] translates a domain by [n]. *) val times : t -> elt -> t (** [times d k] expands a domain by factor [k]. *) val compare : t -> t -> elt (** [compare d1 d2] is a comparison function working first on the cardinal, then (if [d1] and [d2] have the same size) on the lexicographic order of the domains (expressed in extension). *) val compare_elt : elt -> elt -> elt (** [compare_elt e1 e2] is a comparison function on elements of domains. Convenient to use the [Domain] module as a functor argument as in module [Var]{% ~\ref{module:Var}%}. *) val disjoint : t -> t -> bool (** [disjoint d1 d2] tests whether [d1] and [d2] are disjoint. *) (**/**) val strictly_inf : elt -> elt -> bool facile-1.1/src/fcl_setDomain.mli0000644005005300001440000000651510117553006017445 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_setDomain.mli,v 1.1 2004/08/09 14:40:01 barnier Exp $ *) (** {1 Integer Set Domain Operations} *) (** Implementation of sets of integers. The signature is freely inspired by the Set module of the standard OCaml library. *) module S : sig type t = Fcl_domain.t val empty: t val is_empty: t -> bool val mem: int -> t -> bool val add: int -> t -> t val singleton: int -> t val remove: int -> t -> t val union: t -> t -> t val inter: t -> t -> t val diff: t -> t -> t val compare: t -> t -> int val equal: t -> t -> bool val subset: t -> t -> bool val iter: (int -> unit) -> t -> unit val cardinal: t -> int val elements: t -> int list val min_elt: t -> int val max_elt: t -> int val choose: t -> int val remove_up : int -> t -> t val remove_low : int -> t -> t end type elt = S.t (** Type of elements of set domains. They are sets themselves. *) type t (** Type of finite domains of integer sets: a domain is a powerset lattice of sets bounded by definite elements or {e glb} (Greater Lower Bound) and possible elements or {e lub} (Lower Upper Bounds). The glb is a subset of the lub. Note that the empty domain cannot be represented. *) (** {2 Creation} *) val elt_of_list : int list -> elt (** Creates a set from a list of integers. *) val interval : elt -> elt -> t (** [interval glb lub] builds the domain of sets greater than [glb] and smaller than [lub]. An [Invalid_argument] exception is raised if [glb] is not a subset of [lub]. *) (** {2 Access and Operations} *) val size : t -> int (** [size d] returns |glb(d)|-|lub(d)|+1, i.e. the height of the lattice, not its number of elements. *) val min : t -> elt val max : t -> elt val min_max : t -> elt * elt (** Access to glb and lub. *) val fprint_elt : out_channel -> elt -> unit val fprint : out_channel -> t -> unit (** Pretty printing of elements and domains. *) val mem : elt -> t -> bool (** [mem x d] tests whether [x] belongs to the domain [d]. *) val included : t -> t -> bool (** [included d1 d2] tests whether the domain [d1] is included in [d2], i.e. glb([d2]) included in glb([d1]) and lub([d1]) included in lub([d2]). *) val iter : (elt -> 'a) -> t -> 'a (** Iteration on values of the domain. {b Exponential} with the [size] of the domain. *) val values : t -> elt list (** Returns values of a domain. {b Exponential} with the [size] of the domain. *) (**/**) val intersection : elt -> elt -> elt val strictly_inf : elt -> elt -> bool val compare_elt : elt -> elt -> int val unsafe_interval : elt -> elt -> t (** [glb] <= [lub] not checked. *) val remove_up : elt -> t -> t val remove_low : elt -> t -> t facile-1.1/src/fcl_float.mli0000644005005300001440000000240010117553006016614 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_float.mli,v 1.3 2003/06/11 14:43:58 barnier Exp $ *) val epsilon : float type elt = float and t val fprint_elt : out_channel -> float -> unit val fprint : out_channel -> t -> unit val size : t -> int val min : t -> float val max : t -> float val min_max : t -> float * float val mem : float -> t -> bool val interval : float -> float -> t val included : t -> t -> bool val strictly_inf : elt -> elt -> bool val compare_elt : elt -> elt -> int val zero : elt -> bool val remove_low : elt -> t -> t val remove_up : elt -> t -> t facile-1.1/src/fcl_stak.mli0000644005005300001440000000673310117553006016466 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_stak.mli,v 1.24 2004/07/30 10:37:13 barnier Exp $ *) (** {1 Global Stack of Goals, Backtrackable Operations} *) (** This module provides functions to control the execution of the goal stack, as well as {e backtrackable references}, i.e. mutable data structures restored on backtracking. Nota: the module name [Stak] lacks a '[c]' because of a possible clash with the OCaml standard library module [Stack]. *) (** {2 Access} *) type level (** Type of a level in the stack. *) val older : level -> level -> bool (** [older l1 l2] true if level [l1] precedes [l2]. *) val size : unit -> int (** Size of the stack, i.e. number of trailings. *) val depth : unit -> int (** Depth of the stack, i.e. number of active levels. *) val level : unit -> level (** Returns the current level. *) val levels : unit -> level list (** Returns the current active levels. *) val nb_choice_points : unit -> int (** Access to a global counter incremented at each choice point. Useful to implement search strategies such as Limited Discrepancy Search{% ~\cite{harvey95.lds}.%} *) (** {2 Control} *) exception Level_not_found of level (** Raised by [cut]. *) val cut : level -> unit (** [cut l] cuts the choice points left on the stack until level [l]. Raise [Level_not_found] if level is not reached and stack is empty. *) exception Fail of string (** Raised during solving whenever a failure occurs. The string argument is informative. *) val fail : string -> 'a (** [fail x] equivalent to [raise (Fail x)]. *) (** {2 Backtrackable References} *) type 'a ref (** Backtrackable reference of type ['a]. I.e. type of mutable data structures restored on backtracking. *) val ref : 'a -> 'a ref (** Returns a reference whose modifications will be trailed during the solving of a goal. *) val set : 'a ref -> 'a -> unit (** Sets a backtrackable reference. *) val get : 'a ref -> 'a (** Dereference. *) (**/**) type gl = { name : string; call : unit -> gl option } (** Concrete type of goals. Hidden in Facile. *) exception Empty_stack (** _Undocumented_ *) val reset : unit -> unit (** Empty the stack. *) val save : gl list -> level (** Push a choice point on the stack. *) val backtrack : unit -> gl list (** _Undocumented_ Pop a success continuation. May raise Empty_stack. *) val backtrack_all : unit -> unit (** _Undocumented_ Pop the whole stack. *) val trail : (unit -> unit) -> unit (** _Undocumented_ [trail undo] Push the closure [undo] on the stack. The closure will be called when poped from the stack. *) val cut_bottom : level -> unit (** _Undocumented_ Raise Level_not_found if level is not reached and stack is empty. *) val unsafe_set : 'a ref -> 'a -> unit (** _Undocumented_ Unbacktrackable modification. *) facile-1.1/src/fcl_data.mli0000644005005300001440000000330310117553006016423 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_data.mli,v 1.2 2004/07/30 13:09:43 barnier Exp $ *) (** {1 Bactrackable Data Structures} *) (** This module provides "efficient" backtrackable data structures, i.e. with incremental setting and trailing. *) module Array : sig val set : 'a array -> int -> 'a -> unit (** [set t i x] Bactrackable assignment of [t.(i)] with [x]. *) end (** Bactrackable arrays. *) module Hashtbl : sig type ('a, 'b) t val create : int -> ('a, 'b) t val get : ('a, 'b) t -> ('a, 'b) Hashtbl.t val add : ('a, 'b) t -> 'a -> 'b -> unit val find : ('a, 'b) t -> 'a -> 'b val mem : ('a, 'b) t -> 'a -> bool val remove : ('a, 'b) t -> 'a -> unit val replace : ('a, 'b) t -> 'a -> 'b -> unit val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c end (** Bactrackable hashtables. This module provides a subset of the hashtable interface of the OCaml standard library module Hashtbl (see {% ~\cite{ocaml}%}). *) facile-1.1/src/fcl_cstr.mli0000644005005300001440000001765210117553006016501 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_cstr.mli,v 1.45 2004/09/03 13:23:11 barnier Exp $ *) (** Posting Constraints and Building New Ones *) (** {% \paragraph{Overview} %} *) (** This module defines the type [t] of constraints and functions to create and post constraints: mainly a [create] function which allows to build new constraints from scratch (this function is not needed when using standard FaCiLe predefined constraints) and the mostly useful [post] function which must be called to actually add a constraint to the constraint store. *) (** {% \subsection{Basic} %} *) exception DontKnow (** Exception raised by the [check] function of a reified constraint when it is not known whether the constraint is satisfied or violated. *) type priority (** Type of waking priority. *) val immediate : priority val normal : priority val later : priority (** Available priorities: - immediate: as soon as possible, for quick updates; - normal: standard priority; - later: for time consuming constraints (e.g. [Gcc.cstr], [Alldiff.cstr]...). *) type t (** The type of constraints. *) val create : ?name:string -> ?nb_wakings:int -> ?fprint:(out_channel -> unit) -> ?priority:priority -> ?init:(unit -> unit) -> ?check:(unit -> bool) -> ?not:(unit -> t) -> (int -> bool) -> (t -> unit) -> t (** [create ?name ?nb_wakings ?fprint ?priority ?init ?check ?not update delay] builds a new constraint: - [name] is a describing string for the constraint. Default value is ["anonymous"]. - [nb_wakings] is the number of calls to [Var.delay] with distinct "[waking_id]" arguments {% (see~\ref{val:Var.BASICFD.delay})%} within the constraint own [delay] function (see below). Default value is [1]. Beware that if [nb_wakings] is greater than 1 and the optional [init] argument is not provided, [init] default behaviour is to do nothing (i.e. the [update] function will not be called). - [fprint] should print the constraint on an output channel taken as its only argument. Default value is to print the [name] string. - [priority] is either [immediate], [normal] or [later]. Time costly constraints should be waken after quick ones. Default value is [normal]. - [init] is useful to perform initialization of auxiliary data structures needed and maintained by the [update] function. [init ()] is called as soon as the constraint is posted. Default value is to call [(update 0)] if [nb_wakings] is equal to 1 to perform an initial propagation; if [nb_wakings] is greater than 1, default value is [fun () -> ()], i.e. it does nothing. Hence, an [init] argument must be provided if this is not the desired behaviour. - [check] must be specified if the constraint is to be reifiable (as well as the [not] function). When the constraint is reified, [check ()] is called to verify whether the constraint is satisfied or violated, i.e. the constraint itself or its negation is entailed by the constraint store. It should return [true] if the constraint is satisfied, [false] if it is violated and raise [DontKnow] when it is not known. [check] {b must not} change the domains of the variables involved in the constraint. Default: [Failure] exception is raised. - [not] must be specified if the constraint is reifiable (as well as [check]). [not ()] should return a constraint which is the negation of the constraint being defined. When the constraint is reified, it is called to post the negation of the constraint whenever [check ()] return [false], i.e. the negation is entailed by the constraint store. Default: [Failure] exception is raised. - [update] is a mandatory argument which propagates the constraint, i.e. filters domains and checks consistency. This function takes an integer as its unique parameter, according to the optional [waking_id] argument given to the [Var.delay] calls featured in the constraint own [delay] function (see below). When a waking event occurs, this function is called with the corresponding integer "[waking_id]", and must return [true] when the constraint is (partially) satisfied {e for this event}, [false] if further propagations have to be performed, and raise [Stak.Fail] whenever an inconsistency is detected. The whole constraint is solved when [update 0], ..., [update (nb_wakings-1)] have all returned [true]. E.g. a global constraint on an array of variables can be aware of which variable has triggered the awakening by providing the integer index of the variable as its "[waking_id]" to the [Var.delay] function. [update] is called with [0] by default when the [nb_wakings] argument has been omitted; in this case, the constraint is solved as soon as [update] returns [true]. - [delay] schedules the awakening of the constraint [ct] (which is taken as its unique argument), i.e. the execution of its [update] function. If [update id] should be called (because it may propagates) when one of the events contained in the events {% (see~\ref{val:Var.ATTR.on-underscorerefine})%} list [es] occurred on variable [v], then [Var.delay es v ~waking_id:id ct] should be called within the body of the [delay] function. Beware that {b all the "[waking_id]s" must be contiguous integers ranging from} [0] {b to} [nb_wakings-1], otherwise the behaviour is unspecified. [delay] is a mandatory argument. *) val post : t -> unit (** [post c] posts the constraint [c] to the constraint store. *) val one : t val zero : t (** The constraint which succeeds (resp. fails) immediately. *) (** {% \subsection{Access} %} *) val id : t -> int (** [id c] returns a unique integer identifying the constraint [c]. *) val name : t -> string (** [name c] returns the name of the constraint [c]. *) val priority : t -> priority (** [priority c] returns the priority of the constraint [c]. *) val fprint : out_channel -> t -> unit (** [fprint chan c] prints the constraint [c] on channel [chan]. Calls the [fprint] function passed to [create]. *) val is_solved : t -> bool (** [is_solved c] returns [true] if [c] is satisfied and [false] otherwise. *) val active_store : unit -> t list (** [active_store ()] returns the list of all active constraints, i.e. whose [update] functions have returned [false]. *) val not : t -> t (** [not c] returns the negation of [c]. *) (**/**) (* Following values are undocumented *) (** An object with wakable constraints *) type event val new_event : unit -> event val schedule : event -> unit val register : event -> ?waking_id:int -> t -> unit val registered : event -> (t * int) list (** Returns ALL constraints *) val delay : event list -> ?waking_id:int -> t -> unit (** [delay event_list c] suspends constraint [c] on all the events in [event_list]. *) val conjunction : t list -> t (** Posts a conjunction of constraints when posted ([one] if the list is empty). Not reifiable. *) val reset_queue : unit -> unit val assert_empty_queue : unit -> unit (** _Undocumented_ [reset_queue ()] reset the constraint queue. *) val wake_all : unit -> unit (** _Undocumented_ [wake_all ()] wake all constraints respecting priority order. *) val init : t -> unit (** _Undocumented_ [init c] post the constraint deamon [c] (no wake and no add call). *) val self_delay : t -> (t -> unit) val check : t -> bool facile-1.1/src/fcl_var.mli0000644005005300001440000002227210117553006016310 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_var.mli,v 1.31 2004/09/03 13:25:55 barnier Exp $ *) (** {1 Constrained, Attributed, Finite Domain Variables} *) module type ATTR = sig type t (** Type of attributes. *) type domain (** Type of domains stored in attributes. *) type elt (** Type of element of domains. *) type event (** Type of events (modifications on variables) on which to suspend. *) val dom : t -> domain (** [dom a] returns the integer domain of an attribute. *) val on_refine : event (** Event occuring when a variable is changed, i.e. its domain modified. *) val on_subst : event (** Event occuring when a variable is instantiated. *) val on_min : event val on_max : event (** Event occuring when the lower (resp. upper) bound of a variable decreases.*) val fprint : out_channel -> t -> unit (** [fprint chan a] prints attribute [a] on channel [chan]. *) val min : t -> elt val max : t -> elt (** [min a] (resp. [max a]) returns the lower (resp. upper) bound of [a]. *) val member : t -> elt -> bool (** [member a n] tests if [n] belongs to [dom a]. *) val id : t -> int (** [id a] returns a unique integer identifying the attribute [a]. *) val constraints_number : t -> int (** [constraints_number a] returns the number of different constraints attached to [a]. *) val size : t -> int (** [size a] returns the number of integer values in the domain of [a]. *) end (** Signature of the Attribute of a Domain Variable. A module endowed with this type is required to build finite domain variables. [Domain] and [SetDomain] are suitable domain modules. *) module Attr : ATTR with type domain = Fcl_domain.t and type elt = Fcl_domain.elt module SetAttr : ATTR with type domain = Fcl_setDomain.t and type elt = Fcl_setDomain.S.t type ('a, 'b) concrete = Unk of 'a | Val of 'b (** Concrete type of the value of finite domain variables. *) module type BASICFD = sig type t (** Type of finite domain variable. *) type attr (** Type of attributes. *) type domain (** Type of domains. *) type elt (** Type of elements of domains. *) type event (** Type of domain reduction events. *) (** {2 Creation} *) val create : ?name:string -> domain -> t (** [create ?name d] returns a new variable with domain [d]. If provided, [name] will be used by the pretty printer. *) val interval : ?name:string -> elt -> elt -> t (** [interval ?name inf sup] returns a new variable with domain [[inf..sup]]. If provided, [name] will be used by the pretty printer.*) val array : ?name:string -> int -> elt -> elt -> t array (** [array n inf sup] returns an array of [n] new variables with domain [[inf..sup]]. If provided, [name] (suffixed with the index of the element) will be used by the pretty printer. *) val elt : elt -> t (** [int n] returns a new variable instantiated to integer value [n]. *) (** {2 Access} *) val is_var : t -> bool (** [is_var v] returns [true] if [v] is not instantiated and [false] otherwise. *) val is_bound : t -> bool (** [is_bound v] returns [true] if [v] is instantiated and [false] otherwise. *) val value : t -> (attr, elt) concrete (** [value v] returns [Val n] if [v] is instantiated to [n], [Unk a] otherwise where [a] is the attribute of [v]. Should always be used in a matching: [match value v with Val n -> ... | Unk a -> ...]. *) val min : t -> elt (** [min v] returns the lower bound of [v]. *) val max : t -> elt (** [max v] returns the upper bound of [v]. *) val min_max : t -> elt * elt (** [min_max v] returns both the lower and upper bounds of [v]. *) val elt_value : t -> elt (** [int_value v] returns the value of [v] if it is instantiated and raises a [Failure] exception otherwise. *) val int_value : t -> elt (* [int_value = elt_value] deprecated. *) val size : t -> int (** [size v] returns the number of integer values in the domain of [v] ([1] if [v] is instantiated). *) val member : t -> elt -> bool (** [member v n] returns [true] if [n] belongs to the domain of [v] and [false] otherwise. *) val id : t -> int (** [id v] returns a unique integer identifying the attribute associated with [v]. Must be called only on non ground variable, raise [Failure] otherwise. *) val name : t -> string (** [name v] returns the name of variable [v] (the empty string if it was not provided while created). Must be called only on non ground variable, raise [Failure] otherwise. *) val compare : t -> t -> int (** Compares two variables. Values (bound variables) are smaller than unknowns (unbound variables). Unknowns are sorted according to their attribute [id]. *) val equal : t -> t -> bool (** Tests if two variables are equal with respect to [compare]. *) val fprint : out_channel -> t -> unit (** [fprint chan v] prints variable [v] on channel [chan]. *) val fprint_array : out_channel -> t array -> unit (** [fprint_array chan vs] prints array of variables [vs] on channel [chan]. *) (** {2 Refinement} *) val unify : t -> elt -> unit (** [unify v n] instantiates variable [v] with integer value [n]. Raises [Fcl_stak.Fail] in case of failure. [unify] may be called either on unbound variables or on instantiated variables. *) val refine : t -> domain -> unit (** [refine v d] reduces the domain of [v] with domain [d]. [d] must be included in the domain of [v], otherwise the behaviour is unspecified (corrupted system or exception raised). *) val refine_low : t -> elt -> unit (** [refine_low v inf] reduces the domain of [v] by cutting all values strictly less than [inf]. *) val refine_up : t -> elt -> unit (** [refine_up v sup] reduces the domain of [v] by cutting all values strictly greater than [sup]. *) val refine_low_up : t -> elt -> elt -> unit (** [refine_low_up v inf sup] reduces the domain of [v] by cutting all values strictly less than [inf] and greater than [sup]. Robust even if [v] is already bound (checks that [inf] <= [v] <= [sup], otherwise fails). *) (** {2 Events and suspending} *) val on_refine : event (** Event occuring when a variable is changed, i.e. its domain modified. *) val on_subst : event (** Event occuring when a variable is instantiated. *) val on_min : event val on_max : event (** Event occuring when the lower (resp. upper) bound of a variable decreases. *) val delay : event list -> t -> ?waking_id:int -> Fcl_cstr.t -> unit (** [delay event_list v ~waking_id:id c] suspends constraint [c] on all the events in [event_list] occurring on [v]. An optional integer [id] may be associated to the wakening: it must be unique and range from 0 to [nb_wakings-1], [nb_wakings] being the argument of [Cstr.create] specifying the number of calls to [delay] with distinct [waking_id] arguments. These integers are arguments to the "update" function of constraints and aim at discriminating waking events to fire the appropriate propagation rule. [waking_id] default value is 0. This function has no effect on instantiated variables (as no event could occur on a ground variable). *) (**/**) val int : elt -> t val subst : t -> elt -> unit (** [subst v n] instantiates variable [v] with integer value [n]. Raises [Fcl_stak.Fail] in case of failure. Must be called only on unbound (not instantiated) variable, otherwise a [Failure] exception is raised. *) val unify_cstr : t -> elt -> Fcl_cstr.t end (** Common variables module signature. *) (** Extended signature for finite domain variable (with added functions irrelevant to set variables). *) module type FD = sig include BASICFD val remove : t -> elt -> unit (** [remove v a] removes [a] from the domain of [v]. Leaves the domain unchanged if [a] does not belong to it. *) val values : t -> elt list (** [values v] returns the list of all integers in the domain of [v]. If [v] is instantiated to [n], returns the singleton list containing [n]. *) val iter : (elt -> unit) -> t -> unit (** [iter f v] iterates f on each integer in the domain of [v]. *) end module Fd : FD with type domain = Fcl_domain.t and type elt = Fcl_domain.elt and type attr = Attr.t and type event = Attr.event (** Concrete finite domain variable module. *) module SetFd : BASICFD with type domain = Fcl_setDomain.t and type elt = Fcl_setDomain.S.t and type attr = SetAttr.t and type event = SetAttr.event (** Concrete integer set variable module. *) (**/**) (** Obsolete, for backward compatibility only *) type concrete_fd = (Fd.attr, Fd.elt) concrete val delay : Attr.event list -> Fd.t -> ?waking_id:int -> Fcl_cstr.t -> unit facile-1.1/src/fcl_invariant.mli0000644005005300001440000001210510117553006017505 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_invariant.mli,v 1.2 2004/09/08 09:54:23 barnier Exp $ *) (** Backtrackable Invariant References *) (** This module provides types and functions to create and handle Backtrackable Invariant References (noted BIR in the sequel). BIRs are single-valued variables whose values are restored upon backtracks and which are linked by "one-way" constraints. They maintain functional dependencies between "source" {e setable} BIRs (initialized with their creation value) and {e unsetable} BIRs built upon them. BIRs may be convenient to automatically handle heuristic criteria or the data structures of local search algorithms {% ~\cite{localizer97}%}. Note that circular dependencies are not allowed by the typing policy. *) type ('a, 'b) t type setable type unsetable type 'a setable_t = ('a, setable) t type 'a unsetable_t = ('a, unsetable) t (** Type of BIRs. Parameter ['a] stands for the type of the value of the BIR. Parameter ['b] is [setable] if the BIR can be assigned, [unsetable] if not. [setable_t] and [unsetable_t] are shortcuts. *) (** {% \subsection{Creation and access} %} *) val create : ?name:string -> 'a -> 'a setable_t (** [create ~name:"" v] returns a setable BIR with initial content [v]. An optional string can be given to name the BIR. *) val constant : ?name:string -> 'a -> 'a unsetable_t (** [constant ~name:"" cst] returns an unsetable BIR with initial content [cst]. An optional string can be given to name the BIR. *) val set : 'a setable_t -> 'a -> unit (** Assignment of a setable BIR. *) val get : ('a, 'b) t -> 'a (** Access to the content of a BIR. *) val id : ('a, 'b) t -> int (** [id r] returns a unique integer associated to BIR [r]. *) val name : ('a, 'b) t -> string (** [name r] returns the name (specified or generated) of BIR [r]. *) val fprint : out_channel -> ?printer:(out_channel -> 'a -> unit) -> ('a, 'b) t -> unit (** [fprint c ~printer:(fun _ _ -> ()) r] prints BIR [r] on channel [c]. An optional custom printer can be given to display the value of [r]. *) (** {% \subsection{Operations: generic, arithmetic, arrays} %} *) val unary : ?name:string -> ('a -> 'b) -> (('a, 'c) t -> 'b unsetable_t) (** [unary ~name:"Invariant.unary" f] wraps the unary function [f] into an operator on BIRs. An optional string can be given to name the operator. *) val binary : ?name:string -> ('a -> 'b -> 'c) -> (('a, 'd) t -> ('b, 'e) t -> 'c unsetable_t) (** [binary ~name:"Invariant.binary" f] wraps the binary function [f] into an operator on BIRs. An optional string can be given to name the operator. *) val ternary : ?name:string -> ('a -> 'b -> 'c -> 'd) -> (('a, 'e) t -> ('b, 'f) t -> ('c, 'g) t -> 'd unsetable_t) (** [ternary ~name:"Invariant.ternary" f] wraps the ternary function [f] into an operator on BIRs. An optional string can be given to name the operator. *) val sum : (int, 'a) t array -> int unsetable_t (** [sum a] returns a BIR equal to the sum of elements of [a]. *) val prod : (int, 'a) t array -> int unsetable_t (** [sum a] returns a BIR equal to the product of elements of [a]. *) module Array : sig val get : ('a, 'b) t array -> (int, 'c) t -> 'a unsetable_t (** [get a i] returns the BIR element number [i] of array [a]. *) val argmin : ('a, 'b) t array -> ('a -> 'c) -> int unsetable_t (** [argmin a c] returns the BIR index of the minimum BIR value of [a] for criterion [c]. *) val min : ('a, 'b) t array -> ('a -> 'c) -> 'a unsetable_t (** [min a c] returns the minimum BIR value of [a] for criterion [c]. *) end (** {% \subsection{From domain variables to BIRs} %} *) (** Generic signature. *) module type FD = sig type fd (** Type of a finite domain variable. *) type elt (** Type of elements in the domain. *) val min : fd -> elt unsetable_t val max : fd -> elt unsetable_t val size : fd -> int unsetable_t val is_var : fd -> bool unsetable_t (** BIR variants of [Fd.Var] access functions. *) val unary : ?name:string -> (fd -> 'a) -> fd -> 'a unsetable_t (** [unary ~name:"Invariant.XxxFd.unary" f v] Wrapper of any access function over [fd] type. *) end module Fd : FD with type fd = Fcl_var.Fd.t and type elt = Fcl_var.Fd.elt (** Module for accessing finite integer domain variables with BIRs. *) module SetFd : FD with type fd = Fcl_var.SetFd.t and type elt = Fcl_var.SetFd.elt (** Module for accessing set domain variables with BIRs. *) facile-1.1/src/fcl_reify.mli0000644005005300001440000000512410117553006016633 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_reify.mli,v 1.20 2004/07/28 16:01:00 barnier Exp $ *) (** Constraints Reification *) (** All the reification functions and operators only work on {b reifiable} constraints, i.e. constraints endowed with a [check] function {b and} a [not] function (or built-in constraints for which the documentation does not mention "Not reifiable"). Otherwise a [Failure] (fatal error) exception is raised. *) val boolean : ?delay_on_negation:bool -> Fcl_cstr.t -> Fcl_var.Fd.t (** [boolean ~delay_on_negation:true c] returns a boolean (0..1) variable associated to the constraint [c]. The constraint is satisfied iff the boolean variable is instantiated to 1. Conversely, its negation is satisfied iff it is instantiated to 0. The waking conditions of the contraint relating [c] and the boolean variable are the ones set by the [delay] function of [c] (set by the [delay] argument of [Cstr.create]). If the optional argument [delay_on_negation] is set to [true], the new constraint is also attached to the events that awake the negation of [c] (i.e. the constraint returned by the [not] function of [c]), otherwise it is not. [delay_on_negation] default value is [true]. *) val cstr : ?delay_on_negation:bool -> Fcl_cstr.t -> Fcl_var.Fd.t -> Fcl_cstr.t (** [cstr ~delay_on_negation:true c b] is equivalent to the constraint [boolean ?delay_on_negation c =~ b]. [delay_on_negation] default value is [true]. *) (** {% \subsection{Operators} %} *) val (&&~~) : Fcl_cstr.t -> Fcl_cstr.t -> Fcl_cstr.t val (||~~) : Fcl_cstr.t -> Fcl_cstr.t -> Fcl_cstr.t val (=>~~) : Fcl_cstr.t -> Fcl_cstr.t -> Fcl_cstr.t val (<=>~~) : Fcl_cstr.t -> Fcl_cstr.t -> Fcl_cstr.t val xor : Fcl_cstr.t -> Fcl_cstr.t -> Fcl_cstr.t val not : Fcl_cstr.t -> Fcl_cstr.t (** Logical reification operators on constraints, namely and, or, implies, equivalent, exclusive or, not. *) facile-1.1/src/fcl_boolean.mli0000644005005300001440000000214610117553006017135 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) val cstr : Fcl_var.Fd.t array -> Fcl_var.Fd.t -> Fcl_cstr.t (** [cstr bools sum] returns a constraint ensuring that [sum] is equal to the sum of the boolean variables of the array [bools]. This constraint posts a demon for each variable. *) val sum : Fcl_var.Fd.t array -> Fcl_var.Fd.t (** [sum bools] returns the sum (a new variable) and posts the preceding constraint. *) facile-1.1/src/fcl_linear.mli0000644005005300001440000000313410117553006016766 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) type operator = LessThan | Equal | Diff val min_max_plus_inter : int -> int -> int -> int -> (int * int) val min_max_minus_inter : int -> int -> int -> int -> (int * int) val cstr : ?boolsum:int -> (int * Fcl_var.Fd.t) list -> operator -> int -> Fcl_cstr.t (* [cstr (?boolsum:int) coef_vars op d] returns the linear constraint [sum coef_vars op d] and automatically optimizes boolean sums larger than [boolsum] variables (default: 5). *) val linear_aux : (int * Fcl_var.Fd.t) list -> int -> Fcl_var.Fd.t val shift_cstr : Fcl_var.Fd.t -> Fcl_var.Fd.t -> int -> Fcl_cstr.t (** [shift_cstr y x d] returns the constraint [y = x+d] *) val get_boolsum_threshold : unit -> int (** Returns the minimum size for boolean sums optimization. *) val set_boolsum_threshold : int -> unit (** Set the minimum size for boolean sums optimization. [boolsum_threshold max_int] disables it. *) facile-1.1/src/fcl_nonlinear.mli0000644005005300001440000000364710117553006017512 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) val min_of_absmod_inter : int -> int -> int -> int -> int val max_of_absmod_inter : int -> int -> int -> int -> int val diffsign : int -> int -> bool val diffeqsign : int -> int -> bool val udiffsign : int -> int -> bool val min_max_mult_inter : int -> int -> int -> int -> (int * int) val min_max_div_inter : int -> int -> int -> int -> (int * int) val min_max_mod_inter : int -> int -> int -> int -> (int * int) val min_max_abs_inter : int -> int -> (int * int) val min_max_expn_inter : int -> int -> int -> (int * int) val expn_int : int -> int -> int (* [expn_int x n] computes [x^n]. *) val monome : Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_cstr.t val monome_aux : Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_var.Fd.t val absolute : Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_cstr.t val absolute_aux : Fcl_var.Fd.t -> Fcl_var.Fd.t val division : Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_cstr.t val division_aux : Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_var.Fd.t val modulo : Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_cstr.t val modulo_aux : Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_var.Fd.t val expn : Fcl_var.Fd.t -> Fcl_var.Fd.t -> int -> Fcl_cstr.t val expn_aux : Fcl_var.Fd.t -> int -> Fcl_var.Fd.t facile-1.1/src/fcl_expr.mli0000644005005300001440000000405710117553006016477 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (** Arithmetic Expressions over Variables of Type [Var.Fd.t] *) (** This module provides functions and operators to build arithmetic expressions. *) type agg_op = Pluse | Multe type bin_op = Dive | Mode type un_op = Abse type var = Var of Fcl_var.Fd.t | Aux of int type t = Agg of agg_op * (int * t) list * int | Bin of bin_op * t * t | Un of un_op * t | Inte of int | Fde of var (** Type of arithmetic expressions over variables of type [Var.Fd.t] and integers. *) val fprint : out_channel -> t -> unit (** [fprint chan e] prints expression [e] on channel [chan]. *) val eval : t -> int (** [eval e] returns the integer numerical value of a fully instantiated expression [e]. Raises [Invalid_argument] if [e] is not instantiated. *) val min_of_expr : t -> int val max_of_expr : t -> int (** [min_of_expr e] (resp. [max_of_expr e]) returns the minimal (resp. maximal) possible value of expression [e]. *) val min_max_of_expr : t -> (int * int) (** [min_max_of_expr e] is equivalent to [(min_of_expr e, max_of_expr e)]. *) val compare_expr : t -> t -> int val compare_intexpr : (int * t ) -> (int * t ) -> int val reduce : t -> t (** [reduce e] normalizes expression [e]. *) val constrain : t -> Fcl_linear.operator -> Fcl_cstr.t (** [constrain e op] returns the constraint [e op = 0] and post intermediate constraints. *) facile-1.1/src/fcl_arith.mli0000644005005300001440000001353210117553006016626 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (** {1 Arithmetic Expressions and Constraints} *) (** {% \paragraph{Overview} %} *) (** This module provides functions and operators to build arithmetic expressions and state (in/dis)equation constraints on them. *) (** {2 Basics} *) type t (** Type of arithmetic expressions over variables of type [Var.Fd.t] and integers. *) (*** Conversion *) val i2e : int -> t (** [i2e n] returns an expression which evaluates to [n]. *) val fd2e : Fcl_var.Fd.t -> t (** [fd2e v] returns an expression which evaluates to [n] if the variable [v] is instantiated to [n]. *) val e2fd : t -> Fcl_var.Fd.t (** [e2fd e] creates and returns a new variable [v] and posts the constraint [fd2e v =~ e]. *) (** {2 Construction of Arithmetic Expressions} *) (** {b Only} if compiled in bytecode (using [facile.cma]), the arithmetic operators check whether any integer overflow (i.e. the result of an arithmetic operation on integers is less than [min_int] or greater than [max_int]) occurs during constraints internal computations and raise an assert failure. Arithmetic operations are taken modulo {% $2^{31}$%} otherwise (or {% $2^{63}$%} on 64-bit processors, see the OCaml reference manual{% ~\cite{ocaml}%}), thus incomplete failures may happen with native code compiled programs. *) val (+~) : t -> t -> t val (-~) : t -> t -> t val ( *~) : t -> t -> t (** Addition, substraction, multiplication on expressions. *) val ( **~) : t -> int -> t (** Exponentiation of an expression to an integer value. *) val (/~) : t -> t -> t val (%~) : t -> t -> t (** Division and modulo on expressions. The exception [Division_by_zero] is raised whenever the second argument evaluates to 0. *) val abs : t -> t (** Absolute value on expressions. *) val sum : t array -> t val sum_fd : Fcl_var.Fd.t array -> t (** [sum exps] (resp. [sum_fd vars]) returns the sum of all the elements of an array of expressions (resp. variables). Returns an expression that evaluates to 0 if the array is empty. *) val scalprod : int array -> t array -> t val scalprod_fd : int array -> Fcl_var.Fd.t array -> t (** [scalprod coeffs exps] (resp. [scalprod_fd coeffs vars]) returns the scalar product of an array of integers and an array of expressions (resp. variables). Returns an expression that evaluates to 0 if both arrays are empty. Raises [Invalid_argument] if the arrays don't have the same length. *) val prod : t array -> t val prod_fd : Fcl_var.Fd.t array -> t (** [prod exps] (resp. [prod_fd vars]) returns the product of all the elements of an array of expressions (resp. variables). Returns an expression that evaluates to 1 if the array is empty. *) (** {2 Access} *) val fprint : out_channel -> t -> unit (** [fprint chan e] prints expression [e] on channel [chan]. *) val eval : t -> int (** [eval e] returns the integer numerical value of a fully instantiated expression [e]. Raises [Invalid_argument] if [e] is not instantiated. *) val min_of_expr : t -> int val max_of_expr : t -> int (** [min_of_expr e] (resp. [max_of_expr e]) returns the minimal (resp. maximal) possible value of expression [e]. *) val min_max_of_expr : t -> (int * int) (** [min_max_of_expr e] is equivalent to [(min_of_expr e, max_of_expr e)]. *) (** {2 Arithmetic Constraints on Expressions} *) (** FaCiLe processes arithmetic constraints to try to simplify and factorize common subexpressions. Furthermore, auxilliary variables are created to handle non-linear expressions and substituted to the original terms. So printing an arithmetic constraint may produce something quite different from the user's input. *) val (<~) : t -> t -> Fcl_cstr.t val (<=~) : t -> t -> Fcl_cstr.t val (=~) : t -> t -> Fcl_cstr.t val (>=~) : t -> t -> Fcl_cstr.t val (>~) : t -> t -> Fcl_cstr.t val (<>~) : t -> t -> Fcl_cstr.t (** Strictly less, less or equal, equal, greater or equal, strictly greater and different constraints on expressions. *) val shift : Fcl_var.Fd.t -> int -> Fcl_var.Fd.t (** [shift x d] returns a finite domain variable constrained to be equal to [x+d]. *) (** {2 Reification} *) (** The following operators are shortcuts to lighten the writing of reified expressions. They replace the corresponding constraint by an expression equal to a boolean variable that is instantiated to [1] when the constraint is satisfied and to [0] if it is violated. See module [Reify] {% \ref{module:Reify}%}. *) (** [e1 op~~ e2] is equivalent to [fd2e (Reify.boolean (e1 op~ e2))]. *) val (<~~) : t -> t -> t val (<=~~) : t -> t -> t val (=~~) : t -> t -> t val (>=~~) : t -> t -> t val (>~~) : t -> t -> t val (<>~~) : t -> t -> t (** Reified strictly less, less or equal, equal, greater or equal, strictly greater and different. *) (** {2 Boolean sums setting} FaCiLe tries to automatically optimize the processing of boolean (0-1 variables) sums whenever their sizes are large enough. *) val get_boolsum_threshold : unit -> int (** Returns the minimum size for boolean sums optimization. (Default: 5) *) val set_boolsum_threshold : int -> unit (** Set the minimum size for boolean sums optimization. [boolsum_threshold max_int] disables it. *) facile-1.1/src/fcl_conjunto.mli0000644005005300001440000000700710117553006017356 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_conjunto.mli,v 1.9 2004/08/09 14:45:41 barnier Exp $ *) (** Constraints on Finite Sets *) val subset : Fcl_var.SetFd.t -> Fcl_var.SetFd.t -> Fcl_cstr.t (** [subset v1 v2] ensures that [v1] is a subset of [v2]. Not reifiable. *) val cardinal : Fcl_var.SetFd.t -> Fcl_var.Fd.t (** [cardinal v] returns the cardinal (an integer variable) of the set [v]. Not reifiable. *) val smallest : Fcl_var.SetFd.t -> Fcl_var.Fd.t (** [smallest v] returns the smallest element (an integer variable) of [v]. *) val union : Fcl_var.SetFd.t -> Fcl_var.SetFd.t -> Fcl_var.SetFd.t val inter : Fcl_var.SetFd.t -> Fcl_var.SetFd.t -> Fcl_var.SetFd.t (** Operations on sets. *) val all_disjoint : Fcl_var.SetFd.t array -> Fcl_cstr.t (** [all_disjoint vars] ensures that all the set variables of array [vars] are pairwise disjoint. Not reifiable. *) val disjoint : Fcl_var.SetFd.t -> Fcl_var.SetFd.t -> Fcl_cstr.t (** [disjoint v1 v2] defined by [all_disjoint [|v1; v2|]]. Not reifiable. *) val inside : int -> Fcl_var.SetFd.t -> unit val outside : int -> Fcl_var.SetFd.t -> unit (** Basic refinements for labeling. *) val mem : Fcl_var.Fd.t -> Fcl_var.SetFd.t -> Fcl_cstr.t (** [mem x v] states that [x] belongs to [v]. *) val inf_min : Fcl_var.SetFd.t -> Fcl_var.SetFd.t -> Fcl_cstr.t (** [inf_min v1 v2] ensures that the minimal element of [v1] is less than or equal to the minimal element of [v2]. The empty set is smaller than any other set. Useful to break permutation symmetries for a set of set variables. Not reifiable. *) val order : Fcl_var.SetFd.t -> Fcl_var.SetFd.t -> Fcl_cstr.t (** [order v1 v2] ensures that [v1] is less than or equal to [v2] according to [Domain.compare] {% (see~\ref{val:Domain.compare})%}. Caution: [order] builds the cardinal variables of [v1] and [v2]; if they are already available, please use [order_with_card]. Not reifiable. *) val order_with_card : Fcl_var.SetFd.t -> Fcl_var.Fd.t -> Fcl_var.SetFd.t -> Fcl_var.Fd.t -> Fcl_cstr.t (** [order_with_card v1 card1 v2 card2] is equivalent to [order] but the cardinals of the variables must be provided too. Useful to sort a set of variables. *) val member : Fcl_var.SetFd.t -> Fcl_setDomain.elt list -> Fcl_cstr.t (** [member v l] ensures that [v] will have a value in [l]. Not reifiable. *) val sum_weight : Fcl_var.SetFd.t -> (int * int) list -> Fcl_var.Fd.t (** [sum_weight v weights] returns an integer variable equal to the sum of the weights associated with the value in [v]. [weights] must be a list of pairs [value, weight)] that associates a unique weight to each value possibly in [v]. All the weights must be positive integers. *) (**/**) val atmost1 : Fcl_var.SetFd.t array -> int -> unit (* [atmost1 sets card] states that [sets] must have cardinality [card] and must intersect pairwise in atmost one element *) facile-1.1/src/fcl_goals.mli0000644005005300001440000002154610117553006016630 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_goals.mli,v 1.55 2004/07/30 10:37:13 barnier Exp $ *) (** {1 Building and Solving Goals} *) (** This module provides functions and operators to build goals that will control the search, i.e. mainly choose and instantiate variables. *) (** {2 Access} *) type t (** The type of goals. *) val name : t -> string (** [name g] returns the name of the goal [g]. *) val fprint : out_channel -> t -> unit (** [fprint chan g] prints the name of goal [g] on channel [chan]. *) (** {2 Creation} *) val fail : t val success : t (** Failure (resp. success). Neutral element for the disjunction (resp. conjunction) over goals. Could be implemented as [create (fun () -> Stak.fail "fail")] (resp. [create (fun () -> ())]). *) val atomic : ?name:string -> (unit -> unit) -> t (** [atomic ~name:"atomic" f] returns a goal calling function [f]. [f] must take [()] as argument and return [()]. [name] default value is ["atomic"]. *) val create : ?name:string -> ('a -> t) -> 'a -> t (** [create ~name:"create" f a] returns a goal calling [f a]. [f] should return a goal (success to stop). [name] default value is ["create"]. *) val create_rec : ?name:string -> (t -> t) -> t (** [create_rec ~name:"create_rec" f] returns a goal calling [f]. [f] takes the goal itself as argument and should return a goal (success to stop). Useful to write recursive goals. [name] default value is ["create_rec"]. *) (** {2 Operators and Built-in Goals} *) val (&&~) : t -> t -> t val (||~) : t -> t -> t (** Conjunction and disjunction over goals. Note that these two operators do have the {b same priority}. Goals expressions must therefore be carefully parenthesized to produce the expected result. *) val forto : int -> int -> (int -> t) -> t val fordownto : int -> int -> (int -> t) -> t (** [forto min max g] (resp. [fordownto min max g]) returns the conjunctive iteration of goal [g] on increasing (resp. decreasing) integers from [min] (resp. [max]) to [max] (resp. [min]). *) val once : t -> t (** [once g] cuts choice points left on goal [g]. *) val sigma : ?domain:Fcl_domain.t -> (Fcl_var.Fd.t -> t) -> t (** [sigma ~domain:Domain.int fgoal] creates the goal [(fgoal v)] where [v] is a new variable of domain [domain]. Default domain is the largest one. It can be considered as an existential quantification, hence the concrete notation [sigma] of this function (because existential quantification can be seen as a generalized disjunction). *) (** {3 Instantiation of Finite Domain Variables} *) val unify : Fcl_var.Fd.t -> int -> t (** [unify var x] instantiates variable [var] to [x]. *) val indomain : Fcl_var.Fd.t -> t (** Non-deterministic instantiation of a variable, by labeling its domain (in increasing order). *) val instantiate : (Fcl_domain.t -> int) -> Fcl_var.Fd.t -> t (** [instantiate choose var] Non-deterministic instantiation of a variable, by labeling its domain using the value returned by the [choose] function. *) val dichotomic : Fcl_var.Fd.t -> t (** Non-deterministic instantiation of a variable, by dichotomic recursive exploration of its domain. *) (** {3 Instantiation of Set Variables} *) module Conjunto : sig val indomain : Fcl_var.SetFd.t -> t (** Non-deterministic instantiation of set variables ([refine] of Gervet's Conjunto{% ~\cite{conjunto}%}). *) end (** {2 Operations on Array of Variables} *) module Array : sig val foralli : ?select:('a array -> int) -> (int -> 'a -> t) -> 'a array -> t (** [foralli ?select g a] returns the conjunctive iteration of the application of goal [g] on the elements of array [a] and on their indices. The order is computed by the heuristic [?select] which must raise [Not_found] to terminate. Default heuristic is increasing order over indices. *) val forall : ?select:('a array -> int) -> ('a -> t) -> 'a array -> t (** [forall ?select g a] defined by [foralli ?select (fun _i x -> g x) a], i.e. indices of selected elements are not passed to goal [g]. *) val existsi : ?select:('a array -> int) -> (int -> 'a -> t) -> 'a array -> t (** [existsi ?select g a] returns the disjunctive iteration of the application of goal [g] on the elements of array [a] and on their indices. The order is computed by the heuristic [?select] which must raise [Not_found] to terminate. Default heuristic is increasing order over indices. *) val exists : ?select:('a array -> int) -> ('a -> t) -> 'a array -> t (** [exists ?select g a] defined by [existsi ?select (fun _i x -> g x) a], i.e. indices of selected elements are not passed to goal [g]. *) val choose_index : (Fcl_var.Attr.t -> Fcl_var.Attr.t -> bool) -> Fcl_var.Fd.t array -> int (** [choose_index order fds] returns the index of the best (minimun) free (not instantiated) variable in the array [fds] for the criterion [order]. Raises [Not_found] if all variables are bound (instantiated). *) val not_instantiated_fd : Fcl_var.Fd.t array -> int (** [not_instantiated_fd fds] returns the index of one element in [fds] which is not instantiated. Raises [Not_found] if all variables in array [fds] are bound. *) val labeling: Fcl_var.Fd.t array -> t (** Standard labeling, i.e. conjunctive non-deterministic instantiation of an array of variables. Defined as [forall indomain]. *) end (** {2 Operations on List of Variables} *) module List : sig val forall : ?select:('a list -> 'a * 'a list) -> ('a -> t) -> 'a list -> t (** [forall ?select g [x1;x2;...;xn]] is [g x1 &&~ g x2 &&~ ... &&~ g xn], i.e. returns the conjunctive iteration of goal [g] on list [a]. *) val exists : ?select:('a list -> 'a * 'a list) -> ('a -> t) -> 'a list -> t (** [exists ?select g [x1;x2;...;xn]] is [g x1 ||~ g x2 ||~ ... ||~ g xn], i.e. returns the disjunctive iteration of goal [g] on list [a]. *) val member : Fcl_var.Fd.t -> int list -> t (** [member v l] returns the disjunctive iteration of the instantiation of the variable [v] to the values in the integer list [l]. Defined by [fun v l -> exists (fun x -> create (fun () -> Fd.unify v x)) l]. *) val labeling: Fcl_var.Fd.t list -> t (** Standard labeling, i.e. conjunctive non-deterministic instantiation of a list of variables. Defined as [forall indomain]. *) end (** {2 Optimization} *) type bb_mode = Restart | Continue (** Branch and bound mode. *) val minimize : ?step:int -> ?mode:bb_mode -> t -> Fcl_var.Fd.t -> (int -> unit) -> t (** [minimize ~step:1 ~mode:Continue goal cost solution] runs a Branch and Bound algorithm on [goal] for bound [cost], with an improvement of at least [step] between each solution found. With [mode] equal to [Restart], the search restarts from the beginning for every step whereas with mode [Continue] (default) the search simply carries on with an update of the cost constraint. [solution] is called with the instantiation value of [cost] (which must be instantiated by [goal]) as argument each time a solution is found; this function can therefore be used to store (e.g. in a reference) the current solution. Default [step] is 1. [minimize] {b always fails}. *) (** {2 Search Strategy} *) val lds : ?step:int -> t -> t (** [lds ~step:1 g] returns a goal which will iteratively search [g] with increasing limited discrepancy (see {% ~\cite{harvey95.lds}%}) by increment [step]. [step] default value is 1. *) (** {2 Solving} *) val solve : ?control:(int -> unit) -> t -> bool (** [solve ~control:(fun _ -> ()) g] solves the goal [g] and returns a success ([true]) or a failure ([false]). The execution can be precisely controlled with the [control] argument whose single argument is the number of bactracks since the beginning of the search. This function is called after every local failure: - it can raise [Stak.Fail] to force a failure of the search in the current branch (i.e. backtrack); - it can raise any other user exception to stop the search process; - it must return [unit] to continue the search; this is the default behavior. *) (**/**) val reset : unit -> unit (** _Undocumented_ Resets the OR stack (it is not done by solve). *) facile-1.1/src/fcl_fdArray.mli0000644005005300001440000000431310117553006017104 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_fdArray.mli,v 1.15 2003/02/03 15:50:48 brisset Exp $ *) (** Constraints over Arrays of Variables *) val min : Fcl_var.Fd.t array -> Fcl_var.Fd.t val max : Fcl_var.Fd.t array -> Fcl_var.Fd.t (** [min vars] (resp. [max vars]) returns a variable constrained to be equal to the variable that will be instantiated to the minimal (resp. maximal) value among all the variables in the array [vars]. Raises [Invalid_argument] if [vars] is empty. Not reifiable. *) val min_cstr : Fcl_var.Fd.t array -> Fcl_var.Fd.t -> Fcl_cstr.t val max_cstr : Fcl_var.Fd.t array -> Fcl_var.Fd.t -> Fcl_cstr.t (** [min_cstr vars mini] (resp. [max_cstr vars maxi]) returns the constraint [fd2e (min vars) =~ fd2e mini] (resp. [fd2e (max vars) =~ fd2e maxi]). Raises [Invalid_argument] if [vars] is empty. Not reifiable. *) val get : Fcl_var.Fd.t array -> Fcl_var.Fd.t -> Fcl_var.Fd.t (** [get vars index] returns a variable constrained to be equal to [vars.(index)]. Variable [index] is constrained within the range of the valid indices of the array [(0..Array.length vars - 1)]. Raises [Invalid_argument] if [vars] is empty. Not reifiable. *) val get_cstr : Fcl_var.Fd.t array -> Fcl_var.Fd.t -> Fcl_var.Fd.t -> Fcl_cstr.t (** [get_cstr vars index v] returns the constraint [fd2e vars.(index) =~ fd2e v]. Variable [index] is constrained within the range of the valid indices of the array [(0..Array.length vars - 1)]. Raises [Invalid_argument] if [vars] is empty. Not reifiable. *) facile-1.1/src/fcl_gcc.mli0000644005005300001440000000331210117553006016246 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_gcc.mli,v 1.15 2004/07/23 16:37:34 barnier Exp $ *) (** Global Cardinality Constraint *) type level = Basic | Medium | High val cstr : ?level:level -> Fcl_var.Fd.t array -> (Fcl_var.Fd.t * int) array -> Fcl_cstr.t (** [cstr (?level:High) vars distribution] returns a constraint ensuring that for each pair [(c,v)] of cardinal variable [c] and integer value [v] in the list [distribution], [c] variables in the array [vars] will be instantiated to [v], i.e. [card \{vi = v | vi in vars\} = c]. All values [v] in [distribution] must be different otherwise the exception [Invalid_argument] is raised. Three levels of propagation are provided : [Basic] is the quickest, [High] performs the highest amount of propagation. [level] default value is [High]. The constraint posts the redundant constraint stating that the sum of the cardinals is equal to the number of variables. This constraint is also known as the "distribute" constraint. Not reifiable. *) facile-1.1/src/fcl_opti.mli0000644005005300001440000000365210117553006016474 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_opti.mli,v 1.17 2004/07/28 15:52:47 barnier Exp $ *) (* Module [Opti]: Branch and Bound optimization *) type mode = Restart | Continue val minimize : Fcl_goals.t -> Fcl_var.Fd.t -> ?control:(int -> unit) -> ?step:int -> ?mode:mode -> (int -> 'a) -> 'a option (* Deprecated: use [Goals.minimize] instead. [minimize goal cost ?control ?step ?mode solution] runs a Branch and Bound algorithm on [goal] for bound [cost], with an improvment of a least [step] between each solution found. With [mode] equals to [Restart] (default), the search restarts from the beginning for every step while with mode [Continue] the search simply carries on with an update of the cost constraint. [solution] is called with the instantiation value of [cost] as argument each time a solution is found. The result is the value returned by [solution] on the last solution, embedded in an option type ([Some sol]); if no solution is found, [None] is returned. [?control] is passed to [Goals.solve] as its first (optional) argument. Default [control] does nothing (i.e. [fun _ -> ()]). Default [step] is 1. [Invalid_argument] exception is raised if [step] is negative or null. *) facile-1.1/src/fcl_alldiff.mli0000644005005300001440000000261710117553006017122 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_alldiff.mli,v 1.16 2004/08/12 15:22:07 barnier Exp $ *) (** the "All Different" Constraint *) type algo = Lazy | Bin_matching of Fcl_var.Fd.event val cstr : ?algo:algo -> Fcl_var.Fd.t array -> Fcl_cstr.t (** [alldiff (?algo:Lazy) vars] States that the variables of [vars] are different from each other. The optional argument [algo] specifies the level of propagation. [Lazy]: waits for instantiation and removes the corresponding value from other domains. [Bin_matching c]: waits for event [c] (e.g. [Var.Fd.on_refine]) and uses a bin matching algorithm to ensure the constraint is consistent. [algo] default value is [Lazy]. Not reifiable. *) facile-1.1/src/fcl_sorting.mli0000644005005300001440000000333610117553006017205 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_sorting.mli,v 1.11 2003/02/03 15:50:48 brisset Exp $ *) (** Sorting Constraint *) val sort : Fcl_var.Fd.t array -> Fcl_var.Fd.t array (** [sort a] returns an array of variables constrained to be the variables in [a] sorted in increasing order. *) val sortp : Fcl_var.Fd.t array -> Fcl_var.Fd.t array * Fcl_var.Fd.t array (** [sortp a] same as [sort] but returns a couple [(sorted, perm)] where [sorted] is the array of sorted variables and [perm] is an array of variables constrained to be the permutation between [a] and [sorted], i.e. [a.(i) = sorted.(perm.(i))]. *) val cstr : Fcl_var.Fd.t array -> ?p:Fcl_var.Fd.t array option -> Fcl_var.Fd.t array -> Fcl_cstr.t (** [cstr a (?perm:None) sorted] returns the constraint ensuring that [sorted] is the result of sorting array [a] according to the permutation [perm]. [perm] default value is [None], meaning the argument is irrelevant. Raises [Invalid_argument] if arrays have incompatible length. Not reifiable. *) facile-1.1/src/fcl_interval.mli0000644005005300001440000000244010117553006017337 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_interval.mli,v 1.12 2004/07/26 15:55:25 barnier Exp $ *) (** Variable Membership to an Interval *) val is_member : Fcl_var.Fd.t -> int -> int -> Fcl_var.Fd.t (** [is_member v inf sup] returns a boolean variable which will be instantiated to [1] if [v] is in [inf..sup] and to [0] otherwise. *) val cstr : Fcl_var.Fd.t -> int -> int -> Fcl_var.Fd.t -> Fcl_cstr.t (** [cstr v inf sup b] returns a constraint ensuring that the boolean variable [b] is instantiated to [1] if [v] is in [inf..sup] and to [0] otherwise. Not reifiable. *) facile-1.1/src/fcl_genesis.mli0000644005005300001440000000263010117553006017151 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: fcl_genesis.mli,v 1.4 2000/11/15 15:31:48 barnier Exp $ *) (* Module [Genesis]: uniform random binary CSP generation *) val urbcsp : int -> int -> int -> int -> (int * int * (int * int) list) list (* _Undocumented_ [urbcsp nbvar sizedom cstrd tight] return the specifications of a uniform random binary CSP with [nbvar] variables whose domain size is [sizedom], with a constraindness of [cstrd]% (density of the constraint graph) and a tightness (density of each constraint) of [tight]%. The return value is a list of triples [(i, j, l)], [0<=i,j t val unsafe_create : elt list -> t val interval : elt -> elt -> t val int : t val boolean : t val is_empty : t -> bool val size : t -> elt val min : t -> elt val max : t -> elt val min_max : t -> elt * elt val iter : (elt -> unit) -> t -> unit val interval_iter : (elt -> elt -> unit) -> t -> unit val member : elt -> t -> bool val values : t -> elt list val fprint_elt : out_channel -> elt -> unit val fprint : out_channel -> t -> unit val sprint : t -> string val included : t -> t -> bool val add : elt -> t -> t val remove : elt -> t -> t val remove_up : elt -> t -> t val remove_low : elt -> t -> t val remove_low_up : elt -> elt -> t -> t val remove_closed_inter : elt -> elt -> t -> t val intersection : t -> t -> t val union : t -> t -> t val difference : t -> t -> t val diff : t -> t -> t val remove_min : t -> t val minus : t -> t val plus : t -> elt -> t val times : t -> elt -> t val smallest_geq : t -> elt -> elt val greatest_leq : t -> elt -> elt val largest_hole_around : t -> elt -> elt * elt val choose : (elt -> elt -> bool) -> t -> elt val compare : t -> t -> elt val compare_elt : elt -> elt -> elt val disjoint : t -> t -> bool end module SetDomain : sig module S : sig type t val empty : t val is_empty : t -> bool val mem : int -> t -> bool val add : int -> t -> t val singleton : int -> t val remove : int -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val compare : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val iter : (int -> unit) -> t -> unit val cardinal : t -> int val elements : t -> int list val min_elt : t -> int val max_elt : t -> int val choose : t -> int val remove_up : int -> t -> t val remove_low : int -> t -> t end type elt = S.t type t val min : t -> elt val max : t -> elt val min_max : t -> elt * elt val mem : elt -> t -> bool val interval : elt -> elt -> t val fprint_elt : out_channel -> elt -> unit val fprint : out_channel -> t -> unit val included : t -> t -> bool val iter : (elt -> 'a) -> t -> 'a val values : t -> elt list val elt_of_list : int list -> elt end module Stak : sig type level val older : level -> level -> bool val size : unit -> int val depth : unit -> int val level : unit -> level val levels : unit -> level list val nb_choice_points : unit -> int exception Level_not_found of level val cut : level -> unit exception Fail of string val fail : string -> 'a val trail : (unit -> unit) -> unit type 'a ref val ref : 'a -> 'a ref val set : 'a ref -> 'a -> unit val get : 'a ref -> 'a end module Data : sig module Array : sig val set : 'a array -> int -> 'a -> unit end module Hashtbl : sig type ('a, 'b) t val create : int -> ('a, 'b) t val get : ('a, 'b) t -> ('a, 'b) Hashtbl.t val add : ('a, 'b) t -> 'a -> 'b -> unit val find : ('a, 'b) t -> 'a -> 'b val mem : ('a, 'b) t -> 'a -> bool val remove : ('a, 'b) t -> 'a -> unit val replace : ('a, 'b) t -> 'a -> 'b -> unit val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c end end module Cstr : sig exception DontKnow type priority val immediate : priority val normal : priority val later : priority type t val id : t -> int val name : t -> string val priority : t -> priority val fprint : out_channel -> t -> unit val is_solved : t -> bool val create : ?name:string -> ?nb_wakings:int -> ?fprint:(out_channel -> unit) -> ?priority:priority -> ?init:(unit -> unit) -> ?check:(unit -> bool) -> ?not:(unit -> t) -> (int -> bool) -> (t -> unit) -> t val post : t -> unit val init : t -> unit val one : t val zero : t val active_store : unit -> t list end module Var : sig module type ATTR = sig type t type domain type elt type event val dom : t -> domain val on_refine : event val on_subst : event val on_min : event val on_max : event val fprint : out_channel -> t -> unit val min : t -> elt val max : t -> elt val member : t -> elt -> bool val id : t -> int val constraints_number : t -> int val size : t -> int end module Attr : ATTR with type domain = Domain.t and type elt = int module SetAttr : ATTR with type domain = SetDomain.t and type elt = SetDomain.S.t type ('a, 'b) concrete = Unk of 'a | Val of 'b module type BASICFD = sig type t type attr type domain type elt type event val create : ?name:string -> domain -> t val interval : ?name:string -> elt -> elt -> t val array : ?name:string -> int -> elt -> elt -> t array val elt : elt -> t val is_var : t -> bool val is_bound : t -> bool val value : t -> (attr, elt) concrete val min : t -> elt val max : t -> elt val min_max : t -> elt * elt val elt_value : t -> elt val int_value : t -> elt val size : t -> int val member : t -> elt -> bool val id : t -> int val name : t -> string val compare : t -> t -> int val equal : t -> t -> bool val fprint : out_channel -> t -> unit val fprint_array : out_channel -> t array -> unit val unify : t -> elt -> unit val refine : t -> domain -> unit val refine_low : t -> elt -> unit val refine_up : t -> elt -> unit val refine_low_up : t -> elt -> elt -> unit val on_refine : event val on_subst : event val on_min : event val on_max : event val delay : event list -> t -> ?waking_id:int -> Cstr.t -> unit val int : elt -> t val subst : t -> elt -> unit val unify_cstr : t -> elt -> Cstr.t end module type FD = sig include BASICFD val remove : t -> elt -> unit val values : t -> elt list val iter : (elt -> unit) -> t -> unit end module Fd : FD with type domain = Domain.t and type elt = Domain.elt and type attr = Attr.t and type event = Attr.event module SetFd : BASICFD with type domain = SetDomain.t and type elt = SetDomain.S.t and type attr = SetAttr.t and type event = SetAttr.event val delay : Attr.event list -> Fd.t -> ?waking_id:int -> Cstr.t -> unit end module Reify : sig val boolean : ?delay_on_negation:bool -> Cstr.t -> Var.Fd.t val cstr : ?delay_on_negation:bool -> Cstr.t -> Var.Fd.t -> Cstr.t val (||~~) : Cstr.t -> Cstr.t -> Cstr.t val (&&~~) : Cstr.t -> Cstr.t -> Cstr.t val (<=>~~) : Cstr.t -> Cstr.t -> Cstr.t val xor : Cstr.t -> Cstr.t -> Cstr.t val not : Cstr.t -> Cstr.t val (=>~~) : Cstr.t -> Cstr.t -> Cstr.t end module Alldiff : sig type algo = Lazy | Bin_matching of Var.Fd.event val cstr : ?algo:algo -> Var.Fd.t array -> Cstr.t end module Goals : sig type t val name : t -> string val fprint : out_channel -> t -> unit val atomic : ?name:string -> (unit -> unit) -> t val create : ?name:string -> ('a -> t) -> 'a -> t val create_rec : ?name:string -> (t -> t) -> t val fail : t val success : t val ( &&~ ) : t -> t -> t val ( ||~ ) : t -> t -> t val once : t -> t val solve : ?control:(int -> unit) -> t -> bool val lds : ?step:int -> t -> t val unify : Var.Fd.t -> int -> t val indomain : Var.Fd.t -> t val instantiate : (Domain.t -> int) -> Var.Fd.t -> t val dichotomic : Var.Fd.t -> t val forto : int -> int -> (int -> t) -> t val fordownto : int -> int -> (int -> t) -> t module Array : sig val foralli : ?select:('a array -> int) -> (int -> 'a -> t) -> 'a array -> t val forall : ?select:('a array -> int) -> ('a -> t) -> 'a array -> t val existsi : ?select:('a array -> int) -> (int -> 'a -> t) -> 'a array -> t val exists : ?select:('a array -> int) -> ('a -> t) -> 'a array -> t val choose_index : (Var.Attr.t -> Var.Attr.t -> bool) -> Var.Fd.t array -> int val not_instantiated_fd : Var.Fd.t array -> int val labeling : Var.Fd.t array -> t end module GlArray : (* Deprecated *) sig val iter_h : ('a array -> int) -> ('a -> t) -> 'a array -> t val iter_hi : ('a array -> int) -> (int -> 'a -> t) -> 'a array -> t val iter : ('a -> t) -> 'a array -> t val iteri : (int -> 'a -> t) -> 'a array -> t val iter2 : ('a -> 'b -> t) -> 'a array -> 'b array -> t val labeling : Var.Fd.t array -> t val choose_index : (Var.Attr.t -> Var.Attr.t -> bool) -> Var.Fd.t array -> int val not_instantiated_fd : Var.Fd.t array -> int end module List : sig val forall : ?select:('a list -> 'a * 'a list) -> ('a -> t) -> 'a list -> t val exists : ?select:('a list -> 'a * 'a list) -> ('a -> t) -> 'a list -> t val member : Var.Fd.t -> int list -> t val labeling : Var.Fd.t list -> t end module GlList : (* deprecated *) sig val iter : ('a -> t) -> 'a list -> t val labeling : Var.Fd.t list -> t val member : Var.Fd.t -> int list -> t val iter_h : ('a list -> 'a * 'a list) -> ('a -> t) -> 'a list -> t end type bb_mode = Restart | Continue val minimize : ?step:int -> ?mode:bb_mode -> t -> Var.Fd.t -> (int -> unit) -> t val sigma : ?domain:Domain.t -> (Var.Fd.t -> t) -> t module Conjunto : sig val indomain : Var.SetFd.t -> t end end module Sorting : sig val sort : Var.Fd.t array -> Var.Fd.t array val sortp : Var.Fd.t array -> Var.Fd.t array * Var.Fd.t array val cstr : Var.Fd.t array -> ?p:Var.Fd.t array option -> Var.Fd.t array -> Cstr.t end module Boolean : sig val cstr : Var.Fd.t array -> Var.Fd.t -> Cstr.t val sum : Var.Fd.t array -> Var.Fd.t end module Expr : sig type t val fprint : out_channel -> t -> unit val eval : t -> int val min_of_expr : t -> int val max_of_expr : t -> int val min_max_of_expr : t -> (int * int) end module Arith : sig type t val i2e : int -> t val fd2e : Var.Fd.t -> t val ( +~ ) : t -> t -> t val ( *~ ) : t -> t -> t val ( -~ ) : t -> t -> t val ( /~ ) : t -> t -> t val ( **~ ) : t -> int -> t val ( %~ ) : t -> t -> t val abs : t -> t val sum : t array -> t val sum_fd : Var.Fd.t array -> t val scalprod : int array -> t array -> t val scalprod_fd : int array -> Var.Fd.t array -> t val prod : t array -> t val prod_fd : Var.Fd.t array -> t val fprint : out_channel -> t -> unit val eval : t -> int val min_of_expr : t -> int val max_of_expr : t -> int val min_max_of_expr : t -> (int * int) val ( <=~ ) : t -> t -> Cstr.t val ( <~ ) : t -> t -> Cstr.t val ( >~ ) : t -> t -> Cstr.t val ( =~ ) : t -> t -> Cstr.t val ( <>~ ) : t -> t -> Cstr.t val ( >=~ ) : t -> t -> Cstr.t val e2fd : t -> Var.Fd.t val ( <=~~ ) : t -> t -> t val ( <~~ ) : t -> t -> t val ( >~~ ) : t -> t -> t val ( =~~ ) : t -> t -> t val ( <>~~ ) : t -> t -> t val ( >=~~ ) : t -> t -> t val shift : Var.Fd.t -> int -> Var.Fd.t val get_boolsum_threshold : unit -> int val set_boolsum_threshold : int -> unit end module Invariant : sig type ('a, 'b) t type setable type unsetable type 'a setable_t = ('a, setable) t type 'a unsetable_t = ('a, unsetable) t val create : ?name:string -> 'a -> 'a setable_t val constant : ?name:string -> 'a -> 'a unsetable_t val set : 'a setable_t -> 'a -> unit val get : ('a, 'b) t -> 'a val id : ('a, 'b) t -> int val name : ('a, 'b) t -> string val fprint : out_channel -> ?printer:(out_channel -> 'a -> unit) -> ('a, 'b) t -> unit val unary : ?name:string -> ('a -> 'b) -> (('a, 'c) t -> 'b unsetable_t) val binary : ?name:string -> ('a -> 'b -> 'c) -> (('a, 'd) t -> ('b, 'e) t -> 'c unsetable_t) val ternary : ?name:string -> ('a -> 'b -> 'c -> 'd) -> (('a, 'e) t -> ('b, 'f) t -> ('c, 'g) t -> 'd unsetable_t) val sum : (int, 'a) t array -> int unsetable_t val prod : (int, 'a) t array -> int unsetable_t module Array : sig val get : ('a, 'b) t array -> (int, 'c) t -> 'a unsetable_t val argmin : ('a, 'b) t array -> ('a -> 'c) -> int unsetable_t val min : ('a, 'b) t array -> ('a -> 'c) -> 'a unsetable_t end module type FD = sig type fd type elt val min : fd -> elt unsetable_t val max : fd -> elt unsetable_t val size : fd -> int unsetable_t val is_var : fd -> bool unsetable_t val unary : ?name:string -> (fd -> 'a) -> fd -> 'a unsetable_t end module Fd : FD with type fd = Var.Fd.t and type elt = Var.Fd.elt module SetFd : FD with type fd = Var.SetFd.t and type elt = Var.SetFd.elt end module Interval : sig val is_member : Var.Fd.t -> int -> int -> Var.Fd.t val cstr : Var.Fd.t -> int -> int -> Var.Fd.t -> Cstr.t end module FdArray : sig val min : Var.Fd.t array -> Var.Fd.t val min_cstr : Var.Fd.t array -> Var.Fd.t -> Cstr.t val max : Var.Fd.t array -> Var.Fd.t val max_cstr : Var.Fd.t array -> Var.Fd.t -> Cstr.t val get : Var.Fd.t array -> Var.Fd.t -> Var.Fd.t val get_cstr : Var.Fd.t array -> Var.Fd.t -> Var.Fd.t -> Cstr.t end module Gcc : sig type level = Basic | Medium | High val cstr : ?level:level -> Var.Fd.t array -> (Var.Fd.t * int) array -> Cstr.t end module Opti : sig type mode = Restart | Continue val minimize : Goals.t -> Var.Fd.t -> ?control:(int -> unit) -> ?step:int -> ?mode:mode -> (int -> 'a) -> 'a option end module Conjunto : sig val subset : Var.SetFd.t -> Var.SetFd.t -> Cstr.t val cardinal : Var.SetFd.t -> Var.Fd.t val smallest : Var.SetFd.t -> Var.Fd.t val union : Var.SetFd.t -> Var.SetFd.t -> Var.SetFd.t val inter : Var.SetFd.t -> Var.SetFd.t -> Var.SetFd.t val all_disjoint : Var.SetFd.t array -> Cstr.t val disjoint : Var.SetFd.t -> Var.SetFd.t -> Cstr.t val inside : int -> Var.SetFd.t -> unit val outside : int -> Var.SetFd.t -> unit val inf_min : Var.SetFd.t -> Var.SetFd.t -> Cstr.t val order : Var.SetFd.t -> Var.SetFd.t -> Cstr.t val order_with_card : Var.SetFd.t -> Var.Fd.t -> Var.SetFd.t -> Var.Fd.t -> Cstr.t val member : Var.SetFd.t -> SetDomain.elt list -> Cstr.t val mem : Var.Fd.t -> Var.SetFd.t -> Cstr.t val sum_weight : Var.SetFd.t -> (int * int) list -> Var.Fd.t val atmost1 : Var.SetFd.t array -> int -> unit end module Easy : sig val i2e : int -> Arith.t val fd2e : Var.Fd.t -> Arith.t val ( +~ ) : Arith.t -> Arith.t -> Arith.t val ( *~ ) : Arith.t -> Arith.t -> Arith.t val ( -~ ) : Arith.t -> Arith.t -> Arith.t val ( /~ ) : Arith.t -> Arith.t -> Arith.t val ( **~ ) : Arith.t -> int -> Arith.t val ( %~ ) : Arith.t -> Arith.t -> Arith.t val ( <=~ ) : Arith.t -> Arith.t -> Cstr.t val ( <~ ) : Arith.t -> Arith.t -> Cstr.t val ( >~ ) : Arith.t -> Arith.t -> Cstr.t val ( =~ ) : Arith.t -> Arith.t -> Cstr.t val ( <>~ ) : Arith.t -> Arith.t -> Cstr.t val ( >=~ ) : Arith.t -> Arith.t -> Cstr.t val ( <=~~ ) : Arith.t -> Arith.t -> Arith.t val ( <~~ ) : Arith.t -> Arith.t -> Arith.t val ( >~~ ) : Arith.t -> Arith.t -> Arith.t val ( =~~ ) : Arith.t -> Arith.t -> Arith.t val ( <>~~ ) : Arith.t -> Arith.t -> Arith.t val ( >=~~ ) : Arith.t -> Arith.t -> Arith.t val (&&~~) : Cstr.t -> Cstr.t -> Cstr.t val (||~~) : Cstr.t -> Cstr.t -> Cstr.t val (=>~~) : Cstr.t -> Cstr.t -> Cstr.t val (<=>~~) : Cstr.t -> Cstr.t -> Cstr.t val ( &&~ ) : Goals.t -> Goals.t -> Goals.t val ( ||~ ) : Goals.t -> Goals.t -> Goals.t module Fd : Var.FD with type t = Var.Fd.t and type domain = Domain.t and type elt = Domain.elt and type attr = Var.Attr.t and type event = Var.Attr.event type ('a, 'b) concrete' = ('a, 'b) Var.concrete = Unk of 'a | Val of 'b type concrete_fd = (Fd.attr, Fd.elt) concrete' end facile-1.1/examples/0000755005005300001440000000000010117553006015213 5ustar barnierusers00000000000000facile-1.1/examples/Makefile0000644005005300001440000000174710117553006016664 0ustar barnierusers00000000000000# $Id: Makefile.facile,v 1.2 2003/08/06 14:01:31 brisset Exp $ # Generic Makefile for single files using FaCiLe. Allow to produce # file.out (ocamlc) and file.opt (ocamlopt) from file.ml while linking # with the FaCiLe library FACILEDIR= +facile INCLUDES= -I $(FACILEDIR) OCAMLC= ocamlc -g $(INCLUDES) OCAMLMLI= ocamlc $(INCLUDES) OCAMLOPT= ocamlopt $(INCLUDES) OCAMLDEP= ocamldep $(INCLUDES) .SUFFIXES: .SUFFIXES: .ml .mli .mly .mll .cmi .cmo .cmx .out .opt .p.cmx .popt .ml.cmo : $(OCAMLC) -c $< .mli.cmi : $(OCAMLMLI) -c $< .ml.cmx : $(OCAMLOPT) -c $< # To produce profiled objects .ml.p.cmx : $(OCAMLOPT) -p -c $< mv $*.cmx $@ mv $*.o $*.p.o .cmo.out : $(OCAMLC) -o $@ facile.cma $< # To produce profiled binaries .p.cmx.popt : $(OCAMLOPT) -p -o $@ facile.p.cmxa $< .cmx.opt : $(OCAMLOPT) -o $@ facile.cmxa $< .mly.ml : ocamlyacc $< .mll.ml : ocamllex $< clean: \rm -f *.cmo *.cmi *.cmx *.o *~ *.opt *.out .depend *.popt .depend: $(OCAMLDEP) *.mli *.ml > $@ include .depend facile-1.1/examples/queens.ml0000644005005300001440000000460110117553006017046 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: queens.ml,v 1.22 2004/07/01 09:29:18 barnier Exp $ *) open Facile open Easy (* Print a solution *) let print queens = let n = Array.length queens in if n <= 10 then (* Pretty printing *) for i = 0 to n - 1 do let c = Fd.int_value queens.(i) in (* queens.(i) is bound *) for j = 0 to n - 1 do Printf.printf "%c " (if j = c then '*' else '-') done; print_newline () done else (* Short print *) for i = 0 to n-1 do Printf.printf "line %d : col %a\n" i Fd.fprint queens.(i) done; flush stdout;; (* Solve the n-queens problem *) let queens n = (* n decision variables in 0..n-1 *) let queens = Fd.array n 0 (n-1) in (* 2n auxiliary variables for diagonals *) let shift op = Array.mapi (fun i qi -> Arith.e2fd (op (fd2e qi) (i2e i))) queens in let diag1 = shift (+~) and diag2 = shift (-~) in (* Global constraints *) Cstr.post (Alldiff.cstr queens); Cstr.post (Alldiff.cstr diag1); Cstr.post (Alldiff.cstr diag2); (* Heuristic Min Size, Min Value *) let h a = (Var.Attr.size a, Var.Attr.min a) in let min_min = Goals.Array.choose_index (fun a1 a2 -> h a1 < h a2) in (* Search goal *) let labeling = Goals.Array.forall ~select:min_min Goals.indomain in (* Solve *) let bt = ref 0 in if Goals.solve ~control:(fun b -> bt := b) (labeling queens) then begin Printf.printf "%d backtracks\n" !bt; print queens end else prerr_endline "No solution" let _ = if Array.length Sys.argv <> 2 then raise (Failure "Usage: queens "); Gc.set ({(Gc.get ()) with Gc.space_overhead = 500}); (* May help except with an underRAMed system *) queens (int_of_string Sys.argv.(1));; facile-1.1/examples/golf.ml0000644005005300001440000001057010117553006016477 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: golf.ml,v 1.21 2003/07/18 14:55:43 brisset Exp $ *) (* A Golf Tournament (from http://www.icparc.ic.ac.uk/~cg6/conjunto.html) There are 32 golfers, who play individually but in groups of 4, called foursomes. The tournament is organized in weeks. Each week a new set of foursomes has to be computed such that each person only golfs with the same person once. So if two golfers have played each other in any previous week they should not play each other in the coming weeks. The question is: "how many weeks can we ensure this before players start to play each other a second time ?" The formulation is generalized to any number of golfers, groups and weeks. *) open Facile open Easy (* Two modes using the Global Cardinality Constraint or the Sort constraint *) type mode = Gcc | Sort let mode_of = function "gcc" -> Gcc | "sort" -> Sort | _ -> failwith "Unknown mode";; let go nb_groups size_group nb_weeks mode = let nb_golfers = nb_groups * size_group in (* An array of nb_weeks*nb_golfers decision variables to choose the group (in 0..nb_groups-1) of every golfer every week *) let vars = Array.init nb_weeks (fun _ -> Fd.array nb_golfers 0 (nb_groups-1)) in (* Constraints *) (* For each week, exactly size_group golfers in each group: *) begin match mode with Gcc -> (* Using a Global Cardinality Constraint *) let cards_values = Array.init nb_groups (fun i -> (Fd.int size_group, i)) in for w = 0 to nb_weeks - 1 do Cstr.post (Gcc.cstr vars.(w) cards_values) done | Sort -> (* Using a Sorting constraint: For each week the sorted array of groups is equal to [|0;0;0;0;1;1;1;1;2;2;2;2;....|] *) let sorted = Array.init nb_golfers (fun i -> Fd.int (i / size_group)) in for j = 0 to nb_weeks - 1 do Cstr.post (Sorting.cstr vars.(j) sorted) done end; (* Two golfers do not play in the same group more than once *) for g1 = 0 to nb_golfers - 1 do (* for each pair of golfers *) for g2 = g1+1 to nb_golfers - 1 do let g1_with_g2 = Array.init nb_weeks (fun w -> Arith.e2fd (fd2e vars.(w).(g1) =~~ fd2e vars.(w).(g2))) in Cstr.post (Arith.sum_fd g1_with_g2 <=~ i2e 1) done done; (* Breaking the symmetries 0 always in the first group, 1 in a group less than 1, ... First week (0) a priori chosen *) for w = 0 to nb_weeks - 1 do for g = 0 to nb_groups - 1 do Cstr.post (fd2e vars.(w).(g) <=~ i2e g) done done; for g = 0 to nb_golfers - 1 do Cstr.post (fd2e vars.(0).(g) =~ i2e (g / size_group)) done; (* Seach goal: Choose the groups for the first golfer, then for second one, ... *) let goal = Goals.forto 0 (nb_golfers-1) (fun g -> Goals.forto 0 (nb_weeks-1) (fun w -> Goals.indomain vars.(w).(g))) in (* Solving *) let nb_backtracks = ref 0 and start = Sys.time () in if Goals.solve ~control:(fun n -> nb_backtracks := n) goal then begin Printf.printf "Found a solution in %.2fs\n" (Sys.time () -. start); for w = 0 to nb_weeks - 1 do for g = 0 to nb_groups do for p = 0 to nb_golfers - 1 do if Fd.int_value vars.(w).(p) = g then Printf.printf "%2d " p done; print_string " "; done; print_newline () done end else prerr_endline "No solution"; Printf.printf "with %d fails\n" !nb_backtracks;; let _ = if Array.length Sys.argv < 5 then prerr_endline "Usage: golf (gcc or sort)" else let nb_groups = int_of_string Sys.argv.(1) and size_group = int_of_string Sys.argv.(2) and nb_weeks = int_of_string Sys.argv.(3) and mode = mode_of Sys.argv.(4) in go nb_groups size_group nb_weeks mode;; facile-1.1/examples/magic.ml0000644005005300001440000000406110117553006016626 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: magic.ml,v 1.9 2001/06/01 14:13:09 barnier Exp $ *) (* Magic Sequence A magic sequence is a sequence of N values (x0, x1, , xN-1) such that 0 will appear in the sequence x0 times, 1 will appear x1 times,..., and N-1 will appear in the sequence xN-1 times. For example, for N=3, the following sequence is a solution: (1, 2, 1, 0). That is, 0 is present once, 1 is present twice, 2 is present once, and 3 is not present. *) open Facile open Easy let magic n = (* n variables *) let x = Fd.array n 0 (n-1) in (* Constraint: cardinality constraint with x as variables and cardinals *) let card_vals = Array.mapi (fun i x -> (x, i)) x in Cstr.post (Gcc.cstr ~level:Gcc.Medium x card_vals); (* Redundant constraints *) let vals = Array.init n (fun i -> i) in Cstr.post (Arith.scalprod_fd vals x =~ i2e n); (* Search goal: first fail with min domain size *) let min_size = Goals.Array.choose_index (fun a1 a2 -> Var.Attr.size a1 < Var.Attr.size a2) in let goal = Goals.Array.forall ~select:min_size Goals.indomain x in (* Search *) if Goals.solve goal then begin Array.iter (fun v -> Printf.printf "%a " Fd.fprint v) x; print_newline () end else prerr_endline "No solution";; let _ = if Array.length Sys.argv < 2 then prerr_endline "Usage: magic " else magic (int_of_string Sys.argv.(1));; facile-1.1/examples/marriage.ml0000644005005300001440000000572010117553006017340 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: marriage.ml,v 1.5 2004/09/07 13:40:26 barnier Exp $ *) (* From ILOG stablema.cpp, OPL marriage.mod *) open Printf open Facile open Easy let n = 5 let richard = 0 and james = 1 and john = 2 and hugh = 3 and greg = 4 let men = [| richard ; james ; john ; hugh ; greg |] let helen = 0 and tracy = 1 and linda = 2 and sally = 3 and wanda = 4 let women = [| helen ; tracy ; linda ; sally ; wanda |] let rankWomen = [|[|1; 2; 4; 3; 5 |]; [|3; 5; 1; 2; 4 |]; [|5; 4; 2; 1; 3 |]; [|1; 3; 5; 4; 2 |]; [|4; 2; 3; 5; 1 |] |];; let rankMen = [| [|5; 1; 2; 4; 3 |]; [|4; 1; 3; 2; 5 |]; [|5; 3; 2; 4; 1 |]; [|1; 5; 4; 3; 2 |]; [|4; 3; 2; 1; 5 |] |];; let ai2e = Array.map i2e let go () = let one_wife _ = Fd.create (Domain.interval 0 (Array.length women - 1)) and one_husband _ = Fd.create (Domain.interval 0 (Array.length men - 1)) in let wife = Fd.array n 0 (n-1) and husband = Fd.array n 0 (n-1) in let wifee = Array.map fd2e wife and husbande = Array.map fd2e husband in Array.iter (fun m -> Cstr.post (fd2e (FdArray.get husband (Array.get wife m)) =~ i2e m)) men; Array.iter (fun w -> Cstr.post (fd2e (FdArray.get wife (Array.get husband w)) =~ i2e w)) women; let array_fd = Array.map Fd.int in let rankMen_wife = Array.map (fun m -> FdArray.get (array_fd rankMen.(m)) wife.(m)) men and rankWomen_husband = Array.map (fun w -> FdArray.get (array_fd rankWomen.(w)) husband.(w)) women in Array.iter (fun m -> Array.iter (fun w -> let rankMen_m_w = i2e rankMen.(m).(w) and rankMen_wife_m = fd2e rankMen_wife.(m) and rankWomen_husband_w = fd2e rankWomen_husband.(w) and rankWomen_w_m = i2e rankWomen.(w).(m) in Cstr.post (fd2e (Reify.boolean (rankMen_m_w <~ rankMen_wife_m)) <=~ fd2e (Reify.boolean (rankWomen_husband_w <~ rankWomen_w_m ))); Cstr.post (fd2e (Reify.boolean (rankWomen_w_m <~ rankWomen_husband_w)) <=~ fd2e (Reify.boolean (rankMen_wife_m <~ rankMen_m_w)))) women) men; let goal = Goals.Array.labeling wife &&~ Goals.Array.labeling husband in if Goals.solve goal then begin printf "wifes: "; Array.iter (fun w -> printf "%a " Fd.fprint w) wife; print_newline() end else prerr_endline "No" let _ = go ();; facile-1.1/examples/tiles.ml0000644005005300001440000000637510117553006016700 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: tiles.ml,v 1.7 2004/09/07 13:52:28 barnier Exp $ *) (* How to cover a square with square tiles of the given sizes From http://www.icparc.ic.ac.uk/eclipse/examples/square_tiling.pl.txt 4 data samples numbered 0 to 3 to pass as argument on the command line *) open Facile open Easy (* [| ( [|Tile sizes|], Big square size) |] *) let data = [| ([|2; 1; 1; 1; 1; 1|], 3); ([|10; 9; 7; 6; 4; 4; 3; 3; 3; 3; 3; 2; 2; 2; 1; 1; 1; 1; 1; 1|], 19); ([|50; 42; 37; 35; 33; 29; 27; 25; 24; 19; 18; 17; 16; 15; 11; 9; 8; 7; 6; 4; 2|], 112); ([|81; 64; 56; 55; 51; 43; 39; 38; 35; 33; 31; 30; 29; 20; 18; 16; 14; 9; 8; 5; 4; 3; 2; 1|], 175); |] let tile (sizes, size) = let n = Array.length sizes in let var i = Fd.interval 0 (size - sizes.(i)) in let xs = Array.init n var and ys = Array.init n var in let no_overlap i j = Cstr.post ((fd2e xs.(j) +~ i2e sizes.(j) <=~ fd2e xs.(i)) (* j on left of i *) ||~~ (fd2e xs.(j) >=~ fd2e xs.(i) +~ i2e sizes.(i)) (* j on right of i *) ||~~ (fd2e ys.(j) +~ i2e sizes.(j) <=~ fd2e ys.(i)) (* j below i *) ||~~ (fd2e ys.(j) >=~ fd2e ys.(i) +~ i2e sizes.(i))) in (* j above i *) for i = 0 to n-1 do (* For all squares *) for j = i+1 to n-1 do (* For all ordered pairs of squares *) no_overlap i j done done; (* Redundant capacity constraints *) for i = 0 to size-1 do (* For all verticals and horizontals *) let full_line xy = let intersections = Array.init n (fun j -> Interval.is_member xy.(j) (i-sizes.(j)+1) i) in Cstr.post (Arith.scalprod_fd sizes intersections =~ i2e size) in full_line xs; full_line ys done; let min_min = (* minimum min strategy *) Goals.Array.choose_index (fun a1 a2 -> Var.Attr.min a1 < Var.Attr.min a2) in let try_min v = (* Instantiates to min or remove min *) match Fd.value v with Unk attr -> Goals.unify v (Var.Attr.min attr) ||~ Goals.atomic (fun () -> Fd.refine v (Domain.remove_min (Var.Attr.dom attr))) | _ -> failwith "Tiles.try_min: v should be bound" in let goal = Goals.Array.forall ~select:min_min try_min xs &&~ Goals.Array.forall ~select:min_min try_min ys in if Goals.solve goal then begin Printf.printf "size: x y\n\n"; for i = 0 to n - 1 do Printf.printf "%d: %a %a\n" sizes.(i) Fd.fprint xs.(i) Fd.fprint ys.(i) done end else Printf.printf "No solution\n";; let _ = (* Gc.set {(Gc.get ()) with Gc.space_overhead = 600}; (* makes a big difference... *) *) tile data.(int_of_string Sys.argv.(1)) facile-1.1/examples/golomb.ml0000644005005300001440000000616610117553006017035 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: golomb.ml,v 1.16 2004/09/07 13:40:47 barnier Exp $ *) (* Golomb Ruler A Golomb ruler is a set of integers (marks) a(1) < ... < a(k) such that all the differences a(i)-a(j) (i > j) are distinct. Clearly we may assume a(1)=0. Then a(k) is the length of the Golomb ruler. For a given number of marks, k, we are interested in finding the shortest Golomb rulers. Such rulers are called optimal. *) open Facile open Easy let golomb n = (* Tick marks between 0 and 2^n (bound obtained with a (very) greedy method) *) let n2 = (truncate (2.**float n)) and dummy = Fd.int 0 in let ticks = Fd.array n 0 n2 and dists = Array.create ((n*(n-1))/2) dummy in (* Constraints *) Fd.unify ticks.(0) 0; (* First tick at the start of the ruler *) let cpt = ref 0 in (* Compute all the distances *) for i = 0 to n - 1 do (* Ticks are ordered *) if i < n-1 then Cstr.post (fd2e ticks.(i+1) >~ fd2e ticks.(i)); for j = i+1 to n - 1 do dists.(!cpt) <- Arith.e2fd (fd2e ticks.(j) -~ fd2e ticks.(i)); Cstr.post (fd2e dists.(!cpt) >~ i2e 0); incr cpt done done; (* All the distances are distinct *) (***) Cstr.post (Alldiff.cstr ~algo:(Alldiff.Bin_matching Var.Fd.on_subst) dists); (*** for i = 0 to Array.length dists - 1 do for j = i+1 to Array.length dists - 1 do Cstr.post (fd2e dists.(i) <>~ fd2e dists.(j)) done done; ***) (* Breaking the symmetry *) Cstr.post (fd2e dists.(!cpt - 1) >~ fd2e dists.(0)); (* Search Goal *) let goal = Goals.Array.labeling ticks in (* Search fot the optimal solution: minimal last tick *) let bt = ref 0 in ignore (Goals.solve ~control:(fun b -> bt := b) (Goals.minimize goal ticks.(n-1) (fun _cost -> Printf.printf "Found better: "; Array.iter (fun t -> Printf.printf "%a " Fd.fprint t) ticks; Printf.printf "(%d backtracks)" !bt; print_newline ()))); Printf.printf "%d backtracks\n" !bt let _ = Gc.set ({(Gc.get ()) with Gc.space_overhead = 100}); if Array.length Sys.argv < 2 then prerr_endline "Usage: golomb " else golomb (int_of_string Sys.argv.(1));; (* Reveil sur inst Reveil sur ref Alldiff basique n^2 <> CPU Btks CPU Btks CPU Backtracks CPU Backtracks 7 0.09 236 0.09 181 0.1 357 0.3 357 8 0.84 1669 0.72 1131 1.1 2740 4.4 2740 9 7.56 9919 5.8 5915 12.32 19452 56 19452 10 69.8 62474 50.6 34254 121 140752 708 140752 *) facile-1.1/examples/coins.ml0000644005005300001440000000425310117553006016664 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: coins.ml,v 1.13 2004/09/07 09:24:43 barnier Exp $ *) (* Which coins do you need to give back change for any amount between 0 and [max], using coins from [values]. *) open Facile open Easy let coins values max = let domains = Array.map (fun v -> Domain.interval 0 (max / v)) values in let gen_vars () = Array.map (fun d -> Fd.create d) domains in (* The solution *) let nb_min_coins = gen_vars () in let mat = Array.init max (fun i -> (* coins needed to give back i *) let nb_coins = gen_vars () in Cstr.post (Arith.scalprod_fd values nb_coins =~ i2e i); for j = 0 to Array.length nb_coins - 1 do let nbpj = nb_coins.(j) and nbmpj = nb_min_coins.(j) in Cstr.post (fd2e nbpj <=~ fd2e nbmpj) done; nb_coins) in (* Cost: nb of coins *) let cost = Arith.e2fd (Arith.sum_fd nb_min_coins) in let cost = Fd.interval 0 max in Cstr.post (fd2e cost =~ Arith.sum_fd nb_min_coins); (* Search goal *) let goal = Goals.Array.forall Goals.Array.labeling mat &&~ Goals.Array.labeling nb_min_coins in (* Searching for the best solution *) let best = ref [||] in ignore (Goals.solve (Goals.minimize goal cost (fun c -> Printf.printf "%d found\n" c; flush stdout; best := Array.map Fd.int_value nb_min_coins))); match !best with [||] -> prerr_endline "No solution" | sol -> Array.iter (fun x -> Printf.printf "%d " x) sol; print_newline ();; let _ = coins [|1;2;5;10;20|] 100;; facile-1.1/examples/prolog.ml0000644005005300001440000001002310117553006017043 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: prolog.ml,v 1.8 2001/06/15 10:27:27 barnier Exp $ *) (* FaCiLe as a Prolog interpreter: the family tree In this example, we write the classic goals parent, grandparent and ancestor for the following family tree: sam | jim + lucy | fred + lynn | ann Then we search all the solutions for various questions, using a "findall" goal that builds a list of all the possible values for a given variable such that a given goal succeeds. This example was inspired by Mattias Waldau and translated from the following Prolog source: father(ann, fred). father(fred, jim). father(jim, sam). mother(ann, lynn). mother(fred, lucy). parent(X,Y) :- mother(X,Y). parent(X,Y) :- father(X,Y). grandparent(X,Y) :- parent(X,Z), parent(Z,Y). ancestor(X,Y) :- parent(X,Y). ancestor(X,Y) :- parent(X,Z), ancestor(Z,Y). *) open Facile open Easy let ann = 0 and fred = 1 and jim = 2 and sam = 3 and lynn = 4 and lucy = 5 let name_of = function 0 -> "Ann" | 1 -> "Fred" | 2 -> "Jim" | 3 -> "Sam" | 4 -> "Lynn" | 5 -> "Lucy" | _ -> invalid_arg "name_of" let family_dom = Domain.create [ann; fred; jim; sam; lynn; lucy] (* child first, parent second *) let fathers = [(ann, fred); (fred, jim); (jim, sam)] let mothers = [(ann, lynn); (fred, lucy)] (* [father x y] [x]: child; [y]: father*) let father x y = Goals.List.exists (fun (c, f) -> Goals.unify x c &&~ Goals.unify y f) fathers (* [mother x y] [x]: child; [y]: mother] *) let mother x y = Goals.List.exists (fun (c, m) -> Goals.unify x c &&~ Goals.unify y m) mothers let parent x y = father x y ||~ mother x y (* We use the existential quantifier [Goals.sigma] to hide the creation of an intermediate variable. However, we provide its domain [family_dom] which is an optional argument (if omitted, the domain is the largest one). *) let grandparent x y = Goals.sigma ~domain:family_dom (fun z -> parent x z &&~ parent z y) (* Recursive goal implemented from a recursive function using Goals.create *) let rec ancestor x y = Goals.create (fun () -> parent x y ||~ (Goals.sigma ~domain:family_dom (fun z -> parent x z &&~ ancestor z y))) () (* [val findall : (Fd.t -> Goals.t) -> int list] [findall g] returns all the solutions of variables [y] such that the goal [g y] succeeds. *) let findall g = (* The solutions are stored in a list. *) let sol = ref [] in let store v = Goals.atomic (fun () -> sol := Fd.int_value v :: !sol) in let goal = Goals.sigma ~domain:family_dom (fun y -> g y &&~ store y &&~ Goals.fail) ||~ Goals.success in if Goals.solve goal then !sol else failwith "Unexpected failure" let all_ancestors x = findall (fun y -> ancestor x y) let all_parents x = findall (fun y -> parent x y) let all_grandchildren y = findall (fun x -> grandparent x y) let _ = let print_list l = List.iter (fun a -> Printf.printf "%s " (name_of a)) l; print_newline () in (* All the ancestors of Ann *) let ancestors = all_ancestors (Fd.int ann) in print_list ancestors; (* All the parents of Jim and Ann *) let parents = all_parents (Fd.create (Domain.create [jim; ann])) in print_list parents; (* All the grandchildren of Sam *) let grandchildren = all_grandchildren (Fd.int sam) in print_list grandchildren facile-1.1/examples/seven_eleven.ml0000644005005300001440000000307410117553006020227 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: seven_eleven.ml,v 1.4 2004/09/07 13:41:28 barnier Exp $ *) (* Arithmetic puzzle 711 Find the numbers a, b, c and d such that a+b+c+d = 711 and a*b*c*d = 711000000 This example was suggested by Mattias Waldau. *) open Facile open Easy let seven_eleven () = let a = Fd.interval 0 330 and b = Fd.interval 0 160 and c = Fd.interval 0 140 and d = Fd.interval 0 140 in (* max a * max b * max c * max d should be less than max_int*) assert (Fd.max a * Fd.max b * Fd.max c * Fd.max d <= max_int); Cstr.post (fd2e a +~ fd2e b +~ fd2e c +~ fd2e d =~ i2e 711); Cstr.post (fd2e a *~ fd2e b *~ fd2e c *~ fd2e d =~ i2e 711000000); let numbers = [|a;b;c;d|] in if Goals.solve (Goals.Array.labeling numbers) then Printf.printf "%a\n" Fd.fprint_array numbers else prerr_endline "No solution" let _ = seven_eleven () facile-1.1/examples/scheduling.ml0000644005005300001440000002133010117553006017671 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: scheduling.ml,v 1.4 2004/08/12 15:31:52 barnier Exp $ *) open Facile open Easy module Task = struct type t = { start : Fd.t; end_time : Arith.t; processing_time : int; name : string ; id : int } let gen_int = Fcl_misc.gen_int_fun () let create ?(name = "") s p = { start = s; end_time = fd2e s +~ i2e p; processing_time = p; name = name; id = gen_int () } let id a = a.id let name a = a.name let start a = a.start let end_time a = a.end_time let release_date a = Fd.min a.start let processing_time a = a.processing_time let deadline a = Fd.max a.start + a.processing_time let update_release_date a x = let s = a.start in match Fd.value s with Unk attra -> Fd.refine s (Domain.remove_low x (Var.Attr.dom attra)) | Val v -> if x > v then Stak.fail "Scheduling.Task.update_release_date" let update_deadline a x = let s = a.start in match Fd.value s with Unk attra -> Fd.refine s (Domain.remove_up (x - a.processing_time) (Var.Attr.dom attra)) | Val v -> if x < v + a.processing_time then Stak.fail "Scheduling.Task.update_deadline" let end_time_bounds a = Arith.min_max_of_expr a.end_time let fprint_end_time c a = let (mi, ma) = end_time_bounds a in if mi = ma then Printf.fprintf c "%d" mi else Printf.fprintf c "[%d-%d]" mi ma let before a1 a2 = a1.end_time <=~ fd2e a2.start let after a1 a2 = before a2 a1 let fprint c a = Printf.fprintf c "%a -- %d --> %a\n" Fd.fprint a.start a.processing_time fprint_end_time a end type t = Task.t array let fprint f s = Array.iter (Task.fprint f) s let create = Array.of_list let tasks = Array.to_list let iter = Array.iter let number_of_tasks = Array.length (* Edge Finding *) (* From Constraint-Based Scheduling, page 24 *) (* [cc] maximal minimal end time [c.(i)] maximal minimal end time of A_j that come after A-i [pp] sum of processing times *) module T = Task let compare_release_dates a a' = compare (T.release_date a) (T.release_date a') let update_r a = let n = Array.length a in (* First sort {A_1,...,A_n} ascending release dates *) Array.sort compare_release_dates a; (* Check first if it is globally consistent *) try for i = 1 to n - 1 do if T.release_date a.(i) < T.deadline a.(i-1) then raise Exit done; true with Exit -> (* Copy release_dates in [r] and do updates directly in [a] *) let r = Array.map T.release_date a in (* 1..3 *) let c = Array.create n 0 in for k = 0 to n-1 do (* 4..29 *) let pp = ref 0 and cc = ref min_int in let dk = T.deadline a.(k) in for i = n-1 downto 0 do (* 6..15 *) let di = T.deadline a.(i) and pi = Task.processing_time a.(i) in if di <= dk then begin pp := !pp + pi; cc := max !cc (r.(i) + !pp); if !cc > dk then Stak.fail "Scheduling.update_r" end; c.(i) <- !cc done; let hh = ref min_int in for i = 0 to n-1 do (* 16..28 *) let di = T.deadline a.(i) and pi = T.processing_time a.(i) in if di <= dk then begin (* 17..19 *) hh := max !hh (r.(i) + !pp); pp := !pp - pi end else begin (* 20..26 *) if r.(i) + !pp + pi > dk then T.update_release_date a.(i) c.(i); if !hh + pi > dk then T.update_release_date a.(i) !cc end done done; false (* Check is done at the beginning of update *) let compare_deadlines a a' = compare (T.deadline a) (T.deadline a') let update_d a = let n = Array.length a in (* First sort {A_1,...,A_n} asscending deadline dates *) Array.sort compare_deadlines a; (* Check done ONLY in update_r *) (* Copy deadlines in [d] and do updates directly in [a] *) let d = Array.map T.deadline a in (* 1..3 *) let c = Array.create n 0 in for k = n-1 downto 0 do (* 4..29 *) let pp = ref 0 and cc = ref max_int in let rk = T.release_date a.(k) in for i = 0 to n-1 do (* 6..15 *) let ri = T.release_date a.(i) and pi = Task.processing_time a.(i) in if ri >= rk then begin pp := !pp + pi; cc := min !cc (d.(i) - !pp); if !cc < rk then Stak.fail "Scheduling.update_d" end; c.(i) <- !cc done; let hh = ref max_int in for i = n-1 downto 0 do (* 16..28 *) let ri = T.release_date a.(i) and pi = T.processing_time a.(i) in if ri >= rk then begin (* 17..19 *) hh := min !hh (d.(i) - !pp); pp := !pp - pi end else begin (* 20..26 *) if d.(i) - (!pp + pi) < rk then T.update_deadline a.(i) c.(i); if !hh - pi < rk then T.update_deadline a.(i) !cc end done done; false (* Check is done at the beginning of update *) let edge_finding = fun a -> let update _ = update_r a || update_d a and delay ct = Array.iter (fun a -> Fd.delay [Var.Fd.on_min; Var.Fd.on_max] (Task.start a) ct) a and priority = Cstr.later and name = "Scheduling.edge_finding" in Cstr.create ~priority ~name update delay let disjunctive2 a1 a2 = let update _ = T.release_date a2 >= T.deadline a1 || let p1p2 = T.processing_time a1 + T.processing_time a2 in if T.release_date a2 + p1p2 > T.deadline a1 then begin (* a2 cannot be before a1 *) Cstr.post (fd2e (T.start a2) >=~ T.end_time a1); true end else false and delay ct = Fd.delay [Var.Fd.on_max] (Task.start a1) ct; Fd.delay [Var.Fd.on_min] (Task.start a2) ct and priority = Cstr.later and name = "Scheduling.disjunctive2" in Cstr.create ~priority ~name update delay let disjunctive a = let n = Array.length a and c = ref Cstr.one in for i = 0 to n - 1 do for j = 0 to n - 1 do if i <> j then c := Reify.(&&~~) !c (disjunctive2 a.(i) a.(j)) done done; !c module Goals = struct let rank s = let n = Array.length s and s = Array.copy s in (* We will swap elements *) let swap i j = let tmp = s.(i) in s.(i) <- s.(j); s.(j) <- tmp and arg_smallest_release_date i = let value j = (T.release_date s.(j), T.deadline s.(j) - T.processing_time s.(j), T.id s.(j)) in let best = ref i in for j = i+1 to n-1 do if value j < value !best then best := j done; !best and is_first i () = let endsi = Task.end_time s.(i) in for j = i + 1 to n - 1 do (* Others start after *) Cstr.post (fd2e (Task.start s.(j)) >=~ endsi) done and is_not_first i () = if i = n-1 then Stak.fail "Scheduling.Goals.rank.is_not_first"; let minimal_end_time_of_another = FdArray.min (Array.map (fun a -> Arith.e2fd (T.end_time a)) (Array.sub s (i+1) (n-i-1))) in (***Printf.printf "%a >= %a\n" Fd.fprint (Task.start s.(i)) Fd.fprint minimal_end_time_of_another; flush stdout; ***) Cstr.post (fd2e (Task.start s.(i)) >=~ fd2e minimal_end_time_of_another) in (*** let rec rank i = Goals.create (fun i -> (***Printf.printf "rank %d: \n" i; fprint stdout s; ***) if i < n then let j = arg_smallest_release_date i in (*** Printf.printf "i=%d j=%d\n" i j; ***) swap i j; Goals.(||~) (Goals.(&&~) (Goals.atomic (is_first i)) (rank (i+1))) (Goals.(&&~) (Goals.atomic (is_not_first i)) (rank i)) else begin (***fprint stdout s; ***) Goals.success end) i in rank 0 ***) let swap_bt i j () = if i <> j then begin let tmp = s.(i) in s.(i) <- s.(j); s.(j) <- tmp; Stak.trail (fun () -> swap i j) end in let another_first i j () = let latest_start_j = T.deadline s.(j) - T.processing_time s.(j) in try for i = i to n - 1 do if i <> j && T.release_date s.(i) + T.processing_time s.(i) <= latest_start_j then raise Exit done; Stak.fail "Scheduling.Goals.another_first" with Exit -> () in let rec rank i i' = (* i' is the smallest which can be selected first *) Goals.create (fun i -> if i < n then if i' < n then let j = arg_smallest_release_date i' in (Goals.atomic (swap_bt i j) &&~ Goals.atomic (is_first i) &&~ rank (i+1) (i+1)) ||~ (Goals.atomic (swap_bt i' j) &&~ Goals.atomic (is_not_first i') &&~ rank i (i'+1)) else Stak.fail "Scheduling.Goals.rank" else Goals.success) i in rank 0 0 end facile-1.1/examples/scheduling.mli0000644005005300001440000000713510117553006020051 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) (* $Id: scheduling.mli,v 1.3 2004/08/09 16:04:41 barnier Exp $ *) open Facile open Easy module Task : sig type t (** Type of tasks. *) val create : ?name:string -> Fd.t -> int -> t (** [create start processing_time] return a new task with start time [start] and constant duration [processing_time]. *) val name : t -> string (** [name t] return the name of task [t]. *) val start : t -> Fd.t (** [start t] return the start time of task [t] as a variable. *) val end_time : t -> Arith.t (** [end_time t] return the end time of task [t] as an expression (i.e. [start t +~ processing_time t]). *) val release_date : t -> int (** [release_date t] return the earliest start time of task [t] (i.e. [Fd.min (start t)]). *) val processing_time : t -> int (** [processing_time t] return the duration of task [t]. *) val deadline : t -> int (** [name t] return the latest completion time of task [t] (i.e. [Fd.max (start t) + processing_time t]). *) val before : t -> t -> Cstr.t (** [before t1 t2] returns a constraint ensuring that [t1] is processed before [t2]. *) val after : t -> t -> Cstr.t (** [after t1 t2] returns a constraint ensuring that [t1] is processed after [t2]. *) val update_release_date : t -> int -> unit (** [update_release_date t start] refine task [t] so that it cannot begin before [start]. *) val update_deadline : t -> int -> unit (** [update_deadline t endtime] refine task [t] so that it cannot end after [endtime]. *) val fprint : out_channel -> t -> unit (** [fprint chan t] print task [t] on out channel [chan]. *) end type t (** Type of unary ressource. They are associated with the set of tasks which require it. *) val fprint : out_channel -> t -> unit (** [fprint chan r] print ressource [r] (i.e. the set of tasks which require it) on out channel [chan]. *) val create : Task.t list -> t (** [create ts] return a new ressource which must process (if constrained) all tasks in list [ts]. *) val tasks : t -> Task.t list (** [tasks r] return the list of tasks that require [r]. *) val iter : (Task.t -> unit) -> t -> unit (** [iter f r] iterate on all tasks requiring ressource [r]. *) val number_of_tasks : t -> int (** [number_of_tasks r] return the number of tasks requiring ressource [r]. *) val edge_finding : t -> Cstr.t (** [edge_finding r] return a unary capacity constraint on ressource [r]. Propagations are performed with the edge-finding bounding algorithm. *) val disjunctive : t -> Cstr.t (** [disjunctive r] return a unary capacity constraint on ressource [r]. Propagations are performed by pairwise disjunctive constraints on all the tasks of [r]. *) module Goals : sig val rank : t -> Goals.t (** [rank r] return a goal that ranks tasks of ressource [r]: the unranked task with the smallest release date is non-deterministically chosen to be ranked first. *) end facile-1.1/examples/jobshop.ml0000644005005300001440000001111210117553006017205 0ustar barnierusers00000000000000(***********************************************************************) (* *) (* FaCiLe *) (* A Functional Constraint Library *) (* *) (* Nicolas Barnier, Pascal Brisset, LOG, CENA *) (* *) (* Copyright 2004 CENA. All rights reserved. This file is distributed *) (* under the terms of the GNU Lesser General Public License. *) (***********************************************************************) open Facile open Easy module T = Scheduling.Task let read_mt file = let inbuf = Scanf.Scanning.from_file file in let (nb_job, nb_task) = Scanf.bscanf inbuf "%d %d " (fun a b -> (a, b)) in let duration = Array.make_matrix nb_job nb_task 0 and num_mach = Array.make_matrix nb_job nb_task 0 in for i=0 to nb_job-1 do for j=0 to nb_task-1 do Scanf.bscanf inbuf "%d %d " (fun a b -> duration.(i).(j) <- a; num_mach.(i).(j) <- b - 1) done done; (duration, num_mach) let js file = let cpu_start = Sys.time () in let (duration, num_mach) = read_mt file in let nb_job = Array.length duration and nb_task = Array.length duration.(0) in let horizon = Array.fold_left (Array.fold_left (+)) 0 duration in let machs = Array.create nb_task [] and sums = Array.create nb_task 0 in let a = Array.mapi (fun i jobi -> Array.mapi (fun j pij -> let s = Fd.interval 0 (horizon - pij) in let name = Printf.sprintf "%d %d" (i+1) (j+1) in let a = T.create ~name s pij in let m = num_mach.(i).(j) in sums.(m) <- sums.(m) + pij; machs.(m) <- a :: machs.(m); a) jobi) duration in let jobs_ends = Array.init nb_job (fun i -> Arith.e2fd (T.end_time a.(i).(nb_task-1))) in let makespan = FdArray.max jobs_ends in let schedules = Array.map (fun m -> Scheduling.create m) machs in (* Machines constraints *) Array.iter (fun s -> Cstr.post (Scheduling.edge_finding s)) schedules; (* Redondant constraint : fewer backtracks but higher cpu *) (* Not enough to find alone mt10 optimal solution *) (* Array.iter (fun s -> Cstr.post (Scheduling.disjunctive s)) schedules;*) (* precedence *) for i = 0 to nb_job-1 do for j = 1 to nb_task-1 do Cstr.post (T.after a.(i).(j) a.(i).(j-1)) done done; (* Goal: ranking ressource by ressource, starting with the most critical *) let max_deadline i = List.fold_left (fun r a -> max r (T.deadline a)) min_int machs.(i) in let min_release_date i = List.fold_left (fun r a -> min r (T.release_date a)) max_int machs.(i) in let ranked = Array.init nb_task (fun _ -> Stak.ref false) in let most_critical schedules = let best = ref (-1) and slack_best = ref max_int in for i = 0 to nb_task - 1 do if not (Stak.get ranked.(i)) then let mi = max_deadline i - min_release_date i - sums.(i) in if mi < !slack_best then begin best := i; slack_best := mi end done; if !best >= 0 then begin Stak.set ranked.(!best) true; !best end else raise Not_found in let goal = Goals.Array.forall ~select:most_critical Scheduling.Goals.rank schedules &&~ Goals.Array.forall Goals.Array.labeling (Array.map (Array.map T.start) a) in Printf.printf "Constraints set: %.2fs\n" (Sys.time() -. cpu_start); let control b = Printf.printf "\b\b\b\b\b\b%d" b; flush stdout in let schedules_sol = ref None in let schedules2triples sched = Array.map (fun s -> List.map (fun a -> (Fd.elt_value (T.start a), T.processing_time a, Arith.eval (T.end_time a))) (Scheduling.tasks s)) sched in let solution cost = Printf.printf " cost=%d cpu=%.2fs\n" cost (Sys.time () -. cpu_start); flush stdout; schedules_sol := Some (schedules2triples schedules) in ignore (Goals.solve ~control (Goals.minimize goal makespan solution)); let total = Sys.time () -. cpu_start in begin match !schedules_sol with Some sol -> Printf.printf "\n"; Array.iter (fun s -> List.iter (fun (s, p, e) -> Printf.printf "%d -- %d --> %d\n" s p e) s; Printf.printf "\n") sol | None -> Printf.printf "No solution\n" end; Printf.printf " cpu=%.2fs\n" total let _ = let data_file = ref "mt10.dat" in Arg.parse [] (fun s -> data_file := s) ""; (* if you have a lot of RAM *) (* Gc.set ({(Gc.get ()) with Gc.space_overhead = 500});*) js !data_file facile-1.1/examples/mt10.dat0000644005005300001440000000101610117553006016464 0ustar barnierusers0000000000000010 10 29 1 78 2 09 3 36 4 49 5 11 6 62 7 56 8 44 9 21 10 43 1 90 3 75 5 11 10 69 4 28 2 46 7 46 6 72 8 30 9 91 2 85 1 39 4 74 3 90 9 10 6 12 8 89 7 45 10 33 5 81 2 95 3 71 1 99 5 09 7 52 9 85 8 98 4 22 10 43 6 14 3 06 1 22 2 61 6 26 4 69 5 21 9 49 8 72 10 53 7 84 3 02 2 52 6 95 4 48 9 72 10 47 1 65 7 06 5 25 8 46 2 37 1 61 4 13 3 32 7 21 6 32 10 89 9 30 8 55 5 31 3 86 1 46 2 74 6 32 5 88 7 19 9 48 10 36 8 79 4 76 1 69 2 76 4 51 6 85 3 11 10 40 7 89 8 26 5 74 9 85 2 13 1 61 3 07 7 64 9 76 10 47 6 52 4 90 5 45 8 facile-1.1/README0000644005005300001440000000250010117553006014252 0ustar barnierusers00000000000000OVERVIEW: FaCiLe is a Functional Constraint Library implemented in Objective Caml. CONTENTS: README this file Makefile main Makefile src/ source files of the library examples/ some examples using the library INSTALLATION: All you need is the Objective Caml 3.02 (or greater) compiler and standard Unix tools (make...). 0) Configure the library. The single option of configuration is the directory you want to put the library files in (facile.cma, facile.cmxa, facile.a facile.cmi). Default is the subdirectory "facile" of the Ocaml library directory (returned by "ocamlc -where"). ./configure [--faciledir ] 1) First compile the library with a simple make 2) Check the result make check You should get a solution for the 8 queens problem. 3) Then install the library with a (usually as root) make install DOCUMENTATION The documentation is available as Postscript and PDF format and as a bundle of HTML files. It also can be found online at the web site: http://www.recherche.enac.fr/opti/facile/doc AVAILABILITY: The package and the documentation are available at: http://www.recherche.enac.fr/opti/facile/distrib BUG REPORTS AND USER FEEDBACK: Send bug reports by E-mail to: facile@recherche.enac.fr facile-1.1/LICENSE0000644005005300001440000004544310117553006014414 0ustar barnierusers00000000000000FaCiLe, Copyright (C) 2001, CENA This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --------------------------------------------------------------------------------- GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS facile-1.1/Makefile0000644005005300001440000000103710117553006015036 0ustar barnierusers00000000000000# $Id: release_Makefile,v 1.7 2003/05/15 09:13:16 brisset Exp $ include config_Makefile compile: cd src; make install: if test -d $(FACILEDIR); then : ; else mkdir $(FACILEDIR); fi cp src/facile.cmi src/facile.cma src/facile.cmxa src/facile.a $(FACILEDIR) chmod a+r $(FACILEDIR)/facile.cmi chmod a+r $(FACILEDIR)/facile.cma chmod a+r $(FACILEDIR)/facile.cmxa chmod a+r $(FACILEDIR)/facile.a clean: cd src; make clean distclean uninstall: rm -fr $(FACILEDIR) check: cd examples; make FACILEDIR=../src queens.opt; ./queens.opt 8 facile-1.1/configure0000755005005300001440000000157210117553006015311 0ustar barnierusers00000000000000#! /bin/sh # $Id: configure,v 1.7 2004/07/02 09:58:47 barnier Exp $ # Checking for ocaml >= $ocaml_min_version (i.e. with -where option and # compilation of or-patterns fixed) ocaml_min_version=3.02 echo "Checking for OCaml compiler (>= ${ocaml_min_version})..." if expr `ocamlc -version` \>\= $ocaml_min_version >/dev/null 2>&1; then version=`ocamlc -version` echo "OCaml $version found" else echo "Aborting... OCaml compiler is either missing or too old" exit 1 fi # Default place for facile in OCaml library directory faciledir=`ocamlc -where`/facile # Parse command-line arguments while : ; do case "$1" in "") break;; -faciledir|--faciledir) faciledir=$2; shift;; *) echo "Unknown option \"$1\"." 1>&2; exit 2;; esac shift done # Generates config_Makefile echo FACILEDIR=$faciledir > config_Makefile echo FaCiLe directory: $faciledir facile-1.1/config_Makefile0000644005005300001440000000005310117553006016360 0ustar barnierusers00000000000000FACILEDIR=please_run_configure_before_make