Pentacles

[jj2007]

the crystals are not really 3000 million years old, they crystallised 440 ± 50 million years ago; on Tuesday

Wrong, Richard, it was on Thursday!

[Richard]

Wrong, Richard, it was on Thursday!

And I thought today was a Tuesday.

[jj2007]

You forgot about leap years, Richard ;-)

[dodicat]

440 million years ago when Richard reckoned my crystals were formed, there were only 20 hours and 48 minutes in a day, so leap years are a modern phenomenon, and thus are history.

Code: Select all

function min(v() as double,byref ok as long=0) as long
      dim as double d=1e12
      dim as long ret
      for n as long=lbound(v) to ubound(v)
            if v(n)>0 andalso d>v(n) then d=v(n):ret=n:if ok=0 then ok=1
            next n
      if ok then return ret 
       end function
            
'dim as double d(...)={-1,0,1,3,4,.5,5}
dim as long flag
Dim As Double d(...) = { -2, 0, -1, -3, -4, -.5, -5}
var m=min(d(),flag)


if flag then
print d(m)
else
  print "no suitable matches found"
end if
sleep
 

[Richard]

Pity about the case of;
Dim As Double d(...) = { -2, 0, -1, -3, -4, -.5, -5 }

[albert]

@Richard

My question is:

If I have several variables , v1 = -1 , v2 = 100 , v3 = 10 , v4 = -5

How do i pick the lowest variable greater than 0??

All i could think was ; to put the values in one array , and the names in another , and bubble sort the two arrays.. But that takes too long...

[Richard]

@albert.
I posted a solution for you. https://freebasic.net/forum/viewtopic.p ... 63#p282263

[albert]

@Richard

Thanks for the code... I got it working...

There were a flurry of posts after your comment , and it went onto another page.. And i didn't see it...

[albert]

@Richard

I got it returning the variable identity as well as the smallest value..

Code: Select all

screen 19

Dim As longint min_pos , vars
Dim As Integer valid

#Macro find_min_pos( v , v1 )
If v >= 0 Then
    If valid Then
        If min_pos > v Then min_pos = v : vars = v1
    Else
        min_pos = v
        vars = v1
        valid = -1
    End If
End If
#Endmacro

do
        
    Dim As longint v1 , v2 , v3 , v4
    
    v1 = int( rnd * 256 )
    v2 = int( rnd * 256 )
    v3 = int( rnd * 256 )
    v4 = int( rnd * 256 )
    
    valid = 0
    find_min_pos( v1 , 1 )
    find_min_pos( v2 , 2 )
    find_min_pos( v3 , 3 )
    find_min_pos( v4 , 4 )
    
    print
    print "var 1 = " ; v1
    print "var 2 = " ; v2
    print "var 3 = " ; v3
    print "var 4 = " ; v4
    print
    
    If valid Then
        print "Smallest var = " ; vars ; " with value " ; min_pos
    Else
        Print "invalid"
    End If
    
    sleep
    
loop until inkey = chr( 27 )

sleep
end

Here it is with negatives...
If you hold a key down and watch it , you'll see , it never goes over 2 digits...So it might be useful for compression???

Code: Select all

screen 19

Dim As longint smallest , vars
Dim As Integer valid

#Macro find_smallest( v , v1 )
If v >= 0 Then
    If valid Then
        If smallest > v Then smallest = v : vars = v1
    Else
        smallest = v
        vars = v1
        valid = -1
    End If
End If
#Endmacro

do
        
    Dim As longint v1 , v2 , v3 , v4
    
    randomize
    
    v1 = int( rnd * 256 )
    v2 = v1 - 200
    v3 = v1 - 100
    v4 = v1 - 10
    
    valid = 0
    find_smallest( v1 , 1 )
    find_smallest( v2 , 2 )
    find_smallest( v3 , 3 )
    find_smallest( v4 , 4 )
    
    print
    print "var 1 = " ; v1
    print "var 2 = " ; v2
    print "var 3 = " ; v3
    print "var 4 = " ; v4
    print
    
    If valid Then
        print "Smallest var = " ; vars ; " with value " ; smallest
    Else
        Print "invalid"
    End If
    
    sleep
    
loop until inkey = chr( 27 )

