﻿Option Explicit

Private Pi As Double
Private VisibleSheet As Integer
Private TunnelTexture(32 * 32 - 1) As Integer
Private RotoZoomTexture(32 * 32 - 1) As Integer

Private framebuf(51 * 51 - 1) As Double
Private ovx(20), ovy(20), ovz(20) As Double

Private EffectBrightness As Double

Private Enum FadePhase
    FadeIn = 0
    Normal = 1
    FadeOut = 2
    Finish = 3
End Enum

Public Sub Demo()
    Pi = 3.1415926535
    VisibleSheet = 1

    Dim startTime, previousLineTime, endTime As Double
    Dim fadeInTime, fadeOutTime As Double
    Dim nextLine, lastLine As Integer
    Dim Text As New ScrollText
    Dim fadeSpeed, fadeTime As Double
    Dim Phase As FadePhase
    fadeSpeed = 0.4
    fadeTime = 1 / fadeSpeed

    Text.addLine 4, "ananasmurska presents"
    Text.addLine 4, "excellence™"
    Text.addLine 2, ""
    Text.addLine 3, "(completely made at the party place)"
    Text.addLine 2, ""
    Text.addLine 1, "code: "
    Text.addLine 2, "code: j.pupu"
    Text.addLine 2, "code: ion"
    Text.addLine 2, "code: blueflame"
    Text.addLine 0.1, ""
    Text.addLine 0.1, "KUAKE WORLD DOMINATION"
    Text.addLine 2, ""
    Text.addLine 4, "world's first free-directional tunnel in excel™"
    Text.addLine 2, ""
    Text.addLine 2, "greetings to: "
    Text.addLine 2, "greetings to: aspekt"
    Text.addLine 2, "greetings to: grin"
    Text.addLine 2, "greetings to: gluterol"
    Text.addLine 2, "greetings to: tukka"
    Text.addLine 2, "greetings to: lücid"
    Text.addLine 2, "greetings to: matt current"
    Text.addLine 2, "greetings to: moonhazard"
    Text.addLine 2, "greetings to: numedia cyclops"
    Text.addLine 2, "greetings to: puolijohde"
    Text.addLine 2, "greetings to: pwp"
    Text.addLine 2, "greetings to: tAAt"
    Text.addLine 2, "greetings to: unique"
    Text.addLine 2, ""
    Text.addLine 3, "that's it, i'm going home."
    Text.addLine 1, ""

    startTime = Timer
    previousLineTime = startTime
    endTime = startTime + Text.endTime

    init

    setTitle Text.Line.Text
    
    interpolatePalette 1, 27, 0, 0, 0, 0, 44, 160
    interpolatePalette 28, 49, 0, 44, 160, 128, 255, 196
    interpolatePalette 50, 56, 128, 255, 196, 255, 255, 255

    Phase = FadeIn
    fadeInTime = Timer
    While Phase <> Finish
        If Phase = Normal Then
            If Timer >= startTime + 9 Then
                Phase = FadeOut
                fadeOutTime = Timer
            End If
        ElseIf Phase = FadeIn Then
            If EffectBrightness <= 1 Then
                EffectBrightness = fadeSpeed * (Timer - fadeInTime)
            Else
                EffectBrightness = 1
                Phase = Normal
            End If
        ElseIf Phase = FadeOut Then
            EffectBrightness = 1 - fadeSpeed * (Timer - fadeOutTime)
            If EffectBrightness < 0 Then
                Phase = Finish
            End If
        End If
        
        If Timer >= previousLineTime + Text.Line.time Then
            previousLineTime = previousLineTime + Text.Line.time
            Text.nextLine
            setTitle Text.Line.Text
        End If

        swapBuffer
        'tunnel -1 * (Timer - startTime)
        thingy 0.3 * (Timer - startTime)
        'rotoZoom 0.3 * (Timer - startTime)
    Wend
    
    interpolatePalette 1, 27, 0, 0, 0, 255, 0, 0
    interpolatePalette 28, 49, 255, 0, 0, 255, 255, 0
    interpolatePalette 50, 56, 255, 255, 0, 255, 255, 255

    Phase = FadeIn
    fadeInTime = Timer
    While Phase <> Finish
        If Phase = Normal Then
            If Timer >= startTime + 36 Then
                Phase = FadeOut
                fadeOutTime = Timer
            End If
        ElseIf Phase = FadeIn Then
            If EffectBrightness <= 1 Then
                EffectBrightness = fadeSpeed * (Timer - fadeInTime)
            Else
                EffectBrightness = 1
                Phase = Normal
            End If
        ElseIf Phase = FadeOut Then
            EffectBrightness = 1 - fadeSpeed * (Timer - fadeOutTime)
            If EffectBrightness < 0 Then
                Phase = Finish
            End If
        End If
        
        If Timer >= previousLineTime + Text.Line.time Then
            previousLineTime = previousLineTime + Text.Line.time
            Text.nextLine
            setTitle Text.Line.Text
        End If

        swapBuffer
        tunnel -1 * (Timer - startTime)
        'thingy 0.3 * (Timer - startTime)
        'rotoZoom 0.3 * (Timer - startTime)
    Wend

    interpolatePalette 1, 27, 0, 0, 0, 0, 0, 255
    interpolatePalette 28, 49, 0, 0, 255, 0, 255, 255
    interpolatePalette 50, 56, 0, 255, 255, 255, 255, 255

    Phase = FadeIn
    fadeInTime = Timer
    While Phase <> Finish
        If Phase = Normal Then
            If Timer >= endTime - fadeTime Then
                Phase = FadeOut
                fadeOutTime = Timer
            End If
        ElseIf Phase = FadeIn Then
            If EffectBrightness <= 1 Then
                EffectBrightness = fadeSpeed * (Timer - fadeInTime)
            Else
                EffectBrightness = 1
                Phase = Normal
            End If
        ElseIf Phase = FadeOut Then
            EffectBrightness = 1 - fadeSpeed * (Timer - fadeOutTime)
            If EffectBrightness < 0 Then
                Phase = Finish
            End If
        End If
        
        If Timer >= previousLineTime + Text.Line.time Then
            previousLineTime = previousLineTime + Text.Line.time
            Text.nextLine
            setTitle Text.Line.Text
        End If

        swapBuffer
        'tunnel -1 * (Timer - startTime)
        rotoZoom 0.5 * (Timer - startTime)
    Wend

    initColors
    setTitle Text.Line.Text

    deInit
