|
|
Post by bplus on Dec 22, 2023 18:51:00 GMT
Try 50 itmes to see sort before and after comment out that and try 1 Miilion Randomly generated items
DefLng A-Z
' comment one of the following
'Const nItems = 1000000 'for timing 1 Million items
Const nItems = 50 ' fits array before and after on one screen
Dim sa$(0 To nItems) 'setup with string array sa$() to hold random generated strings
For x = 1 To nItems ' make a random list to sort
b$ = ""
r = (Rnd * 5) \ 1 + 2
For i = 0 To r
b$ = b$ + Mid$("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789.?", (Rnd * 64) \ 1 + 1, 1)
Next
sa$(x) = b$
Print b$,
Next
Print
Print "Press any to sort"
Sleep
t## = Timer(.01)
QSort 0, nItems, sa$()
time## = Timer(.01) - t##
'Cls
For i = 0 To nItems
Print sa$(i),
Next
Print
Print "time:"; time##
' modified for QB64 from JB
' This is the best all purpose sort routine around, don't worry how it works, it just does!
' To use this sub rountine store all the string values you want to sort into Arr$() array
' call Qsort with Start = LBound(Arr$) and Finish = UBound(Arr$)
Sub QSort (Start, Finish, Arr$())
Dim i As Long, j As Long, x$
i = Start
j = Finish
x$ = Arr$(Int((i + j) / 2))
While i <= j
While Arr$(i) < x$
i = i + 1
Wend
While Arr$(j) > x$
j = j - 1
Wend
If i <= j Then
Swap Arr$(i), Arr$(j)
i = i + 1
j = j - 1
End If
Wend
If j > Start Then QSort Start, j, Arr$()
If i < Finish Then QSort i, Finish, Arr$()
End Sub
|
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Jan 14, 2024 20:20:24 GMT
I just tried with 1000000 about 0.7s, then I changed line 36 like this:
Sub QSort (Start, Finish, Arr$()) Static
..., and there 0.05s! Strange or normal ? i just add 'Static' !
I then used the routine to sort balls with rotations using Pythagoras...
widthe = 800 '1440 'set width screen
height = 600 '1080 'set height screen
Screen _NewImage(widthe, height, 32)
'_FULLSCREEN
pts = 150 '<---- Number of balls & zmax ...As many balls as Z's
start:
r$ = ""
hui = .78 '<---- The Pythagoras limit...!
bol = .42 + pts / 100000 'distribution cramped .5 to large 1.5
ReDim Array!(pts)
ReDim face!(pts, 2)
'generate balls positions
For i = 1 To pts
face!(i, 0) = i 'z
g = face!(i, 0) * (bol)
h = face!(i, 0) * (bol)
Array!(i) = face!(i, 0)
face!(i, 1) = (Rnd * g) * Sgn((Rnd * Rnd)) 'x
face!(i, 2) = (Rnd * h) * Sgn((Rnd - Rnd)) 'y
Next i
po! = Timer + 1 'the time before show!
tot = 0
kk! = 0
_Display
Do
''Calculation of FPS
'If timtofps < Timer Then
' fps = tot
' tot = 0
' timtofps = Timer + 1
'End If
If kk! < Timer Then
goturn = 0
'Calculation of rotation angles
c = Sgn(Rnd - Rnd) * (240 * Rnd + Rnd * 120 * ((Rnd - Rnd))) 'yz rot
d = Sgn(Rnd - Rnd) * (240 * Rnd + Rnd * 120 * ((Rnd - Rnd))) 'xz rot
e = Sgn(Rnd - Rnd) * (90 * Rnd): e = e + Sgn(e) * (5 + Rnd * 5) 'xy rot
c = c * Rnd + Sgn(c) * 45: d = Sgn(d) * 5 + d * 1.5
If Rnd < .5 Then block = 1 Else block = 0
If Abs(e) > Abs(c) And Abs(e) > Abs(d) Then vite = Rnd Else If Abs(c) + Abs(d) > 360 Then vite = 1 + Rnd * 5
If Abs(c) + Abs(d) + Abs(e) < 50 Then vite = 5 + Rnd * 15
kk! = Timer + .2 + Rnd * .8
End If
tot = tot + 1
'
Cls , _RGBA(3, 5, 17, 255)
QSort LBound(Array!), UBound(Array!), Array!()
For t = pts To 1 Step -1 'rotation using pythagoras
If face!(t, 0) < pts / 467 Then GoTo nopoint
If po! < Timer Then
'xz rot
If block = 1 Then face!(t, 0) = face!(t, 0) - pts / 2
hyp = Sqr(face!(t, 1) * face!(t, 1) + face!(t, 0) * face!(t, 0))
a = -face!(t, 0) / hyp / d
cx = (face!(t, 1) / hyp) + a
If cx < hui And cx > -hui Then
If (cx * cx) < 1 Then sx = Sqr(1 - cx * cx) * Sgn(face!(t, 0))
Else
a = face!(t, 1) / hyp / d
sx = (face!(t, 0) / hyp) + a
If (sx * sx) < 1 Then cx = Sqr(1 - sx * sx) * Sgn(face!(t, 1))
End If
face!(t, 1) = hyp * cx
face!(t, 0) = hyp * sx
If block = 1 Then face!(t, 0) = face!(t, 0) + pts / 2
'yz
If block = 0 Then face!(t, 0) = face!(t, 0) - pts / 2
hyp = Sqr(face!(t, 2) * face!(t, 2) + face!(t, 0) * face!(t, 0))
a = -face!(t, 0) / hyp / c
cx = (face!(t, 2) / hyp) + a
If cx < hui And cx > -hui Then
If (cx * cx) < 1 Then sx = Sqr(1 - cx * cx) * Sgn(face!(t, 0))
Else
a = face!(t, 2) / hyp / c
sx = (face!(t, 0) / hyp) + a
If (sx * sx) < 1 Then cx = Sqr(1 - sx * sx) * Sgn(face!(t, 2))
End If
face!(t, 2) = hyp * cx
face!(t, 0) = hyp * sx
If block = 0 Then face!(t, 0) = face!(t, 0) + pts / 2
'xy
hyp = Sqr(face!(t, 2) * face!(t, 2) + face!(t, 1) * face!(t, 1))
a = -face!(t, 1) / hyp / e
cx = (face!(t, 2) / hyp) + a
If cx < hui And cx > -hui Then
If (cx * cx) < 1 Then sx = Sqr(1 - cx * cx) * Sgn(face!(t, 1))
Else
a = face!(t, 2) / hyp / e
sx = (face!(t, 1) / hyp) + a
If (sx * sx) < 1 Then cx = Sqr(1 - sx * sx) * Sgn(face!(t, 2))
End If
face!(t, 2) = hyp * cx
face!(t, 1) = hyp * sx
If face(t, 0) > 0 Then
ax = (480 * face!(t, 1)) / face!(t, 0)
ay = (480 * face!(t, 2)) / face!(t, 0)
ax = ax + _Width / 2
ay = ay + _Height / 2
If ax < -50 Or ax > _Width + 50 Or ay > _Height + 50 Or ay < -50 Then GoTo nopoint
''___________________________________________ hyde some oldballs the shape of the ball
R = (pts - face!(t, 0)) / (face!(t, 0)) * 6.5 '- ((face!(t, 0) / pts)) * 6 '
For a = 0 To _Pi / 2 Step _Pi / (R * 4)
cl = (a * 35) * ((pts - face!(t, 0)) / pts)
x = Cos(a) * (R * 1.2)
y = Sin(a) * (R * 1.2)
Line (ax + x, ay - y)-(ax - x, ay - y), _RGB(cl * .2, cl * .8, cl)
Line (ax + x, ay + y)-(ax - x, ay + y), _RGB(cl, cl * .2, cl * .4)
Next a
'_____________________________________ draw balls catch on web (can't remember where!)
R = (pts - face!(t, 0)) / (face!(t, 0))
peri = Int(R * 250 - pts / 2000) 'nb point on ball
dlong = _Pi * (5 - (Sqr(5)))
If peri > 0 Then dz = 1 / peri
dong = 0
z = 1 - dz / 2
cl = 256 - (face!(t, 0) / pts * 256)
For k = 1 To peri 'draw spiral
If z = 1 Or z <= -1 Then GoTo zero
R = Sqr(1 - z * z) * 8
x = (Cos(dong) * (R * (pts / 600)) + face!(t, 1))
y = ((sindong) * (R * (pts / 600)) + face!(t, 2))
zz = z + face!(t, 0)
If zz < face!(t, 0) Or zz = 0 Then GoTo zero
z = z - dz
dong = dong + dlong
sindong = Sin(dong)
fx = Int(_Width / 2 + 480 * x / (zz))
fy = Int(_Height / 2 + 480 * y / (zz))
If fx < 0 Or fx > _Width Or fy < 0 Or fy > _Height Then GoTo zero
If zz < face!(t, 0) Then Exit For
PSet (fx, fy), _RGBA(cl, cl + sindong * cl / 17, cl + sindong * cl / 2, 225 * ((8 - R) / 8))
zero:
Next k
End If
End If
nopoint:
face!(t, 0) = face!(t, 0) - (8 - vite) * (0.0025) * pts
If face!(t, 0) < pts / 467 Then 'respawn!
face!(t, 0) = pts 'zmax
g = face!(t, 0) * (bol)
h = face!(t, 0) * (bol)
face!(t, 1) = (Rnd * g) * Sgn((Rnd - Rnd)) 'x
face!(t, 2) = (Rnd * h) * Sgn((Rnd - Rnd)) 'y
End If
Array!(t) = face!(t, 0) ' sort z coord!
Next t
If Timer < po! Then '7 seconds before the show
Cls
h$ = Str$(Int(100 - ((po! - Timer)) * 100)) + "%"
_PrintString (_Width / 1.44, _Height / 1.875), h$
Line (_Width / 3.26, _Height / 2.14)-(_Width / 1.44, _Height / 1.875), _RGB(230, 0, 0), BF
Line (_Width / 3.26 + (_Width / 160), _Height / 2.06)-(_Width / 3.26 + (_Width / 160) + (_Width / 2.66 - ((po! - Timer) * _Width / (2.66))), _Height / 1.93), , BF
_Display
_Limit 20
Else
Print "Hit 'esc' to quit | current balls:"; pts; "| Enter new number of balls and hit enter:"; r$
'Print "FPS"; fps
_Display
_Limit 20
End If
x = _KeyHit ' input key presed or not!
If x Then
If x < 0 Then ' Released negative value means key released'
x = -x
If add = 1 Then add = 2 ' if key pressed and key released then key confirm!
Else ' Pressed
add = 1 ' key pressed
End If
If x < 256 Then 'ASCII code values
If add = 2 Then If x >= 48 And x <= 57 Then r$ = r$ + Chr$(x): add = 0 ' if key confirm add keypress to r$ and set add to 0
End If
If Val(r$) > 0 Then If x = 13 Then pts = Val(r$): r$ = "": GoTo start ' if hit enter restart!
End If
Loop Until _KeyDown(27)
End
System
' modified for QB64 from JB
' This is the best all purpose sort routine around, don't worry how it works, it just does!
' To use this sub rountine store all the string values you want to sort into Arr$() array
' call Qsort with Start = LBound(Arr$) and Finish = UBound(Arr$)
Sub QSort (Start, Finish, Array!()) Static
Shared face!()
Dim i As Long, j As Long
i = Start
j = Finish
temp! = Array!(Int((i + j) / 2))
While i <= j
While Array!(i) < temp!
i = i + 1
Wend
While Array!(j) > temp!
j = j - 1
Wend
If i <= j Then
Swap Array!(i), Array!(j)
Swap face!(i, 0), face!(j, 0)
Swap face!(i, 1), face!(j, 1)
Swap face!(i, 2), face!(j, 2)
i = i + 1
j = j - 1
End If
Wend
If j > Start Then QSort Start, j, Array!()
If i < Finish Then QSort i, Finish, Array!()
End Sub
|
|
|
|
Post by bplus on Jan 14, 2024 20:55:16 GMT
Hey are you one of those middle or eastern European genii that is way cool!  Never worked with STATIC for subs, guess it's faster! |
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Jan 14, 2024 21:14:40 GMT
... Not really, I tested it by chance... it doesn't have the same effect every time. I don't even know what it's for?...
In fact, I was inspired by this non-recursive sub that I find less pretty... ...same result!
Sub QSort (Array!(), StartEl, NumEls) Static 'added 10/31/2005 - thanks to Edward F. Moneo
ReDim QStack(NumEls \ 5 + 10) ' 'create a stack array
First = StartEl ' 'initialize work variables
Last = StartEl + NumEls - 1
StackPtr = 0 '
Do
Do
Temp! = Array!((Last + First) \ 2) ' 'seek midpoint
I = First
J = Last
Do ' 'reverse both < and > below to sort descending
While Array!(I) < Temp!
I = I + 1
Wend
While Array!(J) > Temp!
J = J - 1
Wend
If I > J Then Exit Do
If I < J Then
Swap Array!(I), Array!(J)
End If
I = I + 1
J = J - 1
Loop While I <= J
If I < Last Then
QStack(StackPtr) = I ' 'Push I
QStack(StackPtr + 1) = Last ' 'Push Last
StackPtr = StackPtr + 2
End If
Last = J
Loop While First < Last
If StackPtr = 0 Then Exit Do ' 'Done
StackPtr = StackPtr - 2
First = QStack(StackPtr) ' 'Pop First
Last = QStack(StackPtr + 1) ' 'Pop Last
Loop
Erase QStack 'delete the stack array
End Sub
|
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Jan 15, 2024 22:49:21 GMT
can't remember how my balls program work and there is some code to do nothing like ddd or the second rotation (line 56). that's not good ..
does this happen's sometimes ? i sheduled this in 2016 ...and i forgot ... the drawing of the balls was from the web somewhere (some code in C++) but the rest i did it! and yet i can not remember the why ! but there must be a reason... for sure.
|
|
|
|
Post by bplus on Jan 15, 2024 23:15:15 GMT
In my forays into 3d sims, I use a sort on z axis to draw what is in the back first so it does not block out what is in front of it.
|
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Jan 16, 2024 0:20:05 GMT
Ok same sort of use yes z is 'face!(anythink, 0)' in the code !
I now remember why!! it's the rotation x,y for the second rotation!(line56)
In this code i have to mask with _RGB(0,0,0) too each balls before draw it in addition to Qsort because they're hollow balls.')
|
|
