nonograms.fsx

let solveByBacktracking moves solved initialState = 
    let rec inner state = 
        // to do: backtrack immediately if arrive at state we've seen before. (This can't happen for knight's tour or n queens as below.)
        match state with
            | Some progress when (progress |> solved |> not) ->
                progress |> moves |> Seq.map (Some >> inner) |> Seq.tryFind Option.isSome |> Option.flatten
            | _ -> state
    initialState |> Some |> inner

let describe row = 
    let groupContiguousBy projection list =
        let folder x groups = 
            let key = x |> projection
            match groups with 
            | (k, group)::rest when k = key ->
                (k, x::group)::rest
            | _ -> (key, [x])::groups
        [] |> Array.foldBack folder list
    row |> groupContiguousBy id |> List.where fst |> List.map (snd >> List.length)

let makePuzzle (grid: bool[,]) =
    let rows = [0..Array2D.length1 grid-1] |> List.map (fun i -> grid.[i,*])
    let columns = [0..Array2D.length2 grid-1] |> List.map (fun j -> grid.[*,j])
    (rows |> List.map describe, columns |> List.map describe)

let consistent description partial =
    ()

let solveNonogram (horizontals, verticals) = 
    let n = horizontals |> List.length
    let m = verticals |> List.length
    let solved (_, grid) = 
        makePuzzle grid = (horizontals, verticals)
    let moves (depth, grid) = 
        if depth < n*m then
            let i = depth / m
            let j = depth % n
            printfn "%A" (i, j)
            assert (i < Array2D.length1 grid)
            assert (j < Array2D.length2 grid)
            seq { 
                for x in [true; false] do 
                let copy = Array2D.copy grid
                copy.[i, j] <- x
                yield (depth+1, copy)
              }
        else
            Seq.empty
    let empty = Array2D.create n m false
    (0, empty) |> solveByBacktracking moves solved |> Option.map snd

let easy = [[false; true; false]; [true;true;false]] |> array2D
let solution = easy |> makePuzzle |> solveNonogram
solution |> printfn "%A"

// solveNonogram ([[3];[2;1];[3;2];[2;2];[6];[1;5];[6];[1];[2]], [[1;2];[3;1];[1;5];[7;1];[5];[3];[4];[3]]) |> printfn "%A"