Poor Man's 3D Wire Frame - Printable Version

OPTION _EXPLICIT DIM AS INTEGER DTW, DTH: DTW = _DESKTOPWIDTH: DTH = _DESKTOPHEIGHT SCREEN _NEWIMAGE(DTW, DTH, 32) _FULLSCREEN _SQUAREPIXELS , _SMOOTH ' _MOUSEHIDE ' TYPE pnt x AS SINGLE y AS SINGLE ' ang AS SINGLE ' radius AS SINGLE ' END TYPE ' DIM pnt(1 TO 13) AS pnt DIM c AS INTEGER DIM AS DOUBLE radians DIM AS INTEGER radius DIM AS SINGLE adder, sizeFactor, angle, fpChange DIM AS SINGLE shipX, shipY DIM AS LONG starScape DIM AS _UNSIGNED LONG yellow yellow = _RGB32(249, 244, 17) shipX = DTW / 2 shipY = DTH / 2 DATA 180,25 ' 1 11 POINTS TO PLAY WITH, 1 is nose point DATA 265,30 ' 2 DATA = THETA ANGLE, RADIUS - larger radius = closer to viewer DATA 275,30 ' 3 DATA 340,4 ' 4 DATA 0,5 ' 5 DATA 20,4 ' 6 DATA 85,30 ' 7 DATA 95,30 ' 8 DATA 130,4 ' 9 DATA 230,4 ' 10 DATA 0,0 ' 11 DATA 270,27 ' 12, side panel point DATA 90,27 ' 13, other side panel FOR c = 1 TO UBOUND(pnt) ' init points array READ angle, radius pnt(c).ang = angle pnt(c).radius = radius NEXT c sizeChange 2.5 sizeFactor = 38 ' start up settings adder = .25 angle = 270 fpChange = 66 ' the nose point pnt(1).radius = pnt(1).radius + fpChange drawStars DO CLS FOR c = 1 TO UBOUND(pnt) ' rotate ship pnt(c).ang = pnt(c).ang + adder radians = _D2R(pnt(c).ang) pnt(c).x = pnt(c).radius * COS(radians) + shipX ' atan2 subbed for x/cos value spins in Y axis, neg for left side, pos for right pnt(c).y = pnt(c).radius * _ATAN2(pnt(c).x, pnt(c).y) + shipY ' atan2 subbed for y/sin value spins in X axis, upside down, rightside up... NEXT c _PUTIMAGE , starScape, 0 ' -----------------------------******************* LINE (pnt(1).x, pnt(1).y)-(pnt(2).x, pnt(2).y), yellow ' draw ship FOR c = 3 TO 8 LINE -(pnt(c).x, pnt(c).y), yellow NEXT c LINE (pnt(8).x, pnt(8).y)-(pnt(1).x, pnt(1).y), yellow LINE (pnt(3).x, pnt(3).y)-(pnt(1).x, pnt(1).y), yellow LINE (pnt(7).x, pnt(7).y)-(pnt(1).x, pnt(1).y), yellow LINE (pnt(2).x, pnt(2).y)-(pnt(10).x, pnt(10).y), yellow LINE (pnt(8).x, pnt(8).y)-(pnt(9).x, pnt(9).y), yellow LINE (pnt(10).x, pnt(10).y)-(pnt(11).x, pnt(11).y), yellow LINE (pnt(9).x, pnt(9).y)-(pnt(11).x, pnt(11).y), yellow LINE (pnt(5).x, pnt(5).y)-(pnt(11).x, pnt(11).y), yellow IF sizeFactor > 10 AND sizeFactor < 80 AND fpChange > -20 AND shipX = DTW / 2 AND shipY = DTH / 2 THEN IF angle < 80 OR angle > 287 THEN PAINT (_WIDTH / 2, _HEIGHT / 2 + 40), _RGB32(250, 50, 150, 60), yellow IF angle > 77 AND angle < 255 THEN PAINT (_WIDTH / 2, _HEIGHT / 2 + 40), _RGB32(100, 190, 0, 90), yellow END IF IF sizeFactor > -50 THEN CIRCLE (pnt(12).x, pnt(12).y), 2, _RGB32(249, 249, 0) ' side panel PAINT (pnt(12).x, pnt(12).y), _RGB32(255, 0, 0), _RGB32(249, 249, 0) CIRCLE (pnt(13).x, pnt(13).y), 2, _RGB32(249, 250, 0) PAINT (pnt(13).x, pnt(13).y), _RGB32(255, 0, 0), _RGB32(249, 250, 0) END IF ' -----------------------------******************* user input IF _KEYDOWN(122) THEN shipX = shipX - 2 IF _KEYDOWN(120) THEN shipX = shipX + 2 IF _KEYDOWN(99) THEN shipY = shipY - 1.554 IF _KEYDOWN(118) THEN shipY = shipY + 1.554 IF _KEYDOWN(19200) THEN IF fpChange > -500 THEN pnt(1).radius = pnt(1).radius - 1 ' far point changes fpChange = fpChange - 1 END IF END IF IF _KEYDOWN(19712) THEN IF fpChange < 500 THEN pnt(1).radius = pnt(1).radius + 1 fpChange = fpChange + 1 END IF END IF IF _KEYDOWN(97) THEN adder = -.5 ' angle changes IF _KEYDOWN(100) THEN adder = .5 IF _KEYDOWN(18432) THEN IF sizeFactor < 150 THEN sizeChange 1.01: sizeFactor = sizeFactor + .5 ' size changes IF _KEYDOWN(20480) THEN IF sizeFactor > -250 THEN sizeChange .99: sizeFactor = sizeFactor - .5 IF _KEYDOWN(114) THEN adder = .2 ' r to rotate IF _KEYDOWN(115) THEN adder = 0 ' s to stop angle = angle + adder ' auto-spin IF angle > 359 THEN angle = 0 ' mind the angle IF angle < 0 THEN angle = 359 PRINT "Angle:"; INT(angle) PRINT "Size Factor:"; sizeFactor PRINT "Far Point Change:"; fpChange PRINT PRINT "up arrow = ENLARGE SHIP" PRINT "down arrow = SHRINK SHIP" PRINT "left arrow = 'PULL' NOSE POINT" PRINT "right arrow = 'PUSH' NOSE POINT" PRINT "d = spin fast clockwise" PRINT "a = spin fast counterclockwise" PRINT "r = back to slow rotate" PRINT "s = stop rotation" PRINT "z = LEFT" PRINT "x = RIGHT" PRINT "c = UP" PRINT "v = DOWN" _DISPLAY _LIMIT 200 LOOP UNTIL _KEYDOWN(27) SYSTEM ' ------------------------------------ SUB sizeChange (r AS SINGLE) DIM c AS INTEGER SHARED AS pnt pnt() FOR c = 1 TO UBOUND(pnt) pnt(c).radius = pnt(c).radius * r NEXT c END SUB ' ------------------------------------ SUB drawStars () ' starscape backdrop DIM c AS INTEGER DIM AS LONG virtual SHARED AS LONG starScape virtual = _NEWIMAGE(1280, 720, 32) ' _DEST virtual c = 0 DO c = c + 1 PSET ((INT(RND * _WIDTH)), INT(RND * _HEIGHT)), _RGB32(200) ' whites LOOP UNTIL c = 2000 ' was 3600 c = 0 DO c = c + 1 PSET ((INT(RND * _WIDTH)), INT(RND * _HEIGHT)), _RGB32(70) ' grays LOOP UNTIL c = 6000 ' was 3600 c = 0 DO c = c + 1 PSET ((INT(RND * _WIDTH)), INT(RND * _HEIGHT)), _RGB32(255, 67, 55, 124) ' reddies DRAW "S2U1R1D1L1" LOOP UNTIL c = 26 c = 0 DO c = c + 1 PSET ((INT(RND * _WIDTH)), INT(RND * _HEIGHT)), _RGB32(0, 255, 0, 116) ' greenies DRAW "S2U1R1D1L1" LOOP UNTIL c = 86 c = 0 DO c = c + 1 PRESET ((INT(RND * _WIDTH)), INT(RND * _HEIGHT)), _RGB32(255, 255, 183, 120) ' big yellows DRAW "S4U1R1D1L1" LOOP UNTIL c = 130 starScape = _COPYIMAGE(virtual, 32) ' software image _DEST 0 _FREEIMAGE virtual END SUB ' -----------------------------------------

Code: (Select All)

For c = 1 To UBound(pnt) '                  rotate ship

        pnt(c).ang = pnt(c).ang + adder

        radians = _D2R(pnt(c).ang)

        pnt(c).x = pnt(c).radius * Cos(radians) + shipX ' ????  atan2 subbed for x/cos value spins in Y axis, neg for left side, pos for right

        pnt(c).y = pnt(c).radius * Sin(radians) + shipY ' ???? atan2 subbed for y/sin value spins in X axis, upside down, rightside up...

    Next c

Code: (Select All)

_Title "Diamond Spaceship" 'b+ 2022-07-23

' 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, p6, t, m, dir, glow, i, x, a, y, b, lx, ly, la, lb

pi = _Pi

p6 = pi / 6

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(25)

edge = &H99AAAAFF

Do Until _KeyDown(27)

    Cls

    t = (t + 0.01)

    i = 0

    While i <= 12

        r = Cos(p6 * i + t + ao)

        x = m - 300 * r

        a = m - 250 * r

        y = 400 - 40 * Cos(p6 * (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

        If i Mod 2 Then colr = &H220000FF Else colr = &H2200FFFF

        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