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.


Messages - The Librarian

Pages: 1 [2] 3
16
Games / WideScreen Asteroids by TerryRitchie
« on: February 29, 2020, 10:48:03 pm »
WideScreen Asteroids

Author: @TerryRitchie
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=2157.0
Version: 2020
Tags: [2d], [game], [asteroids]

Description:
' This is NOT a clone of the original Asteroids coin-op game.
'
' Differences:  - Widescreen format

'               - Hyperspace opens a black hole to create a worm
'                 hole. All asteroids on the screen are pulled
'                 toward the vortex by gravity. Using hyperspace
'                 is very dangerous because it speeds up
'                 asteroids and draws them toward the player
'                 upon re-entry. Once hyperspace is used it can't
'                 be used again for 10 seconds.

'               - Particle effects when objects are hit. The player
'                 ship, UFOs, and small asteroids also disintegrate
'                 into individual pieces upon collision.

'               - The ship emits an exhaust trail behind it when
'                 thrusting.

'               - The game starts out with 5 large asteroids and
'                 maxes out at 16 large asteroids.

'               - Only the small UFO will appear if the game
'                 believes the player is saucer hunting. It will
'                 attempt to clear the remaining asteroids to force
'                 player to the next wave.

'               - Small UFOs get more accurate and shoot more
'                 often as waves progress.

'               - Advancing to the next wave is done through a
'                 warping sequence.

'               - A background star field moves in synch with the
'                 player's ship. As waves progress the star field
'                 begins to advance forward as well. This gives
'                 the illusion of asteroids moving faster than they
'                 really are.


' Features:     - A menu with player selectable options.

'               - All keyboard key inputs can be defined.

'               - Pixel perfect collision detection. You can
'                 literally roll the ship around asteroids.

'               - Mute and pause keys.

'               - Background ambient sci-fi sound.

'               - Player selectable full screen or windowed mode.

Source Code:
See download(s) below.

asteroids.png

17
Utilities / SafeLoadFont (preserve cursor position) by SMcNeill
« on: August 27, 2019, 09:57:41 pm »
SafeLoadFont (preserve cursor position)

Contributor(s): @SMcNeill
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1597.msg108787#msg108787
Tags: [font]

Description:
Safely loads a font without destroying our current print location and making it revert to the top left corner.

