gbg.bas

   1 /'
   2 Generic Block Game
   3 Copyright 2008, 2018 Pajo <xpio at tut dot by>
   4
   5 This program is free software: you can redistribute it and/or modify
   6 it under the terms of the GNU General Public License as published by
   7 the Free Software Foundation, either version 3 of the License, or
   8 (at your option) any later version.
   9
  10 This program is distributed in the hope that it will be useful,
  11 but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 GNU General Public License for more details.
  14
  15 You should have received a copy of the GNU General Public License
  16 along with this program.  If not, see <https://www.gnu.org/licenses/>.
  17 '/
  18
  19 #include "fbgfx.bi"
  20 Using fb
  21
  22 Const GFXPATH="gfx"
  23 Const VARPATH="variations"
  24 Dim Shared nextvariation As String
  25 Dim Shared title As String
  26 ReDim Shared help () As String
  27 Dim Shared As UByte playabletiles, numberoftiles
  28 Dim Shared As Short columns=1, rows=1
  29 Dim Shared As Byte wrap,gravity,randominputs,randomgoals,showscore=False
  30 Dim Shared score as short=0
  31 ReDim Shared tilesfiles(0) As String
  32 Dim Shared speed as single=3
  33 ReDim Shared randomtable() As UByte
  34 Dim Shared tim as Double
  35
  36 Declare Function loadgame(filename As String) As Byte
  37 Declare Sub loadTiles(increment As Byte=1)
  38 Declare Sub initplayfield()
  39
  40
  41 Sub resizewindow(w As UShort, h As UShort, t As String = title)
  42         Dim As Integer x, y
  43         ScreenControl GET_WINDOW_POS, x, y
  44         ScreenRes w, h, 16, 2
  45         WindowTitle(t)
  46         If x > 0 And y > 0 Then ScreenControl SET_WINDOW_POS, x, y
  47 End Sub
  48
  49
  50 Function asctonumber(ch As UByte) As UByte
  51         If ch=46 Then : Return 0
  52         ElseIf ch=33 Then : Return 254 'start=!=254
  53         ElseIf ch=Asc("@") Then : Return 253 'exit=@=253
  54         ElseIf ch>=48 And ch<=57 Then : Return ch-48
  55         ElseIf ch>=65 And ch<=90 Then : Return ch-65+10
  56         ElseIf ch>=97 And ch<=122 Then : Return ch-97+36
  57         Else : Return 255
  58         End If
  59 End Function
  60
  61 Function getImgWidth(filename As String) As Short
  62         Open filename For Input As #2
  63         If Err>0 Then Return 0
  64         Dim w As Integer
  65         Get #2,19,w
  66         Close #2
  67         Return w
  68 End Function
  69
  70 ReDim Shared inputsindex(0) As UByte 'pokazuje krajeve
  71 ReDim Shared inputs(0,2) As UByte
  72 ReDim Shared goals(0,2) As UByte
  73 Sub loadshapes(shapes() As UByte, filename As String, index As Byte=False)
  74         Dim l as String
  75         Dim currentpoint As Short=0
  76         Dim As UByte a,b=0,currentshape=0
  77         Do Until l="}" Or Eof(1)
  78                 Line Input #1,l
  79                 If l="" Then
  80                         b=0
  81                         shapes(currentpoint,0)=255
  82                         shapes(currentpoint,1)=255
  83                         shapes(currentpoint,2)=255 'end shape
  84                         If index Then
  85                                 ReDim Preserve inputsindex(currentshape)
  86                                 inputsindex(currentshape)=currentpoint
  87                                 currentshape+=1
  88                         End if
  89                         currentpoint+=1
  90                         ReDim Preserve shapes(currentpoint,2)
  91                 ElseIf l<>"}" Then
  92                         For a=0 To Len(l)-1
  93                                 shapes(currentpoint,0)=a
  94                                 shapes(currentpoint,1)=b
  95                                 If l[a]=46 Then : shapes(currentpoint,2)=0
  96                                 Else : shapes(currentpoint,2)=asctonumber(l[a])
  97                                 End If
  98                                 currentpoint+=1
  99                                 ReDim Preserve shapes(currentpoint,2)
 100                         Next
 101                         b+=1
 102                 EndIf
 103         Loop
 104         shapes(currentpoint,0)=255
 105         shapes(currentpoint,1)=255
 106         shapes(currentpoint,2)=255 'end shape
 107         If index Then
 108                 ReDim Preserve inputsindex(currentshape)
 109                 inputsindex(currentshape)=currentpoint
 110         End If
 111 End Sub
 112
 113
 114 Declare Sub gameOver()
 115
 116 Dim Shared playfield(0 to columns-1,0 to rows-1) as UByte
 117 Dim Shared originalplayfield(0 to columns-1,0 to rows-1) as UByte
 118
 119 Type block
 120         'Declare Constructor
 121         Declare Sub init()
 122         Declare Sub update(justerase As Byte = False)
 123         Declare Sub drop()
 124         Declare Function move(as Byte,as Byte=0,As UByte=0) As Byte
 125         As UByte typ
 126         As Short x,y
 127 private:
 128         Declare Function isblocked(x as Byte, y As Byte=0, typ As UByte=0, mode As Byte=False) As Byte
 129         As Short oldx,oldy
 130         As UByte oldtyp
 131 end type
 132
 133 ReDim Shared nextshape() As UByte
 134
 135 Function block.isblocked(x as Byte, y As Byte=0, typ As UByte=0, mode As Byte=False) As Byte
 136         Dim As Short strt, stp, a
 137         Dim As Byte failed
 138
 139         If typ=1 Then strt=0 Else strt=inputsindex(typ-1-1)+1 'preskace se ona 255 tacka
 140         stp=inputsindex(typ-1)-1 'izostavlja se ona 255 tacka
 141         'mode=True = ispituje se origin
 142         For a = strt To stp
 143                 failed=inputs(a,2)<>0 And _
 144                 playfield(x+inputs(a,0),y+inputs(a,1))<>254 And _
 145                 playfield(x+inputs(a,0),y+inputs(a,1))<>253
 146                 If Not mode Then failed=failed And playfield(x+inputs(a,0),y+inputs(a,1))<>0
 147                 failed=failed Or y+inputs(a,1)>=rows _
 148                 Or y+inputs(a,1)<0 _
 149                 Or x+inputs(a,0)>=columns _
 150                 Or x+inputs(a,0)<0
 151                 If failed Then Exit For
 152         Next
 153         Return failed
 154 End Function
 155
 156
 157 Sub block.init()
 158         If randominputs Then 'permutovati brojeve od 1 do playabletiles
 159                 Dim a As UByte
 160                 ReDim randomtable(playabletiles) As UByte
 161                 For a = 1 To playabletiles
 162                         randomtable(a)=fix(rnd*playabletiles)+1
 163                 Next
 164         EndIf
 165
 166         Type xy
 167                 As UByte x,y
 168         End Type
 169         ReDim startpositions(0) As xy
 170         Dim posnumber As UShort=0
 171         Dim As UShort x,y
 172         Dim starttyp As UByte
 173         this.typ=Fix(RND*(UBound(inputsindex)+1))+1
 174         starttyp=this.typ
 175         Do
 176            For y=0 to rows-1 : For x=0 to columns-1
 177                 If originalplayfield(x,y)=254 Then
 178                         If Not this.isblocked(x,y,this.typ,True) Then  'dodaj na listu
 179                                         ReDim Preserve startpositions(posnumber) As xy
 180                                         startpositions(posnumber)=Type(x,y)
 181                                         posnumber+=1
 182                         EndIf
 183                 EndIf
 184            Next x: Next y
 185            If posnumber=0 Then
 186                 this.typ=nextshape(this.typ)
 187                         If this.typ=starttyp Then
 188                                 gameOver()
 189                                 Return
 190                         EndIf
 191            EndIf
 192         Loop Until posnumber>0
 193         posnumber=fix(rnd*posnumber)
 194         this.x=startpositions(posnumber).x
 195         this.y=startpositions(posnumber).y
 196         this.oldx=this.x
 197         this.oldy=this.y
 198         this.oldtyp=this.typ
 199 End Sub
 200
 201 'Constructor block
 202         'constructor bi se pokretao kod samog deklarisanja, pre playfielda
 203 'End Constructor
 204
 205 Function getshapewidthheight(typ As UByte,geth As Byte = False) As Short
 206         Dim As Short strt, stp, a, maxwidth=0, maxheight=0
 207
 208         If typ=1 Then strt=0 Else strt=inputsindex(typ-1-1)+1 'preskace se ona 255 tacka
 209         stp=inputsindex(typ-1)-1 'izostavlja se ona 255 tacka
 210         For a = strt To stp
 211                 If maxwidth<inputs(a,0) Then maxwidth=inputs(a,0)
 212                 If maxheight<inputs(a,1) Then maxheight=inputs(a,1)
 213         Next
 214         If geth Then Return maxheight
 215         Return maxwidth
 216 End Function
 217
 218
 219 Function block.move(x as Byte, y As Byte=0, typ As UByte=0) As Byte 'successful?True/False
 220         Dim As Byte dw,dh
 221         If typ=0 Then
 222                  typ=this.typ
 223         Else
 224                 '!centriranje
 225                 dw=(getshapewidthheight(this.typ)-getshapewidthheight(typ)) / 2
 226                 If gravity Then
 227                         dh=0
 228                 Else
 229                         dh=(getshapewidthheight(this.typ,True)-getshapewidthheight(typ,True)) / 2
 230                 EndIf
 231         EndIf
 232         this.oldx=this.x
 233         this.oldy=this.y
 234         this.oldtyp=this.typ
 235         this.update(True) 'just erase oldx i oldy
 236
 237         this.x=x + this.x + dw
 238         this.y=y + this.y + dh
 239         If wrap Then
 240                 this.x=(this.x + columns) Mod columns
 241                 If Not gravity Then this.y=(this.y + rows) Mod rows
 242         EndIf
 243 /'
 244                         failed=failed Or y+inputs(a,1)>=rows _
 245                         Or y+inputs(a,1)<0 _
 246                         Or x+inputs(a,0)>=columns _
 247                         Or x+inputs(a,0)<0
 248 '/
 249
 250         Dim As Byte failed
 251         failed=this.isblocked(this.x,this.y,typ)
 252         If failed Then
 253                 this.x=this.oldx
 254                 this.y=this.oldy
 255                 this.typ=this.oldtyp
 256         Else
 257                 this.typ=typ
 258         EndIf
 259         this.update()
 260         Return Not failed
 261
 262 End Function
 263
 264
 265 Sub markshape(shapestart As Short,shapeend As Short,x As Short,y As Short)
 266         Dim As Short mx,my,q
 267         For q=shapestart To shapeend-1
 268                 mx=x-goals(q,0)
 269                 my=y-goals(q,1)
 270                 If goals(q,2)<>0 And playfield(mx,my)<100 Then
 271                         playfield(mx,my)+=100
 272                 End if
 273         Next
 274 End Sub
 275
 276
 277 Function matchshape(x As Short,y As Short) As Byte
 278         Dim As Byte fullshape,foundshape=False
 279         Dim As Short mx,my,shapestart=0,p=0,q
 280         Dim a As UByte
 281         Dim goalscolors(100) As UByte 'za randomgoals '!max 100 randomgolova
 282         fullshape=True
 283         For p=0 To UBound(goals)
 284                 If goals(p,0)=255 And goals(p,1)=255 And goals(p,2)=255 Then '255,255,255=end
 285                         If fullshape=True Then
 286                                 markshape(shapestart,p,x,y)
 287                                 foundshape=True
 288                         End If
 289                         shapestart=p+1
 290                         fullshape=True
 291                         For a=0 To UBound(goalscolors) : goalscolors(a)=0 : Next a
 292                 Else
 293                         mx=x-goals(p,0)
 294                         my=y-goals(p,1)
 295                         If mx<0 Or mx>columns-1 Or my<0 Or my>rows-1 Then
 296                                 fullshape=False
 297                         ElseIf goals(p,2)=255 Then '255=joker
 298                                 fullshape = fullshape And _
 299                                 (playfield(mx,my)<>0) And _
 300                                 (playfield(mx,my)<>254) And _
 301                                 (playfield(mx,my)<>253)
 302                         ElseIf goals(p,2)<>0 Then
 303                                 If randomgoals Then
 304                                         If goalscolors(goals(p,2))=0 Then
 305                                                 If (playfield(mx,my)<>0) And _
 306                                                         (playfield(mx,my)<>254) And _
 307                                                         (playfield(mx,my)<>253)Then
 308                                                         goalscolors(goals(p,2))=playfield(mx,my)
 309                                                 Else
 310                                                         fullshape=False
 311                                                 EndIf
 312                                         EndIf
 313                                         fullshape = fullshape And (playfield(mx,my)=goalscolors(goals(p,2)) _
 314                                         Or playfield(mx,my)=goalscolors(goals(p,2))+100)
 315                                 Else
 316                                         fullshape = fullshape And (playfield(mx,my)=goals(p,2) _
 317                                         Or playfield(mx,my)=goals(p,2)+100)
 318                                 EndIf
 319                         End If
 320                 End If
 321         Next
 322         Return foundshape
 323 End Function
 324
 325
 326 Sub checksituation()
 327    Dim As Byte x,y,gap,removed=False,scoremulti=0,existsnextvariation=False, gotonextvariation=True
 328    For y=0 To rows-1 : For x=0 To columns-1
 329        if matchshape(x,y) Then scoremulti+=1
 330    Next x: Next y
 331         If gravity Then 'remove >100 (marked shapes)
 332            For x=0 To columns-1
 333                gap=0
 334                For y=rows-1 To 0 Step -1
 335                     If playfield(x,y)>100 And playfield(x,y)<>254 And playfield(x,y)<>253 Then
 336                         gap+=1
 337                     Else
 338                                                 If playfield(x,y)=254 Then
 339                                                         If originalplayfield(x,y)=254 Or originalplayfield(x,y)=253 Then
 340                                                                 playfield(x,y+gap)=originalplayfield(x,y)
 341                                                         Else
 342                                                                 playfield(x,y+gap)=0
 343                                                         EndIf
 344                                                 Else playfield(x,y+gap)=playfield(x,y)
 345                                                 End If
 346                     End if
 347                     If y<gap Then
 348                         If originalplayfield(x,y)=254 Or originalplayfield(x,y)=253 Then
 349                                 playfield(x,y)=originalplayfield(x,y)
 350                         Else
 351                                 playfield(x,y)=0
 352                         EndIf
 353                     EndIf
 354                 Next y
 355                 removed=removed or gap>0
 356             Next x
 357     If removed Then checksituation()
 358         Else 'no gravity
 359                 For y=0 To rows-1 : For x=0 To columns-1
 360                         If playfield(x,y)>100 And playfield(x,y)<>254 And playfield(x,y)<>253 Then
 361                                 If originalplayfield(x,y)=254 Or originalplayfield(x,y)=254 Then
 362                                         playfield(x,y)=originalplayfield(x,y)
 363                                 Else
 364                                         playfield(x,y)=0
 365                                 EndIf
 366                         EndIf
 367                 Next x: Next y
 368         EndIf
 369         score+=scoremulti*10
 370         'proveri da li je pokriven exit
 371         For y=0 To rows-1 : For x=0 To columns-1
 372                 If originalplayfield(x,y)=253 Then
 373                         existsnextvariation=True
 374                         If playfield(x,y)=253 Then gotonextvariation=False
 375                 EndIf
 376         Next x: Next y
 377         If existsnextvariation And gotonextvariation Then
 378                 loadgame(VARPATH+"/"+nextvariation)
 379                 loadTiles(0)
 380                 speed=3
 381                 initplayfield()
 382         EndIf
 383 End Sub
 384
 385
 386 Sub block.update(justerase As Byte =False)
 387         Dim As Short strt, stp, a
 388
 389         If this.oldtyp=1 Then strt=0 Else strt=inputsindex(this.oldtyp-1-1)+1 'preskace se ona 255 tacka
 390         stp=inputsindex(this.oldtyp-1)-1 'izostavlja se ona 255 tacka
 391         For a = strt To stp
 392                 If inputs(a,2)<>0 Then
 393                         If originalplayfield(this.oldx+inputs(a,0),this.oldy+inputs(a,1))=254 Or _
 394                                 originalplayfield(this.oldx+inputs(a,0),this.oldy+inputs(a,1))=253 Then
 395                                 playfield(this.oldx+inputs(a,0),this.oldy+inputs(a,1)) = _
 396                                 originalplayfield(this.oldx+inputs(a,0),this.oldy+inputs(a,1)) 'cuvamo "start" pri pomeranju
 397                         Else
 398                                 playfield(this.oldx+inputs(a,0),this.oldy+inputs(a,1))=0
 399                         EndIf
 400                 EndIf
 401         Next
 402         If justerase=False Then
 403                 If this.typ=1 Then strt=0 Else strt=inputsindex(this.typ-1-1)+1 'preskace se ona 255 tacka
 404                 stp=inputsindex(this.typ-1)-1 'izostavlja se ona 255 tacka
 405                 For a = strt To stp
 406                         If inputs(a,2)<>0 Then
 407                                 If randominputs Then
 408                                         playfield(this.x+inputs(a,0),this.y+inputs(a,1))=randomtable(inputs(a,2))
 409                                 Else
 410                                         playfield(this.x+inputs(a,0),this.y+inputs(a,1))=inputs(a,2)
 411                                 EndIf
 412                         EndIf
 413                 Next
 414         EndIf
 415
 416 End Sub
 417
 418
 419 Sub block.drop()
 420         If Not this.move(0,1) Then
 421                 checksituation()
 422                 this.init()
 423         EndIf
 424 /'
 425 nije mi jasno kako checksituation funkcionise bez ovoga:
 426                 this.update()
 427 '/
 428 End Sub
 429
 430
 431 Dim keypress As String
 432
 433 sub initplayfield
 434         ReDim playfield(0 to columns-1,0 to rows-1) As UByte
 435    dim as ubyte x,y
 436    for y=0 to rows-1 : for x=0 to columns-1
 437        playfield(x,y)=originalplayfield(x,y)
 438    next x : next y
 439 end sub
 440
 441
 442 Dim Shared tilewidth As Short
 443 Dim Shared tilesimg As Any Ptr
 444 Dim Shared scoreimg As Any Ptr
 445
 446 Declare Sub drawplayfield()
 447
 448 Sub loadTiles(increment As Byte=1)
 449         Static tilesetnum As UByte
 450         tilesetnum+=increment
 451         If tilesetnum>UBound(tilesfiles) Then tilesetnum=0
 452         If tilesetnum<0 Then tilesetnum = UBound(tilesfiles)
 453
 454         Dim tilesfile As String
 455         tilesfile=GFXPATH & "/" & tilesfiles(tilesetnum)
 456         tilewidth = getImgWidth(tilesfile)
 457         If showscore Then
 458                 resizewindow(tilewidth*columns,tilewidth*rows+16)
 459         Else
 460                 resizewindow(tilewidth*columns,tilewidth*rows)
 461         EndIf
 462         ScreenSet 0,1
 463
 464         tilesimg = ImageCreate(tilewidth, tilewidth*(3+numberoftiles))
 465         BLoad tilesfile, tilesimg
 466         scoreimg = ImageCreate(122,20)
 467         BLoad GFXPATH+"/brojke.bmp", scoreimg
 468         drawplayfield()
 469 End Sub
 470
 471 dim shared blok as block
 472
 473 Sub drawscore
 474         Dim As UByte a,digit
 475         Dim As Byte numberstarted=False
 476
 477         Dim xpx As UShort = tilewidth*columns
 478         Line(0,0)-(xpx,16),RGB(0,0,0),BF
 479         For a=0 To 9 'max 10 digits - traze se otpozadi
 480                 If 10^a > score Then Exit For
 481                 digit=Fix((score Mod 10^(a+1)) / 10^a)
 482                 If digit=1 Then
 483                         xpx-=5
 484                         Put (xpx,1),scoreimg,(13,0)-(17,14),PSet
 485                 ElseIf digit=0 Then
 486                         xpx-=13
 487                         Put (xpx,1),scoreimg,(0,0)-(12,14),PSet
 488                 Else
 489                         xpx-=13
 490                         Put (xpx,1),scoreimg,(-8+digit*13,0)-(-8+12+digit*13,14),PSet
 491                 EndIf
 492         Next
 493 End Sub
 494
 495
 496 Sub drawplayfield
 497         Dim As Short offsetx=0,offsety=0,offsetpx=0,offsetpy=0
 498         If showscore Then offsetpy=16
 499         Dim As UByte x,y,t
 500         for y=0 to rows-1 : for x=0 to columns-1
 501                 If playfield(x,y)=0 Then : t=0
 502                 ElseIf playfield(x,y)=254 Then : t=1
 503                 ElseIf playfield(x,y)=253 Then : t=2
 504                 Else : t=playfield(x,y)+2
 505                 End If
 506                 Put (offsetpx+(offsetx+x)*tilewidth, offsetpy+(offsety+y)*tilewidth), _
 507                 tilesimg,(0,t*tilewidth) - Step(tilewidth-1,tilewidth-1),PSet
 508         Next x: Next y
 509         If showscore Then drawscore
 510
 511         ScreenSync
 512         ScreenCopy
 513 End Sub
 514
 515
 516 Sub loadtilesets()
 517         Dim l As String, n As UByte=0
 518         Do Until l="}" Or Eof(1)
 519                 Line Input #1,l
 520                 ReDim Preserve tilesfiles(n)
 521                 tilesfiles(n)=l
 522                 n+=1
 523         Loop
 524         ReDim Preserve tilesfiles(n-2)
 525 End Sub
 526
 527
 528 Sub loadcycle()
 529         Dim l As String, n As UByte
 530         Line Input #1,l
 531         ReDim nextshape(Len(l)) As UByte
 532         For n=0 To Len(l) 'nextshape(0) se ne koristi
 533                 nextshape(n+1)=asctonumber(l[n])
 534         Next
 535 End Sub
 536
 537
 538 Sub loadplayfield()
 539         columns=0 : rows=0
 540         Dim l As String, n As UByte
 541         Dim position As Integer = Seek(1)
 542         Dim As Short a,b=0
 543         Do Until l="}" Or Eof(1)
 544                 rows+=1
 545                 Line Input #1,l
 546                 If Len(l)>columns Then columns=Len(l)
 547         Loop
 548         ReDim originalplayfield(0 to columns-1,0 to rows-1) as UByte
 549         rows-=1
 550         Seek #1,position
 551         l=""
 552         Do Until l="}" Or Eof(1)
 553                 b+=1
 554                 Line Input #1,l
 555                 For a=0 To Len(l)-1
 556 /'
 557                         If l[a]=46 Then : originalplayfield(a,b-1)=0
 558                         Else : originalplayfield(a,b-1)=asctonumber(l[a])
 559                         End If
 560 '/
 561                         n=asctonumber(l[a])
 562                         originalplayfield(a,b-1)=n
 563                         If n>numberoftiles And n<100 Then numberoftiles=n
 564                 Next
 565         Loop
 566         If playabletiles>numberoftiles Then numberoftiles=playabletiles
 567 End Sub
 568
 569
 570 Sub loadsettings()
 571         wrap=False
 572         gravity=False
 573         randominputs=False
 574         randomgoals=False
 575         Dim l As String
 576         Do Until l="}" Or Eof(1)
 577                 Line Input #1,l
 578                 wrap=wrap Or l="wrap"
 579                 gravity=gravity Or l="gravity"
 580                 randominputs=randominputs Or l="randominputs"
 581                 randomgoals=randomgoals Or l="randomgoals"
 582                 If Left(l,6)="tiles:" Then playabletiles=CInt(Mid(l,7))
 583         Loop
 584 End Sub
 585
 586
 587 Sub gameRestart()
 588         score=0
 589         speed=3
 590         initplayfield()
 591         blok.init()
 592         blok.update()
 593         drawplayfield()
 594 End Sub
 595
 596
 597 Function readtitle(filename As String) As String
 598         Dim As String l, result
 599         Open filename For Input As #1
 600         If Err>0 Then Print "Error opening the file":End
 601         Do
 602                 Line Input #1,l
 603                 Select Case l
 604                         Case "Title {"
 605                                 Line Input #1,result
 606                 End Select
 607         Loop Until Eof(1)
 608         Close #1
 609         Return result
 610 End Function
 611
 612
 613 Sub loadhelp()
 614         ReDim help(0)
 615         Dim l As String
 616         Do Until Eof(1)
 617                 Line Input #1,l
 618                 If l="}" Then Exit Do
 619                 ReDim Preserve help(UBound(help) + 1)
 620                 help(UBound(help)) = l
 621         Loop
 622 End Sub
 623
 624
 625 Function loadgame(filename As String) As Byte
 626         If filename = "" Then Return False
 627         Dim l As String
 628         Open filename For Input As #1
 629         If Err>0 Then Print "Error opening the file":End
 630         Do
 631                 Line Input #1,l
 632                 Select Case l
 633                         Case "Title {"
 634                                 Line Input #1,l
 635                                 title = l
 636                                 WindowTitle(l)
 637                         Case "Settings {"
 638                                 loadsettings()
 639                         Case "Next {"
 640                                 Line Input #1,nextvariation
 641                         Case "Tilesets {"
 642                                 loadtilesets()
 643                         Case "Playfield {"
 644                                 loadplayfield()
 645                         Case "Input {"
 646                                 loadshapes(inputs(),filename,True)
 647                         Case "Cycle {"
 648                                 loadcycle()
 649                         Case "Goals {"
 650                                 loadshapes(goals(),filename)
 651                         Case "Help {"
 652                                 loadhelp()
 653                 End Select
 654         Loop Until Eof(1)
 655         Close #1
 656         gameRestart()
 657         loadTiles(0)
 658         Return True
 659 End Function
 660
 661
 662 Function isin(xx As Short,yy As Short,x As Short,y As Short,w As UShort=50,h As UShort=50) As Byte
 663                 Dim in As Byte = True
 664                 in=in And xx>=x And xx<=x+w
 665                 in=in And yy>=y And yy<=y+h
 666                 Return in
 667 End Function
 668
 669
 670 Sub togglescore()
 671         showscore=Not showscore
 672         If showscore Then
 673                 resizewindow(tilewidth*columns,tilewidth*rows+16)
 674         Else
 675                 resizewindow(tilewidth*columns,tilewidth*rows)
 676         EndIf
 677         ScreenSet 0,1
 678         drawplayfield()
 679 End Sub
 680
 681
 682 Sub quit()
 683         ImageDestroy(tilesimg)
 684         ImageDestroy(scoreimg)
 685         End
 686 End Sub
 687
 688
 689 Type button
 690         text As String * 64
 691         As Byte row, column, border
 692         As UShort x, y, w, h
 693 End Type
 694
 695
 696 Function drawbutton(text As String, row As Byte, column As Byte = -1, border As Byte = True, filled As Byte = False) As button
 697 'Draws a button. If column (0 to 4) is present, draws a smaller button in that column
 698         Const MAXW = 299, H = 40, MARGIN = 10, PL = 20, FH = 8, FW = 8
 699         Dim as Short w = MAXW, ox = 0
 700         If column >= 0 Then
 701                 w = MAXW / 4 - MARGIN * 0.75
 702                 ox = (w + MARGIN) * column
 703         End If
 704         If filled Then
 705                 Line (ox, H*row + MARGIN*row)-(ox + w, H*row+MARGIN*row+H), RGB(0,0,127), bf
 706         Else
 707                 Line (ox, H*row + MARGIN*row)-(ox + w, H*row+MARGIN*row+H), RGB(11,11,11), bf
 708         End If
 709         If border Then Line (ox, H*row + MARGIN*row)-(ox + w, H*row+MARGIN*row+H), RGB(127,127,127), b
 710         If (Not border) Or (column >= 0) Then
 711                 Draw String (ox + w/2-Len(text)*FW/2, H*row+MARGIN*row + H/2-FH/2), text
 712         Else
 713                 Draw String (ox + PL, H*row+MARGIN*row + H/2-FH/2), text
 714         End If
 715         Return Type(text, row, column, border, ox, H*row + MARGIN*row, w, H)
 716 End Function
 717
 718
 719 Function openloader(directory As String, page As UByte = 0, resize As Boolean = True) As String
 720         If title = "" Then title = "Generic Block Game"
 721         If resize Then
 722                 resizewindow(300,300)
 723         Else
 724                 Cls
 725         End If
 726         Dim e As EVENT
 727         Dim As Integer mousex, mousey, pressed
 728
 729         Dim buttons(6) As button
 730
 731         drawbutton("Load Variation",0,,False)
 732         'store all filenames
 733         ReDim filenames (0) As String
 734         filenames(0) = Dir(directory + "/*")
 735         Do While Len(filenames(UBound(filenames)))
 736                 ReDim Preserve filenames(UBound(filenames)+1)
 737                 filenames(UBound(filenames)) = Dir()
 738         Loop
 739         'write out 4
 740         Dim title As String
 741         Dim As Byte row = 1, fn = page*4
 742         Do While row < 5 and Len(filenames(fn))
 743                 title = readtitle(directory + "/" + filenames(fn))
 744                 buttons(row) = drawbutton(row & ". " + title,row)
 745                 row += 1 : fn += 1
 746         Loop
 747         ReDim Preserve filenames(UBound(filenames)-1) 'last one was empty
 748
 749         buttons(5) = drawbutton("prev",5,0)
 750         buttons(6) = drawbutton("next",5,1)
 751         drawbutton(page + 1 & "/" & (UBound(filenames)) \ 4 + 1,5,2, False)
 752         buttons(0) = drawbutton("exit",5,3)
 753
 754         Dim keypress As String
 755         Do
 756                 keypress=InKey
 757                 ' handle mouse
 758                 If (ScreenEvent(@e)) Then
 759                         Select Case e.type
 760                         Case EVENT_MOUSE_BUTTON_PRESS
 761                                 pressed = e.button=1
 762                                         If e.button=2 Then Exit Do
 763                                         If pressed Then
 764                                                 GetMouse(mousex,mousey)
 765                                                 If isin(mousex,mousey,buttons(1).x,buttons(1).y,buttons(1).w,buttons(1).h) Then
 766                                                         keypress = "1"
 767                                                 ElseIf isin(mousex,mousey,buttons(2).x,buttons(2).y,buttons(2).w,buttons(2).h) Then
 768                                                         keypress = "2"
 769                                                 ElseIf isin(mousex,mousey,buttons(3).x,buttons(3).y,buttons(3).w,buttons(3).h) Then
 770                                                         keypress = "3"
 771                                                 ElseIf isin(mousex,mousey,buttons(4).x,buttons(4).y,buttons(4).w,buttons(4).h) Then
 772                                                         keypress = "4"
 773                                                 ElseIf isin(mousex,mousey,buttons(5).x,buttons(5).y,buttons(5).w,buttons(5).h) Then
 774                                                         keypress = "p"
 775                                                 ElseIf isin(mousex,mousey,buttons(6).x,buttons(6).y,buttons(6).w,buttons(6).h) Then
 776                                                         keypress = "n"
 777                                                 ElseIf isin(mousex,mousey,buttons(0).x,buttons(0).y,buttons(0).w,buttons(0).h) Then
 778                                                         keypress = "x"
 779                                                 End If
 780                                         End If
 781                         Case EVENT_MOUSE_BUTTON_RELEASE
 782                                 pressed = 0
 783                         Case EVENT_MOUSE_MOVE
 784                                 If (pressed) Then
 785                                                 ScreenControl GET_WINDOW_POS, mousex, mousey
 786                                                 ScreenControl SET_WINDOW_POS, mousex + e.dx, mousey + e.dy
 787                                 End If
 788                         End Select
 789                 End If
 790                 'end mouse
 791         Loop Until keypress <> ""
 792         If Val(keypress) >= 1 And Val(keypress) <= 9 And Len(filenames(Val(keypress) + page*4 - 1)) Then
 793                 Return directory + "/" + filenames(Val(keypress) + page*4 - 1)
 794         End If
 795         'hacky recursion
 796         If keypress=Chr(255)+"P" Or keypress=Chr(255)+"M" Or keypress="n" Then 'down or right or n
 797                 If (page+1) * 4 <= UBound(filenames) Then
 798                         Return openloader(directory, page+1, False)
 799                 Else
 800                         Return openloader(directory, 0, False)
 801                 End If
 802         ElseIf keypress=Chr(255)+"H" Or keypress=Chr(255)+"K" Or keypress="p" Then 'up or left or p
 803                 If page > 0 Then
 804                         Return openloader(directory, page-1, False)
 805                 Else
 806                         Return openloader(directory, UBound(filenames) \ 4, False)
 807                 End If
 808
 809         End If
 810 End Function
 811
 812
 813 Sub openhelp()
 814         Dim As Integer w,h
 815         ScreenInfo(w,h)
 816
 817         resizewindow(300,300, "Help")
 818
 819         Color RGB(127,127,127)
 820         Print "Generic Block Game"
 821         Print
 822         Print "This game is free software (GPL3+)."
 823         Print "See fbc.bas for source and details."
 824         Print
 825         Print
 826         Color RGB(255,255,255)
 827         If gravity Then
 828                 Print "Use left and right arrows to move,"
 829                 Print "Up arrow or space to rotate"
 830                 Print "Down arrow to lower, Enter to drop."
 831         Else
 832                 Print "Use arrows to move,"
 833                 Print "Space to rotate, Enter to fix."
 834         End If
 835         Print
 836         Print
 837         Color RGB(127,127,127)
 838         Print "Help for " + title
 839         Color RGB(255,255,255)
 840         Print
 841
 842         Dim As UByte a
 843         For a = 0 To UBound(help)
 844                 Print help(a)
 845         Next a
 846
 847         Dim e As EVENT
 848         Dim keypress As String
 849         Do
 850                 keypress=InKey
 851                 ScreenEvent(@e)
 852         Loop Until keypress <> "" Or e.type = EVENT_MOUSE_BUTTON_PRESS
 853
 854         resizewindow(w,h)
 855         drawplayfield()
 856 End Sub
 857
 858
 859 Sub openmenu()
 860         Dim As Integer w,h
 861         ScreenInfo(w,h)
 862
 863         Dim e As EVENT
 864         Dim As Integer x, y, pressed
 865
 866         Dim menuimg As Any Ptr
 867         resizewindow(150,150, "Menu")
 868         menuimg = ImageCreate(150,150)
 869         BLoad GFXPATH+"/menu.bmp", menuimg
 870         Put(0,0),menuimg,PSet
 871         Dim keypress as string
 872         Do
 873                 keypress=InKey
 874
 875                 If (ScreenEvent(@e)) Then
 876                 Select Case e.type
 877                 Case EVENT_MOUSE_BUTTON_PRESS
 878                     pressed = e.button=1
 879                                         If e.button>=2 Then Exit Do
 880                                         If pressed Then
 881                                                 GetMouse(x,y)
 882                                                 If isin(x,y,0,0) Then 'help
 883                                                         keypress = Chr(255)+";" 'F1
 884                                                 ElseIf isin(x,y,100,0) Then 'quit
 885                                                         keypress = Chr(27) 'Esc
 886                                                 ElseIf isin(x,y,50,50) Then 'tiles
 887                                                         keypress = "t"
 888                                                 ElseIf isin(x,y,0,50) Then 'speed
 889                                                         keypress = "+"
 890                                                 ElseIf isin(x,y,100,50) Then 'score
 891                                                         keypress = "s"
 892                                                 ElseIf isin(x,y,50,0) Then 'restart
 893                                                         keypress = Chr(255)+"<" 'F2
 894                                                 ElseIf isin(x,y,0,100) Then 'load
 895                                                         keypress = "l"
 896                                                 End If
 897                                         End If
 898                 Case EVENT_MOUSE_BUTTON_RELEASE
 899                     pressed = 0
 900                 Case EVENT_MOUSE_MOVE
 901                     If (pressed) Then
 902                                                 ScreenControl GET_WINDOW_POS, x, y
 903                                                 ScreenControl SET_WINDOW_POS, x + e.dx, y + e.dy
 904                     End If
 905                 Case EVENT_WINDOW_CLOSE
 906                                 keypress = Chr(27)
 907                 End Select
 908                 End If
 909
 910                 Select Case keypress
 911                         Case "t"
 912                                 loadTiles(1)
 913                                 ImageDestroy(menuimg)
 914                                 Exit Sub
 915                         Case "+"
 916                                 speed=speed/1.5
 917                                 Exit Do
 918                         Case "s"
 919                                 togglescore()
 920                                 ImageDestroy(menuimg)
 921                                 Exit Sub
 922                         Case Chr(255)+";" 'F1
 923                                 openhelp()
 924                         Case Chr(255)+"<" 'F2
 925                                 gameRestart()
 926                                 Exit Do
 927                         Case "l"
 928                                 If loadgame(openloader(VARPATH)) Then
 929                                         ImageDestroy(menuimg)
 930                                         Exit Sub 'Don't restore window size
 931                                 End If
 932                         Case Chr(27)
 933                                 ImageDestroy(menuimg)
 934                                 quit()
 935                 End Select
 936
 937         Loop Until keypress <> ""
 938         ImageDestroy(menuimg)
 939
 940         resizewindow(w,h)
 941         drawplayfield()
 942 End Sub
 943
 944
 945 Function windowmouse() As String
 946         Dim e As EVENT
 947         Dim As Integer x, y
 948         Static pressed As Integer=0
 949         If (ScreenEvent(@e)) Then
 950                 Select Case e.type
 951                 Case EVENT_MOUSE_BUTTON_PRESS
 952                         If e.button=1 Then Return Chr(13) 'Enter = drop
 953                         If e.button=2 Then Return " " 'Space = turn
 954                         If e.button>2 Then Return Chr(27) 'Esc = open menu
 955                 Case EVENT_WINDOW_CLOSE
 956                         quit()
 957                 Case EVENT_MOUSE_MOVE
 958                         If e.x < (blok.x + getshapewidthheight(blok.typ) / 2) * tilewidth Then Return Chr(255)+"K"
 959                         If e.x > (blok.x + getshapewidthheight(blok.typ) / 2 + 1) * tilewidth Then Return Chr(255)+"M"
 960
 961                 End Select
 962         End If
 963 End Function
 964
 965
 966 Sub gameOver()
 967         Dim As Short offsety=0, offsety2=0
 968         Dim As Byte inkeyemptied=False, scoredrawn=False
 969         Dim tim2 As Double
 970         scoredrawn=showscore
 971         If showscore Then offsety=16
 972         offsety2=offsety
 973         Dim keypress As String
 974         tim=Timer()
 975         tim2=Timer()
 976         Do
 977                 If Timer-tim2>0.5 Then
 978                         keypress=InKey
 979                 Else
 980                         While InKey<>"" : Wend 'prazni inkey tokom prvih pola sekunde
 981                 EndIf
 982
 983                 If offsety2<tilewidth*rows+offsety-6 Then
 984                         If Timer-tim>0.03 Then
 985                                 tim=Timer()
 986                                 Line (0,offsety2)-(tilewidth*columns,offsety2+6),RGB(0,0,0),BF
 987                                 Put(tilewidth*columns/2-47/2,offsety2+1),scoreimg,(52,15)-(99,19),PSet
 988                                 offsety2+=1
 989                                 ScreenSync
 990                                 ScreenCopy
 991                         EndIf
 992                 EndIf
 993                 If offsety2>20 And Not scoredrawn Then
 994                         drawscore()
 995                         scoredrawn=True
 996                 EndIf
 997
 998                 windowmouse()
 999         Loop Until keypress<>""
