11-15-2024, 09:00 PM
(11-15-2024, 08:41 PM)bplus Wrote: I like the thinking so far, z adjusting for how close image is and using transparent colors. I don't know how well the glasses can seperate blended blue and red, and if you don't blend would the last color overwrite the first competeing for same pixel?What's your avatar method?
I do like my avatar method, no need for glasses
All I know is that the glasses can seperate the blended blue and red fine in the youtube demos, so it should be doable in code?
Here was my last attempt, using solid shapes, but it just uses flat squares and circles, and so it doesn't look 3d.
I think it would need to actually draw 3D shapes with different perspective for the right/left images for it to work.
Arrow keys move the 2nd closer shape around, minus key shrinks it, +/= key increases size:
Code: (Select All)
' CONSTANTS
Const FALSE = 0
Const TRUE = Not FALSE
' KEY CODES
Const cUpArrow = 18432
Const cDownArrow = 20480
Const cLeftArrow = 19200
Const cRightArrow = 19712
' COLORS
Dim Shared cRed~&
Dim Shared cCyan~&
Dim Shared cEmpty~&
Dim Shared iScreenWidth%
Dim Shared iScreenHeight%
Dim Shared x, y, z, p, q, t, zoom
Dim Shared sw, sh, mx, my, mb, mw
Dim Shared u
Dim Shared xx0, x0
Dim Shared x1a, y1a, x2a, y2a, x1b, y1b, x2b, y2b, xSkew1, xSkew2, ySkew1, ySkew2
' SET SHARED VALUES
cRed~& = _RGB32(255, 0, 0, 128) ' semi-transparent
cCyan~& = _RGB32(0, 255, 255, 128) ' semi-transparent
cEmpty~& = _RGB32(0, 0, 0, 0) ' _RGBA(red, green, blue, alpha) where alpha& specifies the alpha component transparency value from 0 (fully transparent) to 255 (opaque).
iScreenWidth% = 1024 ' 800
iScreenHeight% = 768 ' 600
'vince_3d_v1
'madscijr_3d_v1
madscijr_3d_v2
System
Sub madscijr_3d_v2
Screen _NewImage(iScreenWidth%, iScreenHeight%, 32)
'Screen _NewImage(_DesktopWidth, _DesktopHeight, 32)
_ScreenMove 0, 0
Dim square1x, square1y, square1w, square1h, square1dist, square1x2, square1y2, square1w2, square1h2
Dim circle1x, circle1y, circle1r, circle1dist, circle1x2, circle1y2, circle1r2
'Dim oval1x, oval1y, oval1w, oval1h, oval1dist, oval1x2, oval1y2, oval1w2, oval1h2
square1x = 100
square1y = 100
square1w = 200
square1h = 200
square1dist = 20
square1y2 = square1y
square1w2 = square1w + 25
square1h2 = square1h + 25
circle1x = 400
circle1y = 100
circle1r = 100
circle1dist = 40
circle1y2 = circle1y
circle1r2 = circle1r + 25
'oval1x = 400
'oval1y = 100
'oval1w = 100
'oval1h = 300
'oval1dist = 40
'oval1y2 = oval1y
Do
If _KeyDown(cLeftArrow) Then square1dist = square1dist - 1: circle1dist = circle1dist - 1
If _KeyDown(cRightArrow) Then square1dist = square1dist + 1: circle1dist = circle1dist + 1
If _KeyDown(cUpArrow) Then square1y2 = square1y2 - 1: circle1y2 = circle1y2 - 1
If _KeyDown(cDownArrow) Then square1y2 = square1y2 + 1: circle1y2 = circle1y2 + 1
If _KeyDown(Asc("-")) Then square1w2 = square1w2 - 1: circle1dist = circle1dist - 1: circle1r2 = circle1r2 - 1
If _KeyDown(Asc("=")) Then square1w2 = square1w2 + 1: circle1dist = circle1dist + 1: circle1r2 = circle1r2 + 1
square1x2 = square1x + square1dist
circle1x2 = circle1x + circle1dist
_Dest 0: Cls , cBlack
'Locate 1, 1: Print xSkew2
' red is to the left
' LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
'Line (x1a, y1a)-(x2a, y2a), _RGB(255, 0, 0)
Call DrawRectSolid(square1x, square1y, square1w, square1h, cRed~&)
Call CircleFill(circle1x, circle1y, circle1r, cRed~&)
'Call EllipseFill(oval1x, oval1y, a, b, C)
' cyan is to the right
' LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
'Line (x1b, y1b)-(x2b, y2b), _RGB(0, 255, 255)
Call DrawRectSolid(square1x2, square1y2, square1w2, square1h2, cCyan~&)
Call CircleFill(circle1x2, circle1y2, circle1r2, cCyan~&)
'Call EllipseFill(oval1x2, oval1y, a, b, C)
_Display
_Limit 30
Loop Until _KeyHit = 27
_AutoDisplay ' RETURN TO AUTODISPLAY
End Sub ' madscijr_3d_v2
' /////////////////////////////////////////////////////////////////////////////
' DRAW A 2-D RECTANGLE (SOLID)
Sub DrawRectSolid (iX As Integer, iY As Integer, iSizeW As Integer, iSizeH As Integer, fgColor As _Unsigned Long)
Line (iX, iY)-(iX + iSizeW, iY + iSizeH), fgColor, BF ' Draw a solid rectangle
End Sub ' DrawRectSolid
' /////////////////////////////////////////////////////////////////////////////
Sub CircleFill (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' R = radius
' C = fill color
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub ' CircleFill
' /////////////////////////////////////////////////////////////////////////////
Sub EllipseFill (CX As Integer, CY As Integer, a As Integer, b As Integer, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' a = semimajor axis
' b = semiminor axis
' C = fill color
If a = 0 Or b = 0 Then Exit Sub
Dim h2 As _Integer64
Dim w2 As _Integer64
Dim h2w2 As _Integer64
Dim x As Integer
Dim y As Integer
w2 = a * a
h2 = b * b
h2w2 = h2 * w2
Line (CX - a, CY)-(CX + a, CY), C, BF
Do While y < b
y = y + 1
x = Sqr((h2w2 - y * y * w2) \ h2)
Line (CX - x, CY + y)-(CX + x, CY + y), C, BF
Line (CX - x, CY - y)-(CX + x, CY - y), C, BF
Loop
End Sub ' EllipseFill
' /////////////////////////////////////////////////////////////////////////////
Sub EllipseTilt (CX, CY, a, b, ang, C As _Unsigned Long)
' CX = center x coordinate
' CY = center y coordinate
' a = semimajor axis
' b = semiminor axis
' ang = clockwise orientation of semimajor axis in radians (0 default)
' C = fill color
For k = 0 To 6.283185307179586 + .025 Step .025
i = a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = -a * Cos(k) * Sin(ang) + b * Sin(k) * Cos(ang)
i = i + CX
j = -j + CY
If k <> 0 Then
Line -(i, j), C
Else
PSet (i, j), C
End If
Next
End Sub ' EllipseTilt
' /////////////////////////////////////////////////////////////////////////////
Sub EllipseTiltFill (destHandle&, CX, CY, a, b, ang, C As _Unsigned Long)
' destHandle& = destination handle
' CX = center x coordinate
' CY = center y coordinate
' a = semimajor axis
' b = semiminor axis
' ang = clockwise orientation of semimajor axis in radians (0 default)
' C = fill color
Dim max As Integer, mx2 As Integer, i As Integer, j As Integer
Dim prc As _Unsigned Long
Dim D As Integer, S As Integer
D = _Dest: S = _Source
prc = _RGB32(255, 255, 255, 255)
If a > b Then max = a + 1 Else max = b + 1
mx2 = max + max
tef& = _NewImage(mx2, mx2)
_Dest tef&
_Source tef&
For k = 0 To 6.283185307179586 + .025 Step .025
i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
If k <> 0 Then
Line (lasti, lastj)-(i, j), prc
Else
PSet (i, j), prc
End If
lasti = i: lastj = j
Next
Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
For y = 0 To mx2
x = 0
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
xleft(y) = x
While Point(x, y) = prc And x < mx2
x = x + 1
Wend
While Point(x, y) <> prc And x < mx2
x = x + 1
Wend
If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
Next
_Dest destHandle&
For y = 0 To mx2
If xleft(y) <> mx2 Then Line (xleft(y) + CX - max, y + CY - max)-(xright(y) + CX - max, y + CY - max), C, BF
Next
_Dest D: _Dest S
_FreeImage tef&
End Sub ' EllipseTiltFill
' /////////////////////////////////////////////////////////////////////////////
Function ColorToString$ (MyValue~&)
Dim Mystring As String
Select Case MyValue~&
Case cRed~&:
Mystring = "Red"
Case cCyan~&:
Mystring = "Cyan"
Case cEmpty~&:
Mystring = "Empty"
Case Else:
Mystring = _Trim$(Str$(MyValue~&))
End Select
ColorToString$ = Mystring
End Function ' ColorToString$
' /////////////////////////////////////////////////////////////////////////////
Sub madscijr_3d_v1
sw = 800
sh = 600
Screen _NewImage(sw, sh, 32)
If _Resize Then
sw = _ResizeWidth - 20
sh = _ResizeHeight - 20
Screen _NewImage(sw, sh, 32)
End If
x1a = 100
y1a = 100
x2a = 400
y2a = 500
xSkew1 = 10
ySkew1 = 5
xSkew2 = 40
ySkew2 = 10
Do
If _KeyDown(19200) Then xSkew2 = xSkew2 + 1
If _KeyDown(19712) Then xSkew2 = xSkew2 - 1
x1b = x1a + xSkew1
y1b = y1a + ySkew1
x2b = x2a + xSkew2
y2b = y2a + ySkew2
Cls
Locate 1, 1: Print xSkew2
' LINE [STEP] [(column1, row1)]-[STEP] (column2, row2), color[, [{B|BF}], style%]
' red is to the left
Line (x1a, y1a)-(x2a, y2a), _RGB(255, 0, 0)
' cyan is to the right
Line (x1b, y1b)-(x2b, y2b), _RGB(0, 255, 255)
_Display
_Limit 30
Loop Until _KeyHit = 27
End Sub ' madscijr_3d_v1
' /////////////////////////////////////////////////////////////////////////////
Sub vince_3d_v1
sw = 800
sh = 600
Screen _NewImage(sw, sh, 32)
If _Resize Then
sw = _ResizeWidth - 20
sh = _ResizeHeight - 20
Screen _NewImage(sw, sh, 32)
End If
zoom = 100
x = 1
y = 0
z = 0
proj
Line (sw / 2, sh / 2)-(sw / 2 + zoom * p, sh / 2 - zoom * q), _RGB(255, 0, 0)
x = 0
y = 1
z = 0
proj
Line (sw / 2, sh / 2)-(sw / 2 + zoom * p, sh / 2 - zoom * q), _RGB(0, 0, 255)
x = 0
y = 0
z = 1
proj
Line (sw / 2, sh / 2)-(sw / 2 + zoom * p, sh / 2 - zoom * q), _RGB(0, 255, 0)
y0 = -0.3
u = 0
x0 = 0.1
Do
u = u + 0.1
If _KeyDown(19200) Then x0 = x0 + 0.1
If _KeyDown(19712) Then x0 = x0 - 0.1
Cls
Locate 1, 1: Print xx0
xx0 = 0
Color _RGB(255, 0, 0)
square -0.5, y0, -1, -0.5, y0, 1, 0.5, y0, 1, 0.5, y0, -1 'roof
square -0.5, y0 - 0.5, -1, -0.5, y0 - 0.5, 1, 0.5, y0 - 0.5, 1, 0.5, y0 - 0.5, -1 'floor
square -0.5, y0, -1, 0.5, y0, -1, 0.5, y0 - 0.5, -1, -0.5, y0 - 0.5, -1 'rear
square -0.5, y0, 1, 0.5, y0, 1, 0.5, y0 - 0.5, 1, -0.5, y0 - 0.5, 1 'windshield
xx0 = x0
Color _RGB(0, 255, 255)
square -0.5, y0, -1, -0.5, y0, 1, 0.5, y0, 1, 0.5, y0, -1 'roof
square -0.5, y0 - 0.5, -1, -0.5, y0 - 0.5, 1, 0.5, y0 - 0.5, 1, 0.5, y0 - 0.5, -1 'floor
square -0.5, y0, -1, 0.5, y0, -1, 0.5, y0 - 0.5, -1, -0.5, y0 - 0.5, -1 'rear
square -0.5, y0, 1, 0.5, y0, 1, 0.5, y0 - 0.5, 1, -0.5, y0 - 0.5, 1 'windshield
_Display
_Limit 30
Loop Until _KeyHit = 27
End Sub ' 'vince_3d_v1
' /////////////////////////////////////////////////////////////////////////////
Sub square (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
x = x1
y = y1
z = z1
proj
PReset (sw / 2 + zoom * p, sh / 2 - zoom * q)
x = x2
y = y2
z = z2
proj
Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)
x = x3
y = y3
z = z3
proj
Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)
x = x4
y = y4
z = z4
proj
Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)
x = x1
y = y1
z = z1
proj
Line -(sw / 2 + zoom * p, sh / 2 - zoom * q)
End Sub
' /////////////////////////////////////////////////////////////////////////////
Sub proj
rot u, 1, 1, 0
x = x + xx0
d = 100
p = x * d / (100 + y)
q = y * d / (100 + y)
End Sub
' /////////////////////////////////////////////////////////////////////////////
Sub rot (u, rx, ry, rz)
dd = Sqr(rx * rx + ry * ry + rz * rz)
rx = rx / dd
ry = ry / dd
rz = rz / dd
x1 = x
y1 = y
z1 = z
x2 = ry * z - rz * y
y2 = rz * x - rx * z
z2 = rx * y - ry * x
x3 = rx * (rx * x + ry * y + rz * z)
y3 = ry * (rx * x + ry * y + rz * z)
z3 = rz * (rx * x + ry * y + rz * z)
x = x1 * Cos(u) + x2 * Sin(u) + x3 * (1 - Cos(u))
y = y1 * Cos(u) + y2 * Sin(u) + y3 * (1 - Cos(u))
z = z1 * Cos(u) + z2 * Sin(u) + z3 * (1 - Cos(u))
End Sub
' /////////////////////////////////////////////////////////////////////////////
Sub rotx (u, x0, y0, z0)
xx = x - x0
yy = (y - y0) * Cos(u) - (z - z0) * Sin(u)
zz = (y - y0) * Sin(u) + (z - z0) * Cos(u)
x = xx + x0
y = yy + y0
z = zz + z0
End Sub
' /////////////////////////////////////////////////////////////////////////////
Sub roty (u, x0, y0, z0)
xx = (x - x0) * Cos(u) + (z - z0) * Sin(u)
yy = y - y0
zz = -(x - x0) * Sin(u) + (z - z0) * Cos(u)
x = xx + x0
y = yy + y0
z = zz + z0
End Sub
' /////////////////////////////////////////////////////////////////////////////
Sub rotz (u, x0, y0, z0)
xx = (x - x0) * Cos(u) - (y - y0) * Sin(u)
yy = (x - x0) * Sin(u) + (y - y0) * Cos(u)
zz = z - z0
x = xx + x0
y = yy + y0
z = zz + z0
End Sub