Source Code:
Code: QB64: [Select]
  1. DIM fonts(3) AS LONG
  2. SCREEN _NEWIMAGE(640, 480, 32)
  3.  
  4. font(0) = _LOADFONT("cour.ttf", 16, "monospace")
  5. font(1) = _LOADFONT("courbd.ttf", 16, "monospace")
  6. font(2) = _LOADFONT("courbi.ttf", 16, "monospace")
  7. font(3) = _LOADFONT("couri.ttf", 16, "monospace")
  8.  
  11. PRINT "First, I want to showcase the exisinging issue with the _FONT command."
  12. PRINT "Let's start out typing something, and then pause before loading a"
  13. PRINT "new font..."
  14.  
  16. _FONT font(0)
  17. COLOR &HFFF00000, &HFFFFFF00
  18. slowprint "NOW WHERE IS OUR PRINT CURSOR AT??"
  20. CLS , 0
  21. COLOR -1, 0
  22.  
  23. PRINT "Now, let's try this same type of thing, while using SafeLoadFont"
  24. PRINT "We'll start typing something, and then pause before safe loading"
  25. PRINT "a new font..."
  26.  
  28.  
  29. slowprint "Slowly watch what happens to our print cursor "
  30. SafeLoadFont font(1)
  31. slowprint "as we use SafeLoadFont to change "
  32. SafeLoadFont font(2)
  33. slowprint "fonts while happily printing to "
  34. SafeLoadFont 16
  35. slowprint "the screen, without a concern in the world! "
  38. PRINT "Now, isn't that something?!"
  39.  
  40.  
  41. SUB slowprint (text$)
  42.     FOR i = 1 TO LEN(text$)
  43.         PRINT MID$(text$, i, 1);
  44.         _LIMIT 5
  45.     NEXT
  47.  
  48. SUB SafeLoadFont (font#)
  49.     'Safely loads a font without destroying our current print location and making it revert to the top left corner.
  50.  
  51.     down = CSRLIN: right = POS(0)
  52.     down = (down - 1) * _FONTHEIGHT
  53.     IF _FONTWIDTH <> 0 THEN 'we start with a monospace font
  54.         right = (right - 1) * _PRINTWIDTH(" ") 'convert the monospace LOC to a graphic X coordinate
  55.     END IF
  56.     _FONT font#
  57.     IF _FONTWIDTH <> 0 THEN 'we swapped to a monospace font
  58.         right = (right / _PRINTWIDTH(" ")) + 1 'convert the graphic X coordinate back to a monospace LOC column
  59.     END IF
  60.     down = (down / _FONTHEIGHT) + 1
  61.     IF right < 1 THEN right = 1
  62.     LOCATE down, right
  64.  

screenshot.PNG

18
Utilities / SaveImage (take screenshots) by SMcNeill
« on: August 24, 2019, 05:38:01 pm »
SaveImage

Contributor(s): @SMcNeill
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=2701.0
Tags: [bmp] [export] [gif] [graphics] [jpg] [png] [zlib]

Description:
How to save a QB64 screen image in either BMP or PNG format; how one can easily turn a text screen into a 256 color graphic screen with one simple command; and how to compress and inflate strings or programs quickly and easily.
There's a lot of stuff packaged inside the library here, but the main ones which a user might decide to call is the following:
FUNCTION SaveImage (file$, image&, x1%, y1%, x2%, y2%) 
SUB SaveFullImage (filename$)
SUB SaveFullBMP (filename$)
SUB SaveFullJPG (filename$)
SUB SaveBMP (filename$, image&, x1%, y1%, x2%, y2%)
FUNCTION TextScreenToImage256& (image&)
FUNCTION TextScreenToImage32& (image&)
FUNCTION Deflate$ (text$) 
FUNCTION Inflate$ (text$)
FUNCTION PNGExport (file$, imagehandle%, x1%, y1%, x2%, y2%) 
SUB SaveJPG (file$, image&, startx, starty, finishx, finishy)

As you can see, most of these routines can easily be handled by simply using FUNCTION SaveImage, which then decides if it needs to convert from a text screen to a graphic screen, and which save routine to make use of.

Source Code:
Code: QB64: [Select]
  1. '$INCLUDE:'SaveImage.BI'
  2.  
  3. CONST SaveTextAs256Color = 0 'Flag to Save as 256 color file or 32-bit color file, when converting SCREEN 0 to an image
  4. '                             Set to TRUE (any non-zero value) to save text screens in 256 color mode.
  5. '                             Set to FALSE (zero) to save text screens in 32-bit color mode.
  6.  
  7.  
  8. 'CONST ConvertToStandard256Palette = 0
  9. '                             Set the value to 0 (FALSE) to preseve the color information perfectly, using its default palette.
  10. '                             If the CONST is set (TRUE), then we convert our colors to as close of a match as possible, while
  11. '                             preserving the standard QB64 256-color palette.
  12. '                             Commented here, simply to help folks know that it exists for use when converting a 32 bit image
  13. '                             down to 256 colors, such as what the GIF routine has to do for us (GIFs are limited to 256 color images)
  14.  
  15. SCREEN _NEWIMAGE(1280, 720, 32)
  16. DIM exportimage(4) AS STRING
  17. InitialImage$ = "Volcano Logo.jpg"
  18. exportimage(1) = "testimage.png": exportimage(2) = "testimage.bmp"
  19. exportimage(3) = "testimage.jpg": exportimage(4) = "testimage.gif"
  20.  
  21. 'If you want to test the demo with a screen 0 image, then...
  22. l& = _LOADIMAGE(InitialImage$) 'Remark out this line
  23. '_PUTIMAGE , l& 'And remark the _PUTIMAGE line down below as well
  24.  
  25. 'And unremark the following
  26. 'SCREEN 0
  27. 'FOR i = 0 TO 15
  28. '    COLOR i
  29. '    PRINT "COLOR i"
  30. 'NEXT
  31. 'Then you can watch as we prove that we can save images while in Screen 0 TEXT mode.
  32. FOR i = 1 TO 4
  33.     _PUTIMAGE , l& 'Remark out this line, if you want to see the SCREEN 0 demo
  34.     LOCATE 1, 1
  35.     Result = SaveImage(exportimage(i), 0, 0, 0, _WIDTH - 1, _HEIGHT - 1)
  36.     IF Result = 1 THEN 'file already found on drive
  37.         KILL exportimage(i) 'delete the old file
  38.         Result = SaveImage(exportimage(i), 0, 0, 0, _WIDTH - 1, _HEIGHT - 1) 'save the new one again
  39.     END IF
  40.     PRINT Result
  41.     IF Result < 0 THEN PRINT "Successful " + exportimage(i) + " export" ELSE PRINT ext$ + " Export failed with Error Code:"; Result: ' END
  42.     SLEEP
  44.  
  45. FOR i = 1 TO 4
  46.     zz& = _LOADIMAGE(exportimage(i), 32)
  47.     IF zz& <> -1 THEN
  48.         SCREEN zz&
  49.         PRINT "Image Handle: "; zz&, exportimage(i)
  50.         PRINT "Successful Import using _LOADIMAGE"
  51.     ELSE
  52.         PRINT "ERROR - Not Loading the new image (" + exportimage(i) + ") with _LOADIMAGE."
  53.     END IF
  54.     SLEEP
  56.  
  59.  
  60. '$INCLUDE:'SaveImage.BM'
  61.  

Volcano Logo.jpg

Check out the latest update at the author's Project File in the URL above.
 
 

19
Utilities / ImageToData (and back) by SMcNeill
« on: August 18, 2019, 12:38:36 am »
ImageToData (and back)

Contributor(s): @SMcNeill
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1553.0
Tags: [data] [graphics] [mem]

Description:
The MemImageToData is a specialized version of MemToHex which takes a _MEMIMAGE and converts it to Hex, while placing the DATA statement in front of it for us, for quick use pasting it into another program.  It basically lets us store image files inside a BAS file, without needing to _LOADIMAGE them externally.

Source Code:
Code: QB64: [Select]
  1. ' Set graphics mode.
  2. SCREEN _NEWIMAGE(640, 480, 32)
  3.  
  4. ' Prepare mem block(s) and image(s).
  6. t = _NEWIMAGE(16, 16, 32)
  7. m = _MEMIMAGE(t)
  8.  
  9. ' Send colored pixels to the destination "t".
  11. CIRCLE (8, 8), 7, -1
  12. PAINT (8, 8), -1
  13.  
  14. ' --> So far, nothing has appeared on the screen! <--
  15.  
  16. ' Copy the contents of "t" to the clipboard and display the result.
  17. _CLIPBOARD$ = MemImagetoDATA$(m, "t", 160)
  18.  
  20.  
  21. COLOR _RGB(255, 255, 255)
  22. PRINT "Hex representation of a small filled circle:": PRINT
  23. COLOR _RGB(155, 155, 155)
  25. PRINT "... etc. etc. ..."
  28. COLOR _RGB(255, 255, 255)
  29. PRINT "This information is already contained in the DATA statements in this program."
  30. PRINT "Press any key to convert this data back to an image."
  31.  
  33.  
  34. ' Restore using the proper label associated with the data.
  35. RESTORE TheDataLabel
  36.  
  37. ' Create and display a new image using the data.
  38. t1 = DATAtoImage
  39. _PUTIMAGE (320, 400), t1
  40.  
  42.  
  43. TheDataLabel:
  44. DATA 16,16,4
  45. DATA 00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000000000000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
  46. DATA FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000
  47. DATA 0000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
  48. DATA FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
  49. DATA 00000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
  50. DATA FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000000000000000
  51. DATA 000000000000000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000000000000000000000000000000000000
  52.  
  53. FUNCTION DATAtoImage&
  54.     'Requires a RESTORE label for the proper data BEFORE calling this routine
  55.     READ w, h, ps
  56.     SELECT CASE ps
  57.         CASE 1: ps = 256 '256 color screen
  58.         CASE 2: ps = 0 'text screen
  59.         CASE 4: ps = 32 '32-bit color screen
  60.     END SELECT
  61.     DATAtoImage& = _NEWIMAGE(w, h, ps)
  62.     DIM m AS _MEM
  63.     m = _MEMIMAGE(DATAtoImage&)
  65.     DO
  66.         READ hx$
  67.         FOR i = 1 TO LEN(hx$) STEP 2
  68.             h = VAL("&H" + MID$(hx$, i, 2))
  69.             _MEMPUT m, m.OFFSET + o, h
  70.             o = o + 1
  71.         NEXT
  72.         LOCATE 1, 1: PRINT o, m.SIZE
  73.     LOOP UNTIL o >= m.SIZE
  74.     _MEMFREE m
  76.  
  77. FUNCTION MemImagetoDATA$ (m AS _MEM, label$, break)
  79.     s = ConvertOffset(m.SIZE) - 1
  80.     label$ = _TRIM$(label$)
  81.     IF label$ = "" THEN label$ = "generic_label_placeholder:"
  82.     IF RIGHT$(label$, 1) <> ":" THEN label$ = label$ + ":"
  83.     MemImagetoDATA$ = label$ + CHR$(10) + "DATA "
  84.     MemImagetoDATA$ = MemImagetoDATA$ + STR$(_WIDTH(m.IMAGE)) + ", "
  85.     MemImagetoDATA$ = MemImagetoDATA$ + STR$(_HEIGHT(m.IMAGE)) + ", "
  86.     MemImagetoDATA$ = MemImagetoDATA$ + STR$(_PIXELSIZE(m.IMAGE)) + CHR$(10) + "DATA "
  87.     FOR i = 0 TO s
  88.         _MEMGET m, m.OFFSET + i, b
  89.         h$ = HEX$(b)
  90.         IF LEN(h$) = 1 THEN h$ = "0" + h$
  91.         MemImagetoDATA$ = MemImagetoDATA$ + h$
  92.         IF i MOD break = break - 1 AND i < s THEN
  93.             MemImagetoDATA$ = MemImagetoDATA$ + CHR$(10) + "DATA "
  94.         END IF
  95.     NEXT
  97.  
  98. FUNCTION ConvertOffset&& (value AS _OFFSET)
  99.     DIM m AS _MEM 'Define a memblock
  100.     m = _MEM(value) 'Point it to use value
  101.     $IF 64BIT THEN
  102.         'On 64 bit OSes, an OFFSET is 8 bytes in size.  We can put it directly into an Integer64
  103.         _MEMGET m, m.OFFSET, ConvertOffset&& 'Get the contents of the memblock and put the values there directly into ConvertOffset&&
  104.     $ELSE
  105.         'However, on 32 bit OSes, an OFFSET is only 4 bytes.  We need to put it into a LONG variable first
  106.         _MEMGET m, m.OFFSET, temp& 'Like this
  107.         ConvertOffset&& = temp& 'And then assign that long value to ConvertOffset&&
  108.     $END IF
  109.     _MEMFREE m 'Free the memblock
  111.  

screenshot.png


20
Utilities / MemToHex (and HexToMem) by SMcNeill
« on: August 17, 2019, 11:50:23 pm »
MemToHex (and HexToMem)

Contributor(s): @SMcNeill
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1553.0
Tags: [hex] [mem]

Description:
With these, we can convert ANY memblock into a sequence of HEX values (which makes them excellent to paste into another program as DATA statements), and then we can take those hex values and convert them back into a memblock.

Source Code:
Code: QB64: [Select]
  1. ' The string to be processed should have known length.
  2. ' or:
  3. ' Change 12 to a higher number and the HEX representation stores the trailing whitespace.
  4. ' Trailing whitespace in an ordinary string can be truncated using RTRIM$().
  5. DIM TheString AS STRING * 12
  6. TheString = "Hello World!"
  7.  
  8. ' Prepare MEM block.
  9. DIM m AS _MEM: m = _MEM(TheString)
  10.  
  11. ' Convert string to HEX and print.
  12. Hx$ = MemToHex(m)
  13. PRINT Hx$
  14.  
  15. ' Overwrite string.
  16. TheString = "Overwritten?"
  17. PRINT TheString
  18.  
  19. ' Restore string from MEM and print the result.
  20. HexToMem Hx$, m
  21. PRINT TheString; "..."
  22. 'PRINT RTRIM$(TheString); "..."
  23.  
  24. ' Free the memblock (redundant at END but good practice).
  27.  
  28. FUNCTION MemToHex$ (m AS _MEM)
  30.     s = ConvertOffset(m.SIZE) - 1
  31.     FOR i = 0 TO s
  32.         _MEMGET m, m.OFFSET + i, b
  33.         h$ = HEX$(b)
  34.         IF LEN(h$) = 1 THEN h$ = "0" + h$
  35.         MemToHex$ = MemToHex$ + h$
  36.     NEXT
  38.  
  39. SUB HexToMem (hx$, m AS _MEM)
  40.     DIM i AS _INTEGER64
  42.     FOR i = 1 TO LEN(hx$) STEP 2
  43.         h = VAL("&H" + MID$(hx$, i, 2))
  44.         _MEMPUT m, m.OFFSET + i \ 2, h
  45.     NEXT
  47.  
  48. FUNCTION ConvertOffset&& (value AS _OFFSET)
  49.     DIM m AS _MEM 'Define a memblock
  50.     m = _MEM(value) 'Point it to use value
  51.     $IF 64BIT THEN
  52.         ' On 64 bit OSes, an OFFSET is 8 bytes in size. We can put it directly into an Integer64.
  53.         _MEMGET m, m.OFFSET, ConvertOffset&& ' Get the contents of the memblock and put the values there directly into ConvertOffset&&.
  54.     $ELSE
  55.         'However, on 32 bit OSes, an OFFSET is only 4 bytes. We need to put it into a LONG variable first.
  56.         _MEMGET m, m.OFFSET, temp& ' Like this:
  57.         ConvertOffset&& = temp& ' And then assign that long value to ConvertOffset&&.
  58.     $END IF
  59.     _MEMFREE m ' Free the memblock.
  61.  

screenshot.png

21
2D/3D Graphics / Sanctum 3D World by STxAxTIC
« on: August 13, 2019, 09:53:46 pm »
Sanctum 3D World

Author: STxAxTIC
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1600.0
Version: QB64
Tags: [3d] [graphics] [open world]

Description:
Sanctum is an open world 3D engine that makes everything from CIRCLE and LINE. Suggested left hand on "WSAD", and right hand on numeric keypad (hybrid gamer setup)... Discover heaven, discover hell, find the pyramid, find the megalith, blow up the moon, play with blocks.

Source Code:
Code: QB64: [Select]
  1. '$EXEICON:'sanctum.ico'
  2. 'REM $include:'Color32.BI'
  3.  
  4. CONST Aquamarine = _RGB32(127, 255, 212)
  5. CONST Blue = _RGB32(0, 0, 255)
  6. CONST BlueViolet = _RGB32(138, 43, 226)
  7. CONST Chocolate = _RGB32(210, 105, 30)
  8. CONST Cyan = _RGB32(0, 255, 255)
  9. CONST DarkBlue = _RGB32(0, 0, 139)
  10. CONST DarkGoldenRod = _RGB32(184, 134, 11)
  11. CONST DarkGray = _RGB32(169, 169, 169)
  12. CONST DarkKhaki = _RGB32(189, 183, 107)
  13. CONST DeepPink = _RGB32(255, 20, 147)
  14. CONST DodgerBlue = _RGB32(30, 144, 255)
  15. CONST ForestGreen = _RGB32(34, 139, 34)
  16. CONST Gray = _RGB32(128, 128, 128)
  17. CONST Green = _RGB32(0, 128, 0)
  18. CONST Indigo = _RGB32(75, 0, 130)
  19. CONST Ivory = _RGB32(255, 255, 240)
  20. CONST LightSeaGreen = _RGB32(32, 178, 170)
  21. CONST Lime = _RGB32(0, 255, 0)
  22. CONST LimeGreen = _RGB32(50, 205, 50)
  23. CONST Magenta = _RGB32(255, 0, 255)
  24. CONST PaleGoldenRod = _RGB32(238, 232, 170)
  25. CONST Purple = _RGB32(128, 0, 128)
  26. CONST Red = _RGB32(255, 0, 0)
  27. CONST RoyalBlue = _RGB32(65, 105, 225)
  28. CONST SaddleBrown = _RGB32(139, 69, 19)
  29. CONST Sienna = _RGB32(160, 82, 45)
  30. CONST SlateGray = _RGB32(112, 128, 144)
  31. CONST Snow = _RGB32(255, 250, 250)
  32. CONST Sunglow = _RGB32(255, 207, 72)
  33. CONST SunsetOrange = _RGB32(253, 94, 83)
  34. CONST Teal = _RGB32(0, 128, 128)
  35. CONST White = _RGB32(255, 255, 255)
  36. CONST Yellow = _RGB32(255, 255, 0)
  37.  
  38. ' Constants.
  39. pi = 3.1415926536
  40. ee = 2.7182818285
  41.  
  42. ' Scale.
  43. DIM bignumber AS LONG
  44. bignumber = 3000000
  45.  
  46. ' Video.
  47. 'SCREEN _NEWIMAGE(640, 480, 32)
  48. SCREEN _NEWIMAGE(800, 600, 32)
  49. 'SCREEN _NEWIMAGE(1024, 768, 32)
  52. screenwidth = _WIDTH
  53. screenheight = _HEIGHT
  54.  
  55. ' Camera orientation vectors.
  56. DIM uhat(3), vhat(3), nhat(3)
  57.  
  58. ' Basis vectors defined in three-space.
  59. DIM xhat(3), yhat(3), zhat(3)
  60. xhat(1) = 1: xhat(2) = 0: xhat(3) = 0
  61. yhat(1) = 0: yhat(2) = 1: yhat(3) = 0
  62. zhat(1) = 0: zhat(2) = 0: zhat(3) = 1
  63.  
  64. ' Group structure.
  65. TYPE VectorGroupElement
  66.     Identity AS LONG
  67.     Pointer AS LONG
  68.     Lagger AS LONG
  69.     FirstVector AS LONG
  70.     LastVector AS LONG
  71.     GroupName AS STRING * 50
  72.     Visible AS INTEGER
  73.     ForceAnimate AS INTEGER
  74.     COMFixed AS INTEGER
  75.     COMx AS SINGLE ' Center of mass
  76.     COMy AS SINGLE
  77.     COMz AS SINGLE
  78.     ROTx AS SINGLE ' Center of rotation
  79.     ROTy AS SINGLE
  80.     ROTz AS SINGLE
  81.     REVx AS SINGLE ' Revolution speed
  82.     REVy AS SINGLE
  83.     REVz AS SINGLE
  84.     DIMx AS SINGLE ' Maximum volume
  85.     DIMy AS SINGLE
  86.     DIMz AS SINGLE
  88. DIM VectorGroup(bignumber) AS VectorGroupElement
  89.  
  90. ' World vectors.
  91. DIM vec(bignumber, 3) ' Relative Position
  92. DIM vec3Dpos(bignumber, 3) ' Position
  93. DIM vec3Dvel(bignumber, 3) ' Linear velocity
  94. DIM vec3Dacc(bignumber, 3) ' Linear acceleration
  95. DIM vec3Danv(bignumber, 3) ' Angular velocity
  96. DIM vec3Dvis(bignumber) ' Visible toggle
  97. DIM vec2D(bignumber, 2) ' Projection onto 2D plane
  98. DIM vec3Dcolor(bignumber) AS LONG ' Original color
  99. DIM vec2Dcolor(bignumber) AS LONG ' Projected color
  100.  
  101. ' Clipping planes.
  102. DIM nearplane(4), farplane(4), rightplane(4), leftplane(4), topplane(4), bottomplane(4)
  103.  
  104. ' State.
  106. nearplane(4) = 1
  107. farplane(4) = -100
  108. rightplane(4) = 0 '*' fovd * (nhat(1) * rightplane(1) + nhat(2) * rightplane(2) + nhat(3) * rightplane(3))
  109. leftplane(4) = 0
  110. topplane(4) = 0
  111. bottomplane(4) = 0
  112. midscreenx = screenwidth / 2
  113. midscreeny = screenheight / 2
  114. fovd = -256
  115. numgroupvisible = 0
  116. numvectorvisible = 0
  117. groupidticker = 0
  118. vecgroupid = 0
  119. vectorindex = 0
  120. rotspeed = 1 / 33
  121. linspeed = 3 / 2
  122. timestep = .001
  123. camx = -40
  124. camy = 30
  125. camz = 40
  126. uhat(1) = -.2078192: uhat(2) = -.9781672: uhat(3) = 0
  127. vhat(1) = 0: vhat(2) = 0: vhat(3) = 1
  128. toggletimeanimate = 1
  129. toggleinvertmouse = -1
  130. togglehud = 1
  131.  
  132. ' Prime main loop.
  133. GOSUB initialize.objects
  134. GOSUB redraw
  135.  
  136. ' Begin main loop.
  137. fpstimer = INT(TIMER)
  138. fps = 0
  140.     GOSUB redraw
  141.     GOSUB mouseprocess
  142.     GOSUB keyprocess
  143.  
  144.     fps = fps + 1
  145.     tt = INT(TIMER)
  146.     IF tt = fpstimer + 1 THEN
  147.         fpstimer = tt
  148.         fpsreport = fps
  149.         fps = 0
  150.     END IF
  151.  
  152.     _DISPLAY
  153.     _KEYCLEAR
  154.     _LIMIT 30
  156.  
  158.  
  159. ' Gosubs.
  160.  
  161. redraw:
  162. GOSUB normalize.screen.vectors
  163. GOSUB calculate.clippingplanes
  164. GOSUB compute.visible.groups
  165. GOSUB plot.visible.vectors
  167.  
  168. mouseprocess:
  169. 'mx = 0
  170. 'my = 0
  171. 'DO WHILE _MOUSEINPUT
  172. '    mx = mx + _MOUSEMOVEMENTX
  173. '    my = my + _MOUSEMOVEMENTY
  174. '    IF _MOUSEWHEEL > 0 THEN GOSUB rotate.clockwise
  175. '    IF _MOUSEWHEEL < 0 THEN GOSUB rotate.counterclockwise
  176. '    IF mx > 0 THEN
  177. '        GOSUB rotate.uhat.plus: GOSUB normalize.screen.vectors
  178. '    END IF
  179. '    IF mx < 0 THEN
  180. '        GOSUB rotate.uhat.minus: GOSUB normalize.screen.vectors
  181. '    END IF
  182. '    IF my > 0 THEN
  183. '        IF toggleinvertmouse = -1 THEN
  184. '            GOSUB rotate.vhat.plus: GOSUB normalize.screen.vectors
  185. '        ELSE
  186. '            GOSUB rotate.vhat.minus: GOSUB normalize.screen.vectors
  187. '        END IF
  188. '    END IF
  189. '    IF my < 0 THEN
  190. '        IF toggleinvertmouse = -1 THEN
  191. '            GOSUB rotate.vhat.minus: GOSUB normalize.screen.vectors
  192. '        ELSE
  193. '            GOSUB rotate.vhat.plus: GOSUB normalize.screen.vectors
  194. '        END IF
  195. '    END IF
  196. '    mx = 0
  197. '    my = 0
  198. 'LOOP
  200.  
  201. keyprocess:
  202. IF _KEYDOWN(119) = -1 OR _KEYDOWN(18432) = -1 THEN GOSUB strafe.camera.nhat.minus ' w or uparrow
  203. IF _KEYDOWN(115) = -1 OR _KEYDOWN(20480) = -1 THEN GOSUB strafe.camera.nhat.plus ' s or downarrow
  204. IF _KEYDOWN(97) = -1 THEN GOSUB strafe.camera.uhat.minus ' a
  205. IF _KEYDOWN(100) = -1 THEN GOSUB strafe.camera.uhat.plus ' d
  206. IF _KEYDOWN(56) = -1 THEN GOSUB rotate.vhat.plus: GOSUB normalize.screen.vectors ' 8
  207. IF _KEYDOWN(50) = -1 THEN GOSUB rotate.vhat.minus: GOSUB normalize.screen.vectors ' 2
  208. IF _KEYDOWN(19200) = -1 OR _KEYDOWN(52) = -1 THEN GOSUB rotate.uhat.minus: GOSUB normalize.screen.vectors ' 4
  209. IF _KEYDOWN(19712) = -1 OR _KEYDOWN(54) = -1 THEN GOSUB rotate.uhat.plus: GOSUB normalize.screen.vectors ' 6
  210. IF _KEYDOWN(55) = -1 THEN GOSUB rotate.clockwise ' 7
  211. IF _KEYDOWN(57) = -1 THEN GOSUB rotate.counterclockwise ' 9
  212. IF _KEYDOWN(49) = -1 THEN GOSUB rotate.uhat.minus: GOSUB normalize.screen.vectors: GOSUB rotate.clockwise ' 1
  213. IF _KEYDOWN(51) = -1 THEN GOSUB rotate.uhat.plus: GOSUB normalize.screen.vectors: GOSUB rotate.counterclockwise ' 3
  214. IF _KEYDOWN(113) = -1 THEN GOSUB strafe.camera.vhat.minus ' q
  215. IF _KEYDOWN(101) = -1 THEN GOSUB strafe.camera.vhat.plus ' e
  216.  
  218. IF (key$ <> "") THEN
  219.     SELECT CASE key$
  220.         CASE "x"
  221.             uhat(1) = 0: uhat(2) = 1: uhat(3) = 0
  222.             vhat(1) = 0: vhat(2) = 0: vhat(3) = 1
  223.         CASE "X"
  224.             uhat(1) = 0: uhat(2) = -1: uhat(3) = 0
  225.             vhat(1) = 0: vhat(2) = 0: vhat(3) = 1
  226.         CASE "y"
  227.             uhat(1) = -1: uhat(2) = 0: uhat(3) = 0
  228.             vhat(1) = 0: vhat(2) = 0: vhat(3) = 1
  229.         CASE "Y"
  230.             uhat(1) = 1: uhat(2) = 0: uhat(3) = 0
  231.             vhat(1) = 0: vhat(2) = 0: vhat(3) = 1
  232.         CASE "z"
  233.             uhat(1) = 1: uhat(2) = 0: uhat(3) = 0
  234.             vhat(1) = 0: vhat(2) = 1: vhat(3) = 0
  235.             GOSUB normalize.screen.vectors
  236.         CASE "Z"
  237.             uhat(1) = 0: uhat(2) = 1: uhat(3) = 0
  238.             vhat(1) = 1: vhat(2) = 0: vhat(3) = 0
  239.         CASE "]"
  240.             farplane(4) = farplane(4) - 1
  241.         CASE "["
  242.             farplane(4) = farplane(4) + 1
  243.         CASE " "
  244.             togglehud = -togglehud
  245.         CASE "t"
  246.             toggletimeanimate = -toggletimeanimate
  247.         CASE "i"
  248.             toggleinvertmouse = -toggleinvertmouse
  249.         CASE "v"
  250.             OPEN "snapshot-camera.txt" FOR OUTPUT AS #1
  251.             PRINT #1, camx, camy, camz
  252.             PRINT #1, uhat(1), uhat(2), uhat(3)
  253.             PRINT #1, vhat(1), vhat(2), vhat(3)
  254.             CLOSE #1
  255.         CASE CHR$(27)
  256.             SYSTEM
  257.         CASE "n"
  258.             VectorGroup(closestgroup).COMFixed = 1
  259.             FOR vectorindex = VectorGroup(closestgroup).FirstVector TO VectorGroup(closestgroup).LastVector
  260.                 vec3Dvel(vectorindex, 1) = (RND - .5) * 200
  261.                 vec3Dvel(vectorindex, 2) = (RND - .5) * 200
  262.                 vec3Dvel(vectorindex, 3) = (RND - .5) * 200
  263.             NEXT
  264.         CASE "k"
  265.             p = VectorGroup(closestgroup).Pointer
  266.             l = VectorGroup(closestgroup).Lagger
  267.             VectorGroup(l).Pointer = p
  268.             IF (p <> -999) THEN
  269.                 VectorGroup(p).Lagger = l
  270.             END IF
  271.         CASE "b"
  272.             tilesize = 5
  273.             ' Determine last object id.
  274.             p = 1
  275.             DO
  276.                 k = VectorGroup(p).Identity
  277.                 p = VectorGroup(k).Pointer
  278.                 IF (p = -999) THEN EXIT DO
  279.             LOOP
  280.             lastobjectid = k
  281.             vectorindex = VectorGroup(lastobjectid).LastVector
  282.             ' Create new group.
  283.             groupidticker = groupidticker + 1
  284.             vecgroupid = groupidticker
  285.             VectorGroup(vecgroupid).Identity = vecgroupid
  286.             VectorGroup(vecgroupid).Pointer = -999
  287.             VectorGroup(vecgroupid).Lagger = lastobjectid
  288.             VectorGroup(vecgroupid).GroupName = "Block"
  289.             VectorGroup(vecgroupid).Visible = 0
  290.             VectorGroup(vecgroupid).COMFixed = 1
  291.             VectorGroup(vecgroupid).DIMx = tilesize / 2
  292.             VectorGroup(vecgroupid).DIMy = tilesize / 2
  293.             VectorGroup(vecgroupid).DIMz = tilesize / 2
  294.             VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  295.             FOR r = 1 TO 400
  296.                 vectorindex = vectorindex + 1
  297.                 vec3Dpos(vectorindex, 1) = camx + -20 * nhat(1) + (RND - .5) * tilesize
  298.                 vec3Dpos(vectorindex, 2) = camy + -20 * nhat(2) + (RND - .5) * tilesize
  299.                 vec3Dpos(vectorindex, 3) = camz + -20 * nhat(3) + (RND - .5) * tilesize
  300.                 vec3Dvis(vectorindex) = 0
  301.                 IF RND > .5 THEN
  302.                     vec3Dcolor(vectorindex) = Lime
  303.                 ELSE
  304.                     vec3Dcolor(vectorindex) = Purple
  305.                 END IF
  306.                 GOSUB integratecom
  307.             NEXT
  308.             VectorGroup(vecgroupid).LastVector = vectorindex
  309.             GOSUB calculatecom
  310.             VectorGroup(lastobjectid).Pointer = vecgroupid
  311.     END SELECT
  314.  
  315. convert:
  316. ' Convert graphics from uv-cartesian coordinates to monitor coordinates.
  317. x0 = x: y0 = y
  318. x = x0 + midscreenx
  319. y = -y0 + midscreeny
  321.  
  322. rotate.uhat.plus:
  323. uhat(1) = uhat(1) + nhat(1) * rotspeed
  324. uhat(2) = uhat(2) + nhat(2) * rotspeed
  325. uhat(3) = uhat(3) + nhat(3) * rotspeed
  327.  
  328. rotate.uhat.minus:
  329. uhat(1) = uhat(1) - nhat(1) * rotspeed
  330. uhat(2) = uhat(2) - nhat(2) * rotspeed
  331. uhat(3) = uhat(3) - nhat(3) * rotspeed
  333.  
  334. rotate.vhat.plus:
  335. vhat(1) = vhat(1) + nhat(1) * rotspeed
  336. vhat(2) = vhat(2) + nhat(2) * rotspeed
  337. vhat(3) = vhat(3) + nhat(3) * rotspeed
  339.  
  340. rotate.vhat.minus:
  341. vhat(1) = vhat(1) - nhat(1) * rotspeed
  342. vhat(2) = vhat(2) - nhat(2) * rotspeed
  343. vhat(3) = vhat(3) - nhat(3) * rotspeed
  345.  
  346. rotate.counterclockwise:
  347. v1 = vhat(1)
  348. v2 = vhat(2)
  349. v3 = vhat(3)
  350. vhat(1) = vhat(1) + uhat(1) * rotspeed
  351. vhat(2) = vhat(2) + uhat(2) * rotspeed
  352. vhat(3) = vhat(3) + uhat(3) * rotspeed
  353. uhat(1) = uhat(1) - v1 * rotspeed
  354. uhat(2) = uhat(2) - v2 * rotspeed
  355. uhat(3) = uhat(3) - v3 * rotspeed
  357.  
  358. rotate.clockwise:
  359. v1 = vhat(1)
  360. v2 = vhat(2)
  361. v3 = vhat(3)
  362. vhat(1) = vhat(1) - uhat(1) * rotspeed
  363. vhat(2) = vhat(2) - uhat(2) * rotspeed
  364. vhat(3) = vhat(3) - uhat(3) * rotspeed
  365. uhat(1) = uhat(1) + v1 * rotspeed
  366. uhat(2) = uhat(2) + v2 * rotspeed
  367. uhat(3) = uhat(3) + v3 * rotspeed
  369.  
  370. strafe.camera.uhat.plus:
  371. camx = camx + uhat(1) * linspeed
  372. camy = camy + uhat(2) * linspeed
  373. camz = camz + uhat(3) * linspeed
  375.  
  376. strafe.camera.uhat.minus:
  377. camx = camx - uhat(1) * linspeed
  378. camy = camy - uhat(2) * linspeed
  379. camz = camz - uhat(3) * linspeed
  381.  
  382. strafe.camera.vhat.plus:
  383. camx = camx + vhat(1) * linspeed
  384. camy = camy + vhat(2) * linspeed
  385. camz = camz + vhat(3) * linspeed
  387.  
  388. strafe.camera.vhat.minus:
  389. camx = camx - vhat(1) * linspeed
  390. camy = camy - vhat(2) * linspeed
  391. camz = camz - vhat(3) * linspeed
  393.  
  394. strafe.camera.nhat.plus:
  395. camx = camx + nhat(1) * linspeed
  396. camy = camy + nhat(2) * linspeed
  397. camz = camz + nhat(3) * linspeed
  399.  
  400. strafe.camera.nhat.minus:
  401. camx = camx - nhat(1) * linspeed
  402. camy = camy - nhat(2) * linspeed
  403. camz = camz - nhat(3) * linspeed
  405.  
  406. normalize.screen.vectors:
  407. uhatmag = SQR(uhat(1) * uhat(1) + uhat(2) * uhat(2) + uhat(3) * uhat(3))
  408. uhat(1) = uhat(1) / uhatmag: uhat(2) = uhat(2) / uhatmag: uhat(3) = uhat(3) / uhatmag
  409. vhatmag = SQR(vhat(1) * vhat(1) + vhat(2) * vhat(2) + vhat(3) * vhat(3))
  410. vhat(1) = vhat(1) / vhatmag: vhat(2) = vhat(2) / vhatmag: vhat(3) = vhat(3) / vhatmag
  411. uhatdotvhat = uhat(1) * vhat(1) + uhat(2) * vhat(2) + uhat(3) * vhat(3)
  412. ' The normal vector points toward the eye.
  413. nhat(1) = uhat(2) * vhat(3) - uhat(3) * vhat(2)
  414. nhat(2) = uhat(3) * vhat(1) - uhat(1) * vhat(3)
  415. nhat(3) = uhat(1) * vhat(2) - uhat(2) * vhat(1)
  416. nhatmag = SQR(nhat(1) * nhat(1) + nhat(2) * nhat(2) + nhat(3) * nhat(3))
  417. nhat(1) = nhat(1) / nhatmag: nhat(2) = nhat(2) / nhatmag: nhat(3) = nhat(3) / nhatmag
  419.  
  420. calculate.clippingplanes:
  421. ' Calculate normal vectors to all clipping planes.
  422. h2 = screenheight / 2
  423. w2 = screenwidth / 2
  424. nearplane(1) = -nhat(1)
  425. nearplane(2) = -nhat(2)
  426. nearplane(3) = -nhat(3)
  427. farplane(1) = nhat(1)
  428. farplane(2) = nhat(2)
  429. farplane(3) = nhat(3)
  430. rightplane(1) = h2 * fovd * uhat(1) - h2 * w2 * nhat(1)
  431. rightplane(2) = h2 * fovd * uhat(2) - h2 * w2 * nhat(2)
  432. rightplane(3) = h2 * fovd * uhat(3) - h2 * w2 * nhat(3)
  433. mag = SQR(rightplane(1) * rightplane(1) + rightplane(2) * rightplane(2) + rightplane(3) * rightplane(3))
  434. rightplane(1) = rightplane(1) / mag
  435. rightplane(2) = rightplane(2) / mag
  436. rightplane(3) = rightplane(3) / mag
  437. leftplane(1) = -h2 * fovd * uhat(1) - h2 * w2 * nhat(1)
  438. leftplane(2) = -h2 * fovd * uhat(2) - h2 * w2 * nhat(2)
  439. leftplane(3) = -h2 * fovd * uhat(3) - h2 * w2 * nhat(3)
  440. mag = SQR(leftplane(1) * leftplane(1) + leftplane(2) * leftplane(2) + leftplane(3) * leftplane(3))
  441. leftplane(1) = leftplane(1) / mag
  442. leftplane(2) = leftplane(2) / mag
  443. leftplane(3) = leftplane(3) / mag
  444. topplane(1) = w2 * fovd * vhat(1) - h2 * w2 * nhat(1)
  445. topplane(2) = w2 * fovd * vhat(2) - h2 * w2 * nhat(2)
  446. topplane(3) = w2 * fovd * vhat(3) - h2 * w2 * nhat(3)
  447. mag = SQR(topplane(1) * topplane(1) + topplane(2) * topplane(2) + topplane(3) * topplane(3))
  448. topplane(1) = topplane(1) / mag
  449. topplane(2) = topplane(2) / mag
  450. topplane(3) = topplane(3) / mag
  451. bottomplane(1) = -w2 * fovd * vhat(1) - h2 * w2 * nhat(1)
  452. bottomplane(2) = -w2 * fovd * vhat(2) - h2 * w2 * nhat(2)
  453. bottomplane(3) = -w2 * fovd * vhat(3) - h2 * w2 * nhat(3)
  454. mag = SQR(bottomplane(1) * bottomplane(1) + bottomplane(2) * bottomplane(2) + bottomplane(3) * bottomplane(3))
  455. bottomplane(1) = bottomplane(1) / mag
  456. bottomplane(2) = bottomplane(2) / mag
  457. bottomplane(3) = bottomplane(3) / mag
  459.  
  460. compute.visible.groups:
  461. closestdist2 = 10000000
  462. closestgroup = 1
  463. fp42 = farplane(4) * farplane(4)
  464.  
  465. k = 1
  466. k = VectorGroup(k).Identity
  467. DO ' iterates k
  468.  
  469.     VectorGroup(k).Visible = 0
  470.  
  471.     dx = VectorGroup(k).COMx - camx
  472.     dy = VectorGroup(k).COMy - camy
  473.     dz = VectorGroup(k).COMz - camz
  474.  
  475.     dist2 = dx * dx + dy * dy + dz * dz
  476.  
  477.     IF dist2 < fp42 THEN
  478.  
  479.         groupinview = 1
  480.         IF dx * nearplane(1) + dy * nearplane(2) + dz * nearplane(3) - nearplane(4) < 0 THEN groupinview = 0
  481.         'IF dx * farplane(1) + dy * farplane(2) + dz * farplane(3) - farplane(4) < 0 THEN groupinview = 0
  482.         IF dx * rightplane(1) + dy * rightplane(2) + dz * rightplane(3) - rightplane(4) < 0 THEN groupinview = 0
  483.         IF dx * leftplane(1) + dy * leftplane(2) + dz * leftplane(3) - leftplane(4) < 0 THEN groupinview = 0
  484.         IF dx * topplane(1) + dy * topplane(2) + dz * topplane(3) - topplane(4) < 0 THEN groupinview = 0
  485.         IF dx * bottomplane(1) + dy * bottomplane(2) + dz * bottomplane(3) - bottomplane(4) < 0 THEN groupinview = 0
  486.         IF groupinview = 1 THEN
  487.  
  488.             IF (dist2 < closestdist2) THEN
  489.                 closestdist2 = dist2
  490.                 closestgroup = k
  491.             END IF
  492.  
  493.             VectorGroup(k).Visible = 1
  494.  
  495.             IF (toggletimeanimate = 1) THEN
  496.                 vecgroupid = k
  497.                 GOSUB timeanimate
  498.             END IF
  499.  
  500.             FOR i = VectorGroup(k).FirstVector TO VectorGroup(k).LastVector
  501.                 GOSUB clip.project.vectors
  502.             NEXT
  503.  
  504.         ELSE
  505.             ' Force animation regardless of clipping.
  506.             IF (VectorGroup(k).ForceAnimate = 1) THEN
  507.                 vecgroupid = k
  508.                 GOSUB timeanimate
  509.             END IF
  510.         END IF
  511.     ELSE
  512.         ' Force animation regardless of distance from camera.
  513.         IF (VectorGroup(k).ForceAnimate = 1) THEN
  514.             vecgroupid = k
  515.             GOSUB timeanimate
  516.         END IF
  517.     END IF
  518.     k = VectorGroup(k).Pointer
  519.     IF k = -999 THEN EXIT DO
  520.     k = VectorGroup(k).Identity
  523.  
  524. clip.project.vectors: ' requires i
  525. vec(i, 1) = vec3Dpos(i, 1) - camx
  526. vec(i, 2) = vec3Dpos(i, 2) - camy
  527. vec(i, 3) = vec3Dpos(i, 3) - camz
  528. fogswitch = -1
  529. vec3Dvis(i) = 0
  530. vectorinview = 1
  531. ' Perform view plane clipping.
  532. IF vec(i, 1) * nearplane(1) + vec(i, 2) * nearplane(2) + vec(i, 3) * nearplane(3) - nearplane(4) < 0 THEN vectorinview = 0
  533. IF vec(i, 1) * farplane(1) + vec(i, 2) * farplane(2) + vec(i, 3) * farplane(3) - farplane(4) < 0 THEN vectorinview = 0
  534. IF vec(i, 1) * farplane(1) + vec(i, 2) * farplane(2) + vec(i, 3) * farplane(3) - farplane(4) * .85 < 0 THEN fogswitch = 1
  535. IF vec(i, 1) * rightplane(1) + vec(i, 2) * rightplane(2) + vec(i, 3) * rightplane(3) - rightplane(4) < 0 THEN vectorinview = 0
  536. IF vec(i, 1) * leftplane(1) + vec(i, 2) * leftplane(2) + vec(i, 3) * leftplane(3) - leftplane(4) < 0 THEN vectorinview = 0
  537. IF vec(i, 1) * topplane(1) + vec(i, 2) * topplane(2) + vec(i, 3) * topplane(3) - topplane(4) < 0 THEN vectorinview = 0
  538. IF vec(i, 1) * bottomplane(1) + vec(i, 2) * bottomplane(2) + vec(i, 3) * bottomplane(3) - bottomplane(4) < 0 THEN vectorinview = 0
  539. IF vectorinview = 1 THEN
  540.     vec3Dvis(i) = 1
  541.     ' Project vectors onto the screen plane.
  542.     vec3Ddotnhat = vec(i, 1) * nhat(1) + vec(i, 2) * nhat(2) + vec(i, 3) * nhat(3)
  543.     vec2D(i, 1) = (vec(i, 1) * uhat(1) + vec(i, 2) * uhat(2) + vec(i, 3) * uhat(3)) * fovd / vec3Ddotnhat
  544.     vec2D(i, 2) = (vec(i, 1) * vhat(1) + vec(i, 2) * vhat(2) + vec(i, 3) * vhat(3)) * fovd / vec3Ddotnhat
  545.     IF fogswitch = 1 THEN vec2Dcolor(i) = Gray ELSE vec2Dcolor(i) = vec3Dcolor(i)
  548.  
  549. timeanimate: ' requires vecgroupid
  550. dt = timestep
  551.  
  552. xcom = VectorGroup(vecgroupid).COMx
  553. ycom = VectorGroup(vecgroupid).COMy
  554. zcom = VectorGroup(vecgroupid).COMz
  555. xrot = VectorGroup(vecgroupid).ROTx
  556. yrot = VectorGroup(vecgroupid).ROTy
  557. zrot = VectorGroup(vecgroupid).ROTz
  558. xrev = VectorGroup(vecgroupid).ROTx
  559. yrev = VectorGroup(vecgroupid).ROTy
  560. zrev = VectorGroup(vecgroupid).ROTz
  561. xdim = VectorGroup(vecgroupid).DIMx
  562. ydim = VectorGroup(vecgroupid).DIMy
  563. zdim = VectorGroup(vecgroupid).DIMz
  564.  
  565. IF (VectorGroup(vecgroupid).COMFixed = 0) THEN GOSUB resetcom
  566.  
  567. FOR vectorindex = VectorGroup(vecgroupid).FirstVector TO VectorGroup(vecgroupid).LastVector
  568.  
  569.     ' Linear velocity update
  570.     ax = vec3Dacc(vectorindex, 1)
  571.     ay = vec3Dacc(vectorindex, 2)
  572.     az = vec3Dacc(vectorindex, 3)
  573.     IF (ax <> 0) THEN vec3Dvel(vectorindex, 1) = vec3Dvel(vectorindex, 1) + ax * dt
  574.     IF (ay <> 0) THEN vec3Dvel(vectorindex, 2) = vec3Dvel(vectorindex, 2) + ay * dt
  575.     IF (az <> 0) THEN vec3Dvel(vectorindex, 3) = vec3Dvel(vectorindex, 3) + az * dt
  576.  
  577.     ' Linear position update with periodic boundaries inside group dimension
  578.     vx = vec3Dvel(vectorindex, 1)
  579.     vy = vec3Dvel(vectorindex, 2)
  580.     vz = vec3Dvel(vectorindex, 3)
  581.     IF (vx <> 0) THEN
  582.         px = vec3Dpos(vectorindex, 1) + vx * dt
  583.         IF ABS(px - xcom) > xdim THEN
  584.             IF (px > xcom) THEN
  585.                 px = xcom - xdim
  586.             ELSE
  587.                 px = xcom + xdim
  588.             END IF
  589.         END IF
  590.         vec3Dpos(vectorindex, 1) = px
  591.     END IF
  592.     IF (vy <> 0) THEN
  593.         py = vec3Dpos(vectorindex, 2) + vy * dt
  594.         IF ABS(py - ycom) > ydim THEN
  595.             IF (py > ycom) THEN
  596.                 py = ycom - ydim
  597.             ELSE
  598.                 py = ycom + ydim
  599.             END IF
  600.         END IF
  601.         vec3Dpos(vectorindex, 2) = py
  602.     END IF
  603.     IF (vz <> 0) THEN
  604.         pz = vec3Dpos(vectorindex, 3) + vz * dt
  605.         IF ABS(pz - zcom) > zdim THEN
  606.             IF (pz > zcom) THEN
  607.                 pz = zcom - zdim
  608.             ELSE
  609.                 pz = zcom + zdim
  610.             END IF
  611.         END IF
  612.         vec3Dpos(vectorindex, 3) = pz
  613.     END IF
  614.  
  615.     ' Rotation update
  616.     IF (xrot <> 0) THEN
  617.         anv = vec3Danv(vectorindex, 1)
  618.         yy = vec3Dpos(vectorindex, 2) - yrot
  619.         zz = vec3Dpos(vectorindex, 3) - zrot
  620.         y = yy * COS(timestep * anv) - zz * SIN(timestep * anv)
  621.         z = yy * SIN(timestep * anv) + zz * COS(timestep * anv)
  622.         vec3Dpos(vectorindex, 2) = y + yrot
  623.         vec3Dpos(vectorindex, 3) = z + zrot
  624.     END IF
  625.     IF (yrot <> 0) THEN
  626.         anv = vec3Danv(vectorindex, 2)
  627.         xx = vec3Dpos(vectorindex, 1) - xrot
  628.         zz = vec3Dpos(vectorindex, 3) - zrot
  629.         x = xx * COS(timestep * anv) + zz * SIN(timestep * anv)
  630.         z = -xx * SIN(timestep * anv) + zz * COS(timestep * anv)
  631.         vec3Dpos(vectorindex, 1) = x + xrot
  632.         vec3Dpos(vectorindex, 3) = z + zrot
  633.     END IF
  634.     IF (zrot <> 0) THEN
  635.         anv = vec3Danv(vectorindex, 3)
  636.         xx = vec3Dpos(vectorindex, 1) - xrot
  637.         yy = vec3Dpos(vectorindex, 2) - yrot
  638.         x = xx * COS(timestep * anv) - yy * SIN(timestep * anv)
  639.         y = xx * SIN(timestep * anv) + yy * COS(timestep * anv)
  640.         vec3Dpos(vectorindex, 1) = x + xrot
  641.         vec3Dpos(vectorindex, 2) = y + yrot
  642.     END IF
  643.  
  644.     ' Revolution update
  645.     IF (xrev <> 0) THEN
  646.         anv = xrev
  647.         yy = vec3Dpos(vectorindex, 2) - ycom
  648.         zz = vec3Dpos(vectorindex, 3) - zcom
  649.         y = yy * COS(timestep * anv) - zz * SIN(timestep * anv)
  650.         z = yy * SIN(timestep * anv) + zz * COS(timestep * anv)
  651.         vec3Dpos(vectorindex, 2) = y + ycom
  652.         vec3Dpos(vectorindex, 3) = z + zcom
  653.     END IF
  654.     IF (yrev <> 0) THEN
  655.         anv = yrev
  656.         xx = vec3Dpos(vectorindex, 1) - xcom
  657.         zz = vec3Dpos(vectorindex, 3) - zcom
  658.         x = xx * COS(timestep * anv) + zz * SIN(timestep * anv)
  659.         z = -xx * SIN(timestep * anv) + zz * COS(timestep * anv)
  660.         vec3Dpos(vectorindex, 1) = x + xcom
  661.         vec3Dpos(vectorindex, 3) = z + zcom
  662.     END IF
  663.     IF (zrev <> 0) THEN
  664.         anv = zrev
  665.         xx = vec3Dpos(vectorindex, 1) - xcom
  666.         yy = vec3Dpos(vectorindex, 2) - ycom
  667.         x = xx * COS(timestep * anv) - yy * SIN(timestep * anv)
  668.         y = xx * SIN(timestep * anv) + yy * COS(timestep * anv)
  669.         vec3Dpos(vectorindex, 1) = x + xcom
  670.         vec3Dpos(vectorindex, 2) = y + ycom
  671.     END IF
  672.  
  673.     IF (VectorGroup(vecgroupid).COMFixed = 0) THEN GOSUB integratecom
  675. IF (VectorGroup(vecgroupid).COMFixed = 0) THEN GOSUB calculatecom
  677.  
  678. integratecom: ' requires vecgroupid
  679. VectorGroup(vecgroupid).COMx = vec3Dpos(vectorindex, 1) + VectorGroup(vecgroupid).COMx
  680. VectorGroup(vecgroupid).COMy = vec3Dpos(vectorindex, 2) + VectorGroup(vecgroupid).COMy
  681. VectorGroup(vecgroupid).COMz = vec3Dpos(vectorindex, 3) + VectorGroup(vecgroupid).COMz
  683.  
  684. calculatecom: ' requires vecgroupid
  685. f = 1 + VectorGroup(vecgroupid).LastVector - VectorGroup(vecgroupid).FirstVector
  686. VectorGroup(vecgroupid).COMx = VectorGroup(vecgroupid).COMx / f
  687. VectorGroup(vecgroupid).COMy = VectorGroup(vecgroupid).COMy / f
  688. VectorGroup(vecgroupid).COMz = VectorGroup(vecgroupid).COMz / f
  690.  
  691. resetcom: ' requires vecgroupid
  692. VectorGroup(vecgroupid).COMx = 0
  693. VectorGroup(vecgroupid).COMy = 0
  694. VectorGroup(vecgroupid).COMz = 0
  696.  
  697. plot.visible.vectors:
  698. GOSUB plot.vectors
  699. GOSUB plot.hud
  701.  
  702. plot.vectors:
  704. numgroupvisible = 0
  705. numvectorvisible = 0
  706. k = 1
  707. k = VectorGroup(k).Identity
  709.     IF (VectorGroup(k).Visible = 1) THEN
  710.         numgroupvisible = numgroupvisible + 1
  711.         FOR i = VectorGroup(k).FirstVector TO VectorGroup(k).LastVector - 1
  712.             IF (vec3Dvis(i) = 1) THEN
  713.                 numvectorvisible = numvectorvisible + 1
  714.                 IF k = closestgroup THEN col = Yellow ELSE col = vec2Dcolor(i)
  715.                 x = vec2D(i, 1): y = vec2D(i, 2): GOSUB convert: x1 = x: y1 = y
  716.                 x = vec2D(i + 1, 1): y = vec2D(i + 1, 2): GOSUB convert: x2 = x: y2 = y
  717.                 IF ((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1)) < 225 THEN
  718.                     LINE (x1, y1)-(x2, y2), col
  719.                 ELSE
  720.                     CIRCLE (x1, y1), 1, col
  721.                 END IF
  722.             END IF
  723.         NEXT
  724.     END IF
  725.     k = VectorGroup(k).Pointer
  726.     IF k = -999 THEN EXIT DO
  727.     k = VectorGroup(k).Identity
  730.  
  731. plot.hud:
  732. ' Redraw compass.
  733. x = 30 * (xhat(1) * uhat(1) + xhat(2) * uhat(2) + xhat(3) * uhat(3)): y = 30 * (xhat(1) * vhat(1) + xhat(2) * vhat(2) + xhat(3) * vhat(3)): GOSUB convert
  734. LINE (midscreenx, midscreeny)-(x, y), Red
  735. x = 30 * (yhat(1) * uhat(1) + yhat(2) * uhat(2) + yhat(3) * uhat(3)): y = 30 * (yhat(1) * vhat(1) + yhat(2) * vhat(2) + yhat(3) * vhat(3)): GOSUB convert
  736. LINE (midscreenx, midscreeny)-(x, y), Green
  737. x = 30 * (zhat(1) * uhat(1) + zhat(2) * uhat(2) + zhat(3) * uhat(3)): y = 30 * (zhat(1) * vhat(1) + zhat(2) * vhat(2) + zhat(3) * vhat(3)): GOSUB convert
  738. LINE (midscreenx, midscreeny)-(x, y), Blue
  739. IF togglehud = 1 THEN
  740.     COLOR LimeGreen
  741.     LOCATE 2, 2: PRINT "- View Info -"
  742.     COLOR DarkKhaki
  743.     LOCATE 3, 2: PRINT "FPS:"; fpsreport
  744.     LOCATE 4, 2: PRINT "Vectors:"; numvectorvisible
  745.     LOCATE 5, 2: PRINT "Groups:"; numgroupvisible
  746.     LOCATE 6, 2: PRINT "Depth:"; -farplane(4)
  747.     LOCATE 7, 2: PRINT "Adjust via [ ]"
  748.     COLOR LimeGreen
  749.     LOCATE 9, 2: PRINT "- Camera -"
  750.     COLOR DarkKhaki
  751.     LOCATE 10, 2: PRINT INT(camx); INT(camy); INT(camz)
  752.     COLOR LimeGreen
  753.     LOCATE 12, 2: PRINT "- Closest: -"
  754.     COLOR DarkKhaki
  755.     LOCATE 13, 2: PRINT LTRIM$(RTRIM$(VectorGroup(closestgroup).GroupName))
  756.     COLOR LimeGreen
  757.     a$ = "MOVE - ALIGN": LOCATE 2, screenwidth / 8 - LEN(a$): PRINT a$
  758.     COLOR DarkKhaki
  759.     a$ = "q w e - x y z": LOCATE 3, screenwidth / 8 - LEN(a$): PRINT a$
  760.     a$ = "a s d - X Y Z": LOCATE 4, screenwidth / 8 - LEN(a$): PRINT a$
  761.     a$ = "i = invert ms": LOCATE 5, screenwidth / 8 - LEN(a$): PRINT a$
  762.     COLOR LimeGreen
  763.     a$ = "- ROTATE -": LOCATE 7, screenwidth / 8 - LEN(a$): PRINT a$
  764.     COLOR DarkKhaki
  765.     a$ = "7 8 9 Mouse": LOCATE 8, screenwidth / 8 - LEN(a$): PRINT a$
  766.     a$ = "4 5 6   +  ": LOCATE 9, screenwidth / 8 - LEN(a$): PRINT a$
  767.     a$ = "1 2 3 Wheel": LOCATE 10, screenwidth / 8 - LEN(a$): PRINT a$
  768.     COLOR LimeGreen
  769.     a$ = "- CONTROL -": LOCATE 12, screenwidth / 8 - LEN(a$): PRINT a$
  770.     COLOR DarkKhaki
  771.     a$ = "t = Stop time": LOCATE 13, screenwidth / 8 - LEN(a$): PRINT a$
  772.     a$ = "b = Create": LOCATE 14, screenwidth / 8 - LEN(a$): PRINT a$
  773.     a$ = "n = Destroy": LOCATE 15, screenwidth / 8 - LEN(a$): PRINT a$
  774.     a$ = "k = Delete": LOCATE 16, screenwidth / 8 - LEN(a$): PRINT a$
  775.     COLOR LimeGreen
  776.     a$ = "SPACE = Hide Info": LOCATE (screenheight / 16) - 3, (screenwidth / 8) / 2 - LEN(a$) / 2: PRINT a$
  778.     COLOR LimeGreen
  779.     a$ = "You See: " + LTRIM$(RTRIM$(VectorGroup(closestgroup).GroupName)): LOCATE (screenheight / 16) - 3, (screenwidth / 8) / 2 - LEN(a$) / 2: PRINT a$
  782.  
  783. 'groupidfromname: ' requires n$, returns k
  784. 'k = 1
  785. 'k = VectorGroup(k).Identity
  786. 'DO ' iterates k
  787. '    IF n$ = LTRIM$(RTRIM$(VectorGroup(k).GroupName)) THEN EXIT DO
  788. '    k = VectorGroup(k).Pointer
  789. '    IF k = -999 THEN EXIT DO
  790. '    k = VectorGroup(k).Identity
  791. 'LOOP
  792. 'RETURN
  793.  
  794. ' Data.
  795.  
  796. initialize.objects:
  797. vectorindex = 0
  798. groupidticker = 0
  799. gridsize = 550
  800. tilesize = 15
  801.  
  802. '__AAA
  803. groupidticker = groupidticker + 1
  804. vecgroupid = groupidticker
  805. VectorGroup(vecgroupid).Identity = vecgroupid
  806. VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  807. VectorGroup(vecgroupid).Lagger = vecgroupid - 1 ' Fancy way to say 0.
  808. VectorGroup(vecgroupid).GroupName = "__AAA"
  809. VectorGroup(vecgroupid).Visible = 0
  810. VectorGroup(vecgroupid).COMFixed = 1
  811. VectorGroup(vecgroupid).DIMx = 5
  812. VectorGroup(vecgroupid).DIMy = 5
  813. VectorGroup(vecgroupid).DIMz = 5
  814. VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  815. FOR r = 1 TO 1
  816.     vectorindex = vectorindex + 1
  817.     vec3Dpos(vectorindex, 1) = 0
  818.     vec3Dpos(vectorindex, 2) = 0
  819.     vec3Dpos(vectorindex, 3) = -1000
  820.     vec3Dcolor(vectorindex) = White
  821.     GOSUB integratecom
  823. VectorGroup(vecgroupid).LastVector = vectorindex
  824. GOSUB calculatecom
  825.  
  826. 'Dirt
  827. h = 5
  828. FOR w = 1 TO 5
  829.     FOR u = -gridsize TO gridsize STEP tilesize
  830.         FOR v = -gridsize TO gridsize STEP tilesize
  831.             groupidticker = groupidticker + 1
  832.             vecgroupid = groupidticker
  833.             VectorGroup(vecgroupid).Identity = vecgroupid
  834.             VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  835.             VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  836.             VectorGroup(vecgroupid).GroupName = "Dirt"
  837.             VectorGroup(vecgroupid).Visible = 0
  838.             VectorGroup(vecgroupid).COMFixed = 1
  839.             VectorGroup(vecgroupid).DIMx = 35
  840.             VectorGroup(vecgroupid).DIMy = 35
  841.             VectorGroup(vecgroupid).DIMz = 35
  842.             VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  843.             FOR i = u TO u + tilesize STEP h
  844.                 FOR j = v TO v + tilesize STEP h
  845.                     IF RND > 1 - w / 5 THEN
  846.                         vectorindex = vectorindex + 1
  847.                         vec3Dpos(vectorindex, 1) = i + RND * h - RND * h
  848.                         vec3Dpos(vectorindex, 2) = j + RND * h - RND * h
  849.                         vec3Dpos(vectorindex, 3) = -(w - 1) * 70 - RND * 70
  850.                         vec3Dvis(vectorindex) = 0
  851.                         IF RND > .5 THEN
  852.                             vec3Dcolor(vectorindex) = DarkGoldenRod
  853.                         ELSE
  854.                             IF RND > .5 THEN
  855.                                 vec3Dcolor(vectorindex) = SaddleBrown
  856.                             ELSE
  857.                                 vec3Dcolor(vectorindex) = Sienna
  858.                             END IF
  859.                         END IF
  860.                         GOSUB integratecom
  861.                     END IF
  862.                 NEXT
  863.             NEXT
  864.             VectorGroup(vecgroupid).LastVector = vectorindex
  865.             GOSUB calculatecom
  866.         NEXT
  867.     NEXT
  869.  
  870. 'Grass and Puddles
  871. h = 2
  872. FOR u = -gridsize TO gridsize STEP tilesize
  873.     FOR v = -gridsize TO gridsize STEP tilesize
  874.         groupidticker = groupidticker + 1
  875.         vecgroupid = groupidticker
  876.         VectorGroup(vecgroupid).Identity = vecgroupid
  877.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  878.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  879.         VectorGroup(vecgroupid).GroupName = "Grass and Puddles"
  880.         VectorGroup(vecgroupid).Visible = 0
  881.         VectorGroup(vecgroupid).COMFixed = 1
  882.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  883.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  884.         VectorGroup(vecgroupid).DIMz = 3
  885.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  886.         FOR i = u TO u + tilesize STEP h
  887.             FOR j = v TO v + tilesize STEP h
  888.                 vectorindex = vectorindex + 1
  889.                 vec3Dpos(vectorindex, 1) = i + RND * h - RND * h
  890.                 vec3Dpos(vectorindex, 2) = j + RND * h - RND * h
  891.                 vec3Dpos(vectorindex, 3) = .5 + 1 * COS((i - 15) * .08) - 1 * COS((j - 6) * .12)
  892.                 vec3Dvis(vectorindex) = 0
  893.                 IF vec3Dpos(vectorindex, 3) > 0 THEN
  894.                     IF RND > .5 THEN
  895.                         vec3Dcolor(vectorindex) = Green
  896.                     ELSE
  897.                         vec3Dcolor(vectorindex) = ForestGreen
  898.                     END IF
  899.                 ELSE
  900.                     vec3Dvel(vectorindex, 1) = (RND - .5) * 20
  901.                     vec3Dvel(vectorindex, 2) = (RND - .5) * 20
  902.                     vec3Dvel(vectorindex, 3) = (RND - .5) * 20
  903.                     IF RND > .2 THEN
  904.                         vec3Dcolor(vectorindex) = LightSeaGreen
  905.                     ELSE
  906.                         vec3Dcolor(vectorindex) = Blue
  907.                     END IF
  908.                 END IF
  909.                 GOSUB integratecom
  910.             NEXT
  911.         NEXT
  912.         VectorGroup(vecgroupid).LastVector = vectorindex
  913.         GOSUB calculatecom
  914.     NEXT
  916.  
  917. 'Grave
  918. thickness = 2.5
  919. span = 20
  920. height = 30
  921. crux = 22
  922. FOR xloc = -90 TO -290 STEP -60
  923.     FOR yloc = 0 TO 180 STEP 45
  924.         FOR k = 0 TO height
  925.             groupidticker = groupidticker + 1
  926.             vecgroupid = groupidticker
  927.             VectorGroup(vecgroupid).Identity = vecgroupid
  928.             VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  929.             VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  930.             VectorGroup(vecgroupid).GroupName = "Grave"
  931.             VectorGroup(vecgroupid).Visible = 0
  932.             VectorGroup(vecgroupid).COMFixed = 1
  933.             VectorGroup(vecgroupid).DIMx = thickness
  934.             VectorGroup(vecgroupid).DIMy = thickness
  935.             VectorGroup(vecgroupid).DIMz = thickness
  936.             VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  937.             FOR i = -thickness TO thickness STEP thickness / 2
  938.                 FOR j = -thickness TO thickness STEP thickness / 2
  939.                     vectorindex = vectorindex + 1
  940.                     vec3Dpos(vectorindex, 1) = xloc + i + (RND - .5) * 2
  941.                     vec3Dpos(vectorindex, 2) = yloc + j + (RND - .5) * 2
  942.                     vec3Dpos(vectorindex, 3) = k + (RND - .5) * 2
  943.                     vec3Dvis(vectorindex) = 0
  944.                     IF RND > .5 THEN
  945.                         vec3Dcolor(vectorindex) = SlateGray
  946.                     ELSE
  947.                         vec3Dcolor(vectorindex) = DarkGray
  948.                     END IF
  949.                     GOSUB integratecom
  950.                 NEXT
  951.             NEXT
  952.             VectorGroup(vecgroupid).LastVector = vectorindex
  953.             GOSUB calculatecom
  954.         NEXT
  955.         FOR j = -span / 2 TO -thickness
  956.             groupidticker = groupidticker + 1
  957.             vecgroupid = groupidticker
  958.             VectorGroup(vecgroupid).Identity = vecgroupid
  959.             VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  960.             VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  961.             VectorGroup(vecgroupid).GroupName = "Grave"
  962.             VectorGroup(vecgroupid).Visible = 0
  963.             VectorGroup(vecgroupid).COMFixed = 1
  964.             VectorGroup(vecgroupid).DIMx = thickness
  965.             VectorGroup(vecgroupid).DIMy = thickness
  966.             VectorGroup(vecgroupid).DIMz = thickness
  967.             VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  968.             FOR k = -thickness TO thickness STEP thickness / 2
  969.                 FOR i = -thickness TO thickness STEP thickness / 2
  970.                     vectorindex = vectorindex + 1
  971.                     vec3Dpos(vectorindex, 1) = xloc + i + (RND - .5) * 2
  972.                     vec3Dpos(vectorindex, 2) = yloc + j + (RND - .5) * 2
  973.                     vec3Dpos(vectorindex, 3) = crux + k + (RND - .5) * 2
  974.                     vec3Dvis(vectorindex) = 0
  975.                     IF RND > .5 THEN
  976.                         vec3Dcolor(vectorindex) = SlateGray
  977.                     ELSE
  978.                         vec3Dcolor(vectorindex) = DarkGray
  979.                     END IF
  980.                     GOSUB integratecom
  981.                 NEXT
  982.             NEXT
  983.             VectorGroup(vecgroupid).LastVector = vectorindex
  984.             GOSUB calculatecom
  985.         NEXT
  986.         FOR j = thickness TO span / 2
  987.             groupidticker = groupidticker + 1
  988.             vecgroupid = groupidticker
  989.             VectorGroup(vecgroupid).Identity = vecgroupid
  990.             VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  991.             VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  992.             VectorGroup(vecgroupid).GroupName = "Grave"
  993.             VectorGroup(vecgroupid).Visible = 0
  994.             VectorGroup(vecgroupid).COMFixed = 1
  995.             VectorGroup(vecgroupid).DIMx = thickness
  996.             VectorGroup(vecgroupid).DIMy = thickness
  997.             VectorGroup(vecgroupid).DIMz = thickness
  998.             VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  999.             FOR k = -thickness TO thickness STEP thickness / 2
  1000.                 FOR i = -thickness TO thickness STEP thickness / 2
  1001.                     vectorindex = vectorindex + 1
  1002.                     vec3Dpos(vectorindex, 1) = xloc + i + (RND - .5) * 2
  1003.                     vec3Dpos(vectorindex, 2) = yloc + j + (RND - .5) * 2
  1004.                     vec3Dpos(vectorindex, 3) = crux + k + (RND - .5) * 2
  1005.                     vec3Dvis(vectorindex) = 0
  1006.                     IF RND > .5 THEN
  1007.                         vec3Dcolor(vectorindex) = SlateGray
  1008.                     ELSE
  1009.                         vec3Dcolor(vectorindex) = DarkGray
  1010.                     END IF
  1011.                     GOSUB integratecom
  1012.                 NEXT
  1013.             NEXT
  1014.             VectorGroup(vecgroupid).LastVector = vectorindex
  1015.             GOSUB calculatecom
  1016.         NEXT
  1017.     NEXT
  1019.  
  1020. 'Heaven's Bottom Layer
  1021. h = 2
  1022. FOR u = -gridsize TO gridsize STEP tilesize
  1023.     FOR v = -gridsize TO gridsize STEP tilesize
  1024.         groupidticker = groupidticker + 1
  1025.         vecgroupid = groupidticker
  1026.         VectorGroup(vecgroupid).Identity = vecgroupid
  1027.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1028.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1029.         VectorGroup(vecgroupid).GroupName = "Heaven's Bottom Layer"
  1030.         VectorGroup(vecgroupid).Visible = 0
  1031.         VectorGroup(vecgroupid).COMFixed = 1
  1032.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1033.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1034.         VectorGroup(vecgroupid).DIMz = 3
  1035.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1036.         FOR i = u TO u + tilesize STEP h
  1037.             FOR j = v TO v + tilesize STEP h
  1038.                 vectorindex = vectorindex + 1
  1039.                 vec3Dpos(vectorindex, 1) = i + RND * h - RND * h
  1040.                 vec3Dpos(vectorindex, 2) = j + RND * h - RND * h
  1041.                 vec3Dpos(vectorindex, 3) = 420 - RND
  1042.                 vec3Dvis(vectorindex) = 0
  1043.                 IF RND > .5 THEN
  1044.                     vec3Dcolor(vectorindex) = BlueViolet
  1045.                 ELSE
  1046.                     vec3Dcolor(vectorindex) = Cyan
  1047.                 END IF
  1048.                 GOSUB integratecom
  1049.             NEXT
  1050.         NEXT
  1051.         VectorGroup(vecgroupid).LastVector = vectorindex
  1052.         GOSUB calculatecom
  1053.     NEXT
  1055.  
  1056. 'Hell Spawn
  1057. FOR u = -gridsize TO gridsize STEP tilesize
  1058.     FOR v = -gridsize TO gridsize STEP tilesize
  1059.         groupidticker = groupidticker + 1
  1060.         vecgroupid = groupidticker
  1061.         VectorGroup(vecgroupid).Identity = vecgroupid
  1062.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1063.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1064.         VectorGroup(vecgroupid).GroupName = "Hell Spawn"
  1065.         VectorGroup(vecgroupid).Visible = 0
  1066.         VectorGroup(vecgroupid).COMFixed = 1
  1067.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1068.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1069.         VectorGroup(vecgroupid).DIMz = 35
  1070.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1071.         FOR i = u TO u + tilesize STEP tilesize / 5
  1072.             FOR j = v TO v + tilesize STEP tilesize / 5
  1073.                 vectorindex = vectorindex + 1
  1074.                 vec3Dpos(vectorindex, 1) = i + (RND - .5) * tilesize
  1075.                 vec3Dpos(vectorindex, 2) = j + (RND - .5) * tilesize
  1076.                 vec3Dpos(vectorindex, 3) = -350 - RND * 70
  1077.                 vec3Dvel(vectorindex, 1) = 0
  1078.                 vec3Dvel(vectorindex, 2) = 0
  1079.                 vec3Dvel(vectorindex, 3) = 400 * RND
  1080.                 vec3Dvis(vectorindex) = 0
  1081.                 IF RND > .2 THEN
  1082.                     vec3Dcolor(vectorindex) = Red
  1083.                 ELSE
  1084.                     vec3Dcolor(vectorindex) = DarkGoldenRod
  1085.                 END IF
  1086.                 GOSUB integratecom
  1087.             NEXT
  1088.         NEXT
  1089.         VectorGroup(vecgroupid).LastVector = vectorindex
  1090.         GOSUB calculatecom
  1091.         VectorGroup(vecgroupid).COMz = -350 - 35
  1092.     NEXT
  1094.  
  1095. 'Icewall East
  1096. h = 2
  1097. FOR u = -gridsize TO gridsize STEP tilesize
  1098.     FOR v = 0 TO 70 STEP tilesize
  1099.         groupidticker = groupidticker + 1
  1100.         vecgroupid = groupidticker
  1101.         VectorGroup(vecgroupid).Identity = vecgroupid
  1102.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1103.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1104.         VectorGroup(vecgroupid).GroupName = "Icewall East"
  1105.         VectorGroup(vecgroupid).Visible = 0
  1106.         VectorGroup(vecgroupid).COMFixed = 1
  1107.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1108.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1109.         VectorGroup(vecgroupid).DIMz = tilesize / 2
  1110.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1111.         FOR i = u TO u + tilesize STEP h
  1112.             FOR j = v TO v + tilesize STEP h
  1113.                 vectorindex = vectorindex + 1
  1114.                 vec3Dpos(vectorindex, 1) = gridsize + tilesize / 2
  1115.                 vec3Dpos(vectorindex, 2) = i + RND * h - RND * h
  1116.                 vec3Dpos(vectorindex, 3) = j + RND * h - RND * h
  1117.                 vec3Dvis(vectorindex) = 0
  1118.                 IF RND > .5 THEN
  1119.                     vec3Dcolor(vectorindex) = White
  1120.                 ELSE
  1121.                     vec3Dcolor(vectorindex) = Ivory
  1122.                 END IF
  1123.                 GOSUB integratecom
  1124.             NEXT
  1125.         NEXT
  1126.         VectorGroup(vecgroupid).LastVector = vectorindex
  1127.         GOSUB calculatecom
  1128.     NEXT
  1130.  
  1131. 'Icewall South
  1132. h = 2
  1133. FOR u = -gridsize TO gridsize STEP tilesize
  1134.     FOR v = 0 TO 70 STEP tilesize
  1135.         groupidticker = groupidticker + 1
  1136.         vecgroupid = groupidticker
  1137.         VectorGroup(vecgroupid).Identity = vecgroupid
  1138.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1139.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1140.         VectorGroup(vecgroupid).GroupName = "Icewall South"
  1141.         VectorGroup(vecgroupid).Visible = 0
  1142.         VectorGroup(vecgroupid).COMFixed = 1
  1143.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1144.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1145.         VectorGroup(vecgroupid).DIMz = tilesize / 2
  1146.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1147.         FOR i = u TO u + tilesize STEP h
  1148.             FOR j = v TO v + tilesize STEP h
  1149.                 vectorindex = vectorindex + 1
  1150.                 vec3Dpos(vectorindex, 1) = -gridsize
  1151.                 vec3Dpos(vectorindex, 2) = i + RND * h - RND * h
  1152.                 vec3Dpos(vectorindex, 3) = j + RND * h - RND * h
  1153.                 vec3Dvis(vectorindex) = 0
  1154.                 IF RND > .5 THEN
  1155.                     vec3Dcolor(vectorindex) = White
  1156.                 ELSE
  1157.                     vec3Dcolor(vectorindex) = Ivory
  1158.                 END IF
  1159.                 GOSUB integratecom
  1160.             NEXT
  1161.         NEXT
  1162.         VectorGroup(vecgroupid).LastVector = vectorindex
  1163.         GOSUB calculatecom
  1164.     NEXT
  1166.  
  1167. 'Icewall North
  1168. h = 2
  1169. FOR u = -gridsize TO gridsize STEP tilesize
  1170.     FOR v = 0 TO 70 STEP tilesize
  1171.         groupidticker = groupidticker + 1
  1172.         vecgroupid = groupidticker
  1173.         VectorGroup(vecgroupid).Identity = vecgroupid
  1174.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1175.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1176.         VectorGroup(vecgroupid).GroupName = "Icewall North"
  1177.         VectorGroup(vecgroupid).Visible = 0
  1178.         VectorGroup(vecgroupid).COMFixed = 1
  1179.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1180.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1181.         VectorGroup(vecgroupid).DIMz = tilesize / 2
  1182.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1183.         FOR i = u TO u + tilesize STEP h
  1184.             FOR j = v TO v + tilesize STEP h
  1185.                 vectorindex = vectorindex + 1
  1186.                 vec3Dpos(vectorindex, 1) = i + RND * h - RND * h
  1187.                 vec3Dpos(vectorindex, 2) = gridsize + tilesize / 2
  1188.                 vec3Dpos(vectorindex, 3) = j + RND * h - RND * h
  1189.                 vec3Dvis(vectorindex) = 0
  1190.                 IF RND > .5 THEN
  1191.                     vec3Dcolor(vectorindex) = White
  1192.                 ELSE
  1193.                     vec3Dcolor(vectorindex) = Ivory
  1194.                 END IF
  1195.                 GOSUB integratecom
  1196.             NEXT
  1197.         NEXT
  1198.         VectorGroup(vecgroupid).LastVector = vectorindex
  1199.         GOSUB calculatecom
  1200.     NEXT
  1202.  
  1203. 'Icewall West
  1204. h = 2
  1205. FOR u = -gridsize TO gridsize STEP tilesize
  1206.     FOR v = 0 TO 70 STEP tilesize
  1207.         groupidticker = groupidticker + 1
  1208.         vecgroupid = groupidticker
  1209.         VectorGroup(vecgroupid).Identity = vecgroupid
  1210.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1211.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1212.         VectorGroup(vecgroupid).GroupName = "Icewall West"
  1213.         VectorGroup(vecgroupid).Visible = 0
  1214.         VectorGroup(vecgroupid).COMFixed = 1
  1215.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1216.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1217.         VectorGroup(vecgroupid).DIMz = tilesize / 2
  1218.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1219.         FOR i = u TO u + tilesize STEP h
  1220.             FOR j = v TO v + tilesize STEP h
  1221.                 vectorindex = vectorindex + 1
  1222.                 vec3Dpos(vectorindex, 1) = i + RND * h - RND * h
  1223.                 vec3Dpos(vectorindex, 2) = -gridsize
  1224.                 vec3Dpos(vectorindex, 3) = j + RND * h - RND * h
  1225.                 vec3Dvis(vectorindex) = 0
  1226.                 IF RND > .5 THEN
  1227.                     vec3Dcolor(vectorindex) = White
  1228.                 ELSE
  1229.                     vec3Dcolor(vectorindex) = Ivory
  1230.                 END IF
  1231.                 GOSUB integratecom
  1232.             NEXT
  1233.         NEXT
  1234.         VectorGroup(vecgroupid).LastVector = vectorindex
  1235.         GOSUB calculatecom
  1236.     NEXT
  1238.  
  1239. 'Lake of Fire
  1240. h = 2
  1241. FOR u = -gridsize TO gridsize STEP tilesize
  1242.     FOR v = -gridsize TO gridsize STEP tilesize
  1243.         groupidticker = groupidticker + 1
  1244.         vecgroupid = groupidticker
  1245.         VectorGroup(vecgroupid).Identity = vecgroupid
  1246.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1247.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1248.         VectorGroup(vecgroupid).GroupName = "Lake of Fire"
  1249.         VectorGroup(vecgroupid).Visible = 0
  1250.         VectorGroup(vecgroupid).COMFixed = 1
  1251.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1252.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1253.         VectorGroup(vecgroupid).DIMz = tilesize / 2
  1254.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1255.         FOR i = u TO u + tilesize STEP h
  1256.             FOR j = v TO v + tilesize STEP h
  1257.                 vectorindex = vectorindex + 1
  1258.                 vec3Dpos(vectorindex, 1) = i + RND * h - RND * h
  1259.                 vec3Dpos(vectorindex, 2) = j + RND * h - RND * h
  1260.                 vec3Dpos(vectorindex, 3) = -350 - 70 - RND
  1261.                 vec3Dvis(vectorindex) = 0
  1262.                 IF RND > .2 THEN
  1263.                     vec3Dcolor(vectorindex) = Red
  1264.                 ELSE
  1265.                     vec3Dcolor(vectorindex) = Indigo
  1266.                 END IF
  1267.                 GOSUB integratecom
  1268.             NEXT
  1269.         NEXT
  1270.         VectorGroup(vecgroupid).LastVector = vectorindex
  1271.         GOSUB calculatecom
  1272.     NEXT
  1274.  
  1275. 'Megalith
  1276. ctrx = -90
  1277. ctry = -320
  1278. ctrz = 4
  1279. w = 8
  1280. h = 256
  1281. dens = 100
  1282. FOR k = 1 TO h STEP w
  1283.     FOR i = -h / 20 + k / 20 TO h / 20 - k / 20 STEP w
  1284.         FOR j = -h / 20 + k / 20 TO h / 20 - k / 20 STEP w
  1285.             groupidticker = groupidticker + 1
  1286.             vecgroupid = groupidticker
  1287.             VectorGroup(vecgroupid).Identity = vecgroupid
  1288.             VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1289.             VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1290.             VectorGroup(vecgroupid).GroupName = "Megalith"
  1291.             VectorGroup(vecgroupid).Visible = 0
  1292.             VectorGroup(vecgroupid).COMFixed = 1
  1293.             VectorGroup(vecgroupid).DIMx = w / 2
  1294.             VectorGroup(vecgroupid).DIMy = w / 2
  1295.             VectorGroup(vecgroupid).DIMz = w / 2
  1296.             VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1297.             FOR q = 1 TO dens
  1298.                 vectorindex = vectorindex + 1
  1299.                 vec3Dpos(vectorindex, 1) = ctrx + i + (RND - .5) * w
  1300.                 vec3Dpos(vectorindex, 2) = ctry + j + (RND - .5) * w
  1301.                 vec3Dpos(vectorindex, 3) = ctrz + k + (RND - .5) * w
  1302.                 vec3Dvis(vectorindex) = 0
  1303.                 IF RND > .5 THEN
  1304.                     vec3Dcolor(vectorindex) = Cyan
  1305.                 ELSE
  1306.                     vec3Dcolor(vectorindex) = Teal
  1307.                 END IF
  1308.                 GOSUB integratecom
  1309.             NEXT
  1310.             VectorGroup(vecgroupid).LastVector = vectorindex
  1311.             GOSUB calculatecom
  1312.         NEXT
  1313.     NEXT
  1315.  
  1316. 'Pyramid
  1317. ctrx = -90
  1318. ctry = -120
  1319. ctrz = 4
  1320. w = 8
  1321. h = 56
  1322. dens = 50
  1323. FOR k = 1 TO h STEP w
  1324.     FOR i = -h / 2 + k / 2 TO h / 2 - k / 2 STEP w
  1325.         FOR j = -h / 2 + k / 2 TO h / 2 - k / 2 STEP w
  1326.             groupidticker = groupidticker + 1
  1327.             vecgroupid = groupidticker
  1328.             VectorGroup(vecgroupid).Identity = vecgroupid
  1329.             VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1330.             VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1331.             VectorGroup(vecgroupid).GroupName = "Pyramid"
  1332.             VectorGroup(vecgroupid).Visible = 0
  1333.             VectorGroup(vecgroupid).COMFixed = 1
  1334.             VectorGroup(vecgroupid).DIMx = tilesize / 2
  1335.             VectorGroup(vecgroupid).DIMy = tilesize / 2
  1336.             VectorGroup(vecgroupid).DIMz = tilesize / 2
  1337.             VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1338.             FOR q = 1 TO dens
  1339.                 vectorindex = vectorindex + 1
  1340.                 vec3Dpos(vectorindex, 1) = ctrx + i + (RND - .5) * w
  1341.                 vec3Dpos(vectorindex, 2) = ctry + j + (RND - .5) * w
  1342.                 vec3Dpos(vectorindex, 3) = ctrz + k + (RND - .5) * w
  1343.                 vec3Dvis(vectorindex) = 0
  1344.                 IF RND > .5 THEN
  1345.                     vec3Dcolor(vectorindex) = DarkGoldenRod
  1346.                 ELSE
  1347.                     vec3Dcolor(vectorindex) = GoldenRod
  1348.                 END IF
  1349.                 GOSUB integratecom
  1350.             NEXT
  1351.             VectorGroup(vecgroupid).LastVector = vectorindex
  1352.             GOSUB calculatecom
  1353.         NEXT
  1354.     NEXT
  1356.  
  1357. 'Rain
  1358. FOR u = -gridsize TO gridsize STEP tilesize
  1359.     FOR v = -gridsize TO gridsize STEP tilesize
  1360.         groupidticker = groupidticker + 1
  1361.         vecgroupid = groupidticker
  1362.         VectorGroup(vecgroupid).Identity = vecgroupid
  1363.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1364.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1365.         VectorGroup(vecgroupid).GroupName = "Rain"
  1366.         VectorGroup(vecgroupid).Visible = 0
  1367.         VectorGroup(vecgroupid).COMFixed = 1
  1368.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1369.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1370.         VectorGroup(vecgroupid).DIMz = 35
  1371.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1372.         FOR i = u TO u + tilesize STEP tilesize '/ 3
  1373.             FOR j = v TO v + tilesize STEP tilesize '/ 3
  1374.                 vectorindex = vectorindex + 1
  1375.                 vec3Dpos(vectorindex, 1) = i + (RND - .5) * tilesize
  1376.                 vec3Dpos(vectorindex, 2) = j + (RND - .5) * tilesize
  1377.                 vec3Dpos(vectorindex, 3) = RND * 70
  1378.                 vec3Dvel(vectorindex, 1) = 0
  1379.                 vec3Dvel(vectorindex, 2) = 0
  1380.                 vec3Dvel(vectorindex, 3) = -400 * RND
  1381.                 vec3Dvis(vectorindex) = 0
  1382.                 IF RND > 5 THEN
  1383.                     vec3Dcolor(vectorindex) = Aquamarine
  1384.                 ELSE
  1385.                     vec3Dcolor(vectorindex) = DodgerBlue
  1386.                 END IF
  1387.                 GOSUB integratecom
  1388.             NEXT
  1389.         NEXT
  1390.         VectorGroup(vecgroupid).LastVector = vectorindex
  1391.         GOSUB calculatecom
  1392.         VectorGroup(vecgroupid).COMz = 35
  1393.     NEXT
  1395.  
  1396. 'Sky
  1397. h = 2
  1398. FOR u = -gridsize TO gridsize STEP tilesize
  1399.     FOR v = -gridsize TO gridsize STEP tilesize
  1400.         groupidticker = groupidticker + 1
  1401.         vecgroupid = groupidticker
  1402.         VectorGroup(vecgroupid).Identity = vecgroupid
  1403.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1404.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1405.         VectorGroup(vecgroupid).GroupName = "Sky"
  1406.         VectorGroup(vecgroupid).Visible = 0
  1407.         VectorGroup(vecgroupid).COMFixed = 1
  1408.         VectorGroup(vecgroupid).DIMx = tilesize / 2
  1409.         VectorGroup(vecgroupid).DIMy = tilesize / 2
  1410.         VectorGroup(vecgroupid).DIMz = 3
  1411.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1412.         FOR i = u TO u + tilesize STEP h
  1413.             FOR j = v TO v + tilesize STEP h
  1414.                 vectorindex = vectorindex + 1
  1415.                 vec3Dpos(vectorindex, 1) = i + (RND - RND) * h
  1416.                 vec3Dpos(vectorindex, 2) = j + (RND - RND) * h
  1417.                 vec3Dpos(vectorindex, 3) = 70 + (RND - RND) * h
  1418.                 vec3Dvel(vectorindex, 1) = (RND - RND) * 2
  1419.                 vec3Dvel(vectorindex, 2) = (RND - RND) * 2
  1420.                 vec3Dvel(vectorindex, 3) = (RND - RND) * 2
  1421.                 vec3Danv(vectorindex, 1) = 0
  1422.                 vec3Danv(vectorindex, 2) = 0
  1423.                 vec3Danv(vectorindex, 3) = 0
  1424.                 vec3Dvis(vectorindex) = 0
  1425.                 IF RND > .5 THEN
  1426.                     vec3Dcolor(vectorindex) = Snow
  1427.                 ELSE
  1428.                     vec3Dcolor(vectorindex) = RoyalBlue
  1429.                 END IF
  1430.                 GOSUB integratecom
  1431.             NEXT
  1432.         NEXT
  1433.         VectorGroup(vecgroupid).LastVector = vectorindex
  1434.         GOSUB calculatecom
  1435.     NEXT
  1437.  
  1438. 'Stars
  1439. h = 5
  1440. FOR w = 1 TO 5
  1441.     FOR u = -gridsize TO gridsize STEP tilesize
  1442.         FOR v = -gridsize TO gridsize STEP tilesize
  1443.             groupidticker = groupidticker + 1
  1444.             vecgroupid = groupidticker
  1445.             VectorGroup(vecgroupid).Identity = vecgroupid
  1446.             VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1447.             VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1448.             VectorGroup(vecgroupid).GroupName = "Stars"
  1449.             VectorGroup(vecgroupid).Visible = 0
  1450.             VectorGroup(vecgroupid).COMFixed = 1
  1451.             VectorGroup(vecgroupid).DIMx = tilesize / 2
  1452.             VectorGroup(vecgroupid).DIMy = tilesize / 2
  1453.             VectorGroup(vecgroupid).DIMz = tilesize / 2
  1454.             VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1455.             FOR i = u TO u + tilesize STEP h
  1456.                 FOR j = v TO v + tilesize STEP h
  1457.                     IF RND > 1 - w / 5 THEN
  1458.                         vectorindex = vectorindex + 1
  1459.                         vec3Dpos(vectorindex, 1) = i + RND * h - RND * h
  1460.                         vec3Dpos(vectorindex, 2) = j + RND * h - RND * h
  1461.                         vec3Dpos(vectorindex, 3) = w * 70 + RND * 70
  1462.                         vec3Dvis(vectorindex) = 0
  1463.                         IF RND > .5 THEN
  1464.                             vec3Dcolor(vectorindex) = GhostWhite
  1465.                         ELSE
  1466.                             IF RND > .5 THEN
  1467.                                 vec3Dcolor(vectorindex) = White
  1468.                             ELSE
  1469.                                 vec3Dcolor(vectorindex) = DarkGray
  1470.                             END IF
  1471.                         END IF
  1472.                         GOSUB integratecom
  1473.                     END IF
  1474.                 NEXT
  1475.             NEXT
  1476.             VectorGroup(vecgroupid).LastVector = vectorindex
  1477.             GOSUB calculatecom
  1478.         NEXT
  1479.     NEXT
  1481.  
  1482. 'Sun
  1483. radius = 10
  1484. dx = .0628
  1485. dy = .0628
  1486. xl = 0: xr = 2 * pi
  1487. yl = 0: yr = pi
  1488. xrange = 1 + INT((-xl + xr) / dx)
  1489. yrange = 1 + INT((-yl + yr) / dy)
  1490. FOR i = 1 TO xrange STEP 10
  1491.     FOR j = 1 TO yrange STEP 10
  1492.         groupidticker = groupidticker + 1
  1493.         vecgroupid = groupidticker
  1494.         VectorGroup(vecgroupid).Identity = vecgroupid
  1495.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1496.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1497.         VectorGroup(vecgroupid).GroupName = "Sun"
  1498.         VectorGroup(vecgroupid).Visible = 0
  1499.         VectorGroup(vecgroupid).COMFixed = 1
  1500.         VectorGroup(vecgroupid).DIMx = radius
  1501.         VectorGroup(vecgroupid).DIMy = radius
  1502.         VectorGroup(vecgroupid).DIMz = radius
  1503.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1504.         FOR u = i TO i + 10 STEP 1
  1505.             FOR v = j TO j + 10 STEP 1
  1506.                 vectorindex = vectorindex + 1
  1507.                 theta = u * dx - dx
  1508.                 phi = v * dy - dy
  1509.                 vec3Dpos(vectorindex, 1) = radius * SIN(phi) * COS(theta)
  1510.                 vec3Dpos(vectorindex, 2) = radius * SIN(phi) * SIN(theta)
  1511.                 vec3Dpos(vectorindex, 3) = 90 + radius * COS(phi)
  1512.                 vec3Dvis(vectorindex) = 0
  1513.                 IF RND > .5 THEN
  1514.                     vec3Dcolor(vectorindex) = Sunglow
  1515.                 ELSE
  1516.                     vec3Dcolor(vectorindex) = SunsetOrange
  1517.                 END IF
  1518.                 GOSUB integratecom
  1519.             NEXT
  1520.         NEXT
  1521.         GOSUB integratecom
  1522.         VectorGroup(vecgroupid).LastVector = vectorindex
  1523.         GOSUB calculatecom
  1524.     NEXT
  1526.  
  1527. 'Moon
  1528. radius = 4
  1529. au = 60
  1530. dx = (2 * pi / radius) * .05
  1531. dy = (2 * pi / radius) * .05
  1532. xl = 0: xr = 2 * pi
  1533. yl = 0: yr = pi
  1534. xrange = 1 + INT((-xl + xr) / dx)
  1535. yrange = 1 + INT((-yl + yr) / dy)
  1536. groupidticker = groupidticker + 1
  1537. vecgroupid = groupidticker
  1538. VectorGroup(vecgroupid).Identity = vecgroupid
  1539. VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1540. VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1541. VectorGroup(vecgroupid).GroupName = "Moon"
  1542. VectorGroup(vecgroupid).Visible = 0
  1543. VectorGroup(vecgroupid).ForceAnimate = 1
  1544. VectorGroup(vecgroupid).COMFixed = 0
  1545. VectorGroup(vecgroupid).ROTx = 0
  1546. VectorGroup(vecgroupid).ROTy = 0
  1547. VectorGroup(vecgroupid).ROTz = 90
  1548. VectorGroup(vecgroupid).REVx = 1.5
  1549. VectorGroup(vecgroupid).REVy = 0
  1550. VectorGroup(vecgroupid).REVz = 0
  1551. VectorGroup(vecgroupid).DIMx = 2 * radius + 1
  1552. VectorGroup(vecgroupid).DIMy = 2 * radius + 1
  1553. VectorGroup(vecgroupid).DIMz = 2 * radius + 1
  1554. VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1555. FOR i = 1 TO xrange
  1556.     FOR j = 1 TO yrange
  1557.         vectorindex = vectorindex + 1
  1558.         theta = i * dx - dx
  1559.         phi = j * dy - dy
  1560.         vec3Dpos(vectorindex, 1) = au + radius * SIN(phi) * COS(theta)
  1561.         vec3Dpos(vectorindex, 2) = radius * SIN(phi) * SIN(theta)
  1562.         vec3Dpos(vectorindex, 3) = 90 + radius * COS(phi)
  1563.         vec3Danv(vectorindex, 1) = 0
  1564.         vec3Danv(vectorindex, 2) = 0
  1565.         vec3Danv(vectorindex, 3) = 1.5
  1566.         vec3Dvis(vectorindex) = 0
  1567.         IF RND > .5 THEN
  1568.             vec3Dcolor(vectorindex) = Gray
  1569.         ELSE
  1570.             vec3Dcolor(vectorindex) = PaleGoldenRod
  1571.         END IF
  1572.         GOSUB integratecom
  1573.         VectorGroup(vecgroupid).LastVector = vectorindex
  1574.         GOSUB calculatecom
  1575.     NEXT
  1577.  
  1578. 'Waves or Particles? (1)
  1579. FOR i = 1 TO 5 STEP 1
  1580.     FOR k = 1 TO 5 STEP 1
  1581.         groupidticker = groupidticker + 1
  1582.         vecgroupid = groupidticker
  1583.         VectorGroup(vecgroupid).Identity = vecgroupid
  1584.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1585.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1586.         VectorGroup(vecgroupid).GroupName = "Waves or Particles?"
  1587.         VectorGroup(vecgroupid).Visible = 0
  1588.         VectorGroup(vecgroupid).COMFixed = 1
  1589.         VectorGroup(vecgroupid).DIMx = 4
  1590.         VectorGroup(vecgroupid).DIMy = 1
  1591.         VectorGroup(vecgroupid).DIMz = 4
  1592.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1593.         FOR u = i TO i + 1 STEP .05
  1594.             FOR v = k TO k + 1 STEP .05
  1595.                 vectorindex = vectorindex + 1
  1596.                 vec3Dpos(vectorindex, 1) = 70 + 7 * u
  1597.                 vec3Dpos(vectorindex, 2) = 80 + 1 * COS((u ^ 2 - v ^ 2))
  1598.                 vec3Dpos(vectorindex, 3) = 10 + 7 * v
  1599.                 vec3Dvis(vectorindex) = 0
  1600.                 IF vec3Dpos(vectorindex, 2) < 80 THEN
  1601.                     vec3Dcolor(vectorindex) = DarkBlue
  1602.                 ELSE
  1603.                     vec3Dcolor(vectorindex) = DeepPink
  1604.                 END IF
  1605.                 GOSUB integratecom
  1606.             NEXT
  1607.         NEXT
  1608.         VectorGroup(vecgroupid).LastVector = vectorindex
  1609.         GOSUB calculatecom
  1610.     NEXT
  1612.  
  1613. 'Waves or Particles? (2)
  1614. FOR i = 1 TO 5 STEP 1
  1615.     FOR k = 1 TO 5 STEP 1
  1616.         groupidticker = groupidticker + 1
  1617.         vecgroupid = groupidticker
  1618.         VectorGroup(vecgroupid).Identity = vecgroupid
  1619.         VectorGroup(vecgroupid).Pointer = vecgroupid + 1
  1620.         VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1621.         VectorGroup(vecgroupid).GroupName = "Particles or Waves?"
  1622.         VectorGroup(vecgroupid).Visible = 0
  1623.         VectorGroup(vecgroupid).COMFixed = 1
  1624.         VectorGroup(vecgroupid).DIMx = 4
  1625.         VectorGroup(vecgroupid).DIMy = 1
  1626.         VectorGroup(vecgroupid).DIMz = 4
  1627.         VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1628.         FOR u = i TO i + 1 STEP .05
  1629.             FOR v = k TO k + 1 STEP .05
  1630.                 vectorindex = vectorindex + 1
  1631.                 vec3Dpos(vectorindex, 1) = -7 * u
  1632.                 vec3Dpos(vectorindex, 2) = 80 + 1 * COS(2 * ((u - 7) ^ 2 - (v - 5) ^ 2))
  1633.                 vec3Dpos(vectorindex, 3) = 10 + 7 * v
  1634.                 vec3Dvis(vectorindex) = 0
  1635.                 IF vec3Dpos(vectorindex, 2) < 80 THEN
  1636.                     vec3Dcolor(vectorindex) = Magenta
  1637.                 ELSE
  1638.                     vec3Dcolor(vectorindex) = Chocolate
  1639.                 END IF
  1640.                 GOSUB integratecom
  1641.             NEXT
  1642.         NEXT
  1643.         VectorGroup(vecgroupid).LastVector = vectorindex
  1644.         GOSUB calculatecom
  1645.     NEXT
  1647.  
  1648. '__ZZZ
  1649. groupidticker = groupidticker + 1
  1650. vecgroupid = groupidticker
  1651. VectorGroup(vecgroupid).Identity = vecgroupid
  1652. VectorGroup(vecgroupid).Pointer = -999
  1653. VectorGroup(vecgroupid).Lagger = vecgroupid - 1
  1654. VectorGroup(vecgroupid).GroupName = "__ZZZ"
  1655. VectorGroup(vecgroupid).COMFixed = 1
  1656. VectorGroup(vecgroupid).FirstVector = vectorindex + 1
  1657. FOR r = 1 TO 1
  1658.     vectorindex = vectorindex + 1
  1659.     vec3Dpos(vectorindex, 1) = 0
  1660.     vec3Dpos(vectorindex, 2) = 0
  1661.     vec3Dpos(vectorindex, 3) = -1000
  1662.     vec3Dcolor(vectorindex) = White
  1663.     GOSUB integratecom
  1665. VectorGroup(vecgroupid).LastVector = vectorindex
  1666. GOSUB calculatecom
  1668.  

screenshot.png

22
Utilities / Split1000 (simple string parser) Collaboration
« on: August 12, 2019, 08:50:44 am »
Split1000 (simple string parser)

Contributor(s): @bplus, @luke, @SMcNeill
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=1073.0
Tags: [string] [parsing]

Description:
This SUB will take a given N delimited string, and delimiter$ and creates an array of N+1 strings using the LBOUND of the given dynamic array to load.

Source Code:
Code: QB64: [Select]
  2. _TITLE "Split demo 2" ' started by B+ on 08-27-2019 to compare to Item$ demo
  3. 'new data setup structure to streamline code in setup
  4.  
  5. SCREEN _NEWIMAGE(400, 300, 32)
  6. 'globals seen inside SUBs and FUNCTIONs because SHARED
  7. DIM SHARED topIndex AS INTEGER '<< this is how many keywords we have
  8. 'VVVV REDIM means dynamic arrays, so can change in setup
  9. REDIM SHARED d(1 TO topIndex) AS STRING
  10.  
  11. 'locals just seen in following main code section
  13. REDIM LIST$(1 TO 1)
  14. setup
  15. FOR i = LBOUND(d) TO UBOUND(d) 'all the keywords are first word$ of d() data array
  16.     Split d(i), ",", LIST$()
  17.     PRINT "Data index:"; i; " "; "String Item:"; LBOUND(LIST$); LIST$(LBOUND(LIST$))
  18.     FOR j = LBOUND(LIST$) + 1 TO UBOUND(LIST$)
  19.         PRINT SPACE$(15); "String Item:"; j; LIST$(j) 'j-1 counts off the items after the first
  20.     NEXT
  21.     PRINT: INPUT "Ok... press enter "; w$
  22.     CLS
  24.  
  25. SUB setup '3rd method of data structure, this is meant to be edited over and over as add to a refine words and substitutes
  26.     topIndex = 5 ' <<< make modifications to d() and then update this number, that's it!
  27.     REDIM d(1 TO topIndex) AS STRING
  28.     d(1) = "Months,January,February,March,April,May,June,July,August,September,October,November,December"
  29.     d(2) = "Days,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday"
  30.     d(3) = "Holidays,NewYears Day,MLK Day,Valentine's Day,Easter,Mother's Day,Memorial Day,Father's Day,Independence Day,Bplus Day,Labor Day,Halloween,Thanksgiving,Christmas"
  31.     d(4) = "Test no further words/phrases in this line. (And the next test will do an empty string.)"
  32.     d(5) = ""
  34.  
  35. 'This SUB will take a given N delimited string, and delimiter$ and creates an array of N+1 strings using the LBOUND of the given dynamic array to load.
  36. 'notes: the loadMeArray() needs to be dynamic string array and will not change the LBOUND of the array it is given.
  37. SUB Split (SplitMeString AS STRING, delim AS STRING, loadMeArray() AS STRING)
  38.     DIM curpos AS LONG, arrpos AS LONG, LD AS LONG, dpos AS LONG 'fix use the Lbound the array already has
  39.     curpos = 1: arrpos = LBOUND(loadMeArray): LD = LEN(delim)
  40.     dpos = INSTR(curpos, SplitMeString, delim)
  41.     DO UNTIL dpos = 0
  42.         loadMeArray(arrpos) = MID$(SplitMeString, curpos, dpos - curpos)
  43.         arrpos = arrpos + 1
  44.         IF arrpos > UBOUND(loadMeArray) THEN REDIM _PRESERVE loadMeArray(LBOUND(loadMeArray) TO UBOUND(loadMeArray) + 1000) AS STRING
  45.         curpos = dpos + LD
  46.         dpos = INSTR(curpos, SplitMeString, delim)
  47.     LOOP
  48.     loadMeArray(arrpos) = MID$(SplitMeString, curpos)
  49.     REDIM _PRESERVE loadMeArray(LBOUND(loadMeArray) TO arrpos) AS STRING 'get the ubound correct
  51.  

screenshot.PNG

Bplus Edit: bplus version was collaboration of @bplus, @luke, @SMcNeill URL where the original discussion was started by Luke contains his complementary Join function. The above is bplus version with a couple of revisions tweaked into it since first posting.

23
Utilities / BIN$ (binary converter) by RhoSigma
« on: August 11, 2019, 01:50:39 pm »
BIN$ (binary converter)

Contributor(s): @RhoSigma
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=4261.msg136393#msg136393
Tags: [binary] [number conversion]

Description:
Although there are already many approaches for a BIN$ function in the Forum, some of my own, some from bplus and Steve McNeill and probably others, I felt there should be one, which best mimics the regular behavior and results of the built-in HEX$ and OCT$ functions, rather than focusing on speed or extended flexibility.

So here it is:
can handle positive and negative numbers
returns the binary string without &B prefix, just as HEX$ and OCT$ do
the result for positive numbers is just as long as needed, ie. no leading zeros are returned
the result length for negative numbers is determined by the integer range, which the given input number does fit in, eg. 8 for numbers in _BYTE range (down until -128), 16 for INTEGER (down until -32768) etc..

Source Code:
Code: QB64: [Select]
  1.     _TITLE "Bin$ Example"
  2.     '=== Full description for the Bin$() function is available
  3.     '=== in the separate HTML document.
  4.     '=====================================================================
  5.      
  6.     '-- some usage examples
  7.     PRINT "some simple numbers..."
  8.     num& = 5: PRINT num&; "= "; Bin$(num&)
  9.     num& = -4: PRINT num&; "= "; Bin$(num&)
  10.     num& = 32000: PRINT num&; "= "; Bin$(num&)
  11.     PRINT
  12.      
  13.     PRINT "works also with &B, &H and &O..."
  14.     PRINT " &B1101 = "; Bin$(&B1101)
  15.     PRINT " &H211 = "; Bin$(&H211)
  16.     PRINT " &O377 = "; Bin$(&O377)
  17.     PRINT
  18.      
  19.     PRINT "and even with floating points (converts integer part only)..."
  20.     num# = 123.456: PRINT num#; "= "; Bin$(num#)
  21.     num# = -60000.25: PRINT num#; "= "; Bin$(num#)
  22.     num# = 0.5: PRINT num#; "= "; Bin$(num#)
  23.     PRINT
  24.      
  25.     '-- done
  26.     END
  27.      
  28.      
  29.      
  30.      
  31.     '--- Full description available in separate HTML document.
  32.     '---------------------------------------------------------------------
  33.     FUNCTION Bin$ (value&&)
  34.     '--- option _explicit requirements ---
  35.     DIM temp~&&, binStr$, charPos%, highPos%
  36.     '--- init ---
  37.     temp~&& = value&&
  38.     binStr$ = STRING$(64, "0"): charPos% = 64: highPos% = 64
  39.     '--- convert ---
  40.     DO
  41.         IF (temp~&& AND 1) THEN MID$(binStr$, charPos%, 1) = "1": highPos% = charPos%
  42.         charPos% = charPos% - 1: temp~&& = temp~&& \ 2
  43.     LOOP UNTIL temp~&& = 0
  44.     '--- adjust negative size ---
  45.     IF value&& < 0 THEN
  46.         IF -value&& < &H0080000000~&& THEN highPos% = 33
  47.         IF -value&& < &H0000008000~&& THEN highPos% = 49
  48.         IF -value&& < &H0000000080~&& THEN highPos% = 57
  49.     END IF
  50.     '--- set result ---
  51.     Bin$ = MID$(binStr$, highPos%)
  53.      
  54.  

 
screenshot.jpg
 

 

Librarian's note: RhoSigma is author of the &B updates to QB64, and this BIN$ should serve as best complement to &B thus the replacement of the old BIN$ code; screenshot contains new range of numbers that this BIN$ can do.

24
Utilities / _MEM Sort by SMcNeill
« on: August 11, 2019, 12:51:49 pm »
_MEM Sort

Contributor(s): @SMcNeill
Source: qb64 @ Freeformus
URL: http://qb64.freeforums.net/thread/28/mem-sort
Tags: [_MEM] [sort]

Description:
The following routine is a quick and efficient way to sort almost any type of array, regardless of data type. (The one thing it doesn't sort is variable-length strings, as _MEM doesn't support those at all.)

Source Code:
Code: QB64: [Select]
  1. SCREEN _NEWIMAGE(1280, 720, 256)
  3.  
  5. DIM x(5) AS _BYTE
  7. DIM z(5) AS STRING * 5
  8.  
  9. 'Let's see if we can sort the integer array
  10. 'Initialize Data
  11. FOR i = 0 TO 5: x(i) = RND * 100: PRINT x(i),: NEXT: PRINT
  12. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  13.  
  14. 'Sort
  15. m = _MEM(x())
  16. Sort m
  18.  
  19. 'Result
  20. FOR i = 0 TO 5: PRINT x(i),: NEXT: PRINT
  21.  
  22. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  25.  
  26.  
  27. 'Try the same routine with a different data type array to sort
  28. 'Initialize Data
  29. FOR i = 0 TO 7: y(i) = RND * 100: PRINT y(i),: NEXT
  31. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  32.  
  33. 'Sort
  34. m = _MEM(y())
  35. Sort m
  37.  
  38. 'Result
  39. FOR i = 0 TO 7: PRINT y(i),: NEXT: PRINT
  40. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  43.  
  44.  
  45. 'To test with fixed length string arrays
  46. z(0) = "Doggy": z(1) = "Pudding": z(2) = "Frog ": z(3) = "test2": z(4) = "Test2": z(5) = "test1"
  47. FOR i = 0 TO 5: PRINT z(i),: NEXT: PRINT
  48. PRINT "----------------------------------------------------------------------------------------------------------------------------------------------------------------"
  49.  
  50. m = _MEM(z())
  51. Sort m
  53.  
  54. 'Result
  55. FOR i = 0 TO 5: PRINT z(i),: NEXT: PRINT
  56.  
  59.  
  60.  
  61.  
  62. SUB Sort (m AS _MEM)
  64.     $IF 64BIT THEN
  65.         DIM ES AS _INTEGER64, EC AS _INTEGER64
  66.     $ELSE
  67.         DIM ES AS LONG, EC AS LONG
  68.     $END IF
  69.  
  70.     IF NOT m.TYPE AND 65536 THEN EXIT SUB 'We won't work without an array
  71.     IF m.TYPE AND 1024 THEN DataType = 10
  72.     IF m.TYPE AND 1 THEN DataType = DataType + 1
  73.     IF m.TYPE AND 2 THEN DataType = DataType + 2
  74.     IF m.TYPE AND 4 THEN IF m.TYPE AND 128 THEN DataType = DataType + 4 ELSE DataType = 3
  75.     IF m.TYPE AND 8 THEN IF m.TYPE AND 128 THEN DataType = DataType + 8 ELSE DataType = 5
  76.     IF m.TYPE AND 32 THEN DataType = 6
  77.     IF m.TYPE AND 512 THEN DataType = 7
  78.  
  79.     'Convert our offset data over to something we can work with
  80.     DIM m1 AS _MEM: m1 = _MEMNEW(LEN(ES))
  81.     _MEMPUT m1, m1.OFFSET, m.ELEMENTSIZE: _MEMGET m1, m1.OFFSET, ES 'Element Size
  82.     _MEMPUT m1, m1.OFFSET, m.SIZE: _MEMGET m1, m1.OFFSET, EC 'Element Count will temporily hold the WHOLE array size
  83.     _MEMFREE m1
  84.  
  85.     EC = EC / ES - 1 'Now we take the whole element size / the size of the elements and get our actual element count.  We subtract 1 so our arrays start at 0 and not 1.
  86.     'And work with it!
  87.     DIM o AS _OFFSET, o1 AS _OFFSET, counter AS _UNSIGNED LONG
  88.  
  89.     SELECT CASE DataType
  90.         CASE 1 'BYTE
  91.             DIM temp1(-128 TO 127) AS _UNSIGNED LONG
  92.             DIM t1 AS _BYTE
  93.             i = 0
  94.             DO
  95.                 _MEMGET m, m.OFFSET + i, t1
  96.                 temp1(t1) = temp1(t1) + 1
  97.                 i = i + 1
  98.             LOOP UNTIL i > EC
  99.             i1 = -128
  100.             DO
  101.                 DO UNTIL temp1(i1) = 0
  102.                     _MEMPUT m, m.OFFSET + counter, i1 AS _BYTE
  103.                     counter = counter + 1
  104.                     temp1(i1) = temp1(i1) - 1
  105.                     IF counter > EC THEN EXIT SUB
  106.                 LOOP
  107.                 i1 = i1 + 1
  108.             LOOP UNTIL i1 > 127
  109.         CASE 2: 'INTEGER
  110.             DIM temp2(-32768 TO 32767) AS _UNSIGNED LONG
  111.             DIM t2 AS INTEGER
  112.             i = 0
  113.             DO
  114.                 _MEMGET m, m.OFFSET + i * 2, t2
  115.                 temp2(t2) = temp2(t2) + 1
  116.                 i = i + 1
  117.             LOOP UNTIL i > EC
  118.             i1 = -32768
  119.             DO
  120.                 DO UNTIL temp2(i1) = 0
  121.                     _MEMPUT m, m.OFFSET + counter * 2, i1 AS INTEGER
  122.                     counter = counter + 1
  123.                     temp2(i1) = temp2(i1) - 1
  124.                     IF counter > EC THEN EXIT SUB
  125.                 LOOP
  126.                 i1 = i1 + 1
  127.             LOOP UNTIL i1 > 32767
  128.         CASE 3 'SINGLE
  129.             DIM T3a AS SINGLE, T3b AS SINGLE
  130.             gap = EC
  131.             DO
  132.                 gap = 10 * gap \ 13
  133.                 IF gap < 1 THEN gap = 1
  134.                 i = 0
  135.                 swapped = 0
  136.                 DO
  137.                     o = m.OFFSET + i * 4
  138.                     o1 = m.OFFSET + (i + gap) * 4
  139.                     IF _MEMGET(m, o, SINGLE) > _MEMGET(m, o1, SINGLE) THEN
  140.                         _MEMGET m, o1, T3a
  141.                         _MEMGET m, o, T3b
  142.                         _MEMPUT m, o1, T3b
  143.                         _MEMPUT m, o, T3a
  144.                         swapped = -1
  145.                     END IF
  146.                     i = i + 1
  147.                 LOOP UNTIL i + gap > EC
  148.             LOOP UNTIL gap = 1 AND swapped = 0
  149.         CASE 4 'LONG
  150.             DIM T4a AS LONG, T4b AS LONG
  151.             gap = EC
  152.             DO
  153.                 gap = 10 * gap \ 13
  154.                 IF gap < 1 THEN gap = 1
  155.                 i = 0
  156.                 swapped = 0
  157.                 DO
  158.                     o = m.OFFSET + i * 4
  159.                     o1 = m.OFFSET + (i + gap) * 4
  160.                     IF _MEMGET(m, o, LONG) > _MEMGET(m, o1, LONG) THEN
  161.                         _MEMGET m, o1, T4a
  162.                         _MEMGET m, o, T4b
  163.                         _MEMPUT m, o1, T4b
  164.                         _MEMPUT m, o, T4a
  165.                         swapped = -1
  166.                     END IF
  167.                     i = i + 1
  168.                 LOOP UNTIL i + gap > EC
  169.             LOOP UNTIL gap = 1 AND swapped = 0
  170.         CASE 5 'DOUBLE
  171.             DIM T5a AS DOUBLE, T5b AS DOUBLE
  172.             gap = EC
  173.             DO
  174.                 gap = 10 * gap \ 13
  175.                 IF gap < 1 THEN gap = 1
  176.                 i = 0
  177.                 swapped = 0
  178.                 DO
  179.                     o = m.OFFSET + i * 8
  180.                     o1 = m.OFFSET + (i + gap) * 8
  181.                     IF _MEMGET(m, o, DOUBLE) > _MEMGET(m, o1, DOUBLE) THEN
  182.                         _MEMGET m, o1, T5a
  183.                         _MEMGET m, o, T5b
  184.                         _MEMPUT m, o1, T5b
  185.                         _MEMPUT m, o, T5a
  186.                         swapped = -1
  187.                     END IF
  188.                     i = i + 1
  189.                 LOOP UNTIL i + gap > EC
  190.             LOOP UNTIL gap = 1 AND swapped = 0
  191.         CASE 6 ' _FLOAT
  192.             DIM T6a AS _FLOAT, T6b AS _FLOAT
  193.             gap = EC
  194.             DO
  195.                 gap = 10 * gap \ 13
  196.                 IF gap < 1 THEN gap = 1
  197.                 i = 0
  198.                 swapped = 0
  199.                 DO
  200.                     o = m.OFFSET + i * 32
  201.                     o1 = m.OFFSET + (i + gap) * 32
  202.                     IF _MEMGET(m, o, _FLOAT) > _MEMGET(m, o1, _FLOAT) THEN
  203.                         _MEMGET m, o1, T6a
  204.                         _MEMGET m, o, T6b
  205.                         _MEMPUT m, o1, T6b
  206.                         _MEMPUT m, o, T6a
  207.                         swapped = -1
  208.                     END IF
  209.                     i = i + 1
  210.                 LOOP UNTIL i + gap > EC
  211.             LOOP UNTIL gap = 1 AND swapped = 0
  212.         CASE 7 'String
  213.             DIM T7a AS STRING, T7b AS STRING, T7c AS STRING
  214.             T7a = SPACE$(ES): T7b = SPACE$(ES): T7c = SPACE$(ES)
  215.             gap = EC
  216.             DO
  217.                 gap = INT(gap / 1.247330950103979)
  218.                 IF gap < 1 THEN gap = 1
  219.                 i = 0
  220.                 swapped = 0
  221.                 DO
  222.                     o = m.OFFSET + i * ES
  223.                     o1 = m.OFFSET + (i + gap) * ES
  224.                     _MEMGET m, o, T7a
  225.                     _MEMGET m, o1, T7b
  226.                     IF T7a > T7b THEN
  227.                         T7c = T7b
  228.                         _MEMPUT m, o1, T7a
  229.                         _MEMPUT m, o, T7c
  230.                         swapped = -1
  231.                     END IF
  232.                     i = i + 1
  233.                 LOOP UNTIL i + gap > EC
  234.             LOOP UNTIL gap = 1 AND swapped = false
  235.         CASE 8 '_INTEGER64
  236.             DIM T8a AS _INTEGER64, T8b AS _INTEGER64
  237.             gap = EC
  238.             DO
  239.                 gap = 10 * gap \ 13
  240.                 IF gap < 1 THEN gap = 1
  241.                 i = 0
  242.                 swapped = 0
  243.                 DO
  244.                     o = m.OFFSET + i * 8
  245.                     o1 = m.OFFSET + (i + gap) * 8
  246.                     IF _MEMGET(m, o, _INTEGER64) > _MEMGET(m, o1, _INTEGER64) THEN
  247.                         _MEMGET m, o1, T8a
  248.                         _MEMGET m, o, T8b
  249.                         _MEMPUT m, o1, T8b
  250.                         _MEMPUT m, o, T8a
  251.                         swapped = -1
  252.                     END IF
  253.                     i = i + 1
  254.                 LOOP UNTIL i + gap > EC
  255.             LOOP UNTIL gap = 1 AND swapped = 0
  256.         CASE 11: '_UNSIGNED _BYTE
  257.             DIM temp11(0 TO 255) AS _UNSIGNED LONG
  258.             DIM t11 AS _UNSIGNED _BYTE
  259.             i = 0
  260.             DO
  261.                 _MEMGET m, m.OFFSET + i, t11
  262.                 temp11(t11) = temp11(t11) + 1
  263.                 i = i + 1
  264.             LOOP UNTIL i > EC
  265.             i1 = 0
  266.             DO
  267.                 DO UNTIL temp11(i1) = 0
  268.                     _MEMPUT m, m.OFFSET + counter, i1 AS _UNSIGNED _BYTE
  269.                     counter = counter + 1
  270.                     temp11(i1) = temp11(i1) - 1
  271.                     IF counter > EC THEN EXIT SUB
  272.                 LOOP
  273.                 i1 = i1 + 1
  274.             LOOP UNTIL i1 > 255
  275.         CASE 12 '_UNSIGNED INTEGER
  276.             DIM temp12(0 TO 65535) AS _UNSIGNED LONG
  277.             DIM t12 AS _UNSIGNED INTEGER
  278.             i = 0
  279.             DO
  280.                 _MEMGET m, m.OFFSET + i * 2, t12
  281.                 temp12(t12) = temp12(t12) + 1
  282.                 i = i + 1
  283.             LOOP UNTIL i > EC
  284.             i1 = 0
  285.             DO
  286.                 DO UNTIL temp12(i1) = 0
  287.                     _MEMPUT m, m.OFFSET + counter * 2, i1 AS _UNSIGNED INTEGER
  288.                     counter = counter + 1
  289.                     temp12(i1) = temp12(i1) - 1
  290.                     IF counter > EC THEN EXIT SUB
  291.                 LOOP
  292.                 i1 = i1 + 1
  293.             LOOP UNTIL i1 > 65535
  294.         CASE 14 '_UNSIGNED LONG
  295.             DIM T14a AS _UNSIGNED LONG, T14b AS _UNSIGNED LONG
  296.             gap = EC
  297.             DO
  298.                 gap = 10 * gap \ 13
  299.                 IF gap < 1 THEN gap = 1
  300.                 i = 0
  301.                 swapped = 0
  302.                 DO
  303.                     o = m.OFFSET + i * 4
  304.                     o1 = m.OFFSET + (i + gap) * 4
  305.                     IF _MEMGET(m, o, _UNSIGNED LONG) > _MEMGET(m, o1, _UNSIGNED LONG) THEN
  306.                         _MEMGET m, o1, T14a
  307.                         _MEMGET m, o, T14b
  308.                         _MEMPUT m, o1, T14b
  309.                         _MEMPUT m, o, T14a
  310.                         swapped = -1
  311.                     END IF
  312.                     i = i + 1
  313.                 LOOP UNTIL i + gap > EC
  314.             LOOP UNTIL gap = 1 AND swapped = 0
  315.         CASE 18: '_UNSIGNED _INTEGER64
  316.             DIM T18a AS _UNSIGNED _INTEGER64, T18b AS _UNSIGNED _INTEGER64
  317.             gap = EC
  318.             DO
  319.                 gap = 10 * gap \ 13
  320.                 IF gap < 1 THEN gap = 1
  321.                 i = 0
  322.                 swapped = 0
  323.                 DO
  324.                     o = m.OFFSET + i * 8
  325.                     o1 = m.OFFSET + (i + gap) * 8
  326.                     IF _MEMGET(m, o, _UNSIGNED _INTEGER64) > _MEMGET(m, o1, _UNSIGNED _INTEGER64) THEN
  327.                         _MEMGET m, o1, T18a
  328.                         _MEMGET m, o, T18b
  329.                         _MEMPUT m, o1, T18b
  330.                         _MEMPUT m, o, T18a
  331.                         swapped = -1
  332.                     END IF
  333.                     i = i + 1
  334.                 LOOP UNTIL i + gap > EC
  335.             LOOP UNTIL gap = 1 AND swapped = 0
  336.     END SELECT
  338.  

screenshot.png

25
Utilities / Extended (Unix Epoch) Timer by SMcNeill
« on: August 11, 2019, 05:29:22 am »
Extended (Unix Epoch) Timer

Contributor(s): @SMcNeill
Source: qb64 @ Freeforums
URL: http://qb64.freeforums.net/thread/20/extended-timer-uet
Tags: [date], [time], [timer]

Description:
The Unix Epoch Time is a popular timekeeping standard based on the number of seconds elapsed since midnight on Jan 1, 1970 in Greenwich, London. The Extended Timer function below will calculate the (relative) Unix epoch time from the local system time and date.

Source Code:
Code: QB64: [Select]
  1. SHELL "https://www.epochconverter.com/"
  3.     CLS
  4.     PRINT TIMER, INT(ExtendedTimer)
  5.     PRINT "Compare to the time at https://www.epochconverter.com/"
  6.     _DISPLAY
  7.     _LIMIT 10
  9.  
  10. FUNCTION ExtendedTimer##
  11.     d$ = DATE$
  12.     l = INSTR(d$, "-")
  13.     l1 = INSTR(l + 1, d$, "-")
  14.     m = VAL(LEFT$(d$, l))
  15.     d = VAL(MID$(d$, l + 1))
  16.     y = VAL(MID$(d$, l1 + 1)) - 1970
  17.     FOR i = 1 TO m
  18.         SELECT CASE i 'Add the number of days for each previous month passed
  19.             CASE 1: d = d 'January doestn't have any carry over days.
  20.             CASE 2, 4, 6, 8, 9, 11: d = d + 31
  21.             CASE 3: d = d + 28
  22.             CASE 5, 7, 10, 12: d = d + 30
  23.         END SELECT
  24.     NEXT
  25.     FOR i = 1 TO y
  26.         d = d + 365
  27.     NEXT
  28.     FOR i = 2 TO y STEP 4
  29.         IF m > 2 THEN d = d + 1 'add an extra day for leap year every 4 years, starting in 1970
  30.     NEXT
  31.     d = d - 1 'for year 2000
  32.     s~&& = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
  33.     ExtendedTimer## = (s~&& + TIMER)
  35.  

screenshot.png

26
Programs / Samples/Toolbox re-awakening. Call for entries.
« on: August 10, 2019, 08:49:24 pm »
As the topic says, it's time we expand our Samples Gallery and Toolbox. Please reply to this post with links to existing threads in Programs with code that qualifies.

First things first though - is everyone happy with the filled circle/ellipse code up there?

27
2D/3D Graphics / Inverse Julia Fractal Explorer by Zom-B
« on: February 06, 2019, 08:46:40 pm »
Inverse Julia Fractal Explorer

Author: Zom-B
Source: [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there] Forum
URL: /forum/index.php?topic=1132.0]http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=1132.0
Version: QB64
Tags: [fractal] [inverse julia set]

