Ray Trace a translation from SpecBAS

[bplus]

OMG! LOL yeah pretty nice!

[MasterGy]

he didn’t let me calm down to understand a few things.
It works. Walking in space. Look up, down, spin.
WASD + mouse.

Code: QB64: [Select]

1. _TITLE "RayTrace" 'b+ trans from JB to QB64 2022-02-26
2. scrw = 400
3. scrh = scrw / _DESKTOPWIDTH * _DESKTOPHEIGHT
4.  
5.  
6.  
7.  
8. SCREEN _NEWIMAGE(scrw, scrh, 32)
9. _SCREENMOVE _MIDDLE
10. READ spheres
11. DIM c(spheres, 9), r(spheres), q(spheres), cl(4) AS _UNSIGNED LONG
12. w = scrw / 2
13. h = scrh / 4
14. s = 0
15. cl(1) = _RGB32(120, 65, 45) ' shaddow
16. cl(2) = _RGB32(0, 0, 100)
17. cl(3) = _RGB32(255, 255, 0)
18. cl(4) = _RGB32(0, 0, 200)
19. RANDOMIZE TIMER
20. FOR k = 1 TO spheres
21.     READ a, b, c, d
22.     c(k, 5) = a
23.     c(k, 2) = -(d + .3 + 2 * RND(1))
24.     c(k, 6) = c
25.     c(k, 4) = .1
26.     r = d
27.     r(k) = r
28.     q(k) = r * r
29. NEXT k
30.  
31. me(1) = -0.2: me(2) = -3: me(0) = c(1, 1): me(3) = _PI
32.  
33.  
34. DO
35.  
36.  
37.     'bouncing
38.     FOR k = 1 TO spheres
39.         c(k, 4) = c(k, 4) + .01
40.         ck = c(k, 2) + c(k, 4)
41.         IF -ck < r(k) THEN c(k, 4) = -.2: ck = -r(k)
42.         c(k, 2) = ck
43.     NEXT k
44.  
45.     'control
46.     mousex = 0: mousey = 0: WHILE _MOUSEINPUT: mousex = mousex + _MOUSEMOVEMENTX: mousey = mousey + _MOUSEMOVEMENTY: WEND
47.     me(3) = me(3) + mousex * .01
48.     h = h + mousey * .5
49.     k_a = _KEYDOWN(ASC("a")): k_d = _KEYDOWN(ASC("d")): k_w = _KEYDOWN(ASC("w")): k_s = _KEYDOWN(ASC("s"))
50.     go_ang = -(k_a * 90 + k_d * -90 + k_s * 180 - 180) * (_PI / 180) - me(3)
51.     go = (k_a + k_d + k_w + k_s = -1) * .2
52.     me(0) = me(0) + SIN(go_ang) * go
53.     me(2) = me(2) - COS(go_ang) * go
54.     me(1) = me(1) + (_KEYDOWN(ASC("+")) - _KEYDOWN(ASC("-"))) * .02
55.  
56.     'spheres rotating
57.     FOR k = 1 TO spheres
58.         c(k, 1) = c(k, 5) - me(0)
59.         c(k, 3) = c(k, 6) - me(2)
60.         rotate_2d c(k, 1), c(k, 3), me(3)
61.         c(k, 1) = c(k, 1) + me(0)
62.         c(k, 3) = c(k, 3) + me(2)
63.     NEXT k
64.  
65.  
66.     FOR i = 1 TO scrh STEP 1
67.         FOR j = 0 TO scrw - 1
68.             x = me(0): y = me(1): z = me(2): ba = 3
69.             dx = j - w: dy = h - i: dz = scrw
70.             dd = dx * dx + dy * dy + dz * dz
71.             neverend_cycle_agent = 0
72.             DO: neverend_cycle_agent = neverend_cycle_agent + 1: IF neverend_cycle_agent > 2000 THEN EXIT DO
73.                 n = (y >= 0 OR dy <= 0) '* -1   <<< Makes $1000 for knowing where to tap the hammer
74.                 IF n = 0 THEN s = (y / dy) * -1
75.                 dd_temp = 1 / SQR(dd)
76.                 FOR k = 1 TO spheres
77.                     px = c(k, 1) - x: py = c(k, 2) - y: pz = c(k, 3) - z
78.                     pp = px * px + py * py + pz * pz
79.                     sc = px * dx + py * dy + pz * dz
80.                     IF sc > 0 THEN
81.                         bb = sc * sc / dd
82.                         aa = q(k) - pp + bb
83.                         IF aa > 0 THEN
84.                             sc = (SQR(bb) - SQR(aa)) * dd_temp
85.                             IF sc < s OR n < 0 THEN n = k: s = sc
86.                         END IF
87.                     END IF
88.                 NEXT k
89.                 IF n < 0 THEN
90.                     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))
91.                     EXIT DO
92.                 ELSE
93.                     dx = dx * s: dy = dy * s: dz = dz * s: dd = dd * s * s
94.                     x = x + dx: y = y + dy: z = z + dz
95.                     IF n <> 0 THEN
96.                         nx = x - c(n, 1): ny = y - c(n, 2): nz = z - c(n, 3)
97.                         nn = nx * nx + ny * ny + nz * nz
98.                         l = 2 * (dx * nx + dy * ny + dz * nz) / nn
99.                         dx = dx - nx * l: dy = dy - ny * l: dz = dz - nz * l
100.                     ELSE
101.                         FOR k = 1 TO spheres
102.                             u = c(k, 1) - x
103.                             v = c(k, 3) - z
104.                             IF u * u + v * v <= q(k) THEN ba = 1: EXIT FOR
105.                         NEXT k
106.  
107.                         x2 = x - me(0): z2 = z - me(2): rotate_2d x2, z2, -me(3): x2 = x2 + me(0): z2 = z2 + me(2) 'field rotating
108.  
109.                         IF (x2 - INT(x2) > .5) = (z2 - INT(z2) > .5) THEN 'x,y pepita size
110.                             PSET (j, scrh - i), cl(ba)
111.                         ELSE
112.                             PSET (j, scrh - i), cl(ba + 1)
113.                         END IF
114.                         EXIT DO
115.                     END IF
116.                 END IF
117.             LOOP
118.         NEXT j
119.     NEXT i
120.     _DISPLAY: CLS
121. LOOP
122. SLEEP
123.  
124. DATA 4
125.  
126. DATA -0.3,-0.8,3,0.6
127. DATA 0.9,-1.4,3.5,0.35
128.  
129. DATA 0.7,-0.45,2.5,0.4
130. DATA -0.5,-0.3,1.5,0.25
131. DATA 1.0,-0.2,1.5,0.2
132. DATA -0.1,-0.2,1.25,0.2
133.  
134.  
135. SUB rotate_2d (x, y, ang): x1 = -(x * COS(ang) - y * SIN(ang)): y1 = -(x * SIN(ang) + y * COS(ang)): x = x1: y = y1: END SUB
136.  
137.  

