Listen to QB64 Report!
Our podcast on all things QB64 is out now. Listen at
http://podcast.qb64.org
Show Posts
This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.
'https://www.quora.com/How-do-I-delete-negative-elements-from-an-array-and-print-positive-numbers-only
REDIM somearray(0 TO 16777215) AS DOUBLE
FOR s = LBOUND(somearay) TO UBOUND(somearray)
somearray(s) = (1 / 2 - RND) * (1 + RND)
NEXT
s! = TIMER(.001)
FlashSort somearray(), LBOUND(somearray), UBOUND(somearray), 1
DIM where AS _INTEGER64
DIM x AS _INTEGER64
where = BinarySearch(somearray(), LBOUND(somearray), UBOUND(somearray), 0)
f! = TIMER(.001)
x = LBOUND(somearray)
FOR i = where TO UBOUND(somearray)
PRINT somearray(i)
somearray(x) = somearray(i)
x = x + 1
NEXT
PRINT f! - s!
REDIM _PRESERVE somearray(LBOUND(somearray) TO UBOUND(somearray) - where + LBOUND(somearray))
FUNCTION BinarySearch (a() AS DOUBLE, start AS _INTEGER64, finish AS _INTEGER64, what AS DOUBLE)
DIM a AS _INTEGER64: a = start
DIM b AS _INTEGER64: b = finish
DO
where = a + (b - a) \ 2
SELECT CASE a(where)
CASE IS < what
a = where + 1
CASE IS > what
b = where - 1
CASE ELSE
EXIT DO
END SELECT
LOOP UNTIL b < a
BinarySearch = where
END FUNCTION
SUB FlashSort (CGSortLibArr() AS DOUBLE, start AS LONG, finish AS LONG, order&)
'* change these:
DIM hold AS DOUBLE
DIM flash AS DOUBLE
DIM ANMiN AS DOUBLE
'* to the same type as the array being sorted
'* change these:
DIM KIndex AS LONG
DIM MIndex AS LONG
DIM SIndex AS LONG
'* to long for qbxx as qbxx has no _unsigned types
'* the original ratio was .125 but i kept getting array bounds errors
MIndex = (INT(.128 * (finish - start + 1)) + 1) OR 2
'* change these:
DIM FlashTrackL(0 TO MIndex) AS LONG
DIM FlashI AS LONG
DIM FlashJ AS LONG
DIM NextFlashJ AS LONG
DIM FlashNMove AS LONG
DIM MaxValueIndex AS LONG
DIM MinValueIndex AS LONG
DIM FinishMinusOne AS LONG
'* to the appropriate type for the range being sorted (must match start, finish variables)
'* don't mess:
DIM FlashC1 AS DOUBLE '* for some reason does not work with _float
'* with this. it needs to be a double at the very least but float gives this a far greater range
'* more than likely more range than is practical. but ya never know (change this to double for qbxx)
' sorts array A with finish elements by use of
' index vector L with M elements, with M ca. 0.128(finish-start).
' Translation of Karl-Dietrich Neubert's FlashSort
' algorithm into BASIC by Erdmann Hess.
' Generalized Numeric Version -- recoded by codeguy
'* This is the absolute quickest sorting algorithm I can find for numeric arrays. Unfortunately, generalizing this for
'* strings may require some work. sounds like a project to me. I have changed a couple things from the original,
'* namely that .125 has been changed to .128. It seems that after a few runs on randomized data, a subscript error
'* kept popping up. Traced it to FlashTrackL() and added a minor (about 2.4&) increase in the upper bound of FlashTrackL().
'* I suppose this could also be used for non-integer and non-string types as well. Note: For very large N, HashListSort()
'* works even faster and has a similar memory footprint. But yes, this is still faster than QuickSort for N>10000 and like
'* HashListSort, operates in asymptotically close to O(N) time.
REM =============== CLASS FORMATION =================
ANMiN = CGSortLibArr(start)
MaxValueIndex = finish
MinValueIndex = start
FOR FlashI = start TO finish
IF (CGSortLibArr(FlashI) > CGSortLibArr(MaxValueIndex)) THEN MaxValueIndex = FlashI
IF (CGSortLibArr(FlashI) < CGSortLibArr(MinValueIndex)) THEN MinValueIndex = FlashI
NEXT FlashI
SWAP CGSortLibArr(MinValueIndex), CGSortLibArr(start): MinValueIndex = start: ANMiN = CGSortLibArr(MinValueIndex)
SWAP CGSortLibArr(MaxValueIndex), CGSortLibArr(finish): MaxValueIndex = finish
IF ANMiN = CGSortLibArr(MaxValueIndex) THEN
'* this is a monotonic sequence array and by definition is already sorted
EXIT SUB
END IF
DIM FlashTrackL(MIndex)
FlashC1 = (MIndex - 1) / (CGSortLibArr(MaxValueIndex) - ANMiN)
FOR FlashI = start + 1 TO finish - 1
KIndex = INT(FlashC1 * (CGSortLibArr(FlashI) - ANMiN)) + 1
FlashTrackL(KIndex) = FlashTrackL(KIndex) + 1
NEXT
FOR KIndex = LBOUND(FlashTrackL) + 1 TO MIndex
FlashTrackL(KIndex) = FlashTrackL(KIndex) + FlashTrackL(KIndex - 1)
NEXT KIndex
REM ==================== PERMUTATION ================
FlashNMove = 0
FlashJ = start + 1
KIndex = MIndex
FinishMinusOne = finish - 1
WHILE (FlashNMove < FinishMinusOne)
WHILE (FlashJ > FlashTrackL(KIndex))
FlashJ = FlashJ + 1
KIndex = INT(FlashC1 * (CGSortLibArr(FlashJ) - ANMiN)) + 1
WEND
flash = CGSortLibArr(FlashJ)
DO
IF (FlashJ = (FlashTrackL(KIndex) + 1)) THEN
EXIT DO
ELSE
IF FlashNMove < (FinishMinusOne) THEN
KIndex = INT(FlashC1 * (flash - ANMiN)) + 1
hold = CGSortLibArr(FlashTrackL(KIndex))
CGSortLibArr(FlashTrackL(KIndex)) = flash
flash = hold
FlashTrackL(KIndex) = FlashTrackL(KIndex) - 1
FlashNMove = FlashNMove + 1
ELSE
EXIT DO
END IF
END IF
LOOP
WEND
'================= Insertion Sort============
FOR SIndex = LBOUND(FlashtrackL) + 1 TO MIndex
'* sort subranges
'********************* insertionsortz CGSortLibArr(), FlashTrackL(SIndex - 1), FlashTrackL(SIndex) - 1, order&
FOR FlashI = FlashTrackL(SIndex) - 1 TO FlashTrackL(SIndex - 1) STEP -1
IF (CGSortLibArr(FlashI + 1) < CGSortLibArr(FlashI)) THEN
hold = CGSortLibArr(FlashI)
NextFlashJ = FlashI
DO
FlashJ = NextFlashJ
IF FlashJ < FlashTrackL(SIndex) THEN
NextFlashJ = FlashJ + 1
IF (CGSortLibArr(NextFlashJ) < hold) THEN
SWAP CGSortLibArr(FlashJ), CGSortLibArr(NextFlashJ)
ELSE
EXIT DO
END IF
ELSE
EXIT DO
END IF
LOOP
CGSortLibArr(FlashJ) = hold
END IF
NEXT
'* 914k/Ghz when it reaches this point, assuming this array is mostly sorted.
NEXT
EXIT SUB
IF order& = 1 THEN EXIT SUB
FlashI = start
FlashJ = finish
WHILE FlashJ > FlashI
SWAP CGSortLibArr(FlashI), CGSortLibArr(FlashJ)
FlashI = FlashI + 1
FlashJ = FlashJ - 1
WEND
END SUB
DEFLNG A-Z
DECLARE CUSTOMTYPE LIBRARY ".\direntry"
FUNCTION load_dir& (s AS STRING)
FUNCTION has_next_entry& ()
SUB close_dir ()
SUB get_next_entry (s AS STRING, flags AS LONG, file_size AS LONG)
END DECLARE
REDIM SHARED Tree(0) AS STRING
SCREEN _NEWIMAGE(1280, 740, 32)
_DELAY .25
_SCREENMOVE 80, 0
DIM cd$, i, w$
PRINT "Creating tree."
t# = TIMER(0.001)
MakeTree _CWD$ 'testing in QB64 folder
PRINT "Tree created."
PRINT USING "##.##### seconds creating and sorting tree."; TIMER - t#
SLEEP
CLS
_KEYCLEAR
PRINT "Showing Tree"
FOR i = 0 TO UBOUND(Tree) 'show tree
PRINT _TRIM$(STR$(i)); ": "; Tree(i)
IF i MOD 40 = 0 AND i > 0 THEN INPUT "Press enter to continue... "; w$: CLS
NEXT
SUB GetSubDirs (SearchDirectory AS STRING)
CONST IS_DIR = 1
DIM flags AS LONG, file_size AS LONG, length, nam$
IF load_dir(SearchDirectory + CHR$(0)) THEN
DO
length = has_next_entry
IF length > -1 THEN
nam$ = SPACE$(length)
get_next_entry nam$, flags, file_size
IF RIGHT$(nam$, 1) <> "." AND RIGHT$(nam$, 2) <> ".." THEN
IF flags = IS_DIR OR _DIREXISTS(SearchDirectory + "\" + nam$) THEN
REDIM _PRESERVE Tree(UBOUND(Tree) + 1)
Tree(UBOUND(Tree)) = SearchDirectory + "\" + nam$
END IF
END IF
END IF
LOOP UNTIL length = -1
ELSE
PRINT "Dir not loaded"
END IF
close_dir
END SUB
SUB MakeTree (Dir$)
DIM OnDir AS LONG
REDIM Tree(0) AS STRING
Tree(0) = Dir$
DO
GetSubDirs Tree(OnDir)
OnDir = OnDir + 1
LOOP UNTIL OnDir > UBOUND(Tree)
QuickSortIterativeString Tree(), LBOUND(tree), OnDir - 1, 1
'gap = UBOUND(Tree)
'DO
' gap = 10 * gap \ 13
' IF gap < 1 THEN gap = 1
' i = 0
' swapped = 0
' DO
' IF Tree(i) > Tree(i + gap) THEN
' SWAP Tree(i), Tree(i + gap)
' swapped = -1
' END IF
' i = i + 1
' LOOP UNTIL i + gap > UBOUND(Tree)
'LOOP UNTIL gap = 1 AND swapped = 0
END SUB
SUB QuickSortIterativeString (CGSortLibArr() AS String, QSIStart AS LONG, QSIFinish AS LONG, order&)
DIM QSI_Local_Compare AS String '* MUST be same type as element of CGSortLibArr()
'* These MUST be the appropriate type for the range being sorted
DIM QSI_Local_I AS LONG
DIM QSI_local_J AS LONG
DIM QSI_Local_Hi AS LONG
DIM QSI_Local_Low AS LONG
DIM QSI_Local_Mid AS LONG
'****************************************************************
'* Integer suffices for QSI_Local_MinStackPtr unless you're sorting more than 2^32767 elements.
DIM QSI_Local_MinStackPtr AS INTEGER: QSI_Local_MinStackPtr = 0
DIM QSI_Local_QSI_local_CurrentStackPtr AS INTEGER: QSI_Local_QSI_local_CurrentStackPtr = 0
DIM QSI_Local_FinishMinusStart AS LONG: QSI_Local_FinishMinusStart = QSIFinish - QSIStart
DIM QSI_local_Remainder AS INTEGER
'* yes, the equation log(QSIfinish-QSIstart)/log(2)+1 works too
DO
QSI_local_Remainder = QSI_Local_FinishMinusStart - (2 * INT(QSI_Local_FinishMinusStart / 2))
QSI_Local_FinishMinusStart = (QSI_Local_FinishMinusStart - QSI_local_Remainder) / 2
QSI_Local_MinStackPtr = QSI_Local_MinStackPtr + 1
LOOP UNTIL QSI_Local_FinishMinusStart < 1
'* MUST be appropriate type to handle the range (QSIfinish-QSIstart) being sorted
DIM QSI_LStack(0 TO QSI_Local_MinStackPtr, 0 TO 1) AS LONG
QSI_local_CurrentStackPtr = 0
QSI_LStack(QSI_local_CurrentStackPtr, 0) = QSIStart
QSI_LStack(QSI_local_CurrentStackPtr, 1) = QSIFinish
DO
QSI_Local_Low = QSI_LStack(QSI_local_CurrentStackPtr, 0)
QSI_Local_Hi = QSI_LStack(QSI_local_CurrentStackPtr, 1)
DO
QSI_Local_I = QSI_Local_Low
QSI_local_J = QSI_Local_Hi
QSI_Local_Mid = QSI_Local_Low + (QSI_Local_Hi - QSI_Local_Low) \ 2
QSI_Local_Compare = CGSortLibArr(QSI_Local_Mid)
SELECT CASE order&
CASE 1
DO
DO WHILE CGSortLibArr(QSI_Local_I) < QSI_Local_Compare
QSI_Local_I = QSI_Local_I + 1
LOOP
DO WHILE CGSortLibArr(QSI_local_J) > QSI_Local_Compare
QSI_local_J = QSI_local_J - 1
LOOP
IF QSI_Local_I <= QSI_local_J THEN
SWAP CGSortLibArr(QSI_Local_I), CGSortLibArr(QSI_local_J)
QSI_Local_I = QSI_Local_I + 1
QSI_local_J = QSI_local_J - 1
END IF
LOOP UNTIL QSI_Local_I > QSI_local_J
CASE ELSE
DO
DO WHILE CGSortLibArr(QSI_Local_I) > QSI_Local_Compare
QSI_Local_I = QSI_Local_I + 1
LOOP
DO WHILE CGSortLibArr(QSI_local_J) < QSI_Local_Compare
QSI_local_J = QSI_local_J - 1
LOOP
IF QSI_Local_I <= QSI_local_J THEN
SWAP CGSortLibArr(QSI_Local_I), CGSortLibArr(QSI_local_J)
QSI_Local_I = QSI_Local_I + 1
QSI_local_J = QSI_local_J - 1
END IF
LOOP UNTIL QSI_Local_I > QSI_local_J
END SELECT
IF QSI_local_J - QSI_Local_Low < QSI_Local_Hi - QSI_Local_I THEN
IF QSI_Local_I < QSI_Local_Hi THEN
QSI_LStack(QSI_local_CurrentStackPtr, 0) = QSI_Local_I
QSI_LStack(QSI_local_CurrentStackPtr, 1) = QSI_Local_Hi
QSI_local_CurrentStackPtr = QSI_local_CurrentStackPtr + 1
END IF
QSI_Local_Hi = QSI_local_J
ELSE
IF QSI_Local_Low < QSI_local_J THEN
QSI_LStack(QSI_local_CurrentStackPtr, 0) = QSI_Local_Low
QSI_LStack(QSI_local_CurrentStackPtr, 1) = QSI_local_J
QSI_local_CurrentStackPtr = QSI_local_CurrentStackPtr + 1
END IF
QSI_Local_Low = QSI_Local_I
END IF
LOOP WHILE QSI_Local_Low < QSI_Local_Hi
QSI_local_CurrentStackPtr = QSI_local_CurrentStackPtr - 1
LOOP UNTIL QSI_local_CurrentStackPtr < 0
END SUB
'BinarySearchTestI64
OPTION _EXPLICIT
CONST OrderDescending = -1
CONST OrderAscending = 1
CONST OrderMonotonic = 0
DIM LowerBoundTestArry AS _UNSIGNED _INTEGER64
DIM UpperBoundTestArry AS _UNSIGNED _INTEGER64: UpperBoundTestArry = 0
DIM MainI AS _UNSIGNED _INTEGER64: MainI = LowerBoundTestArry
DIM MainWhere AS _UNSIGNED _INTEGER64: MainWhere = LowerBoundTestArry
DIM MaiTestStart AS SINGLE
DIM MainTestEnd AS SINGLE
DIM mainOrderchoice AS INTEGER: mainOrderchoice = OrderDescending
DIM MainRepPercentage AS DOUBLE: MainRepPercentage = 0
DO
UpperBoundTestArry = UpperBoundTestArry + 1
REDIM CgSortLbAr(LowerBoundTestArry TO UpperBoundTestArry) AS DOUBLE
FillArray CgSortLbAr(), LowerBoundTestArry, UpperBoundTestArry, mainOrderchoice, MainRepPercentage
MaiTestStart = TIMER(.001)
FOR MainI = LowerBoundTestArry TO UpperBoundTestArry
cgBinarysearch CgSortLbAr(), LowerBoundTestArry, UpperBoundTestArry, CgSortLbAr(MainI), MainWhere
IF CgSortLbAr(MainI) = CgSortLbAr(MainWhere) THEN
ELSE
STOP
END IF
NEXT
MainTestEnd = TIMER(.001)
PRINT UpperBoundTestArry - LowerBoundTestArry; MainTestEnd - MaiTestStart
UpperBoundTestArry = UpperBoundTestArry * 2
LOOP UNTIL UpperBoundTestArry > 67108863
PRINT UpperBoundTestArry
SUB FillArray (CgSortLibArr() AS DOUBLE, start AS _UNSIGNED _INTEGER64, finish AS _UNSIGNED _INTEGER64, OrderChoice AS INTEGER, Repetitions AS DOUBLE)
DIM FillArray_RepeatStart AS _UNSIGNED _INTEGER64
IF OrderChoice = OrderMonotonic THEN
FOR FillArray_RepeatStart = start TO finish
CgSortLibArr(FillArray_RepeatStart) = 0
NEXT
ELSE
IF Repetitions > 0 THEN
IF Repetitions < 100 THEN
FillArray_RepeatStart = finish - INT((Repetitions / 100) * (finish - start))
ELSE
FillArray_RepeatStart = finish
END IF
DIM FillArray_u AS _UNSIGNED _INTEGER64: FillArray_u = start
DO
IF FillArray_u > finish - 1 THEN
EXIT DO
ELSE
IF FillArray_u > FillArray_RepeatStart THEN
CgSortLibArr(FillArray_u) = CgSortLibArr(FillArray_RepeatStart)
END IF
END IF
FillArray_u = FillArray_u + 1
LOOP
ELSE
SELECT CASE OrderChoice
CASE OrderDescending
FOR FillArray_RepeatStart = start TO finish
CgSortLibArr(FillArray_RepeatStart) = (finish - FillArray_RepeatStart) / (finish - start + 1)
NEXT
CASE OrderAscending
FOR FillArray_RepeatStart = start TO finish
CgSortLibArr(FillArray_RepeatStart) = (FillArray_RepeatStart) / (finish - start + 1)
NEXT
CASE ELSE
FOR FillArray_RepeatStart = start TO finish
CgSortLibArr(FillArray_RepeatStart) = 0
NEXT
END SELECT
END IF
END IF
END SUB
SUB cgBinarysearch (CgSortLibArr() AS DOUBLE, start AS _UNSIGNED _INTEGER64, finish AS _UNSIGNED _INTEGER64, what AS DOUBLE, where AS _UNSIGNED _INTEGER64)
DIM BinarySearch_low AS _INTEGER64
DIM BinarySearch_high AS _INTEGER64
SELECT CASE CgSortLibArr(start)
CASE IS <= CgSortLibArr(finish)
BinarySearch_low = start
BinarySearch_high = finish
DO
where = BinarySearch_low + (BinarySearch_high - BinarySearch_low) \ 2
IF CgSortLibArr(where) < what THEN
BinarySearch_low = where + 1
ELSEIF CgSortLibArr(where) > what THEN
BinarySearch_high = where - 1
ELSE
EXIT SUB
END IF
LOOP WHILE BinarySearch_low < BinarySearch_high
where = BinarySearch_low
CASE ELSE
BinarySearch_low = finish
BinarySearch_high = start
DO
where = BinarySearch_high + (BinarySearch_low - BinarySearch_high) \ 2
IF CgSortLibArr(where) > what THEN
BinarySearch_high = where + 1
ELSEIF CgSortLibArr(where) < what THEN
BinarySearch_low = where - 1
ELSE
EXIT SUB
END IF
LOOP WHILE BinarySearch_low > BinarySearch_high
where = BinarySearch_high
END SELECT
END SUB
'NSpace3D.bas
TYPE RGBRec
red AS _UNSIGNED _BYTE
green AS _UNSIGNED _BYTE
blue AS _UNSIGNED _BYTE
END TYPE
TYPE Coord
x AS INTEGER
y AS INTEGER
z AS INTEGER
END TYPE
TYPE PointRec
x AS SINGLE
y AS SINGLE
z AS SINGLE
radius AS SINGLE
colorsRGB AS RGBRec
inc AS Coord
precalcRGB AS LONG
precalcdiameter AS LONG
END TYPE
TYPE Segment
xseg AS _UNSIGNED _BYTE
yseg AS _UNSIGNED _BYTE
zseg AS _UNSIGNED _BYTE
xsegsize AS _UNSIGNED _BYTE
ysegsize AS _UNSIGNED _BYTE
zsegsize AS _UNSIGNED _BYTE
END TYPE
TYPE ScreenRec
begins AS Coord
ends AS Coord
END TYPE
xscreen& = _SCREENIMAGE
SCREEN xscreen&
CLS
DIM GScrn AS ScreenRec
GScrn.begins.x = 1
GScrn.begins.y = 1
GScrn.begins.z = 1
GScrn.ends.x = _WIDTH(xscreen&)
GScrn.ends.y = _HEIGHT(xscreen&)
GScrn.ends.z = 1024
DIM a(8191) AS PointRec
DIM SegmentMetrics AS Segment
SegmentMetrics.xseg = 16
SegmentMetrics.xsegsize = (GScrn.ends.x - GScrn.begins.x + 1) / SegmentMetrics.xseg
SegmentMetrics.yseg = 16
SegmentMetrics.ysegsize = (GScrn.ends.y - GScrn.begins.y + 1) / SegmentMetrics.yseg
SegmentMetrics.zseg = 16
SegmentMetrics.zsegsize = (GScrn.ends.z - GScrn.begins.z + 1) / SegmentMetrics.zseg
REDIM NspaceObjects(SegmentMetrics.xseg, SegmentMetrics.yseg, SegmentMetrics.zseg, SizeOf(a()) / 4)
REDIM counts%(SegmentMetrics.xseg, SegmentMetrics.yseg, SegmentMetrics.zseg)
FOR i = LBOUND(a) TO UBOUND(a)
a(i).radius = (RND * 2) OR 1
a(i).precalcdiameter = a(i).radius * 2
a(i).x = a(i).radius + RND * (GScrn.ends.x - a(i).radius)
a(i).y = a(i).radius + RND * (GScrn.ends.y - a(i).radius)
a(i).z = a(i).radius + RND * (GScrn.ends.z - a(i).radius)
a(i).inc.x = (6 * (1 - RND * 2)) OR 1
a(i).inc.y = (6 * (1 - RND * 2)) OR 1
a(i).inc.z = (6 * (1 - RND * 2)) OR 1
a(i).colorsRGB.red = INT(RND * 256)
a(i).colorsRGB.green = INT(RND * 256)
a(i).colorsRGB.blue = INT(RND * 256)
a(i).precalcRGB = _RGB(a(i).colorsRGB.red, a(i).colorsRGB.green, a(i).colorsRGB.blue)
NEXT
frames& = 0
lastframe& = 0
Start! = TIMER(.001)
xstart! = Start!
DIM XLoop AS _UNSIGNED _BYTE
DIM YLoop AS _UNSIGNED _BYTE
DIM ZLoop AS _UNSIGNED _BYTE
DO
CLS
FOR i = LBOUND(a) TO UBOUND(a)
IF a(i).x - a(i).radius + a(i).inc.x < GScrn.begins.x THEN
a(i).inc.x = -a(i).inc.x
ELSEIF a(i).x + a(i).radius + a(i).inc.x > GScrn.ends.x THEN
a(i).inc.x = -a(i).inc.x
END IF
a(i).x = a(i).x + a(i).inc.x
IF a(i).y - a(i).radius + a(i).inc.y < GScrn.begins.y THEN
a(i).inc.y = -a(i).inc.y
ELSEIF a(i).y + a(i).radius + a(i).inc.y > GScrn.ends.y THEN
a(i).inc.y = -a(i).inc.y
END IF
a(i).y = a(i).y + a(i).inc.y
IF a(i).z - a(i).radius + a(i).inc.z < GScrn.begins.z THEN
a(i).inc.z = -a(i).inc.z
ELSEIF a(i).z + a(i).radius + a(i).inc.z > GScrn.ends.z THEN
a(i).inc.z = -a(i).inc.z
END IF
a(i).z = a(i).z + a(i).inc.z
PSET (a(i).x, a(i).y), a(i).precalcRGB
NEXT
NSpace a(), SegmentMetrics, NspaceObjects(), counts%()
FOR XLoop = 0 TO SegmentMetrics.xseg
FOR YLoop = 0 TO SegmentMetrics.yseg
FOR ZLoop = 0 TO SegmentMetrics.zseg
FOR d% = 0 TO counts%(XLoop, YLoop, ZLoop) - 2
m& = NspaceObjects(XLoop, YLoop, ZLoop, d%)
FOR e% = d% + 1 TO counts%(XLoop, YLoop, ZLoop) - 1
n& = NspaceObjects(XLoop, YLoop, ZLoop, e%)
IF Collision%(a(m&), a(n&)) THEN
a(n&).inc.x = -a(m&).inc.x
a(n&).inc.y = -a(m&).inc.y
a(n&).inc.z = -a(m&).inc.z
END IF
NEXT
NEXT
NEXT
NEXT
NEXT
REDIM counts%(SegmentMetrics.xseg, SegmentMetrics.yseg, SegmentMetrics.zseg)
IF ABS(TIMER(.001) - Start!) < 2 THEN
frames& = frames& + 1
ELSE
Start! = TIMER(.001)
PRINT (frames& - lastframe&) / 2
lastframe& = frames&
END IF
_DISPLAY
d$ = INKEY$
LOOP UNTIL d$ > ""
finish! = TIMER(.001)
CLS
SCREEN 0
PRINT frames& / (finish! - xstart!)
SUB NSpace (a() AS PointRec, SegmentsXYZ AS Segment, NspaceObjects(), Counts%())
DIM xbox, ybox, zbox AS _UNSIGNED _BYTE
DIM oxseg, oyseg, ozseg AS _UNSIGNED _BYTE
FOR m& = LBOUND(A) TO UBOUND(A)
oxseg = a(m&).x \ SegmentsXYZ.xsegsize
oyseg = a(m&).y \ SegmentsXYZ.ysegsize
ozseg = a(m&).z \ SegmentsXYZ.zsegsize
IF Counts%(oxseg, oyseg, ozseg) > UBOUND(NspaceObjects, 4) THEN
REDIM _PRESERVE NspaceObjects(SegmentsXYZ.xseg, SegmentsXYZ.yseg, SegmentsXYZ.zseg, Counts%(oxseg, oyseg, ozseg))
'* PRINT Counts%(oxseg, oyseg, ozseg)
END IF
dx% = Counts%(oxseg, oyseg, ozseg)
NspaceObjects(oxseg, oyseg, ozseg, dx%) = m&
Counts%(oxseg, oyseg, ozseg) = dx% + 1
IF a(m&).radius THEN
FOR u = -a(m&).radius TO a(m&).radius STEP a(m&).precalcdiameter
xbox = (a(m&).x + u) \ SegmentsXYZ.xsegsize
IF xbox >= 0 THEN
IF xbox <= SegmentsXYZ.xseg THEN
ybox = (a(m&).y + u) \ SegmentsXYZ.ysegsize
IF ybox >= 0 THEN
IF ybox <= SegmentsXYZ.yseg THEN
zbox = (a(m&).z + u) \ SegmentsXYZ.zsegsize
IF zbox >= 0 THEN
IF zbox <= SegmentsXYZ.zseg THEN
IF xbox <> oxseg OR ybox <> oyseg OR zbox <> ozseg THEN
dx% = Counts%(xbox, ybox, zbox)
NspaceObjects(xbox, ybox, zbox, dx%) = m&
Counts%(xbox, ybox, zbox) = dx% + 1
END IF
END IF
END IF
END IF
END IF
END IF
END IF
NEXT
END IF
NEXT
END SUB
FUNCTION SizeOf% (a() AS PointRec)
SizeOf% = UBOUND(a) - LBOUND(a) + 1
END FUNCTION
FUNCTION Collision% (a AS PointRec, b AS PointRec)
Collision% = 0
IF ABS(b.x - a.x) > a.radius + b.radius THEN
EXIT SUB
ELSE
IF ABS(b.y - a.y) > a.radius + b.radius THEN
EXIT SUB
ELSE
IF ABS(b.z - a.z) > a.radius + b.radius THEN
EXIT SUB
ELSE
Collision% = -1
END IF
END IF
END IF
END FUNCTION
'*NSpace Sub And Demo Code (2-d)
'*NSpaceRoutine2D.bas
TYPE RGBRec
red AS _UNSIGNED _BYTE
green AS _UNSIGNED _BYTE
blue AS _UNSIGNED _BYTE
END TYPE
TYPE Coord
x AS INTEGER
y AS INTEGER
END TYPE
TYPE PointRec
x AS SINGLE
y AS SINGLE
radius AS SINGLE
colorsRGB AS RGBRec
inc AS Coord
precalcRGB AS LONG
precalcdiameter AS LONG
END TYPE
TYPE Segment
xseg AS _UNSIGNED _BYTE
yseg AS _UNSIGNED _BYTE
xsegsize AS _UNSIGNED _BYTE
ysegsize AS _UNSIGNED _BYTE
END TYPE
TYPE ScreenRec
begins AS Coord
ends AS Coord
END TYPE
xscreen& = _SCREENIMAGE
SCREEN xscreen&
CLS
DIM GScrn AS ScreenRec
GScrn.begins.x = 1
GScrn.begins.y = 1
GScrn.ends.x = _WIDTH(xscreen&)
GScrn.ends.y = _HEIGHT(xscreen&)
DIM a(8191) AS PointRec
DIM SegmentMetrics AS Segment
SegmentMetrics.xseg = 16
SegmentMetrics.xsegsize = (GScrn.ends.x - GScrn.begins.x + 1) / SegmentMetrics.xseg
SegmentMetrics.yseg = 16
SegmentMetrics.ysegsize = (GScrn.ends.y - GScrn.begins.y + 1) / SegmentMetrics.yseg
REDIM NspaceObjects(SegmentMetrics.xseg, SegmentMetrics.yseg, SizeOf(a()) / 4)
REDIM counts%(SegmentMetrics.xseg, SegmentMetrics.yseg)
FOR i = LBOUND(a) TO UBOUND(a)
a(i).radius = (RND * 2) OR 1
a(i).precalcdiameter = a(i).radius * 2
a(i).x = a(i).radius + RND * (GScrn.ends.x - a(i).radius)
a(i).y = a(i).radius + RND * (GScrn.ends.y - a(i).radius)
a(i).inc.x = (6 * (1 - RND * 2)) OR 1
a(i).inc.y = (6 * (1 - RND * 2)) OR 1
a(i).colorsRGB.red = INT(RND * 256)
a(i).colorsRGB.green = INT(RND * 256)
a(i).colorsRGB.blue = INT(RND * 256)
a(i).precalcRGB = _RGB(a(i).colorsRGB.red, a(i).colorsRGB.green, a(i).colorsRGB.blue)
NEXT
frames& = 0
lastframe& = 0
Start! = TIMER(.001)
xstart! = Start!
DIM XLoop AS _UNSIGNED _BYTE
DIM YLoop AS _UNSIGNED _BYTE
DO
CLS
FOR i = LBOUND(a) TO UBOUND(a)
IF a(i).x - a(i).radius + a(i).inc.x < GScrn.begins.x THEN
a(i).inc.x = -a(i).inc.x
ELSEIF a(i).x + a(i).radius + a(i).inc.x > GScrn.ends.x THEN
a(i).inc.x = -a(i).inc.x
END IF
a(i).x = a(i).x + a(i).inc.x
IF a(i).y - a(i).radius + a(i).inc.y < GScrn.begins.y THEN
a(i).inc.y = -a(i).inc.y
ELSEIF a(i).y + a(i).radius + a(i).inc.y > GScrn.ends.y THEN
a(i).inc.y = -a(i).inc.y
END IF
a(i).y = a(i).y + a(i).inc.y
PSET (a(i).x, a(i).y), a(i).precalcRGB
NEXT
NSpace a(), SegmentMetrics, NspaceObjects(), counts%()
FOR XLoop = 0 TO SegmentMetrics.xseg
FOR YLoop = 0 TO SegmentMetrics.yseg
FOR d% = 0 TO counts%(XLoop, YLoop) - 2
m& = NspaceObjects(XLoop, YLoop, d%)
FOR e% = d% + 1 TO counts%(XLoop, YLoop) - 1
n& = NspaceObjects(XLoop, YLoop, e%)
IF Collision%(a(m&), a(n&)) THEN
a(n&).inc.x = -a(m&).inc.x
a(n&).inc.y = -a(m&).inc.y
END IF
NEXT
NEXT
NEXT
NEXT
REDIM counts%(SegmentMetrics.xseg, SegmentMetrics.yseg)
IF ABS(TIMER(.001) - Start!) < 2 THEN
frames& = frames& + 1
ELSE
Start! = TIMER(.001)
PRINT (frames& - lastframe&) / 2
lastframe& = frames&
END IF
_DISPLAY
d$ = INKEY$
LOOP UNTIL d$ > ""
finish! = TIMER(.001)
CLS
SCREEN 0
PRINT frames& / (finish! - xstart!)
SUB NSpace (a() AS PointRec, SegmentsXYZ AS Segment, NspaceObjects(), Counts%())
DIM xbox, ybox AS _UNSIGNED _BYTE
DIM oxseg, oyseg AS _UNSIGNED _BYTE
FOR m& = LBOUND(A) TO UBOUND(A)
oxseg = a(m&).x \ SegmentsXYZ.xsegsize
oyseg = a(m&).y \ SegmentsXYZ.ysegsize
IF Counts%(oxseg, oyseg) > UBOUND(NspaceObjects, 3) THEN
REDIM _PRESERVE NspaceObjects(SegmentsXYZ.xseg, SegmentsXYZ.yseg, Counts%(oxseg, oyseg))
'* PRINT Counts%(oxseg, oyseg)
END IF
dx% = Counts%(oxseg, oyseg)
NspaceObjects(oxseg, oyseg, dx%) = m&
Counts%(oxseg, oyseg) = dx% + 1
IF a(m&).radius THEN
FOR u = -a(m&).radius TO a(m&).radius STEP a(m&).precalcdiameter
xbox = (a(m&).x + u) \ SegmentsXYZ.xsegsize
IF xbox >= 0 THEN
IF xbox <= SegmentsXYZ.xseg THEN
ybox = (a(m&).y + u) \ SegmentsXYZ.ysegsize
IF ybox >= 0 THEN
IF ybox <= SegmentsXYZ.yseg THEN
IF xbox <> oxseg OR ybox <> oyseg THEN
dx% = Counts%(xbox, ybox)
NspaceObjects(xbox, ybox, dx%) = m&
Counts%(xbox, ybox) = dx% + 1
END IF
END IF
END IF
END IF
END IF
NEXT
END IF
NEXT
END SUB
FUNCTION SizeOf% (a() AS PointRec)
SizeOf% = UBOUND(a) - LBOUND(a) + 1
END FUNCTION
FUNCTION Collision% (a AS PointRec, b AS PointRec)
Collision% = 0
IF ABS(b.x - a.x) > a.radius + b.radius THEN
EXIT SUB
ELSE
IF ABS(b.y - a.y) > a.radius + b.radius THEN
EXIT SUB
END IF
END IF
END FUNCTION
[code]
As you can see, this is not much different from the 3d version, except that all references and variables used for z-plane have been eliminated! ENJOY!
'* nspace5.bas
'$checking: off
CONST NXDivs% = 16
CONST NYDivs% = 16
CONST NZDivs% = 16
CONST ubst% = 2519
CONST NDimensions% = 2
CONST MaxObjectRadius% = 3
MaxFPS% = 64
DIM SHARED MinScreenX%, MaxScreenX%, MinScreenY%, MaxScreenY%, NxDivSize%, NyDivSize%
DIM SHARED cstart AS SINGLE, cend AS SINGLE, minx, maxx, miny, maxy
cstart = 0: cend = 6.2
REDIM SHARED PolysInRegion%(NXDivs%, NYDivs%, 0), counts%(NXDivs%, NYDivs%), MaxPolys%
REDIM SHARED SinTable!(0 TO ubst%), CosTable!(0 TO ubst%), PolysInRegion%(NXDivs%, NYDivs%, 0)
'***********
DIM SHARED text$
text$ = " D.K.M Productions"
DIM SHARED word(1 TO LEN(text$) * 8, 1 TO 16)
FOR i& = 0 TO ubst%
SinTable!(i&) = SIN(2 * i& * 3.1415926535 / (ubst% + 1))
CosTable!(i&) = COS(2 * i& * 3.1415926535 / (ubst% + 1))
NEXT
oscreen& = _SCREENIMAGE
MaxScreenX% = _WIDTH(oscreen&) / 2
MaxScreenY% = _HEIGHT(oscreen&) / 2
MaxScreenZ% = 0
_FREEIMAGE oscreen&
MinScreenX% = 0
MinScreenY% = 0
MinScreenZ% = 0
ModNxDivsSx% = (MaxScreenX% - MinScreenX%) MOD NXDivs%
ModNyDivsSy% = (MaxScreenY% - MinScreenY%) MOD NYDivs%
ModNzDivsSz% = (MaxScreenZ% - MinScreenZ%) MOD NZDivs%
NxDivSize% = ((MaxScreenX% - MinScreenX%) - ModNxDivSx%) / NXDivs%
NyDivSize% = ((MaxScreenY% - MinScreenY%) - ModNyDivSy%) / NYDivs%
NzDivSize% = ((MaxScreenZ% - MinScreenZ%) - ModNzDivSz%) / NZDivs%
TYPE Polygons
x AS SINGLE
y AS SINGLE
z AS SINGLE
mass AS SINGLE
radius AS INTEGER
speedx AS SINGLE
speedy AS SINGLE
speedz AS SINGLE
COLOR AS INTEGER
'mass AS SINGLE
nsides AS INTEGER
radius2 AS SINGLE
END TYPE
REDIM b(0 TO 1) AS Polygons
MaxPolys% = 127
DIM SHARED Polys(0 TO MaxPolys%) AS Polygons
SepX% = (MaxScreenX% - MinScreenX%) / (2 * MaxObjectRadius%)
accum% = MaxObjectRadius%
x% = MaxObjectRadius%
y% = MaxObjectRadius%
FOR i% = LBOUND(Polys) TO UBOUND(Polys)
Polys(i%).nsides = SetRand(3, 5)
Polys(i%).radius = MaxObjectRadius% '* SetRand%(0, MaxObjectRadius%)
Polys(i%).x = x% '* SetRand(MinScreenX% + Polys(i%).radius, MaxScreenX% - Polys(i%).radius)
Polys(i%).speedx = SetRand(0, MaxObjectRadius% / 2)
Polys(i%).y = y% '* SetRand(MinScreenY% + Polys(i%).radius, MaxScreenY% - Polys(i%).radius)
Polys(i%).z = SetRand(MinScreenZ% + Polys(i%).radius, MaxScreenZ% - Polys(i%).radius)
Polys(i%).speedy = SetRand(0, MaxObjectRadius% / 2)
Polys(i%).speedz = SetRand(0, MaxObjectRadius% / 2)
Polys(i%).COLOR = SetRand(43, 127)
Polys(i%).mass = Polys(i%).nsides \ 2 + 1
IF x% > MaxScreenX% - MaxObjectRadius% THEN
y% = y% + 2 * MaxObjectRadius%
x% = MaxObjectRadius%
ELSE
x% = x% + 2 * MaxObjectRadius%
END IF
Polys(i%).radius2 = Polys(i%).radius ^ 2
NEXT
DIM logo AS Polygons
logo.z = 0
logo.speedx = 0
logo.speedy = 0
logo.speedz = 0
logo.mass = 1
GameScreen& = _NEWIMAGE(MaxScreenX%, MaxScreenY%, 256)
dimensionFlags% = 1
TempX% = (NDimensions% - 1)
BitSet% = 1
WHILE TempX% > 0
dimensionFlags% = dimensionFlags% OR 2 ^ BitSet%
BitSet% = BitSet% + 1
TempX% = TempX% \ 2
WEND
SCREEN GameScreen&
logo.x = _WIDTH / 2
logo.y = _HEIGHT / 2
LOCATE 2, 1: PRINT text$;
analyse
DO
'_AUTODISPLAY
IF _MOUSEINPUT THEN
PlayerX% = _MOUSEX
PlayerY% = _MOUSEY
lmb% = _MOUSEBUTTON(1)
rmb% = _MOUSEBUTTON(2)
END IF
'* check to see if objects collide with each other
DIM row AS INTEGER, cnt AS INTEGER
DIM xrot AS INTEGER, yrot AS INTEGER, scale AS INTEGER
xrot = 6: yrot = 6: scale = 4
OUT &H3C8, 1: OUT &H3C9, 10: OUT &H3C9, 20: OUT &H3C9, 63
time! = TIMER
DO
CLS
row = 2
Ltime! = TIMER
DO
DO
'LINE (minx, miny)-(max, maxy), 0, BF
minx = 32767
miny = 32767
FOR i = cstart TO cend STEP .04
x = (scale * 60 - (row * xrot)) * (COS(i))
IF x < minx THEN
minx = x
END IF
IF x > maxx THEN
maxx = x
END IF
y = (scale * 60 - (row * yrot)) * (SIN(i))
IF y < miny THEN
miny = y
END IF
IF y > maxy THEN
maxy = y
END IF
cnt = cnt + 1
IF word(cnt, row) > 0 THEN
CIRCLE (x / 2 + _WIDTH / 2, y / 2 + _HEIGHT / 2), scale, 1
PAINT STEP(0, 0), 1, 1
END IF
IF cnt = LEN(text$) * 8 THEN cnt = 0: EXIT DO
NEXT
LOOP
row = row + 1
LOOP UNTIL row = 16
cend = cend + .1
cstart = cstart + .1
IF ABS(maxx) > ABS(maxy) THEN
logo.radius = ABS(maxx) / 2
ELSE
logo.radius = ABS(maxy) / 2
END IF
logo.mass = 1
logo.radius2 = logo.radius ^ 2
IF -1 THEN
FOR i% = LBOUND(polys) TO UBOUND(polys)
IF Collision%(logo, Polys(i%), dimensionFlags%) THEN
IF (logo.x = Polys(i%).x) THEN
logo.speedx = (logo.radius / (scale ^ 2))
logo.speedy = 1
ELSE
slope! = (logo.y - Polys(i%).y) / (logo.x - Polys(i%).x)
IF Polys(i%).y >= logo.y THEN '* either going N or E (270-90)
IF Polys(i%).x >= logo.x THEN 'going east
Theta! = slope! * 90
ELSE 'going north
Theta! = 270 + slope! * 90
END IF
ELSE
IF Polys(i%).x >= logo.x THEN
Theta! = 90 + slope! * 90
ELSE
Theta! = 180 + 90 * slope!
END IF
END IF
logo.speedx = logo.radius / (scale ^ 2) * COS(Theta! * 3.14159 / 180)
logo.speedy = logo.radius / (scale ^ 2) * SIN(Theta! * 3.14159 / 180)
END IF
b(0) = logo
b(1) = Polys(i%)
CalcVelocities b(), 0, 1, dimensionFlags%
Polys(i%) = b(1)
Position Polys(i%), dimensionFlags%
'* DrawPoly Polys(i%)
ELSE
Position Polys(i%), dimensionFlags%
IF 0 THEN
IF Polys(i%).x < _WIDTH / 2 - maxx / 2 THEN
DrawPoly Polys(i%)
'PAINT (Polys(i%).x, Polys(i%).y), Polys(i%).color
ELSEIF Polys(i%).x > maxx / 2 + _WIDTH / 2 THEN
DrawPoly Polys(i%)
'PAINT (Polys(i%).x, Polys(i%).y), Polys(i%).color
ELSE
m% = (m% + 1) MOD 2
IF m% THEN
Polys(i%).x = _WIDTH / 2 - maxx / 2 - 1
ELSE
Polys(i%).x = maxx / 2 + _WIDTH / 2 + 1
END IF
END IF
ELSE
DrawPoly Polys(i%)
END IF
GetPossibleIndexes i%, Polys(i%).x, Polys(i%).y, Polys(i%).radius, MinScreenX%, MaxScreenX%, MinScreenY%, MaxScreenY%
'CollidedWithPlayer% = Collision%(PlayerX%, PlayerY%, 100, Polys(i%).x, Polys(i%).y, Polys(i%).radius)
'IF CollidedWithPlayer% THEN
'END IF
END IF
NEXT
END IF
FOR ax% = 0 TO NXDivs%
FOR ay% = 0 TO NYDivs%
FOR xj% = 0 TO counts%(ax%, ay%) - 1
p1% = PolysInRegion%(ax%, ay%, xj%)
FOR aj% = xj% + 1 TO counts%(ax%, ay%) - 1
p2% = PolysInRegion%(ax%, ay%, aj%)
IF Collision%(Polys(p1%), Polys(p2%), dimensionFlags%) THEN
CalcVelocities Polys(), p1%, p2%, dimensionFlags%
END IF
NEXT
NEXT
counts%(ax%, ay%) = 0
NEXT
NEXT
REDIM PolysInRegion%(NXDivs%, NYDivs%, 0)
Dtime! = ABS(TIMER - Ltime!)
IF ABS(Dtime! - 1 / MaxFPS%) > .010 THEN
MaxPolys% = MaxPolys% + 1
REDIM _PRESERVE Polys(MaxPolys%) AS Polygons
Polys(MaxPolys%).nsides = SetRand(3, 5)
Polys(MaxPolys%).radius = MaxObjectRadius% '* SetRand%(0, MaxObjectRadius%)
IF MaxPolys% MOD 2 THEN
Polys(MaxPolys%).x = SetRand(MinScreenX% + Polys(i%).radius, MinScreenX% + Polys(i%).radius)
Polys(MaxPolys%).y = SetRand(MinScreenY% + Polys(i%).radius, MinScreenY% + Polys(i%).radius)
ELSE
Polys(MaxPolys%).x = SetRand(MaxScreenX% - Polys(i%).radius, MaxScreenX% - Polys(i%).radius)
Polys(MaxPolys%).y = SetRand(MaxScreenY% - Polys(i%).radius, MaxScreenY% - Polys(i%).radius)
END IF
Polys(MaxPolys%).speedx = SetRand(0, MaxObjectRadius% / 2)
Polys(MaxPolys%).z = SetRand(MinScreenZ% + Polys(i%).radius, MaxScreenZ% - Polys(i%).radius)
Polys(MaxPolys%).speedy = SetRand(0, MaxObjectRadius% / 2)
Polys(MaxPolys%).speedz = SetRand(0, MaxObjectRadius% / 2)
Polys(MaxPolys%).COLOR = SetRand(43, 127)
Polys(MaxPolys%).mass = Polys(i%).nsides \ 2 + 1
Polys(i%).radius2 = Polys(i%).radius ^ 2
ELSEIF ABS(Dtime! - 1 / MaxFPS%) < .010 THEN
MaxPolys% = MaxPolys% - 100
REDIM _PRESERVE Polys(MaxPolys%) AS Polygons
END IF
_DISPLAY
_LIMIT 20
LOOP UNTIL ABS(TIMER - time!) > .15
LOOP UNTIL INKEY$ > "" OR rmb%
SYSTEM
SUB Position (P AS Polygons, flags%)
IF flags% AND 4 THEN
IF P.z + P.speedz < MinScreenZ% THEN
P.speedz = -P.speedz
ELSEIF P.z + P.speedz > MaxScreenZ% THEN
P.speedz = -P.speedz
END IF
P.z = P.z + P.speedz
END IF
IF flags% AND 2 THEN
IF P.y + P.speedy < MinScreenY% THEN
P.speedy = -P.speedy
ELSEIF P.y + P.speedy > MaxScreenY% THEN
P.speedy = -P.speedy
END IF
P.y = P.y + P.speedy
END IF
IF flags% AND 1 THEN
IF P.x + P.speedx < MinScreenX% THEN
P.speedx = -P.speedx
ELSEIF P.x + P.speedx > MaxScreenX% THEN
P.speedx = -P.speedx
END IF
P.x = P.x + P.speedx
END IF
END SUB
FUNCTION Collision% (T1 AS Polygons, t2 AS Polygons, flags%)
IF (flags% AND 4) THEN
dx! = (T1.x - t2.x) ^ 2
dy! = (T1.y - t2.y) ^ 2
IF dx! + dy! > (T1.radius2 + t2.radius2) THEN
Collision% = 0
ELSE
IF ABS(T1.z - t2.z) > (T1.radius + t2.radius) THEN
Collision% = 0
ELSE
Collision% = -1
END IF
END IF
EXIT FUNCTION
END IF
IF (flags% AND 2) THEN
dx! = (T1.x - t2.x) ^ 2
dy! = (T1.y - t2.y) ^ 2
IF dx! + dy! > (T1.radius2 + t2.radius2) THEN
Collision% = 0
ELSE
Collision% = -1
END IF
EXIT FUNCTION
END IF
IF flags% AND 1 THEN
IF ABS(T1.x - t2.x) > T1.radius + t2.radius THEN
Collision% = 0
ELSE
Collision% = -1
END IF
EXIT FUNCTION
END IF
END FUNCTION
FUNCTION SetRand% (MinValue%, MaxValue%)
SetRand% = MinValue% + RND * (MaxValue% - MinValue%)
END FUNCTION
SUB GetPossibleIndexes (PolyNumber%, x%, y%, radius%, MinSX%, MaxSX%, MinSY%, MaxSY%)
IF radius% > 0 THEN
oldix% = -1
oldiy% = -1
FOR i% = -radius% TO radius% STEP radius%
SELECT CASE x%
CASE MinSX% + radius% TO MaxSX% - radius%
SELECT CASE y%
CASE MinSY% + radius% TO MaxSY% - radius%
ax% = (x% + i%) \ NxDivSize%
ay% = (y% + i%) \ NyDivSize%
IF ax% <> oldix% OR ay% <> oldiy% THEN
IF counts%(ax%, ay%) > UBOUND(PolysInRegion%, 3) THEN
REDIM _PRESERVE PolysInRegion%(NXDivs%, NYDivs%, counts%(ax%, ay%))
END IF
PolysInRegion%(ax%, ay%, counts%(ax%, ay%)) = PolyNumber%
counts%(ax%, ay%) = counts%(ax%, ay%) + 1
oldix% = ax%
oldiy% = ay%
END IF
END SELECT
END SELECT
NEXT
ELSE
ax% = (x%) \ NxDivSize%
ay% = (y%) \ NyDivSize%
PolysInRegion%(ax%, ay%, counts%(ax%, ay%)) = PolyNumber%
counts%(ax%, ay%) = counts%(ax%, ay%) + 1
END IF
END SUB
SUB CalcVelocities (b() AS Polygons, i&, j&, flags%)
IF flags% AND 1 THEN
temp1 = b(i&).speedx
temp2 = b(j&).speedx
totalMass = (b(i&).mass + b(j&).mass)
b(i&).speedx = (temp1 * (b(i&).mass - b(j&).mass) + (2 * b(j&).mass * temp2)) / totalMass
b(j&).speedx = (temp2 * (b(j&).mass - b(i&).mass) + (2 * b(i&).mass * temp1)) / totalMass
ELSE
EXIT SUB
END IF
IF flags% AND 2 THEN
temp1 = b(i&).speedy
temp2 = b(j&).speedy
b(i&).speedy = (temp1 * (b(i&).mass - b(j&).mass) + (2 * b(j&).mass * temp2)) / totalMass
b(j&).speedy = (temp2 * (b(j&).mass - b(i&).mass) + (2 * b(i&).mass * temp1)) / totalMass
ELSE
EXIT SUB
END IF
IF flags% AND 4 THEN
temp1 = b(i&).speedz
temp2 = b(j&).speedz
b(i&).speedz = (temp1 * (b(i&).mass - b(j&).mass) + (2 * b(j&).mass * temp2)) / totalMass
b(j&).speedz = (temp2 * (b(j&).mass - b(i&).mass) + (2 * b(i&).mass * temp1)) / totalMass
ELSE
EXIT SUB
END IF
END SUB
SUB DrawPoly (T AS Polygons)
IF T.nsides > 0 THEN
IF T.radius > 0 THEN
CircleStepDeg% = (ubst% + 1) / T.nsides
Newx = T.x + T.radius * CosTable!(0)
Newy = T.y + T.radius * SinTable!(0)
angle% = 0
fpx = Newx
fpy = Newy
angle% = CircleStepDeg%
DO
IF angle% > ubst% THEN
LINE (fpx, fpy)-(Newx, Newy), T.COLOR
EXIT DO
ELSE
lastx = Newx
lasty = Newy
Newx = T.x + T.radius * CosTable!(angle%)
Newy = T.y + T.radius * SinTable!(angle%)
LINE (lastx, lasty)-(Newx, Newy), T.COLOR
angle% = angle% + CircleStepDeg%
END IF
LOOP
ELSE
PSET (T.x, T.y), T.COLOR
END IF
ELSE
PSET (T.x, T.y), T.COLOR
END IF
END SUB
SUB analyse
COLOR 2: LOCATE 1, 1: PRINT text$
DIM px AS INTEGER, py AS INTEGER, cnt AS INTEGER, ltrcnt AS INTEGER
px = 1: py = 1
DO
word(px, py) = POINT(px, py)
PSET (px, py), 1
px = px + 1
IF px = LEN(text$) * 8 THEN
px = 1
py = py + 1
END IF
LOOP UNTIL py = 16
END SUB
'CgShuffleAlgorithm
'* for highly repetitive arrays and not so repetitive ones
'* this is a SLIGHT modification of Knuth Shuffle
OPTION _EXPLICIT
DIM CgMainDemoLow AS _INTEGER64: CgMainDemoLow = 0
DIM CgMainDemoHigh AS _INTEGER64: CgMainDemoHigh = CgMainDemoLow + 1048575
'* rounds defines the number of attempts to find a non-matching array element
DIM rounds AS INTEGER: rounds = 4
'* minimum array element value
DIM CgMainDemoCSTAMin AS DOUBLE: CgMainDemoCSTAMin = 0
'* maximum array element
DIM CgMainDemoCSTAMax AS DOUBLE: CgMainDemoCSTAMax = 1
REDIM CgShuffleTestAray(CgMainDemoLow TO CgMainDemoHigh) AS DOUBLE
'* lagre enough to handle array index values beyond most practical applications because you never konow.
DIM v AS _INTEGER64
'* generate
FOR v = CgMainDemoLow TO CgMainDemoHigh
CgShuffleTestAray(v) = CgMainDemoCSTAMin + INT(RND * (CgMainDemoCSTAMax - CgMainDemoCSTAMin + 1 / 2))
NEXT
'* display results
FOR v = CgMainDemoLow TO CgMainDemoHigh
PRINT CgShuffleTestAray(v);
NEXT
CgShuffle CgShuffleTestAray(), CgMainDemoLow, CgMainDemoHigh, rounds
SUB CgShuffle (a() AS DOUBLE, start AS _INTEGER64, finish AS _INTEGER64, rounds AS INTEGER)
DIM cgsp AS _INTEGER64: cgsp = start
DIM cgsq AS _INTEGER64: cgsq = finish
DIM cgsr AS _INTEGER64: cgsr = cgsq - cgsp
DIM cgss AS _UNSIGNED _INTEGER64
DIM cgsh AS _INTEGER64
DO WHILE cgsr > 0
cgss = rounds
DO
cgsh = cgsp + INT(RND * cgsr) + 1
IF a(cgsp) <> a(cgsh) THEN
SWAP a(cgsp), a(cgsh)
EXIT DO
END IF
cgss = cgss - 1
LOOP UNTIL cgss < 1
cgsr = cgsr - 1
cgsp = cgsq - cgsr
LOOP
END SUB