Description:
The longer you hold your mouse at one position, the more it starts to glow.

Source Code:
Code: QB64: [Select]
  1. DEFSNG A-Z
  2.  
  3. DIM SHARED px, py, cx, cy
  4.  
  5. SCREEN _NEWIMAGE(1024, 768, 256)
  6.  
  7. COLOR 255
  8. FOR i% = 0 TO 255
  9.     r% = INT((i% / 255) ^ .9323335 * 255)
  10.     g% = INT((i% / 255) ^ 1.576838 * 255)
  11.     b% = INT((i% / 255) ^ 3.484859 * 255)
  12.     _PALETTECOLOR i%, _RGB32(r%, g%, b%)
  14.  
  15. '####################################################################################################################
  16.  
  17. setSeed _MOUSEX, _MOUSEY
  18.  
  21.         n% = 0
  22.         _DISPLAY
  23.         CLS
  24.         setSeed _MOUSEX, _MOUSEY
  25.     END IF
  26.  
  27.     DO 'Marsaglia polar method for random gaussian
  28.         u = RND * 2 - 1
  29.         v = RND2 * 2 - 1
  30.         s = u * u + v * v
  31.     LOOP WHILE s >= 1 OR s = 0
  32.     s = SQR(-2 * LOG(s) / s) * 0.5
  33.     u = u * s * 2
  34.     v = v * s * 2
  35.  
  36.     calcInverseJulia u, v, 1
  37.  
  38.     n% = n% + 1
  39.     IF n% = 300 THEN
  40.         n% = 0
  41.         _DISPLAY
  42.     END IF
  44.  
  45. '####################################################################################################################
  46.  
  47. SUB setSeed (x, y)
  48.     cx = (x / _WIDTH - 0.5) * 4
  49.     cy = (0.5 - y / _HEIGHT) * 3
  51.  
  52. '####################################################################################################################
  53.  
  54. SUB calcInverseJulia (x, y, depth%)
  55.     re = x - cx
  56.     im = y - cy
  57.  
  58.     a = SQR(re * re + im * im)
  59.     x = SQR((a + re) * 0.5)
  60.     IF im < 0 THEN y = -SQR((a - re) * 0.5) ELSE y = SQR((a - re) * 0.5)
  61.  
  62.     PSET2 (x / 4 + 0.5) * _WIDTH, (0.5 - y / 3) * _HEIGHT, 0.02
  63.     PSET2 (x / -4 + 0.5) * _WIDTH, (0.5 + y / 3) * _HEIGHT, 0.02
  64.     IF depth% < 32 THEN
  65.         IF RND < 0.5 THEN calcInverseJulia x, y, depth% + 1 ELSE calcInverseJulia -x, -y, depth% + 1
  66.     END IF
  68.  
  69. '####################################################################################################################
  70.  
  71. SUB PSET2 (x, y, i)
  72.     x% = INT(x)
  73.     y% = INT(y)
  74.     dx = x - x%
  75.     dy = y - y%
  76.  
  77.     q3 = dx * dy
  78.     q2 = (1 - dx) * dy
  79.     q1 = dx * (1 - dy)
  80.     q0 = (1 - dx) * (1 - dy)
  81.  
  82.     PSET (x%, y%), (1 - (1 - q0 * i) * (1 - POINT(x%, y%) / 255)) * 255
  83.     PSET (x% + 1, y%), (1 - (1 - q1 * i) * (1 - POINT(x% + 1, y%) / 255)) * 255
  84.     PSET (x%, y% + 1), (1 - (1 - q2 * i) * (1 - POINT(x%, y% + 1) / 255)) * 255
  85.     PSET (x% + 1, y% + 1), (1 - (1 - q3 * i) * (1 - POINT(x% + 1, y% + 1) / 255)) * 255
  87.  
  88. '####################################################################################################################
  89.  
  91.     seed&& = (25214903917&& * seed&& + 11&&) MOD 281474976710656&&
  92.     RND2 = seed&& / 281474976710656&&
  94.  

