(* #load "graphics.cma";; *)

open Array;;
open List;;
open Sys;;
open Random;;
open Graphics;;

let dir = "." and ext = ".sud" and ext2 = ".oku" ;;
chdir dir;;


(* m est un bool vect vect vect de taille 10*10*10                                  *
 * m.(i).(j).(k) = true si k est une possibilité en i,j                             *
 * m.(i).(j).(0) = true si m.(i).(j) pas encore trouvé                              *
 * m.(i).(0).(k) = true si k pas encore trouvé à la ligne i                         *
 * m.(i).(0).(0) = true si ligne i pas complète                                     *
 * même chose pour les colonnes                                                     *
 * c est un bool vect vect vect de taille 3*3*3 et représente les petits carrés 3*3 *
 * c.(i).(j).(k) = true si k pas encore trouvé au carré i,j                         *
 * c.(i).(j).(0) = true si carré i,j pas complet                                    *)


let aff = ref false ;;
let print_endline s = if !aff then print_endline s ;;

let m = Array.make_matrix 10 10 [||] and c = Array.make_matrix 3 3 [||] and nc = ref [] ;;

let opt = ref 0 ;;

let init_mc mc =
        for i = 0 to Array.length mc - 1 do
        for j = 0 to Array.length mc.(0) - 1 do
                mc.(i).(j) <- Array.make 10 true;
        done;
        done;
        mc.(0).(0).(0) <- false;
;;

let reset deb =
        init_mc m;
        init_mc c;
        nc:= deb;
;;

reset [];;

let init_grille () =
        let i = ref 1 in
        while !i <> 0 do
                print_string "i ? ";
                i:= read_int();
                if !i <> 0 then (
                        print_string "j ? ";
                        let j = read_int() in
                        if j <> 0 then (
                                print_string "val ? ";
                                let z = read_int() in
                                if z <> 0 then nc:= (!i,j,z) :: !nc;
                        );
                );
        done;
;;


let rec print_nc = function
        | [] -> print_newline();
        | ((i,j,z)::q) -> print_int i ; print_string "," ; print_int j ; print_string " : ";
                          print_int z ; print_string "  ;  ";
                          print_nc q;
;;

let print_nc nc = if !aff then print_nc nc ;;


(* ma première grille sauvée dans g1                                                              *
 *                                                                                                *
 * let deb = [1, 2, 9; 2, 3, 6; 2, 5, 4; 2, 9, 8; 3, 1, 5; 3, 4, 8; 3, 6, 7; 3, 8, 2;             *
 *            3, 9, 9; 4, 9, 3; 5, 3, 3; 5, 6, 9; 5, 7, 8; 6, 2, 7; 6, 3, 2; 6, 7, 5;             *
 *            7, 1, 9; 7, 5, 1; 7, 9, 6; 8, 2, 2; 8, 4, 3; 8, 9, 5; 9, 4, 2; 9, 6, 4; 9, 7, 7] ;; *)



let elimine m c nc =

let maj1case i j z =
        if not m.(i).(j).(z) then
                failwith ("case "^(string_of_int i)^","^(string_of_int j)^" cas "^(string_of_int z)^" repoussé");
        if z <> 0 && m.(i).(j).(0)  then (
                for k = 0 to z-1 do m.(i).(j).(k) <- false done;
                for k = z+1 to 9 do m.(i).(j).(k) <- false done;
                for x = 0 to i-1 do m.(x).(j).(z) <- false done;
                for x = i+1 to 9 do m.(x).(j).(z) <- false done;
                for y = 0 to j-1 do m.(i).(y).(z) <- false done;
                for y = j+1 to 9 do m.(i).(y).(z) <- false done;
                for xx = 1 to 3 do
                for yy = 1 to 3 do
                        let ii = (i-1)/3*3+xx and jj = (j-1)/3*3+yy in
                        if (ii <> i || jj <> j) then m.(ii).(jj).(z) <- false;
                done;
                done;
                c.((i-1)/3).((j-1)/3).(z) <- false;
        );
in

let rec maj = function
        | [] -> ()
        | ((i,j,z)::q) -> maj1case i j z ; maj q
in


let plusquuncas1 i j =
        if m.(i).(j).(0) then (
                let b = ref 0 and z = ref 0 in
                for k = 1 to 9 do
                        if m.(i).(j).(k) then (
                                z:= k;
                                incr b;
                        );
                done;
                if !b = 0 then failwith ("case "^(string_of_int i)^","^(string_of_int j)^" : plus de cas");
                if !b = 1 then !z else 0;
        )
        else 0;
in

let plusquuncas () =
        for i = 1 to 9 do
                if m.(i).(0).(0) then (
                        for j = 1 to 9 do
                                if m.(i).(j).(0) then (
                                        let z = plusquuncas1 i j in
                                        if z <> 0 then nc:= (i,j,z) :: !nc;
                                );
                        done;
                );
        done;
in


let plusquunchoix () =

let plusquunchoixligne i =
        if m.(i).(0).(0) then (
                for k = 1 to 9 do
                        if m.(i).(0).(k) then (
                                let b = ref 0 and j = ref 0 in
                                for y = 1 to 9 do
                                        if m.(i).(y).(k) then (
                                                j:= y;
                                                incr b;
                                        );
                                done;
                                if !b = 0 then
                                        failwith ("ligne "^(string_of_int i)^" : plus de choix pour "^(string_of_int k));
                                if !b = 1 then nc:= (i,!j,k) :: !nc;
                        );
                done;
        );
in

let plusquunchoixcol j =
        if m.(0).(j).(0) then (
                for k = 1 to 9 do
                        if m.(0).(j).(k) then (
                                let b = ref 0 and i = ref 0 in
                                for x = 1 to 9 do
                                        if m.(x).(j).(k) then (
                                                i:= x;
                                                incr b;
                                        );
                                done;
                                if !b = 0 then
                                        failwith ("colonne "^(string_of_int j)^" : plus de choix pour "^(string_of_int k));
                                if !b = 1 then nc:= (!i,j,k) :: !nc;
                        );
                done;
        );
in

let plusquunchoixcarre ii jj =
        if c.(ii).(jj).(0) then (
                for k = 1 to 9 do
                        if c.(ii).(jj).(k) then (
                                let b = ref 0 and i = ref 0 and j = ref 0 in
                                for xx = 1 to 3 do
                                for yy = 1 to 3 do
                                        let x = ii*3+xx and y = jj*3+yy in
                                        if m.(x).(y).(k) then (
                                                i:= x;
                                                j:= y;
                                                incr b;
                                        );
                                done;
                                done;
                                if !b = 0 then
                                        failwith ("carré "^(string_of_int (ii+1))^","^(string_of_int (jj+1))^
                                                  " : plus de choix pour "^(string_of_int k));
                                if !b = 1 then nc:= (!i,!j,k) :: !nc;
                        );
                done;
        );
in

for ij = 1 to 9 do
        plusquunchoixligne ij;
        plusquunchoixcol   ij;
done;
for ii = 0 to 2 do
for jj = 0 to 2 do
        plusquunchoixcarre ii jj;
done;
done;
in


let verifcomp () =

let veriflignecomp i =
        if m.(i).(0).(0) then (
                let b = ref true and z = ref 1 in
                while !b && !z < 10 do
                        if m.(i).(0).(!z) then b:= false
                                          else incr z;
                done;
                if !z = 10 then (
                        print_endline ("ligne "^(string_of_int i)^" complète");
                        m.(i).(0).(0) <- false;
                );
        );
in

let verifcolcomp j =
        if m.(0).(j).(0) then (
                let b = ref true and z = ref 1 in
                while !b && !z < 10 do
                        if m.(0).(j).(!z) then b:= false
                                          else incr z;
                done;
                if !z = 10 then (
                        print_endline ("colonne "^(string_of_int j)^" complète");
                        m.(0).(j).(0) <- false;
                );
        );
in

let verifcarrecomp ii jj =
        if c.(ii).(jj).(0) then (
                let b = ref true and z = ref 1 in
                while !b && !z < 10 do
                        if c.(ii).(jj).(!z) then b:= false
                                            else incr z;
                done;
                if !z = 10 then (
                        print_endline ("carre "^(string_of_int (ii+1))^","^(string_of_int (jj+1))^" complet");
                        c.(ii).(jj).(0) <- false;
                );
        );
in

let veriffin () =
        let b = ref true and x = ref 1 in
        while !b && !x < 10 do
                if m.(!x).(0).(0) then b:= false
                                  else incr x;
        done;
        if !x = 10 then (
                print_endline "grille terminée !";
                m.(0).(0).(0) <- true;
        );
in

let rec verifcomp1 checki checkj checkc = function
        | [] -> veriffin()
        | ((i,j,_)::q) -> if not (mem i !checki )then (veriflignecomp i ; checki:= i :: !checki);
                          if not (mem j !checkj) then (verifcolcomp j ; checkj:= j :: !checkj);
                          let ii = (i-1)/3 and jj = (j-1)/3 in
                          if not (mem (ii,jj) !checkc) then (verifcarrecomp ii jj ; checkc:= (ii,jj) :: !checkc);
                          verifcomp1 checki checkj checkc q;
in

verifcomp1 (ref []) (ref []) (ref []) !nc;

in


let rec make_set = function
        | [] -> []
        | (a::q) when mem a q -> make_set q
        | (a::q) -> a :: (make_set q)
in


let elimine1 () =
        let nncc = ref [] in
        nc:= make_set !nc;
        while !nc <> [] do
                while !nc <> [] do
                        maj !nc;
                        verifcomp();
                        nc:= [];
                        plusquuncas();
                        print_nc !nc;
                        nncc:= !nncc @ !nc;
                done;
                plusquunchoix();
                nc:= make_set !nc;
                print_nc !nc;
                nncc:= !nncc @ !nc;
        done;
        !nncc;
in

nc:= elimine1();
;;


let matrix m =

        let caseij i j =
                let z = ref 1 and b = ref true in
                while !b && !z < 10 do
                        if m.(i).(j).(!z) then b:= false else incr z;
                done;
                if !z = 10 then failwith ("case "^(string_of_int i)^","^(string_of_int j)^" : plus de choix restant");
                !z
        in

        let mm = Array.make_matrix 9 9 0 in
        for i = 1 to 9 do
        for j = 1 to 9 do
                if not m.(i).(j).(0) then mm.(i-1).(j-1) <- caseij i j;
        done;
        done;
        mm;
;;


let poss m =
        let poss = ref [] in
        for i = 9 downto 1 do
                if m.(i).(0).(0) then (
                        for j = 9 downto 1 do
                                if m.(i).(j).(0) then (
                                        let p = ref [] in
                                        for z = 9 downto 1 do
                                                if m.(i).(j).(z) then p:= z :: !p;
                                        done;
                                        poss:= (i, j, !p) :: !poss;
                                );
                        done;
                );
        done;
        !poss;
;;

let poss2 ineq =

        let rec tri_insertion ineq l =

                let rec insere a = function
                        | [] -> [a]
                        | (b::q) when ineq a b -> a::b::q
                        | (b::q) -> b::(insere a q)
                in

                match l with
                        | [] -> []
                        | (a::q) -> insere a (tri_insertion ineq q)
        in

        tri_insertion ineq (poss m);
;;

let ineq x y =
        let _,_,k = x and _,_,l = y in
        length k <= length l;
;;

let ineq2 x y =
        let _,_,k = x and _,_,l = y in
        length k >= length l
;;

let poss3 = function
        | 1 -> poss m
        | 3 -> poss2 ineq2
        | _ -> poss2 ineq
;;


let copy_trinityx m =
        let i = Array.length m and j = Array.length m.(0) in
        let mm = Array.make_matrix i j [||] in
        for x = 0 to i-1 do
        for y = 0 to j-1 do
                mm.(x).(y) <- copy m.(x).(y);
        done;
        done;
        mm;
;;

let copy_trinityx2 mm m =
        for i = 0 to Array.length m - 1 do
        for j = 0 to Array.length m.(0) - 1 do
                mm.(i).(j) <- copy m.(i).(j);
        done;
        done;
;;


let parcours_largeur poss =

        let testposscase1 i j z =
                let mm = copy_trinityx m and cc = copy_trinityx c and nc = ref [i,j,z] in
                try
                        print_endline ("case "^(string_of_int i)^","^(string_of_int j)^" test : "^(string_of_int z));
                        elimine mm cc nc;
                        true;
                with Failure s -> print_endline s ; false
        in

        let rec testposscase2 i j ztrouve b l = match b,l with
                | false, [] -> failwith ("case "^(string_of_int i)^","^(string_of_int j)^" plus de choix restant")
                | true,  [] -> ztrouve
                | false, (z::q) -> testposscase2 i j z (testposscase1 i j z) q
                | true, (z::_) when testposscase1 i j z -> failwith "au moins 2 cas"
                | true, (z::q) -> testposscase2 i j ztrouve true q
        in

        let rec parcours nc = function
                | [] -> nc
                | ((i,j,l)::q) -> try parcours ((i, j, (testposscase2 i j 0 false l)) :: nc) q
                                  with Failure "au moins 2 cas" -> parcours nc q
        in

        print_endline "parcours des possibilités en largeur";
        let sol = parcours [] poss in
        print_endline "fin du parcours";
        nc:= rev sol;
;;

let solution_largeur possi =
        let deb = !nc and sol = ref [] in
        elimine m c nc;
        sol:= [deb, !nc];
        parcours_largeur (poss3 possi);
        let mm = copy_trinityx m and cc = copy_trinityx c and nncc = ref !nc
        and s = ref [] and ss = ref [] in
        while not m.(0).(0).(0) && !nncc <> [] do
                s:= (hd !nncc) :: !s;
                nncc:= tl !nncc;
                ss:= !s;
                elimine m c ss;
                if !ss <> [] then (
                        let sss = ref [hd !s] in
                        elimine mm cc sss;
                        if ss = sss then (nncc:= !nncc @ (tl !s) ; s:= [hd !s];)
                                    else elimine mm cc ss;
                        sol:= (rev !s, !ss) :: !sol;
                        s:= [];
                        nncc:= filter (fun x -> not (mem x !ss)) !nncc;
                );
                if !nncc = [] then (
                        if !s <> [] then sol:= (rev !s, []) :: !sol;
                        parcours_largeur (poss3 possi);
                        nncc:= !nc;
                );
        done;
        m.(0).(0).(0), (rev !sol);
;;

let solution_largeur_opt () =

        let rec atomise = function
                | [] -> []
                | (a::q) -> [a] :: (atomise q)
        in

        let rec couples1 a = function
	        | [] -> []
                | (b::q) -> [a;b] :: (couples1 a q)
        in

        let rec couples = function
	        | [] -> []
	        | (a::q) -> (couples1 a q) @ (couples q)
        in

        let rec triuplets1 a = function
                | [] -> []
                | (b::q) -> (a::b) :: (triuplets1 a q)
        in

        let rec triuplets = function
                | [] -> []
                | (a::q) -> (triuplets1 a (couples q)) @ (triuplets q)
        in

        let rec apl = function
                | [] -> []
                | (a::q) -> a @ (apl q)
        in

        let sol = ref [] and nncc = !nc in
        elimine m c nc;
        sol:= [[], nncc, !nc];
        parcours_largeur (poss3 1);
        while !nc <> [] do
                let mm = copy_trinityx m and cc = copy_trinityx c and nc3 = ref !nc in
                elimine mm cc nc3;
                let nc2 = ref (atomise !nc) and s = ref [] and ss = ref [] in
                (try
                        for q = 1 to 4 do
                                while !nc2 <> [] do
                                        copy_trinityx2 mm m;
                                        copy_trinityx2 cc c;
                                        s:= hd !nc2;
                                        elimine mm cc s;
                                        if length !s = length !nc3 then
                                                ss:= (hd !nc2) :: !ss;
                                        nc2:= tl !nc2;
                                done;
                                if !ss <> [] then (
                                        s:= apl !ss;
                                        sol:= (rev !ss, filter (fun x -> not (mem x !s)) !nc, !nc3) :: !sol;
                                        raise Exit;
                                ) else (
                                        match q with
                                                | 1 -> nc2:= couples !nc
                                                | 2 -> nc2:= triuplets !nc
                                                | _ -> nc2:= [!nc]
                                );
                        done;
                with Exit -> ());
                elimine m c nc;
                parcours_largeur (poss3 1);
        done;
        rev !sol;
;;


let parcours_profondeur0 poss maxsol =

        let nncc = !nc and res = ref [] and res1 = ref [] in
        try

        let retireposs poss nc =

                let rec retire1 i j = function
                        | [] -> []
                        | ((x,y,_)::q) when (x = i && y = j) -> q
                        | ((x,y,z)::q) -> (x,y,z) :: (retire1 i j q)
                in

                let rec retire2 poss = function
                        | [] -> poss
                        | ((i,j,_)::q) -> retire2 (retire1 i j poss) q
                in

                retire2 poss nc;
        in

        let rec ajouteenteteachaqueliste a = function
                | [] -> []
                | (b::q) -> (a::b) :: (ajouteenteteachaqueliste a q)
        in

        let rec testposscase m c poss i j z =
                try
                        nc:= [i,j,z];
                        print_endline ("case "^(string_of_int i)^","^(string_of_int j)^" test : "^(string_of_int z));
                        elimine m c nc;
                        res1:= (i,j,z) :: !res1;
                        if m.(0).(0).(0) then (
                                res:= (rev !res1) :: !res;
                                let s = wait_next_event [Poll] in
                                if s.keypressed || s.button then raise Exit;
                                res1:= tl !res1;
                                if !maxsol = 1 then raise Exit else decr maxsol;
                                [[i,j,z]];
                        ) else ajouteenteteachaqueliste (i,j,z) (parcours m c (retireposs poss !nc));
                with Failure s -> print_endline s ; []

        and parcours m c = function
                | [] -> []
                | ((_,_,[])::_) -> if !res1 <> [] then res1:= tl !res1 ; []
                | ((i,j,(z::q))::r) -> let mm = copy_trinityx m and cc = copy_trinityx c in
                                       let testijz = testposscase mm cc r i j z in
                                       testijz @ (parcours m c ((i,j,q)::r))
        in

        let sol = parcours m c poss in nc:= nncc ; true, sol

        with | Exit -> nc:= nncc ; false, rev !res
             | Break -> nc:= nncc ; false, rev !res
             | Out_of_memory -> nc:= nncc ; false, rev !res
;;

let parcours_profondeur poss = parcours_profondeur0 poss (ref 0) ;;

let parcours_prof () =

        let rec to_poss = function
                | [] -> []
                | ((i,j,z)::q) -> (i,j,[z]) :: (to_poss q)
        in

        let rec minimize = function
                | [] -> []
                | (a::q) -> (rev (hd (snd (parcours_profondeur (rev (to_poss a)))))) :: (minimize q)
        in

        let rec listlist_length = function
                | [] -> 0
                | (a::q) -> (length a) + (listlist_length q)
        in

        let b1,pp1 = parcours_profondeur (poss3 1)
        and b2,pp2 = parcours_profondeur (poss3 2)
        and b3,pp3 = parcours_profondeur (poss3 3) in

        let pp4 = minimize pp1 and pp5 = minimize pp2 and pp6 = minimize pp3 in

        if listlist_length pp4 < listlist_length pp5 then (
                if listlist_length pp4 <= listlist_length pp6 then b1,pp4 else b3,pp6
        ) else (if listlist_length pp5 <= listlist_length pp6 then b2,pp5 else b3,pp6);
;;

let solution_profondeur () =
        let sol = ref [!nc] in
        elimine m c nc;
        sol:= !nc :: !sol;
        let b, p = if !opt > 1 then parcours_prof() else parcours_profondeur (poss3 (!opt + 1)) in
        sol:= p @ !sol;
        b, rev !sol;
;;

let solution_unique () =
        elimine m c nc;
        let b,l = parcours_profondeur0 (poss3 2) (ref 2) in
        b && length l < 2;
;;

let matrixx () =

        let finit x =
                let mm = copy_trinityx m and cc = copy_trinityx c and nc = ref x in
                elimine mm cc nc;
                mm;
        in

        map matrix (map finit (snd (parcours_profondeur (poss3 2))));
;;


let generation () =

let rec generation_comp () =
        reset [];
        try
                for z = 1 to 8 do
                        for i = 1 to 8 do
		        	if m.(i).(0).(z) then (
                                        let j = ref (1 + int 9) in
                                        while not m.(i).(!j).(z) do
	        	                	j:= 1 + int 9;
                                                while not c.((i-1)/3).((!j-1)/3).(z) do
                                                        j:= 1 + int 9;
                                                done;
	                       		done;
                                        nc:= [i,!j,z];
                                        elimine m c nc;
                                );
                        done;
                done;
        with _ -> generation_comp()
in

let liste_cases m =
        nc:= [];
        for i = 9 downto 1 do
        for j = 9 downto 1 do
                nc:= (i,j,m.(i-1).(j-1)) :: !nc;
        done;
        done;
in

let liste_comp l =
        reset l;
        solution_unique();
in

let rand_perm n =
        let t = Array.make n 0 and b = Array.make (n+1) false and a = ref 0 in
        b.(0) <- true;
        for i = 0 to n-1 do
                while b.(!a) do a:= 1 + int n done;
                t.(i) <- !a;
                b.(!a) <- true;
        done;
        t;
in

let melange t =
        let n = Array.length t in
        let u = Array.make n t.(0) and p = rand_perm n in
        for i = 0 to n-1 do u.(i) <- t.(p.(i)-1) done;
        for i = 0 to n-1 do t.(i) <- u.(i) done;
in

let melange l =
        let t = of_list l in
        melange t;
        to_list t;
in

let rec minimalise l = function
        | [] -> l
        | (_::q) when liste_comp (l@q) -> minimalise l q
        | (a::q) -> minimalise (a::l) q
in

let minimalise l = minimalise [] l in


generation_comp();
liste_cases (matrix m);
reset (minimalise (melange !nc));
;;


let save0 m nc s =
        let rec maj m = function
                | [] -> ()
                | ((i,j,z)::q) -> m.(i-1).(j-1) <- z ; maj m q
        in
        let mm = matrix m in
        maj mm nc;
        chdir dir;
        let file = open_out (s ^ ext) in
        for i = 0 to 8 do
                for j = 0 to 8 do
                        output_string file (string_of_int mm.(i).(j));
                done;
                output_string file "\n";
        done;
        close_out file;
;;

let save = save0 m !nc ;;

let haschanged mm =
        try
                for i = 1 to 9 do
                for j = 1 to 9 do
                for z = 1 to 9 do
                        if not mm.(i).(j).(z) then raise Exit;
                done;
                done;
                done;
                false;
        with Exit -> true
;;

let save1 nc nncc mm s =
        chdir dir;
        let file = open_out (s ^ ext2) in
        let rec aux = function
                | [] -> output_string file "\n"
                | ((i,j,z)::q) -> output_string file ((string_of_int i)^(string_of_int j)^(string_of_int z));
                                  aux q
        in
        aux nncc;
        let rec isin i j = function
                | [] -> false
                | ((x,y,_)::q) -> if (x = i && y = j) then true else isin i j q
        in
        for i = 1 to 9 do
        for j = 1 to 9 do
                if not (isin i j nc) then (
                        let p = ref "" in
                        for z = 1 to 9 do
                                if not mm.(i).(j).(z) then p:= !p ^ (string_of_int z);
                        done;
                        if !p <> "" then output_string file ((string_of_int i)^(string_of_int j)^(!p)^"\n");
                );
        done;
        done;
        close_out file;
;;

let load s =
        chdir dir;
        let file = open_in (s ^ ext) in
        reset [];
        for i = 1 to 9 do
                let s = input_line file in
                for j = 1 to 9 do
                        let z = int_of_char s.[j-1] - 48 in
                        if z <> 0 then nc:= (i,j,z) :: !nc;
                done;
        done;
        nc:= rev !nc;
        close_in file;
;;

let load1 s =
        let ioc c = int_of_char c - 48
        and nc = ref [] and mm = Array.make_matrix 10 10 [||] in
        init_mc mm;
        chdir dir;
        let file = open_in (s ^ ext2) in
        let s = input_line file in
        for n = 0 to String.length s /3 -1 do
                nc:= (ioc s.[n*3], ioc s.[n*3+1], ioc s.[n*3+2]) :: !nc;
        done;
        try
                while true do
                        let s = input_line file in
                        for z = 2 to String.length s - 1 do
                                mm.(ioc s.[0]).(ioc s.[1]).(ioc s.[z]) <- false;
                        done;
                done;
                !nc, mm;
        with End_of_file -> close_in file ; !nc, mm
;;