Pendulum waves

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
Ivan, Zagreb
Posts: 16
Joined: Oct 04, 2011 19:44
Location: Croatia

Pendulum waves

Postby Ivan, Zagreb » Oct 04, 2011 20:04

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

Postby pestery » Oct 05, 2011 1:50

Very cool :-)
BasicScience
Posts: 475
Joined: Apr 18, 2008 4:09
Location: Los Angeles, CA
Contact:

Postby BasicScience » Oct 05, 2011 3:34

very cool, indeed.
Ivan, Zagreb
Posts: 16
Joined: Oct 04, 2011 19:44
Location: Croatia

Postby Ivan, Zagreb » Oct 05, 2011 6:38

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
Posts: 686
Joined: Oct 22, 2005 21:12
Location: Denmark

Postby h4tt3n » Oct 05, 2011 8:30

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...

Postby Milivoj » Oct 05, 2011 14:06

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
Posts: 2338
Joined: May 31, 2005 9:59
Location: Croatia
Contact:

Postby Lachie Dazdarian » Oct 05, 2011 18:04

Otkud sad ovi purgeri? ;)
duke4e
Posts: 717
Joined: Dec 04, 2005 0:16
Location: Varazdin, Croatia, Europe
Contact:

Postby duke4e » Oct 06, 2011 7:01

Nemam pojma :P
Lachie Dazdarian
Posts: 2338
Joined: May 31, 2005 9:59
Location: Croatia
Contact:

Postby Lachie Dazdarian » Oct 06, 2011 7:44

K'o kineza nas je.
bojan.dosen
Posts: 166
Joined: May 14, 2007 12:20
Location: Zagreb, Croatia

Postby bojan.dosen » Oct 10, 2011 21:22

Malo nas je al nas ima! :)

Return to “Tips and Tricks”

Who is online

Users browsing this forum: Majestic-12 [Bot] and 1 guest