inversejulia.png

28
2D/3D Graphics / Julia Rings by Relsoft
« on: February 06, 2019, 08:38:50 pm »
Julia Rings

Author: Relsoft
Source: [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there] Forum
URL: /forum/index.php?topic=128.0]http://www.[abandoned, outdated and now likely malicious qb64 dot net website - don’t go there]/forum/index.php?topic=128.0
Version: QB64
Tags: [fractal] [julia set]

Description:
Automated Julia set explorer.

Source Code:
Code: QB64: [Select]
  1. ' The Lord of the Julia Rings
  2. ' The Fellowship of the Julia Ring
  3. ' Free Basic
  4. ' Relsoft
  5. ' Rel.BetterWebber.com
  6. '
  7. ' Converted to QB64 format by Galleon (FB specific code commented)
  8.  
  9. DEFLNG A-Z
  10.  
  11. ''$include: 'TinyPTC.bi'
  12. ''$include: 'user32.bi'
  13.  
  14. 'option explicit
  15.  
  16. CONST SCR_WIDTH = 320 * 2
  17. CONST SCR_HEIGHT = 240 * 2
  18.  
  19. CONST SCR_SIZE = SCR_WIDTH * SCR_HEIGHT
  20. CONST SCR_MIDX = SCR_WIDTH \ 2
  21. CONST SCR_MIDY = SCR_HEIGHT \ 2
  22.  
  23. CONST FALSE = 0, TRUE = NOT FALSE
  24.  
  25. CONST PI = 3.141593
  26. CONST MAXITER = 20
  27. CONST MAXSIZE = 4
  28.  
  29. DIM Buffer(SCR_SIZE - 1) AS LONG
  30. DIM Lx(SCR_WIDTH - 1) AS SINGLE
  31. DIM Ly(SCR_HEIGHT - 1) AS SINGLE
  32. DIM sqrt(SCR_SIZE - 1) AS SINGLE
  33.  
  34. 'if( ptc_open( "FreeBASIC Julia (Relsoft)", SCR_WIDTH, SCR_HEIGHT ) = 0 ) then
  35. '   end -1
  36. 'end if
  37.  
  38. SCREEN _NEWIMAGE(SCR_WIDTH, SCR_HEIGHT, 32), , 1, 0
  39.  
  40. DIM px AS LONG, py AS LONG
  42. DIM xmin AS SINGLE, xmax AS SINGLE, ymin AS SINGLE, ymax AS SINGLE
  43. DIM theta AS SINGLE
  44. DIM deltax AS SINGLE, deltay AS SINGLE
  46. DIM xsquare AS SINGLE, ysquare AS SINGLE
  47. DIM ytemp AS SINGLE
  48. DIM temp1 AS SINGLE, temp2 AS SINGLE
  49. DIM i AS LONG, pixel AS LONG
  52. DIM r AS LONG, g AS LONG, b AS LONG
  53. DIM red AS LONG, grn AS LONG, blu AS LONG
  54. DIM tmp AS LONG, i_last AS LONG
  55.  
  57. DIM cmagsq AS SINGLE
  60. DIM drad_L AS SINGLE
  61. DIM drad_H AS SINGLE
  63. DIM ztoti AS LONG
  64.  
  65. 'pointers to array "buffer"
  66. 'dim p_buffer as long ptr, p_bufferl as long ptr
  67.  
  68. xmin = -2.0
  69. xmax = 2.0
  70. ymin = -1.5
  71. ymax = 1.5
  72.  
  73. deltax = (xmax - xmin) / (SCR_WIDTH - 1)
  74. deltay = (ymax - ymin) / (SCR_HEIGHT - 1)
  75.  
  76. FOR i = 0 TO SCR_WIDTH - 1
  77.     Lx(i) = xmin + i * deltax
  79.  
  80. FOR i = 0 TO SCR_HEIGHT - 1
  81.     Ly(i) = ymax - i * deltay
  83.  
  84. FOR i = 0 TO SCR_SIZE - 1
  85.     sqrt(i) = SQR(i)
  87.  
  88. 'dim hwnd as long
  89. 'hwnd = GetActiveWindow
  90.  
  91. DIM stime AS LONG, Fps AS SINGLE, Fps2 AS SINGLE
  92.  
  93. stime = TIMER
  94.  
  96.  
  97.     '    p_buffer = @buffer(0)
  98.     '    p_bufferl = @buffer(SCR_SIZE-1)
  99.  
  100.     frame = (frame + 1) AND &H7FFFFFFF
  101.     theta = frame * PI / 180
  102.  
  103.     p = COS(theta) * SIN(theta * .7)
  104.     q = SIN(theta) + SIN(theta)
  105.     p = p * .6
  106.     q = q * .6
  107.  
  108.     cmag = SQR(p * p + q * q)
  109.     cmagsq = (p * p + q * q)
  110.     drad = 0.04
  111.     drad_L = (cmag - drad)
  112.     drad_L = drad_L * drad_L
  113.     drad_H = (cmag + drad)
  114.     drad_H = drad_H * drad_H
  115.  
  116.     FOR py = 0 TO (SCR_HEIGHT \ 2) - 1
  117.         ty = Ly(py)
  118.         FOR px = 0 TO SCR_WIDTH - 1
  119.             x = Lx(px)
  120.             y = ty
  121.             xsquare = 0
  122.             ysquare = 0
  123.             ztot = 0
  124.             i = 0
  125.             WHILE (i < MAXITER) AND ((xsquare + ysquare) < MAXSIZE)
  126.                 xsquare = x * x
  127.                 ysquare = y * y
  128.                 ytemp = x * y * 2
  129.                 x = xsquare - ysquare + p
  130.                 y = ytemp + q
  131.                 zmag = (x * x + y * y)
  132.                 IF (zmag < drad_H) AND (zmag > drad_L) AND (i > 0) THEN
  133.                     ztot = ztot + (1 - (ABS(zmag - cmagsq) / drad))
  134.                     i_last = i
  135.                 END IF
  136.                 i = i + 1
  137.                 IF zmag > 4.0 THEN
  138.                     EXIT WHILE
  139.                 END IF
  140.             WEND
  141.  
  142.             IF ztot > 0 THEN
  143.                 i = CINT(SQR(ztot) * 500)
  144.             ELSE
  145.                 i = 0
  146.             END IF
  147.             IF i < 256 THEN
  148.                 red = i
  149.             ELSE
  150.                 red = 255
  151.             END IF
  152.  
  153.             IF i < 512 AND i > 255 THEN
  154.                 grn = i - 256
  155.             ELSE
  156.                 IF i >= 512 THEN
  157.                     grn = 255
  158.                 ELSE
  159.                     grn = 0
  160.                 END IF
  161.             END IF
  162.  
  163.             IF i <= 768 AND i > 511 THEN
  164.                 blu = i - 512
  165.             ELSE
  166.                 IF i >= 768 THEN
  167.                     blu = 255
  168.                 ELSE
  169.                     blu = 0
  170.                 END IF
  171.             END IF
  172.  
  173.             tmp = INT((red + grn + blu) \ 3)
  174.             red = INT((red + grn + tmp) \ 3)
  175.             grn = INT((grn + blu + tmp) \ 3)
  176.             blu = INT((blu + red + tmp) \ 3)
  177.  
  178.             SELECT CASE (i_last MOD 3)
  179.                 CASE 1
  180.                     tmp = red
  181.                     red = grn
  182.                     grn = blu
  183.                     blu = tmp
  184.                 CASE 2
  185.                     tmp = red
  186.                     blu = grn
  187.                     red = blu
  188.                     grn = tmp
  189.             END SELECT
  190.  
  191.             'pixel = red shl 16 or grn shl 8 or blu
  192.             '*p_buffer = pixel
  193.             '*p_bufferl = pixel
  194.             'p_buffer = p_buffer + Len(long)
  195.             'p_bufferl = p_bufferl - Len(long)
  196.             pixel = _RGB32(red, grn, blu)
  197.             PSET (px, py), pixel
  198.             PSET (SCR_WIDTH - 1 - px, SCR_HEIGHT - 1 - py), pixel
  199.  
  200.         NEXT px
  201.     NEXT py
  202.  
  203.     'calc fps
  204.     Fps = Fps + 1
  205.     IF stime + 1 < TIMER THEN
  206.         Fps2 = Fps
  207.         Fps = 0
  208.         stime = TIMER
  209.     END IF
  210.  
  211.     '    SetWindowText hwnd, "FreeBasic Julia Rings FPS:" + str$(Fps2)
  212.     LOCATE 1, 1: PRINT "QB64 Julia Rings FPS:" + STR$(Fps2)
  213.  
  214.     'ptc_update @buffer(0)
  215.     PCOPY 1, 0
  216.  
  218.  
  219. 'ptc_close
  220.  
  222.  

