Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Diffuse Limited Aggregation (v. 2.0)
| Uploader: |  psygate |
| Datum/Zeit: | 06.07.2006 14:05:25 |
'DLA - Diffuse Limited Aggregation
'Simulation by psygate
'Comments on my source will follow within the next days.
'05. July 2006
'use as you like
'just leave some credits ^_^
'
'If you like the program, or you
'would like to know something about it,
'please contact me: physikprof@gmail.com
'To-Do:
'Comment the source
'Maybe mouse interface
option explicit
randomize timer
option nokeyword draw
type particle
x as double
y as double
dx as double
dy as double
ox as double
oy as double
end type
dim shared as uinteger num,xmax,ymax
print "Use current resolution? (1)"
input num
print
if num=1 then
screeninfo xmax,ymax
else
print "X-Screen-Width?"
input xmax
print
print "Y-Screen-Width?"
input ymax
print
end if
print "Number of particles?"
input num
'xmax=480
'ymax=272
'num=1000
dim as integer pointer ascreen,buffer,clr
dim as integer a,b,p,q,g,t,s,win,ag,tr,deca,f
dim as string key
dim as particle dot(num)
dim shared as integer attract,moving,aggreg,bg
attract=&HF0F0F0
moving=&H00FF00
aggreg=&Hffffff
bg=&H000000
declare sub draw(byref a as integer pointer)
screenres xmax,ymax,32,,1
setmouse xmax-1,ymax-1,0
new:
for a=0 to num
with dot(a)
.x=int(rnd*xmax)
.y=int(rnd*ymax)
.dx=rnd*(-1)^int(rnd*2)
.dy=rnd*(-1)^int(rnd*2)
end with
next
if deca=0 then ascreen=imagecreate(xmax,ymax,bg)
buffer=imagecreate(xmax,ymax,bg)
clr=imagecreate(xmax,ymax,bg)
if deca=0 then
q=int(rnd*5)+1
if q=1 then
circle ascreen,(xmax/2,ymax/2),ymax/2,attract
elseif q=2 then
line ascreen,(xmax/3,ymax/2)-(xmax/3*2,ymax/2),attract
elseif q=3 then
pset ascreen,(xmax/2,ymax/2),attract
elseif q=4 then
line ascreen,(0,ymax-1)-(xmax-1,ymax-1),attract
elseif q=5 then
pset ascreen,(xmax/3,ymax/2),attract
pset ascreen,(xmax/3*2,ymax/2),attract
end if
end if
'bload "C:\PSP.bmp",ascreen
put (0,0),ascreen,pset
while key<>chr(27)
screenlock
put (0,0),ascreen,pset
for a=0 to num
with dot(a)
if f=0 then
.x+=.dx
.y+=.dy
else
.x+=(-1)^int(rnd*2)
.y+=(-1)^int(rnd*2)
end if
if .x>=xmax-1 and .dx>0 then .x=xmax-1:.dx-=1
if .x<=0 and .dx<0 then .x=0:.dx+=1
if .y>=ymax-1 and .dy>0 then .y=ymax-1:.dy-=1
if .y<=0 and .dy<0 then .y=0:.dy+=1
if .x>xmax-1 then .x=xmax-1
if .y>ymax-1 then .y=ymax-1
if .x<0 then .x=0
if .y<0 then .y=0
if point(.x-1,.y,ascreen)=attract or point(.x,.y,ascreen)=attract or _
point(.x+1,.y,ascreen)=attract or point(.x-1,.y-1,ascreen)=attract or _
point(.x,.y-1,ascreen)=attract or point(.x+1,.y-1,ascreen)=attract or _
point(.x-1,.y+1,ascreen)=attract or point(.x,.y+1,ascreen)=attract or _
point(.x+1,.y+1,ascreen)=attract or _ 'Next part for green aggregated particles:
point(.x-1,.y,ascreen)=aggreg or point(.x,.y,ascreen)=aggreg or _
point(.x+1,.y,ascreen)=aggreg or point(.x-1,.y-1,ascreen)=aggreg or _
point(.x,.y-1,ascreen)=aggreg or point(.x+1,.y-1,ascreen)=aggreg or _
point(.x-1,.y+1,ascreen)=aggreg or point(.x,.y+1,ascreen)=aggreg or _
point(.x+1,.y+1,ascreen)=aggreg then
pset ascreen,(.x,.y),aggreg
.x=int(rnd*xmax)
.y=int(rnd*ymax)
.dx=rnd*(-1)^int(rnd*2)
.dy=rnd*(-1)^int(rnd*2)
g+=1
end if
if tr=0 then pset(.x,.y),moving
end with
next
if ag=1 then locate 1,1:print "Aggregated Particles:";g
screenunlock
key=inkey$
if key="d" then deca=1:ascreen=imagecreate(xmax,ymax,bg):draw(ascreen):goto new
if key="n" then goto new
if key="s" then bsave "C:\DLA_"+str(s)+".bmp",0:s+=1
if key="q" then tr=not tr
if key="a" then
if ag=1 then ag=0
if ag=0 then ag=1
end if
if key="f" then f=not f
if key="w" then
if win=0 then
put screenptr,(0,0),buffer,pset
screenres xmax,ymax,32,,
cls
put (0,0),buffer,pset
win=not win
elseif win=-1 then
put screenptr,(0,0),buffer,pset
screenres xmax,ymax,32,,1
put (0,0),buffer,pset
win=not win
end if
end if
if key<>"q" and key<>"f" and key<>chr(27) and key<>"n" and key<>"s" and key<>"a" and _
key<>"w" and key<>"" or key="h" and key<>"d"then
put screenptr,(0,0),buffer,pset
cls
locate 1,1
print "HELP-LINES:"
print "------------"
print
print "Key | Effect"
print "-----------------------------------------------------------"
print " a | Show/Don't show number of aggregated particles"
print " n | Start new aggregation (Change Attraktor by luck)"
print " s | Save a picture (.bmp) of current state of aggregation"
print " w | Change between window or full-window mode"
print " q | Show/Don't show moving particles"
print " f | Switch between slow and fast mode."
print " d | Draw-Mode: Draw your own attraktor."
if xmax<=320 then getkey:cls
print
print
print "Please use lowercase characters! If you don't use them"
print "you'll just get here into the help menu ;-)"
print
print "-----------------------------------------------------------"
print "About (Scientific Background):"
print "------------------------------"
print "This program was written by psygate to simulate the aggregation of "
print "Many attractive images and life-like structures can be generated"
print "using models of physical processes from areas of chemistry and physics."
print "One such example is diffusion limited aggregation or DLA which describes,"
print "among other things, the diffusion and aggregation of zinc ions in an"
print "electrolytic solution onto electrodes. 'Diffusion' because the particles"
print "forming the structure wander around randomly before attaching themselves"
print "('Aggregating') to the structure."
print "Source: http://astronomy.swin.edu.au/~pbourke/fractals/dla/"
print
getkey
cls
put (0,0),buffer,pset
key=""
end if
wend
end
sub draw(byref a as integer pointer)
dim as string key
dim as integer xm,ym,button,xm2,ym2,xb,yb,ox,oy
dim as integer pointer prev
prev=imagecreate(xmax,ymax,bg)
cls
' ascreen=imagecreate(xmax,ymax,bg)
print "Welcome to the Draw Mode!"
print "--------------------------"
print "Now you can draw a attraktor with the mouse."
print "To draw a point just press your left mouse button."
print
print "To draw a LINE just press l and then define two points by clicking."
print "To draw a CIRCLE press c and then click to define a mid-point and"
print "a second time to define the radius."
print "To draw a SQUARE just press q."
print "To clr everything press t"
print
print "To EXIT the Draw Mode just press ESC."
getkey
setmouse 0,0,1
cls
while key<>chr(27)
getmouse xm,ym,,button
put (0,0),a
if button=1 then pset a,(xm,ym),attract
if key="l" then
put (0,0),a
xm=xmax:ym=ymax:xm2=xmax:ym2=ymax
while xm=xmax or ym=ymax
getmouse xb,yb,,button
if button=1 then xm=xb:ym=yb
wend
pset (xm,ym),attract
button=0
sleep 100,1
while xm2=xmax or ym2=ymax
getmouse xb,yb,,button
if button=1 then xm2=xb:ym2=yb
wend
pset (xm2,ym2),attract
line a,(xm,ym)-(xm2,ym2),attract
end if
if key="c" then
put (0,0),a
xm=xmax:ym=ymax:xm2=xmax:ym2=ymax
while xm=xmax or ym=ymax
getmouse xb,yb,,button
if button=1 then xm=xb:ym=yb
wend
pset (xm,ym),attract
button=0
sleep 100,1
while xm2=xmax or ym2=ymax
getmouse xb,yb,,button
if button=1 then xm2=xb:ym2=yb
wend
pset (xm2,ym2),attract
circle a,(xm,ym),sqr((xm-xm2)^2+(ym-ym2)^2),attract
end if
if key="q" then
put (0,0),a
xm=xmax:ym=ymax:xm2=xmax:ym2=ymax
while xm=xmax or ym=ymax
getmouse xb,yb,,button
if button=1 then xm=xb:ym=yb
wend
pset (xm,ym),attract
button=0
sleep 100,1
while xm2=xmax or ym2=ymax
getmouse xb,yb,,button
if button=1 then xm2=xb:ym2=yb
wend
pset (xm2,ym2),attract
line a,(xm,ym)-(xm2,ym2),attract,b
end if
if key="t" then cls:a=imagecreate (xmax,ymax,0)
key=inkey$
wend
end sub