Ruzzle solver in OCaml

ruzzle.ml

type 'a arbre = N of ('a * 'a arbre) list

let read_file filename =
    let chan = open_in filename in
    let mots = ref [] in
    try while true do
        mots := input_line chan::!mots;
    done; []
    with End_of_file -> close_in chan; !mots

let prefixes dico =
    let ajouter arbre mot =
        let n = String.length mot in
        let rec largeur i = function
            | [] -> [mot.[i], profondeur (N []) (i + 1)]
            | (l, a)::t -> if l == mot.[i] then (l, profondeur a (i + 1))::t else (l, a)::largeur i t
        and profondeur arbre i =
            if i = n then arbre else match arbre with
                | N [] -> N [mot.[i], profondeur (N []) (i + 1)]
                | N liste -> N (largeur i liste)
        in profondeur arbre 0
    in List.fold_left ajouter (N []) dico

let _ =
    let grille = [|"DLUD"; "IOEE"; "NSNI"; "ADPN"|] in
    let dirs = [(-1, -1); (-1, 0); (-1, 1); (0, -1); (0, 1); (1, -1); (1, 0); (1, 1)] in
    let ruzzle racine =
        let dejavu = Array.make 16 false in
        let rec parcours noeud pref i j =
            if i >= 0 && i < 4 && j >= 0 && j < 4 && not dejavu.(4 * i + j) then (
                let fouille (lettre, sousarbre) =
                    if grille.(i).[j] = lettre then (
                        dejavu.(4 * i + j) <- true;
                        if sousarbre = N [] then Printf.printf "%s\n" (pref ^ String.make 1 lettre);
                        List.iter (function (di, dj) -> parcours sousarbre (pref ^ String.make 1 lettre) (i + di) (j + dj)) dirs;
                        dejavu.(4 * i + j) <- false;
                    )
                in match noeud with
                    | N [] -> ()
                    | N fils -> List.iter fouille fils
            )
        in for i = 0 to 3 do
            for j = 0 to 3 do
                parcours racine "" i j
            done
        done
    in ruzzle (prefixes (read_file "dico.txt")) (* dico.txt : http://zyzzyva.net/lexicons/ODS6.txt *)