julia.png

29
Games / Tetris by _vince
« on: September 27, 2018, 10:37:42 pm »
Tetris

Author: @_vince
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=626.0
Version: 2018
Tags: [2d], [game], [tetris]

Description:
clean and simple tetris implementation. you can change variables size, sw, and sh for custom board sizes.

20:55 < _vince> ive said it before but i think tetris is the ultimate test of a
                programmer
20:55 < _vince> as it combines all programming concepts but doesnt demand any
                specialized knowledge

controls:
* arrow keys: movement, up: rotate
* shift + left/right/down: hard left/right/drop
* spacebar: hard drop
* +/-: change speed
* p: pause
* Enter: restart
* Esc: quit

Source Code:
Code: QB64: [Select]
  2. deflng a-z
  3.  
  4. dim shared piece(6, 3, 1)
  5. dim shared piece_color(6)
  6. dim shared size, sw, sh
  7.  
  8. size = 35
  9. sw = 10
  10. sh = 20
  11.  
  12. redim shared board(sw - 1, sh - 1)
  13.  
  14. piece(0,0,0)=0: piece(0,1,0)=1: piece(0,2,0)=1: piece(0,3,0)=0
  15. piece(0,0,1)=0: piece(0,1,1)=1: piece(0,2,1)=1: piece(0,3,1)=0
  16. piece(1,0,0)=1: piece(1,1,0)=1: piece(1,2,0)=1: piece(1,3,0)=1
  17. piece(1,0,1)=0: piece(1,1,1)=0: piece(1,2,1)=0: piece(1,3,1)=0
  18. piece(2,0,0)=0: piece(2,1,0)=0: piece(2,2,0)=1: piece(2,3,0)=1
  19. piece(2,0,1)=0: piece(2,1,1)=1: piece(2,2,1)=1: piece(2,3,1)=0
  20. piece(3,0,0)=0: piece(3,1,0)=1: piece(3,2,0)=1: piece(3,3,0)=0
  21. piece(3,0,1)=0: piece(3,1,1)=0: piece(3,2,1)=1: piece(3,3,1)=1
  22. piece(4,0,0)=0: piece(4,1,0)=1: piece(4,2,0)=1: piece(4,3,0)=1
  23. piece(4,0,1)=0: piece(4,1,1)=0: piece(4,2,1)=1: piece(4,3,1)=0
  24. piece(5,0,0)=0: piece(5,1,0)=1: piece(5,2,0)=1: piece(5,3,0)=1
  25. piece(5,0,1)=0: piece(5,1,1)=1: piece(5,2,1)=0: piece(5,3,1)=0
  26. piece(6,0,0)=0: piece(6,1,0)=1: piece(6,2,0)=1: piece(6,3,0)=1
  27. piece(6,0,1)=0: piece(6,1,1)=0: piece(6,2,1)=0: piece(6,3,1)=1
  28.  
  29. screen _newimage(sw*size, sh*size, 32)
  30.  
  31. piece_color(0) = _rgb(0,200,0)
  32. piece_color(1) = _rgb(200,0,0)
  33. piece_color(2) = _rgb(156,85,211)
  34. piece_color(3) = _rgb(219,112,147)
  35. piece_color(4) = _rgb(0,100,250)
  36. piece_color(5) = _rgb(230,197,92)
  37. piece_color(6) = _rgb(0,128,128)
  38.  
  40.  
  41. redraw = -1
  42.  
  43. speed = 10
  44. lines = 0
  45. pause = 0
  46. putpiece = 0
  47. startx = (sw - 4)/2
  48.  
  49. pn = int(rnd*7)
  50. px = startx
  51. py = 1
  52. rot = 0
  53.  
  54. title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  55. _title title$
  56.  
  57. t = timer
  58.  
  60.         if (timer - t) > (1/speed) and not pause then
  61.                 if valid(pn, px, py + 1, rot) then py = py + 1 else putpiece = -1
  62.  
  63.                 t = timer
  64.                 redraw = -1
  65.         end if
  66.  
  67.         if putpiece then
  68.                 if valid(pn, px, py, rot) then
  69.                         n = place(pn, px, py, rot)
  70.                         if n then
  71.                                 lines = lines + n
  72.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  73.                                 _title title$
  74.                         end if
  75.                 end if
  76.  
  77.                 pn = int(rnd*7)
  78.                 px = startx
  79.                 py = 0
  80.                 rot = 0
  81.  
  82.                 putpiece = 0
  83.                 redraw = -1
  84.  
  85.                 if not valid(pn, px, py, rot) then
  86.                         for y=0 to sh-1
  87.                                 for x=0 to sw-1
  88.                                         board(x, y) = 0
  89.                                 next
  90.                         next
  91.                         lines = 0
  92.                         title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  93.                         _title title$
  94.                 end if
  95.         end if
  96.  
  97.         if redraw then
  98.                 line (0,0)-(sw*size, sh*size),_rgb(0,0,0),bf
  99.                 for y=0 to sh - 1
  100.                         for x=0 to sw - 1
  101.                                 if board(x, y) <> 0 then
  102.                                         line (x*size, y*size)-step(size-2, size-2), piece_color(board(x, y)-1), bf
  103.                                 else
  104.                                         line (x*size, y*size)-step(size-2, size-2), _rgb(50,50,50), b
  105.                                 end if
  106.                         next
  107.                 next
  108.  
  109.                 for y=0 to 1
  110.                         for x=0 to 3
  111.                                 rotate xx, yy, x, y, pn, rot
  112.                                 if piece(pn, x, y) then line ((px + xx)*size, (py + yy)*size)-step(size-2, size-2), piece_color(pn), bf
  113.                         next
  114.                 next
  115.  
  116.                 _display
  117.                 redraw = 0
  118.         end if
  119.  
  120.         k = _keyhit
  121.         if k then
  122.                 shift = _keydown(100304) or _keydown(100303)
  123.                 select case k
  124.                 case 18432 'up
  125.                         if valid(pn, px, py, (rot + 1) mod 4) then rot = (rot + 1) mod 4
  126.                         pause = 0
  127.                 case 19200 'left
  128.                         if shift then
  129.                                 for xx=0 to sw-1
  130.                                         if not valid(pn, px - xx, py, rot) then exit for
  131.                                 next
  132.                                 px = px - xx + 1
  133.                         else
  134.                                 if valid(pn, px - 1, py, rot) then px = px - 1
  135.                         end if
  136.                         pause = 0
  137.                 case 19712 'right
  138.                         if shift then
  139.                                 for xx=px to sw-1
  140.                                         if not valid(pn, xx, py, rot) then exit for
  141.                                 next
  142.                                 px = xx - 1
  143.                         else
  144.                                 if valid(pn, px + 1, py, rot) then px = px + 1
  145.                         end if
  146.                         pause = 0
  147.                 case 20480, 32 'down
  148.                         if shift or k = 32 then
  149.                                 for yy=py to sh-1
  150.                                         if not valid(pn, px, yy, rot) then exit for
  151.                                 next
  152.                                 py = yy - 1
  153.                                 putpiece = -1
  154.                         else
  155.                                 if valid(pn, px, py + 1, rot) then py = py + 1
  156.                         end if
  157.                         pause = 0
  158.                 case 112 'p
  159.                         pause = not pause
  160.                 case 13 'enter
  161.                         for y=0 to sh-1
  162.                                 for x=0 to sw-1
  163.                                         board(x, y) = 0
  164.                                 next
  165.                         next
  166.                         pn = int(rnd*7)
  167.                         px = startx
  168.                         py = 0
  169.                         rot = 0
  170.                         putpiece = 0
  171.                         lines = 0
  172.                         title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  173.                         _title title$
  174.                 case 43, 61 'plus
  175.                         if speed < 100 then
  176.                                 speed = speed + 1
  177.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  178.                                 _title title$
  179.                         end if
  180.                 case 95, 45
  181.                         if speed > 1 then
  182.                                 speed = speed - 1
  183.                                 title$ = "lines="+ltrim$(str$(lines))+",speed="++ltrim$(str$(speed))
  184.                                 _title title$
  185.                         end if
  186.                 case 27
  187.                         exit do
  188.                 end select
  189.  
  190.                 redraw = -1
  191.         end if
  194.  
  195. sub rotate(xx, yy, x, y, pn, rot)
  196.         select case pn
  197.         case 0
  198.                 rot_new = 0
  199.         case 1 to 3
  200.                 rot_new = rot mod 2
  201.         case 4 to 6
  202.                 rot_new = rot
  203.         end select
  204.  
  205.         select case rot_new
  206.         case 0
  207.                 xx = x
  208.                 yy = y
  209.         case 1
  210.                 xx = y + 2
  211.                 yy = 2 - x
  212.         case 2
  213.                 xx = 4 - x
  214.                 yy = 1 - y
  215.         case 3
  216.                 xx = 2 - y
  217.                 yy = x - 1
  218.         end select
  220.  
  221. function valid(pn, px, py, rot)
  222.         for y=0 to 1
  223.                 for x=0 to 3
  224.                         rotate xx, yy, x, y, pn, rot
  225.                         if py + yy >= 0 then
  226.                                 if piece(pn, x, y) then
  227.                                         if (px + xx >= sw) or (px + xx < 0) then
  228.                                                 valid = 0
  229.                                                 exit function
  230.                                         end if
  231.                                         if (py + yy >= sh) then
  232.                                                 valid = 0
  233.                                                 exit function
  234.                                         end if
  235.                                         if (py >= 0) then
  236.                                         if board(px + xx, py + yy) then
  237.                                                 valid = 0
  238.                                                 exit function
  239.                                         end if
  240.                                         end if
  241.                                 end if
  242.                         end if
  243.                 next
  244.         next
  245.  
  246.         valid = -1
  248.  
  249. function place(pn, px, py, rot)
  250.         lines = 0
  251.  
  252.         for y=0 to 1
  253.                 for x=0 to 3
  254.                         rotate xx, yy, x, y, pn, rot
  255.                         if py + yy >= 0 then if piece(pn, x, y) then board(px + xx, py + yy) = pn + 1
  256.                 next
  257.         next
  258.  
  259.         'clear lines
  260.         for y=py-1 to py+2
  261.                 if y>=0 and y<sh then
  262.                         clr = -1
  263.                         for x=0 to sw - 1
  264.                                 if board(x, y) = 0 then
  265.                                         clr = 0
  266.                                         exit for
  267.                                 end if
  268.                         next
  269.  
  270.                         if clr then
  271.                                 lines = lines + 1
  272.                                 for yy=y to 1 step -1
  273.                                         for x=0 to sw-1
  274.                                                 board(x, yy) = board(x, yy-1)
  275.                                         next
  276.                                 next
  277.                         end if
  278.                 end if
  279.         next
  280.  
  281.         place = lines
  283.  

