Pendulum waves

[Ivan, Zagreb]

After I saw the video of the pendulum waves, I have programmed this

Code: Select all

Dim As integer i, j, k, X, Y, B(5)	' B - Boja
Dim As integer S, M, MM, BK	' S - Smjer;  BK - Broj kuglica; 
Dim As Integer Li(100)
Dim As Double Ld(100), T
ScreenInfo X, Y 				' Uzima informaciju o rezoluciji monitora : ' i=8 -> Ekran bez okvira
X -= 64 : Y -= 64 : i = 4 	' i=4 -> Prozor sa okvirom
'Ex = 1280-64 : Ey = 1024-64 
Screenres X, Y, 32, 3, i  	' Postavlja rezoluciju prozora (može biti manja nego od ekrana)
Width X\8, Y\16       		' Postavlja veličinu fonta (8*16 font)
Screenset 1  ' U ekran 1 postavlja osnovno stanje tipkala
BK = 100
S = 1
M = 1
B(0) = &HFFFF00
B(1) = &HFF00FF
B(2) = &H00FFFF
B(3) = &HFF0000
B(4) = &H00FF00
B(5) = &H0000FF
Do     
    If MultiKey(&H4D) Then S =  1
    If MultiKey(&H4B) Then S = -1
    If MultiKey(&H48) Then M += 1
    If MultiKey(&H50) Then M -= 1   
    If M < 0 Then M = 0  
        Cls
        for i = 1 to BK
            Ld(i) = 300 * sin ((i+32) * (T/5000))
            Li(i) = int(Ld(i))
        next i
        T += (M * S)
		For k = 5 To 0 Step -1
			For j = 0 To k
			    For i = j+1 to BK-k-1 Step (k+1)
			        'Line (i * 15 + 10, Li(i) + 400)-((i+k+1) * 15 + 10, Li(i+k+1) + 400), B(k)
			        Line (i * 15, Li(i) + 400)-((i+k+1) * 15, Li(i+k+1) + 400), B(k)
			    Next i  				
			Next j
		Next k
   
        for i = 1 to BK
            'Circle (i * 15 + 10, Li(i) + 400), 6,  &HFFFFFF, , , , F
            'Circle (i * 15 + 10, Li(i) + 400), 3,  &H000000, , , , F    
            Circle (i * 15, Li(i) + 400), 6,  &HFFFFFF, , , , F
            Circle (i * 15, Li(i) + 400), 3,  &H000000, , , , F      
        next i
        Sleep 20   
        Screencopy 1, 0 ' Osnovno stanje kopira u ekran 0
Loop Until MultiKey (&h01) 'Petlja se vrti dok ne pritisneš "ESC"

esc for exit
number 0 to 9 for on and off lines
arrow up faster
arrow down slower
arrow left and right for reversing

[pestery]

Very cool :-)

[BasicScience]

very cool, indeed.

[Ivan, Zagreb]

Here's a link:
http://www.youtube.com/watch?v=yVkdfJ9PkRQ
last version with comment in English:

Code: Select all

Dim As integer i, j, k, X, Y, S, M, B(8), BB(9), MM, BK	' BK - Number of balls; B - Color; BB- Color number
Dim As String Sl
Dim As Integer Ptr Li
Dim As Double Ptr Ld
Dim As Double T
ScreenInfo X, Y 			' Takes information about the monitor resolution 
ScreenRes X, Y, 8, 2, 8  	' Sets the resolution window 
Screenset 1,0  ' draw in page 1, shows page 0
BK = (X \ 15) - 1
Li = Callocate ((BK+1) * Len(Integer))
Ld = Callocate ((BK+1) * Len(Double))
For i = 1 To 9
	BB(i) = 1
	B(i-1) = i	
Next
BB(0) = 1 : B(0) = 14 : B(9) = 13
M = 1 : S = 1
Do     
    Sl = InKey 
    If (Asc(SL) > 47) And (Asc(SL) < 58) Then BB(asc(SL)-48) = (BB(asc(SL)-48) + 1) And 1 ' On or Off colored lines
    If MultiKey(&h48) Then M += 1	' Arrow UP		(faster)
    If MultiKey(&h50) Then M -= 1	' Arrow Down	(slower)
    If MultiKey(&h4B) Then S = -1	' Arrow Left	(back)
    If MultiKey(&h4D) Then S =  1	' Arrow Right	(forward)  
	If M < 0 Then M = 0				' It can not slower than the stationary
        cls
        T += (M*S)        
        for i = 1 to BK
            Ld[i] = (Y\2-16) * sin ((i+16) * (T/10000))
            Li[i] = int(Ld[i])
        next i
		For k = 8 To 0 Step -1
			If BB(k+1) Then
				Draw String (5,k*20+20),Str(k+1),B(k)
				For j = 0 To k
				    For i = j+1 to BK-k-1 Step (k+1)
				        Line (i * 15, Li[i] + Y\2)-((i+k+1) * 15, Li[i+k+1] + Y\2), B(k)
				    Next i  				
				Next j
			End If	
		Next k
   		If BB(0)Then
	        for i = 1 to BK
	            Circle (i * 15, Li[i] + Y\2), 6,  15, , , , F
	            Circle (i * 15, Li[i] + Y\2), 3,  0, , , , F        
	        next i
        End If
        Sleep 20   
        Screencopy 1, 0 	' page 1 copy in spage 0