End Sub

Private Sub init()
    Dim s As Object

    'Application.DisplayFullScreen = True
    
    initTunnelTexture
    initRotoZoomTexture
    initThingy

    While Sheets.Count < 2
        Sheets.Add
    Wend

    For Each s In Sheets
        s.Select
    
        Cells.Select

        With Selection
            .Clear

            .ColumnWidth = 1.1
            .RowHeight = 11
            .Interior.ColorIndex = 1 ' black bg
            .Font.ColorIndex = 55     ' white fg
            .Font.Size = 7
            .Font.Bold = False
        End With

        Rows(2).Select
        With Selection
            .RowHeight = 30
            .Font.Size = 24
            .Font.Bold = True
        End With
        
        range("A1:AZ52").Select
        ActiveWindow.zoom = True

        range("A1").Select
    Next
End Sub

Private Sub deInit()
    Dim s As Object

    'Application.DisplayFullScreen = False
    
    'While Sheets.Count > 1
    '    Sheets(1).Delete
    'Wend

    For Each s In Sheets
        s.Select
    
        ActiveWindow.zoom = 100

        Cells.Select
        
        With Selection
            .Clear

            .ColumnWidth = 10
            .RowHeight = 15
            .Interior.ColorIndex = 0
            .Font.ColorIndex = 1
            .Font.Size = 10
            .Font.Bold = False
        End With

        range("A1").FormulaR1C1 = "Select Tools / Macro / Macros or press Alt-F8; then run 'Demo'."
        
        range("A2").Select
    Next
