FreeBasic

Данная анимация выполнена средствами встроенной библиотеки GFXLIB.

Автор: неизвестен
Платформы: Windows, Linux

''prg: Untitled
''compiler: FB 0.18.1b

Const XRES = 512
Const YRES = 256
Const XRESM1 = XRES - 1
Const YRESM1 = YRES - 1
Const XRES2 = XRES \ 2
Const YRES2 = YRES \ 2
Const YY0 = 0 + 32
Const YY1 = YRESM1 - 32
Const DEGREETORAD = 3.1415926535897932 / 180
Const As Ubyte FALSE = 0
Const As Ubyte TRUE = Not FALSE

Type VERTEX
        As Single x, y, z
        As Single u, v, iz
        'As Integer sx, sy
End Type

Type NODE
        As Single iz
        As Ubyte colour
        As Ubyte tl
        As Uinteger pntr
End Type

Dim Shared As Ubyte Ptr Scrn
Dim Shared As Single zbuffer(xres * yres)
Dim Shared As Integer alphabuffer(xres * yres)
Dim Shared As Integer alphapixellist(xres * yres)
Dim Shared As Integer aplindex
Dim Shared As Ubyte translucent
Dim Shared As node nodeheap(xres * yres)
Dim Shared As Uinteger nodepointer
Dim Shared As Single sinlut(1024), coslut(1024)
Dim Shared As Integer leftedgex(yresm1)
Dim Shared As Integer rightedgex(yresm1)
Dim Shared As Single leftedgeu(yresm1)
Dim Shared As Single rightedgeu(yresm1)
Dim Shared As Single leftedgev(yresm1)
Dim Shared As Single rightedgev(yresm1)
Dim Shared As Single leftedgeiz(yresm1)
Dim Shared As Single rightedgeiz(yresm1)
Dim Shared As Integer firstscanline, lastscanline
Dim Shared As Ubyte colour
Dim Shared As vertex quad(4)
Dim Shared As vertex quadrst(4)
Dim Shared As vertex cube1(8)
Dim Shared As Integer qx(4), qy(4)
Dim Shared As Single q1z(4)


Declare Sub drawcube
Declare Sub init
Declare Sub clearall
Declare Sub rotatequad (As Integer, As Integer, As Integer, As Single)
Declare Sub scanquad
Declare Sub drawpolygon
Declare Sub drawpolygonalpha
Declare Sub sortpixelz (As Integer, As Single)
Declare Sub drawpixelalpha
Declare Sub pixelizer (As Integer, As Integer, As Integer, As Integer, As Integer,  As Ubyte Ptr, As Ubyte Ptr)
Declare Function blend (As Integer, As Integer) As Ubyte

Dim Shared As Integer xa, ya, za
Dim Shared As Integer o(32) = {0,1,2,3,3,2,4,5,5,4,6,7,7,6,1,0,7,0,3,5,6,1,2,4}
'Dim Shared As Integer o(16) = {0,1,2,3,3,2,4,5,5,4,6,7,7,6,1,0}


Sub MAIN
        Screenres XRES, YRES,,,8 Or 32
        Scrn = Screenptr
        init
        Dim As Double t
        Do
                t = Timer
                Screenlock
                clearall
                drawcube
                'pixelizer(8, 100, 100, 90, 90, scrn, scrn) 'try to uncomment this               
                Screenunlock
                Sleep 1
                ''advance angles
                xa = (xa + 2) And 1023 ' 360/1024th (~1/3) degree steps
                ya = (ya + 2) And 1023
                za = (za + 6) And 1023
                ''now wait a moment
                While (Timer - t) < 0.033 '30 Hz
                Wend
                'screensync
        Loop Until Inkey <> ""
        'Sleep
End Sub

MAIN
End

Sub init
        ''init sin/cos lut
        Dim As Double t = 0.0, s = 360 / 1024
        For i As Integer = 0 To 1023
                sinlut(i) = Sin(t * degreetorad)
                coslut(i) = Cos(t * degreetorad)
                t += s
        Next
       
        ''init palette
        Dim As Single RB = 1.0, GB = 1.0, BB= 1.0
        Dim As Single RF = 0.0, GF = 0.0,  BF = 1.0, A = 1.0, d = 1.0 / 255
        Dim As Integer r, g, b
        Palette 0,0,0,0
        For i As Integer = 1 To 255
                r = (RF * A + RB * (1.0 - A)) * 255
                g = (GF * A + GB * (1.0 -A)) * 255
                b = (BF * A + BB * (1.0 - A)) * 255
                Palette 256 - i, r, g, b
                a -= d
        Next
        ''clear screen
        For i As Integer =  YY0 * XRES To YY1 * XRES - 1
                scrn[i] = 255
        Next
        ''read data
        For i As Integer = 0 To 7
                Read cube1(i).x
                Read cube1(i).y
                Read cube1(i).z
        Next
