Code Golf: Lights out

Answer 1

Haskell, 263 characters (277 and 285 before edit) (according to wc)

import List
o x=zipWith4(\a b c i->foldr1(/=)[a,b,c,i])x(f:x)$tail x++[f]
f=0>0
d t=mapM(\_->[f,1>0])t>>=c t
c(l:m:n)x=map(x:)$c(zipWith(/=)m x:n)$o x l
c[k]x=[a|a<-[[x]],not$or$o x k]
main=interact$unlines.u((['.','X']!!).fromEnum).head.d.u(<'.').lines
u=map.map

This includes IO code : you can simply compile it and it works. This method use the fact that once the first line of the solution is determined, it is easy to determine what the other lines should look like. So we try every solution for the first line, and verify that the all lights are off on the last line, and this algorithm is O(n²*2^n)

Edit : here is an un-shrunk version :

import Data.List

-- xor on a list. /= works like binary xor, so we just need a fold
xor = foldr (/=) False

-- what will be changed on a line when we push the buttons :
changeLine orig chg = zipWith4 (\a b c d -> xor [a,b,c,d]) chg (False:chg) (tail chg ++ [False]) orig

-- change a line according to the buttons pushed one line higher :
changeLine2 orig chg = zipWith (/=) orig chg

-- compute a solution given a first line.
-- if no solution is given, return []

solution (l1:l2:ls) chg = map (chg:) $ solution (changeLine2 l2 chg:ls) (changeLine l1 chg)
solution [l] chg = if or (changeLine l chg) then [] else [[chg]]


firstLines n = mapM (const [False,True]) [1..n]

-- original uses something equivalent to "firstLines (length gris)", which only
-- works on square grids.
solutions grid = firstLines (length $ head grid) >>= solution grid

main = interact $ unlines . disp . head . solutions . parse . lines
    where parse = map (map (\c ->
                                case c of
                                  '.' -> False
                                  '*' -> True))
          disp = map (map (\b -> if b then 'X' else '.'))

Answer 2

Ruby:

class Array
    def solve
        carry
        (0...(2**w)).each {|i|
            flip i
            return self if solved?
            flip i
        }
    end

    def flip(i)
        (0...w).each {|n|
            press n, 0 if i & (1 << n) != 0
        }
        carry
    end

    def solved?
        (0...h).each {|y|
            (0...w).each {|x|
                return false if self[y][x]
            }
        }
        true
    end

    def carry
        (0...h-1).each {|y|
            (0...w).each {|x|
                press x, y+1 if self[y][x]
            }
        }
    end

    def h() size end
    def w() self[0].size end

    def press x, y
        @presses = (0...h).map { [false] * w } if @presses == nil
        @presses[y][x] = !@presses[y][x]

        inv x, y
        if y>0 then inv x, y-1 end
        if y<h-1 then inv x, y+1 end
        if x>0 then inv x-1, y end
        if x<w-1 then inv x+1, y end
    end

    def inv x, y
        self[y][x] = !self[y][x]
    end

    def presses
        (0...h).each {|y|
            puts (0...w).map {|x|
                if @presses[y][x] then 'X' else '.' end
            }.inject {|a,b| a+b}
        }
    end
end