1000
1001         Cls
1002         gameRestart()
1003 End Sub
1004
1005
1006 Randomize
1007 If Not loadgame(Command) Then
1008         If Not loadgame(openloader(VARPATH)) Then End
1009 End If
1010 tim=Timer()
1011 do
1012         keypress=InKey
1013         If keypress = "" Then keypress = windowmouse()
1014         If keypress=Chr(255)+"K" Then 'left
1015                 blok.move(-1)
1016                 drawplayfield()
1017         ElseIf keypress=Chr(255)+"M" Then 'right
1018                 blok.move(1)
1019                 drawplayfield()
1020         ElseIf keypress=" " Then
1021                 blok.move(0,0,nextshape(blok.typ)) 'cycle
1022                 drawplayfield()
1023         ElseIf keypress=Chr(255)+"H" Then 'move up or rotate
1024                 If gravity Then
1025                 blok.move(0,0,nextshape(blok.typ)) 'cycle
1026                 Else
1027                         blok.move(0,-1)
1028                 EndIf
1029         drawplayfield()
1030         ElseIf keypress=Chr(255)+"P" Then 'down
1031                 If gravity Then
1032                         score+=1
1033                         blok.drop()
1034                         tim=Timer()
1035                         blok.update()
1036                 Else
1037                         blok.move(0,1)
1038                 EndIf
1039                 drawplayfield()
1040         ElseIf keypress="t" Or keypress="T" Then
1041                 loadTiles(1)
1042         ElseIf keypress=Chr(13) Then 'enter=fix or drop
1043                 If gravity Then
1044                         Do : score+=1 : Loop While blok.move(0,1)
1045                 EndIf
1046                 checksituation()
1047                 blok.init()
1048                 blok.update()
1049                 drawplayfield()
1050         ElseIf keypress="s" Or keypress="S" then 'score
1051                 togglescore()
1052         ElseIf keypress="l" Or keypress="L" then 'load
1053                 If Not loadgame(openloader(VARPATH)) Then loadTiles(0) 'restore window size
1054         ElseIf keypress=Chr(255)+";" then 'F1
1055                 openhelp()
1056         ElseIf keypress=Chr(255)+"<" then 'F2
1057         gameRestart()
1058         ElseIf keypress="+" Then 'speed+
1059                 speed=speed/1.5
1060         ElseIf keypress=Chr(27) Then 'Esc
1061                 openmenu()
1062         EndIf
1063         If gravity And Timer-tim>speed then
1064         speed=speed/1.003
1065         blok.drop()
1066         blok.update()
1067         drawplayfield()
1068         tim=Timer()
1069         End If
1070 Loop
1071