End Sub

Private Sub initTunnelTexture()
    Dim x, y, c As Integer
    For y = 0 To 31
        For x = 0 To 31
            'c = Int(((Sin(x * 6 * Pi / 32) * Sin(x * 2 * Pi / 32) + Cos(y * 6 * Pi / 32)) / (2 * 2) + 0.5) * 55)
            c = Int(((Sin(x * 6 * Pi / 32) _
                    + Cos((x + y) * 2 * Pi / 32) * 2 _
                    + Cos(y * 6 * Pi / 32) _
                    ) / (3 * 2.7) + 0.5) * 55)
            TunnelTexture(x + y * 32) = c
        Next x
    Next y
End Sub

Private Sub initThingy()
    Dim i As Integer
    Dim x, y, z, vlen As Double
    Randomize
    For i = 0 To 20 - 1
        x = Rnd() * 2 - 1#  '(Rnd() Mod 200) - 100) / 100#
        y = Rnd() * 2 - 1#  '((Rnd() Mod 200) - 100) / 100#
        z = Rnd() * 2 - 1#  '((Rnd() Mod 200) - 100) / 100#
        vlen = Sqr(x * x + y * y + z * z)
        ovx(i) = x / vlen
        ovy(i) = y / vlen
        ovz(i) = z / vlen
    Next i
End Sub

Private Sub initRotoZoomTexture()
    Dim logo As String
    Dim x, y, c As Integer
    For y = 0 To 31
        For x = 0 To 31
            c = 27 + 27 * ( _
                0.4 * Sin(x / 31 * 2 * Pi) _
                + 0.3 * Cos(y / 31 * 2 * Pi) _
            )
            RotoZoomTexture(x + y * 32) = c
        Next
    Next
End Sub

Private Sub interpolatePalette(index1 As Integer, index2 As Integer, _
    r1 As Integer, g1 As Integer, b1 As Integer, _
    r2 As Integer, g2 As Integer, b2 As Integer)
'
    Dim i, length As Integer
    length = index2 - index1
    For i = 0 To length
        Dim coeff As Double
        coeff = i / length
        ActiveWorkbook.Colors(index1 + i) = _
            RGB((1 - coeff) * r1 + coeff * r2, _
            (1 - coeff) * g1 + coeff * g2, _
            (1 - coeff) * b1 + coeff * b2)
    Next
End Sub

Private Sub initColors()
    Dim s As Object

    For Each s In Sheets
        s.Select

        Cells.Select

        With Selection
            .Interior.ColorIndex = 1 ' black bg
            .Font.ColorIndex = 55 ' white fg
        End With

        range("A1").Select
    Next
End Sub

Private Sub setTitle(Text As String)
    Dim s As Object
    
    For Each s In Sheets
        s.range("B2").FormulaR1C1 = Text
    Next
End Sub

Private Sub swapBuffer()
    VisibleSheet = 1 + ((2 - VisibleSheet) Mod 2)
    Sheets(VisibleSheet).Select
End Sub

Private Sub putPixel(ByVal x As Integer, ByVal y As Integer, ByVal color As Integer)
    Dim range As String
    Dim cn As String
    
    If x < 0 Or y < 0 Or x > 50 Or y > 50 Then Exit Sub

    If x < 26 Then
        cn = Chr$(65 + x)
    Else
        cn = "A" + Chr(65 + x - 26)
    End If
    
    range = cn + CStr(y + 1)

    If color < 0 Then color = 0
    If color > 55 Then color = 55

    'ActiveCell.FormulaR1C1 = cn + Str(x)
    '
    'Sheets(3 - VisibleSheet).Range(kohta).Interior.color = RGB(x * 5, color * 5, 0)
    Sheets(3 - VisibleSheet).range(range).Interior.ColorIndex = color + 1
