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