STDIN.read.split(/\n/).map{|x|x.split(//).map {|v|v == '*'}}.solve.presses

Answer 3

Lua, 499 characters

Fast, uses Strategy to find a quicker solution.

m={46,[42]=88,[46]=1,[88]=42}o={88,[42]=46,[46]=42,[88]=1}z={1,[42]=1}r=io.read
l=r()s=#l q={l:byte(1,s)}
for i=2,s do q[#q+1]=10 l=r()for j=1,#l do q[#q+1]=l:byte(j)end end
function t(p,v)q[p]=v[q[p]]or q[p]end
function u(p)t(p,m)t(p-1,o)t(p+1,o)t(p-s-1,o)t(p+s+1,o)end
while 1 do e=1 for i=1,(s+1)*s do
if i>(s+1)*(s-1)then if z[q[i]]then e=_ end
elseif z[q[i]]then u(i+s+1)end end
if e then break end
for i=1,s do if 42==q[i]or 46==q[i]then u(i)break end u(i)end end
print(string.char(unpack(q)))

Example input:

.....
.....
.....
.....
*...*

Example output:

XX...
..X..
X.XX.
X.X.X
...XX

Answer 4

F#, 365 370, 374, 444 including all whitespace

open System
let s(r:string)=
    let d=r.IndexOf"\n"
    let e,m,p=d+1,r.ToCharArray(),Random()
    let o b k=m.[k]<-char(b^^^int m.[k])
    while String(m).IndexOfAny([|'*';'\\'|])>=0 do
        let x,y=p.Next d,p.Next d
        o 118(x+y*e)
        for i in x-1..x+1 do for n in y-1..y+1 do if i>=0&&i<d&&n>=0&&n<d then o 4(i+n*e)
    printf"%s"(String m)

Here's the original readable version before the xor optimization. 1108

open System

let solve (input : string) =
    let height = input.IndexOf("\n")
    let width = height + 1

    let board = input.ToCharArray()
    let rnd = Random()

    let mark = function
        | '*' -> 'O'
        | '.' -> 'X'
        | 'O' -> '*'
        |  _  -> '.'

    let flip x y =
        let flip = function
            | '*' -> '.'
            | '.' -> '*'
            | 'X' -> 'O'
            |  _  -> 'X'

        if x >= 0 && x < height && y >= 0 && y < height then
            board.[x + y * width] <- flip board.[x + y * width]

    let solved() =
        String(board).IndexOfAny([|'*';'O'|]) < 0

    while not (solved()) do
        let x = rnd.Next(height) // ignore newline
        let y = rnd.Next(height)

        board.[x + y * width] <- mark board.[x + y * width]

        for i in -1..1 do
            for n in -1..1 do
                flip (x + i) (y + n)

    printf "%s" (String(board))

Answer 5

For Haskell, here's a 406 376 342 character solution, though I'm sure there's a way to shrink this. Call the s function for the first solution found:

s b=head$t(b,[])
l=length
t(b,m)=if l u>0 then map snd u else concat$map t c where{i=[0..l b-1];c=[(a b p,m++[p])|p<-[(x,y)|x<-i,y<-i]];u=filter((all(==False)).fst)c}
a b(x,y)=foldl o b[(x,y),(x-1,y),(x+1,y),(x,y-1),(x,y+1)]
o b(x,y)=if x<0||y<0||x>=r||y>=r then b else take i b++[not(b!!i)]++drop(i+1)b where{r=floor$sqrt$fromIntegral$l b;i=y*r+x}

In its more-readable, typed form:

solution :: [Bool] -> [(Int,Int)]
solution board = head $ solutions (board, [])

solutions :: ([Bool],[(Int,Int)]) -> [[(Int,Int)]]
solutions (board,moves) =
    if length solutions' > 0
        then map snd solutions'
        else concat $ map solutions candidates
    where 
        boardIndices = [0..length board - 1]
        candidates = [
            (applyMove board pair, moves ++ [pair]) 
                | pair <- [(x,y) | x <- boardIndices, y <- boardIndices]]
        solutions' = filter ((all (==False)) . fst) candidates

applyMove :: [Bool] -> (Int,Int) -> [Bool]
applyMove board (x,y) = 
    foldl toggle board [(x,y), (x-1,y), (x+1,y), (x,y-1), (x,y+1)]

toggle :: [Bool] -> (Int,Int) -> [Bool]
toggle board (x,y) = 
    if x < 0 || y < 0 || x >= boardSize || y >= boardSize then board
    else
        take index board ++ [ not (board !! index) ] 
            ++ drop (index + 1) board
    where 
        boardSize = floor $ sqrt $ fromIntegral $ length board
        index = y * boardSize + x

Note that this is a horrible breadth-first, brute-force algorithm.

Answer 6

Ruby, 225 221

---

b=$<.read.split
d=b.size
n=b.join.tr'.*','01'
f=2**d**2
h=0
d.times{h=h<<d|2**d-1&~1}
f.times{|a|e=(n.to_i(2)^a^a<<d^a>>d^(a&h)>>1^a<<1&h)&f-1
e==0&&(i=("%0*b"%[d*d,a]).tr('01','.X')
d.times{puts i[0,d]
i=i[d..-1]}
exit)}