End Sub

''things that have to be re-initialized every frame
Sub clearall
        NODEPOINTER = 1
        ''clear screen
        'for i as integer =  YY0 * XRES to YY1 * XRES - 1
        '        scrn[i] = 255
        'next
        For i As Integer = 0 To aplindex - 1
                scrn[alphapixellist(i)] = 255
        Next
        APLINDEX = 0
End Sub

Sub drawcube
        Dim As Integer j, k
        Dim As Single a, b, c
        colour = 130
        TRANSLUCENT = TRUE'FALSE
                For n As Integer = 1 To 6
                For i As Integer = 0 To 3
                        k = o(j)
                        quad(i).x = 0.8 * cube1(k).x
                        quad(i).y = 0.8 * cube1(k).y
                        quad(i).z = 0.8 * cube1(k).z
                        j += 1
                Next
                rotatequad(xa, ya, za, 1)
                scanquad
                drawpolygonalpha
'                if TRANSLUCENT = TRUE then
'                        TRANSLUCENT = FALSE
'                else
'                        TRANSLUCENT = TRUE
'                end if
                colour -= 10
        Next
        j = 0
        colour = 40
        TRANSLUCENT = TRUE
        For n As Integer = 1 To 6
                For i As Integer = 0 To 3
                        k = o(j)
                        quad(i).x = cube1(k).x
                        quad(i).y = cube1(k).y
                        quad(i).z = cube1(k).z
                        j += 1
                Next
                rotatequad(ya, za, xa, 1)
                scanquad
                drawpolygonalpha
'                if TRANSLUCENT = TRUE then
'                        TRANSLUCENT = FALSE
'                else
'                        TRANSLUCENT = TRUE
'                end if
                colour -= 6
        Next
        drawpixelalpha
End Sub

'Rotate angle xa, ya, za, scale s
Sub rotatequad (xa As Integer, ya As Integer, za As Integer, s As Single)
        Dim As Single sinx = sinlut(xa), cosx = coslut(xa)
        Dim As Single siny = sinlut(ya), cosy = coslut(ya)
        Dim As Single sinz = sinlut(za), cosz = coslut(za), f, f1, tz = -4
        Dim As Single fx = 180, t1
        Dim As Single x, y, z
        For i As Integer = 0 To 3
                'rotate x-axis
                f = quad(i).y
                f1 = quad(i).z
                x = quad(i).x
                y = f * cosx - f1 * sinx
                z = f * sinx + f1 * cosx

                'rotate y-axis
                f = x
                f1 = z
                x = f * cosy - f1 * siny
                z = (f * siny + f1 * cosy) * s + tz

                'rotate z-axis
                f = x
                f1 = y
                x = (f * cosz - f1 * sinz) * s
                y = (f * sinz + f1 * cosz) * s
                t1= 1 / z
                'quad(i).iz = t1
                ''transform to screen view
                'quad(i).sx = XRES2 - x * fx * t1 + 0.5
                'quad(i).sy = YRES2 + y * fx * t1 + 0.5
                q1z(i) = t1
                ''transform to screen view
                qx(i) = XRES2 - x * fx * t1 + 0.5
                qy(i) = YRES2 + y * fx * t1 + 0.5
          Next

End Sub