[MasterGy]

I tried something else. If we calculate an image as soil, it still works very well. If we expose the dog to the ground, the dog cannot be recognized on the ground because we are close to the ground and cannot see it at the same time. But if we approach the spheres, the dog can be recognized in the sphere due to the reflection! We can raise the "SCRW" high, it makes a very nice picture, it will only be difficult to navigate because it will be very slow.

Do you see the dog in the sphere?
 

[CharlieJV]

Nothing as wickedly wild as what Master Gy has done.

It is still a bunch of fun mindlessly playing with colors.

 

[bplus]

You guys are doing great things with this, bravo!

[bplus]

Ah! I have tsh73 translation with the Rainbow Sub solved. Now the colors are as they were from the original code ie the sky is no long flat blue PLUS I added some Mods that move the balls and Move your mouse for surprise! (Well not now I guess).

Code: QB64: [Select]

1. 'https://retrobasic.allbasic.info/index.php?topic=721.0
2. 'converting to JB. Tsh73 Feb 2022
3. 'converting to QB64 b+ 2022-03-02 and Mods >>>>   moving balls, move your mouse!
4. _Title "Move your mouse!"
5. Const scrw = 320, scrh = 200
6. Screen _NewImage(scrw, scrh, 32)
7.  
8. Dim Shared As _Unsigned Long qb(15)
9. qb(0) = &HFF000000
10. qb(1) = &HFF000088
11. qb(2) = &HFF008800
12. qb(3) = &HFF008888
13. qb(4) = &HFF880000
14. qb(5) = &HFF880088
15. qb(6) = &HFF888800
16. qb(7) = &HFFCCCCCC
17. qb(8) = &HFF888888
18. qb(9) = &HFF0000FF
19. qb(10) = &HFF00FF00
20. qb(11) = &HFF00FFFF
21. qb(12) = &HFFFF0000
22. qb(13) = &HFFFF00FF
23. qb(14) = &HFFFFFF00
24. qb(15) = &HFFFFFFFF
25.  
26. Dim Shared As _Unsigned Long pal(255)
27.  
28. For i = 0 To 15: pal(i) = qb(i): Next
29. ' pal 16,255,255,255:
30. pal(16) = &HFFFFFFFF
31. ' pal 32,0,192,255:
32. pal(32) = &HFF00CCFF
33. ' pal 255,0,0,192:
34. pal(255) = &HFF0000CC
35. ' rainbow 16 to 32:
36. rainbow 16, 32
37. ' rainbow 32 to 255
38. rainbow 32, 255
39.  
40. Read spheres
41. Dim c(spheres, 3), r(spheres), q(spheres), cl(4), d(spheres, 3)
42. w = scrw / 2: h = scrh / 2: s = 0
43. cl(1) = 6: cl(2) = 1
44. cl(3) = cl(1) + 8: cl(4) = cl(2) + 8
45. For k = 1 To spheres
46.     Read c1, c2, c3, r
47.     c(k, 1) = c1: c(k, 2) = c2: c(k, 3) = c3
48.     d(k, 1) = .01 * (Rnd - .5): d(k, 2) = .01 * (Rnd - .5): d(k, 3) = .01 * (Rnd - .5)
49.     r(k) = r: q(k) = r * r
50. Next k
51.  
52. Data 6
53. Data -0.3,-0.8,3,0.6
54.  
55. Data 0.9,-1.4,3.5,0.35
56. Data 0.7,-0.45,2.5,0.4
57. Data -0.5,-0.3,1.5,0.15
58. Data 1.0,-0.2,1.5,0.1
59. Data -0.1,-0.2,1.25,0.2
60.  
61. Do
62.     lc = lc + 1
63.     If lc = 50 Then toggle = 1 - toggle: lc = 0
64.     For k = 1 To spheres
65.         If toggle Then
66.             c(k, 1) = c(k, 1) + d(k, 1): c(k, 2) = c(k, 2) + d(k, 2): c(k, 3) = c(k, 3) + d(k, 3)
67.         Else
68.             c(k, 1) = c(k, 1) - d(k, 1): c(k, 2) = c(k, 2) - d(k, 2): c(k, 3) = c(k, 3) - d(k, 3)
69.         End If
70.     Next
71.     While _MouseInput: Wend
72.     c(spheres, 1) = -2.5 * (.4 - _MouseX / _Width): c(spheres, 2) = -2. * (.75 * _Height - _MouseY) / _Height: c(spheres, 3) = 2
73.     For i = 1 To scrh
74.         For j = 0 To scrw - 1
75.  
76.             x = 0.3: y = -0.5: z = 0: ba = 3
77.             dx = j - w: dy = h - i: dz = (scrh / 480) * 600
78.             dd = dx * dx + dy * dy + dz * dz
79.             recurs:
80.             b1 = (y >= 0): b2 = (dy <= 0)
81.             b3 = -(b1 Or b2)
82.             n = n - b3
83.             n = 0 - -(y >= 0 Or dy <= 0)
84.  
85.             If n = 0 Then s = 0 - y / dy
86.             For k = 1 To spheres
87.                 px = c(k, 1) - x: py = c(k, 2) - y: pz = c(k, 3) - z
88.                 pp = px * px + py * py + pz * pz
89.                 sc = px * dx + py * dy + pz * dz
90.                 If sc <= 0 Then GoTo continueK
91.                 bb = sc * sc / dd
92.                 aa = q(k) - pp + bb
93.                 If aa <= 0 Then GoTo continueK
94.                 sc = (Sqr(bb) - Sqr(aa)) / Sqr(dd)
95.                 If sc < s Or n < 0 Then n = k: s = sc
96.                 continueK:
97.             Next k
98.  
99.             If n < 0 Then
100.                 'plot ink 16+(dy*dy/dd)*240;j,scrh-i
101.                 c = Int(16 + (dy * dy / dd) * 240)
102.                 '#gr "color ";c;" ";c;" ";c
103.                 If lastCol <> c Then 'prevent extra color switching - JB speed-up
104.                     Color pal(c)
105.                     lastCol = c
106.                 End If
107.                 PSet (j, scrh - i)
108.                 GoTo continueJ
109.             End If
110.             dx = dx * s: dy = dy * s: dz = dz * s: dd = dd * s * s
111.             x = x + dx: y = y + dy: z = z + dz
112.             If n <> 0 Then
113.                 nx = x - c(n, 1): ny = y - c(n, 2): nz = z - c(n, 3)
114.                 nn = nx * nx + ny * ny + nz * nz
115.                 l = 2 * (dx * nx + dy * ny + dz * nz) / nn
116.                 dx = dx - nx * l: dy = dy - ny * l: dz = dz - nz * l
117.                 GoTo recurs 'really only GOTO
118.             End If
119.             For k = 1 To spheres
120.                 u = c(k, 1) - x
121.                 v = c(k, 3) - z
122.                 If u * u + v * v <= q(k) Then
123.                     ba = 1
124.                     Exit For
125.                 End If
126.             Next k
127.             If (x - Int(x) > .5) = (z - Int(z) > .5) Then
128.                 'needs "int to lower" vs "int to 0"
129.                 'If (x - (Int(x) - (x <> Int(x)) * (x < 0)) > .5) = (z - (Int(z) - (z <> Int(z)) * (z < 0)) > .5) Then
130.                 'If (x Mod 1 + (x < 0) > .5) = (z Mod 1 + (z < 0) > .5) Then
131.                 ik = cl(ba)
132.             Else
133.                 ik = cl(ba + 1)
134.             End If
135.             'plot ink ik;j,scrh-i
136.             '#gr "color ";ik;" ";ik;" ";ik
137.             If lastCol <> ik Then 'prevent extra color switching
138.                 Color pal(ik)
139.                 lastCol = ik
140.             End If
141.             PSet (j, scrh - i)
142.             continueJ:
143.         Next j
144.     Next i
145.     _Display
146. Loop
147.  
148. Sub rainbow (startIdx, stopIdx)
149.     r0 = _Red32(pal(startIdx))
150.     r1 = _Red32(pal(stopIdx))
151.     g0 = _Green32(pal(startIdx))
152.     g1 = _Green32(pal(stopIdx))
153.     b0 = _Blue32(pal(startIdx))
154.     b1 = _Blue32(pal(stopIdx))
155.     For i = startIdx + 1 To stopIdx - 1
156.         a = 1 - (stopIdx - i) / (stopIdx - startIdx) 'startIdx..stopIdx -> 0..1
157.         R = Int(r0 * (1 - a) + r1 * a)
158.         G = Int(g0 * (1 - a) + g1 * a)
159.         B = Int(b0 * (1 - a) + b1 * a)
160.         pal(i) = _RGB32(R, G, B)
161.     Next
162. End Sub
163.  
164.  

Colors as they should be: