|
Post by bplus on Feb 11, 2024 14:12:13 GMT
Wow nice! Good idea to keep turning for 3D
Rule: Survival? If mm < 9 Or mm > 18 Then U2(x, y, z) = -1 Else U2(x, y, z) = 1 Birth? If (mm > 12 And mm < 18) Then U2(x, y, z) = 1 Else U2(x, y, z) = -1
Only 61 lines!
|
|
|
Post by anthonyrbrown on Feb 11, 2024 14:38:05 GMT
3Dversion !! ( hit space to restart! ) Screen _NewImage(800, 600, 32) Dim As Integer MAX, MAX2 MAX = 45: MAX2 = MAX / 2 Dim U(MAX, MAX, MAX) As _Byte Dim U2(MAX, MAX, MAX) As _Byte start: Randomize Timer For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If Rnd > .5 Then U(x, y, z) = 1 Else U(x, y, z) = -1 Next z, y, x Do Cls cos1 = Cos(Timer * .5) sin1 = Sin(Timer * .5) For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If U(x, y, z) = 1 Then px = (x - MAX2) * cos1 - (z - MAX2) * sin1 pz = (x - MAX2) * sin1 + (z - MAX2) * cos1 py = y - MAX2 ax = _Width / 2 + 450 * (px) / (MAX + pz + MAX2) ay = _Height / 2 + 450 * (py) / (MAX + pz + MAX2) cl = (205 - ((pz + MAX2) / MAX) * 205) + 50 PSet (ax, ay), _RGB(cl, cl, cl) End If Next z, y, x For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 mm = 0 If U(x, y, z) = 1 Then For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If mm < 9 Or mm > 18 Then U2(x, y, z) = -1 Else U2(x, y, z) = 1 If mmax < mm Then mmax = mm Else For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If mmax2 < mm Then mmax2 = mm If (mm > 12 And mm < 18) Then U2(x, y, z) = 1 Else U2(x, y, z) = -1 End If Next z, y, x _Display For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 U(x, y, z) = U2(x, y, z) Next z, y, x If _KeyDown(32) Then GoTo start Loop Until _KeyDown(27) WOW! So Cool ubi44 It's Amazing what a little accurate! code will do,I am sure there are lot's of things that can be done with that code! Just fantastic!!! A.R.B
|
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Feb 11, 2024 15:39:38 GMT
Thank you!
I just added colors to get a better look at "life". In red the births, in blue the deaths, in grey still alive!
The rules give a nice visual, with other rules there are changes with each generation, sometimes everything dies, sometimes it's overpopulation. It's not easy!
Screen _NewImage(800, 600, 32) Dim As Integer MAX, MAX2 MAX = 45: MAX2 = MAX / 2 Dim U(MAX, MAX, MAX) As _Byte Dim U2(MAX, MAX, MAX) As _Byte Dim c(MAX, MAX, MAX) start: Randomize Timer For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If Rnd > .5 Then U(x, y, z) = 1: c(x, y, z) = 1 Else U(x, y, z) = -1 Next z, y, x Do Cls cos1 = Cos(Timer * .5) sin1 = Sin(Timer * .5) For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If U(x, y, z) = 1 Or c(x, y, z) = 2 Then px = (x - MAX2) * cos1 - (z - MAX2) * sin1 pz = (x - MAX2) * sin1 + (z - MAX2) * cos1 py = y - MAX2 ax = _Width / 2 + 450 * (px) / (MAX + pz + MAX2) ay = _Height / 2 + 450 * (py) / (MAX + pz + MAX2) cl = (205 - ((pz + MAX2) / MAX) * 205) + 50 Select Case c(x, y, z) Case 0: PSet (ax, ay), _RGB(cl, cl, cl) Case 1: Circle (ax, ay), (cl / 255) * 3, _RGB(cl, cl / 10, 0) Case 2: Circle (ax, ay), (cl / 255) * 3, _RGB(0, cl / 2, cl) End Select c(x, y, z) = 0 End If Next z, y, x For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 mm = 0 If U(x, y, z) = 1 Then For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If mm < 9 Or mm > 18 Then U2(x, y, z) = -1: c(x, y, z) = 2 Else U2(x, y, z) = 1: c(x, y, z) = 0 Else For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If (mm > 12 And mm < 18) Then U2(x, y, z) = 1: c(x, y, z) = 1: Else U2(x, y, z) = -1 End If Next z, y, x _Display For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 U(x, y, z) = U2(x, y, z) Next z, y, x If _KeyDown(32) Then GoTo start Loop Until _KeyDown(27)
|
|
|
Post by anthonyrbrown on Feb 11, 2024 15:57:28 GMT
You just beat me to it ubi44 as I was finishing my dinner! I just can't stop looking at this,it's definitely one of my Top 10 best programs I have ever seen! you have taken this right out of my brain and put it on the screen,which comes to what I was going to ask you,as if your program is not already Amazing enough! I would much rather look at it than any Screen saver,showing glowing logs burning etc. (Ah! a Cash/Money moment!!!) how about a LIFE3D-Screen-Saver App Now what I was going to ask... Is there any way you can add some different colours to the lifes? I would love to see this on a large TV monitor so you can look deep into the 3D World any chance of different display sizes from what you have and in between up to large screen format? And lastly any chance of a speed of play option at the start like very slow to very fast maybe from 1 - 100 ? which would help when studying the 3D World ? All of that and I am ready to retire! Thanks you have made my day! A.R.B
|
|
|
Post by bplus on Feb 11, 2024 16:07:20 GMT
Yeah I added _Limit 10 after the CLS to slow down the action, now I can see more active blue areas moving around clusters.
Slow the spin and the frame update:
Do
Cls
_Limit 2 ' new cos1 = Cos(Timer * .05) 'edit sin1 = Sin(Timer * .05) 'edit
Oh yeah! Try it _FullScreeen
|
|
|
Post by bplus on Feb 12, 2024 4:33:58 GMT
Game of Life Cubed: Option _Explicit _Title "3D Render: Game of Life Cubed, hold enter key to reset" ' B+ started 2019-10-20 (as Vector Math) ' Based on notes provided to QB64 forum by William F Barnes, on 2019-10-19 ' https://www.qb64.org/forum/index.php?topic=1782.0 ' A vector's dimension is the number of components it has. ' Here is code for processing 2 and 3 dimension vectors.
'2019-11-20 add STxAxTIC's conversion code for new sub screenXY ' Nice cube corners maker and nice wireframe cube
'2019-11-22 3D render 2, Upon STxAxTIC's advice crank up the FOVD, ' I did and found a nice range of cube like cubes, I also have a check ' for xyz to see if it is viewable, which we will test with FOVD. ' Oddly I had to make FOVD negative in order to get the numbers in the ' correct quadrants. When the cube center crosses into positive, ' the quadrants will flip-flop, but still a nice cube is drawn. ' When the cube center is at z=0 you will see a big X across screen!
'2021-12-19 3D Render 3: Cube of Cubes for Graphics Test #3
' 2024-02-11 try 3d Game of Life ?
Const sxmax = 700, symax = 700 Const tlx = -20, tly = 20, brx = 20, bry = -20 ' Cartesian Coordinate System corners for WINDOW command ' to convert mouse coordinates to WINDOW after call look up PMAP
Type xyType x As Single y As Single End Type
Type xyzType x As Single y As Single z As Single End Type
' notation 0 w/arrowHat (no way of telling if 2, 3 or more dimensions) Dim Shared v2zero As xyType, v3zero As xyzType v2zero.x = 0: v2zero.y = 0 v3zero.x = 0: v3zero.y = 0: v3zero.z = 0
'Basis Vectors, isolate components e sub x Dot V w/arrowHat = V sub x Dim Shared v2e(1 To 2) As xyType, v3e(1 To 3) As xyzType v2e(1).x = 1: v2e(1).y = 0 v2e(2).x = 0: v2e(2).y = 1 v3e(1).x = 1: v3e(1).y = 0: v3e(1).z = 0 v3e(2).x = 0: v3e(2).y = 1: v3e(2).z = 0 v3e(3).x = 0: v3e(3).y = 0: v3e(3).z = 1
Dim Shared fovd As Double 'for screenXY of (x, y, z) point in real space fovd = -60 '???
Dim Shared zmin, zmax, xmin, xmax, ymin, ymax zmin = -32: zmax = -21 xmin = -6: xmax = 6 ymin = -6: ymax = 6
Screen _NewImage(sxmax, symax, 32) 'square screen _ScreenMove 300, 40 Randomize Timer Window (tlx, tly)-(brx, bry) ' <<<<<<<<<<<<<<<<<<<< get a Cartesian Coordinate System started ' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>> to convert mouse coordinates to WINDOW after call look up PMAP ' ==================================== end of 3D Render setup ?
Dim As Integer U(xmin To xmax, ymin To ymax, zmin To zmax), U2(xmin To xmax, ymin To ymax, zmin To zmax) Dim As Integer x, y, z, i, j, r, g, b, mm, xx, yy, zz, rr, gg, bb ReDim testCube(0) As xyzType
restart: For z = zmin + 1 To zmax - 1 For x = xmin + 1 To xmax - 1 For y = ymin + 1 To ymax - 1 If Rnd > .8 Then U(x, y, z) = 1 Next y, x, z rr = Rnd * 50 + 50: gg = Rnd * 50 + 50: bb = Rnd * 50 + 50 Do Cls r = rr: g = gg: b = bb For z = zmin + 1 To zmax - 1 r = r + 15: g = g + 15: b = b + 15 Color _RGB32(r, g, b, 200) For x = xmin + 1 To xmax - 1 For y = ymin + 1 To ymax - 1 If U(x, y, z) = 1 Then newCube x, y, z, 1, testCube() ' finds 8 xyz point corners given x,y,z center and side ReDim screenTest(0 To 7) As xyType For i = 0 To 7 screenXY testCube(i), screenTest(i) ' take a corner x,y,z and convert to screen coordinates x,y 'PRINT screenTest(i).x, screenTest(i).y Next drawWireCube screenTest() ' draw cube from screen coodinates End If Next y, x, z _Display _Limit 2 If _KeyDown(13) Then Cls: _Delay .5: GoTo restart For z = zmin + 1 To zmax - 1 For x = xmin + 1 To xmax - 1 For y = ymin + 1 To ymax - 1 mm = 0 For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then Else If U(xx, yy, zz) = 1 Then mm = mm + 1 End If Next zz, yy, xx If (mm > 5) And (mm < 12) Then U2(x, y, z) = 1 ElseIf U(x, y, z) = 1 And mm < 10 And mm > 5 Then U2(x, y, z) = 1 Else U2(x, y, z) = 0 End If Next y, x, z
For z = zmin + 1 To zmax - 1 For x = xmin + 1 To xmax - 1 For y = ymin + 1 To ymax - 1 U(x, y, z) = U2(x, y, z) Next y, x, z
Loop Until _KeyDown(27)
'this code decides if x,y,z on real map is in square cone of vision 'DIM SHARED zmin, zmax, xmin, xmax, ymin, ymax 'move to top 'zmin = -50: zmax = -1 'xmin = -50: xmax = 50 'ymin = -50: ymax = 50 Function xyzInView (test As xyzType) If test.z >= zmin And test.z <= zmax Then If Abs(test.x) <= .5 * Abs(test.z) Then If Abs(test.y) <= .5 * Abs(test.z) Then xyzInView = -1 End If End If End Function
'bring this in for testing xyzInView Function irnd% (n1, n2) 'return an integer between 2 numbers Dim l%, h% If n1 > n2 Then l% = n2: h% = n1 Else l% = n1: h% = n2 irnd% = Int(Rnd * (h% - l% + 1)) + l% End Function
' ========================================================================= 2019-11-20 code Sub drawWireCube (corners() As xyType) 'front face Line (corners(0).x, corners(0).y)-(corners(1).x, corners(1).y) Line -(corners(2).x, corners(2).y) Line -(corners(3).x, corners(3).y) Line -(corners(0).x, corners(0).y) 'back face Line (corners(4).x, corners(4).y)-(corners(5).x, corners(5).y), _DefaultColor - _RGB32(50, 50, 0) Line -(corners(6).x, corners(6).y), _DefaultColor - _RGB32(50, 50, 0) Line -(corners(7).x, corners(7).y), _DefaultColor - _RGB32(50, 50, 0) Line -(corners(4).x, corners(4).y), _DefaultColor - _RGB32(50, 50, 0) 'connect front to back Line (corners(0).x, corners(0).y)-(corners(4).x, corners(4).y), _DefaultColor - _RGB32(25, 25, 0) Line (corners(1).x, corners(1).y)-(corners(5).x, corners(5).y), _DefaultColor - _RGB32(25, 25, 0) Line (corners(2).x, corners(2).y)-(corners(6).x, corners(6).y), _DefaultColor - _RGB32(25, 25, 0) Line (corners(3).x, corners(3).y)-(corners(7).x, corners(7).y), _DefaultColor - _RGB32(25, 25, 0) End Sub
Sub newCube (cx, cy, cz, side, cubeCorners() As xyzType) Dim sd2, lx, rx, ty, by, fz, bz ReDim cubeCorners(0 To 7) As xyzType sd2 = side / 2 rx = cx + sd2: lx = cx - sd2 ty = cy + sd2: by = cy - sd2 fz = cz + sd2: bz = cz - sd2 cubeCorners(0).x = lx: cubeCorners(0).y = ty: cubeCorners(0).z = fz cubeCorners(1).x = rx: cubeCorners(1).y = ty: cubeCorners(1).z = fz cubeCorners(2).x = rx: cubeCorners(2).y = by: cubeCorners(2).z = fz cubeCorners(3).x = lx: cubeCorners(3).y = by: cubeCorners(3).z = fz cubeCorners(4).x = lx: cubeCorners(4).y = ty: cubeCorners(4).z = bz cubeCorners(5).x = rx: cubeCorners(5).y = ty: cubeCorners(5).z = bz cubeCorners(6).x = rx: cubeCorners(6).y = by: cubeCorners(6).z = bz cubeCorners(7).x = lx: cubeCorners(7).y = by: cubeCorners(7).z = bz End Sub
' project (x, y, z) point in real space to screenXY of user's eye-line Sub screenXY (xyzReal As xyzType, xyScreen As xyType) 'convert STxAxTIC's code to my code here ' https://www.qb64.org/forum/index.php?topic=1904.msg111304#msg111304
' vec3Ddotnhat = vec(i, 1) * nhat(1) + vec(i, 2) * nhat(2) + vec(i, 3) * nhat(3) ' vec2D(i, 1) = (vec(i, 1) * uhat(1) + vec(i, 2) * uhat(2) + vec(i, 3) * uhat(3)) * fovd / vec3Ddotnhat ' vec2D(i, 2) = (vec(i, 1) * vhat(1) + vec(i, 2) * vhat(2) + vec(i, 3) * vhat(3)) * fovd / vec3Ddotnhat
'my comments and conversion 'fovd seems like a variable that should be globally shared, maybe constant? Dim vec3Ddotnhat vec3Ddotnhat = v3DotProduct(xyzReal, v3e(3)) xyScreen.x = v3DotProduct(xyzReal, v3e(1)) * fovd / vec3Ddotnhat xyScreen.y = v3DotProduct(xyzReal, v3e(2)) * fovd / vec3Ddotnhat End Sub
'================================================= subs and fuctions from Vector Math.bas 2019-10-20 Sub setV3 (x, y, z, setMe As xyzType) setMe.x = x: setMe.y = y: setMe.z = z End Sub
Function v3$ (showMeInnards As xyzType) v3$ = "[" + ts$(showMeInnards.x) + ", " + ts$(showMeInnards.y) + ", " + ts$(showMeInnards.z) + "]" End Function
Function ts$ (number) ts$ = _Trim$(Str$(number)) End Function
'notation UppercaseLetter w/arrowhat + uppercase Letter w/arrowHat Sub v2Add (A As xyType, B As xyType, Sum As xyType) Sum.x = A.x + B.x Sum.y = A.y + B.y End Sub Sub v3Add (A As xyzType, B As xyzType, Sum As xyzType) Sum.x = A.x + B.x Sum.y = A.y + B.y Sum.z = A.z + B.z End Sub
'notation UppercaseLetter w/arrowHat - UppercaseLetter w/arrowHat Sub v2Subtr (A As xyType, B As xyType, Sum As xyType) Sum.x = A.x - B.x Sum.y = A.y - B.y End Sub Sub v3Subtr (A As xyzType, B As xyzType, Sum As xyzType) Sum.x = A.x - B.x Sum.y = A.y - B.y Sum.z = A.z - B.z End Sub
'notation lowercaseletter (for a number next to (times)) UppercaseLetter w/arrowHat Sub v2Scale (mult As Single, A As xyType, Scale As xyType) 'parallels Scale.x = mult * A.x Scale.y = mult * A.y End Sub Sub v3Scale (mult As Single, A As xyzType, Scale As xyzType) 'parallels Scale.x = mult * A.x Scale.y = mult * A.y Scale.z = mult * A.z End Sub
'notation the inverse of A w/arrowHat is -A w/arrowHat Sub v2Inverse (A As xyType, Inverse As xyType) ' A + InverseOfA = 0 Inverse.x = -A.x Inverse.y = -A.y End Sub Sub v3Inverse (A As xyzType, Inverse As xyzType) ' A + InverseOfA = 0 Inverse.x = -A.x Inverse.y = -A.y Inverse.z = -A.z End Sub
'notation: A w/arrowHat Dot B w/arrowHat v2 Dot Product is a number, v3 Dot Product is a vector Function v2DotProduct (A As xyType, B As xyType) 'shadow or projection if A Dot B = 0 then A , B are perpendicular v2DotProduct = A.x * B.x + A.y * B.y End Function Function v3DotProduct (A As xyzType, B As xyzType) 'shadow or projection if A Dot B = 0 then A , B are perpendicular v3DotProduct = A.x * B.x + A.y * B.y + A.z * B.z End Function
'notation absolute value bars about A w/arrowHat OR just an UppercaseLetter (with no hat), its just a number Function v2Magnitude (A As xyType) 'hypotenuse of right triangle v2Magnitude = Sqr(v2DotProduct(A, A)) End Function Function v3Magnitude (A As xyzType) 'hypotenuse of cube v3Magnitude = Sqr(v3DotProduct(A, A)) End Function
'notation: A w/arrowHat X B w/arrowHat, X is a Cross get it? Function v2CrossProduct (A As xyType, B As xyType) ' a vector perpendicular to both A and B, v2 is a magnitude v2CrossProduct = A.x * B.y - A.y * B.x End Function Sub v3CrossProduct (A As xyzType, B As xyzType, Cross As xyzType) ' v3 cross product is a 3d vector perpendicular to A and B 'notice x has no x components, y no y componets, z no z components Cross.x = A.y * B.z - A.z * B.y Cross.y = A.z * B.x - A.x * B.z Cross.z = A.x * B.y - A.y * B.x End Sub
'notation: A w/caratHat = A w/arrowHat divided by A (UppercaseLetter) or scaled by 1/A magnitude (no hats) Sub v2Unit (A As xyType, Unit As xyType) Dim m As Single m = v2Magnitude(A) v2Scale 1 / m, A, Unit End Sub Sub v3Unit (A As xyzType, Unit As xyzType) Dim m As Single m = v3Magnitude(A) v3Scale 1 / m, A, Unit End Sub
|
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Feb 12, 2024 8:54:39 GMT
Bravo! Really interesting! I'm impressed with the setup 3D. I also intended to make cubes but I got stuck in the implementation (too complicated to join each cube to each other).
|
|
|
Post by anthonyrbrown on Feb 12, 2024 9:23:20 GMT
Game of Life Cubed: Option _Explicit _Title "3D Render: Game of Life Cubed, hold enter key to reset" ' B+ started 2019-10-20 (as Vector Math) ' Based on notes provided to QB64 forum by William F Barnes, on 2019-10-19 ' https://www.qb64.org/forum/index.php?topic=1782.0 ' A vector's dimension is the number of components it has. ' Here is code for processing 2 and 3 dimension vectors.
'2019-11-20 add STxAxTIC's conversion code for new sub screenXY ' Nice cube corners maker and nice wireframe cube
'2019-11-22 3D render 2, Upon STxAxTIC's advice crank up the FOVD, ' I did and found a nice range of cube like cubes, I also have a check ' for xyz to see if it is viewable, which we will test with FOVD. ' Oddly I had to make FOVD negative in order to get the numbers in the ' correct quadrants. When the cube center crosses into positive, ' the quadrants will flip-flop, but still a nice cube is drawn. ' When the cube center is at z=0 you will see a big X across screen!
'2021-12-19 3D Render 3: Cube of Cubes for Graphics Test #3
' 2024-02-11 try 3d Game of Life ?
Const sxmax = 700, symax = 700 Const tlx = -20, tly = 20, brx = 20, bry = -20 ' Cartesian Coordinate System corners for WINDOW command ' to convert mouse coordinates to WINDOW after call look up PMAP
Type xyType x As Single y As Single End Type
Type xyzType x As Single y As Single z As Single End Type
' notation 0 w/arrowHat (no way of telling if 2, 3 or more dimensions) Dim Shared v2zero As xyType, v3zero As xyzType v2zero.x = 0: v2zero.y = 0 v3zero.x = 0: v3zero.y = 0: v3zero.z = 0
'Basis Vectors, isolate components e sub x Dot V w/arrowHat = V sub x Dim Shared v2e(1 To 2) As xyType, v3e(1 To 3) As xyzType v2e(1).x = 1: v2e(1).y = 0 v2e(2).x = 0: v2e(2).y = 1 v3e(1).x = 1: v3e(1).y = 0: v3e(1).z = 0 v3e(2).x = 0: v3e(2).y = 1: v3e(2).z = 0 v3e(3).x = 0: v3e(3).y = 0: v3e(3).z = 1
Dim Shared fovd As Double 'for screenXY of (x, y, z) point in real space fovd = -60 '???
Dim Shared zmin, zmax, xmin, xmax, ymin, ymax zmin = -32: zmax = -21 xmin = -6: xmax = 6 ymin = -6: ymax = 6
Screen _NewImage(sxmax, symax, 32) 'square screen _ScreenMove 300, 40 Randomize Timer Window (tlx, tly)-(brx, bry) ' <<<<<<<<<<<<<<<<<<<< get a Cartesian Coordinate System started ' >>>>>>>>>>>>>>>>>>>>>>>>>>>>>> to convert mouse coordinates to WINDOW after call look up PMAP ' ==================================== end of 3D Render setup ?
Dim As Integer U(xmin To xmax, ymin To ymax, zmin To zmax), U2(xmin To xmax, ymin To ymax, zmin To zmax) Dim As Integer x, y, z, i, j, r, g, b, mm, xx, yy, zz, rr, gg, bb ReDim testCube(0) As xyzType
restart: For z = zmin + 1 To zmax - 1 For x = xmin + 1 To xmax - 1 For y = ymin + 1 To ymax - 1 If Rnd > .8 Then U(x, y, z) = 1 Next y, x, z rr = Rnd * 50 + 50: gg = Rnd * 50 + 50: bb = Rnd * 50 + 50 Do Cls r = rr: g = gg: b = bb For z = zmin + 1 To zmax - 1 r = r + 15: g = g + 15: b = b + 15 Color _RGB32(r, g, b, 200) For x = xmin + 1 To xmax - 1 For y = ymin + 1 To ymax - 1 If U(x, y, z) = 1 Then newCube x, y, z, 1, testCube() ' finds 8 xyz point corners given x,y,z center and side ReDim screenTest(0 To 7) As xyType For i = 0 To 7 screenXY testCube(i), screenTest(i) ' take a corner x,y,z and convert to screen coordinates x,y 'PRINT screenTest(i).x, screenTest(i).y Next drawWireCube screenTest() ' draw cube from screen coodinates End If Next y, x, z _Display _Limit 2 If _KeyDown(13) Then Cls: _Delay .5: GoTo restart For z = zmin + 1 To zmax - 1 For x = xmin + 1 To xmax - 1 For y = ymin + 1 To ymax - 1 mm = 0 For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then Else If U(xx, yy, zz) = 1 Then mm = mm + 1 End If Next zz, yy, xx If (mm > 5) And (mm < 12) Then U2(x, y, z) = 1 ElseIf U(x, y, z) = 1 And mm < 10 And mm > 5 Then U2(x, y, z) = 1 Else U2(x, y, z) = 0 End If Next y, x, z
For z = zmin + 1 To zmax - 1 For x = xmin + 1 To xmax - 1 For y = ymin + 1 To ymax - 1 U(x, y, z) = U2(x, y, z) Next y, x, z
Loop Until _KeyDown(27)
'this code decides if x,y,z on real map is in square cone of vision 'DIM SHARED zmin, zmax, xmin, xmax, ymin, ymax 'move to top 'zmin = -50: zmax = -1 'xmin = -50: xmax = 50 'ymin = -50: ymax = 50 Function xyzInView (test As xyzType) If test.z >= zmin And test.z <= zmax Then If Abs(test.x) <= .5 * Abs(test.z) Then If Abs(test.y) <= .5 * Abs(test.z) Then xyzInView = -1 End If End If End Function
'bring this in for testing xyzInView Function irnd% (n1, n2) 'return an integer between 2 numbers Dim l%, h% If n1 > n2 Then l% = n2: h% = n1 Else l% = n1: h% = n2 irnd% = Int(Rnd * (h% - l% + 1)) + l% End Function
' ========================================================================= 2019-11-20 code Sub drawWireCube (corners() As xyType) 'front face Line (corners(0).x, corners(0).y)-(corners(1).x, corners(1).y) Line -(corners(2).x, corners(2).y) Line -(corners(3).x, corners(3).y) Line -(corners(0).x, corners(0).y) 'back face Line (corners(4).x, corners(4).y)-(corners(5).x, corners(5).y), _DefaultColor - _RGB32(50, 50, 0) Line -(corners(6).x, corners(6).y), _DefaultColor - _RGB32(50, 50, 0) Line -(corners(7).x, corners(7).y), _DefaultColor - _RGB32(50, 50, 0) Line -(corners(4).x, corners(4).y), _DefaultColor - _RGB32(50, 50, 0) 'connect front to back Line (corners(0).x, corners(0).y)-(corners(4).x, corners(4).y), _DefaultColor - _RGB32(25, 25, 0) Line (corners(1).x, corners(1).y)-(corners(5).x, corners(5).y), _DefaultColor - _RGB32(25, 25, 0) Line (corners(2).x, corners(2).y)-(corners(6).x, corners(6).y), _DefaultColor - _RGB32(25, 25, 0) Line (corners(3).x, corners(3).y)-(corners(7).x, corners(7).y), _DefaultColor - _RGB32(25, 25, 0) End Sub
Sub newCube (cx, cy, cz, side, cubeCorners() As xyzType) Dim sd2, lx, rx, ty, by, fz, bz ReDim cubeCorners(0 To 7) As xyzType sd2 = side / 2 rx = cx + sd2: lx = cx - sd2 ty = cy + sd2: by = cy - sd2 fz = cz + sd2: bz = cz - sd2 cubeCorners(0).x = lx: cubeCorners(0).y = ty: cubeCorners(0).z = fz cubeCorners(1).x = rx: cubeCorners(1).y = ty: cubeCorners(1).z = fz cubeCorners(2).x = rx: cubeCorners(2).y = by: cubeCorners(2).z = fz cubeCorners(3).x = lx: cubeCorners(3).y = by: cubeCorners(3).z = fz cubeCorners(4).x = lx: cubeCorners(4).y = ty: cubeCorners(4).z = bz cubeCorners(5).x = rx: cubeCorners(5).y = ty: cubeCorners(5).z = bz cubeCorners(6).x = rx: cubeCorners(6).y = by: cubeCorners(6).z = bz cubeCorners(7).x = lx: cubeCorners(7).y = by: cubeCorners(7).z = bz End Sub
' project (x, y, z) point in real space to screenXY of user's eye-line Sub screenXY (xyzReal As xyzType, xyScreen As xyType) 'convert STxAxTIC's code to my code here ' https://www.qb64.org/forum/index.php?topic=1904.msg111304#msg111304
' vec3Ddotnhat = vec(i, 1) * nhat(1) + vec(i, 2) * nhat(2) + vec(i, 3) * nhat(3) ' vec2D(i, 1) = (vec(i, 1) * uhat(1) + vec(i, 2) * uhat(2) + vec(i, 3) * uhat(3)) * fovd / vec3Ddotnhat ' vec2D(i, 2) = (vec(i, 1) * vhat(1) + vec(i, 2) * vhat(2) + vec(i, 3) * vhat(3)) * fovd / vec3Ddotnhat
'my comments and conversion 'fovd seems like a variable that should be globally shared, maybe constant? Dim vec3Ddotnhat vec3Ddotnhat = v3DotProduct(xyzReal, v3e(3)) xyScreen.x = v3DotProduct(xyzReal, v3e(1)) * fovd / vec3Ddotnhat xyScreen.y = v3DotProduct(xyzReal, v3e(2)) * fovd / vec3Ddotnhat End Sub
'================================================= subs and fuctions from Vector Math.bas 2019-10-20 Sub setV3 (x, y, z, setMe As xyzType) setMe.x = x: setMe.y = y: setMe.z = z End Sub
Function v3$ (showMeInnards As xyzType) v3$ = "[" + ts$(showMeInnards.x) + ", " + ts$(showMeInnards.y) + ", " + ts$(showMeInnards.z) + "]" End Function
Function ts$ (number) ts$ = _Trim$(Str$(number)) End Function
'notation UppercaseLetter w/arrowhat + uppercase Letter w/arrowHat Sub v2Add (A As xyType, B As xyType, Sum As xyType) Sum.x = A.x + B.x Sum.y = A.y + B.y End Sub Sub v3Add (A As xyzType, B As xyzType, Sum As xyzType) Sum.x = A.x + B.x Sum.y = A.y + B.y Sum.z = A.z + B.z End Sub
'notation UppercaseLetter w/arrowHat - UppercaseLetter w/arrowHat Sub v2Subtr (A As xyType, B As xyType, Sum As xyType) Sum.x = A.x - B.x Sum.y = A.y - B.y End Sub Sub v3Subtr (A As xyzType, B As xyzType, Sum As xyzType) Sum.x = A.x - B.x Sum.y = A.y - B.y Sum.z = A.z - B.z End Sub
'notation lowercaseletter (for a number next to (times)) UppercaseLetter w/arrowHat Sub v2Scale (mult As Single, A As xyType, Scale As xyType) 'parallels Scale.x = mult * A.x Scale.y = mult * A.y End Sub Sub v3Scale (mult As Single, A As xyzType, Scale As xyzType) 'parallels Scale.x = mult * A.x Scale.y = mult * A.y Scale.z = mult * A.z End Sub
'notation the inverse of A w/arrowHat is -A w/arrowHat Sub v2Inverse (A As xyType, Inverse As xyType) ' A + InverseOfA = 0 Inverse.x = -A.x Inverse.y = -A.y End Sub Sub v3Inverse (A As xyzType, Inverse As xyzType) ' A + InverseOfA = 0 Inverse.x = -A.x Inverse.y = -A.y Inverse.z = -A.z End Sub
'notation: A w/arrowHat Dot B w/arrowHat v2 Dot Product is a number, v3 Dot Product is a vector Function v2DotProduct (A As xyType, B As xyType) 'shadow or projection if A Dot B = 0 then A , B are perpendicular v2DotProduct = A.x * B.x + A.y * B.y End Function Function v3DotProduct (A As xyzType, B As xyzType) 'shadow or projection if A Dot B = 0 then A , B are perpendicular v3DotProduct = A.x * B.x + A.y * B.y + A.z * B.z End Function
'notation absolute value bars about A w/arrowHat OR just an UppercaseLetter (with no hat), its just a number Function v2Magnitude (A As xyType) 'hypotenuse of right triangle v2Magnitude = Sqr(v2DotProduct(A, A)) End Function Function v3Magnitude (A As xyzType) 'hypotenuse of cube v3Magnitude = Sqr(v3DotProduct(A, A)) End Function
'notation: A w/arrowHat X B w/arrowHat, X is a Cross get it? Function v2CrossProduct (A As xyType, B As xyType) ' a vector perpendicular to both A and B, v2 is a magnitude v2CrossProduct = A.x * B.y - A.y * B.x End Function Sub v3CrossProduct (A As xyzType, B As xyzType, Cross As xyzType) ' v3 cross product is a 3d vector perpendicular to A and B 'notice x has no x components, y no y componets, z no z components Cross.x = A.y * B.z - A.z * B.y Cross.y = A.z * B.x - A.x * B.z Cross.z = A.x * B.y - A.y * B.x End Sub
'notation: A w/caratHat = A w/arrowHat divided by A (UppercaseLetter) or scaled by 1/A magnitude (no hats) Sub v2Unit (A As xyType, Unit As xyType) Dim m As Single m = v2Magnitude(A) v2Scale 1 / m, A, Unit End Sub Sub v3Unit (A As xyzType, Unit As xyzType) Dim m As Single m = v3Magnitude(A) v3Scale 1 / m, A, Unit End Sub
That is out of this World! bplus and has taken this project up another notch! Ah! my creative juices are really flowing now...how about a Hexagon version!? I am sure that is extremely complicated to code??? View Attachment
|
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Feb 12, 2024 20:44:01 GMT
Finally here is my cubisue version ecran (_width,_height) is the depth buffer !
Screen _NewImage(640, 488, 32) _AllowFullScreen _SquarePixels _FullScreen _SquarePixels , _Smooth Dim As Integer MAX, MAX2
start: MAX = 25 + Int(Rnd * 25): MAX2 = MAX / 2 ReDim U(MAX, MAX, MAX) As _Byte ReDim U2(MAX, MAX, MAX) As _Byte
MoveZ = -MAX2 / 2 rand = (Rnd - Rnd * .25) * .2 Randomize Timer t = 0 For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If Rnd < .5 + rand Then U(x, y, z) = 1: t = t + 1 Else U(x, y, z) = -1 Next z, y, x Dim Shade(255) As Long For c = 0 To 255 i& = _NewImage(1, 1, 32) _Dest i& Line (0, 0)-(_Width(i&), _Height(i&)), _RGBA(0, 0, 0, c), BF Shade(c) = _CopyImage(i&, 33) _FreeImage i& Next c TEX = 0.4
Do TEX = .4 - (MoveZ + 10.5) * .001 If _FullScreen Then _MouseHide Else _MouseShow If _KeyDown(18432) Then MoveZ = MoveZ - 1 If _KeyDown(20480) Then MoveZ = MoveZ + 1 Cls frames% = frames% + 1 If oldtime$ <> Time$ Then fps = frames% frames% = 1 oldtime$ = Time$ End If _Limit 10 Color _RGB(0, 0, 0), _RGB(200, 200, 200) Print t; " first gen cell alive "; b; "live cell at now!" Color _RGB(0, 0, 0), _RGB(227, 227, 227) Print "up down arrow key to move forward or backward" Color _RGB(0, 0, 0), _RGB(255, 255, 255) Print "space to restart || current grid:"; MAX; "^3" Color _RGB(255, 255, 255), _RGB(0, 0, 0) a = a + (fps) / 160 If a > 360 Then a = 0 cos1 = Cos(a) sin1 = Sin(a) ReDim Ecran(_Width, _Height) 'depth buffer For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If U(x, y, z) = 1 Then 'set up cube ix = (x - MAX2) - TEX: iy = (y - MAX2) - TEX: iz = (z - MAX2) - TEX jx = (x - MAX2) + TEX: jy = (y - MAX2) - TEX: jz = (z - MAX2) - TEX kx = (x - MAX2) + TEX: ky = (y - MAX2) + TEX: kz = (z - MAX2) - TEX lx = (x - MAX2) - TEX: ly = (y - MAX2) + TEX: lz = (z - MAX2) - TEX
mx = (x - MAX2) - TEX: my = (y - MAX2) - TEX: mz = (z - MAX2) + TEX nx = (x - MAX2) + TEX: ny = (y - MAX2) - TEX: nz = (z - MAX2) + TEX ox = (x - MAX2) + TEX: oy = (y - MAX2) + TEX: oz = (z - MAX2) + TEX px = (x - MAX2) - TEX: py = (y - MAX2) + TEX: pz = (z - MAX2) + TEX 'rotation x/z ax = (ix) * cos1 - (iz) * sin1 ' az = (ix) * sin1 + (iz) * cos1 ' ay = iy bx = (jx) * cos1 - (jz) * sin1 bz = (jx) * sin1 + (jz) * cos1 ' by = jy cx = (kx) * cos1 - (kz) * sin1 cz = (kx) * sin1 + (kz) * cos1 ' cy = ky dx = (lx) * cos1 - (lz) * sin1 dz = (lx) * sin1 + (lz) * cos1 ' dy = ly
ex = (mx) * cos1 - (mz) * sin1 ez = (mx) * sin1 + (mz) * cos1 ' ey = my fx = (nx) * cos1 - (nz) * sin1 fz = (nx) * sin1 + (nz) * cos1 ' fy = ny gx = (ox) * cos1 - (oz) * sin1 ' gz = (ox) * sin1 + (oz) * cos1 ' gy = oy hx = (px) * cos1 - (pz) * sin1 hz = (px) * sin1 + (pz) * cos1 ' hy = py
'2d coord front face aax = _Width / 2 + 450 * (ax) / (MAX + az + MAX2 + MoveZ) aay = _Height / 2 + 450 * (ay) / (MAX + az + MAX2 + MoveZ) If test(aax, aay) = 0 Then _Continue bbx = _Width / 2 + 450 * (bx) / (MAX + bz + MAX2 + MoveZ) bby = _Height / 2 + 450 * (by) / (MAX + bz + MAX2 + MoveZ) If test(bbx, bby) = 0 Then _Continue ccx = _Width / 2 + 450 * (cx) / (MAX + cz + MAX2 + MoveZ) ccy = _Height / 2 + 450 * (cy) / (MAX + cz + MAX2 + MoveZ) If test(ccx, ccy) = 0 Then _Continue ddx = _Width / 2 + 450 * (dx) / (MAX + dz + MAX2 + MoveZ) ddy = _Height / 2 + 450 * (dy) / (MAX + dz + MAX2 + MoveZ)
If test(ddx, ddy) = 0 Then _Continue 'front u = checkV(ax, ay, (MAX + az + MAX2 + MoveZ), bx, by, (MAX + bz + MAX2 + MoveZ), dx, dy, (MAX + dz + MAX2 + MoveZ)) If u > 0 Then cl = (205 - (((dz + MAX2)) / MAX) * 205) * u + 25 MASK aax, aay, bbx, bby, ddx, ddy, cl, (bz + (MAX + MAX2)) MASK bbx, bby, ccx, ccy, ddx, ddy, cl, (bz + (MAX + MAX2)) End If '2d coord back face eex = _Width / 2 + 450 * (ex) / (MAX + ez + MAX2 + MoveZ) eey = _Height / 2 + 450 * (ey) / (MAX + ez + MAX2 + MoveZ) If test(eex, eey) = 0 Then _Continue ffx = _Width / 2 + 450 * (fx) / (MAX + fz + MAX2 + MoveZ) ffy = _Height / 2 + 450 * (fy) / (MAX + fz + MAX2 + MoveZ) If test(ffx, ffy) = 0 Then _Continue ggx = _Width / 2 + 450 * (gx) / (MAX + gz + MAX2 + MoveZ) ggy = _Height / 2 + 450 * (gy) / (MAX + gz + MAX2 + MoveZ) If test(ggx, ggy) = 0 Then _Continue hhx = _Width / 2 + 450 * (hx) / (MAX + hz + MAX2 + MoveZ) hhy = _Height / 2 + 450 * (hy) / (MAX + hz + MAX2 + MoveZ) 'back If test(hhx, hhy) = 0 Then _Continue u = checkV(hx, hy, (MAX + hz + MAX2 + MoveZ), fx, fy, (MAX + fz + MAX2 + MoveZ), ex, ey, (MAX + ez + MAX2 + MoveZ)) If u > 0 Then cl = (205 - (((fz + MAX2)) / MAX) * 205) * u + 25
MASK eex, eey, ffx, ffy, hhx, hhy, cl, (fz + (MAX + MAX2)) MASK ffx, ffy, ggx, ggy, hhx, hhy, cl, (fz + (MAX + MAX2)) End If 'left u = checkV(dx, dy, (MAX + dz + MAX2 + MoveZ), ex, ey, (MAX + ez + MAX2 + MoveZ), ax, ay, (MAX + az + MAX2 + MoveZ)) If u > 0 Then cl = (205 - (((ez + MAX2)) / MAX) * 205) * (u) + 25
MASK aax, aay, eex, eey, ddx, ddy, cl, (ez + (MAX + MAX2)) MASK eex, eey, hhx, hhy, ddx, ddy, cl, (ez + (MAX + MAX2)) End If ''right u = checkV(fx, fy, (MAX + fz + MAX2 + MoveZ), cx, cy, (MAX + cz + MAX2 + MoveZ), bx, by, (MAX + bz + MAX2 + MoveZ)) If u > 0 Then cl = (205 - (((fz + MAX2)) / MAX) * 205) * (u) + 25
MASK bbx, bby, ccx, ccy, ffx, ffy, cl, (cz + (MAX + MAX2)) MASK ccx, ccy, ggx, ggy, ffx, ffy, cl, (cz + (MAX + MAX2)) End If 'up u = checkV(ex, ey, (MAX + ez + MAX2 + MoveZ), bx, by, (MAX + bz + MAX2 + MoveZ), ax, ay, (MAX + az + MAX2 + MoveZ)) If u > 0 Then cl = (205 - (((ez + MAX2)) / MAX) * 205) * (u) + 25 MASK aax, aay, bbx, bby, eex, eey, cl, (ez + (MAX + MAX2)) MASK bbx, bby, eex, eey, ffx, ffy, cl, (ez + (MAX + MAX2)) End If 'down u = checkV(hx, hy, (MAX + hz + MAX2 + MoveZ), dx, dy, (MAX + dz + MAX2 + MoveZ), cx, cy, (MAX + cz + MAX2 + MoveZ)) If u > 0 Then cl = (205 - (((hz + MAX2)) / MAX) * 205) * (u) + 25 MASK ccx, ccy, ddx, ddy, hhx, hhy, cl, (cz + (MAX + MAX2)) MASK ccx, ccy, hhx, hhy, ggx, ggy, cl, (cz + (MAX + MAX2)) End If ' AB BC CD DA EF FG GH HE AE BF CG DH cube line End If Next z, y, x For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 mm = 0 If U(x, y, z) = 1 Then For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If mm < 9 Or mm > 18 Then U2(x, y, z) = -1 Else U2(x, y, z) = 1 Else For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If (mm > 12 And mm < 18) Then U2(x, y, z) = 1 Else U2(x, y, z) = -1 End If Next z, y, x _Display b = 0 For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 U(x, y, z) = U2(x, y, z) If U(x, y, z) = 1 Then b = b + 1 Next z, y, x If _KeyDown(32) Then GoTo start Loop Until _KeyDown(27) Function checkV (x1, y1, z1, x2, y2, z2, x3, y3, z3)
Xo = (y2 - y1) * (z3 - z1) - (z2 - z1) * (y3 - y1) Yo = (z2 - z1) * (x3 - x1) - (x2 - x1) * (z3 - z1) Zo = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1) D = Sqr(Xo * Xo + Yo * Yo + Zo * Zo) nx = Xo / D: ny = Yo / D: nz = Zo / D px = x1: py = y1: pz = z1 D = Sqr(px * px + py * py + pz * pz) dx = px / D: dy = py / D: dz = pz / D uv = (nz * dz + ny * dy + nx * dx) If uv < 0 Or uv > 1 Then checkV = -1 Else checkV = uv End Function
Sub MASK (ax%, ay%, bx%, by%, cx%, cy%, col%, zzz) Shared Ecran() If Abs(by% - ay%) + Abs(cy% - ay%) > Abs(bx% - ax%) + Abs(cx% - ax%) Then If by% < ay% Then Swap ax%, bx%: Swap ay%, by% If cy% < ay% Then Swap cx%, ax%: Swap cy%, ay% If cy% > by% Then Swap cx%, bx%: Swap cy%, by% a% = by% - ay% c% = cy% - ay% If a% = 0 Then a% = 1 If c% = 0 Then c% = 1 bsura = (bx% - ax%) / a% dsurc = (cx% - ax%) / c% dy% = ay% dx% = ax% For y% = ay% To by% x% = ax% + (y% - ay%) * bsura x1% = dx% + (y% - dy%) * dsurc If test(x%, y%) = 0 Or test(x1%, y%) = 0 Then Exit Sub If x1% = x% Then If test(x%, y%) Then If Ecran(x%, y%) > 0 Then If Ecran(x%, y%) < zzz Then GoTo 41 PSet (x%, y%), _RGB(col%, col%, col%) If test(x%, y%) Then Ecran(x%, y%) = zzz Else For ppx% = x% To x1% Step Sgn(x1% - x%) If test(ppx%, y%) Then If Ecran(ppx%, y%) > 0 Then If Ecran(ppx%, y%) < zzz Then GoTo 41 PSet (ppx%, y%), _RGB(col%, col%, col%) If test(ppx%, y%) Then Ecran(ppx%, y%) = zzz Next End If 41 If y% = cy% Then dy% = cy% dx% = cx% c% = by% - cy% d% = bx% - cx% If c% = 0 Then c% = 1 dsurc = d% / c% End If Next y% Else If bx% < ax% Then Swap ax%, bx%: Swap ay%, by% If cx% < ax% Then Swap cx%, ax%: Swap cy%, ay% If cx% > bx% Then Swap cx%, bx%: Swap cy%, by% b% = bx% - ax% d% = cx% - ax% If b% = 0 Then b% = 1 If d% = 0 Then d% = 1 asurb = (by% - ay%) / b% csurd = (cy% - ay%) / d% dy% = ay% dx% = ax% For x% = ax% To bx% y% = ay% + (x% - ax%) * asurb y1% = dy% + (x% - dx%) * csurd If test(x%, y%) = 0 Or test(x%, y1%) = 0 Then Exit Sub If y1% = y% Then If test(x%, y%) Then If Ecran(x%, y%) > 0 Then If Ecran(x%, y%) < zzz Then GoTo 42 PSet (x%, y%), _RGB(col%, col%, col%) If test(x%, y%) Then Ecran(x%, y%) = zzz Else For ppy% = y% To y1% Step Sgn(y1% - y%) If test(x%, ppy%) Then If Ecran(x%, ppy%) > 0 Then If Ecran(x%, ppy%) < zzz Then GoTo 42 PSet (x%, ppy%), _RGB(col%, col%, col%) If test(x%, ppy%) Then Ecran(x%, ppy%) = zzz Next End If 42 If x% = cx% Then dy% = cy% dx% = cx% c% = by% - cy% d% = bx% - cx% If d% = 0 Then d% = 1 csurd = c% / d% End If Next x% End If End Sub Function test (ax, ay) test = 0 If ax < 0 Or ay < 0 Then Exit Function If ax > _Width Or ay > _Height Then Exit Function test = 1 End Function
|
|
|
Post by bplus on Feb 12, 2024 21:09:33 GMT
Impressive stuff! nice work ubi44!
|
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Feb 13, 2024 7:37:53 GMT
Now with _MapTriangle 3D.. Cleaner!
Screen _NewImage(640, 488, 32) _AllowFullScreen _SquarePixels _FullScreen _SquarePixels , _Smooth Dim As Integer MAX, MAX2
start: MAX = 25 + Int(Rnd * 25): MAX2 = MAX / 2 ReDim U(MAX, MAX, MAX) As _Byte ReDim U2(MAX, MAX, MAX) As _Byte
MoveZ = -MAX2 / 2 rand = (Rnd - Rnd * .25) * .2 Randomize Timer t = 0 For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If Rnd < .5 + rand Then U(x, y, z) = 1: t = t + 1 Else U(x, y, z) = -1 Next z, y, x Dim Shade(255) As Long For c = 0 To 255 i& = _NewImage(1, 1, 32) _Dest i& Line (0, 0)-(_Width(i&), _Height(i&)), _RGB(c, c, c), BF Shade(c) = _CopyImage(i&, 33) _FreeImage i& Next c Do TEX = .4 - (MoveZ + 10.5) * .001 If _FullScreen Then _MouseHide Else _MouseShow If _KeyDown(18432) Then MoveZ = MoveZ - 1 If _KeyDown(20480) Then MoveZ = MoveZ + 1 Cls frames% = frames% + 1 If oldtime$ <> Time$ Then fps = frames% frames% = 1 oldtime$ = Time$ End If _Limit 10 Color _RGB(0, 0, 0), _RGB(200, 200, 200) Print t; " first gen cell alive "; b; "live cell at now!" Color _RGB(0, 0, 0), _RGB(227, 227, 227) Print "up down arrow key to move forward or backward" Color _RGB(0, 0, 0), _RGB(255, 255, 255) Print "space to restart || current grid:"; MAX; "^3" Color _RGB(255, 255, 255), _RGB(0, 0, 0) a = a + (fps) / 160 If a > 360 Then a = 0 cos1 = Cos(a) sin1 = Sin(a)
For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If U(x, y, z) = 1 Then 'set up cube ix = (x - MAX2) - TEX: iy = (y - MAX2) - TEX: iz = (z - MAX2) - TEX jx = (x - MAX2) + TEX: jy = (y - MAX2) - TEX: jz = (z - MAX2) - TEX kx = (x - MAX2) + TEX: ky = (y - MAX2) + TEX: kz = (z - MAX2) - TEX lx = (x - MAX2) - TEX: ly = (y - MAX2) + TEX: lz = (z - MAX2) - TEX
mx = (x - MAX2) - TEX: my = (y - MAX2) - TEX: mz = (z - MAX2) + TEX nx = (x - MAX2) + TEX: ny = (y - MAX2) - TEX: nz = (z - MAX2) + TEX ox = (x - MAX2) + TEX: oy = (y - MAX2) + TEX: oz = (z - MAX2) + TEX px = (x - MAX2) - TEX: py = (y - MAX2) + TEX: pz = (z - MAX2) + TEX 'rotation x/z ax = (ix) * cos1 - (iz) * sin1 ' az = (ix) * sin1 + (iz) * cos1 ' ay = iy bx = (jx) * cos1 - (jz) * sin1 bz = (jx) * sin1 + (jz) * cos1 ' by = jy cx = (kx) * cos1 - (kz) * sin1 cz = (kx) * sin1 + (kz) * cos1 ' cy = ky dx = (lx) * cos1 - (lz) * sin1 dz = (lx) * sin1 + (lz) * cos1 ' dy = ly
ex = (mx) * cos1 - (mz) * sin1 ez = (mx) * sin1 + (mz) * cos1 ' ey = my fx = (nx) * cos1 - (nz) * sin1 fz = (nx) * sin1 + (nz) * cos1 ' fy = ny gx = (ox) * cos1 - (oz) * sin1 ' gz = (ox) * sin1 + (oz) * cos1 ' gy = oy hx = (px) * cos1 - (pz) * sin1 hz = (px) * sin1 + (pz) * cos1 ' hy = py
'front push = -(MAX + MAX2 + MoveZ) u = checkV(ax, ay, az - push, bx, by, bz - push, dx, dy, dz - push) If u > 0 Then col% = maxi((205 - (((dz + MAX2)) / MAX) * 205) * u + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ax, ay, -az + push)-(bx, by, -bz + push)-(dx, dy, -dz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(bx, by, -bz + push)-(cx, cy, -cz + push)-(dx, dy, -dz + push) End If 'back u = checkV(hx, hy, hz - push, fx, fy, fz - push, ex, ey, ez - push) If u > 0 Then col% = maxi((205 - (((fz + MAX2)) / MAX) * 205) * u + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ex, ey, -ez + push)-(fx, fy, -fz + push)-(hx, hy, -hz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(fx, fy, -fz + push)-(gx, gy, -gz + push)-(hx, hy, -hz + push) End If 'left u = checkV(dx, dy, dz - push, ex, ey, ez - push, ax, ay, az - push) If u > 0 Then col% = maxi((205 - (((ez + MAX2)) / MAX) * 205) * (u) + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ax, ay, -az + push)-(ex, ey, -ez + push)-(dx, dy, -dz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ex, ey, -ez + push)-(hx, hy, -hz + push)-(dx, dy, -dz + push) End If ''right u = checkV(fx, fy, fz - push, cx, cy, cz - push, bx, by, bz - push) If u > 0 Then col% = maxi((205 - (((fz + MAX2)) / MAX) * 205) * (u) + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(bx, by, -bz + push)-(cx, cy, -cz + push)-(fx, fy, -fz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(cx, cy, -cz + push)-(gx, gy, -gz + push)-(fx, fy, -fz + push) End If 'up u = checkV(bx, by, bz - push, ax, ay, az - push, ex, ey, ez - push) If u > 0 Then col% = maxi((205 - (((ez + MAX2)) / MAX) * 205) * (u) + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ax, ay, -az + push)-(bx, by, -bz + push)-(ex, ey, -ez + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(bx, by, -bz + push)-(ex, ey, -ez + push)-(fx, fy, -fz + push) End If 'down u = checkV(hx, hy, hz - push, dx, dy, dz - push, cx, cy, cz - push) If u > 0 Then col% = maxi((205 - (((hz + MAX2)) / MAX) * 205) * (u) + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(cx, cy, -cz + push)-(dx, dy, -dz + push)-(hx, hy, -hz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(cx, cy, -cz + push)-(hx, hy, -hz + push)-(gx, gy, -gz + push) End If End If Next z, y, x For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 mm = 0 If U(x, y, z) = 1 Then For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If mm < 9 Or mm > 18 Then U2(x, y, z) = -1 Else U2(x, y, z) = 1 Else For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If (mm > 12 And mm < 18) Then U2(x, y, z) = 1 Else U2(x, y, z) = -1 End If Next z, y, x _Display b = 0 For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 U(x, y, z) = U2(x, y, z) If U(x, y, z) = 1 Then b = b + 1 Next z, y, x If _KeyDown(32) Then GoTo start Loop Until _KeyDown(27) Function checkV (x1, y1, z1, x2, y2, z2, x3, y3, z3) Xo = (y2 - y1) * (z3 - z1) - (z2 - z1) * (y3 - y1) Yo = (z2 - z1) * (x3 - x1) - (x2 - x1) * (z3 - z1) Zo = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1) D = Sqr(Xo * Xo + Yo * Yo + Zo * Zo) nx = Xo / D: ny = Yo / D: nz = Zo / D px = x1: py = y1: pz = z1 D = Sqr(px * px + py * py + pz * pz) dx = px / D: dy = py / D: dz = pz / D uv = (nz * dz + ny * dy + nx * dx) If uv < 0 Or uv > 1 Then checkV = -1 Else checkV = uv End Function Function maxi (x) If x > 255 Then maxi = 255: Exit Function If x < 0 Then maxi = 0: Exit Function maxi = x End Function
|
|
|
Post by anthonyrbrown on Feb 13, 2024 10:34:05 GMT
Fantastic stuff! ubi44 I have been giving this a lot of thought,and as well as my Hexagon blocks idea,I now have another,how about a 3DLIFE WORMS/SNAKES VERSION So instead of Block like life you will have Squiggly Worm like life! a bit like the original Microsoft Snakes but in 3D link below... Snake - 1984 - MS-DOS Game Review www.youtube.com/watch?v=qtQSRSj4PLYBelow is a bit more like the Idea I have... Worm/Snake [1.21 mins to animate] www.youtube.com/watch?v=8mLvy9m5HN0Slither.io A.I. 200,000+ Score Epic Slitherio Gameplay www.youtube.com/watch?v=jBcDBwkV0b8
|
|
|
Post by bplus on Feb 13, 2024 16:20:56 GMT
Now with _MapTriangle 3D.. Cleaner! Screen _NewImage(640, 488, 32) _AllowFullScreen _SquarePixels _FullScreen _SquarePixels , _Smooth Dim As Integer MAX, MAX2
start: MAX = 25 + Int(Rnd * 25): MAX2 = MAX / 2 ReDim U(MAX, MAX, MAX) As _Byte ReDim U2(MAX, MAX, MAX) As _Byte
MoveZ = -MAX2 / 2 rand = (Rnd - Rnd * .25) * .2 Randomize Timer t = 0 For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If Rnd < .5 + rand Then U(x, y, z) = 1: t = t + 1 Else U(x, y, z) = -1 Next z, y, x Dim Shade(255) As Long For c = 0 To 255 i& = _NewImage(1, 1, 32) _Dest i& Line (0, 0)-(_Width(i&), _Height(i&)), _RGB(c, c, c), BF Shade(c) = _CopyImage(i&, 33) _FreeImage i& Next c Do TEX = .4 - (MoveZ + 10.5) * .001 If _FullScreen Then _MouseHide Else _MouseShow If _KeyDown(18432) Then MoveZ = MoveZ - 1 If _KeyDown(20480) Then MoveZ = MoveZ + 1 Cls frames% = frames% + 1 If oldtime$ <> Time$ Then fps = frames% frames% = 1 oldtime$ = Time$ End If _Limit 10 Color _RGB(0, 0, 0), _RGB(200, 200, 200) Print t; " first gen cell alive "; b; "live cell at now!" Color _RGB(0, 0, 0), _RGB(227, 227, 227) Print "up down arrow key to move forward or backward" Color _RGB(0, 0, 0), _RGB(255, 255, 255) Print "space to restart || current grid:"; MAX; "^3" Color _RGB(255, 255, 255), _RGB(0, 0, 0) a = a + (fps) / 160 If a > 360 Then a = 0 cos1 = Cos(a) sin1 = Sin(a)
For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 If U(x, y, z) = 1 Then 'set up cube ix = (x - MAX2) - TEX: iy = (y - MAX2) - TEX: iz = (z - MAX2) - TEX jx = (x - MAX2) + TEX: jy = (y - MAX2) - TEX: jz = (z - MAX2) - TEX kx = (x - MAX2) + TEX: ky = (y - MAX2) + TEX: kz = (z - MAX2) - TEX lx = (x - MAX2) - TEX: ly = (y - MAX2) + TEX: lz = (z - MAX2) - TEX
mx = (x - MAX2) - TEX: my = (y - MAX2) - TEX: mz = (z - MAX2) + TEX nx = (x - MAX2) + TEX: ny = (y - MAX2) - TEX: nz = (z - MAX2) + TEX ox = (x - MAX2) + TEX: oy = (y - MAX2) + TEX: oz = (z - MAX2) + TEX px = (x - MAX2) - TEX: py = (y - MAX2) + TEX: pz = (z - MAX2) + TEX 'rotation x/z ax = (ix) * cos1 - (iz) * sin1 ' az = (ix) * sin1 + (iz) * cos1 ' ay = iy bx = (jx) * cos1 - (jz) * sin1 bz = (jx) * sin1 + (jz) * cos1 ' by = jy cx = (kx) * cos1 - (kz) * sin1 cz = (kx) * sin1 + (kz) * cos1 ' cy = ky dx = (lx) * cos1 - (lz) * sin1 dz = (lx) * sin1 + (lz) * cos1 ' dy = ly
ex = (mx) * cos1 - (mz) * sin1 ez = (mx) * sin1 + (mz) * cos1 ' ey = my fx = (nx) * cos1 - (nz) * sin1 fz = (nx) * sin1 + (nz) * cos1 ' fy = ny gx = (ox) * cos1 - (oz) * sin1 ' gz = (ox) * sin1 + (oz) * cos1 ' gy = oy hx = (px) * cos1 - (pz) * sin1 hz = (px) * sin1 + (pz) * cos1 ' hy = py
'front push = -(MAX + MAX2 + MoveZ) u = checkV(ax, ay, az - push, bx, by, bz - push, dx, dy, dz - push) If u > 0 Then col% = maxi((205 - (((dz + MAX2)) / MAX) * 205) * u + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ax, ay, -az + push)-(bx, by, -bz + push)-(dx, dy, -dz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(bx, by, -bz + push)-(cx, cy, -cz + push)-(dx, dy, -dz + push) End If 'back u = checkV(hx, hy, hz - push, fx, fy, fz - push, ex, ey, ez - push) If u > 0 Then col% = maxi((205 - (((fz + MAX2)) / MAX) * 205) * u + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ex, ey, -ez + push)-(fx, fy, -fz + push)-(hx, hy, -hz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(fx, fy, -fz + push)-(gx, gy, -gz + push)-(hx, hy, -hz + push) End If 'left u = checkV(dx, dy, dz - push, ex, ey, ez - push, ax, ay, az - push) If u > 0 Then col% = maxi((205 - (((ez + MAX2)) / MAX) * 205) * (u) + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ax, ay, -az + push)-(ex, ey, -ez + push)-(dx, dy, -dz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ex, ey, -ez + push)-(hx, hy, -hz + push)-(dx, dy, -dz + push) End If ''right u = checkV(fx, fy, fz - push, cx, cy, cz - push, bx, by, bz - push) If u > 0 Then col% = maxi((205 - (((fz + MAX2)) / MAX) * 205) * (u) + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(bx, by, -bz + push)-(cx, cy, -cz + push)-(fx, fy, -fz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(cx, cy, -cz + push)-(gx, gy, -gz + push)-(fx, fy, -fz + push) End If 'up u = checkV(bx, by, bz - push, ax, ay, az - push, ex, ey, ez - push) If u > 0 Then col% = maxi((205 - (((ez + MAX2)) / MAX) * 205) * (u) + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(ax, ay, -az + push)-(bx, by, -bz + push)-(ex, ey, -ez + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(bx, by, -bz + push)-(ex, ey, -ez + push)-(fx, fy, -fz + push) End If 'down u = checkV(hx, hy, hz - push, dx, dy, dz - push, cx, cy, cz - push) If u > 0 Then col% = maxi((205 - (((hz + MAX2)) / MAX) * 205) * (u) + 25) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(cx, cy, -cz + push)-(dx, dy, -dz + push)-(hx, hy, -hz + push) _MapTriangle (0, 0)-(_Width(Shade(col%)), 0)-(0, _Height(Shade(col%))), Shade(col%) To(cx, cy, -cz + push)-(hx, hy, -hz + push)-(gx, gy, -gz + push) End If End If Next z, y, x For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 mm = 0 If U(x, y, z) = 1 Then For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If mm < 9 Or mm > 18 Then U2(x, y, z) = -1 Else U2(x, y, z) = 1 Else For xx = x - 1 To x + 1 For yy = y - 1 To y + 1 For zz = z - 1 To z + 1 If x = xx And y = yy And z = zz Then _Continue If U(xx, yy, zz) = 1 Then mm = mm + 1 Next zz, yy, xx If (mm > 12 And mm < 18) Then U2(x, y, z) = 1 Else U2(x, y, z) = -1 End If Next z, y, x _Display b = 0 For x = 1 To MAX - 1 For y = 1 To MAX - 1 For z = 1 To MAX - 1 U(x, y, z) = U2(x, y, z) If U(x, y, z) = 1 Then b = b + 1 Next z, y, x If _KeyDown(32) Then GoTo start Loop Until _KeyDown(27) Function checkV (x1, y1, z1, x2, y2, z2, x3, y3, z3) Xo = (y2 - y1) * (z3 - z1) - (z2 - z1) * (y3 - y1) Yo = (z2 - z1) * (x3 - x1) - (x2 - x1) * (z3 - z1) Zo = (x2 - x1) * (y3 - y1) - (y2 - y1) * (x3 - x1) D = Sqr(Xo * Xo + Yo * Yo + Zo * Zo) nx = Xo / D: ny = Yo / D: nz = Zo / D px = x1: py = y1: pz = z1 D = Sqr(px * px + py * py + pz * pz) dx = px / D: dy = py / D: dz = pz / D uv = (nz * dz + ny * dy + nx * dx) If uv < 0 Or uv > 1 Then checkV = -1 Else checkV = uv End Function Function maxi (x) If x > 255 Then maxi = 255: Exit Function If x < 0 Then maxi = 0: Exit Function maxi = x End Function This is best bit of code I've seen in a long time!!! Excellent 5 (of 5) Stars!
|
|
|
Post by bplus on Feb 13, 2024 18:12:16 GMT
ubi44 I hope you don't mind but I posted screen shot and linked to this thread at Discord because this is so good.
|
|
ubi44
New Member
Posts: 32
|
Post by ubi44 on Feb 15, 2024 9:21:09 GMT
Ok no worries ... thanks!
|
|