Nucleation and Growth
This stemmed from an attempt to model the situation when ( say) water vapour condenses ( or freezes) onto a cold window, or a liquid metal cools and solidifies. Each area starts and grows independently.
I had to use tricks to make sure that a growing crystal did not overwrite existing ones, and it is still not perfect. I used direct drawing of points on-a-line, using Bresenham's algorithm, because I had at every point to first look at whether that next pixel was already condensed and growing.
The animation above is of course faster than the actual program runs.
You can also try growing isotropic crystals, which grow as expanding circles; or anisotropically as triangles or squares. I liked the colouring scheme I used, which looks like a micrograph of freezing brass, and makes a nice pattern for tiling.
- 
' **************************************************************************
' *** **
' *** condensingShapess 22 July 2016 tenochtitlanuk **
' *** **
' **************************************************************************
' Rain freezes on glass from nucleation sites starting at random intervals...
nomainwin
global pi, TX, TY, Ttheta, hdc, k, kk
dim drop$( 200)
TX =400: TY =350: Ttheta =0 ' screen centre, pointing North/up.
pi =4 *atn( 1)
move =1
'shape$ ="6," +str$( (0.75^0.5) /2) +", 150, 1,120, 1,120, 1,120" ' equilateral triangle, reached from its centre.
'shape$ ="5, 1, 135, 1, 90, 1, 90, 1, 90, 1, 90" ' squares.
shape$ ="6, 1, 120, 1, 60, 1, 60, 1, 60, 1, 60, 1, 60, 1, 60" ' hexagon.
m =1 ' 4 moves- halfstep, turn 150, down, then 3 times fullstep, turn 120
WindowWidth =1000: WindowHeight =740
'texteditor #w.te1, 10, 620, 804, 50 ' for debugging to see values..
graphicbox #w.gb1, 10, 10, 804, 604
graphicbox #w.gb2, 840, 10, 100, 100
menu #w, "File", "Save", [saveI]
button #w.b1, "Save", saveImage, LR, 50, 50
open "Growing frosty windows." for window as #w
#w "trapclose quit"
h = hwnd( #w.gb1)
calldll #user32, "GetDC", h as ulong, hdc as ulong
#w.gb1 "down ; fill 1 0 0 ; flush"
#w.gb1 "size 1"
#w.gb2 "font DejaVu_Serif 8 bold"
#w.gb2 "down ; fill red ; color black ; backcolor red ; flush"
timer 1000, [p2]
wait
[p2]
timer 0
' **************************************************************************
[makeDrops]
R =int( 150 +100 *cosRad( k *50))
G =int( 100 +250 *rnd( 1))
B =255 -R
x =int( 800 *rnd( 1))
y =int( 600 *rnd( 1))
ra =2
drop$( 1) =str$( x) +"," +str$( y) +"," +right$( "000" +str$( ra), 3) +"," +str$( R +G *2^8 +B *2^16) +"," +str$( int( 181 *rnd( 1)))
timer 1000, [p[
wait
[p]
timer 0
[mainLoop]
for kk =0 to 4000 ' repeat update of screen 2000 times...
for c =1 to m ' ...for each of up to 100 growing zones.
lC =val( word$( drop$( c), 4, ",")) ' x, y, ra, lColor, angle
angle =val( word$( drop$( c), 5, ","))
#w.gb1 "color "; MakeRGB$( lC)
x =val( word$( drop$( c), 1, ","))
y =val( word$( drop$( c), 2, ","))
radius =val( word$( drop$( c), 3, ","))
if radius =0 then [skip]
call display shape$, radius /2, x, y, angle
r1 =instr( drop$( c), ",", 1)
rStart =instr( drop$( c), ",", r1 +1)
rFinis =instr( drop$( c), ",", rStart +1)
drop$( c) =left$( drop$( c), rStart) +right$( "000" +str$( radius +1), 3) +mid$( drop$( c), rFinis)
[skip]
scan
next c
#w.gb1 "getbmp sc 0 0 804 604" ' so redraws don't overflow!
#w.gb1 "cls"
#w.gb1 "drawbmp sc 0 0"
if rnd( 1) <0.20 then ' try to nucleate a new site 20 times in every 100 on average
m =m +1
R =int( 150 +100 *cosRad( k *50))
G =int( 100 +250 *rnd( 1))
B =255 -R
[again] x =int( 800 *rnd( 1))
y =int( 600 *rnd( 1))
if getPixel( x, y) <>1 then [again]
ra =2
drop$( m) =str$( x) +"," +str$( y) +"," +right$( "000" +str$( ra), 3) +"," +str$( R +G *2^8 +B *2^16) +"," +str$( int( 181 *rnd( 1)))
end if
#w.gb2 "cls ; fill red ; color black ; up ; goto 20 30 ; down"
#w.gb2 "\ " +right$( "00000" +str$( kk), 5) +" ";
#w.gb2 "up ; goto 20 60 ; down"
#w.gb2 "\ " +right$( " " +str$( m -1), 5) +" ";
if kk mod 20 =0 then
#w.gb1 "getbmp sc 0 0 804 604"
bmpsave "sc", "shape" +right$( "0000" +str$( kk), 4) +".bmp"
end if
next kk
#w.gb1 "flush"
' ******************************************************************************************
wait
' ____________________________________________________________
function MakeRGB( red, green, blue)
if red < 0 then red = 0
if red >255 then red =255
if green < 0 then green = 0
if green >255 then green =255
if blue < 0 then blue = 0
if blue >255 then blue =255
MakeRGB =( blue *256 *256) +( green *256) +red
end function
function MakeRGB$( cc)
blu =int( cc /256 /256)
grn =int( ( cc -blu *256 *256) / 256)
red =int( cc -blu *256 *256 -grn *256)
MakeRGB$ =str$( red) +" " +str$( grn) +" " +str$( blu)
end function
function longCol( c$)
r =val( word$( c$, 1, " "))
g =val( word$( c$, 2, " "))
b =val( word$( c$, 3, " "))
longCol =r +g *2^8 +b *2^16
end function
function sinRad( a)
sinRad =sin( a *pi /180)
end function
function cosRad( a)
cosRad =cos( a *pi /180)
end function
sub draw lifted, x, y
if lifted =0 then #w.gb1 "up" else #w.gb1 "down"
#w.gb1 "line "; TX; " "; TY; " "; x; " "; y
Ttheta =atan2( x -TX, TY -y) *180 /pi ' NB DEGREES.
TX =x: TY =y
end sub
sub turn angle ' increment/update global turtle direction ( in DEGREES)
Ttheta =( Ttheta +angle) mod 360
end sub
sub forward state, s
dx =s *cosRad( Ttheta)
dy =s *sinRad( Ttheta)
if state =0 then #w.gb1 "up" else #w.gb1 "down"
#w.gb1 "line "; TX; " "; TY; " "; TX +dx; " "; TY +dy; " ; up"
TX =TX +dx
TY =TY +dy
end sub
function atan2( x, y)
Result$ = "Undetermined"
If ( x = 0) and ( y > 0) Then atan2 = pi / 2: Result$ = "Determined"
If ( x = 0) and ( y < 0) Then atan2 = 3 * pi / 2: Result$ = "Determined"
If ( x > 0) and ( y = 0) Then atan2 = 0: Result$ = "Determined"
If ( x < 0) and ( y = 0) Then atan2 = pi: Result$ = "Determined"
If Result$ = "Determined" Then [End.of.function]
BaseAngle = Atn( abs( y) /abs( x))
If (x > 0) and (y > 0) Then atan2 = BaseAngle
If (x < 0) and (y > 0) Then atan2 = pi -BaseAngle
If (x < 0) and (y < 0) Then atan2 = pi +BaseAngle
If (x > 0) and (y < 0) Then atan2 = 2*pi -BaseAngle
[End.of.function]
end function
sub graticule
for x =0 to 800 step 100 ' draw vertical graticule lines
#w.gb1 "line "; x; " "; 0; " "; x; " "; 700
next x
for y =0 to 700 step 100
#w.gb1 "line "; 0; " "; y; " "; 800; " "; y
next y
end sub
[save]
#w.gb1 "getbmp scr 0 0 800 700"
filedialog "Save as ", "*.bmp", fn$
bmpsave "scr", fn$
wait
sub quit h$
end
calldll #user32, "ReleaseDC", hw as ulong, hdc as ulong 'release the DC
close #h$
end
end sub
sub display shape$, scale, x, y, angle
noOfTerms =val( word$( shape$, 1, ","))
vStep =val( word$( shape$, 2, ",")) *scale
Tx =x +vStep *sinRad( angle)
Ty =y -vStep *cosRad( angle)
#w.gb1 "up ; goto "; Tx; " "; Ty; " ; down"
Ttheta =angle
for i =2 to noOfTerms +1
vAngle =val( word$( shape$, 2 *i -1, ","))
vStep =val( word$( shape$, 2 *i , ",")) *scale
Ttheta =Ttheta +vAngle
TxN =Tx +vStep *sinRad( Ttheta)
TyN =Ty -vStep *cosRad( Ttheta)
call bresenham int( Tx), int( Ty), int( TxN), int( TyN) ' replaces 'line Tx Ty TxN TyN')
Tx =TxN
Ty =TyN
next i
end sub
sub delay t
timer t, [cont]
wait
[cont]
timer 0
end sub
function getPixel( x, y)
x =int( x)
y =int( y)
calldll #gdi32, "GetPixel", hdc as ulong, x as long, y as long, getPixel as ulong
'getPixel =pixcol
end function
function getPixel$( x, y)
calldll #gdi32, "GetPixel", hdc as ulong, x as long, y as long, pixcol as ulong
blu =int( pixcol /256 /256)
grn =int( (pixcol -blu *256 *256) / 256)
red =int( pixcol -blu *256 *256 -grn *256)
getPixel$ =str$( red) +" " +str$( grn) +" " +str$( blu)
end function
sub saveImage h$
#w.gb1 "getbmp scr 0 0 804 604"
bmpsave "scr", "freezeShape" +right$( "0000" +str$( k), 4) +".bmp"
end sub
[saveI]
#w.gb1 "getbmp scr 0 0 804 604"
bmpsave "scr", "freezeShape" +right$( "0000" +str$( k), 4) +".bmp"
wait
sub bresenham x1, y1, x2, y2 ' Inputs are integers x1, y1, x2, y2: destroys value of x1, y1
dx = abs( x2 - x1): sx = -1: if x1 < x2 then sx = 1
dy = abs( y2 - y1): sy = -1: if y1 < y2 then sy = 1
er = 0 -dy: if dx > dy then er = dx
er = int( er / 2)
[more] g = getPixel( x1, y1) ' can only write on longcolor 1
if g = 1 then #w.gb1 "set "; x1; " "; y1
scan
if ( ( x1 = x2) and ( y1 = y2)) then exit sub
e2 = er
if ( e2 > 0 -dx) then er = ( er - dy): x1 = ( x1 + sx)
if ( e2 < dy) then er = ( er + dx): y1 = ( y1 + sy)
goto [more]
end sub
sub ellipse x, y, Major, Minor, inclination, bg
xx =Minor *cosRad( 0)
yy =Major *sinRad( 0)
xs =x +xx *cosRad( inclination) -yy *sinRad( inclination)
ys =y +xx *sinRad( inclination) +yy *cosRad( inclination)
#w.gb1 "goto "; xs; " "; ys
#w.gb1 "down"
dAngle =1 /( Major +Minor)' bodge to speed up small circles and not leave gaps at large radii.
for angle =0 to 360 step 1 ' make this bigger at small radius and smaller at large radii
' at present dAngle =0.1 is very slow but =1 leaves gaps.... which then can be filled with wrong colour!
xx =Minor *cosRad( angle)
yy =Major *sinRad( angle)
xs =x +xx *cosRad( inclination) -yy *sinRad( inclination)
ys =y +xx *sinRad( inclination) +yy *cosRad( inclination)
'print getPixel( int( xs), int( ys)), getPixel$( int( xs), int( ys))
g = getPixel( int( xs), int( ys)) ' can only write on longcolor 1 or own colour...
if ( g =1) or ( g =bg) then #w.gb1 "set "; int( xs); " "; int( ys)
next angle
#w.gb1 "up"
end sub