sleep
end

[albert]

It doesn't compress , it expands 4% on the first loop...
Played around for two whole hours and there's no way to get compression out of it..

[coderJeff]

It doesn't compress , it expands 4% on the first loop...
Played around for two whole hours and there's no way to get compression out of it..

One of the reasons the squares topic got locked was the endless compression posts.
Is this starting again here?

[paul doe]

It doesn't compress , it expands 4% on the first loop...
...

Be it as it may, the only thing you're able to consistently compress are coderJeff's balls...

[dodicat]

Yesterday here in Scotland, we were allowed to move cautiously out of our covid bubbles.
I don't know if other countries use the term "bubbles" or "bubbles" translated into their language, in lockdown restrictions.
But bubbles they are called here.
I know that many other countries are still in strict lockdown.
It was bound to happen sooner or later, Mother Earth fighting back at a threat (us).
There exists a gaia philosophy;
https://en.wikipedia.org/wiki/Gaia_hypothesis
I had a terrifying thought while walking my dog through the woods this morning, this planet wants rid of me, at this moment in time Mother Earth regards me as enemy number one.
I reckon my dog is safe enough, and that is a blessing anyway.

Anyway, bubbles:

Code: Select all

Screen 20,32
Dim Shared As Integer xres,yres,freedom
Screeninfo xres,yres
Color ,Rgb(0,0,100)

Declare Function fbmain() As Long
End fbmain

Type v2
    As Single x,y,radius,dx,dy
    As Ulong clr
    As Single m
End Type

Function drawline(x As Long,y As Long,ang As Single,lngth As Single) As v2
    ang=ang*.0174532925199433
    Var x2=(x)+lngth*Cos(ang)
    Var y2=(y)-lngth*Sin(ang)
    Return Type(x2,y2)
End Function

Function DetectBallCollisions overload(b1 As V2,b2 As V2) As Single
    Dim As Single xdiff = b2.x-b1.x
    Dim As Single ydiff = b2.y-b1.y
    If Abs(xdiff) and Abs(ydiff) > b2.radius*b2.radius Then Return 0
    Var L=Sqr(xdiff*xdiff+ydiff*ydiff)
    If L<=(b2.radius+b1.radius) Then return 1
End Function

Function DetectBallCollisions( b1 As V2,b2 As V2,k As Single) As Single
    If Abs(b1.radius-b2.radius)<>k Then Return 0
    Dim As Single xdiff = b2.x-b1.x
    Dim As Single ydiff = b2.y-b1.y
    If (Sqr(xdiff*xdiff+ydiff*ydiff)) < Abs(b2.radius-b1.radius) Then  Return 0
    Return 1
End Function

Sub Check_BallCollisions(b() As v2,k As Single)
    Static As Single L
    For n1 As Long=Lbound(b) To Ubound(b)-1
        For n2 As Long=n1+1 To Ubound(b)
            If freedom Then L=DetectBallCollisions(b(n1),b(n2)) Else L=DetectBallCollisions(b(n1),b(n2),k)
            If L Then
                Dim As Single  impulsex=(b(n1).x-b(n2).x)
                Dim As Single  impulsey=(b(n1).y-b(n2).y)
                Dim As Single ln=Sqr(impulsex*impulsex+impulsey*impulsey)
                impulsex/=ln'normalize the impulse
                impulsey/=ln
                'set one ball to nearest non overlap position
                If freedom=0 Then
                    b(n1).x=b(n2).x+Abs(b(n2).radius-b(n1).radius)*impulsex
                    b(n1).y=b(n2).y+Abs(b(n2).radius-b(n1).radius)*impulsey
                Else
                    b(n1).x=b(n2).x+(b(n2).radius+b(n1).radius)*impulsex
                    b(n1).y=b(n2).y+(b(n2).radius+b(n1).radius)*impulsey
                End If
                
                Dim As Single  impactx=b(n1).dx-b(n2).dx
                Dim As Single  impacty=b(n1).dy-b(n2).dy
                Dim As Single  dot=impactx*impulsex+impacty*impulsey
                'handle masses
                Dim As Single  mn2=b(n1).m/(b(n1).m+b(n2).m),mn1=b(n2).m/(b(n1).m+b(n2).m)
                b(n1).dx-=dot*impulsex*2*mn1
                b(n1).dy-=dot*impulsey*2*mn1
                b(n2).dx+=dot*impulsex*2*mn2
                b(n2).dy+=dot*impulsey*2*mn2
            End If
        Next n2
    Next n1
    
