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.


Topics - bplus

Pages: [1] 2 3 ... 21
1
QB64 Discussion / Tip: get your pathed program file name
« on: April 15, 2022, 11:39:33 pm »
Code: QB64: [Select]
  1. PathedFile$ = Command$(0) 'or process commands sent
  2. Print PathedFile$
  3.  

  [ You are not allowed to view this attachment ]  

2
Programs / Better Bench by Ed Davis
« on: April 11, 2022, 04:15:53 pm »
Generic Basic code convert to QB64 by me for timing and Types:
Code: QB64: [Select]
  2. DefLng A-Z
  3. Dim As Double x, y, xx, yy, start
  4. start = Timer(.001)
  5. accum = 0
  6. count = 0
  7. While count < 1545
  8.     leftedge = -420
  9.     rightedge = 300
  10.     topedge = 300
  11.     bottomedge = -300
  12.     xstep = 7
  13.     ystep = 15
  14.  
  15.     maxiter = 200
  16.  
  17.     y0 = topedge
  18.     While y0 > bottomedge
  19.         x0 = leftedge
  20.         While x0 < rightedge
  21.             y = 0
  22.             x = 0
  23.             thechar = 32
  24.             xx = 0
  25.             yy = 0
  26.             i = 0
  27.             While i < maxiter And xx + yy <= 800
  28.                 xx = Int((x * x) / 200)
  29.                 yy = Int((y * y) / 200)
  30.                 If xx + yy > 800 Then
  31.                     thechar = 48 + i
  32.                     If i > 9 Then
  33.                         thechar = 64
  34.                     End If
  35.                 Else
  36.                     temp = xx - yy + x0
  37.                     If (x < 0 And y > 0) Or (x > 0 And y < 0) Then
  38.                         y = (-1 * Int((-1 * x * y) / 100)) + y0  ' << this line was revised in later post
  39.                     Else
  40.                         y = Int(x * y / 100) + y0
  41.                     End If
  42.                     x = temp
  43.                 End If
  44.  
  45.                 i = i + 1
  46.             Wend
  47.             x0 = x0 + xstep
  48.             accum = accum + thechar
  49.         Wend
  50.         y0 = y0 - ystep
  51.     Wend
  52.  
  53.     If count Mod 300 = 0 Then
  54.         Print accum,
  55.     End If
  56.     count = count + 1
  58.  
  59. Print accum
  60. Print Timer(.001) - start; " seconds"
  61.  
  62. 'This is the output:
  63.  
  64. ' 200574 60372774 120544974 180717174 240889374 301061574 309886830
  65.  
  66.  
I added DEFLNG A-Z and Dim as Double x, y, xx, yy
and I got below 10 secs on Timer with $Checking:Off, 9.61 was best time with everything turned off including Wifi.

Ed has QB64 down for 9.35 secs maybe on better machine...
http://basic4all.epizy.com/index.php?topic=21.msg166#msg166

Can anyone make a significant drop? FreeBasic at top at 1.09 secs

3
Programs / Benchmark_01
« on: April 10, 2022, 01:55:11 pm »
Can someone verify this code is correct and it takes under .5 secs to run, Aurel doesn't believe it.
http://basic4all.epizy.com/index.php?topic=21.0

Code: QB64: [Select]
  1. start = Timer(.001)
  3. For n = 1 To 100000000
  4.     r = n * 2 - Sin(88)
  5. Next n&
  6. Print Timer(.001) - start; "seconds"
  7.  

 
image_2022-04-10_135600031.png


BTW oddly it does better with Double than with Single default.

4
Programs / Easter Egg Decorating
« on: March 29, 2022, 09:03:33 pm »
For Ken,

Code: QB64: [Select]
  1. _Title "Eggs o Dozens" 'b+ 2022-03-29
  3. Const Xmax = 1200, Ymax = 400, Pi = _Pi
  4. Screen _NewImage(Xmax, Ymax, 32)
  5. _ScreenMove 100, 100
  6. scale = 96
  8.     For y = 100 To 300 Step 200
  9.         For x = 100 To 1100 Step 200
  10.             drawEasterEgg x, y, scale, 0
  11.         Next
  12.     Next
  13.     _Delay 1
  15.  
  16. Sub drawEasterEgg (xc, yc, scale, radianAngle)
  17.     r = Rnd: g = Rnd: b = Rnd
  18.     For x = -1 To 1 Step .01
  19.         For y = -1 To 1 Step .01
  20.             If x < 0 Then c = c + .0005 Else c = c - .0005
  21.             If (x * x + (1.4 ^ x * 1.6 * y) ^ 2 - 1) <= .01 Then
  22.                 If y > 0 Then
  23.                     Color _RGB32(128 * (1 - y) + 128 * (1 - y) * Sin(c * r), 128 * (1 - y) + 128 * (1 - y) * Sin(c * g), 127 * (1 - y) + 127 * (1 - y) * Sin(c * b))
  24.                 Else
  25.                     Color _RGB32(128 + 128 * Sin(c * r), 128 + 128 * Sin(c * g), 127 + 127 * Sin(c * b))
  26.                 End If
  27.                 a = _Atan2(y, x)
  28.                 d = scale * Sqr(x * x + y * y)
  29.                 PSet (xc + d * Cos(a + radianAngle), yc + d * Sin(a + radianAngle))
  30.             End If
  31.         Next
  32.     Next
  34.  
  35.  
  36.  

 
Eggs o Dozens.PNG


5
Programs / Random Latin Squares - Rosetta Code
« on: March 25, 2022, 08:02:07 pm »
See Rosetta Code:  http://rosettacode.org/wiki/Random_Latin_squares

Code: QB64: [Select]
  1. _Title "Random Latin Squares - Rosetta Code" ' b+ 2022-03-25
  2. ' ref http://rosettacode.org/wiki/Random_Latin_squares
  5. Dim test, i, j
  6. ReDim b%(0, 0)
  7. Print "As required by RC:"
  8. For test = 1 To 2
  9.     n = 5
  10.     RandomLatinSquare n, b%()
  11.     displayLatinSquare n, b%()
  13. Print "Showing off:"
  14. For n = 2 To 16
  15.     RandomLatinSquare n, b%()
  16.     displayLatinSquare n, b%()
  18.  
  19. Sub RandomLatinSquare (n As Integer, RtnArray%())
  20.     Dim As Integer a(0 To n - 1), b(0 To n - 1)
  21.     For i = 0 To n - 1
  22.         a(i) = i: b(i) = i
  23.     Next
  24.     For i = n - 1 To 1 Step -1
  25.         Swap a(Int((i + 1) * Rnd)), a(i)
  26.         Swap b(Int((i + 1) * Rnd)), b(i)
  27.     Next
  28.     ReDim RtnArray%(0 To n - 1, 0 To n - 1)
  29.     For i = 0 To n - 1
  30.         For j = 0 To n - 1
  31.             RtnArray%(j, i) = (a(j) + b(i)) Mod n
  32.         Next
  33.     Next
  35.  
  36. Function pad$ (n, nSpaces)
  37.     pad$ = Right$(Space$(nSpaces) + _Trim$(Str$(n)), nSpaces)
  39.  
  40. Sub displayLatinSquare (n As Integer, b%())
  41.     For i = 0 To n - 1
  42.         For j = 0 To n - 1
  43.             If n < 10 Then Print pad$(b%(j, i), 2); Else Print pad$(b%(j, i), 3);
  44.         Next
  45.         Print
  46.     Next
  47.     Print
  49.  
  50.  
  51.  

