Global ss_channelcount%
Global ss_bpsample%=16
Global ss_maxchans=50
Global ss_buffersize=1000
Global ss_maxenvs=30
Global ss_sndtype=8
Global ss_lfocount=2
Dim ss_sounds(ss_maxchans)
Dim ss_volume#(ss_maxchans)
Dim ss_schan(ss_maxchans)
Dim ss_sLength#(ss_maxchans)
Dim ss_started(ss_maxchans)
Dim ss_actualvol#(ss_maxchans)
Dim ss_attackdone(ss_maxchans)
Dim ss_decaydone(ss_maxchans)
Dim ss_attack#(ss_maxchans)
Dim ss_decay#(ss_maxchans)
Dim ss_sustain#(ss_maxchans)
Dim ss_release#(ss_maxchans)
Dim ss_currentpitch#(ss_maxchans)
Dim ss_envelope(ss_maxchans)
Dim ss_defattack#(ss_maxenvs)
Dim ss_defdecay#(ss_maxenvs)
Dim ss_defsustain#(ss_maxenvs)
Dim ss_defrelease#(ss_maxenvs)
Dim ss_attackchange#(ss_maxenvs)
Dim ss_decaychange#(ss_maxenvs)
Dim ss_sustainchange#(ss_maxenvs)
Dim ss_releasechange#(ss_maxenvs)
Dim ss_lfoattack#(ss_lfocount,ss_maxenvs)
Dim ss_lfodecay#(ss_lfocount,ss_maxenvs)
Dim ss_lfosustain#(ss_lfocount,ss_maxenvs)
Dim ss_lforelease#(ss_lfocount,ss_maxenvs)
Dim ss_lfo#(ss_lfocount,ss_maxchans)
Dim ss_lfofreq#(ss_lfocount,ss_maxenvs)
Dim ss_lfocounter#(ss_maxchans)
Dim ss_bufferchan(ss_maxchans,ss_buffersize)
Dim ss_buffervol#(ss_maxchans,ss_buffersize)
Dim ss_bufferenv#(ss_maxchans,ss_buffersize)
Dim ss_bufferpitch(ss_maxchans,ss_buffersize)
Dim ss_bufferlength(ss_maxchans,ss_buffersize)
Dim ss_bufferpointer(ss_maxchans)
Dim ss_buffercount(ss_maxchans)
Dim ss_chancheck(ss_maxchans)
Dim ss_channelloop(ss_maxchans)
Dim ss_samplecnt(ss_maxchans)
Dim ss_soundbank(ss_sndtype),ss_samplecntbank(ss_sndtype)
Global forcesoundupdate=0
Global ss_stimer#=100
Global audiotimer=MilliSecs(),updateperiod#=1
Dim wavdata(0,0)
initsoundsystem()
updateperiod#=15
For n=1 To ss_maxchans
soundshape n,1
Next
Global Nxtchan=1
Global dirx,diry
Type path
Field x
Field y
End Type
Type boulder
Field sx,sy
Field x,y
Field player
Field reposition
Field timer
Field triggered
Field rocknumber
End Type
Global ignoreboulders
Global Lastspread
Global scx#=640,scy#=480
scx=800
scy=600
Global Topbit=50
Graphics scx,scy,16,2
Global gametimer=CreateTimer(80)
Global basey=Topbit
TFormFilter 0
Global maxx=40
Global maxy=30
maxx=40/1.3
maxy=30/1.3
;maxx=40*2
;maxy=30*2
Global scrollmode
Global camx=0,ocamx
Global camy=0,ocamy
Global cammvx,cammvy
Global szx#=(scx/(maxx))
Global szy#=((scy-Topbit)/(maxy))
szx=32
szy=32
;szx=16
;szy=16
maxx=maxx-1
maxy=maxy-1
Global Textcnt=8
Dim Charimg(256,Textcnt)
Dim map(maxx+1,maxy+1)
Dim map2(maxx+1,maxy+1) ;Stores walkable area. Used to ensure players arent put where they cant get to or from.
Dim map3(maxx+1,maxy+1) ;Mushroom layer
Dim map4(maxx+1,maxy+1);AI layer
;Dim map4(m
Dim alive(maxx+1,maxy+1)
Dim mapc(4),mapd(4)
mapc(1)=1:mapd(1)=0
mapc(2)=0:mapd(2)=1
mapc(3)=-1:mapd(3)=0
mapc(4)=0:mapd(4)=-1
Global stack
Dim stackx(maxx*maxy)
Dim stacky(maxx*maxy)
Dim stackc(maxx*maxy)
Dim stackd(maxx*maxy)
Global mushrooms
Global mushlife=7
Global images=8
Dim img(images)
Global maxplayers=16
Global players=1
Dim playertype(maxplayers)
playertype(1)=1
Dim px#(maxplayers),py#(maxplayers),pc#(maxplayers),pd#(maxplayers)
Dim fr#(maxplayers)
Dim ok2move(maxplayers)
Dim score(maxplayers)
Dim lives(maxplayers),energy#(maxplayers)
Dim sx(maxplayers)
Dim sy(maxplayers)
Dim diecounter(maxplayers)
Dim dead(maxplayers)
Dim mushs(maxplayers)
Dim playername$(maxplayers)
Dim Lastupdate(maxplayers)
For n=1 To maxplayers
playername$(n)="Player"+Str$(n)
Next
Dim upkey(maxplayers),downkey(maxplayers),Leftkey(maxplayers),Rightkey(maxplayers),dropkey(maxplayers)
Leftkey(1)=203
rightkey(1)=205
upkey(1)=200
downkey(1)=208
Dim red(maxplayers),green(maxplayers),blue(maxplayers)
Dim pdx(maxplayers),pdy(maxplayers)
Dim cfx(maxplayers),cfy(maxplayers),ctx(maxplayers),cty(maxplayers)
Dim playerimg(maxplayers,2)
For o=0 To maxplayers
red(o)=0
green(o)=255
blue(o)=0
Next
Read numcols
For o=1 To numcols
Read red(o)
Read green(o)
Read blue(o)
Next
Global hatred=100,hatgreen=200,hatblue=0
;setup text
Global txsize#=16,txscale#=2,txxdis#=.5
setuptext()
rszx=szx
rszy=szy
Global level=1
.restart
;setup music
setupmusic
Repeat:Until KeyDown(1)=0
level=1
SetBuffer BackBuffer()
menuoption=0
Cls
createlevel(100)
camx=0:camy=0
quit=0
Repeat
by=(scy/2)
option=option-(KeyHit(200)-KeyHit(208))
If option<0 Then option=2
If option>2 Then option=0
yy=by+option*32
text2 scx/2,scy/10,"ULTIMATE MUSHROOM COLLECTOR 2004",1,1
Text2 scx/2,(scy/8)+42,"Collect as many mushrooms as you can!",1,1
Text2 scx/2,(scy/8)+64,"Be the Last surviving player!",1,1
Text2 scx/3,yy,">>"
Text2 scx/2.5,by,"START"
done=0
kh=KeyHit(57)
If KH And option=0 Then done=1
If KH And option=1 Then sel=sel+1:If sel>1 Then sel=0
If kh And option=2 Then quit=1
If sel=0 Then scrollmode=0:Op$="Non-Scrolling" Else scrollmode=1:op$="Scrolling mode"
Text2 scx/2.5,by+32,op$
Text2 scx/2.5,by+64,"Quit"
updatesound
Flip
Cls
Until done Or KeyDown(1) Or quit=1
If scrollmode=0 Then
szx=(scx/(maxx+1))
szy=((scy-basey)/(maxy+1))
Else
szx=rszx
szy=rszy
EndIf
If KeyDown(1) Or quit=1 Then End
;do graphics
Global inv=Rand(1,4)
For o=0 To images
img(o)=creategfx(o)
Next
img(0)=img(3)
SetBuffer BackBuffer()
For o=1 To maxplayers
hatred=red(o)
hatgreen=green(o)
hatblue=blue(o)
If o=1 Then vr=1 Else vr=Rand(2,3)
playerimg(o,1)=creategfx(255,vr)
playerimg(o,2)=creategfx(256,vr)
Next
For n=1 To players
playertype(n)=1
lives(n)=3
Next
For n=players+1 To maxplayers
lives(n)=3
Next
SeedRnd MilliSecs()
.nextlevel
Delete Each boulder
createlevel(level)
;findpath(px(1),py(1),px(2),py(2))
;map(px(1),py(1))=1
;map(px(2),py(2))=1
Flip
drawmap()
Flip
drawmap()
Flip
SetBuffer BackBuffer()
Global starting=MilliSecs()+5000
Global gamestarted=0
acnt=0
finished=0
finishtimer=0
Global updbuffer
If (maxx*szx)<scx And (maxy*szy)<scy Then scrollmode=0 Else scrollmode=1
won=0
Repeat
updbuffer=0
If (MilliSecs()-lstbf)>1000/30 Then updbuffer=1:lstbf=MilliSecs()
;updbuffer=1
;updbuffer=(updbuffer+1) Mod 2
spread
If gamestarted=0 Then drawmap()
If gamestarted=0 And starting<MilliSecs() Then gamestarted=1:DRAWMAP
dfloor
dfx=camx
dfy=camy
dfx=dfx+(scx/2)
dfy=dfy+(scy/2)
dfx=dfx/szx
dfy=dfy/szy
If scrollmode Then drawmapfrom dfx,dfy;camx,camy;px(1),py(1)
If (finished=1 And scrollmode=0) Or dm=1 Then
For x=(maxx/2)-7 To (maxx/2)+7
For y=(maxy/2)-5 To (maxy/2)+2
drawtile x,y
Next
Next
EndIf
dm=0
drawplayers
If gamestarted Then updateplayers
For n=1 To maxplayers
If starting>MilliSecs() And playertype(n)=1 Then
mx=px(n)*szx
my=py(n)*szy
Text2 mx,((my)+basey)-szy,playername$(n),1,0
EndIf
dm=1
Next
updateboulders
colour 0,0,0
Rect 0,0,scx,basey-1,1
colour 255,255,255
dm=0
If gamestarted=0 Then
tx$="Level "+Str$(level)+"!!!"
Text2 scx/2,((scy-basey)/2)-txsize,tx$,1,1
tx$=Int((starting-MilliSecs())/1000)
If tx$="4" Then tx$=""
If tx$="0" Then tx$="GO!!!!"
Text2 scx/2,(scy-basey)/2,tx$,1,1
dm=1
EndIf
nv2=1
For nv#=1 To maxplayers
If lives(nv)>0 Then
Text2 (scx/4)*(nv2-.5),10,playername$(nv),1,1
Text2 (scx/4)*(nv2-.25),32,"x"+lives(nv),1,1
Text2 (scx/4)*(nv2-.9),32,constr(score(nv),6),0,1
nv2=nv2+1
EndIf
Next
;won=0
cnt=0
ck=0
For n=1 To maxplayers
If lives(n)>0 Then cnt=cnt+1:If won=0 Then ck=1
Next
sc=0
If cnt=1 Then
If ck=1 Then
For n2=1 To maxplayers
If score(n2)>sc Then won=n2:sc=score(n2)
Next
EndIf
EndIf
If cnt<2 Then Text2 scx/2,(scy-basey)/2,playername$(won)+" WINS!!!",1,1:dm=1
If finished=1 And lives(1)>0 And won=0 And cnt>0 Then Text2 scx/2,(scy-basey)/2,"Level Complete!",1,1:dm=1
If finished=1 And lives(1)<1 Then Text2 scx/2,(scy-basey)/2,"G A M E O V E R ! ! !",1,1:dm=1:gamestarted=1
If updbuffer=1 Then Flip 0:CopyRect 0,0,scx,scy,0,0,FrontBuffer(),BackBuffer()
Repeat
updatesound()
Until (MilliSecs()-Lastcycle)>1000/60 Or KeyDown(1)
Lastcycle=MilliSecs()
;Cls
;updatesound()
If mushrooms=0 And finished=0 Then finished=1:finishedtimer=MilliSecs()+5000
If lives(1)=0 And FINISHED=0 Then finished=1:finishedtimer=MilliSecs()+5000:STOPSOUND():diefx
If cnt=1 And FINISHED=0 Then finished=1:finishedtimer=MilliSecs()+5000:STOPSOUND():winfx
Until KeyDown(1) Or (finished=1 And finishedtimer<MilliSecs())
If lives(1)=0 Or cnt<2 Then Goto restart
level=level+1
If KeyDown(1) Then Goto restart
Goto Nextlevel
End
Function colour(r1,g1,b1)
r=r1:g=g1:b=b1
inv=4
If inv=1 Then r=b1:g=g1:b=r1
If inv=2 Then r=g1:g=b1:b=r1
If inv=3 Then r=r1:g=b1:b=g1
If inv=4 Then r=r1:g=g1:b=b1
rn#=Rnd(.75,1.5)
rn=-((r-128)+(g-128)+(b-120))/3
;rn=((r-128)+(g-128)+(b-120))/6
rn=rn*1.5
rn=1-(rn/128)
;rn=rn*20
;r=r*rn:g=g*rn:b=b*rn
If r>255 Then r=255
If g>255 Then g=255
If b>255 Then b=255
If r<0 Then r=0
If g<0 Then g=0
If b<0 Then b=0
;If r<>0 Or g<>0 Or b<>0 Then r=255-r:g=255-g:b=255-b
Color r,g,b
End Function
Function drawmap()
dfloor
Local x,y
For x=0 To maxx
For y=0 To maxy
updatesound
drawtile x,y
Next
Next
;Flip
End Function
Function drawmapfrom(x,y)
Local sx,sy,ex,ey,mx,my
If cammvx<>0 Or cammvy<>0 Then
;Cls
scy=scy-basey
sx=(scx/2)/szx+x
sy=(scy/2)/szy+y
ex=sx+(scx/szx)+x
ey=sy+(scy/szy)+y
sx=x-(scx/2)/szx
sy=y-(scy/2)/szy
ex=x+(scx/2)/szx
ey=y+(scy/2)/szy
CopyRect 0,basey,scx,scy,cammvx,cammvy+basey
xtm#=Float(cammvx)/Float(szx)
ytm#=Float(cammvy)/Float(szy)
If Abs(xtm)<1 Then xtm=Sgn(xtm)
If Abs(ytm)<1 Then xtm=Sgn(ytm)
If Abs(xtm)>3 Or Abs(ytm)>3 Then cammvx=0:cammvy=0
If cammvx>0 Then ex=sx+xtm+1:sy=sy-1:ey=ey+1
If cammvx<0 Then sx=(ex-xtm)-1:sy=sy-1:ey=ey+1
If cammvy>0 Then ey=(sy+ytm)+1:sy=sy-1
If cammvy<0 Then sy=(ey-ytm)-2
For mx=sx-1 To ex
For my=sy-1 To ey
If mx>-1 And mx<maxx+1 And my>-1 And my<maxy+1 Then
drawtile mx,my
Else
EndIf
Next
Next
scy=scy+basey
cammvx=0
cammvy=0
EndIf
End Function
Function updateplayers()
For n=1 To maxplayers
If dead(n) Then Goto dontupdateplayer
mx#=px(n)
my#=py(n)
If MX<0 Then MX=0
If MX>MAXX Then MX=MAXX
If MY<0 Then MY=0
If MY>MAXY Then MY=MAXY
If map4(mx,my-1) Then addboulder(mx,my-1,n,25)
If map4(mx,my+1) And pd(n)>0 Then addboulder(mx,my+1,n,1)
If ((MilliSecs()-Lastupdate(n))>50000) Or ok2move(n)=1 Then
If playertype(n)=0 Then ; if AI player
ignoreboulders=1
If pc(n)<>0 Or pd(N)<>0 Then
musha=0
For c=-1 To 1
For d=-1 To 1
If c=0 Or d=0 And (c<>0 Or d<>0) Then
If map3(mx+c,my+d)<>0 Then pc(n)=c:pd(n)=d:musha=1
EndIf
Next
Next
If Rnd(0,100)>60 Or musha=1 Then Goto dontdoanythingAI
EndIf
mdst=500
c=pc(n)
d=pd(n)
If map3(px(n)+c,py(n)+d )=4 Then Goto nochangecd
pc(n)=0
pd(n)=0
tx=0:ty=0
For c=-30 To 30
For d=-30 To 30
xx=mx+c:yy=my+d
dst=Abs((xx-mx))+Abs((yy-my));/2.0
If xx<0 Then xx=0 Else If xx>maxx Then xx=maxx
If yy<0 Then yy=0 Else If yy>maxy Then yy=maxy
;If (c<>0 Or d<>0) And (c=0 Or d=0) Then
If map3(xx,yy)<>0 And dst<=mdst Then
; If mapok(mx+Sgn(c),my+Sgn(d)) Then pc(n)=Sgn(c):pd(n)=Sgn(d):mdst=dst:tx=mx+c:ty=my+d
ok=1
For c2=1 To c:For d2=1 To d
If mapok(mx+c2,my+d2)=0 Then ok=0
Next:Next
If ok=1 Then pc(n)=Sgn(c):pd(n)=Sgn(d):mdst=dst:tx=mx+c:ty=my+d:If dst<3 Then tx=0:ty=0
EndIf
;EndIf
Next
Next
;If mapok(mx+pc(n),my+pd(n))=0 Then pc(n)=-pc(n):pd(n)=-pd(n)
;pc(n)=0
;pd(n)=0
If Rand(0,100)>95 Then pc(n)=0:pd(n)=0
If pc(n)=0 And pd(n)=0 Then
For c=-1 To 1
For d=-1 To 1
xx=mx+c:yy=my+d
dst=Abs((xx-mx))+Abs((yy-my))/2.0
If xx<0 Then xx=0 Else If xx>maxx Then xx=maxx
If yy<0 Then yy=0 Else If yy>maxy Then yy=maxy
;If (c<>0 Or d<>0) And (c=0 Or d=0) Then
If mapok(xx,yy) Then
pc(n)=Sgn(c):pd(n)=Sgn(d):mdst=dst
EndIf
;EndIf
Next
Next
EndIf
.nochangecd
;ln=findpath(cfx(n),cfy(n),ctx(n),cty(n))
;If mapok(mx+pc(n),my+pd(n))=0 Then
oka=okahead(mx,my,pc(n),pd(n))
If oka<0 And oka>-3 Then
lds=1
opc=pc(n)
opd=pd(n)
findbestdirection(mx,my)
If dirx<>0 Or diry<>0 Then pc(n)=dirx:pd(n)=diry
If pc(n)=0 And pd(n)=0 Then
For c=-10 To 10
For d=-10 To 10
xx=mx+c:yy=my+d
;dst=Abs((xx-mx))+Abs((yy-my))
If xx<0 Then xx=0 Else If xx>maxx Then xx=maxx
If yy<0 Then yy=0 Else If yy>maxy Then yy=maxy
If (c<>0 Or d<>0) And (c=0 Or d=0) Then
If map2(xx,yy)<>0 Then
pc(n)=Sgn(c):pd(n)=Sgn(d):mdst=dst
EndIf
EndIf
Next
Next
EndIf
;If OKAHEAD(Xx,yy,pc(n),pd(n))<>1 Then pc(n)=-opc:pd(n)=-opd
EndIf
.justmove
xx=mx+Sgn(pc(n))
yy=my+Sgn(pd(n))
For n2=1 To maxplayers
If xx=px(n2) And yy=py(n2) Then pc(n)=-pc(n):pd(n)=-pd(n)
Next
ok2move(n)=0
If pc(n)<>0 And pd(n)<>0 Then
If Rand(2)=1 Then pc(n)=0 Else pd(n)=0
EndIf
;If map3(mx,my)=4 Then map3(mx,my)=0
mapv=map(mx+pc(n),my+pd(n))
If mapv<>3 And mapv<>2 Then pc(n)=0:pd(n)=0
If (pc(n)=0 And pd(N)=0) Or mapok(mx+pc(n),my+pd(n))=0 Then
findbestdirection(mx,my)
If dirx<>0 Or diry<>0 Then pc(n)=dirx:pd(n)=diry
EndIf
.dontdoanythingAI
ignoreboulders=0
Else
;Player controlled stuff
opc=pc(N)
opd=pd(n)
pc(N)=0
pd(n)=0
pc(n)=-(KeyDown(Leftkey(n))-KeyDown(Rightkey(n)))
pd(n)=KeyDown(downkey(n))-KeyDown(upkey(n))
If pc(N)<>0 And pd(N)<>0 Then
If pc(n)<>opc Then pd(n)=0
If pd(N)<>opd Then pc(N)=0
EndIf
EndIf
ignoreboulders=0
c=Sgn(pc(n))
mx=px(n):my=py(N)
If map4(mx+c,my)<>0 And Abs(c)<>0 Then
addboulder(mx+c,my,n,10)
If mx>2 And mx<maxx-2 Then
If map4(mx+c*2,my)=0 And mapok(mx+c*2,my) Then map4(mx+c*2,my)=map4(mx+c,my):map4(mx+c,my)=0:addboulder(mx+c*2,my,n,10):If mapok(mx+c*3,my)=0 And mapok(mx+c*2,my+1)=0 Then map3(mx+c*2,my)=0:map2(mx+c*2,my)=0
EndIf
EndIf
If mapok(px(n)+pc(n),py(n)+pd(n))=0 Then pc(n)=0:pd(N)=0
px(n)=Int(px(n)):py(n)=Int(py(n))
px(n)=px(n)+Sgn(pc(n))
py(n)=py(n)+Sgn(pd(n))
ok2move(n)=0
lastupdate(n)=MilliSecs()
EndIf
.dontupdateplayer
Next
End Function
Function drawplayers()
Local n,x,y
For n=1 To maxplayers
mx=px(n)
my=py(n)
If MAP3(MX,MY)=4 Then map3(mx,my)=0:score(n)=score(n)+10:If n=1 Then collectsfx(1)
For x=mx-1 To mx+1
For y=my-1 To my+1
;If scrollmode=0 Then
drawtile(x,y)
Next:Next
Next
For n=1 To maxplayers
If lives(n)<1 Then diecounter(n)=10:dead(n)=1:px(n)=0:py(N)=0:pdx(n)=0:pdy(n)=0
If diecounter(n)>0 Then
diecounter(n)=diecounter(n)-1
If diecounter(n)=0 Then positionplayer(n,sx(n),sy(n)):dead(n)=0:map4(sx(n),sy(n))=0:drawmap()
Goto nxtplay
EndIf
If dead(n)=1 Then Goto nxtplay
mx=px(n);/szx
my=py(n);/szy
xad#=(((px(n)*szx)-pdx(n)))
yad#=(((py(n)*szy)-pdy(n)))
maxm=szx/16
If Abs(xad)>maxm Then xad=Sgn(xad)*maxm
If Abs(yad)>maxm Then yad=Sgn(yad)*maxm
If Abs(xad)<1 And Abs(yad)<1 Then ok2move(n)=1
ok2m=0
If Abs(xad)<1 Then pdx(n)=mx*szx:xad=0
If Abs(yad)<1 Then pdy(n)=my*szy:yad=0
;xad=xad/10.0
;yad=yad/10.0
pdx(n)=pdx(n)+xad
pdy(n)=pdy(n)+yad
;PDX(N)=PX(N)*SZX
;PDY(N)=PY(N)*SZY
;sound 2,1,101,1
; sound 3,1,102,1
If pc(n)<>0 Or pd(n)<>0 Then fr(n)=fr(n)+.1
If fr(n)>1.9 Then fr(n)=0
If updbuffer=1 Then DrawImage playerimg(n,Floor(fr(n))+1),pdx(n)-camx,(pdy(n)-camy)+basey
If map4(Int(pdx(n)/szx),Int(pdy(n)/szy))<>0 Then
For x=mx-1 To mx+1
For y=my-1 To my+1
;If scrollmode=0 Then
drawtile(x,y)
Next:Next
die n
EndIf
.nxtplay
Next
End Function
Function Creategfx(number,variant=1)
Local image=CreateImage(szx,szy),cb#,x#,y#,x1#,x2#,cnt,n#,ex#,ey#,bx#,by#,sx#
cb=GraphicsBuffer()
SetBuffer ImageBuffer(image)
If number=1 ;brick
colour 0,220,50
colour 0,255,255
Rect 0,0,szx,szy,1
colour 0,0,0
stp=szy/4.0
cnt=0
For n=0 To szy Step 1
cnt=(cnt+1) Mod 2
Line 0,n,szx,n
For p=0 To 4
bs=cnt*(szx/8)
Line (p*szx/4)+bs,n,(p*szx/4)+bs,stp+n
Next
n=n+stp-1
Next
EndIf
If number=2 Then ;mud
colour 150,100,0
Rect 0,0,szx,szy,1
colour 0,0,0
For n=0 To szx
Plot Rnd(szx),Rnd(szy)
Next
EndIf
If number=3 Then ;grass
colour 0,170,0
Rect 0,0,szx,szy,1
colour 0,100,0
For n=0 To 50
Plot Rnd(szx),Rnd(szy)
Next
EndIf
If number=4 Then
; colour 0,170,0
;Rect 0,0,szx,szy,1
;colour 0,254,200
For sx#=0 To 1 Step .05;(szx/4)*2
ex#=szx/2.0
ey#=szy/3.0
x1#=ex*sx
x2#=ey*sx
colour 0,254*sx,200*sx
bx=(szx/4)
by=(szy/3)
Oval bx+(ex-x1)/2.0,by+(ey-x2)/2.0,x1,x2,0
Next
; Oval szx/4,szy/3,(szx/4)*2,szy/3
colour 0,0,0
Rect 0,(szy/2)+szy/10,szx,szy/2
colour 140,120,0
Rect (szx/2)-szx/8,(szy/3)*2,szx/4,szy/6,1
Oval (szx/2)-szx/8,(szy/2),szx/4,szy/3,1
;For n=0 To szx
;x=Rnd(szx)
;y=Rnd(szy)
; Getcolour(x,y)
;If colourRed()=0 And colourGreen()=170 And colourBlue()=0 Then colour 0,100,0:Plot x,y
; Next
EndIf
If number=5 ;red brick
colour 224,70,0
;colour 224,50,100
Rect 0,0,szx,szy,1
colour 0,0,0
stp=szy/4.0
cnt=0
For n=0 To szy Step 1
cnt=(cnt+1) Mod 2
Line 0,n,szx,n
For p=0 To 4
bs=cnt*(szx/8)
Line (p*szx/4)+bs,n,(p*szx/4)+bs,stp+n
Next
n=n+stp-1
Next
EndIf
If number=6 ;edge wall
For sx=1 To 0 Step -.01
colour 255,255*sx,0
x=sx*szx
y=sx*szy
Line x,y,szx-x,y
Line szx-x,y,szx-x,szy-y
;Line x,y,szx/2,y
;Line x,y,x,szy/2
x=szx-(sx*szx)
y=szy-(sx*szy)
Next
colour 10,10,10
Line 0,0,szx,szy
Line szx,0,0,szy
Rect 0,0,szx+1,szy+1,0
EndIf
If number=7 ;water
colour 50,60,200
Rect 0,0,szx,szy,1
colour 100,100,255
For n=0 To szx/2.0
Plot Rnd(szx),Rnd(szy)
Next
EndIf
If number=8 Then ;rock
colour 200,200,0
;Oval (scx/2)-scx/3,szy/2,(szx/2)-1,szy/2
Oval 0,0,szx-1,(szy-1)/1.1
colour 255,255,0
Oval 0,0,szx-1,(szy-1)/1.2
EndIf
If number=255 Then ;Player walk frame 1
colour 255,255,255
Oval szx/4,szy/6,(szx/4.0)*3.0,szy/6+szx/2.5,0
Oval (szx/2)-szx/6,0,(szx/2)+szx/12,szy/8+szy/2,0
x1=1
x2=2
colour hatred,hatgreen,hatblue
Oval ((szx/2)-szx/6)+x1,0+x1,((szx/2)+szx/12)-x2,(szy/8+szy/2)-x2,1
colour 0,250,200
If variant=2 Then colour 80,120,0
If variant=3 Then colour 200,200,10
Oval (szx/4)+x1,(szy/6)+x1,((szx/4.0)*3.0)-x2,(szy/6+szx/2.5)-x2,1
colour 255,255,255
Line ((szx/2)+szx/3),szy/6,0,szy/6.0
colour 255,0,255
Oval (szx/3)+szx/12,szy/3,szx/8,szy/8,1
Oval ((szx/3)*2)+szx/12,szy/3,szx/8,szy/8,1
;Plot szx/3,szy/3
;Plot (szx/3)*2,szy/3
colour 255,255,255
Line szx/3,(szy/3)*2,szx/5,((szy/3)*2)+szy/12
Line (szx-(szx/3))+szx/6,(szy/3)*2,(szx-(szx/5)+szx/6),((szy/3)*2)+szy/6
Line szx/2.2,(szy/3)*2,szx/2.2,((szy/3)*2)+szy/5
Line (szx-(szx/2.2))+szx/6,(szy/3)*2,(szx-(szx/2.2))+szx/6,((szy/3)*2)+szy/12
EndIf
If number=256 Then ;Player walk frame 2
colour 255,255,255
Oval szx/4,szy/6,(szx/4.0)*3.0,szy/6+szx/2.5,0
Oval (szx/2)-szx/6,0,(szx/2)+szx/12,szy/8+szy/2,0
x1=1
x2=2
colour hatred,hatgreen,hatblue
Oval ((szx/2)-szx/6)+x1,0+x1,((szx/2)+szx/12)-x2,(szy/8+szy/2)-x2,1
colour 0,250,200
If variant=2 Then colour 80,120,0
If variant=3 Then colour 200,200,10
Oval (szx/4)+x1,(szy/6)+x1,((szx/4.0)*3.0)-x2,(szy/6+szx/2.5)-x2,1
colour 255,255,255
Line ((szx/2)+szx/3),szy/6,0,szy/6.0
colour 255,0,255
Oval (szx/3)+szx/12,szy/3,szx/8,szy/8,1
Oval ((szx/3)*2)+szx/12,szy/3,szx/8,szy/8,1
;Plot szx/3,szy/3
;Plot (szx/3)*2,szy/3
colour 255,255,255
Line szx/3,(szy/3)*2,szx/5,((szy/3)*2)+szy/6
Line (szx-(szx/3))+szx/6,(szy/3)*2,(szx-(szx/5)+szx/6),((szy/3)*2)+szy/12
Line szx/2.2,(szy/3)*2,szx/2.2,((szy/3)*2)+szy/12
Line (szx-(szx/2.2))+szx/6,(szy/3)*2,(szx-(szx/2.2))+szx/6,((szy/3)*2)+szy/5
EndIf
SetBuffer cb
Return image
End Function
Function setmap(x,y,set,mapset=1)
If mapset=1 Then
map(x,y)=set
map(maxx-x,y)=set
map(maxx-x,maxy-y)=set
map(x,maxy-y)=set
EndIf
If mapset=2 Then
map2(x,y)=set
map2(maxx-x,y)=set
map2(maxx-x,maxy-y)=set
map2(x,maxy-y)=set
EndIf
If mapset=3 Then
map3(x,y)=set
map3(maxx-x,y)=set
map3(maxx-x,maxy-y)=set
map3(x,maxy-y)=set
EndIf
End Function
Function createlevel(lev)
mushrooms=0
Local msx,msy
SeedRnd lev
For x=0 To maxx
For y=0 To maxy
map(x,y)=3
map2(x,y)=0
map3(x,y)=0
map4(x,y)=0
If x=0 Or x=maxx Or y=0 Or y=maxy Then map(x,y)=6
Next
Next
x=Rand(2,maxx-2)
y=Rand(2,maxy-2)
cd=0
c=0:d=0
For nv=3 To 0 Step -1
If nv=3 Then ng=7:amt=1000
If nv=2 Then ng=1:amt=500
If nv=1 Then ng=5:amt=500
If nv=0 Then ng=3:amt=Sqr(maxx*maxy)*Rand(3,5+(lev/3)):msx=x:msy=y
difr=((maxx*maxy)/200)+1
;RuntimeError difr
cnt=0
For g=1 To amt
;If Rand(1,10)=10 Then x=Rand(1,maxx-1):y=Rand(1,maxy-1):Cd=1
If Rand(1,difr)=Int(difr/2) And cnt>4 Then cd=1
If nv<>0 And nv<>3 Then
If map(x,y)=1 Or map(x,y)=5 Then setmap(x,y,3):x=x-c:y=y-d:setmap(x,y,3):cd=1:x=x+c:y=y+d
x=x+c:y=y+d
If x>0 And x<maxx And y>0 And y<maxy Then If map(x,y)=1 Or map(x,y)=5 Then cd=1
x=x+c:y=y+d
;If x>0 And x<maxx And y>0 And y<maxy Then If map(x,y)=1 Or map(x,y)=5 Then cd=1
x=x-c:y=y-d
x=x-c:y=y-d
EndIf
cnt=cnt+1
If cd=1 Then
cnt=0
Repeat:c=Rand(-1,1):d=Rand(-1,1):
If (c=0 And d=0) Or (c<>0 And d<>0) Then c=0:d=0
xx=x+c
yy=y+d
If xx<1 Then xx=1 Else If xx>maxx Then xx=maxx
If yy<1 Then yy=1 Else If yy>maxy Then yy=maxy
mp=map(xx,yy)
;If KeyDown(1) Then End
Until (c<>0 Or d<>0)
cd=0
EndIf
If x<1 Then x=maxx-1
If y<1 Then y=maxy-1
If x>maxx-1 Then x=1
If y>maxy-1 Then y=1
setmap(x,y,ng)
If ng=3 Then setmap(x,y,ng,2)
If ng<>3 Then setmap(x,y,0,2)
;map(x,y)=ng
;map(x,maxy-y)=ng
;map(maxx-x,y)=ng
;map(maxx-x,maxy-y)=ng
x=x+c
y=y+d
;If ng=4 Then ng=3
Next
Next
For n=1 To maxplayers
Repeat:x=Rand(1,maxx)
y=Rand(1,maxy)
Until map2(x,y)<>0
setmap(x,y,4,3)
Next
;setmap(x,y,0,2)
;map(x,y)=4
;map(x,maxy-y)=4
;map(maxx-x,y)=4
;map(maxx-x,maxy-y)=4
;alive(x,y)=mushlife
;alive(maxx-x,y)=mushlife
;alive(x,maxy-y)=mushlife
;alive(maxx-x,maxy-y)=mushlife
Cls
For x=0 To maxx
For y=0 To maxy
If map2(x,y)<>0 Then map(x,y)=2
;DrawBlock img(map(x,y)),x*szx,y*szy
drawtile x,y
;If map2(x,y)=0 Then DrawBlock img(1),x*szx,y*szy
Next
Next
pl=1
For n=1 To maxplayers/4
n2=4:If n+n2>maxplayers Then n2=(maxplayers Mod 4)+1
Repeat:x=Rand(1,(maxx/2)-2)
y=Rand(1,(maxy/2)-2)
ok=1
If mapok(x,y)=0 Then ok=0
For o=1 To maxplayers
If x=px(o) And y=py(o) Then ok=0
Next
If map2(x,y)=0 Then ok=0
Until ok=1
sx(pl)=x
sy(pl)=y
pl=pl+1
If pl<maxplayers+1 Then
sx(pl)=maxx-x
sy(pl)=y
pl=pl+1
EndIf
If pl<maxplayers+1 Then
sx(pl)=x
sy(pl)=maxy-y
pl=pl+1
EndIf
If pl<maxplayers+1 Then
sx(pl)=maxx-x
sy(pl)=maxy-y
pl=pl+1
EndIf
Next
For n=1 To maxplayers
px(n)=0
py(n)=0
pdx(n)=0
pdy(n)=0
If lives(n)<>0 Then
px(n)=sx(n)
py(n)=sy(n)
pdx(n)=sx(n)*szx
pdy(n)=sy(n)*szy
EndIf
Next
CT=lev*2
If CT>1024 Then CT=1024
For n=1 To CT
MS=MilliSecs()
Repeat:x=Rand(1,maxx)
y=Rand(1,maxy)
;ok=1
ok=1
If mapok(x,y-1)<>0 Then ok=0
;If mapok(x,y-1)=0 And mapok(x,y)=1 Then ok=1
If map4(x,y-1)<>0 Then ok=0
If mapok(x-1,y)=0 And mapok(x+1,y)=0 Then ok=0
;If mapok(x-2,y)=0 Then ok=0
;If mapok(x+2,y)=0 Then ok=0
If mapok(x,y)=0 Then ok=0
If mapok(x,y+1)=0 Then ok=0
If map4(x-1,y)<>0 Or map4(x+1,y)<>0 Then ok=0
For o=1 To maxplayers
If x=px(o) And y=py(o) Then ok=0
Next
;If map2(x,y)=0 Then ok=0
Until ok=1 Or KeyDown(1) Or MilliSecs()-MS>200
If MilliSecs()-MS<200 Then map4(x,y)=8:map4(maxx-x,y)=8 Else N=10250
Next
End Function
Function spread()
Local x,y,x2,y2
mushrooms=0
For x=1 To maxx-1
For y=1 To maxy-1
If map4(x,y)<>0 And map3(x,y)<>0 Then map3(x,y)=0
If map3(x,y)<>0 Then mushrooms=mushrooms+1
Next
Next
ct=0
For nn=1 To maxplayers
If lives(nn)>0 Then ct=ct+1
Next
For nn=1 To (maxx/16)*(ct*.7)
x=Rand(1,maxx-1)
y=Rand(1,maxy-1)
If map3(x,y)=4 Then
Repeat:c=Rand(-1,1):d=Rand(-1,1):
If (c=0 And d=0) Or (c<>0 And d<>0) Then c=0:d=0
Until (c<>0 Or d<>0)
x2=x+c
y2=y+d
If map3(x2,y2)=4 Then alive(x2,y2)=mushlife
If map(x2,y2)=3 Or map(x2,y2)=2
If Rand(100)>0 Then
ok=1
For n2=1 To maxplayers:If px(n2)=x2 And py(n2)=y2 Then ok=0
If px(n2)+pc(n2)=x2 And py(n2)+pd(n2)=y2 Then ok=0
If px(n2)-pc(n2)=x2 And py(n2)-pd(n2)=y2 Then ok=0
Next
If ok=1 Then
map3(x2,y2)=4:Lastspread=MilliSecs():alive(x2,y2)=mushlife
drawtile(x2,y2)
EndIf
EndIf
EndIf
EndIf
Next
;EndIf
End Function
Function drawtileo(x,y)
If updbuffer=1 Then
If map(x,y)<>0 Then DrawBlock img(map(x,y)),(x*(szx))-camx,((y*(szy))-camy)+basey
If map3(x,y)<>0 Then DrawImage img(map3(x,y)),(x*szx)-camx,((y*szy)-camy)+basey
If map4(x,y)<>0 Then DrawImage img(8),(x*szx)-camx,((y*szy)-camy)+basey
EndIf
End Function
Function drawtile(x,y)
Local mx=(x*szx)-camx
Local my=(y*szy)-camy
If mx>-szx And mx<scx And my>-szy And my<scy And updbuffer=1 Then
;Local o,n=WaitTimer(audiotimer):If n>0 Then For o=1 To n::Next
If x>-1 And x<maxx+1 And y>-1 And y<maxy+1 Then
If map(x,y)<>0 Then DrawBlock img(map(x,y)),(x*(szx))-camx,((y*(szy))-camy)+basey
If map3(x,y)<>0 Then DrawImage img(map3(x,y)),(x*szx)-camx,((y*szy)-camy)+basey
If map4(x,y)<>0 Then DrawImage img(8),(x*szx)-camx,((y*szy)-camy)+basey
EndIf
EndIf
End Function
Function dfloor()
If DEAD(1)=0 Then
camx=pdx(1)-(scx/2)
camy=pdy(1)-(scy/2)
If camx<0 Then camx=0
If camy<0 Then camy=0
If camx>((maxx+1)*szx)-scx Then camx=((maxx+1)*szx)-scx
If camy>((maxy+1)*szy)-(scy-basey) Then camy=((maxy+1)*szy)-(scy-basey)
cammvx=-(camx-ocamx)
cammvy=-(camy-ocamy)
ocamx=camx
ocamy=camy
EndIf
End Function
Function mapok(x,y) ;checks for presence of anything including players
Local n
If ignoreboulders=0 Then
For n=1 To maxplayers
If px(n)=x And py(n)=y Then Return 0
If Int(pdx(n)/szx)=x And Int(pdy(n)/szy)=y Then Return 0
Next
EndIf
If ignoreboulders=0 Then If map4(x,y)<>0 Then Return 0
If x<1 Or x>maxx-1 Or y<1 Or y>maxy-1 Then Return 0
If map(x,y)=3 Or map(x,y)=2 Then Return 1
Return 0
End Function
Function mapok2(x,y) ;checks for presence of anything excludin players and boulders
Local n
;If map4(x,y)<>0 Then Return 0
If x<1 Or x>maxx-1 Or y<1 Or y>maxy-1 Then Return 0
If map(x,y)=3 Or map(x,y)=2 Then Return 1
Return 0
End Function
;Hat colours for players
Data 4 ;Number of colours listed
Data 100,200,0
Data 255,0,0
Data 0,0,255
Data 100,0,255
Data 100,255,0
Data 50,50,150
Data 255,0,255
Data 100,255,50
Function findpath(sx,sy,ex,ey)
For x=1 To maxx
For y=1 To maxy
;If map4(x,y)<>0 Then map4(x,y)=0:drawtile x,y
Next
Next
n.path=New path
n\x=sx
n\y=sy
cntr=0
done=0
;Repeat
For n.path=Each path
If done=0 Then
done=checkpath(n\x,n\y,ex,ey,cntr):cntr=cntr+1:Delete n
EndIf
Next
;Until done
Return done
End Function
Function checkpath(x,y,ex,ey,cntr)
Local c,d,n.path
For c=-1 To 1
For d=-1 To 1
If c=0 Or d=0 And Abs(c)<>Abs(d) Then
If (map(x+c,y+d)=2 Or map(x+c,y+d)=3) And map4(x+c,y+d)=0 Then
map4(x+c,y+d)=cntr
drawtile(x+c,y+d)
n.path=New path
n\x=x+c
n\y=y+d
;If KeyDown(1) Then End
EndIf
EndIf
Next
Next
If x=ex And y=ey Then Return 1
End Function
Function positionplayer(n,x,y)
px(n)=x:py(n)=y:pdx(n)=x*szx:pdy(n)=y*szy
End Function
Function die(player)
dead(player)=1
diecounter(player)=60
lives(player)=lives(player)-1
;If playertype(player)<>0 Then
diefx;EndIf
End Function
Function diefx()
FLUSHCHANNEL 3
For nv#=1 To 0 Step -.4
sound 3,nv,220,15
;sound 3,.8,100,10
Next
End Function
Function winfx()
FLUSHCHANNEL 3
FLUSHCHANNEL 4
FLUSHCHANNEL 5
For nv#=1 To 0 Step -.4
sound 3,nv,220,15,3
sound 4,nv,232,15,3
sound 5,nv,240,15,3
;sound 3,.8,100,10
Next
End Function
Function okahead(x,y,c,d)
ok=-1000
x=x+c:y=y+d
cnt=0
For nn=1 To maxx
If x<0 Then x=0 Else If x>maxx Then x=maxx
If y<0 Then y=0 Else If y>maxy Then y=maxy
If map3(x,y)<>0 Then ok=1:dsn=cnt+9000:nn=maxx+1
If mapok(x,y)=0 And ok<>1 And nn<5 Then ok=2:dsn=cnt:nn=maxx+1
For c2=-1 To 1
For d2=-1 To 1
If (c2=0 Or d2=0) And (c2<>0 Or d2<>0) Then
If mapok(x+c2,y+d2) Then cnt=cnt+1
EndIf
Next
Next
cnt=cnt+1
x=x+c:y=y+d
Next
If ok=1 Then ok=dsn
If ok=2 Then ok=-dsn;dsn+1024
Return ok
End Function
Function distancehead(x,y,c,d)
ok=-1000
x=x+c:y=y+d
cnt=0
For nn=1 To maxx
If x<0 Then x=0 Else If x>maxx Then x=maxx
If y<0 Then y=0 Else If y>maxy Then y=maxy
If map3(x,y)<>0 Then dsn=cnt+1024:ok=1:nn=maxx+1
If mapok(x,y)<>0 Then dsn=cnt:ok=1:nn=maxx+1
cnt=cnt+1
x=x+c:y=y+d
Next
If ok=1 Then ok=dsn
Return ok
End Function
Function finddirection(x,y)
Local c,d,dst=0
odirx=dirx:odiry=diry
For bc=-1 To 1
For bd=-1 To 1
If (bc=0 Or bd=0) And (bd<>0 Or bc<>0) Then
distance=distancehead(x,y,bc,bd)
;If distance=-1000 Then distance=0
;If distance>0 Then distance=distance+1000
;If distance<0 Then distance=-distance
If distance>=dst Then dst=distance:dirx=bc*dst:diry=bd*dst
EndIf
Next
Next
If dirx=0 And diry=0 Then
dst=0
For bc=-1 To 1
For bd=-1 To 1
If (bc=0 Or bd=0) And (bd<>0 Or bc<>0) Then
distance=distancehead(x,y,bc,bd)
If distance>=dst Then dst=distance:dirx=bc*dst:diry=bd*dst
EndIf
Next
Next
If dirx=0 And diry=0 Then dirx=odirx:diry=odiry
EndIf
End Function
Function findbestdirection(x,y)
Local c[4],d[4]
If mapok(x,y+1) Then
finddirection(x,y+1)
c[1]=dirx:d[1]=diry
EndIf
If mapok(x,y-1) Then
finddirection(x,y-1)
c[2]=dirx:d[2]=diry
EndIf
If mapok(x+1,y) Then
finddirection(x+1,y)
c[3]=dirx:d[3]=diry
EndIf
If mapok(x-1,y) Then
finddirection(x-1,y)
c[4]=dirx:d[4]=diry
EndIf
bd=0
bc=0
For n=1 To 4
If Abs(c[n])>abc Or Abs(d[n])>abd Then bc=c[n]:bd=d[n]:abc=Abs(bc):abd=Abs(bd):seldn=n
Next
If seldn=1 Then bc=0:bd=1
If seldn=2 Then bc=0:bd=-1
If seldn=3 Then bc=1:bd=0
If seldn=4 Then bc=-1:bd=0
fs=WriteFile("temp.txt")
For n=1 To 4
If c[n]<>0 Or d[n]<>0 Then fns=1
WriteLine fs,c[n]+", "+d[n]
Next
WriteLine fs,bc+", "+bd
CloseFile fs
;If fns=1 Then
;ExecFile "temp.txt"
;End
;EndIf
dirx=bc
diry=bd
Goto Exitbit
For bc=-1 To 1
For bd=-1 To 1
If (bc=0 Or bd=0) And (bd<>0 Or bc<>0) Then
If mapok(x+bc,y+bd)<>0 Then
EndIf
EndIf
Next
Next
.Exitbit
End Function
Function setuptext()
Local n,bf
For n=32 To 128
charimg(n,0)=CreateImage(txsize,txsize)
bf=GraphicsBuffer()
SetBuffer ImageBuffer(charimg(N,0))
colour 128,128,128
colour 0,0,0
;colour 255,255,0
For c=-1 To 1
For d=-1 To 1
Text (txsize/2.0)-c,(txsize/2.0)-d,Chr$(n),1,1
Next:Next
colour 255,255,255
colour 255,255,0
Text (txsize/2.0),(txsize/2.0),Chr$(n),1,1
;Text (txsize/2.0)+1,(txsize/2.0),Chr$(n),1,1
;Text (txsize/2.0),(txsize/2.0)+1,Chr$(n),1,1
;Text (txsize/2.0)+1,(txsize/2.0)+1,Chr$(n),1,1
ScaleImage charimg(n,0),txscale,txscale
MidHandle charimg(n,0)
For n2=1 To Textcnt
charimg(n,n2)=CopyImage(charimg(n,0))
MidHandle charimg(n,0)
RotateImage charimg(n,n2),((n2-1)-Textcnt/2.0)*4
Next
Next
txsize=txsize*txscale
SetBuffer bf
End Function
Function Text2(x,y,Txt$,centre_x=0,centre_y=0)
Local n,a,t$,drawx,drawy
If centre_x=1 Then x=x-Len(txt$)*((txsize*txxdis)/2.0)
If centre_y=1 Then y=y-txsize/2.0
x=x+((txsize*txxdis)/2.0)
y=y+((txsize)/2.0)
For n=1 To Len(Txt$)
t$=Mid$(txt$,n,1)
a=Asc(t$)
If a>32 And a<128 Then
vl#=(Sin(MilliSecs()+(n*500))/2)+.5
vl=(vl*(Textcnt-1))+1
DrawImage charimg(a,vl),x+(n-1)*(txsize*txxdis),y
EndIf
Next
End Function
Function addboulder(x,y,player,timer)
Local n.boulder,do=1,X2,Y2
For X2=X-1 To X+1
For Y2=Y-1 To Y+1
If X2>-1 And X2<MAXX+1 And Y2>-1 And Y2<MAXY+1 Then
If MAP4(X2,Y2)<>0 And ((X2=X Or Y2=Y) And (X2<>X Or Y2<>Y)) Then MAP4(X2,Y2)=0
EndIf
Next
Next
If map4(x,y+1)=0 And mapok2(x,y+1)<>0 Then
For n=Each boulder
If n\x=x And n\y=y Then do=0
Next
If do=1 Then
n=New boulder
n\sx=x
n\sy=y
n\x=x:n\y=y
n\player=0
n\timer=timer
n\triggered=0
n\rocknumber=map4(x,y)
EndIf
EndIf
End Function
Function updateboulders()
Local n.boulder
Local oudb=updbuffer
updbuffer=1
For n=Each boulder
deld=0
ox=n\x
oy=n\y
If map4(n\x,n\y)=0 And n\reposition=0 Then Delete n:Goto nxtn
If mapok(n\x,n\y+1)=0 And n\triggered=0 Then Goto nxtn
If n\reposition=0 Then drawtile n\x,n\y
If n\timer>0 Then n\timer=n\timer-1:Goto Nxtn
If n\triggered=0 Then n\triggered=1:flushchannel 2:sound 2,1,180,20
If n\reposition=0 Then
n\timer=10
If map4(n\x,n\y+1)=0 And mapok2(n\x,n\y+1) Then
map4(n\x,n\y+1)=n\rocknumber:map4(n\x,n\y)=0:drawtile n\x,n\y:drawtile n\x,n\y+1
n\y=n\y+1
Else
n\reposition=1
map4(n\x,n\y)=0
drawtile n\x,n\y
n\timer=256
EndIf
EndIf
If n\reposition=0 Then drawtile ox,oy
If n\reposition And n\timer=0 Then
If mapok(n\sx,n\sy) Then map4(n\sx,n\sy)=n\rocknumber:map4(n\x,n\y)=0:drawtile n\x,n\y:drawtile n\sx,n\sy:Delete n:deld=1
EndIf
.Nxtn
Next
updbuffer=oudb
End Function
Function collectsfx(channel)
flushchannel channel
sound channel,1,150,6
End Function
Function Music(n)
Restore music1
Repeat
Read chan
If chan<>-1 Then
If chan<>0 Then chan=chan+5
;If chan=6 Then chan=4
Read vol#,Pitch,Length#
If chan=6 Or chan=7 Or chan=8 Then Pitch=Pitch-48
Pitch=Pitch+48
If chan=9 Then Pitch=Pitch-48*2
;Pitch=Pitch-24
sound chan,vol#,Pitch+48,Length*3,chan
loopchannel chan,1
EndIf
Until chan=-1
;Repeat
;updatesound()
;Until KeyDown(1)
;End
Restore
End Function
Function setupmusic()
adsr 0,1,-.05,.1,-.1
adsr 9,1,-.05,.1,-.1
adsr 10,1,-.05,.2,-.1
adsr 1,1,0,1,-.1
adsr 2,.2,-.05,.5,-.02
Pitchadsr 1,0,-16,0,16
Pitchadsr 2,-4,-1,-1,-2
Pitchadsr 3,-7,-7,-7,-7
adsr 3,1,-.01,.1,-.1
music(1)
soundshape 5,1
soundshape 6,1
soundshape 7,1
soundshape 3,2
soundshape 2,2
soundshape 1,2
;loopchannel 2 0
For n=5 To 8
adsr n,.2,-.05,.5,-1
Next
End Function
Function Constr$(txt$,ln)
txt$=String$(" ",ln-Len(txt$))+txt$
Return Replace(txt$," ","0")
End Function
.music1
Data 1,.5,52,10
Data 2,.5,68,10
Data 3,.5,80,10
Data 1,.5,52,10
Data 2,.5,68,10
Data 3,.5,80,10
Data 1,.5,52,10
Data 2,.5,72,10
Data 3,.5,80,10
Data 1,.5,52,10
Data 2,.5,72,10
Data 3,.5,80,10
;Data 4,1,4,5
Data 5,1,100,10
Data 5,1,100,10
Data 5,1,92,5
Data 5,1,88,5
Data 5,1,80,10
Data 5,1,72,10
Data 5,1,80,10
Data 5,1,88,10
Data 5,1,80,10
;
Data 5,1,100,10
Data 5,1,100,10
Data 5,1,92,5
Data 5,1,88,5
Data 5,1,80,5
Data 5,1,80,45
Data 4,.5,52,5
;Data 4,.5,68,5
Data 4,.5,80,5
Data 0,1,5,5
Data 0,0,50,15
Data 0,.5,150,10
Data 0,0,0,10
Data 0,1,5,5
Data 0,0,0,5
Data 0,1,5,5
Data 0,.5,20,5
Data 0,.5,150,10
Data 0,0,50,10
Data 0,1,5,5
Data 0,0,50,15
Data 0,.5,150,10
Data 0,0,0,10
Data 0,1,5,5
Data 0,0,0,5
Data 0,1,5,5
Data 0,.5,20,5
Data 0,.5,150,5
Data 0,0,150,5
Data 0,.5,150,5
Data 0,.5,150,5
Data -1
;
;
; Cygnus Software's "chip" simulator...
;
; Programmed Oct-Nov 2004
;
; Feel free to use this code anywhere,
; give credits where credits are due? I would do the same.
; http://danjeruz.servegame.com
; Have fun!!!!
Function initsoundsystem();channels,envelopes)
Local samples,o,nm,snd
Dim wavdata(1,4096)
samples=1
ss_channelcount=1
For o=0 To 10
wavdata(0,o)=-65525/2.1
Next
wavdata(0,1)=-65525/3
wavdata(0,2)=65525/3
samplerate=1
bpsample=16
wavdata(0,1)=-65525/3
wavdata(0,2)=-65525/3
wavdata(0,3)=65525/3
wavdata(0,4)=65525/3
For snd=1 To ss_sndtype
If SND=3 Then
For o=0 To 10
WAVDATA(0,O)=Sin(O*57)*65525/3.0
Next
EndIf
If SND=4 Then
For o=0 To SND*2
WAVDATA(0,O)=Sin((Float(O)/Float(SND*2))*360)*65525/3.0
Next
EndIf
samples=snd*4
Writewav(samples,"S"+Str$(snd)+".wav")
Next
For o=0 To 4096
wavdata(0,o)=Rnd(-65525/2,65525/2)
wavdata(1,o)=Rnd(-65525/2,65525/2)
Next
samples=4096
Writewav(samples,"S0.wav")
For o=0 To ss_sndtype
ss_soundbank(o)=LoadSound("s"+Str$(o)+".wav")
o2=o:If o=0 Then o2=5
ss_samplecntbank(o)=o2
DeleteFile "s"+Str$(o)+".wav"
LoopSound ss_soundbank(o)
Next
For o=0 To ss_maxchans
O2=ss_maxchans-O
nm=(((o2-1)/3) Mod ss_sndtype)+1
If o=0 Then nm=0
ss_sounds(o)=ss_soundbank(nm)
ss_samplecnt(o)=ss_samplecntbank(nm)
Next
For o=0 To ss_maxenvs
ss_defattack(o)=.1
ss_defdecay(o)=-.5
ss_defsustain(o)=0
ss_defrelease(o)=-.1
Next
For o=0 To ss_maxenvs
Next
End Function
Function sound(channel,vol#,Pitch,Length,envelope=-1)
;channel=ss_maxchans-channel
If envelope=-1 Then envelope=channel
Local count
;dim ss_bufferchan(ss_maxchans,ss_buffersize),buffervol(ss_maxchans,ss_buffersize)
;dim ss_bufferpitch(ss_maxchans,ss_buffersize)
;dim ss_bufferlength(ss_maxchans,ss_buffersize)
;dim ss_buffercount(ss_maxchans)
count=ss_buffercount(channel)
If count<0 Then count=0
ss_buffercount(channel)=count
ss_buffervol(channel,count)=vol
ss_bufferpitch(channel,count)=Pitch
ss_bufferlength(channel,count)=Length
ss_bufferenv(channel,count)=envelope
ss_buffercount(channel)=ss_buffercount(channel)+1
If ss_buffercount(channel)>ss_buffersize-1 Then Repeat:updatesound():Until KeyDown(1) Or ss_buffercount(channel)<ss_buffersize-1 Or ss_buffercount(channel)=0;:If buffercount(channel)<0 Then buffercount(channel)=0
End Function
Function updatesound()
Local n,ct,n2
If MilliSecs()-audiotimer>updateperiod Then
audiotimer=MilliSecs()
ct=Float(MilliSecs()-audiotimer)/Float(updateperiod)
If ct>2 Then ct=0
For n=0 To ct
For n2=1 To 1
doupdatesound
updatesoundtimer()
Next
Next
EndIf
End Function
Function doupdatesound()
;soundtimer()=soundtimer()+.01
Local o,count,o2,updvols=0,nx,env
Local divm#=1
For o=0 To ss_maxchans
ss_lfocounter(o)=ss_lfocounter(o)+1
env=ss_envelope(o)
;env=o
updvols=1
pastend=0
attacked=ss_attackdone(o)
If soundtimer()-ss_started(o)>=ss_slength(o)*1 Then pastend=1
count=ss_buffercount(o)
If ss_schan(o)<>0 Then
;ChannelVolume ss_schan(o),ss_volume(o)
If updvols=1 Then
;Dim ss_lfo#(ss_lfocount,ss_maxchans)
;Dim ss_lfofreq#(ss_lfocount,ss_maxchans)
;Dim ss_lfocounter(ss_maxchans)
;vlfo#=lfovalue(ss_lfocounter(o))*ss_lfofreq(2,o)*ss_lfo(2,o)
vlfo#=volumemultiplier(o)
plfo#=Pitchlfo(o)
;plfo#=lfovalue(ss_lfocounter(o))*ss_lfofreq(1,o)*ss_lfo(1,o)
;vlfo=1
;plfo=1
;For n=1 To ss_lfocount
;If ss_lfo(n,o)<ss_lfosustain(n,env) Then ss_lfo(n,o)=ss_lfo(n,o)+ss_lfoattack(n,env) Else ss_lfo(n,o)=ss_lfosustain(n,env)
;Next
If pastend=0 And attacked=0 Then ;Attack section
If ss_volume(o)<1 Then ss_volume(o)=ss_volume(o)+ss_attack(o)
If ss_volume(o)>=1 Then ss_volume(o)=1
For n=1 To ss_lfocount
If ss_lfo(n,o)<1 Then ss_lfo(n,o)=ss_lfo(n,o)+ss_lfoattack(n,env) Else ss_lfo(n,o)=1;ss_lfosustain(n,env)
Next
av#=ss_volume#(o):ChannelVolume ss_schan(o),(av+vlfo)*ss_actualvol(o)
ss_currentpitch(o)=ss_currentpitch(o)+ss_attackchange(env)
nf=freq(ss_currentpitch(O),o)
If nf>10 Then ChannelPitch ss_schan(o),nf
EndIf
If ss_volume(o)>=1 Then attacked=1:ss_attackdone(o)=1
If pastend=0 And attacked=1 Then ;Decay section
ss_volume(o)=ss_volume(o)+ss_decay(o):If ss_volume(o)<ss_sustain(o) Then ss_volume(o)=ss_sustain(o):ss_decaydone(o)=1
For n=1 To ss_lfocount
ss_lfo(n,o)=ss_lfo(n,o)+ss_lfodecay(n,env)
If ss_lfo(n,o)<ss_lfosustain(n,env) Then ss_lfo(n,o)=ss_lfosustain(n,env)
Next
av#=ss_volume#(o):ChannelVolume ss_schan(o),(av+vlfo)*ss_actualvol(o)
ss_currentpitch(o)=ss_currentpitch(o)+ss_decaychange(env)
nf=freq(ss_currentpitch(O),o)
If nf>10 Then ChannelPitch ss_schan(o),nf
EndIf
If ss_decaydone(o)=1 And pastend=0 Then ;Sustain section
ss_currentpitch(o)=ss_currentpitch(o)+ss_sustainchange(env)
av#=ss_volume#(o):ChannelVolume ss_schan(o),(av+vlfo)*ss_actualvol(o)
nf=freq(ss_currentpitch(O),o)
If nf>10 Then ChannelPitch ss_schan(o),nf
EndIf
If pastend=1 Then
ss_volume(o)=ss_volume(o)+ss_release(o):If ss_volume(o)<0 Then ss_volume(o)=0
For n=1 To ss_lfocount
ss_lfo(n,o)=ss_lfo(n,o)+ss_lforelease(n,env)
If ss_lfo(n,o)<0 Then ss_lfo(n,o)=0
Next
av#=ss_volume#(o):ChannelVolume ss_schan(o),(av+vlfo)*ss_actualvol(o)
ss_currentpitch(o)=ss_currentpitch(o)+ss_releasechange(env)
nf=freq(ss_currentpitch(O),o)
If nf>10 Then ChannelPitch ss_schan(o),nf
EndIf
EndIf
EndIf
If pastend=1 And forcesoundupdate=0 Then
count=ss_buffercount(o)
If count>0 And ss_buffercount(o)<ss_buffersize+1 Then
;For nx=1 To 10
;volume(o)=volume(o)*.9
;ChannelVolume schan(o),volume(o)
;Delay 1
;Next
If ss_channelloop(o) Then
addsound(o,ss_buffervol(o,ss_bufferpointer(o)),ss_bufferpitch(o,ss_bufferpointer(o)),ss_bufferlength(o,ss_bufferpointer(o)),ss_bufferenv(o,ss_bufferpointer(o))):ss_bufferpointer(o)=(ss_bufferpointer(o)+1) Mod count
;For o2=1 To count:buffervol(o,o2-1)=buffervol(o,o2):bufferpitch(o,o2-1)=bufferpitch(o,o2):bufferlength(o,o2-1)=bufferlength(o,o2):Next:buffercount(o)=buffercount(o)-1
EndIf
If ss_channelloop(o)=0 Then
addsound(o,ss_buffervol(o,ss_bufferpointer(o)),ss_bufferpitch(o,ss_bufferpointer(o)),ss_bufferlength(o,ss_bufferpointer(o)),ss_bufferenv(o,ss_bufferpointer(o)))
For o2=1 To count
ss_buffervol(o,o2-1)=ss_buffervol(o,o2)
ss_bufferpitch(o,o2-1)=ss_bufferpitch(o,o2)
ss_bufferlength(o,o2-1)=ss_bufferlength(o,o2)
ss_bufferenv(o,o2-1)=ss_bufferenv(o,o2)
Next:ss_buffercount(o)=ss_buffercount(o)-1:If ss_buffercount(o)<0 Then ss_buffercount(o)=0
EndIf
EndIf
EndIf
Next
End Function
Function freq(Pitch,chan)
Local p2,f
If Pitch<0 Then Pitch=Pitch+512
If Pitch>512 Then Pitch=Pitch-512
p2=(Pitch+200)+(Pitchlfo(chan));+Sin(ss_lfocounter(chan))
f = 440 * 2^(((P2/4.0) - 58)/12)
If f<10 Then f=10 Else If f>48000 Then f=48000
Return f*ss_samplecnt(chan)
End Function
Function lfovalue#(cnt)
;Return (Cos#(cnt)+1)/2.0
Return (Cos#(cnt))
End Function
Function volumemultiplier#(channel)
;env=ss_envelope(channel)
;If env<0 Or env>ss_maxenvs Then RuntimeError env
Return lfovalue(ss_lfocounter(channel)*ss_lfofreq(2,ss_envelope(channel)))*ss_lfo(2,channel)
;Return lfovalue(ss_lfocounter(channel))
End Function
Function Pitchlfo#(channel)
Return lfovalue(ss_lfocounter(channel)*ss_lfofreq(1,ss_envelope(channel)))*ss_lfo(1,channel)
End Function
Function addSound(channel,vol#,Pitch,Length#,envelope=-1)
Local p2#,o=ss_maxchans-channel,n
If envelope=-1 Then RuntimeError "sound not buffered correctly!"
ss_chancheck(channel)=0
;Goto Endbit
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
If ss_sounds(channel)<>0 Then
ss_lfocounter(channel)=0
;For n=0 To ss_lfocount
;Next
p2=freq(pitch,channel)
If p2>100 Then
SoundVolume ss_sounds(channel),0
If ChannelPlaying(ss_schan(channel))=0 Then ss_schan(channel)=0 Else StopChannel ss_schan(channel):ss_schan(channel)=0
If ss_schan(channel)=0 Then If ss_sounds(channel)<>0 Then ss_schan(channel)=PlaySound(ss_sounds(channel))
ChannelPitch ss_schan(channel),P2;+((P2+(P2*2.0))/12.0)*4.0
ChannelVolume ss_schan(channel),ss_defattack(envelope)*vol*volumemultiplier(channel);(vol)
SoundVolume ss_sounds(channel),1
For n=1 To ss_lfocount
ss_lfo(n,channel)=ss_lfoattack(n,channel)
Next
ss_currentpitch(channel)=Pitch
ss_volume(channel)=ss_defattack(envelope);vol
ss_actualvol(channel)=vol
ss_sLength(channel)=Length
ss_started(channel)=soundtimer()
ss_attack(channel)=(ss_defattack(envelope)/15)*updateperiod#
ss_release(channel)=(ss_defrelease(envelope)/15)*updateperiod#;-.2
ss_sustain(channel)=ss_defsustain(envelope);.2
ss_decay(channel)=(ss_defdecay(envelope)/15)*updateperiod#;-.8
ss_attackdone(channel)=0
ss_decaydone(channel)=0
ss_chancheck(channel)=soundtimer()
ss_envelope(channel)=envelope
EndIf
EndIf
forcesoundupdate=1
updatesound()
forcesoundupdate=0
.endbit
End Function
Function updatesoundtimer()
;Return MilliSecs()
ss_stimer#=ss_stimer#+1
Return ss_stimer
End Function
Function soundtimer()
Return ss_stimer
End Function
Function loopchannel(channel,loop=1)
ss_channelloop(channel)=loop
End Function
Function LfoADSR(envelope,Lfo,cattack#,cdecay#,csustain#,crelease#)
;ss_lfo#(lfo,ss_maxchans)
;ss_lfo(lfo,
ss_lfoattack(lfo,envelope)=cattack
ss_lfodecay(lfo,envelope)=cdecay
ss_lfosustain(lfo,envelope)=csustain
ss_lforelease(lfo,envelope)=crelease
;Dim ss_lfoattack#(ss_lfocount,ss_maxenvs)
;Dim ss_lfodecay#(ss_lfocount,ss_maxenvs)
;Dim ss_lfosustain#(ss_lfocount,ss_maxenvs)
;Dim ss_lforelease#(ss_lfocount,ss_maxenvs)
;Dim ss_lfo#(ss_lfocount,ss_maxenvs)
;Dim ss_lfofreq#(ss_lfocount,ss_maxenvs)
End Function
Function Lfo(envelope,lfo,frequency)
ss_lfofreq#(lfo,envelope)=frequency
End Function
Function ADSR(envelope,cattack#,cdecay#,csustain#,crelease#)
ss_defattack(envelope)=cattack
ss_defdecay(envelope)=cdecay
ss_defsustain(envelope)=csustain
ss_defrelease(envelope)=crelease
End Function
Function PitchADSR(envelope,cattack#,cdecay#,csustain#,crelease#)
ss_attackchange(envelope)=cattack
ss_decaychange(envelope)=cdecay
ss_sustainchange(envelope)=csustain
ss_releasechange(envelope)=crelease
End Function
Function Soundshape(channel,sound)
If sound>-1 And sound<ss_sndtype+1 Then
ss_sounds(channel)=ss_soundbank(sound)
ss_samplecnt(channel)=ss_samplecntbank(sound)
EndIf
End Function
Function flushchannel(channel)
ss_bufferpointer(channel)=0
ss_buffercount(channel)=0
If ss_schan(channel)<>0 Then If ChannelPlaying(ss_schan(channel)) Then StopChannel ss_schan(channel):ss_schan(channel)=0
ss_started(channel)=-ss_slength(channel)
End Function
Function Stopsound()
Local n
For n=0 To ss_maxchans
flushchannel n
Next
End Function
Function Writewav(wavdatalen,filename$,ss_channelcount=1,samplerate=44100)
samples=wavdatalen
;Function Writewav(nosamples,filename$)
;wavdatalen=(ss_channelcount*nosamples*(bitspersample/8))/4
bitspersample=ss_bpsample
fs=WriteFile(filename$)
If fs=0 Then Return 0
WriteBinString fs,"RIFF"
wavlen=36+((wavdatalen*2)*ss_channelcount)
WriteInt fs,wavlen
Writebinstring fs,"WAVE"
Writebinstring fs,"fmt "
WriteInt fs,16
WriteShort fs,1
WriteShort fs,ss_channelcount
WriteInt fs,samplerate
bitspersample=16
byterate=SampleRate * ss_channelcount * bitspersample/8
WriteInt fs,byterate
WriteShort fs,ss_channelcount * bitspersample/8
WriteShort fs,bitspersample
Writebinstring fs,"data"
WriteInt fs,samples*ss_channelcount * BitsPerSample/8
;WriteInt fs,wavdatalen*4
For p=1 To wavdatalen
If ss_bpsample=8 Then Midr=128
If ss_bpsample=16 Then Midr=Midbit/2.0
If ss_bpsample=32 Then Midr=(Midbit*255)/2.0
For chan=0 To ss_channelcount-1
rval=wavdata(chan,p)
rval=rval-Midr
If rval<0 Then rval=rval+(Midr*2)
If rval<0 Then rval=0 Else If rval>(Midr*2)*2 Then rval=(Midr*2)
;If ss_bpsample>16 Then rval=rval/2.0;WriteShort fs,rval
WriteShort fs,wavdata(chan,p);rval
Next
Next
If ss_channelcount=1 Then ster$="Mono" Else ster$="Stereo"
ss_debugprint"Created "+filename$+" as "+ss_bpsample+" bit, "+samplerate+"hz, "+ster$+" wave file."
CloseFile fs
End Function
Function WriteBinString(filehandle,dat$)
For p=1 To Len(dat$)
WriteByte filehandle,Asc(Mid$(dat$,p,1))
Next
End Function
Function ss_debugprint(St$)
Print st$
End Function |
