Poor Man's 3D Wire Frame

[NakedApe]

Converted to square base Pyramid

Code: (Select All)

_Title "Pyramid Spaceship" 'b+ 2022-07-23 mod 2024-07-04
' 2022-7-24 fixed panel problems and added PolyFill routine for rise and fall glowing

'spinning diamond mini-micro script in micro(A)
' from Aurel Micro A trans:  http://basic4all.epizy.com/index.php?topic=199.new#new

Screen _NewImage(800, 600, 32)
_ScreenMove 200, 0
Dim pi, p2, t, m, dir, glow, i, x, a, y, b, lx, ly, la, lb
pi = _Pi
p2 = pi / 2
t = 0
m = 400
dir = 1
glow = 50
Color _RGB32(200, 200, 240), _RGB32(0, 0, 0)
Dim As _Unsigned Long colr, edge
Dim poly(9)
edge = &H99AAAAFF
Do Until _KeyDown(27)
    Cls
    t = (t + 0.01)
    i = 0
    While i <= 4
        r = Cos(p2 * i + t + ao)
        x = m - 300 * r
        a = m - 250 * r
        y = 400 - 40 * Cos(p2 * (i - 3) + t + ao) - 140 + glow ' y
        b = y + 50
        Color _RGB32(200, 200, 240)
        Line (m, 100 - 140 + glow)-(x, y), edge
        Line (x, y)-(a, b), edge
        Select Case i Mod 4
            Case 0: colr = &H220000FF
            Case 1: colr = &H22008800
            Case 2: colr = &H2200FFFF
            Case 3: colr = &H2200FF00
        End Select
        If i > 0 Then
            Line (a, b)-(la, lb), edge ' bottom disk
            Line (x, y)-(lx, ly), edge ' top disk
            ftri lx, ly, x, y, a, b, colr
            ftri a, b, la, lb, lx, ly, colr
            ftri m, 100 - 140 + glow, lx, ly, x, y, colr
        End If
        poly(2 * i) = a
        poly(2 * i + 1) = b
        lx = x: ly = y
        la = a: lb = b
        i = i + 1
    Wend
    glow = glow + dir
    If glow >= 256 Then dir = -dir: glow = 255
    If glow <= 49 Then dir = -dir: glow = 50
    PolyFill m, 450 - 140 + glow, poly(), _RGB32(200, 200, 255, glow)
    _Display
    _Limit 30
Loop

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

Sub PolyFill (xc, yc, poly(), K As _Unsigned Long) ' closed poly the last point repeats the first to close loop
    Dim i
    For i = LBound(poly) + 2 To UBound(poly) Step 2
        ftri xc, yc, poly(i - 2), poly(i - 1), poly(i), poly(i + 1), K
    Next
End Sub

Cool, thanks for the simplification, @bplus !