Some low hanging fruit, no FreeBasic (or any other Basic) version yet!?

6
Programs / Boids Remake 2022-03
« on: March 19, 2022, 08:47:11 pm »
With some great tips from tsh73 at LB here is a better version of Boids:
Code: QB64: [Select]
  2. _Title "Boids Remake 2022-03" ' b+ 2022-03-19
  3. ' from JB Boids Restart #6 Wings b+ 2022-03-19
  5.  
  6. Const xmax = 1200, ymax = 700, pi = _Pi, nb = 100, no = 7, np = 3
  7. Const green = _RGB32(0, 160, 0), blue = _RGB32(0, 0, 160), black = _RGB32(0, 0, 0), brown = _RGB32(100, 80, 40)
  8. Dim As Long done, headmode, centermode, i, j, testx, testy, iter
  9. Dim As Single hf, cf, t1, s, ao, dist
  10.  
  11. Dim As Single px(np), py(np), pa(np) ' Predator radius is const 10 or so, twice a bird at least
  12. Dim As Single ox(no), oy(no), ord(no) ' obstacle x, y, radius
  13. Dim As Single bx(nb), by(nb), ba(nb), da(nb, nb) ' new  da = distance array
  14. Dim As Long pw(np), bw(nb)
  15. headmode = 1 ' on / off
  16. hf = .3 ' % of 100 pixels distance .1 = 10
  17.  
  18. centermode = 0 ' on / off
  19. cf = .2 'centering factor how strong a pull from 0 to 1  .01 is week .1 pretty strong!
  20.  
  21. Screen _NewImage(xmax, ymax, 32)
  22. _ScreenMove 100, 20
  23.  
  24. For i = 1 To no ' in array for redraw
  25.     ox(i) = rand(90, xmax - 90): oy(i) = rand(90, ymax - 90): ord(i) = rand(25, 90)
  27. For i = 1 To nb
  28.     testAgain: ' don't start a bird inside an obstacle
  29.     testx = rand(20, xmax - 20) ' start random screen x, y away from borders
  30.     testy = rand(20, ymax - 20)
  31.     j = 0
  32.     While j < no ' note get strange results with For loop
  33.         j = j + 1
  34.         If distance(testx, testy, ox(j), oy(j)) < ord(j) + 10 Then GoTo testAgain
  35.     Wend
  36.     j = 0
  37.     While j < i - 1 'no bird crowds please  note get strange results with For loop
  38.         j = j + 1
  39.         If distance(testx, testy, bx(j), by(j)) < 15 Then GoTo testAgain
  40.     Wend
  41.     bx(i) = testx: by(i) = testy: ba(i) = 2 * pi * Rnd: bw(i) = Int(3 * Rnd) ' random headings
  43. For i = 1 To np ' might be smarter to pack the smaller after the larger, ie do predators before birds
  44.     testAgain2: ' don't start a predator inside an obstacle
  45.     testx = rand(40, xmax - 40) ' start random screen x, y away from borders
  46.     testy = rand(40, ymax - 40)
  47.     j = 0
  48.     While j < no ' note get strange results with For loop
  49.         j = j + 1
  50.         If distance(testx, testy, ox(j), oy(j)) < ord(j) + 10 Then GoTo testAgain2
  51.     Wend
  52.     j = 0
  53.     While j < nb ' give birds some space from predators too
  54.         j = j + 1
  55.         If distance(testx, testy, bx(j), by(j)) < 30 Then GoTo testAgain2
  56.     Wend
  57.     px(i) = testx: py(i) = testy: pa(i) = 2 * pi * Rnd: pw(i) = Int(5 * Rnd)
  59. t1 = Timer(.001)
  60. Color , green
  61. While _KeyDown(27) = 0
  62.     Cls
  63.     For i = 1 To no
  64.         fcirc ox(i), oy(i), ord(i), brown
  65.     Next
  66.     For i = 1 To nb - 1 ' find all the distances between birds
  67.         For j = i + 1 To nb ' fix bonehead error of doing this 2x's! thanks tsh73 for catch!
  68.             da(i, j) = distance(bx(i), by(i), bx(j), by(j))
  69.             da(j, i) = da(i, j) ' symetric relationship
  70.         Next
  71.     Next
  72.  
  73.     For i = 1 To np ' Predators are just like a birds
  74.         pw(i) = (1 + pw(i)) Mod 5 ' flapper wings or not
  75.         DrawBird px(i), py(i), 15, pa(i), pw(i), blue
  76.         s = Rnd * 4 + 3 ' get some bird separation here?
  77.         px(i) = px(i) + s * Cos(pa(i)): py(i) = py(i) + s * Sin(pa(i))
  78.         j = 0
  79.         While j < no ' note get strange results with For loop
  80.             j = j + 1
  81.             If distance(px(i), py(i), ox(j), oy(j)) < ord(j) + 23 Then
  82.                 ao = _Atan2(oy(j) - py(i), ox(j) - px(i))
  83.                 pa(i) = AngleAve(pa(i), ao - pi)
  84.             End If
  85.         Wend
  86.         ' JB&LB have better Mod function! tsh73 pointed it to me
  87.         px(i) = Mod2(px(i) + xmax, xmax)
  88.         py(i) = Mod2(py(i) + ymax, ymax)
  89.         ' except predators don't flock
  90.     Next
  91.  
  92.     For i = 1 To nb 'draw then update positions of birds
  93.         ' draw current
  94.         bw(i) = (bw(i) + 1) Mod 4 ' flapper wings or not
  95.         DrawBird bx(i), by(i), 8, ba(i), bw(i), black
  96.         s = rand(3, 7) ' get some bird separation here?
  97.         bx(i) = bx(i) + s * Cos(ba(i)): by(i) = by(i) + s * Sin(ba(i))
  98.         j = 0
  99.         While j < no ' note get strange results with For loop
  100.             j = j + 1
  101.             If distance(bx(i), by(i), ox(j), oy(j)) < ord(j) + 13 Then
  102.                 ao = _Atan2(oy(j) - by(i), ox(j) - bx(i))
  103.                 ba(i) = AngleAve(ba(i), ao - pi)
  104.             End If
  105.         Wend
  106.         j = 0
  107.         While j < np
  108.             j = j + 1
  109.             If distance(bx(i), by(i), px(j), py(j)) < 65 Then
  110.                 ao = _Atan2(py(j) - by(i), px(j) - bx(i))
  111.                 ba(i) = AngleAve(ba(i), ao - pi)
  112.             End If
  113.         Wend
  114.         ' JB&LB have better Mod function! tsh73 pointed it to me
  115.         bx(i) = Mod2(bx(i) + xmax, xmax)
  116.         by(i) = Mod2(by(i) + ymax, ymax)
  117.  
  118.         For j = i + 1 To nb
  119.             dist = da(i, j)
  120.             If dist < 50 Then ' birds are close enough to influence each other by visual
  121.                 'sway the neighbors headings towards each other
  122.                 If headmode And Rnd < hf Then
  123.                     ba(i) = AngleAve(ba(i), AngleAve(ba(i), ba(j)))
  124.                     ba(j) = AngleAve(ba(j), AngleAve(ba(i), ba(j)))
  125.                 End If
  126.             End If
  127.             If dist > 30 And dist < 100 Then
  128.                 'stickiness stay close to neighbors, close distance between
  129.                 If centermode And Rnd < cf Then
  130.                     bx(i) = bx(i) - cf / 10 * (bx(i) - bx(j))
  131.                     bx(j) = bx(j) + cf / 10 * (bx(i) - bx(j))
  132.                     by(i) = by(i) - cf / 10 * (by(i) - by(j))
  133.                     by(j) = by(j) + cf / 10 * (by(i) - by(j))
  134.                 End If
  135.             End If
  136.             If dist < 20 Then ' too close!!!
  137.                 bx(i) = bx(i) + .1 * (bx(i) - bx(j))
  138.                 bx(j) = bx(j) - .1 * (bx(i) - bx(j))
  139.                 by(i) = by(i) + .1 * (by(i) - by(j))
  140.                 by(j) = by(j) - .1 * (by(i) - by(j))
  141.             End If
  142.         Next 'j
  143.     Next ' i
  144.     _Display
  145.     _Limit 10
  147.  
  148. Function rand& (lo As Long, hi As Long) 'rand integer between lo and hi iclusive
  149.     rand& = Int((hi - lo + 1) * Rnd + lo)
  151.  
  152. Function distance (x1, y1, x2, y2) ' default single OK
  153.     distance = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
  155.  
  156. Function AngleAve (ra1, ra2) ' default single OK
  157.     Dim twoPi, ray1, ray2, rtn
  158.     twoPi = pi * 2
  159.     ray1 = Mod2(ra1 + twoPi, twoPi)
  160.     ray2 = Mod2(ra2 + twoPi, twoPi)
  161.     rtn = (ray1 + ray2) / 2
  162.     If Abs(ray1 - ray2) > pi Then rtn = Mod2(rtn - pi + twoPi, twoPi)
  163.     AngleAve = rtn
  165.  
  166. Sub DrawBird (xc, yc, rr, ra, wings As Integer, c As _Unsigned Long)
  167.     Dim x1, y1, x2, y2, x3, y3
  168.     x1 = xc + rr * Cos(ra)
  169.     y1 = yc + rr * Sin(ra)
  170.     x2 = xc + rr * Cos(ra - .9 * pi)
  171.     y2 = yc + rr * Sin(ra - .9 * pi)
  172.     x3 = xc + rr * Cos(ra + .9 * pi)
  173.     y3 = yc + rr * Sin(ra + .9 * pi)
  174.     ftri x1, y1, xc, yc, x2, y2, c
  175.     ftri x1, y1, xc, yc, x3, y3, c
  176.     If wings Then
  177.         x2 = xc + 2 * rr * Cos(ra - 1.57 * pi)
  178.         y2 = yc + 2 * rr * Sin(ra - 1.57 * pi)
  179.         x3 = xc + 2 * rr * Cos(ra + 1.57 * pi)
  180.         y3 = yc + 2 * rr * Sin(ra + 1.57 * pi)
  181.         ftri xc, yc, x2, y2, x3, y3, c
  182.     End If
  184.  
  185. ' this allows us to do floats including negative floats
  186. Function Mod2# (n As Double, modulus As Double)
  187.     Dim rtn As Double
  188.     rtn = modulus * (Abs(n) / modulus - Int(Abs(n) / modulus))
  189.     If n < 0 Then rtn = -rtn
  190.     Mod2# = rtn
  192.  
  193. Sub fcirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long)
  194.     Dim Radius As Long, RadiusError As Long
  195.     Dim X As Long, Y As Long
  196.     Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
  197.     If Radius = 0 Then PSet (CX, CY), C: Exit Sub
  198.     Line (CX - X, CY)-(CX + X, CY), C, BF
  199.     While X > Y
  200.         RadiusError = RadiusError + Y * 2 + 1
  201.         If RadiusError >= 0 Then
  202.             If X <> Y + 1 Then
  203.                 Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
  204.                 Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
  205.             End If
  206.             X = X - 1
  207.             RadiusError = RadiusError - X * 2
  208.         End If
  209.         Y = Y + 1
  210.         Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
  211.         Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
  212.     Wend
  214.  
  215. Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
  216.     Dim D As Long
  217.     Static a&
  218.     D = _Dest
  219.     If a& = 0 Then a& = _NewImage(1, 1, 32)
  220.     _Dest a&
  221.     _DontBlend a& '  '<<<< new 2019-12-16 fix
  222.     PSet (0, 0), K
  223.     _Blend a& '<<<< new 2019-12-16 fix
  224.     _Dest D
  225.     _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
  227.  
  228.  