Sub scanquad
        Dim As Integer  i, j, xpos, m
        Dim As Single x1, x2, y1, y2, dx, iz1, iz2, diz, iz
            firstscanline = XRES
            lastscanline = -1
        For i = 0 To 3 'quad
                'If quad(i).sy < firstscanline Then firstscanline = quad(i).sy
                'If quad(i).sy > lastscanline Then lastscanline = quad(i).sy
                If qy(i) < firstscanline Then firstscanline = qy(i)
                If qy(i) > lastscanline Then lastscanline = qy(i)
        Next
        If firstscanline < YY0 Then firstscanline = YY0
        If lastscanline >= YY1 Then lastscanline = YY1 - 1
        For i = firstscanline To lastscanline
                leftedgex(i) = XRES + 1
                rightedgex(i) = -1
        Next
        For i = 0 To 3
                m = (i + 1) Mod 4
                x1 = qx(i)'quad(i).sx
                y1 = qy(i)'quad(i).sy
                iz1 = q1z(i)'quad(i).iz
                x2 = qx(m)'quad(m).sx
                y2 = qy(m)'quad(m).sy
                iz2 = q1z(m)'quad(m).iz
                If y2 < y1 Then
                        Swap y1, y2
                        Swap x1, x2
                        Swap iz1, iz2
                End If
                dx = (x2 - x1) / (y2 - y1)
                diz = (iz2 - iz1) / (y2 - y1)
                iz = iz1
                For j = y1 To y2 - 1
                        xpos = x1
                        If (j >= YY0) And (j < YY1) Then
                                If (xpos >= 0) And (xpos < XRES) Then
                                        If xpos < leftedgex(j) Then
                                                leftedgex(j) = xpos
                                                leftedgeiz(j) = iz
                                        End If
                                        If xpos > rightedgex(j) Then
                                                rightedgex(j) = xpos
                                                rightedgeiz(j) = iz
                                        End If
                                End If
                        End If
                        x1 += dx
                        iz += diz
                Next
        Next
End Sub

Sub drawpolygon
        Dim As Integer p = firstscanline * XRES
        Dim As Ubyte Ptr ptr1 = Scrn + p
        Dim As Single iz, diz
        For y As Integer = firstscanline To lastscanline
                iz = leftedgeiz(y)
                diz = (rightedgeiz(y) - leftedgeiz(y)) / (rightedgex(y) - leftedgex(y))
                For x As Integer = leftedgex(y) To rightedgex(y) - 1
                        If iz < zbuffer(p + x) Then
                                zbuffer(p + x) = iz
                                ptr1[x] = colour
                        End If
                        iz += diz
                Next
                ptr1 += XRES
                p += XRES
        Next
End Sub

Sub drawpolygonalpha
        Dim As Integer p = firstscanline * XRES
        Dim As Single iz, diz
        For y As Integer = firstscanline To lastscanline
                iz = leftedgeiz(y)
                diz = (rightedgeiz(y) - leftedgeiz(y)) / (rightedgex(y) - leftedgex(y))
                For x As Integer = leftedgex(y) To rightedgex(y) - 1
                        sortpixelz(p + x, iz)
                        iz += diz
                Next
                p += XRES
        Next
End Sub

Sub sortpixelz(index As Integer, iz As Single)
        Dim As Uinteger p, p1, p2
        Dim As Ubyte firstelement
        If alphabuffer(index) = 0 Then
                alphabuffer(index) = nodepointer
                alphapixellist(aplindex) = index
                aplindex += 1
                nodeheap(nodepointer).iz = iz
                nodeheap(nodepointer).colour = colour
                nodeheap(nodepointer).tl = translucent
                nodeheap(nodepointer).pntr = 0
                nodepointer += 1
        Else
                firstelement = TRUE
                p = alphabuffer(index) ''first node pointer
                p1 = nodepointer ''new node pointer
                nodepointer += 1 ''advance to next free node
                p2 = p ''retro pointer
                nodeheap(p1).iz = iz
                nodeheap(p1).colour = colour
                nodeheap(p1).tl = translucent
                nodeheap(p1).pntr = 0
                While nodeheap(p).iz > iz And nodeheap(p).pntr <> 0
                        firstelement = FALSE
                        p2 = p
                        p = nodeheap(p).pntr
                Wend
                If nodeheap(p).pntr = 0 Then
                        If nodeheap(p).iz > iz Then
                                nodeheap(p).pntr = p1
                                nodeheap(p1).pntr = 0
                        Elseif firstelement = TRUE Then
                                alphabuffer(index) = p1
                                nodeheap(p1).pntr = p
                        Else
                                nodeheap(p1).pntr = p
                                nodeheap(p2).pntr = p1
                        End If
                Else
                        If firstelement = TRUE Then
                                alphabuffer(index) = p1
                                nodeheap(p1).pntr = p2
                        Else
                                nodeheap(p1).pntr = p
                                nodeheap(p2).pntr = p1
                        End If
                End If
        End If
End Sub

Function blend(fg As Integer, bg As Integer) As Ubyte
        Return (fg + bg) \ 2
End Function

