Code archives/Miscellaneous/Barkanoid
This code has been declared by its author to be Public Domain code.
Download source code
| |||||
Simple Catch move and throw game. | |||||
; (Speed programming challenge (2 hours) ; ; By Nebula / Crom Design (www.cromdesign.nl) ; ; barkanoid Graphics 640,480,16,2 SetBuffer BackBuffer() ClsColor 30,30,30 : Cls ; Type game Field btop,bleft ;player Field pleft,ptop,pwidth,pheight Field pblock Field pblockcnt Field mapbottom End Type g.game = New game resetlevel ; Global myfont = LoadFont("verdana",16,True) SetFont myfont Global timer = CreateTimer(60) ; Dim blocks(40,40) ; setupblocks() ; While KeyDown(1) = False WaitTimer(timer) Cls moveship drawbeam(0) DrawBlocks drawship grabblock releaseblock drawplayingscreen() If KeyHit(59) Then resetlevel : setupblocks Color 255,255,255: Text 52,15,"F1 to ",1 Color 255,255,255: Text 52,32,"reset level ",1 Flip Wend End Function resetlevel() g.game = First game g\btop = -256 g\bLeft= 96 g\pleft = GraphicsWidth()/2 g\pheight = 64 g\ptop = GraphicsHeight() - g\pheight g\pwidth = 48 g\pblock = 0 g\pblockcnt = 0 g\mapbottom = 40 End Function Function drawplayingscreen() Color 0,0,0 Rect 0,0,96,GraphicsHeight() Color 50,70,40 Rect 2,2,94,GraphicsHeight() End Function Function dropmap() g.game = First game For y=38 To 1 Step -1 For x=0 To 40 If ono = False If blocks(x,y) > 0 Then bb = y ono = True End If End If Next:Next q = g\mapbottom-bb If q > 10 Then g\mapbottom = (bb+10) End Function Function checkcombo(x1,y1,num,rv) g.game = First game ;x = g\pleft+24 ;x=x/48-2 ; For y=y1 To 0 Step -1 If noway = False If blocks(x1,y) = num Then cnt=cnt+1 ;blocks(x1,y) = 0 Else noway = True End If End If Next ; cnt=cnt-1 ;DebugLog cnt ; If cnt > rv Then For y=y1 To y1-cnt Step - 1 blocks(x1,y) = 0 Next dropmap End If ; ;RuntimeError cnt End Function Function releaseblock() g.game = First game cb = g\pblock If cb = 0 Then Return x = g\pleft+24 x=x/48-2 Color 255,0,0 Text 0,0,x If MouseHit(2) = True Then For y1=40 To 0 Step -1 If blocks(x,y1) <> 0 And bb = 0 Then bb = y1 End If Next bb=bb+1 For y1=bb To bb+g\pblockcnt-1 blocks(x,y1) = g\pblock Next checkcombo(x,bb+g\pblockcnt-1,g\pblock,g\pblockcnt) g\pblockcnt = 0 g\pblock = 0 EndIf End Function Function grabblock() g.game = First game ;cb = g\pblock x = g\pleft+24 x=x/48-2 ;Color 255,0,0 ;Text 0,0,x If MouseHit(1) = True And g\pblockcnt < 5 Then lb = 0 : ly = 40 blockselect = False For y=40 To 0 Step -1 Stepdone = False bt = blocks(x,y) If g\pblock = 0 Then If bt > 0 g\pblock = bt EndIf End If ; If (lb = 0 And bt <> 0) And blockselect = False Then If g\pblock = bt lb = bt ly = y; : DebugLog " set to : " + ly + " from : " + y blockselect = True Stepdone = True Else Return End If End If ; If Stepdone = False And blockselect = True Then If lb = bt Then If (y+1) = ly Then ly = y cnt = cnt + 1 End If EndIf EndIf Next ; If lb <> 0 Then ;RuntimeError "found blok" g\pblock = lb g\pblockcnt = cnt + 1 + g\pblockcnt ;remove blocks For y=ly To 40 blocks(x,y) = 0 Next End If ; End If End Function Function drawbeam(num) g.game = First game x = g\pleft y = 0 w = g\pwidth h = GraphicsHeight() Color 40,40,200 Rect x,y,w,h,True End Function Function setupblocks() For x=0 To 10 For y=0 To 30 blocks(x,y) = Rand(1,4) Next:Next End Function Function moveship() g.game = First game If RectsOverlap(MouseX(),MouseY(),1,1,96+g\pwidth/2,0,GraphicsWidth()-(96+g\pwidth),GraphicsHeight()) Then g\pleft = MouseX() - g\pwidth/2 Else If MouseX() < 96 Then g\pLeft = 96 End If End If If g\pleft > 12*48 Then g\pleft = 12*48 End Function Function drawship() g.game = First game x = g\pleft y = g\ptop w = g\pwidth h = g\pheight Color 0,0,0 Rect x,y,w,h,False Color 160,170,170 x=x+1:w=w-2 : y=y+1:h=h-2 Rect x,y,w,h,True ; If g\pblockcnt > 0 Then For y1=y To y-((g\pblockcnt-1)*16) Step -16 draw1block(x,y1,g\pblock) Next End If ; End Function Function DrawBlocks() g.game = First game y2 = (40*16)-(g\mapbottom*16) For x=0 To 40 For y=0 To 40 draw1block((x*48)+g\bleft,((y*16)+g\btop)+y2,blocks(x,y)) Next:Next End Function Function Draw1Block(x,y,num) If num = 0 Then Return Color 0,0,0 Rect x,y,48,16,False Select num Case 1:Color 255,0,0 Case 2:Color 0,255,0 Case 3:Color 0,0,255 Case 4:Color 255,0,255 End Select Rect (x+1),(y+1),48-2,16-2,True End Function |
Comments
| ||
Thanks for sharing, Nebula! |
Code Archives Forum