End Sub

Sub checksides(b() As v2)
    For n As Long=Lbound(b) To Ubound(b)
        If b(n).x<b(n).radius Then b(n).x=b(n).radius:b(n).dx=-b(n).dx
        If b(n).x>xres-b(n).radius Then b(n).x=xres-b(n).radius:b(n).dx=-b(n).dx
        If b(n).y<b(n).radius Then b(n).y=b(n).radius:b(n).dy=-b(n).dy
        If b(n).y>yres-b(n).radius Then b(n).y=yres-b(n).radius:b(n).dy=-b(n).dy
    Next n
End Sub

Sub moveballs(b() As v2)
    For z As Long=1 To Ubound(b)+(freedom=0)
        b(z).x+=b(z).dx
        b(z).y+=b(z).dy
    Next z
End Sub

Sub drawballs(b() As v2)
    For z As Integer=Ubound(b) To 1 Step -1
        Circle(b(z).x,b(z).y),b(z).radius,b(z).clr,,,,f
    Next z
End Sub

Function Regulate(Byval MyFps As Long,Byref fps As Long=0) As Long
    Static As Double timervalue,lastsleeptime,t3,frames
    Var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

Function setup(b() As v2) As Single
    Dim As Single f=Ubound(b)*1.5,k 
    Dim As Ulong colour,n
    For n =1 To Ubound(b)
        If n=1 Then colour=Rgb(55,200,255) Else colour*=Rnd
        b(n)=Type(xres/2,yres/2,f*n,(Rnd-Rnd)*1.5,(Rnd-Rnd)*1.5,colour,(f*n)^1.5)
        If n=Ubound(b) Then b(n).dx=0:b(n).dy=0
        k= f*n
    Next
    k= f*n-k
    Return k
End Function

Function fbmain() As Long
    Dim As v2 b(1 To 10)
    Var k=setup(b())
    Dim As Long fps
    Dim As String key
    
    Do
        key=Inkey
        If key="f" And freedom=0 Then 
            freedom=1
            Dim As Long count
            Dim As v2 ctr=Type(b(Ubound(b)).x,b(Ubound(b)).y)
            For z As Single=0 To 360-1 Step 360/Ubound(b)
                count+=1
                Var p=drawline(ctr.x,ctr.y,z,250)
                b(count).x=p.x
                b(count).y=p.y
                b(count).dx=(p.x-ctr.x)/150
                b(count).dy=(p.y-ctr.y)/150
            Next z
            
        End If
        moveballs(b())
        checksides(b())
        Check_BallCollisions(b(),k)
        Screenlock
        Cls
        drawballs(b())
        Draw String(10,10),"fps = "&fps
        If freedom=0 Then Draw String(10,30),"Press f to leave the bubbles"
        Screenunlock
        Sleep regulate(60,fps)
    Loop Until key=Chr(27)
    Return 0
End Function

 

[Richard]

@dodicat
Have you got a vaccine yet ?

Nice idea for circles inside circles.

...
Like a circle in a spiral, like a wheel within a wheel
Never ending or beginning on an ever spinning reel
As the images unwind, like the circles that you find
In the windmills of your mind!

https://www.songfacts.com/lyrics/noel-h ... -your-mind

[badidea]

Yesterday here in Scotland, we were allowed to move cautiously out of our covid bubbles.
I don't know if other countries use the term "bubbles" or "bubbles" translated into their language, in lockdown restrictions.
But bubbles they are called here.
I know that many other countries are still in strict lockdown.
...

The virus is almost the same everywhere, but the restrictions are different everywhere and they change every few weeks. Here, in the Netherlands, some restrictions are lifted tomorrow, after today's King's day (end of curfew and limiting reopening of terraces). I know that in Belgium they use covid bubbles, here less used term.

I just thought of a graphical simulation of soap bubbles sticking together, merging and popping. But the physics behind soap bubbles is quite complex I discovered, so I leave this challenge for someone more brave and smart.