TheGameCreators - CodeBase

Return to the CodeBase listing

Category: Complete Applications

Version: 1.0

Information

Uploaded: 20th Feb 2009 13:52

Modified: 1st Jan 1970 01:00

Author: Anonymous Coder

Summary

application game color tris

Full Description

DarkBASIC Professional Source Code

` This code was downloaded from The Game Creators

` It is reproduced here with full permission

` http://www.thegamecreators.com

Rem Project: colortris

Rem Created: Wednesday, February 18, 2009

Rem ***** Main Source File *****

rem by:vitaluciano@hotmail.fr

rem

sync on

sync rate 60

set dir "media"

load image "bk1.jpg",1

load image "bk2.jpg",2

load image "bk3.jpg",3

load image "bk4.jpg",4

load image "bk5.jpg",5

load image "bk6.jpg",6

load image "bk7.jpg",7

load image "bk8.jpg",8

global false=0

global true=-1

global dim map$(15,14)

global dim mymap$(12,8)

global dim tempmap$(12,8)

global dim temp001$(12,8)

global dim blok$(3,3)

//global dim blk1$(1,3)

global flg_blk=false

global dim combk(3)

global dim tempcom$(3,3)

global dim tempcomv(3,3)

global bk1=1

global sz=28

global a=sz*2

global b=sz*2

global ky,kx

global slp

global score

global reset01=false

restore mymap

for k=1 to 14

for j=1 to 13

read aa

aaa$=str$(aa)

map$(k,j)=aaa$

next j

next k

for k=1 to 12

for j=1 to 7

mymap$(k,j)="0"

next j

next k

gosub resmymap

randomize timer()

cls

rem ==================main loop========================

cls

if mymap$(1,1)<>"0"

wait key

endif

if spacekey()

cls

score=0

gosub resmymap

bk1=1

flg_blk=false

endif

gosub resmap

gosub dismap

if flg_blk=false

for k=1 to 3

combk(k)=rnd(5)+1

next k

a=sz*2

b=sz*2

ky=1

flg_blk=true

endif

gosub blk

// wait key

sync

loop

end

rem ======================routin=========

dismap:

for k=1 to 14

for j=1 to 13

if map$(k,j)="1"

paste image rnd(5)+1,(j*28)+sz,(k*28)+sz

endif

if map$(k,j)="0"

paste image 8,(j*28)+28,(k*28)+28

endif

next j

next k

for k=1 to 11

for j=1 to 7

if mymap$(k,j)="0" then paste image 8,(j*sz)+(sz*4),(k*sz)+sz

if mymap$(k,j)<>"0"

paste image val(mymap$(k,j)),(j*sz)+(sz*4),(k*sz)+sz

endif

next j

next k

set text size 40

s$="COLOR-TRIS"

text 430,10,s$

set text size 25

s$="Upkey:rotate color"

text 430,50,s$

s$="Rightkey:move"

text 430,70,s$

s$="Leftkey:move"

text 430,90,s$

s$="Downtkey:move down"

text 430,110,s$

s$="Spacekey:resetgame"

text 430,130,s$

s$="Esc:quit"

text 430,150,s$

set text size 35

s$="Score: "+str$(score)

text 430,200,s$

set text size 25

s$="by:vitaluciano@hotmail.fr"

text 430,350,s$

return

rem

blk:

if upkey()

inc bk1,1

endif

if bk1>4 then bk1=1

select  bk1

case 1

gosub resblok

gosub inblok1

endcase

case 2

gosub resblok

gosub inblok2

endcase

case 3

gosub resblok

gosub inblok3

endcase

case 4

gosub resblok

gosub inblok4

endcase

endselect

return

rem

resblok:

for k=1 to 3

for j=1 to 3

blok$(k,j)="0"

next j

next k

return

rem

blkky:

ky=((b-(sz*2))/sz)+1

return

rem

blkkx:

kx=((a-(sz*2))/sz)+1

return

rem

dwn:

if downkey()

slp=30

else

slp=150

endif

return

rem

inblok1:

blok$(1,1)=str$(combk(1))

blok$(2,1)=str$(combk(2))

blok$(3,1)=str$(combk(3))

paste image val(blok$(1,1)),a+(28*3),b

paste image val(blok$(2,1)),a+(28*3),b+sz

paste image val(blok$(3,1)),a+(28*3),b+sz+sz

gosub dwn

sleep slp

b=b+2

gosub blkky

gosub rightleft

if a<=sz*2 then a=sz*2

if a>=sz*8 then a=sz*8

gosub blkkx

if  mymap$(ky+3,kx)<>"0"

mymap$(ky,kx)=blok$(1,1)

mymap$(ky+1,kx)=blok$(2,1)

mymap$(ky+2,kx)=blok$(3,1)

flg_blk=false

endif

if b>=(sz*10)

b=sz*11

mymap$(ky,kx)=blok$(1,1)

mymap$(ky+1,kx)=blok$(2,1)

mymap$(ky+2,kx)=blok$(3,1)

flg_blk=false

endif

return

rem

inblok2:

blok$(1,1)=str$(combk(1))

blok$(1,2)=str$(combk(2))

blok$(1,3)=str$(combk(3))

paste image val(blok$(1,1)),a+(28*3),b

paste image val(blok$(1,2)),a+(28*3)+sz,b

paste image val(blok$(1,3)),a+(28*3)+sz+sz,b

gosub dwn

sleep slp

b=b+2

gosub blkky

gosub rightleft

if a<=sz*2 then a=sz*2

if a>=sz*6 then a=sz*6

gosub blkkx

if  mymap$(ky+1,kx)<>"0"

mymap$(ky,kx)=blok$(1,1)

mymap$(ky,kx+1)=blok$(1,2)

mymap$(ky,kx+2)=blok$(1,3)

flg_blk=false

endif

if  mymap$(ky+1,kx+1)<>"0"

mymap$(ky,kx)=blok$(1,1)

mymap$(ky,kx+1)=blok$(1,2)

mymap$(ky,kx+2)=blok$(1,3)

flg_blk=false

endif

if  mymap$(ky+1,kx+2)<>"0"

mymap$(ky,kx)=blok$(1,1)

mymap$(ky,kx+1)=blok$(1,2)

mymap$(ky,kx+2)=blok$(1,3)

flg_blk=false

endif

if b>=(sz*12)

b=sz*11

mymap$(ky,kx)=blok$(1,1)

mymap$(ky,kx+1)=blok$(1,2)

mymap$(ky,kx+2)=blok$(1,3)

flg_blk=false

endif

return

rem

inblok3:

blok$(1,1)=str$(combk(3))

blok$(2,1)=str$(combk(2))

blok$(3,1)=str$(combk(1))

paste image val(blok$(1,1)),a+(28*3),b

paste image val(blok$(2,1)),a+(28*3),b+sz

paste image val(blok$(3,1)),a+(28*3),b+sz+sz

gosub dwn

sleep slp

b=b+2

gosub blkky

gosub rightleft

if a<=sz*2 then a=sz*2

if a>=sz*8 then a=sz*8

gosub blkkx

if  mymap$(ky+3,kx)<>"0"

mymap$(ky,kx)=blok$(1,1)

mymap$(ky+1,kx)=blok$(2,1)

mymap$(ky+2,kx)=blok$(3,1)

flg_blk=false

endif

if b>=(sz*10)

b=sz*11

mymap$(ky,kx)=blok$(1,1)

mymap$(ky+1,kx)=blok$(2,1)

mymap$(ky+2,kx)=blok$(3,1)

flg_blk=false

endif

return

rem

inblok4:

blok$(1,1)=str$(combk(3))

blok$(1,2)=str$(combk(2))

blok$(1,3)=str$(combk(1))

paste image val(blok$(1,1)),a+(28*3),b

paste image val(blok$(1,2)),a+(28*3)+sz,b

paste image val(blok$(1,3)),a+(28*3)+sz+sz,b

gosub dwn

sleep slp

b=b+2

gosub blkky

gosub rightleft

if a<=sz*2 then a=sz*2

if a>=sz*6 then a=sz*6

gosub blkkx

if  mymap$(ky+1,kx)<>"0"

mymap$(ky,kx)=blok$(1,1)

mymap$(ky,kx+1)=blok$(1,2)

mymap$(ky,kx+2)=blok$(1,3)

flg_blk=false

endif

if  mymap$(ky+1,kx+1)<>"0"

mymap$(ky,kx)=blok$(1,1)

mymap$(ky,kx+1)=blok$(1,2)

mymap$(ky,kx+2)=blok$(1,3)

flg_blk=false

endif

if  mymap$(ky+1,kx+2)<>"0"

mymap$(ky,kx)=blok$(1,1)

mymap$(ky,kx+1)=blok$(1,2)

mymap$(ky,kx+2)=blok$(1,3)

flg_blk=false

endif

if b>=(sz*12)

b=sz*11

mymap$(ky,kx)=blok$(1,1)

mymap$(ky,kx+1)=blok$(1,2)

mymap$(ky,kx+2)=blok$(1,3)

flg_blk=false

endif

return

rem

resmymap:

for k=1 to 11

for j=1 to 7

mymap$(k,j)="0"

next j

next k

return

rem

rightleft:

if rightkey()

a=a+sz

kxx=((a-(sz*2))/sz)+1

if bk1=1 or bk1=3

if kxx<7 and mymap$(ky,kx+1)<>"0" or  mymap$(ky+1,kx+1)<>"0" or  mymap$(ky+2,kx+1)<>"0" then a=a-sz

endif

if bk1=2 or bk1=4

if kxx<6 and mymap$(ky,kx+3)<>"0" then a=a-sz

endif

if leftkey()

a=a-sz

kxx=((a-(sz*2))/sz)+1

if bk1=1 or bk1=3

if kxx>1 and mymap$(ky,kx-1)<>"0" or  mymap$(ky+1,kx-1)<>"0" or  mymap$(ky+2,kx-1)<>"0" then a=a+sz

endif

if bk1=2 or bk1=4

if kxx>1 and mymap$(ky,kx-1)<>"0" then a=a+sz

endif

return

rem

resmap:

go01:

for k=1 to 11

for j=1 to 7

tempmap$(k,j)=mymap$(k,j)

next j

next k

com2=false

gosub resmap01 rem control map orrinzzontal

com7=false

gosub resmap02 rem control map vertical

if com2=true or com7=true

score=score+100

if com2=true

com3=val(tempcom$(1,1))

for k=com3 to 1 step -1

if k<>1

com4=val(tempcom$(1,2))

com5=val(tempcom$(2,2))

com6=val(tempcom$(3,2))

mymap$(k,com4)=tempmap$(k-1,com4)

mymap$(k,com5)=tempmap$(k-1,com5)

mymap$(k,com6)=tempmap$(k-1,com6)

endif

next k

gosub resmymap001

goto go01

endif

rem

if com7=true

com10=tempcomv(1,1)

com11=tempcomv(1,2)

com12=tempcomv(2,2)

com13=tempcomv(3,2)

for k=com10 to 1 step -1

if k>=4

mymap$(k,com11)=tempmap$(k-3,com11)

mymap$(k,com12)=tempmap$(k-3,com12)

mymap$(k,com13)=tempmap$(k-3,com13)

endif

next k

gosub resmymap001

goto go01

endif

// gosub resmymap001

return

rem

resmap01:

for k=11 to 1 step -1

for j=1 to 7

if j<=5 and k>=4

com1$=tempmap$(k,j)

select j

case 1

if com1$<>"0"

if tempmap$(k,1)=com1$ and tempmap$(k,2)=com1$ and tempmap$(k,3)=com1$

tempcom$(1,1)=str$(k)

tempcom$(1,2)=str$(1)

tempcom$(2,1)=str$(k)

tempcom$(2,2)=str$(2)

tempcom$(3,1)=str$(k)

tempcom$(3,2)=str$(3)

com2=true

endif

endcase

case 2

if com1$<>"0"

if tempmap$(k,2)=com1$ and tempmap$(k,3)=com1$ and tempmap$(k,4)=com1$

tempcom$(1,1)=str$(k)

tempcom$(1,2)=str$(2)

tempcom$(2,1)=str$(k)

tempcom$(2,2)=str$(3)

tempcom$(3,1)=str$(k)

tempcom$(3,2)=str$(4)

com2=true

endif

endcase

case 3

if com1$<>"0"

if tempmap$(k,3)=com1$ and tempmap$(k,4)=com1$ and tempmap$(k,5)=com1$

tempcom$(1,1)=str$(k)

tempcom$(1,2)=str$(3)

tempcom$(2,1)=str$(k)

tempcom$(2,2)=str$(4)

tempcom$(3,1)=str$(k)

tempcom$(3,2)=str$(5)

com2=true

endif

endcase

case 4

if com1$<>"0"

if tempmap$(k,4)=com1$ and tempmap$(k,5)=com1$ and tempmap$(k,6)=com1$

tempcom$(1,1)=str$(k)

tempcom$(1,2)=str$(4)

tempcom$(2,1)=str$(k)

tempcom$(2,2)=str$(5)

tempcom$(3,1)=str$(k)

tempcom$(3,2)=str$(6)

com2=true

endif

endcase

case 5

if com1$<>"0"

if tempmap$(k,5)=com1$ and tempmap$(k,6)=com1$ and tempmap$(k,7)=com1$

tempcom$(1,1)=str$(k)

tempcom$(1,2)=str$(5)

tempcom$(2,1)=str$(k)

tempcom$(2,2)=str$(6)

tempcom$(3,1)=str$(k)

tempcom$(3,2)=str$(7)

com2=true

endif

endcase

endselect

endif

next j

next k

return

rem

resmap02:

for k=11 to 1 step -1

for j=1 to 7

if k>=3

com8$=tempmap$(k,j)

if com8$<>"0"

if tempmap$(k,j)=com8$ and tempmap$(k-1,j)=com8$ and tempmap$(k-2,j)=com8$

tempcomv(1,1)=k

tempcomv(1,2)=j

tempcomv(2,1)=k-1

tempcomv(2,2)=j

tempcomv(3,1)=k-2

tempcomv(3,2)=j

com7=true

endif

next j

next k

return

rem

resmymap001:

for k=1 to 11

for j=1 to 7

temp001$(k,j)="0"

tempmap$(k,j)=mymap$(k,j)

next j

next k

for j=1 to 7

select j

case 1

gosub remmap002

endcase

case 2

gosub remmap002

endcase

case 3

gosub remmap002

endcase

case 4

gosub remmap002

endcase

case 5

gosub remmap002

endcase

case 6

gosub remmap002

endcase

case 7

gosub remmap002

endcase

endselect

next j

for k=1 to 11

for j=1 to 7

mymap$(k,j)=temp001$(k,j)

next j

next k

return

rem

remmap002:

kk=12

for k=11 to 1 step -1

if tempmap$(k,j)<>"0"

dec kk,1

temp001$(kk,j)=tempmap$(k,j)

endif

next k

return

rem ==================mappa================

mymap:

data 1,1,1,0,0,0,0,0,0,0,1,1,1

data 1,1,1,1,1,1,1,1,1,1,1,1,1

rem

// blk1:

// data 1,1,1

// data 0,0,0

// rem

// blk2:

// data 1,0,0

Download

Please login to download

Comments

No comments yet.

CodeBase - color tris

Information

Summary

Full Description

DarkBASIC Professional Source Code

Download

Screen Shot

Author

Comments

Author Name:	Anonymous Coder
CodeBase Entries:	7