End Sub

Private Function atan2(ByVal x As Double, ByVal y As Double) As Double

    If x = 0 Then x = 0.0000001 ' cheat

    atan2 = Atn(y / x)
    
    'atan2 = Sgn(x) * Sgn(y) * atan2

End Function

Private Sub tunnel(ByVal zofs As Double)
    Dim vx, vy, vz, vlen As Double
    Dim ox, oy, oz As Double
    Dim k, angle As Double
    Dim tex As String
    Dim y, x, s, t, c As Integer
    Dim sin1, sin2, sin3 As Double
    Dim cos1, cos2, cos3 As Double
    
    sin1 = Sin(zofs * 0.3)
    sin2 = Sin(Sin(zofs * 0.4))
    sin3 = Sin(zofs * 0.5)
    cos1 = Cos(zofs * 0.3)
    cos2 = Cos(Sin(zofs * 0.4))
    cos3 = Cos(zofs * 0.5)

    For y = 0 To 50
        For x = 0 To 50

            ' set ray vector
            vx = x - 25#
            vy = y - 25#
            vz = -50#
            
            ' rotate around X
            'oy = vy
            'vy = cos1 * oy - sin1 * vz
            'vz = sin1 * oy - cos1 * vz
            
            ' rotate around Z
            ox = vx
            vx = cos3 * ox - sin3 * vy
            vy = sin3 * ox + cos3 * vy
            
            ' rotate around Y
            ox = vx
            vx = cos2 * ox - sin2 * vz
            vz = sin2 * ox + cos2 * vz
            
            ' corrective cheat, *cough*
            If vx = 0 Then vx = 0.000001
            If vy = 0 Then vy = 0.000001
            
            ' normalize ray vector
            vlen = Sqr(vx * vx + vy * vy + vz * vz)
            vx = vx / vlen
            vy = vy / vlen
            vz = vz / vlen
            
            angle = atan2(vx, vy) / (Pi / 2)
            
            k = 1# / Sqr(vx * vx + vy * vy)
            vx = vx * k
            vy = vy * k
            vz = vz * k
            
            If angle > 0 Then
                s = Int(angle * 32) Mod 32
            Else
                s = 31 + Int(angle * 32) Mod 32
            End If
            t = Abs(Int(vz * 12 + zofs / Pi * 32) Mod 32)
            
            'c = Asc(Mid(tex, 1 + s + t * 8)) - 32
            c = TunnelTexture(s + t * 32) * EffectBrightness
            If Abs(vz) < 10 Then
                If Abs(vz) > 2 Then
                    ' blend(c, 0, (abs(vz)-2)/8.0
                    c = c * (1 - (Abs(vz) - 2) / 8#)
                End If
            Else
                ' black
                c = 0
            End If
            
            putPixel 1 + x, 3 + y, c
        Next x
    Next y
End Sub

Private Sub rotoZoom(ByVal w As Double)
    Dim sinw, cosw, z As Double
    Dim u, v As Integer
    Dim x, y, c As Integer

    sinw = Sin(w)
    cosw = Cos(w)
    z = 1 + 0.3 * sinw

    For y = 0 To 50
        For x = 0 To 50
            u = Abs(Int(z * (x * cosw - y * sinw))) Mod 32
            'v = Abs(Int(z * (x * sinw + y * cosw))) Mod 32
            v = Abs(Int(z * (x + sinw + y * cosw))) Mod 32
            c = RotoZoomTexture(u + v * 32) * EffectBrightness
            putPixel 1 + x, 3 + y, c
                
            
        Next
    Next
End Sub

Private Sub blit_framebuf()
    Dim x, y, c As Integer
    Dim i As Integer
    i = 0
    For y = 0 To 50
        For x = 0 To 50
            If framebuf(i) > 1# Then
                c = 55
            Else
                c = 55 * framebuf(i)
            End If
            i = i + 1
            If c < 0 Then c = 0
            'If c > 255 Then c = 255
            putPixel 1 + x, 3 + y, EffectBrightness * c
        Next x
    Next y
End Sub

Private Sub raaah()
    Dim x, y As Integer
    Dim x2, y2 As Integer
    Dim i, i2 As Integer
    
    i = 0
    For y = -25 To 25
        y2 = y * 0.8
        For x = -25 To 25
            x2 = x * 0.8
    
            'i2 = (x2 + 25) + (y2 + 25) * 51
            'framebuf(i) = framebuf(i) + framebuf(i2) * 0.7
    
            i2 = i + 1
            If i2 >= 51 * 51 Then i2 = 51 * 51 - 1
            framebuf(i2) = framebuf(i2) + framebuf(i) * 0.7
    
            i = i + 1
        Next x
    Next y
    
    
    'For y = 0 To 25
    '    y2 = y * 0.9
    '    For x = 0 To 25
    '        x2 = x * 0.9
    '
    '        i2 = (x2 + 25) + (y2 + 25) * 51
    '        i = (x + 25) + (y + 25) * 51
    '        framebuf(i) = framebuf(i) + framebuf(i2) * 0.7
            
            'i2 = i + 1
            'If i2 >= 51 * 51 Then i2 = 51 * 51 - 1
            'framebuf(i2) = framebuf(i2) + framebuf(i) * 0.7
            
    '        i = i + 1
    '    Next x
    'Next y
    
End Sub

Private Sub thingy(ByVal time As Double)

    Dim i As Integer
    Dim x, ox As Double
    Dim y As Double
    Dim z As Double
    Dim sin2, cos2, sin3, cos3 As Double
    
    
    ' clear buffer
    For i = 0 To 51 * 50 - 1
        framebuf(i) = framebuf(i + 51) * 0.3
    Next i
    
    For i = 0 To 10
        ' rotate coords
        sin2 = Sin(time)
        cos2 = Cos(time)
        sin3 = Sin(time * 1.3)
        cos3 = Cos(time * 1.3)
        
        ' rotate around Z
        ox = ovx(i)
        x = cos3 * ovx(i) - sin3 * ovy(i)
        y = sin3 * ovx(i) + cos3 * ovy(i)
            
        ' rotate around Y
        ox = x
        x = cos2 * ox - sin2 * z
        z = sin2 * ox + cos2 * z
        
        framebuf(25 + Int(x * 20) + (25 + Int(y * 20)) * 51) = 1#
                
    Next i
    raaah
    blit_framebuf
End Sub

Private scrolltextLines As Collection
Private currentLine As Integer

Private Sub Class_Initialize()
    Set scrolltextLines = New Collection
    currentLine = 1
End Sub

Public Sub addLine(time As Double, Text As String)
    Dim thisLine As New ScrollTextLine

    thisLine.time = time
    thisLine.Text = Text

    scrolltextLines.Add thisLine
End Sub

Public Sub nextLine()
    currentLine = currentLine + 1
    If (currentLine > scrolltextLines.Count) Then currentLine = scrolltextLines.Count
End Sub

Public Property Get Line() As ScrollTextLine
    Set Line = scrolltextLines(currentLine)
End Property

Public Property Get endTime() As Double
    endTime = 0
    If scrolltextLines.Count Then
        Dim Line As Object
        For Each Line In scrolltextLines
            endTime = endTime + Line.time
        Next
    End If
End Property

Private thisLine As Line

Private Type Line
    time As Double
    Text As String
End Type

Private Sub Class_Initialize()
End Sub

Public Property Get time() As Double
    time = thisLine.time
End Property

Public Property Let time(time As Double)
    thisLine.time = time
End Property

Public Property Get Text() As String
    Text = thisLine.Text
End Property

Public Property Let Text(Text As String)
    thisLine.Text = Text
End Property
