Code archives/Graphics/Water 2D
This code has been declared by its author to be Public Domain code.
Download source code
 This is a fun program where you play with water. You click to make walls. Make it rain and watch the water hit the walls and collect in puddles. BLITZMAX version with alpha effects: '''''''''''''''''''''''''''''''''''''''' 'WATER 2D 'Coded by curtastic. ' 'CONTROLS: 'Leftclick To make walls. 'Rightclick To erase walls 'Spacebar Or middleclick To make water. 'Enter To make it rain. 'F10 To save screenshot. ' 'best run with debug off '''''''''''''''''''''''''''''''''''''''' Strict 'If pressure<>0 Then water levels are accurate. it runs slower 'the higher the number, the faster and less accurate pressure is Const PRESSURE=2 'shows error messages and stuff Const DEBUG=False Const scx=320,scy=240 'Const scx=640,scy=480 'works Graphics scx,scy,16 'how many are currently moving. debug only. Global movers 'map=0 = empty 'map=1 = wall 'map=2 = water dot Global map[scx,scy] 'holds links To dots Global dotmap:tdot[scx,scy] 'everything is drawn To this image. Global image:timage=CreateImage(scx,scy) Global pixmap:TPixmap=LockImage(image) 'the transparent color Global backcolor backcolor=$FF000000 'make map know border walls Local fx,fy For fx=0 To scx-1 map[fx,0]=1 WritePixel pixmap,fx,0,$FFffFFff map[fx,scy-1]=1 WritePixel pixmap,fx,scy-1,$FFffFFff Next For fy=0 To scy-1 map[0,fy]=1 WritePixel pixmap,0,fy,$FFffFFff map[scx-1,fy]=1 WritePixel pixmap,scx-1,fy,$FFffFFff Next UnlockImage image Type TDot Field x,y,moved,speedx,blue Global List:TList=CreateList() EndType 'how something's position changes based on direction. '1=Right '2=down '3=Left '4=up Global movex[4],movey[4] movex[0]=1 movex[2]=-1 movey[1]=1 movey[3]=-1 'what FPS it will run at (If computer can keep up) Local timer:ttimer=CreateTimer(250) Local d2:tdot 'main loop Repeat pixmap=LockImage(image) controls() dotsupdate() UnlockImage image drawfront() WaitTimer timer If KeyHit(key_escape) Then End Forever End 'To frontbuffer: draw the image and everything above it Function DrawFront() SetColor 255,255,255 SetBlend alphablend SetAlpha .2 DrawImage image,0,0 SetAlpha 1 SetBlend solidblend SetColor 255,0,0 If DEBUG Then DrawText movers,1,1 'DrawRect MouseX(),MouseY(),3,3 Flip False EndFunction Function DotsUpdate() Local d:tdot Local d2:tdot Local mapdown,mmm,mmm1 If DEBUG Then movers=0 For d=EachIn tdot.list If d.moved=0 Then 'swap colors of nonmoving dots to make still pools sparkle. If Rnd(0,100)<1 Then Local fx,fy Local d2:tdot fx=Rand(-1,1) fy=Rand(-1,1) If Not(fx=0 And fy=0) Then d2=dotmap[d.x+fx, d.y+fy] If d2<>Null Then Local blue blue=d.blue d.blue=d2.blue d2.blue=blue WritePixel pixmap,d.x,d.y,d.blue WritePixel pixmap,d2.x,d2.y,d2.blue EndIf EndIf EndIf Else If DEBUG Then movers=movers+1 If d.y>=scy-3 Then 'fell To the bottom of the screen 'erase and delete WritePixel pixmap, d.x, d.y, backcolor ListRemove tdot.list,d map[d.x,d.y]=0 'dotmap[d.x,d.y]=Null 'tell neighbors that this pixel position is now open Local fx,fy For fy=-1 To 0 For fx=-1 To +1 d2=dotmap[d.x+fx,d.y+fy] If d2<>Null Then d2.moved=1 EndIf Next Next Else mapdown=map[d.x,d.y+1] If mapdown=0 Then 'nothing under it 'move down If d.speedx<>0 Then 'move diagonal down. If map[d.x+Sgn(d.speedx),d.y+1]=0 Then dotmove(d,Sgn(d.speedx),1) EndIf d.speedx=0 Else 'move straight down dotmovey1(d) EndIf ElseIf mapdown=1 Then 'wall under it. stop d.moved=0 d.speedx=0 Else 'mapdown=2 'water under it. (the drop landed in a pool) Local dir,go,addx,dirmin,dirmax 'check both right and left for a place to go dirmin=-1 dirmax=+1 For go=1 To scx+1 For dir=dirmin To dirmax Step 2 addx=go*dir mmm1=map[d.x+addx,d.y+1] If mmm1=0 Then 'teleport to this spot that has nothing under it dotmove(d,addx,1) If Rand(0,1) Then d.speedx=dir go=999999 Exit EndIf mmm=map[d.x+addx,d.y] If mmm=0 Then If mmm1=2 Then 'move horizontally onto water that is falling d2=dotmap[d.x+addx,d.y+1] If DEBUG If d2=Null Then RuntimeError "map=2 but dotmap=null" If d2.moved=1 Then dotmove(d,addx,0) If Rand(0,1) Then d.speedx=dir go=999999 Exit EndIf Else 'mmm1 must equal 1 'move horizontally onto a wall that is at the same y as the pool. dotmove(d,addx,0) If Rand(0,1) Then d.speedx=dir go=999999 Exit EndIf ElseIf mmm=1 Then 'the horizontal-checker hit a wall 'one direction was already bad If dirmin=dirmax Then 'now both dirs were bad. nowhere to teleport horizontally to. d.moved=0 d.speedx=0 'check for a lower spot in the pool. If PRESSURE Then If Rand(1,PRESSURE)=1 Then dotcheckpressure(d) EndIf EndIf go=999999 Exit EndIf 'don't check this direction anymore If dir=-1 Then dirmin=dirmax Else dirmax=dirmin EndIf EndIf Next Next If DEBUG If go<999999 Then error "unreachable code reached" EndIf EndIf EndIf Next EndFunction 'move dot. x and y are offsets Function DotMove(d:tdot,x,y) Local d2:tdot Local fx,fy dotmap[d.x,d.y]=Null map[d.x,d.y]=0 For fy=-1 To +1 For fx=-1 To +1 d2=dotmap[d.x+fx,d.y+fy] If d2<>Null Then d2.moved=1 Next Next WritePixel pixmap, d.x, d.y, backcolor d.x:+x d.y:+y dotmap[d.x,d.y]=d WritePixel pixmap, d.x, d.y, d.blue map[d.x,d.y]=2 d2=dotmap[d.x-1,d.y-1] If d2<>Null Then d2.moved=1 d2=dotmap[d.x,d.y-1] If d2<>Null Then d2.moved=1 d2=dotmap[d.x+1,d.y-1] If d2<>Null Then d2.moved=1 EndFunction 'move dot down one pixel Function DotMoveY1(d:tdot) Local d2:tdot 'erase dot map[d.x,d.y]=0 dotmap[d.x,d.y]=Null WritePixel pixmap, d.x, d.y, backcolor 'tell neighbors that something has moved d2=dotmap[d.x-1,d.y-1] If d2<>Null Then d2.moved=1 d2=dotmap[d.x,d.y-1] If d2<>Null Then d2.moved=1 d2=dotmap[d.x+1,d.y-1] If d2<>Null Then d2.moved=1 d2=dotmap[d.x-1,d.y] If d2<>Null Then d2.moved=1 d2=dotmap[d.x+1,d.y] If d2<>Null Then d2.moved=1 'move down d.y:+1 'place dot map[d.x,d.y]=2 dotmap[d.x,d.y]=d WritePixel pixmap, d.x, d.y, d.blue EndFunction 'this function is only called if PRESSURE<>0 'travels the border of the pool to find a lower spot where d:tdot can be repositioned. Function DotCheckPressure(d:tdot) Local TheY Local x,y Local newx,newy Local startx,starty Local ang,ang2 Local fx Local mapnew they=d.y+1 startx=d.x starty=d.y ang=0 '0=Right, 1=down, 2=Left, 3=up '"& %11" wraps number to be in range of 0 To 3 x=startx y=starty 'scale the outer edge-of-pool by always trying to turn left. so the outer edge will always be on your left. 'for traveling the edge of the the pool, anything that is not a particle is considered a wall. 'standard follow-the-border code. Repeat 'Try to turn left ang2=(ang-1) & %11 newx=x+movex[ang2] newy=y+movey[ang2] mapnew=map[newx,newy] If mapnew=2 Then x=newx y=newy ang=ang2 ElseIf mapnew=0 And y>they Then 'found a spot where the water is lower and has room to move up Exit Else 'Try to go straight newx=x+movex[ang] newy=y+movey[ang] mapnew=map[newx,newy] If mapnew=2 Then x=newx y=newy Else 'Try to turn right ang2=(ang+1) & %11 newx=x+movex[ang2] newy=y+movey[ang2] If map[newx,newy]=2 Then x=newx y=newy ang=ang2 Else 'turn around ang=(ang+2) & %11 EndIf EndIf EndIf 'show pool borders If DEBUG If KeyDown(key_2) Then WritePixel pixmap,x,y,$ffFF0000+Rand(255) 'just went in a big circle around the pool, without finding criteria. If x=startx And y=starty Then Return 0 Forever 'move to new xy dotmove(d, newx-d.x, newy-d.y) Return 1 EndFunction Function Controls() Local d2:tdot 'enter To rain If KeyDown(key_return) Then Local f For f=1 To 10 Local d:tdot d=New tdot d.x=Rnd(scx-3)+1 d.y=1 If map[d.x,d.y]=0 Then ListAddLast tdot.list,d d.blue=$FF000000+Rand(150,255) d.moved=1 dotmap[d.x,d.y]=d map[d.x,d.y]=2 WritePixel pixmap, d.x, d.y, d.blue dotmove(d,0,0) EndIf Next EndIf 'space To make water at mouse If KeyDown(key_space) Or MouseDown(3) Or KeyHit(key_1) Then Local d:tdot Local f For f=0 To 1 d=New tdot d.x=MouseX()+f d.y=MouseY() If d.x<1 Then d.x=1 If d.y<1 Then d.y=1 If d.x>scx-2 Then d.x=scx-2 If d.y>scy-2 Then d.y=scy-2 If map[d.x,d.y]=0 Then ListAddLast tdot.list,d d.blue=$FF000000+Rand(150,255) d.moved=1 dotmap[d.x,d.y]=d map[d.x,d.y]=2 WritePixel pixmap, d.x, d.y, d.blue dotmove(d,0,0) EndIf Next EndIf 'make walls If MouseDown(1) Then Local mx,my Local fx,fy mx=MouseX() my=MouseY() For fy=0 To 5 For fx=0 To 5 If inscreen(mx+fx,my+fy,1) Then If map[mx+fx,my+fy]=0 Then map[mx+fx,my+fy]=1 WritePixel pixmap, mx+fx,my+fy, .. $FF000000+Rand(77+(5-fy)*20,154+(5-fy)*20) Shl 8 EndIf EndIf Next Next EndIf 'erase walls If MouseDown(2) Then Local mx,my Local fx,fy Local fx2,fy2 mx=MouseX() my=MouseY() For fy=0 To 5 For fx=0 To 5 If inscreen(mx+fx,my+fy,1) Then If map[mx+fx,my+fy]=1 Then WritePixel pixmap,mx+fx,my+fy,backcolor map[mx+fx,my+fy]=0 For fy2=-1 To +1 For fx2=-1 To +1 d2=dotmap[mx+fx+fx2,my+fy+fy2] If d2<>Null Then d2.moved=1 EndIf Next Next EndIf EndIf Next Next EndIf 'f10 To save screenshot If KeyHit(key_f10) Then Local i i=1 Repeat If FileType("water2d "+i+".bmp")=0 Then 'SaveImage image,"water2d "+i+".bmp" Exit EndIf i=i+1 Forever EndIf EndFunction Function InScreen(x,y,closer=0) Return x>=closer And y>=closer And x<scx-closer And y<scy-closer EndFunction Function WritePixel2(x,y,c) If inscreen(x,y,1)=0 Then error x+" "+y EndIf WritePixel pixmap,x,y,c EndFunction Function Error(s$) RuntimeError "Error: "+s EndFunction Blitz3D version: |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;WATER 2D. Written by Curtastic. ;CONTROLS: ;Leftclick to make walls. ;Rightclick to erase walls. ;Spacebar or middleclick to make water. ;Enter to make it rain. ;Best run with debug off. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;if pressure<>0 then water levels are accurate. it runs slower ;the higher the number, the faster and less accurate pressure is ;if pressure is positive then a gap must be at least 2 pixels wide for pressure to work Const PRESSURE=1 ;makes water that falls be sprayish, instead of smooth-slimy. runs a little slower Const FRAY=1 ;shows error messages and stuff Const DEBUG=0 Const scx=320,scy=240 Graphics scx,scy,0,1 ;those rude people who break your stuff. ;actually its to debug, its the amount of particles that are moving. Global movers ;map=0 =empty ;map=1 =wall ;map=2 =particle Dim map(scx,scy) Dim dotmap.dot(scx,scy) Global image=CreateImage(scx,scy) ;get the transparent color Global backcolor SetBuffer ImageBuffer(image) backcolor=ReadPixel(1,1) ;make border walls Rect 0,0,scx,scy,0 ;make map know border walls For fx=0 To scx-1 map(fx,0)=1 map(fx,scy-1)=1 Next For fy=0 To scy-1 map(0,fy)=1 map(scx-1,fy)=1 Next Type dot Field x,y,moved,presx,blue End Type Dim movex(4),movey(4) movex(0)=1 movex(2)=-1 movey(1)=1 movey(3)=-1 timer=CreateTimer(250) Local d2.dot Repeat SetBuffer ImageBuffer(image) controls() dotsupdate() SetBuffer FrontBuffer() drawfront() ;Flip False ;Uncomment if using BlitzPlus WaitTimer timer If KeyHit(1) Then End Forever Function DrawFront() DrawBlock image,0,0 Color 255,0,0 If DEBUG Then Text 1,1,movers Rect MouseX(),MouseY(),3,3 End Function Function DotsUpdate() Local d2.dot If DEBUG=0 Then LockBuffer If DEBUG Then movers=0 For d.dot=Each dot If d\moved=1 Then If DEBUG Then movers=movers+1 If d\y>=scy-3 Then ;fell to the bottom of the screen map(d\x,d\y)=0 dotmap(d\x,d\y)=Null For fy=-1 To 0 For fx=-1 To +1 d2=dotmap(d\x+fx,d\y+fy) If d2<>Null Then d2\moved=1 EndIf Next Next WritePixelFast d\x,d\y,0 Delete d Else If map(d\x,d\y+1)=0 Then ;nothing under it ;move down If FRAY Then ;push other fallers aside to widen the downward stream For dir=-1 To +1 Step 2 d2=dotmap(d\x+dir,d\y+1) If d2<>Null Then d2\presx=d2\presx+dir Next If d\presx=0 Then dotmove(d,0,1) ElseIf map(d\x+Sgn(d\presx),d\y+1)=0 Then ;move to the side also dotmove(d,Sgn(d\presx),1) d\presx=0 Else dotmove(d,0,1) d\presx=0 EndIf Else dotmove(d,0,1) EndIf Else ;something under it nodir=0 For go=1 To scx+1 For dir=-1 To +1 Step 2 If nodir<>dir Then If map(d\x+go*dir,d\y)=1 Then If nodir<>0 Then ;both dirs were nonos. nowhere to teleport to d\moved=0 If PRESSURE Then If map(d\x,d\y+1)=2 Then If Rand(1,PRESSURE)=1 Then dotcheckpressure(d) EndIf EndIf EndIf Goto dotdone EndIf nodir=dir EndIf If map(d\x+go*dir,d\y+1)=0 Then dotmove(d,go*dir,1) Goto dotdone ElseIf map(d\x+go*dir,d\y)=0 Then d2=dotmap(d\x+go*dir,d\y+1) If d2<>Null Then If d2\moved=1 Then dotmove(d,go*dir,0) Goto dotdone EndIf EndIf EndIf EndIf Next Next If DEBUG Then error "unreachable code reached" EndIf EndIf EndIf .dotdone Next If DEBUG=0 Then UnlockBuffer End Function Function DotMove(d.dot,x,y) Local d2.dot dotmap(d\x,d\y)=Null map(d\x,d\y)=0 If x=0 And y=1 Then ;common speedup For fx=-1 To +1 d2=dotmap(d\x+fx,d\y-1) If d2<>Null Then d2\moved=1 Next Else For fy=-1 To +1 For fx=-1 To +1 d2=dotmap(d\x+fx,d\y+fy) If d2<>Null Then d2\moved=1 Next Next EndIf WritePixelFast d\x,d\y,backcolor d\x=d\x+x d\y=d\y+y dotmap(d\x,d\y)=d WritePixelFast d\x,d\y,d\blue map(d\x,d\y)=2 d2=dotmap(d\x-1,d\y-1) If d2<>Null Then d2\moved=1 d2=dotmap(d\x,d\y-1) If d2<>Null Then d2\moved=1 d2=dotmap(d\x+1,d\y-1) If d2<>Null Then d2\moved=1 d2=dotmap(d\x-1,d\y) If d2<>Null Then d2\moved=1 d2=dotmap(d\x+1,d\y) If d2<>Null Then d2\moved=1 End Function ;this function is only called if PRESSURE<>0 ;travels the border of the pool to find a spot that can move up, and is farther down than d.dot Function DotCheckPressure(d.dot) they=d\y+1 startx=d\x starty=d\y ang=0 ;0=right, 1=down, 2=left, 3=up ;"And %11" wraps number to be in range of 0 to 3 x=startx y=starty ;scale the outer wall by always trying to move left. so the outer wall will always be on your left ;for traveling the edge of the the pool, anything that is not a particle is considered a wall Repeat ;try to turn left ang2=(ang-1) And %11 newx=x+movex(ang2) newy=y+movey(ang2) If map(newx,newy)=2 Then x=newx y=newy ang=ang2 Else ;try to go straight newx=x+movex(ang) newy=y+movey(ang) If map(newx,newy)=2 Then x=newx y=newy Else ;try to turn right ang2=(ang+1) And %11 newx=x+movex(ang2) newy=y+movey(ang2) If map(newx,newy)=2 Then x=newx y=newy ang=ang2 Else ;turn around ang=(ang+2) And %11 EndIf EndIf EndIf ;find a spot where the water is lower and can move up If y>they Then If ang<>1 Then ;speedup, cant happen when going down ;found what we are looking for If map(x,y-1)=0 Then dotmove(d, x-d\x, y-1-d\y) Return 1 EndIf ;check sides If PRESSURE<0 Then For fx=-1 To +1 Step 2 If map(x+fx,y)=0 Then dotmove(d, x+fx-d\x, y-d\y) Return 1 EndIf Next EndIf EndIf EndIf If DEBUG Then If KeyDown(2) Then WritePixel x,y,$FF0000+Rnd(255) ;just went in a big circle around the pool If x=startx And y=starty Then Return 0 Forever End Function Function Controls() Local d2.dot ;Enter to make rain. If KeyDown(28) Then For f=1 To 10 d.dot=New dot d\x=Rnd(scx-3)+1 d\y=1 If map(d\x,d\y)>0 Then Delete d Else d\blue=Rnd(100,255) d\moved=1 dotmap(d\x,d\y)=d map(d\x,d\y)=2 WritePixel d\x,d\y,d\blue dotmove(d,0,0) EndIf Next EndIf ;Make water from the mouse. If KeyDown(57) Or MouseDown(3) Then d.dot=New dot d\x=MouseX() d\y=MouseY() If d\x<1 Then d\x=1 If d\y<1 Then d\y=1 If d\x>scx-2 Then d\x=scx-2 If d\y>scy-2 Then d\y=scy-2 If map(d\x,d\y)>0 Then Delete d Else d\blue=Rnd(100,255) d\moved=1 dotmap(d\x,d\y)=d map(d\x,d\y)=2 WritePixel d\x,d\y,d\blue dotmove(d,0,0) EndIf EndIf ;Draw terrain. If MouseDown(1) Then mx=MouseX() my=MouseY() For fy=0 To 5 For fx=0 To 5 If inscreen(mx+fx,my+fy,1) Then If map(mx+fx,my+fy)=0 Then map(mx+fx,my+fy)=1 WritePixel mx+fx,my+fy,Rnd(55+fy*20,155+fy*20) Shl 8 EndIf EndIf Next Next EndIf ;Erase terrain. If MouseDown(2) Then mx=MouseX() my=MouseY() For fy=0 To 5 For fx=0 To 5 If inscreen(mx+fx,my+fy,1) Then If map(mx+fx,my+fy)=1 Then WritePixel mx+fx,my+fy,backcolor map(mx+fx,my+fy)=0 For fy2=-1 To +1 For fx2=-1 To +1 d2=dotmap(mx+fx+fx2,my+fy+fy2) If d2<>Null Then d2\moved=1 EndIf Next Next EndIf EndIf Next Next EndIf End Function ;used for controls only Function InScreen(x,y,closer=0) Return x>=closer And y>=closer And x<scx-closer And y<scy-closer End Function ;this function is changed to be WritePixelFast when DEBUG is on Function WritePixelFast2(x,y,c) If inscreen(x,y,1)=0 Then If DEBUG=0 Then UnlockBuffer error x+" "+y EndIf WritePixel x,y,c End Function Function Error(s$) If DEBUG=0 Then UnlockBuffer RuntimeError "Error: "+s End Function |