type 'a ss = Negr of 'a ss list | End of 'a list * int;; type sss = N of sss list | End1 of int;; open List;; exception Something of int;; exception Something2 of ((string * string) list) * ((string * string) list);; let swap a i j = let t = a.(i) in a.(i) <- a.(j); a.(j) <- t;; let fst (x, y) = x and snd (x, y) = y;; let var bin = let rec f l acc = match l with (l1, l2) :: ls -> let acc' = if (not (mem l1 acc)) then l1::acc else acc in if (not (mem l2 acc')) then f ls (l2::acc') else f ls acc' |[] -> rev acc in f bin [];; let step bin = let r = ref bin in let vars = var bin in let f x = nth vars x in let l = length vars - 1 in for i = 0 to l do for j = 0 to l do for k = 0 to l do if (mem (f i, f j) !r) && (mem (f j, f k) !r) && (not (mem (f i, f k) !r)) then r := (f i, f k)::!r done done done; !r;; let rec qsort l = match l with l1::ls -> (qsort (List.filter (fun x -> x < l1) ls)) @ [l1] @ (qsort (List.filter (fun x -> x > l1) ls)) |[] -> [];; let tranz bin = let rec tranz' bin = if bin = step bin then bin else tranz' (step bin) in qsort (tranz' bin);; let add bin = let r2 = ref ([], []) in let vars = var bin in let f x = nth vars x in let l = length vars - 1 in try for i = 0 to l do for j = 0 to l do if (not (mem (f i, f j) bin)) && (not (mem (f j, f i) bin)) && (i <> j) then (r2 := ((f i, f j)::bin, (f j, f i)::bin); raise (Something 0)) done done; (bin, bin) with Something x -> !r2;; let add2 bin vars = let r2 = ref [] in let f x = nth vars x in let l = length vars - 1 in for i = 0 to l do for j = 0 to l do if (not (mem (f i, f j) bin)) && (not (mem (f j, f i) bin)) && (i <> j) && (not (mem ((f i, f j), (f j, f i)) !r2)) && (not (mem ((f j, f i), (f i, f j)) !r2)) then r2 := ((f i, f j), (f j, f i))::!r2 done done; rev !r2;; let del q l = let rec f l' acc = match l' with l1 :: ls -> if l1 = q then (rev acc) @ ls else f ls (l1 :: acc) |[] -> l in f l [];; let (!!) n = let rec f n acc = if n > 0 then f (n - 1) (n * acc) else acc in f n 1;; let ( *** ) x y = int_of_float ((float_of_int x) ** (float_of_int y));; (*let fact_of_int n = let rec max_fact k m = if !!m <= k then max_fact k (m + 1) else (m - 1) in let z = max_fact n 1 in let rec f t m acc = let u = (t / (!!m)) in if m >= 0 then f (t - (u * (!!m))) (m - 1) (u :: acc) else (rev acc) in f n z [];; let rec ( ++ ) p n = if n > 0 then (inc p) ++ (n - 1) else p;; *) let inc_p p = let l = Array.length p in let b = ref (l - 1) in while p.(!b) < p.(!b - 1) do b := !b - 1 done; let t = !b - 1 in for i = !b to l - 1 do if p.(i) < p.(!b) && p.(i) > p.(t) then b := i done; swap p t !b; for i = (t + 1) to ((l + t) / 2) do swap p i (l + t - i) done; p;; let rec (++) p n = if n > 0 then (inc_p p) ++ (n - 1) else p;; let rec max_fact k m = if !!m <= k then max_fact k (m + 1) else m;; let np n m = (Array.init m (fun i -> "a"^(string_of_int (i + 1)))) ++ n;; let rec check g p = match g with (x, y)::ls -> let b = ref 0 in let c = ref 0 in while p.(!b) <> x do b := !b + 1 done; while p.(!c) <> y do c := !c + 1 done; if b > c then false else check ls p |[] -> true;; let t g n = let b = ref 0 in for i = 0 to (!!n - 1) do if (check g (np i n)) then b := !b + 1 done; !b;; let effect (g, k, n) = (float_of_int !!n) /. (2. ** (float_of_int k)) /. (float_of_int (t g n));; let add3 (x, y) g k n e = let x1 = effect (x :: g, k, n) in let x2 = effect (y :: g, k, n) in (*if x1 = x2 then (if x1 < e then [] else raise (Something2 (tranz (x :: g), tranz (y :: g)))) else*) if x1 > x2 then (if x2 < e then [] else qsort (tranz (y :: g))) else (if x1 < e then [] else qsort (tranz (x :: g)));; (*let add4 (x, y) g n = let x1 = effect (x :: g, 0, n) in let x2 = effect (y :: g, 0, n) in if x1 = x2 then raise (Something2 (x, y)) else if x1 > x2 then y else x;; *) let c = ref 1;; let rec next g k n f e = (*let e' = ref e in *) let a = add2 g (Array.to_list (np 0 n)) in let l = length a in if l = 0 then ((*iter f g; print_int (k - 1); print_string " "; print_float (effect (g, k - 1, n));(* read_line ()*)print_string "\n" ; flush stdout;*) End (g, k - 1)) else let r = ref [] in for i = 0 to (l - 1) do let t1 = ref [] in let t2 = ref [] in let z = (nth a i) in (try t1 := (add3 z g k n e); (*if !e' < (effect (!t1, k, n)) then e' := effect (!t1, k, n) else ();*) iter f !t1; print_int k; print_string " "; print_float (effect (!t1, k, n)); print_string "\n"; flush stdout with Something2 (x, y) -> t1 := x; t2 := y(*; iter f !t1; print_int k; print_string " "; print_float (effect (!t1, k, n)); read_line (); flush stdout; iter f !t1; print_int k; print_string " "; print_float (effect (!t1, k, n)); read_line ();flush stdout*)); if !t1 = [] then () else if !t2 = [] then let tt1 = (next !t1 (k + 1) n f e) in (if (List.mem tt1 !r) then () else r := tt1 :: !r) else let tt1 = (next !t1 (k + 1) n f e) in let tt2 = (next !t2 (k + 1) n f e) in (if (List.mem tt1 !r) then (if (List.mem tt2 !r) then () else r := tt2 :: !r) else (if (List.mem tt2 !r) then r := tt1 :: !r else r := tt1 :: tt2 :: !r)) done; Negr !r;; (*let main n = let a = add2 [] (Array.to_list (np 0 n)) in let rec next2 g k l = let l' = length l in if l' = 0 then End1 k else let r = ref [] in for i = 0 to (l' - 1) do let t1 = ref ("","") in let t2 = ref ("","") in let z = (nth l i) in (try t1 := (add4 z g n) with Something2 (x, y) -> t1 := x; t2 := y); if !t2 = ("", "") then r := (next2 (tranz (!t1 :: g)) (k + 1) (del z l)) :: !r else r := (next2 (tranz (!t1 ::g)) (k + 1) (del z l)) :: (next2 (tranz (!t2 :: g)) (k + 1) (del z l)) :: !r done; N !r in let b = ref (n * n) in let rec f l = match l with End1 k -> if !b > k then b := k |N l -> iter (fun x -> f x) l in f (next2 [] 0 a); !b;; *) let main_s n f e = let b = ref ((n * n), []) in let rec ss s = if s = Negr [] then b := (0, []) else (match s with End (g, k) -> if (fst !b) > k then (b := (k, g)) else () |Negr l -> let l' = Array.of_list l in for i = 0 to (Array.length l' - 1) do ss l'.(i) done) in ss (next [] 1 n f e); !b;; let rec all_graph g n = if (add2 g n) = [] then g else all_graph ((fst (List.hd (add2 g n))) :: g) n;; let log_2 n = let n' = float_of_int n in let c = log n' /. log 2. in if (float_of_int (int_of_float c)) < c then int_of_float (c +. 1.) else int_of_float c;; let string_of_ipair (x, y) = "("^string_of_int x^", "^string_of_int y^") ";; let string_of_spair (x, y) = "("^x^", "^y^") ";; let print_ipair x = print_string (string_of_ipair x);; let print_spair x = print_string (string_of_spair x);; let print_ibin bin = iter (print_ipair) bin; print_string "\n";; let print_sbin bin = iter (print_spair) bin; print_string "\n";; let rec print_s s = match s with End (g, k) -> print_string "End ("; iter (print_spair) g; print_string (", "^string_of_int k^"\n") |Negr l -> let l' = Array.of_list l in for i = 0 to (Array.length l' - 1) do print_s l'.(i) done;; (*let bin = [("a1","a2"); ("a2","a3")] in let a = add2 bin (Array.to_list (np 0 4)) in let l = length a in for i = 0 to (l - 1) do let z = (nth a i) in iter (print_spair) (add3 z bin 4); read_line () done;; *) (* print_sbin (qsort bin);; print_sbin (qsort (tranz bin));; print_sbin (qsort (fst (add bin)));; print_sbin (qsort (snd (add bin)));; print_sbin (qsort (tranz (snd (add bin))));; *) (*Array.iter (print_string) (np 2 5);;*) (*print_float (effect ([("a1","a2"); ("a1", "a3");("a2", "a3")], 3, 3));;*) (*let k = main_s 4 (print_spair) in print_int (fst k); print_string "\n"; flush stdout; iter (print_spair) (snd k);; print_string "\n";; print_int (log_2 (!!4));;*) (*print_int (main 4);;*) let n = 6 in let e = effect (all_graph [] (Array.to_list (np 0 n)), log_2 (!!n), n) in print_float e; print_string "\n"; print_int (fst (main_s n (print_spair) e));;