Boids Remake 2022-03.PNG


EDIT: I had an FPS iteration counter but it wasn't working and I don't need it anyway for QB64.

7
Programs / Determinant of a (Square Integer) Matrix
« on: March 11, 2022, 09:52:48 pm »
By recursive calls:
Code: QB64: [Select]
  1. Option _Explicit ' determinantOfMatrix.bas b+ 2022-03-11 translate from
  2. ''''// C++ program to find Determinant of a matrix
  3. ''''#include <iostream>
  4. ''''using namespace std;
  5. ' Hope the above isn't important because WTH?
  6.  
  7. ''''// Dimension of input square matrix
  8. ''''#define N 4
  9. ' Again not sure??  oh this is for testing 4 x 4, the 3 x 3 is commented out
  10.  
  11.  
  12.  
  13.  
  14. ''''// Driver program to test above functions
  15. ' that are defined below :)
  16.  
  17. ''''int main()
  18. ''''{
  19. ''''    /* int mat[N][N] = {{6, 1, 1},
  20. ''''                     {4, -2, 5},
  21. ''''                     {2, 8, 7}}; */
  22.  
  23. ''''    int mat[N][N] = { { 1, 0, 2, -1 },
  24. ''''                      { 3, 0, 0, 5 },
  25. ''''                      { 2, 1, 4, -3 },
  26. ''''                      { 1, 0, 5, 0 } };
  27. ' well crap we need a way to read in a Matrix from a string
  28.  
  29. Dim m$
  30. m$ = "1,2;3,4"
  31. ReDim As Integer mat(0, 0)
  32. readStr2Mat m$, mat()
  33. displayMat mat(), 2, 2
  34. Print " D ="; determinantOfMatrix%(mat(), 2)
  36. m$ = "2, -3,1;2,0,-1 ;1, 4, 5"
  37. ReDim As Integer mat(0, 0)
  38. readStr2Mat m$, mat()
  39. displayMat mat(), 3, 3
  40. Print " D ="; determinantOfMatrix%(mat(), 3)
  42. m$ = "1, 0, 2, -1;3, 0, 0, 5;2, 1, 4, -3;1, 0, 5, 0 "
  43. ReDim As Integer mat(0, 0)
  44. readStr2Mat m$, mat()
  45. displayMat mat(), 4, 4
  46. Print " D ="; determinantOfMatrix%(mat(), 4)
  47.  
  48. ''''    // Function call
  49. ''''    cout <<"Determinant of the matrix is : " << determinantOfMatrix(mat, N);
  50. ''''    return 0;
  51. ''''}
  52.  
  53. ''''// this code is contributed by shivanisinghss2110
  54. ''''Output
  55.  
  56.  
  57. ' Move from near start to end
  58. ''''// Function to get cofactor of mat[p][q] in temp[][]. n is
  59. ''''// current dimension of mat[][]
  60. ''''void getCofactor(int mat[N][N], int temp[N][N], int p,
  61. ''''                 int q, int n)
  62.  
  63. Sub getCofactor (mat() As Integer, temp() As Integer, p As Integer, q As Integer, n As Integer)
  64.     Dim row, col, i, j
  65.     'Print "getCoFactor p, q, n: "; p, q, n
  66.  
  67.     ''''{
  68.     ''''    int i = 0, j = 0;
  69.  
  70.     ''''    // Looping for each element of the matrix
  71.     ''''    for (int row = 0; row < n; row++)
  72.     ''''    {
  73.     ''''        for (int col = 0; col < n; col++)
  74.     ''''        {
  75.     For row = 0 To n - 1
  76.         For col = 0 To n - 1
  77.  
  78.             ''''            //  Copying into temporary matrix only those
  79.             ''''            //  element which are not in given row and
  80.             ''''            //  column
  81.             ''''            if (row != p && col != q)
  82.             If (row <> p) And (col <> q) Then
  83.                 ''''            {
  84.                 ''''                temp[i][j++] = mat[row][col];
  85.  
  86.                 ' is j increased before or after temp(i, j) is assigned???
  87.                 temp(i, j) = mat(row, col)
  88.                 j = j + 1 ' I think j should be increased after temp copy  so temp(0,0) is filled
  89.                 If j = n - 1 Then
  90.                     j = 0: i = i + 1
  91.                 End If
  92.  
  93.                 ''''                // Row is filled, so increase row index and
  94.                 ''''                // reset col index
  95.                 ''''                if (j == n - 1)
  96.                 ''''                {
  97.                 ''''                    j = 0;
  98.                 ''''                    i++;
  99.                 ''''                }
  100.                 ''''            }
  101.                 ''''        }
  102.                 ''''    }
  103.                 ''''}
  104.             End If
  105.         Next
  106.     Next
  108.  
  109.  
  110. ' also moved
  111. ''''/* Recursive function for finding determinant of matrix.
  112. ''''   n is current dimension of mat[][]. */
  113. ''''int determinantOfMatrix(int mat[N][N], int n)
  114. Function determinantOfMatrix% (mat() As Integer, n As Integer)
  115.     ''''{
  116.     ''''    int D = 0; // Initialize result
  117.     Dim As Integer D, sign, f
  118.  
  119.     ''''    //  Base case : if matrix contains single element
  120.     ''''    if (n == 1)
  121.     ''''        return mat[0][0];
  122.  
  123.     If n = 1 Then
  124.         determinantOfMatrix% = mat(0, 0)
  125.     Else
  126.         ''''    int temp[N][N]; // To store cofactors
  127.         Dim temp(n, n) As Integer
  128.         ''''    int sign = 1; // To store sign multiplier
  129.         sign = 1
  130.  
  131.         ''''    // Iterate for each element of first row
  132.         ''''    for (int f = 0; f < n; f++)
  133.         For f = 0 To n - 1
  134.  
  135.             ''''    {
  136.             ''''        // Getting Cofactor of mat[0][f]
  137.             ''''        getCofactor(mat, temp, 0, f, n);
  138.             getCofactor mat(), temp(), 0, f, n
  139.             ''''        D += sign * mat[0][f]
  140.             ''''             * determinantOfMatrix(temp, n - 1);
  141.             D = D + sign * mat(0, f) * determinantOfMatrix%(temp(), n - 1)
  142.             ''''        // terms are to be added with alternate sign
  143.             ''''        sign = -sign;
  144.             sign = -sign
  145.             ''''    }
  146.         Next
  147.         ''''    return D;
  148.         determinantOfMatrix% = D
  149.     End If
  150.     ''''}
  152.  
  153. 'also moved
  154. ''''/* function for displaying the matrix */
  155. ''''void display(int mat[N][N], int row, int col)
  156. Sub displayMat (mat() As Integer, row As Integer, col As Integer)
  157.     Dim As Integer i, j
  158.     ''''{
  159.     ''''    for (int i = 0; i < row; i++)
  160.     ''''    {
  161.     ''''        for (int j = 0; j < col; j++)
  162.     ''''            cout <<"  " <<  mat[i][j];
  163.     ''''        cout <<"n";
  164.     ' the hell
  165.     For i = 0 To row - 1
  166.         For j = 0 To col - 1
  167.             Print Right$("   " + _Trim$(Str$(mat(i, j))), 3); ' hey no more than 2 digit numbers OK?
  168.             ''''    }
  169.             ''''}
  170.         Next
  171.         Print
  172.     Next
  174.  
  175. Sub readStr2Mat (s$, mat() As Integer) ' commas separate columns, semi-colons separate rows
  176.     Dim As Integer i, j
  177.     ReDim rows$(0)
  178.     Split s$, ";", rows$()
  179.     ReDim As Integer mat(UBound(rows$), UBound(rows$))
  180.     For i = 0 To UBound(rows$)
  181.         ReDim nums$(0)
  182.         Split rows$(i), ",", nums$()
  183.         For j = 0 To UBound(nums$)
  184.             mat(i, j) = Val(nums$(j))
  185.         Next
  186.     Next
  188.  
  189. Sub Split (SplitMeString As String, delim As String, loadMeArray() As String)
  190.     Dim curpos As Long, arrpos As Long, LD As Long, dpos As Long 'fix use the Lbound the array already has
  191.     curpos = 1: arrpos = LBound(loadMeArray): LD = Len(delim)
  192.     dpos = InStr(curpos, SplitMeString, delim)
  193.     Do Until dpos = 0
  194.         loadMeArray(arrpos) = Mid$(SplitMeString, curpos, dpos - curpos)
  195.         arrpos = arrpos + 1
  196.         If arrpos > UBound(loadMeArray) Then ReDim _Preserve loadMeArray(LBound(loadMeArray) To UBound(loadMeArray) + 1000) As String
  197.         curpos = dpos + LD
  198.         dpos = InStr(curpos, SplitMeString, delim)
  199.     Loop
  200.     loadMeArray(arrpos) = Mid$(SplitMeString, curpos)
  201.     ReDim _Preserve loadMeArray(LBound(loadMeArray) To arrpos) As String 'get the ubound correct
  203.  
  204.  

8
QB64 Discussion / Is Discord down?
« on: March 08, 2022, 02:19:24 pm »
Doesn't seem to be allowing me in.

9
Programs / Eye Candy
« on: March 06, 2022, 10:03:07 pm »
Code: QB64: [Select]
  2. _Title "Sprezzo #2 Problem 2022-03-06"
  3. Const SQ = 700, SQd2 = SQ / 2
  4. Screen _NewImage(SQ, SQ, 32)
  5. _ScreenMove 300, 60
  7. Dim Shared As Single cN, pR, pG, pB
  8. Dim diag, pi2, i, a, di, r, s
  9. diag = SQd2 * Sqr(2)
  10. pi2 = _Pi(2)
  11.  
  12. Dim colr~&(-1000 To diag + 1000)
  14.     resetPlasma
  15.     For i = -1000 To diag + 1000
  16.         colr~&(i) = Plasma~&
  17.     Next
  18.     di = 1: s = 0
  19.     For a = 0 To pi2 Step pi2 / (16 * 360)
  20.         i = 50 * Sin(s) ' 2 * s or just s
  21.         For r = 0 To diag
  22.             PSet (SQd2 + r * Cos(a), SQd2 + r * Sin(a)), colr~&(r + i)
  23.         Next
  24.         's = s + _Pi(1 / 128)
  25.         s = s + pi2 / 180 ' for almost seamless connect  
  26.     Next
  27.     Sleep
  29.  
  30. Function Plasma~& ()
  31.     cN = cN + .5 'dim shared cN as _Integer64, pR as long, pG as long, pB as long
  32.     Plasma~& = _RGB32(127 + 127 * Sin(pR * cN), 127 + 127 * Sin(pG * cN), 127 + 127 * Sin(pB * cN))
  34.  
  35. Sub resetPlasma ()
  36.     pR = Rnd ^ 2: pG = Rnd ^ 2: pB = Rnd ^ 2
  38.  
  39.  
spectacular.PNG

10
QB64 Discussion / &H colors dont work as CONST
« on: March 03, 2022, 11:49:47 am »
Use to work with POINT, what happened?

Doesn't appear to work way back before 1.4 even.


11
Programs / Rotating Pyramid
« on: March 01, 2022, 09:20:09 am »
Another quickie for this morning and Aurels Forum: http://basic4all.info8-hosting.info/index.php

Showing Aurel how he might do this more satisfactory with his MicroA interpreter with this QB64 example:
Code: QB64: [Select]
  1. _Title "Rotating Pyramid" 'b+ 2022-03-01
  3. cx = _Width / 2
  4. ax = cx: ay = 50 ' apex
  5. ex = cx: ey = 330 ' ellipse
  6. xr = cx * .7: yr = .33 * xr
  8.     Cls
  9.     x1 = ex + xr * Cos(a): y1 = ey + yr * Sin(a)
  10.     x2 = ex + xr * Cos(a + _Pi * .5): y2 = ey + yr * Sin(a + _Pi * .5)
  11.     x3 = ex + xr * Cos(a + _Pi): y3 = ey + yr * Sin(a + _Pi)
  12.     x4 = ex + xr * Cos(a + _Pi * 1.5): y4 = ey + yr * Sin(a + _Pi * 1.5)
  13.     l x1, y1, x2, y2
  14.     l x2, y2, x3, y3
  15.     l x3, y3, x4, y4
  16.     l x4, y4, x1, y1
  17.     l x1, y1, ax, ay
  18.     l x2, y2, ax, ay
  19.     l x3, y3, ax, ay
  20.     l x4, y4, ax, ay
  21.     a = a + .01
  22.     _Display
  23.     _Limit 30
  25.  
  26. Sub l (a, b, c, d) ' this is just way easier to code lines Aurel you dont need this part
  27.     Line (a, b)-(c, d)
  29.  

 
QB64 Rotate Pyramid.PNG

12
Programs / Bump N Go Car Toy
« on: March 01, 2022, 08:19:18 am »
Spriggsy suggested this to me at Discord:
Code: QB64: [Select]
  1. _Title "Bump N Go - Drive Car" 'b+ 2022-03-01
  2. ' b+ mod of Drive Car (Graphics Dir) 'b+ 2021-09-29
  3.  
  5. Type car
  6.     As Single x, y, w, h, ra, speed
  7.     As _Unsigned Long c
  9.  
  10. Dim blue As car
  11. blue.x = _Width / 2: blue.y = _Height / 2
  12. blue.w = 20: blue.h = 40
  13. blue.ra = _Pi / 2: blue.speed = 2
  14. blue.c = 9
  15.  
  16. While _KeyDown(27) = 0
  17.     If blue.speed = 0 Then
  18.         blue.ra = _Atan2(blue.y - _Height / 2, blue.x - _Width / 2) + _Pi + Rnd * -.5
  19.         blue.speed = .1
  20.     End If
  21.     blue.speed = blue.speed + .5
  22.     Cls
  23.     blue.x = blue.x + blue.speed * Cos(blue.ra)
  24.     blue.y = blue.y + blue.speed * Sin(blue.ra)
  25.     If blue.x < 10 Or blue.x > _Width - 10 Then blue.speed = 0
  26.     If blue.y < 10 Or blue.y > _Height - 10 Then blue.speed = 0
  27.     drawCar blue
  28.     _Display ' stop flicker
  29.     _Limit 30 ' loops per sec
  31.  
  32. Sub drawCar (a As car)
  33.     ' code not optimized for speed  just proff of concept
  34.     X1 = a.x + a.h / 2 * Cos(a.ra)
  35.     Y1 = a.y + a.h / 2 * Sin(a.ra)
  36.     X2 = X1 + a.w / 2 * Cos(a.ra + _Pi / 2)
  37.     Y2 = Y1 + a.w / 2 * Sin(a.ra + _Pi / 2)
  38.     X3 = X1 + a.w / 2 * Cos(a.ra - _Pi / 2)
  39.     Y3 = Y1 + a.w / 2 * Sin(a.ra - _Pi / 2)
  40.  
  41.     x4 = a.x + a.h / 2 * Cos(a.ra - _Pi)
  42.     y4 = a.y + a.h / 2 * Sin(a.ra - _Pi)
  43.     x5 = x4 + a.w / 2 * Cos(a.ra + _Pi / 2)
  44.     y5 = y4 + a.w / 2 * Sin(a.ra + _Pi / 2)
  45.     x6 = x4 + a.w / 2 * Cos(a.ra - _Pi / 2)
  46.     y6 = y4 + a.w / 2 * Sin(a.ra - _Pi / 2)
  47.  
  48.     Line (X2, Y2)-(X3, Y3), a.c
  49.     Line (X3, Y3)-(x6, y6), a.c
  50.     Line (x6, y6)-(x5, y5), a.c
  51.     Line (x5, y5)-(X2, Y2), a.c
  52.     Paint (a.x, a.y), a.c, a.c
  53.     Line (X2, Y2)-(X3, Y3), 15 ' give car a front
  54.  
  55.     ' white top  for all cars for future numbers maybe
  56.     X1 = a.x + a.h / 4 * Cos(a.ra)
  57.     Y1 = a.y + a.h / 4 * Sin(a.ra)
  58.     X2 = X1 + (a.w / 2 - 3) * Cos(a.ra + _Pi / 2)
  59.     Y2 = Y1 + (a.w / 2 - 3) * Sin(a.ra + _Pi / 2)
  60.     X3 = X1 + (a.w / 2 - 3) * Cos(a.ra - _Pi / 2)
  61.     Y3 = Y1 + (a.w / 2 - 3) * Sin(a.ra - _Pi / 2)
  62.  
  63.     x4 = a.x + a.h / 4 * Cos(a.ra - _Pi)
  64.     y4 = a.y + a.h / 4 * Sin(a.ra - _Pi)
  65.     x5 = x4 + (a.w / 2 - 3) * Cos(a.ra + _Pi / 2)
  66.     y5 = y4 + (a.w / 2 - 3) * Sin(a.ra + _Pi / 2)
  67.     x6 = x4 + (a.w / 2 - 3) * Cos(a.ra - _Pi / 2)
  68.     y6 = y4 + (a.w / 2 - 3) * Sin(a.ra - _Pi / 2)
  69.  
  70.     Line (X2, Y2)-(X3, Y3), 15
  71.     Line (X3, Y3)-(x6, y6), 15
  72.     Line (x6, y6)-(x5, y5), 15
  73.     Line (x5, y5)-(X2, Y2), 15
  74.     Paint (a.x, a.y), 15, 15
  76.  
  77.  
  78.  

;-))

13
Programs / Evolving RI (Robot Intelligence) for a room vacuum
« on: February 28, 2022, 08:46:23 pm »
I am developing an Agent in AI lingo that is able to act on it's own without human intervention in real time

Here is first crude effort. You press spacebar for each step, or just lean on it to run through process. There is no stop signal, it just keeps on sweeping the random room.

What surprises the heck out of me is that it always, eventually, covers the whole room! So far I've not seen it fail. True  there is a lot of redundant over sweeps of cells but eventually it covers the room.

The sweeper only moves up/down or left/right each step and can only sense if there is an obstacle in these directions.

Code: QB64: [Select]
  1. _Title "I Robot - Room Mapper 1 (IR-RM1)" ' b+ 2022-02-11
  2. ' 2022-02-23 started writing code
  3. ' The little guy, say a vaccum cleaner, is plopped down somewhere in it's new home.
  4. ' The first order of business is to map out it's area of duty,
  5. ' say sweep the whole floor without getting stuck or wasting allot of moves.
  6. ' It is square and can sense, resistence on any of its edges.
  7. ' It is allowed to go N,S,E,W - the four directions
  8. ' If something is sensed on one side it is forbidden to
  9. ' enter that square from that direction.
  10. ' Rule of economy - don't reenter a square already occupied
  11. ' unless that is the only way to go.
  12. ' Do we have enough spelled out to map a room?
  13.  
  14. ' A room is a grid of squares, we don't know the dimensions
  15. ' and there are objects in many of the middle squares or along
  16. ' the walls. Later we may encounter objects that move around
  17. ' like pets or results of fickle home decorators.
  18.  
  19. ' God provides a room with objetcs and randomly drops the robot
  20. ' into it.
  21.  
  22. ' 2022-02-23 first goal is to get an edges mapped. so make up a room
  23. ' Upon some more thinking and just to get the ball rolling, I will
  24. ' allow robot vaccum sweeper to use the room map and mark it with it's
  25. ' own numbers, so now the walls are -1, empty areas 0, places visited
  26. ' are positive numbers, everytime the vacuum reoccupies the square
  27. ' the number is increased.
  28. ' OK the room setup seems satisfactory onto RI = Robot Intelligence
  29.  
  30. ' OK first run it does eventually cover the whole room.
  31. ' Need to know when it has done the whole room. There are some
  32. ' places that have to be left 0
  33.  
  35. Const SW = 601, SH = 601
  36. Screen _NewImage(SW, SH, 32)
  37. _ScreenMove 200, 70
  38.  
  39. ReDim Shared As Integer dx(3), dy(3)
  40. dx(0) = 0: dy(0) = -1
  41. dx(1) = 1: dy(1) = 0
  42. dx(2) = 0: dy(2) = 1
  43. dx(3) = -1: dy(3) = 0
  44.  
  45. ReDim Shared As Long Room(1 To 20, 1 To 20) ' 0 = empty -1 = wall see MakeRoom
  46. Dim Shared As Long rx, ry ' robot location
  47. rx = 10: ry = 10 ' starts here in middle of room should be clear
  48. MakeRoom
  50.     drawRoom 'ok the middle of room is staying clear of stuff
  51.     _Display
  52.     RI ' ok roby make your move
  53.     Sleep
  54.     Cls
  56.  
  57. Sub RI ' the robot appraises it's current postition rx, ry in Room(20x20) and makes a move changing rx, ry and that ends the sub
  58.  
  59.     ' I was here!
  60.     Room(rx, ry) = Room(rx, ry) + 1 ' sweeps the spot
  61.     Dim d(3)
  62.     d(0) = Room(rx, ry - 1)
  63.     d(1) = Room(rx + 1, ry)
  64.     d(2) = Room(rx, ry + 1)
  65.     d(3) = Room(rx - 1, ry)
  66.  
  67.     If d(0) = 0 Then ' one must have ones priorities
  68.         ry = ry - 1: Exit Sub
  69.     ElseIf d(1) = 0 Then
  70.         rx = rx + 1: Exit Sub
  71.     ElseIf d(2) = 0 Then
  72.         ry = ry + 1: Exit Sub
  73.     ElseIf d(3) = 0 Then
  74.         rx = rx - 1: Exit Sub
  75.     End If
  76.  
  77.     ' still here ?  where is min number of visits?
  78.     Dim As Long min, saveI
  79.     min = 10000000
  80.     For i = 0 To 3
  81.         If d(i) <> -1 Then
  82.             If d(i) < min Then min = d(i): saveI = i
  83.         End If
  84.     Next
  85.     rx = rx + dx(saveI)
  86.     ry = ry + dy(saveI)
  88.  
  89. Sub drawRoom
  90.     drawGridSq 0, 0, 30, 30
  91.     For x = 1 To 20
  92.         For y = 1 To 20
  93.             If Room(x, y) = -1 Then
  94.                 Line ((x - 1) * 30, (y - 1) * 30)-Step(30, 30), , BF
  95.             ElseIf Room(x, y) > 0 Then
  96.                 s$ = _Trim$(Str$(Room(x, y)))
  97.                 _PrintString ((x - 1) * 30 + (30 - Len(s$) * 8) / 2, (y - 1) * 30 + 7), s$
  98.             End If
  99.         Next
  100.     Next
  101.     ' and robot
  102.     Line ((rx - 1) * 30, (ry - 1) * 30)-Step(30, 30), &HFFFFFF00, BF
  104.  
  105. Sub MakeRoom
  106.     ReDim As Long Room(1 To 20, 1 To 20) ' 0 = empty -1 = wall
  107.     ' Here are the walls
  108.     For x = 1 To 20
  109.         For y = 1 To 2
  110.             If y = 2 Then z = 20 Else z = 1
  111.             Room(x, z) = -1
  112.             Room(z, x) = -1
  113.         Next
  114.     Next
  115.  
  116.     ' add random rectangles around the edges
  117.     For i = 1 To 20
  118.         rw = Int(Rnd * 4) + 1: rh = Int(Rnd * 4) + 1
  119.         wall = Int(Rnd * 4)
  120.         Select Case wall
  121.             Case 0 ' top
  122.                 If Rnd < .5 Then ys = 1 Else ys = 4
  123.                 xs = Int(Rnd * (20 - rw)) + 1
  124.                 For y = ys To ys + rh - 1
  125.                     For x = xs To xs + rw - 1
  126.                         Room(x, y) = -1
  127.                     Next
  128.                 Next
  129.             Case 1 'right
  130.                 If Rnd < .5 Then xs = 20 - rw + 1 Else xs = 16 - rw + 1
  131.                 ys = Int(Rnd * (20 - rh)) + 1
  132.                 For y = ys To ys + rh - 1
  133.                     For x = xs To xs + rw - 1
  134.                         Room(x, y) = -1
  135.                     Next
  136.                 Next
  137.             Case 2 ' bottom
  138.                 If Rnd < .5 Then ys = 20 - rh + 1 Else ys = 16 - rh + 1
  139.                 xs = Int(Rnd * (20 - rw)) + 1
  140.                 For y = ys To ys + rh - 1
  141.                     For x = xs To xs + rw - 1
  142.                         Room(x, y) = -1
  143.                     Next
  144.                 Next
  145.             Case 3 'left
  146.                 If Rnd < .5 Then xs = 1 Else xs = 4
  147.                 ys = Int(Rnd * (20 - rh)) + 1
  148.                 For y = ys To ys + rh - 1
  149.                     For x = xs To xs + rw - 1
  150.                         Room(x, y) = -1
  151.                     Next
  152.                 Next
  153.         End Select
  154.     Next
  155.  
  157.  
  158. Sub drawGridSq (x, y, sq, n)
  159.     Dim d As Long, i As Long
  160.     d = sq * n
  161.     For i = 0 To n
  162.         Line (x + sq * i, y)-(x + sq * i, y + d)
  163.         Line (x, y + sq * i)-(x + d, y + sq * i)
  164.     Next
  166.  
  167.  

BTW don't expect the vacuum to access sections that are completely walled off by room obstacles. A bit of a problem picking up on those isolated areas so the code knows when everything that could be swept has been as seen in next code reply.

14
Programs / Ray Trace a translation from SpecBAS
« on: February 26, 2022, 02:39:54 pm »
by Paul Dunn here was the original SpecBAS code:
Code: [Select]
10 PAPER 0: INK 15: CLS:
 palette 16,255,255,255:
 palette 32,0,192,255:
 palette 255,0,0,192:
 rainbow 16 to 32:
 rainbow 32 to 255
20 read spheres:t=msecs:
 DIM c(spheres,3),r(spheres),q(spheres),cl(4):
 w=scrw/2,h=scrh/2,s=0:
 cl(1)=6,cl(2)=1,
 cl(3)=cl(1)+8,cl(4)=cl(2)+8
30 FOR k=1 TO spheres:
    READ c(k,1),c(k,2),c(k,3),r:
    r(k)=r,q(k)=r*r:
 NEXT k
40 data 6:
 DATA -0.3,-0.8,3,0.6
50 DATA 0.9,-1.4,3.5,0.35:
 data 0.7,-0.45,2.5,0.4:
 data -0.5,-0.3,1.5,0.15:
 DATA 1.0,-0.2,1.5,0.1:
 DATA -0.1,-0.2,1.25,0.2
60 FOR i=1 TO scrh:
    FOR j=0 TO scrw-1
70       x=0.3,y=-0.5,z=0,ba=3:
       dx=j-w,dy=h-i,dz=(scrh/480)*600,
       dd=dx*dx+dy*dy+dz*dz
80       n=-(y>=0 OR dy<=0):
       IF n=0 THEN
          s=-y/dy
90       FOR k=1 TO spheres:
          px=c(k,1)-x,py=c(k,2)-y,pz=c(k,3)-z,
          pp=px*px+py*py+pz*pz,
          sc=px*dx+py*dy+pz*dz:
          IF sc<=0 THEN
             GO TO 120
100          bb=sc*sc/dd,
          aa=q(k)-pp+bb:
          IF aa<=0 THEN
             GO TO 120
110          sc=(SQR bb-SQR aa)/SQR dd:
          IF sc<s OR n<0 THEN
             n=k,s=sc
120       NEXT k
130       IF n<0 THEN
          plot ink 16+(dy*dy/dd)*240;j,scrh-i:
          go to 200
140       dx=dx*s,dy=dy*s,dz=dz*s,dd=dd*s*s,
       x+=dx,y+=dy,z+=dz:
       IF n<>0 THEN
           nx=x-c(n,1),ny=y-c(n,2),nz=z-c(n,3),
          nn=nx*nx+ny*ny+nz*nz,
          l=2*(dx*nx+dy*ny+dz*nz)/nn,
          dx=dx-nx*l,dy=dy-ny*l,dz=dz-nz*l:
          GO TO 80
160       FOR k=1 TO spheres:
          u=c(k,1)-x,
          v=c(k,3)-z:
          IF u*u+v*v<=q(k) THEN
             ba=1:
             go to 180
170       NEXT k
180       IF (x-INT x>.5)=(z-INT z>.5) THEN
          ik=cl(ba)
       else
          ik=cl(ba+1)
190       plot ink ik;j,scrh-i       
200    NEXT j:
 NEXT i
210 print at 0,0;transparent 1;ink 0;"Time: ";(msecs-t)/1000;" secs":
 pause 0:

Thanks to Rod at Just Basic for getting ball rolling for JB version, pretty easy from there to QB64
Code: QB64: [Select]
  1. _Title "RayTrace" 'b+ trans from JB to QB64 2022-02-26
  2. Const scrw = 1024, scrh = 680
  3. Screen _NewImage(scrw, scrh, 32)
  4. _ScreenMove 150, 40
  5. Read spheres
  6. Dim c(spheres, 3), r(spheres), q(spheres), cl(4) As _Unsigned Long
  7. w = scrw / 2
  8. h = scrh / 2
  9. s = 0
  10. cl(1) = _RGB32(120, 65, 45) ' shaddow
  11. cl(2) = _RGB32(0, 0, 100)
  12. cl(3) = _RGB32(255, 255, 0)
  13. cl(4) = _RGB32(0, 0, 200)
  14. For k = 1 To spheres
  15.     Read a, b, c, d
  16.     c(k, 1) = a
  17.     c(k, 2) = b
  18.     c(k, 3) = c
  19.     r = d
  20.     r(k) = r
  21.     q(k) = r * r
  23.  
  24. For i = 1 To scrh
  25.     For j = 0 To scrw - 1
  26.         x = 0.3: y = -0.5: z = 0: ba = 3
  27.         dx = j - w: dy = h - i: dz = (scrh / 480) * 600
  28.         dd = dx * dx + dy * dy + dz * dz
  29.         recursion:
  30.         n = (y >= 0 Or dy <= 0) '* -1   <<< Makes $1000 for knowing where to tap the hammer
  31.         If n = 0 Then s = (y / dy) * -1
  32.         For k = 1 To spheres
  33.             px = c(k, 1) - x: py = c(k, 2) - y: pz = c(k, 3) - z
  34.             pp = px * px + py * py + pz * pz
  35.             sc = px * dx + py * dy + pz * dz
  36.             If sc <= 0 Then GoTo donek
  37.             bb = sc * sc / dd
  38.             aa = q(k) - pp + bb
  39.             If aa <= 0 Then GoTo donek
  40.             sc = (Sqr(bb) - Sqr(aa)) / Sqr(dd)
  41.             If sc < s Or n < 0 Then n = k: s = sc
  42.             donek:
  43.         Next k
  44.         If n < 0 Then
  45.             PSet (j, scrh - i), _RGB32(128 * (scrh - i) / scrh + 128 * (dy * dy / dd), 128 * (scrh - i) / scrh + 128 * (dy * dy / dd), 200 + 55 * (dy * dy / dd))
  46.             GoTo donej
  47.         End If
  48.         dx = dx * s: dy = dy * s: dz = dz * s: dd = dd * s * s
  49.         x = x + dx: y = y + dy: z = z + dz
  50.         If n <> 0 Then
  51.             nx = x - c(n, 1): ny = y - c(n, 2): nz = z - c(n, 3)
  52.             nn = nx * nx + ny * ny + nz * nz
  53.             l = 2 * (dx * nx + dy * ny + dz * nz) / nn
  54.             dx = dx - nx * l: dy = dy - ny * l: dz = dz - nz * l
  55.             GoTo recursion
  56.         End If
  57.         For k = 1 To spheres
  58.             u = c(k, 1) - x
  59.             v = c(k, 3) - z
  60.             If u * u + v * v <= q(k) Then ba = 1: Exit For
  61.         Next k
  62.         If (x - Int(x) > .5) = (z - Int(z) > .5) Then
  63.             PSet (j, scrh - i), cl(ba)
  64.         Else
  65.             PSet (j, scrh - i), cl(ba + 1)
  66.         End If
  67.         donej:
  68.     Next j
  71.  
  73. Data -0.3,-0.8,3,0.6
  74. Data 0.9,-1.4,3.5,0.35
  75. Data 0.7,-0.45,2.5,0.4
  76. Data -0.5,-0.3,1.5,0.15
  77. Data 1.0,-0.2,1.5,0.1
  78. Data -0.1,-0.2,1.25,0.2
  79.  
  80.  

 
Ray Trace for QB64.PNG

15
QB64 Discussion / GotBasic - QB64 Mention
« on: February 25, 2022, 11:55:17 am »
https://gotbasic.com

Pages: [1] 2 3 ... 21