02-13-2024, 07:25 PM
I was just trying to get some test cubes walled! 4 cubes in the cube space of U(x,y,z) array = Universe
Line points look right but no luck getting any solid fill triangles for wall, I was just trying the one wall on left face of cubes... BTW I commented out the back wall or face of cube because the other 5 walls are sure to block it out.
Line points look right but no luck getting any solid fill triangles for wall, I was just trying the one wall on left face of cubes... BTW I commented out the back wall or face of cube because the other 5 walls are sure to block it out.
Code: (Select All)
Option _Explicit
_Title "3D Render: Game of Life 2" ' 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 ? successful proof of concept!!!
' 2024-02-12 try clothing wireframe cubes with walls with new DrawCube routine
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 ?
' setup for Game of Life (code removed)
'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, r, g, b, mm, xx, yy, zz, rr, gg, bb
' Just get some cubes frick'n walled!!!
'test draw cube
drawCube -3, 3, -25, 2, _RGB32(255, 0, 255)
drawCube 3, 3, -25, 2, _RGB32(255, 0, 0)
drawCube -3, -3, -25, 2, _RGB32(0, 255, 0)
drawCube 3, -3, -25, 2, _RGB32(0, 0, 255)
Sleep
End
'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
'' ========================================================================= old 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
' new 2024-02-12 testing with above code
Sub drawCube (cx, cy, cz, side, colr~&)
Dim As Integer i
Dim sd2, lx, rx, ty, by, fz, bz
ReDim corners(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
corners(0).x = lx: corners(0).y = ty: corners(0).z = fz
corners(1).x = rx: corners(1).y = ty: corners(1).z = fz
corners(2).x = rx: corners(2).y = by: corners(2).z = fz
corners(3).x = lx: corners(3).y = by: corners(3).z = fz
corners(4).x = lx: corners(4).y = ty: corners(4).z = bz
corners(5).x = rx: corners(5).y = ty: corners(5).z = bz
corners(6).x = rx: corners(6).y = by: corners(6).z = bz
corners(7).x = lx: corners(7).y = by: corners(7).z = bz
ReDim xy(0 To 7) As xyType
For i = 0 To 7
screenXY corners(i), xy(i) ' take a corner x,y,z and convert to screen coordinates x,y
' debug check corner coordinates look fine!!!
' Print corners(i).x, corners(i).y, xy(i).x, xy(i).y
Next
'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 (xy(0).x, xy(0).y)-(xy(4).x, xy(4).y), colr~& ' - _RGB32(25, 25, 0)
Line (xy(1).x, xy(1).y)-(xy(5).x, xy(5).y), colr~& ' - _RGB32(25, 25, 0)
Line (xy(2).x, xy(2).y)-(xy(6).x, xy(6).y), colr~& '- _RGB32(25, 25, 0)
Line (xy(3).x, xy(3).y)-(xy(7).x, xy(7).y), colr~& '- _RGB32(25, 25, 0)
' Triangles not working!!!
' andy amayas get line and dot
'Color colr~&
'filltri xy(0).x, xy(0).y, xy(3).x, xy(3).y, xy(7).x, xy(7).y
'filltri xy(4).x, xy(4).y, xy(7).x, xy(7).y, xy(0).x, xy(0).y
'filltri -2, 2, -1, 2, -2, 0 ' line and dot but nothing from above
' nada here too!
'ftri0 xy(0).x, xy(0).y, xy(3).x, xy(3).y, xy(7).x, xy(7).y, colr~&
'ftri0 xy(4).x, xy(4).y, xy(7).x, xy(7).y, xy(0).x, xy(0).y, colr~&
'nope!
'ftri xy(0).x, xy(0).y, xy(3).x, xy(3).y, xy(7).x, xy(7).y, colr~&
'ftri xy(4).x, xy(4).y, xy(7).x, xy(7).y, xy(0).x, xy(0).y, colr~&
' no again
FillTriangle xy(0).x, xy(0).y, xy(3).x, xy(3).y, xy(7).x, xy(7).y, colr~&
FillTriangle xy(4).x, xy(4).y, xy(7).x, xy(7).y, xy(0).x, xy(0).y, colr~&
'front face
Line (xy(0).x, xy(0).y)-(xy(1).x, xy(1).y), colr~&
Line -(xy(2).x, xy(2).y), colr~&
Line -(xy(3).x, xy(3).y), colr~&
Line -(xy(0).x, xy(0).y), colr~&
End Sub
'Andy Amaya's triangle fill modified for QB64, use if color already set
Sub filltri (xx1, yy1, xx2, yy2, xx3, yy3)
Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single, x3 As Single, y3 As Single
Dim slope1 As Single, slope2 As Single, length As Single, x As Single, lastx%, y As Single
Dim slope3 As Single
'make copies before swapping
x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
'triangle coordinates must be ordered: where x1 < x2 < x3
If x2 < x1 Then Swap x1, x2: Swap y1, y2
If x3 < x1 Then Swap x1, x3: Swap y1, y3
If x3 < x2 Then Swap x2, x3: Swap y2, y3
If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)
'draw the first half of the triangle
length = x2 - x1
If length <> 0 Then
slope2 = (y2 - y1) / length
For x = 0 To length
Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1))
lastx% = Int(x + x1)
Next
End If
'draw the second half of the triangle
y = length * slope1 + y1: length = x3 - x2
If length <> 0 Then
slope3 = (y3 - y2) / length
For x = 0 To length
If Int(x + x2) <> lastx% Then
Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2))
End If
Next
End If
End Sub
Sub ftri0 (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long, a&
D = _Dest
a& = _NewImage(1, 1, 32)
_Dest a&
PSet (0, 0), K
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
_FreeImage a& '<<< this is important!
End Sub
'' BEST saves dest and optimized with Static a& and alpha colors work better
'2019-12-16 fix by Steve saves some time with STATIC and saves and restores last dest
Sub ftri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
Dim D As Long
Static a&
D = _Dest
If a& = 0 Then a& = _NewImage(1, 1, 32)
_Dest a&
_DontBlend a& ' '<<<< new 2019-12-16 fix
PSet (0, 0), K
_Blend a& '<<<< new 2019-12-16 fix
_Dest D
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
End Sub
' steves latest version to check out
Sub FillTriangle (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
$Checking:Off
Static a&, m As _MEM
If a& = 0 Then a& = _NewImage(1, 1, 32): m = _MemImage(a&)
_MemPut m, m.OFFSET, K
_MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
$Checking:On
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
' 2019 Stax 3D rendering setup code routines ======================================================
' goes with many lines at start of prgram
'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
b = b + ...