Revision 24
Some minor bugs removed also.
Revision 23
1. A Stop statement inside source code removed. This stop engage when a gosub statement execute from a Case in a Select Case, and was there for debugging, so now removed.
2. Lcase$() found to trim a string (leading spaces and trailing spaces). This was not as planned, so trim function removed.
3.Addition for Group pointers, when point to a group which have a Set function. A Set function make the group to process in that function something which we assign to it.
This is the Minesweeper (16X16) written for rosettacode.org.
Module Minesweeper {
Font "Arial Black"
Bold 0
Form 88,40
Refresh 1000
Def com$, com_label$
Def x, b_row, b_col, where, top_where
Def rows=16, columns=16, swap_first%
Def boolean skiptest, end_game, cheat
Dim Board$(0 to rows+1, 0 to columns+1)="? "
Def mines%, i%, j%, used%, acc%, n%, m%
mines%=max.data(random(int(columns*rows*.1),int(columns*rows*.2)-1), 1)
For i%=1 to rows:For j%=1 to columns
Board$(i%,j%)=". "
Next j%:Next i%
used%=mines%
While used%
used%--
Do
i%=random(1,rows)
j%=random(1, columns)
Until right$(Board$(i%,j%),1)=" "
Board$(i%,j%)=".*"
End While
used%=rows*columns-mines%
\\ remove rem so to never loose from first open
Rem :
swap_first%=used%
\\ when mines%=0 or used%=0 then player win
Report {Minesweeper - rosettacode task
Commands:
- ? 1 2 flag/unflag 1 2
- 1 2 open 1 2
- q to quit
You can pass multiple commands in a line, but q erase all before execute
}
top_where=Row
While not End_Game {GameLoop()}
End
Sub PrintBoard()
Cls, top_where
Print
Print " X ";
For j%=1 to columns {
Print format$("{0::-3} ", j%);
}
Print
For i%=1 to rows {
Print format$(" {0::-3} ", i%);
For j%=1 to columns {
Print " ";Left$(Board$(i%,j%),1);" ";
\\ rem above and unrem follow line to display mines
Rem: Print " ";Board$(i%,j%)+" ";
}
Print
}
End Sub
Sub PrintMines()
Cls, top_where
Print
Print " X ";
For j%=1 to columns {
Print format$("{0::-3} ", j%);
}
Print
For i%=1 to rows {
Print format$(" {0::-3} ", i%);
For j%=1 to columns {
Print " ";Right$(Board$(i%,j%),1);" ";
}
Print
}
End Sub
Sub GameLoop()
'Local com$
Local loopagain as boolean
PrintBoard()
InputCommand()
do
loopagain=true
while not empty
\\ process game command
select case letter$
case "q "
Print "Quit" : end_game=True : exit
case "o "
OpenCell()
case "n "
OpenCell2()
case "? "
SwapCell()
case "c "
Exit Sub
End Select
End While
If mines%=0 or used%=0 then
PrintBoard(): Print "Player Win": end_game=True: Exit Sub
End if
If mines%=-1 then
if swap_first%=used% then
mines%=rows*columns-used%
Local n%, m%
While mines%
Let n%=random(1,rows), m%=random(1, columns)
If Board$(n%, m%)=". " then Board$(n%, m%)=".*" : mines%=0
End While
Board$(i%, j%)=". "
mines%=rows*columns-used%
swap_first%=-100
Push i%, j%, "o "
loopagain=false
else
PrintMines(): Print "Player Loose": end_game=True : Exit Sub
end if
End If
Until loopagain
Flush
Refresh if(End_Game->10,1000)
End Sub
Sub InputCommand()
where=row
While com$=""
cls, where
Print "x x | ? x x | q >";
Refresh 10
Try {
Input "", com$
}
End While
x=1
Flush
While com$<>""
com_label$=""
ParseCommand()
if len(com_label$)<>2 then
com$="" : Print com_label$ : Flush
Refresh 10
push key$ : drop
else
Data com_label$, b_col, b_row
End if
End While
Refresh 1000
End Sub
Sub ParseCommand()
com_label$="o "
skiptest=true
ReadColumn()
if len(com_label$)<>2 then
com$=""
Else.if x=-1 then
com_label$=lcase$(Left$(com$,1))+" "
com$=mid$(com$, 2)
x=1
if len(com_label$)<>2 then
com_label$="no command found"
else.if com_label$="? " then
ReadColumn()
if x>-1 then ReadRow()
else.if com_label$="c " then
cheat=true
else.if com_label$="q " then
flush
com$=""
else
com_label$="Use q or ? for commands"
com$=""
End if
else
ReadRow()
if x>-1 then com_label$="o "
End if
End Sub
Sub ReadRow()
com$=mid$(com$,x)
b_row=val(com$, "??", x)
if x=-1 then
com_label$="Need a row"
else.if b_row<1 or b_row>rows then
com_label$="Need a row from 1 to "+str$(rows)
x=-1
else
com$=mid$(com$,x+1)
x=1
End if
End Sub
Sub ReadColumn()
com$=mid$(com$,x)
b_col=val(com$, "??", x)
if x=-1 then
if not skiptest then com_label$="Need a column"
else.if b_col<1 or b_col>columns then
com_label$="Need a column from 1 to"+str$(columns)
else
com$=mid$(com$,x+1)
x=1
End if
skiptest=false
End Sub
Sub SwapCell()
Read j%, i%
If left$(Board$(i%,j%),1)="?" then
Board$(i%,j%) ="."+Right$(Board$(i%,j%),1)
If cheat Then if Right$(Board$(i%,j%),1)="*" then mines%++
Else.If left$(Board$(i%,j%),1)="." then
Board$(i%,j%) ="?"+Right$(Board$(i%,j%),1)
If cheat Then if Right$(Board$(i%,j%),1)="*" then mines%--
End if
End Sub
Sub OpenCell()
Read j%, i%
If left$(Board$(i%,j%),1)="." then {
if Right$(Board$(i%,j%),1)="*" then mines%=-1 : flush : exit
acc%=0
used%--
Local n%, m%
For n%=i%-1 to i%+1 {
For m%=j%-1 to j%+1 {
If Right$(Board$(n%,m%),1)="*" then acc%++
}
}
For n%=i%-1 to i%+1 {
For m%=j%-1 to j%+1 {
if not (n%=i% and m%=j%) then
if not Right$(Board$(n%,m%),1)="*" then
If left$(Board$(n%,m%),1)="." then
Push n%, m%, "n " ' reverse to stack
Rem : Print stack.size : Refresh
End If
End If
End If
}
}
Board$(i%,j%)=if$(acc%=0->" ",str$(acc%, "# "))
}
End Sub
Sub OpenCell2()
Read J%, i%
If left$(Board$(i%,j%),1)="." then {
if Right$(Board$(i%,j%),1)="*" then exit
acc%=0
used%--
For n%=i%-1 to i%+1 {
For m%=j%-1 to j%+1 {
If Right$(Board$(n%,m%),1)="*" then acc%++
}
}
\\ if cell has no mines around then we check all
if acc%=0 then
Local n%, m%
For n%=i%-1 to i%+1
For m%=j%-1 to j%+1
if not (n%=i% and m%=j%) then
if not Right$(Board$(n%,m%),1)="*" then
If left$(Board$(n%,m%),1)="." then
Push n%, m%, "o " ' reverse to stack
Rem : Print stack.size : Refresh
End If
End If
End If
Next m%
Next n%
End If
Board$(i%,j%)=if$(acc%=0->" ",str$(acc%, "# "))
}
End Sub
}
Minesweeper
Some minor bugs removed also.
Revision 23
1. A Stop statement inside source code removed. This stop engage when a gosub statement execute from a Case in a Select Case, and was there for debugging, so now removed.
2. Lcase$() found to trim a string (leading spaces and trailing spaces). This was not as planned, so trim function removed.
3.Addition for Group pointers, when point to a group which have a Set function. A Set function make the group to process in that function something which we assign to it.
This is the Minesweeper (16X16) written for rosettacode.org.
Module Minesweeper {
Font "Arial Black"
Bold 0
Form 88,40
Refresh 1000
Def com$, com_label$
Def x, b_row, b_col, where, top_where
Def rows=16, columns=16, swap_first%
Def boolean skiptest, end_game, cheat
Dim Board$(0 to rows+1, 0 to columns+1)="? "
Def mines%, i%, j%, used%, acc%, n%, m%
mines%=max.data(random(int(columns*rows*.1),int(columns*rows*.2)-1), 1)
For i%=1 to rows:For j%=1 to columns
Board$(i%,j%)=". "
Next j%:Next i%
used%=mines%
While used%
used%--
Do
i%=random(1,rows)
j%=random(1, columns)
Until right$(Board$(i%,j%),1)=" "
Board$(i%,j%)=".*"
End While
used%=rows*columns-mines%
\\ remove rem so to never loose from first open
Rem :
swap_first%=used%
\\ when mines%=0 or used%=0 then player win
Report {Minesweeper - rosettacode task
Commands:
- ? 1 2 flag/unflag 1 2
- 1 2 open 1 2
- q to quit
You can pass multiple commands in a line, but q erase all before execute
}
top_where=Row
While not End_Game {GameLoop()}
End
Sub PrintBoard()
Cls, top_where
Print " X ";
For j%=1 to columns {
Print format$("{0::-3} ", j%);
}
For i%=1 to rows {
Print format$(" {0::-3} ", i%);
For j%=1 to columns {
Print " ";Left$(Board$(i%,j%),1);" ";
\\ rem above and unrem follow line to display mines
Rem: Print " ";Board$(i%,j%)+" ";
}
}
End Sub
Sub PrintMines()
Cls, top_where
Print " X ";
For j%=1 to columns {
Print format$("{0::-3} ", j%);
}
For i%=1 to rows {
Print format$(" {0::-3} ", i%);
For j%=1 to columns {
Print " ";Right$(Board$(i%,j%),1);" ";
}
}
End Sub
Sub GameLoop()
'Local com$
Local loopagain as boolean
PrintBoard()
InputCommand()
do
loopagain=true
while not empty
\\ process game command
select case letter$
case "q "
Print "Quit" : end_game=True : exit
case "o "
OpenCell()
case "n "
OpenCell2()
case "? "
SwapCell()
case "c "
Exit Sub
End Select
End While
If mines%=0 or used%=0 then
PrintBoard(): Print "Player Win": end_game=True: Exit Sub
End if
If mines%=-1 then
if swap_first%=used% then
mines%=rows*columns-used%
Local n%, m%
While mines%
Let n%=random(1,rows), m%=random(1, columns)
If Board$(n%, m%)=". " then Board$(n%, m%)=".*" : mines%=0
End While
Board$(i%, j%)=". "
mines%=rows*columns-used%
swap_first%=-100
Push i%, j%, "o "
loopagain=false
else
PrintMines(): Print "Player Loose": end_game=True : Exit Sub
end if
End If
Until loopagain
Flush
Refresh if(End_Game->10,1000)
End Sub
Sub InputCommand()
where=row
While com$=""
cls, where
Print "x x | ? x x | q >";
Refresh 10
Try {
Input "", com$
}
End While
x=1
Flush
While com$<>""
com_label$=""
ParseCommand()
if len(com_label$)<>2 then
com$="" : Print com_label$ : Flush
Refresh 10
push key$ : drop
else
Data com_label$, b_col, b_row
End if
End While
Refresh 1000
End Sub
Sub ParseCommand()
com_label$="o "
skiptest=true
ReadColumn()
if len(com_label$)<>2 then
com$=""
Else.if x=-1 then
com_label$=lcase$(Left$(com$,1))+" "
com$=mid$(com$, 2)
x=1
if len(com_label$)<>2 then
com_label$="no command found"
else.if com_label$="? " then
ReadColumn()
if x>-1 then ReadRow()
else.if com_label$="c " then
cheat=true
else.if com_label$="q " then
flush
com$=""
else
com_label$="Use q or ? for commands"
com$=""
End if
else
ReadRow()
if x>-1 then com_label$="o "
End if
End Sub
Sub ReadRow()
com$=mid$(com$,x)
b_row=val(com$, "??", x)
if x=-1 then
com_label$="Need a row"
else.if b_row<1 or b_row>rows then
com_label$="Need a row from 1 to "+str$(rows)
x=-1
else
com$=mid$(com$,x+1)
x=1
End if
End Sub
Sub ReadColumn()
com$=mid$(com$,x)
b_col=val(com$, "??", x)
if x=-1 then
if not skiptest then com_label$="Need a column"
else.if b_col<1 or b_col>columns then
com_label$="Need a column from 1 to"+str$(columns)
else
com$=mid$(com$,x+1)
x=1
End if
skiptest=false
End Sub
Sub SwapCell()
Read j%, i%
If left$(Board$(i%,j%),1)="?" then
Board$(i%,j%) ="."+Right$(Board$(i%,j%),1)
If cheat Then if Right$(Board$(i%,j%),1)="*" then mines%++
Else.If left$(Board$(i%,j%),1)="." then
Board$(i%,j%) ="?"+Right$(Board$(i%,j%),1)
If cheat Then if Right$(Board$(i%,j%),1)="*" then mines%--
End if
End Sub
Sub OpenCell()
Read j%, i%
If left$(Board$(i%,j%),1)="." then {
if Right$(Board$(i%,j%),1)="*" then mines%=-1 : flush : exit
acc%=0
used%--
Local n%, m%
For n%=i%-1 to i%+1 {
For m%=j%-1 to j%+1 {
If Right$(Board$(n%,m%),1)="*" then acc%++
}
}
For n%=i%-1 to i%+1 {
For m%=j%-1 to j%+1 {
if not (n%=i% and m%=j%) then
if not Right$(Board$(n%,m%),1)="*" then
If left$(Board$(n%,m%),1)="." then
Push n%, m%, "n " ' reverse to stack
Rem : Print stack.size : Refresh
End If
End If
End If
}
}
Board$(i%,j%)=if$(acc%=0->" ",str$(acc%, "# "))
}
End Sub
Sub OpenCell2()
Read J%, i%
If left$(Board$(i%,j%),1)="." then {
if Right$(Board$(i%,j%),1)="*" then exit
acc%=0
used%--
For n%=i%-1 to i%+1 {
For m%=j%-1 to j%+1 {
If Right$(Board$(n%,m%),1)="*" then acc%++
}
}
\\ if cell has no mines around then we check all
if acc%=0 then
Local n%, m%
For n%=i%-1 to i%+1
For m%=j%-1 to j%+1
if not (n%=i% and m%=j%) then
if not Right$(Board$(n%,m%),1)="*" then
If left$(Board$(n%,m%),1)="." then
Push n%, m%, "o " ' reverse to stack
Rem : Print stack.size : Refresh
End If
End If
End If
Next m%
Next n%
End If
Board$(i%,j%)=if$(acc%=0->" ",str$(acc%, "# "))
}
End Sub
}
Minesweeper
Δεν υπάρχουν σχόλια:
Δημοσίευση σχολίου
You can feel free to write any suggestion, or idea on the subject.