Loop Until MultiKey (&h01) 	' "ESC" for exit

[h4tt3n]

Very beautiful. I is beginning to worry me, that even the simplest of physics simulations like this one keeps fascinating me like that :-)

[Milivoj]

Some bouncing balls code, with speed statistics on the right.

Sorry about old coding style,
sorry about comments in croatian.

Code: Select all

defint i-n:defdbl a-h,o-z
screenres 900,600
for i=0 to 255:palette i,i,i,i:next i

sx=800:sy=600

n=36:dt=0.01:r=10
dim a(4,n) as double
for i=1 to n
a(1,i)=20*i:a(2,i)=sy-15*i
'a(3,i)=20*rnd-10:a(4,i)=10*rnd-5
next i
a(3,15)=300
pi=3.14159265
dim vd(50) as integer
Dim As Ubyte Ptr buf=imagecreate(2*r,2*r)
for i=-r to r
for j=-r to r
c=sqr(i*i+j*j)
if c<=r-.8 then pset buf,(i+r,j+r),255
if c>r-.8 and c<r then cc=pi*((c-r+.8)/.8-.5): pset buf,(i+r,j+r),int(128-127*sin(cc))
next j:next i

do
for ii=1 to 10
'pomak i odbijanje od ruba, racunanje energije, crtanje
e=0
screenlock:cls
line (804,0)-(900,600),212,BF
line (801,0)-step(0,600),0
line (802,0)-step(0,600),255
line (803,0)-step(0,600),130
for i=1 to 50
line (815,40+10*i)-step(5*vd(i),7),20,BF
vd(i)=0
next i

for i=1 to n
jd=int(.1*sqr(a(3,i)*a(3,i)+a(4,i)*a(4,i)))
if jd<51 then vd(jd)=vd(jd)+1
a(4,i)=a(4,i)+10*dt
a(1,i)=a(1,i)+dt*a(3,i):a(2,i)=a(2,i)+dt*a(4,i)
 if a(1,i)>sx-r then a(1,i)=2*sx-2*r-a(1,i):a(3,i)=-a(3,i)
 if a(2,i)>sy-r then a(2,i)=2*sy-2*r-a(2,i):a(4,i)=-a(4,i) 
 if a(1,i)<r then a(1,i)=2*r-a(1,i):a(3,i)=-a(3,i)
 if a(2,i)<r then a(2,i)=2*r-a(2,i):a(4,i)=-a(4,i)
'circle (a(1,i),a(2,i)),r
put (a(1,i)-r,a(2,i)-r),buf
next i
screenunlock

'sudar
for i=1 to n
for j=i+1 to n
'sudar dviju kuglica (i&j)?
dx=a(1,i)-a(1,j):dy=a(2,i)-a(2,j)
if dx*dx+dy*dy<4*r*r then
 dr=sqr(dx*dx+dy*dy)
 sa=-dy/dr:ca=-dx/dr
 vx=a(3,i)-a(3,j):vy=a(4,i)-a(4,j)
'sustav u kome j miruje
 v=sqr(vx*vx+vy*vy)
 beta=atn(vy/vx)-atn(dy/dx)
 if vx*dx+vy*dy>0 then goto 10 'nema sudara
 if beta<-0.5*pi then beta=beta+pi 
 if beta>0.5*pi then beta=beta-pi 
 u1=v*sin(beta): u2=v*cos(beta)
 a(3,i)=a(3,j)-u1*sa:a(4,i)=a(4,j)+u1*ca
 a(3,j)=a(3,j)+u2*ca:a(4,j)=a(4,j)+u2*sa
endif
10 next j
next i

next ii
sleep 1
loop until inkey$<>""

Ivane, bok. Nisam mislio da još neko u ZG koristi freebasic,
kod mene su svi na c++, fortranu ili nečem još egzotičnijem...

[Lachie Dazdarian]

Otkud sad ovi purgeri? ;)

[duke4e]

Nemam pojma :P

[Lachie Dazdarian]

K'o kineza nas je.

[bojan.dosen]

Malo nas je al nas ima! :)