Sub drawpixelalpha
        Dim As Uinteger p, j, bgcolour = 255, fg
        Dim As Ubyte c1
        For i As Integer = 0 To aplindex - 1
                j = alphapixellist(i)
                p = alphabuffer(j)
                alphabuffer(j) = 0        ''clear alphabuffer at this position
                fg = nodeheap(p).colour
                If nodeheap(p).tl = TRUE Then
                        c1 = (fg+bgcolour)\2 'blend(nodeheap(p).colour, bgcolour)
                Else
                        c1 = fg'nodeheap(p).colour
                End If
                While nodeheap(p).pntr <> 0
                        p = nodeheap(p).pntr
                        fg = nodeheap(p).colour
                        If nodeheap(p).tl = TRUE Then
                                c1 = (fg+c1)\2'blend(nodeheap(p).colour, c1)
                        Else
                                c1 = fg'nodeheap(p).colour
                        End If
                Wend
                scrn[j] = c1
        Next
End Sub

Sub pixelizer(f As Integer, xlbound As Integer, xrbound As Integer, ylbound As Integer, yubound As Integer, src As Ubyte Ptr, dest As Ubyte Ptr)

        Dim As Integer x, y, i, j, c, sum, t, t1
        For y = YRES2 To YRESM1 Step f
        For x = XRES2 To XRESM1 Step f
        c = 0: sum = 0
        For j = 0 To f - 1
                t = (y + j) * XRES
                If (y + j) < (YRES2 + yubound) Then
                        For i = 0 To f - 1
                        If (x + i) < (XRES2 + xrbound) Then
                                c+=1:sum += src[t + x + i]
                        End If
                        Next
                End If
        Next
        If c > 0 Then
        sum = sum / c
        For j = 0 To f - 1
                t = (y + j) * XRES
                If (y + j) < (YRES2 + yubound) Then
                        For i = 0 To f - 1
                        If (x + i) < (XRES2 + xrbound) Then dest[t + x + i] = sum
                        Next
                End If
        Next
        End If
        Next
        Next
        For y = YRES2 To 0 Step -f
        For x = XRES2 To XRESM1 Step f
        c = 0: sum = 0
        For j = 0 To f - 1
                t = (y + j) * XRES
                If (y + j) > (YRES2 - ylbound) Then
                        For i = 0 To f - 1
                        If (x + i) < (XRES2 + xrbound) Then
                                c+=1:sum += src[t + x + i]
                        End If
                        Next
                End If
        Next
        If c > 0 Then
        sum = sum / c
        For j = 0 To f - 1
                t = (y + j) * XRES
                If (y + j) > (YRES2 - ylbound) Then
                        For i = 0 To f - 1
                        If (x + i) < (XRES2 + xrbound) Then dest[t + x + i] = sum
                        Next
                End If
        Next
        End If
        Next
        Next
        For y = YRES2 To 0 Step -f
        For x = XRES2 To 0 Step -f
        c = 0: sum = 0
        For j = 0 To f - 1
                t = (y + j) * XRES
                If (y + j) > (YRES2 - ylbound) Then
                        For i = 0 To f - 1
                        If (x + i) > (XRES2 - xlbound) Then
                                c+=1:sum += src[t + x + i]
                        End If
                        Next
                End If
        Next
        If c > 0 Then
        sum = sum / c
        For j = 0 To f - 1
                t = (y + j) * XRES
                If (y + j) > (YRES2 - ylbound) Then
                        For i = 0 To f - 1
                        If (x + i) > (XRES2 - xlbound) Then dest[t + x + i] = sum
                        Next
                End If
        Next
        End If
        Next
        Next
        For y = YRES2 To YRESM1 Step f
        For x = XRES2 To 0 Step -f
        c = 0: sum = 0
        For j = 0 To f - 1
                t = (y + j) * XRES
                If (y + j) < (YRES2 + yubound) Then
                        For i = 0 To f - 1
                        If (x + i) > (XRES2 - xlbound) Then
                                c+=1:sum += src[t + x + i]
                        End If
                        Next
                End If
        Next
        If c > 0 Then
        sum = sum / c
        For j = 0 To f - 1
                t = (y + j) * XRES
                If (y + j) < (YRES2 + yubound) Then
                        For i = 0 To f - 1
                        If (x + i) > (XRES2 - xlbound) Then dest[t + x + i] = sum
                        Next
                End If
        Next
        End If
        Next
        Next
End Sub

'cube data
cube:
Data -1.0, 1.0, 1.0
Data -1.0, -1.0, 1.0
Data 1.0, -1.0, 1.0
Data 1.0, 1.0, 1.0
Data 1.0, -1.0, -1.0
Data 1.0, 1.0, -1.0
Data -1.0, -1.0, -1.0
Data -1.0, 1.0, -1.0