homework.hs

type Grid = [String]

validGrid :: Grid -> Bool
validGrid [] = False
validGrid x  = allEqual $ map length x

validateGrid :: Grid -> Grid
validateGrid g@(validGrid -> True) = g
validateGrid _                     = error "Broken grid!"

lightsOutLite :: Grid -> Int
lightsOutLite (validateGrid -> g) = length $ filter (== '1') $ concat g

naiveMove :: Int -> Int --Size of the grid
          -> Int -> Int --Coordinates of the move
          -> Integer    --Resulting grid data
naiveMove width height moveX moveY = foldl set 0 $ (moveX, moveY) : neighbors where
    set bits (x, y)
        | x < 0 || y < 0 || x >= width || y >= height = bits
        | otherwise                                   = bits `setBit` ((y * width) + x)
    neighbors = [(moveX + i, moveY + j) | i <- [-1..1], j <- [-1..1], abs i + abs j == 1]

lightsOut :: [String] -> Int
lightsOut (validateGrid -> g) = solution [initial] S.empty 0 where
    (width, height) = (length g, length $ head g)
    maskGen = naiveMove width height
    moveMasks = [maskGen x y | y <- [0..height - 1], x <- [0..width - 1]]
    initial = foldl (\i (s, c) -> if c == '1' then i `setBit` s else i) 0 $ zip [0..] (concat g)
    getMoves node = map (xor node) moveMasks
    updateNodes nodes state = (newNodes, newSet) where
        newSet = foldr S.insert state nodes
        newCandidates = concatMap getMoves nodes
        newNodes = filter (`S.notMember` newSet) newCandidates
    solution []    _     _ = error "No solution"
    solution nodes state n = if 0 `elem` nodes then n else solution newNodes newState (n + 1) where
        (newNodes, newState) = updateNodes nodes state