## Pendulum waves

Ivan, Zagreb
Posts: 16
Joined: Oct 04, 2011 19:44
Location: Croatia

### Pendulum waves

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
Posts: 493
Joined: Jun 16, 2007 2:00
Location: Australia
Very cool :-)
BasicScience
Posts: 489
Joined: Apr 18, 2008 4:09
Location: Los Angeles, CA
Contact:
very cool, indeed.
Ivan, Zagreb
Posts: 16
Joined: Oct 04, 2011 19:44
Location: Croatia
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
Posts: 693
Joined: Oct 22, 2005 21:12
Location: Denmark
Very beautiful. I is beginning to worry me, that even the simplest of physics simulations like this one keeps fascinating me like that :-)
Milivoj
Posts: 16
Joined: Dec 14, 2006 11:39

### If there's physics involved...

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

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
Posts: 2338
Joined: May 31, 2005 9:59
Location: Croatia
Contact:
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:
Nemam pojma :P
Lachie Dazdarian
Posts: 2338
Joined: May 31, 2005 9:59
Location: Croatia
Contact:
K'o kineza nas je.
bojan.dosen
Posts: 166
Joined: May 14, 2007 12:20
Location: Zagreb, Croatia
Malo nas je al nas ima! :)