screenshot.png

30
Utilities / Descriptive Statistics by Bruno Schaefer
« on: June 28, 2018, 06:41:36 am »
Descriptive Statistics

Author: @BSpinoza Bruno Schaefer, Losheim am See, Germany
Author contact: bup.schaefer (.at.) web.de
Source: Submission
Version: 2018-06-16
Tags: [maths] [statistics]

Description:
This program calculates basic descriptive statistics of univariate data:
         n, Std.error, sum, standard error, mean, geometrical mean, variance,
         standard deviation, coefficient of variation, minimum, 1st quartile, median,
         2rd quartile, maximum,skewness, kurtosis, and excess kurtosis.
A dataset must have at least 4 values.
 
Remarks to kurtosis and skewness:
    For kurtosis and skewness the same equation as SPSS, PAST and Excel is used.
    Slightly different results may occur using other programs, especially for
    small sample sizes.
    kurtosis: peak shape  > 3 (excess > 0) leptokurtic: distribution with tapered peak and fat tails
                                    = 3 (excess = 0) mesokurtic: similar to normal bell-curved distribution
                                    < 3 (excess < 0) platykurtic: flat distribution with thin tails
     skewness: symmetry    > 0 skewed right: its right tail is longer and most of the distribution is at the left.
                                         = 0 symmetrical (not skewed)
                                         < 0 skewed left: the left tail is longer and most of the distribution is at the right

