nonogram.elm

import Graphics.Element exposing (show)
import List exposing (map, map2, length, repeat, concat, sum, foldl, filterMap, isEmpty, member, head, tail, indexedMap, filter)
import Maybe exposing (andThen)
import Color
import Graphics.Element exposing (..)

--main = show <| constrainLine [1, 1] [Nothing, Just False, Nothing, Nothing]
--main = show <| tile [1, 1] [Nothing, Just False, Nothing, Nothing]
main = showGrid <| Maybe.withDefault grid0 <| constrainGrid rows cols grid0 `andThen` 
                                              constrainGrid rows cols `andThen`
                                              constrainGrid rows cols `andThen`
                                              constrainGrid rows cols

showGrid : List (List (Maybe Bool)) -> Element
showGrid xss = 
  let
    n = length xss
    w = 800
    h = 800
    side = min (w // n) (h // n)
    renderRows rows = flow down (map renderRow rows)
    renderRow row = flow right (map renderCell row)
    renderCell cell = 
      let 
        squareColor = case cell of
          Just True -> Color.black
          Just False -> Color.white
          Nothing -> Color.lightGrey
        square = spacer side side
      in 
        square |> color squareColor
  in
    container w h middle <| renderRows xss
    
rows = [
    [7, 3, 1, 1, 7],
    [1, 1, 2, 2, 1, 1],
    [1, 3, 1, 3, 1, 1, 3, 1],
    [1, 3, 1, 1, 6, 1, 3, 1],
    [1, 3, 1, 5, 2, 1, 3, 1],
    [1, 1, 2, 1, 1],
    [7, 1, 1, 1, 1, 1, 7],
    [3, 3],
    [1, 2, 3, 1, 1, 3, 1, 1, 2],
    [1, 1, 3, 2, 1, 1],
    [4, 1, 4, 2, 1, 2],
    [1, 1, 1, 1, 1, 4, 1, 3],
    [2, 1, 1, 1, 2, 5],
    [3, 2, 2, 6, 3, 1],
    [1, 9, 1, 1, 2, 1],
    [2, 1, 2, 2, 3, 1],
    [3, 1, 1, 1, 1, 5, 1],
    [1, 2, 2, 5],
    [7, 1, 2, 1, 1, 1, 3],
    [1, 1, 2, 1, 2, 2, 1],
    [1, 3, 1, 4, 5, 1],
    [1, 3, 1, 3, 10, 2],
    [1, 3, 1, 1, 6, 6],
    [1, 1, 2, 1, 1, 2],
    [7, 2, 1, 2, 5]
    ]

cols = [
    [7, 2, 1, 1, 7],
    [1, 1, 2, 2, 1, 1],
    [1, 3, 1, 3, 1, 3, 1, 3, 1],
    [1, 3, 1, 1, 5, 1, 3, 1],
    [1, 3, 1, 1, 4, 1, 3, 1],
    [1, 1, 1, 2, 1, 1],
    [7, 1, 1, 1, 1, 1, 7],
    [1, 1, 3],
    [2, 1, 2, 1, 8, 2, 1],
    [2, 2, 1, 2, 1, 1, 1, 2],
    [1, 7, 3, 2, 1],
    [1, 2, 3, 1, 1, 1, 1, 1],
    [4, 1, 1, 2, 6],
    [3, 3, 1, 1, 1, 3, 1],
    [1, 2, 5, 2, 2],
    [2, 2, 1, 1, 1, 1, 1, 2, 1],
    [1, 3, 3, 2, 1, 8, 1],
    [6, 2, 1],
    [7, 1, 4, 1, 1, 3],
    [1, 1, 1, 1, 4],
    [1, 3, 1, 3, 7, 1],
    [1, 3, 1, 1, 1, 2, 1, 1, 4],
    [1, 3, 1, 4, 3, 3],
    [1, 1, 2, 2, 2, 6, 1],
    [7, 1, 3, 2, 1, 1]
    ]

givens = [
  (3, 3), (3, 4), (3, 12), (3, 13), (3, 21),
  (8, 6), (8, 7), (8, 10), (8, 14), (8, 15), (8, 18),
  (16, 6), (16, 11), (16, 16), (16, 20),
  (21, 3), (21, 4), (21, 9), (21, 10), (21, 15), (21, 20), (21, 21)
    ]

grid0 = 
  let 
    ixes = map (\_ -> [0..24]) [0..24]
  in
    indexedMap (\r row -> map (\c -> if (r, c) `member` givens then Just True else Nothing) row) ixes


constrainGrid : List (List Int) -> List (List Int) -> List (List (Maybe Bool)) -> Maybe (List (List (Maybe Bool)))
constrainGrid rows cols xs = (constrainSide rows xs) `andThen` (transpose >> constrainSide cols >> Maybe.map transpose)

constrainSide : List (List Int) -> List (List (Maybe Bool)) -> Maybe (List (List (Maybe Bool)))
constrainSide cs xs = sequence <| map2 constrainLine cs xs

constrainLine : List Int -> List (Maybe Bool) -> Maybe (List (Maybe Bool))
constrainLine cs xs = 
  let 
    xs2 : List (List Bool)
    xs2 = tile cs xs
    f : List Bool -> Maybe (Maybe Bool)
    f l = case l of 
      (x :: xs) -> Just <| if not x `member` xs then Nothing else Just x
      [] -> Debug.crash "chief, all fucked up"
  in
    if isEmpty xs2 then
      Nothing
    else
      Just <| filterMap f <| transpose xs2

tile : List Int -> List (Maybe Bool) -> List (List Bool)
tile cons xs = case cons of
  []     -> maybeToList <| xs ~> repeat (length xs) False
  (con::cs) -> 
    let
      v gap = 
        let
          (false, xs') = splitAt gap xs
          (true, xs'')  = splitAt con xs'
          (space, xs''') = splitAt 1 xs''
          a = Maybe.withDefault [] <| false ~> repeat gap False
          b = Maybe.withDefault [] <| true ~> repeat con True
          c = Maybe.withDefault [] <| space ~> repeat (length space) False
        in
          (xs''', a, b, c)
      aux (rest, a, b, c) = map (\r -> a ++ b ++ c ++ r) <| tile cs rest
      nl = length xs
    in
      filter (\l -> length l == nl) <| concat (map (\gap -> aux (v gap)) [0 .. length xs - (con + sum cs + length cs)])

(~>) : List (Maybe Bool) -> List Bool -> Maybe (List Bool)
(~>) xs ys = 
  if length xs == length ys && and (map2 (\x y -> maybe True (\x -> x == y) x) xs ys) then
    Just ys
  else
    Nothing

maybeToList : Maybe a -> List a
maybeToList m = case m of
  Just x -> [x]
  Nothing -> []
 
splitAt : Int -> List a -> (List a, List a)
splitAt n xs = (List.take n xs, List.drop n xs)

and : List Bool -> Bool
and = foldl (&&) True

maybe : b -> (a -> b) -> Maybe a -> b
maybe d f m = Maybe.withDefault d <| Maybe.map f m

sequence : List (Maybe a) -> Maybe (List a)
sequence xs = 
  let 
    go : List (Maybe a) -> List a -> Maybe (List a)
    go list acc = 
      case list of
        [] -> Just acc
        (Just v :: rest) -> go rest (acc ++ [v])
        (Nothing :: _) -> Nothing
  in
    go xs []

transpose : List (List a) -> List (List a)
transpose ll =
  case ll of
    [] -> []
    ([]::xss) -> transpose xss
    ((x::xs)::xss) ->
      let
        heads = filterMap head xss
        tails = filterMap tail xss
      in
        (x::heads)::transpose (xs::tails)