# Lights Out Game In Fortran

Here’s an implementation of the Lights out game in fortran. Wrote this in 2011 and found it yesterday. Works as it is and can be improved. Checkout the screenshot.

For those who don’t know, here’s a brief description from wikipedia

The game consists of a 5 by 5 grid of lights. When the game starts, a random number or a stored pattern of these lights is switched on. Pressing any of the lights will toggle it and the four adjacent lights. The goal of the puzzle is to switch all the lights off, preferably in as few button presses as possible.

module lightsout
implicit none
integer :: elements(0:25)
integer :: iswon,moves
logical,parameter :: debug =.false.
character*30 :: sdata(4)

contains

subroutine printtable1()
integer :: i,j,ii,jj

sdata(1)='        _\|/_        '
sdata(2)='        (o o)        '
sdata(3)='+----oOO-{_}-OOo----+'

do i=1,3
write(*,'(a30)') sdata(i)
end do
write(*,'(6(2x,a))')  ' ','a','b','c','d','e'
ii=0
jj=4
do j=1,5
!      write(*,'(6i3)') j,(elements(i),i=ii,jj)
write(*,'(i3,5a3)') j,(achar(elements(i)+46),i=ii,jj)
ii=jj+1
jj=ii+4
end do

!    if(debug) then
!    print *,"Degub mode:"
!    write(*,'(5i8)')(elements(i),i=0,24)
!    end if

end subroutine

subroutine printtable()
integer :: i,j,ii,jj

sdata(1)='        _\|/_        '
sdata(2)='        (o o)        '
sdata(3)='+----oOO-{_}-OOo----+'

do i=1,3
write(*,'(a30)') sdata(i)
end do
write(*,'(6(1x,a,2x))')  ' ','a','b','c','d','e'
ii=1

write(*,'(7(5a))')'    ','___','.','___','.','___','.','___','.','___','.'
do i=1,5
do j=1,5

if(elements(ii) .eq. 0) then
else
end if
ii=ii+1
end do
write(*,*)
write(*,'(i3,5(5a))')i,'.','___','|','___','|','___','|','___','|','___','|'
end do

!    if(debug) then
!    print *,"Degub mode:"
!    write(*,'(5i8)')(elements(i),i=0,24)
!    end if

end subroutine

subroutine fillall()
integer :: i
do i =0 , 24
elements(i)=1
end do
end subroutine

subroutine clearall()
integer :: i
do i = 0, 24
elements(i)=0
end do
end subroutine

subroutine level1()
iswon=0
moves=0
call clearall()
elements(10)=1
elements(12)=1
elements(14)=1
end subroutine

subroutine level2()
iswon=0
moves=0
call clearall();
elements (12)=1;
elements (16)=1;
elements (17)=1;
elements (18)=1;
elements (20)=1;
elements (21)=1;
elements (22)=1;
elements (23)=1;
elements (24)=1;
end subroutine

subroutine level3()
iswon=0
moves=0
call fillall();
elements (4)=0;
elements (6)=0;
elements (7)=0;
elements (8)=0;
elements (11)=0;
elements (12)=0;
elements (13)=0;
elements (16)=0;
elements (17)=0;
elements (18)=0;
elements (24)=0;
end subroutine

subroutine level4()
iswon=0
moves=0
call clearall();
elements (2)=1;
elements (6)=1;
elements (8)=1;
elements (10)=1;
elements (12)=1;
elements (14)=1;
elements (16)=1;
elements (18)=1;
elements (22)=1;
end subroutine

subroutine level5()
iswon=0
moves=0
call clearall();
elements (11)=1;
elements (16)=1;
elements (21)=1;
end subroutine

subroutine checkall()
integer :: win,i
win=1;
do i = 0 ,24
if (elements (i)==0) then
win=0;
end if
end do

if (win==1) then
call printtable()
write(*,*) "You Won!!"
write(*,*) "You did it in ",moves, "moves"
iswon=1
end if
if(debug) print *,'7',iswon
end subroutine

subroutine check(v)
integer :: q,w,row,intv,a,b,c,d,kc,kd,kv,is,v
q=5;
w=1;
moves=moves+1
row=Int(v/q)+w;
intv =Int(v);
a=intv+q;
b=intv-q;
c=intv+w;
d=intv-w;
if(debug) print *, 'check',iswon
if(debug) print *, 'row a b c d', row,a,b,c,d
if (a<0 .or. a>24) then
a=25;
end if
if (b<0 .or. b>24) then
b=25;
end if
if (c<0 .or. c>24) then
c=25;
end if
if (d<0 .or. d>24) then
d=25;
end if
kc = (Int(c/q)+w)
kd = (Int(d/q)+w)
kv = row;
if (kc /= kv) then
c=25;
end if
if (kd /= kv) then
d=25;
end if
if (v==5) d=25;
if(debug) print *,'a b c d second', a,b,c,d
if ( elements (a) == 1) then
elements (a)=0;
else
elements (a)=1;
end if

if ( elements (b) == 1) then
elements (b)=0;
else
elements (b)=1;
end if

if ( elements (c) == 1) then
elements (c)=0;
else
elements (c)=1;
end if

if ( elements (d) == 1) then
elements (d)=0;
else
elements (d)=1;
end if

if ( elements (v) == 1) then
elements (v)=0;
else
elements (v)=1;
end if

if(debug) print *,'6',iswon
call checkall()
if(debug) print *, 'check',iswon
end subroutine

end module

program test
use lightsout
character*2 ::ss
integer :: ival,ilev
if(debug) call fillall()
if(debug) call printtable()
if(debug) print *, "*******"
if(debug) call clearall()
if(debug)  call printtable()

if(debug)  print *, "*******"
if(debug)  call level1()
if(debug)  call printtable()
if(debug)  print *, "*******"
if(debug)  call level2()
if(debug)  call printtable()
if(debug)  print *, "*******"
if(debug)  call level3()
if(debug)  call printtable()
if(debug)  print *, "*******"
if(debug)  call level4()
if(debug)  call printtable()
if(debug)  print *, "*******"
if(debug)  call level5()
if(debug)  call printtable()

ival=0
ilev=1
call level1()

do while(.true.)
if(debug)  print *,iswon,ilev
if(iswon .ne. 0) then
ilev=ilev+1
print *, "Entering level :" ,ilev
if (ilev == 2) call level2
if (ilev == 3) call level3
if (ilev == 4) call level4
if (ilev == 5) call level5
end if

call printtable()
if(debug) print *,'2',iswon,ilev
call givevalue(ss,ival)
if(debug)  print *, ival
if (ival .eq. 999) exit
if(debug) print *,'3',iswon,ilev
if(ival .ne. -1) call check(ival)
if(debug) print *,'4',iswon,ilev

end do
contains

subroutine givevalue(sstext,value)
character*2 :: sstext
integer :: value,i,k

if (sstext(1:1) .eq. 'q') then
value=999
end if

select case(sstext(1:1))

case('a')
i=1
case ('b')
i=2
case ('c')
i=3
case ('d')
i=4
case ('e')
i=5
case default
i=-1
value=-1
end select

if (k <7 .and. k .ne. 0) then
value=(i-1)+(k-1)*5
else
value=-1
k=-1
end if
if(debug) print *, k,i,value
return
100  value =999

end subroutine

end program