Note that this program includes extended ASCII characters and may not copy/paste correctly. If the interface does not draw correctly, use the attached source listing.

Source code:
Code: QB64: [Select]
  1. 'PROGRAM: descriptiveStatistics.bas
  2. '================= Descriptive Statistics  ================
  3. '        written by Bruno Schaefer, Losheim am See, Germany
  4. '                                       created: 15.12.2016
  5. '                                   last review: 16.06.2018
  6. '============================================================================================================
  7. ' This programm calculates basic descriptive statistics of univariate data:
  8. ' n, Std.error, sum, standard error, mean, geometrical mean, variance,
  9. ' standard deviation, coefficient of variation, minimum, 1st quartile, median,
  10. ' 2rd quartile, maximum,skewness, kurtosis, and excess kurtosis.
  11. ' A dataset must have at least 4 values.
  12. ' For kurtosis and skewness the same equation as SPSS, PAST and Excel is used.
  13. ' Slightly different results may occur using other programs, especially for
  14. ' small sample sizes.
  15. ' kurtosis: peak shape  > 3 (excess > 0) leptokurtic: distribution with tapered peak and fat tails
  16. '                       = 3 (excess = 0) mesokurtic: similar to normal bell-curved distribution
  17. '                       < 3 (excess < 0) platykurtic: flat distribution with thin tails
  18. ' skewness: symmetry    > 0 skewed right: its right tail is longer and most of the distribution is at the left.
  19. '                       = 0 symmetrical (not skewed)
  20. '                       < 0 skewed left: the left tail is longer and most of the distribution is at the right
  21. '===============================================================================================================
  22. _TITLE "descriptive statistics"
  23. SCREEN _NEWIMAGE(680, 520, 256)
  24. WEITER$ = "y" 'loop variable
  25. _CLIPBOARD$ = "" 'clears the clipboard
  29.     _LIMIT 30
  30.     DO
  31.         CLS , 14
  32.         COLOR 0, 14
  33.         PRINT " ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»   "
  34.         PRINT " º  DESCRIPTIVE STATISTICS OF UNIVARIATE DATA  º   "
  35.         PRINT " ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍŒ   "
  36.         PRINT "  number of values (n>3): ";
  37.         COLOR 9, 14
  38.         INPUT "", n 'input of the number of values
  39.     LOOP UNTIL n > 3
  40.     REDIM SHARED sample(n)
  41.     FOR I = 1 TO n
  42.         COLOR 0, 14
  43.         PRINT "  value no. " + STR$(I) + ": ";
  44.         COLOR 12, 14
  45.         INPUT "", Wert#
  46.         sample(I) = Wert# '               fills the data array with values
  47.     NEXT I
  48.     ' ----- SORT of the values ----------
  49.     DO
  50.         ic = 0
  51.         FOR I = 1 TO n - 1
  52.             IF sample(I) > sample(I + 1) THEN
  53.                 h = sample(I)
  54.                 sample(I) = sample(I + 1)
  55.                 sample(I + 1) = h
  56.                 ic = 1
  57.             END IF
  58.         NEXT I
  59.     LOOP UNTIL ic = 0
  60.     ' -----------  calculations and output of the results ------------
  61.     CLS
  62.     COLOR 0, 14
  63.     PRINT
  64.     PRINT " =========================== RESULTS =================================="
  65.     COLOR 2, 14
  66.     PRINT "  n (number of values):          "; n
  67.     PRINT "  sum (sum of values):           "; sum#(sample())
  68.     PRINT "  standard error:                "; StdDev.s#(sample()) / SQR(n) ' stderr#(sample())
  69.     PRINT "  range (xmax - xmin):           "; sample(UBOUND(sample)) - sample(LBOUND(sample))
  70.     COLOR 12, 14
  71.     PRINT "  mean:                          "; mean#(sample())
  72.     PRINT "  geometrical mean:              "; geomean#(sample())
  73.     PRINT "  root mean square RMS:          "; rms#(sample())
  74.     PRINT "  variance (sample):             "; variance.s#(sample())
  75.     PRINT "  std.dev. (sample):             "; StdDev.s#(sample()); " = "; _ROUND((StdDev.s#(sample()) * 100 / mean#(sample())) * 100) / 100; " %"
  76.     PRINT "  coeff. of variation:           "; 100 * StdDev.s#(sample()) / mean#(sample())
  77.     COLOR 9, 14
  78.     PRINT "  variance (population):         "; variance.p#(sample())
  79.     PRINT "  std.dev. (population):         "; StdDev.p#(sample()); " = "; _ROUND((StdDev.p#(sample()) * 100 / mean#(sample())) * 100) / 100; " %"
  80.     PRINT "  coefficient of variation:      "; 100 * StdDev.p#(sample()) / mean#(sample())
  81.     COLOR 6, 14
  82.     PRINT "  minimum:                       "; sample(LBOUND(sample))
  83.     PRINT "  1st quartile (percentile 25%): "; quantile#(sample(), 0.25)
  84.     PRINT "  median (percentile 50%):       "; quantile#(sample(), 0.50)
  85.     PRINT "  standard error of the median:  "; variance.p#(sample()) / SQR(n)
  86.     PRINT "  3rd quartile (percentile 75%): "; quantile#(sample(), 0.75)
  87.     PRINT "  maximum:                       "; sample(UBOUND(sample))
  88.     PRINT "  interquartile range:           "; quantile#(sample(), 0.75) - quantile#(sample(), 0.25)
  89.     COLOR 9, 14
  90.     PRINT "  skewness (sample):             "; _ROUND(skew#(sample()) * 100000) / 100000
  91.     PRINT "  kurtosis (sample):             "; _ROUND(kurt#(sample()) * 100000) / 100000
  92.     PRINT "  excess kurtosis(sample):       "; _ROUND(kurt#(sample()) * 100000) / 100000 - 3
  93.     PRINT "  skewness (population):         "; _ROUND(skew#(sample()) * (n - 2) / SQR(n * (n - 1)) * 100000) / 100000
  94.     PRINT "  kurtosis (population):         "; _ROUND((kurt#(sample()) * (n - 2) * (n - 3) / (n - 1) - 6) / (n + 1) * 100000) / 100000
  95.     PRINT "  excess kurtosis (population):  "; _ROUND((kurt#(sample()) * (n - 2) * (n - 3) / (n - 1) - 6) / (n + 1) * 100000) / 100000 - 3
  96.     COLOR 0, 14
  97.     PRINT " ======================================================================"
  98.     DIM CrLf AS STRING * 2
  99.     CrLf = CHR$(13) + CHR$(10)
  100.     _CLIPBOARD$ = _CLIPBOARD$ + " ========================================= " + CrLf
  101.     _CLIPBOARD$ = _CLIPBOARD$ + " DESCRIPTIVE STATISTICS OF UNIVARIATE DATA      " + CrLf
  102.     _CLIPBOARD$ = _CLIPBOARD$ + " ========================================= " + CrLf
  103.     _CLIPBOARD$ = _CLIPBOARD$ + " sorted data:" + CrLf
  104.     FOR I = 1 TO n
  105.         _CLIPBOARD$ = _CLIPBOARD$ + "    " + STR$(sample(I)) + CrLf
  106.     NEXT I
  107.     _CLIPBOARD$ = _CLIPBOARD$ + " ---------------------------------------------------------" + CrLf
  108.     _CLIPBOARD$ = _CLIPBOARD$ + " n (number of values):                  " + STR$(n) + CrLf
  109.     _CLIPBOARD$ = _CLIPBOARD$ + " sum (sum of values):                   " + STR$(sum#(sample())) + CrLf
  110.     _CLIPBOARD$ = _CLIPBOARD$ + " standard error:                        " + STR$(StdDev.s#(sample()) / SQR(n)) + CrLf
  111.     _CLIPBOARD$ = _CLIPBOARD$ + " range (xmax - xmin):                   " + STR$(sample(UBOUND(sample)) - sample(LBOUND(sample))) + CrLf
  112.     _CLIPBOARD$ = _CLIPBOARD$ + " mean:                                  " + STR$(mean#(sample())) + CrLf
  113.     _CLIPBOARD$ = _CLIPBOARD$ + " geometrical mean                       " + STR$(geomean#(sample())) + CrLf
  114.     _CLIPBOARD$ = _CLIPBOARD$ + " root mean square RMS:                  " + STR$(rms#(sample())) + CrLf
  115.     _CLIPBOARD$ = _CLIPBOARD$ + " variance (sample):                     " + STR$(variance.s#(sample())) + CrLf
  116.     _CLIPBOARD$ = _CLIPBOARD$ + " standard deviation (sample):           " + STR$(StdDev.s#(sample())) + CrLf
  117.     _CLIPBOARD$ = _CLIPBOARD$ + " standard deviation (sample) %:         " + STR$(_ROUND((StdDev.s#(sample()) * 100 / mean#(sample())) * 100) / 100) + " %" + CrLf
  118.     _CLIPBOARD$ = _CLIPBOARD$ + " coefficient of variation (sample):     " + STR$(100 * StdDev.s#(sample()) / mean#(sample())) + CrLf
  119.     _CLIPBOARD$ = _CLIPBOARD$ + " variance (population):                 " + STR$(variance.p#(sample())) + CrLf
  120.     _CLIPBOARD$ = _CLIPBOARD$ + " standard deviation(population):        " + STR$(StdDev.p#(sample())) + CrLf
  121.     _CLIPBOARD$ = _CLIPBOARD$ + " standard deviation (population) %:     " + STR$(_ROUND((StdDev.p#(sample()) * 100 / mean#(sample())) * 100) / 100) + " %" + CrLf
  122.     _CLIPBOARD$ = _CLIPBOARD$ + " coefficient of variation (population): " + STR$(100 * StdDev.p#(sample()) / mean#(sample())) + CrLf
  123.     _CLIPBOARD$ = _CLIPBOARD$ + " minimum:                               " + STR$(sample(LBOUND(sample))) + CrLf
  124.     _CLIPBOARD$ = _CLIPBOARD$ + " 1st quartile (25% percentile):         " + STR$(quantile#(sample(), 0.25)) + CrLf
  125.     _CLIPBOARD$ = _CLIPBOARD$ + " median: 2nd quartile (50% percentile): " + STR$(quantile#(sample(), 0.50)) + CrLf
  126.     _CLIPBOARD$ = _CLIPBOARD$ + " standard error of the median:          " + STR$(variance.p#(sample()) / SQR(n)) + CrLf
  127.     _CLIPBOARD$ = _CLIPBOARD$ + " 3rd quartile (75%) :                   " + STR$(quantile#(sample(), 0.75)) + CrLf
  128.     _CLIPBOARD$ = _CLIPBOARD$ + " maximum:                               " + STR$(sample(UBOUND(sample))) + CrLf
  129.     _CLIPBOARD$ = _CLIPBOARD$ + " interquartile range:                   " + STR$(quantile#(sample(), 0.75) - quantile#(sample(), 0.25)) + CrLf
  130.     _CLIPBOARD$ = _CLIPBOARD$ + " skewness (sample):                     " + STR$(_ROUND(skew#(sample()) * 100000) / 100000) + CrLf
  131.     _CLIPBOARD$ = _CLIPBOARD$ + " kurtosis (sample):                     " + STR$(_ROUND(kurt#(sample()) * 100000) / 100000) + CrLf
  132.     _CLIPBOARD$ = _CLIPBOARD$ + " excess kurtosis (sample):              " + STR$(_ROUND(kurt#(sample()) * 100000) / 100000 - 3) + CrLf
  133.     _CLIPBOARD$ = _CLIPBOARD$ + " skewness (population):                 " + STR$(_ROUND(skew#(sample()) * (n - 2) / SQR(n * (n - 1)) * 100000) / 100000) + CrLf
  134.     _CLIPBOARD$ = _CLIPBOARD$ + " kurtosis (population):                 " + STR$(_ROUND((kurt#(sample()) * (n - 2) * (n - 3) / (n - 1) - 6) / (n + 1) * 100000) / 100000) + CrLf
  135.     _CLIPBOARD$ = _CLIPBOARD$ + " excess kurtosis (population):          " + STR$(_ROUND((kurt#(sample()) * (n - 2) * (n - 3) / (n - 1) - 6) / (n + 1) * 100000) / 100000 - 3) + CrLf
  136.     _CLIPBOARD$ = _CLIPBOARD$ + " ---------------------------------------------------------" + CrLf
  137.     PRINT
  138.     PRINT " All results are stored in the clipboard!"
  139.     PRINT " Do you want to start a new statistical evaluation  [y/n]? ";
  140.     SLEEP
  141.     WEITER$ = INKEY$
  142. LOOP WHILE (WEITER$ = "y") OR (WEITER$ = "Y")
  143. COLOR 12, 14
  145. LOCATE 10, 25: PRINT " E N D   O F   P R O G R A M "
  146. LOCATE 12, 25: PRINT "         - - - -"
  147. LOCATE 14, 25: PRINT "      Press any key ": PRINT
  151. 'FUNCTIONS
  152. '============= sum =========="
  153. FUNCTION sum# (x())
  154.     s# = 0
  155.     FOR i = 1 TO n
  156.         s# = s# + x(i)
  157.     NEXT i
  158.     sum# = s#
  160. '============= mean =========="
  161. FUNCTION mean# (x())
  162.     mean# = sum#(x()) / n
  164. '========= variance (sample) =========="
  165. FUNCTION variance.s# (x())
  166.     m# = mean#(x())
  167.     s# = 0
  168.     FOR i = 1 TO n
  169.         s# = s# + (x(i) - mean#(x())) ^ 2
  170.     NEXT i
  171.     variance.s# = s# / (n - 1)
  173. '========= variance population) =========="
  174. FUNCTION variance.p# (x())
  175.     m# = mean#(x())
  176.     s = 0
  177.     FOR i = 1 TO n
  178.         s# = s# + (x(i) - mean#(x())) ^ 2
  179.     NEXT i
  180.     variance.p# = s# / n
  182. '======= standard deviation (sample) ========"
  183. FUNCTION StdDev.s# (x())
  184.     StdDev.s# = SQR(variance.s#(x()))
  186. '======= standard deviation (population) ========"
  187. FUNCTION StdDev.p# (x())
  188.     StdDev.p# = SQR(variance.p#(x()))
  190. '============== median ====================="
  191. FUNCTION median# (x())
  192.     IF (n / 2) = INT(n / 2) THEN
  193.         'even
  194.         median# = (sample(n / 2) + sample((n / 2) + 1)) / 2
  195.     ELSE
  196.         'odd
  197.         median# = sample((n + 1) / 2)
  198.     END IF
  200. '============================ quantile ========================
  201. FUNCTION quantile# (x(), a)
  202.     rang# = a * (n - 1) + 1
  203.     index% = INT(rang#)
  204.     gewicht# = rang# - index%
  205.     quantile# = x(index%) + gewicht# * (x(index% + 1) - x(index%))
  207. '============================ skewness ========================
  208. FUNCTION skew# (x())
  209.     m# = mean#(x())
  210.     s# = StdDev.s#(x())
  211.     sk# = 0
  212.     FOR J = 1 TO n
  213.         sk# = sk# + ((x(J) - m#) / s#) ^ 3
  214.     NEXT J
  215.     IF s# <> 0 THEN
  216.         skew# = sk# * (n / ((n - 1) * (n - 2)))
  217.     ELSE
  218.         skew# = 0
  219.     END IF
  221. '============================ kurtosis ========================
  222. FUNCTION kurt# (x())
  223.     m# = mean#(x())
  224.     s# = StdDev.s#(x())
  225.     krt# = 0
  226.     FOR j = 1 TO n
  227.         krt# = krt# + ((x(j) - m#) / s#) ^ 4
  228.     NEXT j
  229.     IF s# <> 0 THEN
  230.         kurt# = ((krt# * (n + 1) * n) / ((n - 1) * (n - 2) * (n - 3))) - ((3 * (n - 1) ^ 2) / ((n - 2) * (n - 3)))
  231.     ELSE
  232.         kurt# = 0
  233.     END IF
  235. '====================== geometrical mean ========================
  236. FUNCTION geomean# (x())
  237.     gm# = 1
  238.     FOR j = 1 TO n
  239.         gm# = gm# * x(j)
  240.     NEXT j
  241.     geomean# = gm# ^ (1 / n)
  243.  
  244. '============ mean square error ===================
  245. FUNCTION rms# (x())
  246.     ms# = 0
  247.     FOR j = 1 TO n
  248.         ms# = ms# + x(j) ^ 2
  249.     NEXT j
  250.     rms# = SQR(ms# / n)
  252.  

results.jpg

Pages: 1 [2] 3