Proggies

[bplus]

Goldwave

Here is a Golden Oldie that Aurel dragged out at his forum:

Code: (Select All)

_Title "Gold Wave bplus 2018-03-13"
'translated from SmallBASIC: Goldwave by johnno copied and mod by bplus 2018-01-28

'QB64 version 2017 1106/82 (the day before they switched to version 1.2)
Const xmax = 600
Const ymax = 480
Screen _NewImage(xmax, ymax, 32)
_ScreenMove 360, 60
Dim ccc As _Unsigned Long


'                  compare fill triangle subs:  one uses very simple  _MAPTRIANGLE opt = 1
'                                               2nd uses primative line graphic0s  opt <> 1


opt = 0 ' << opt 1 uses _MAPTRIANGLE to fill triangles, any other uses line filled triangles
While 1
    For t = 1 To 60 Step .1 '< changed
        Cls 'changed
        For y1 = 0 To 24
            For x1 = 0 To 24
                x = (12 * (24 - x1)) + (12 * y1)
                y = (-6 * (24 - x1)) + (6 * y1) + 300
                d = ((10 - x1) ^ 2 + (10 - y1) ^ 2) ^ .5
                h = 60 * Sin(x1 / 4 + t) + 65
                If t > 10 And t < 20 Then h = 60 * Sin(y1 / 4 + t) + 65
                If t > 20 And t < 30 Then h = 60 * Sin((x1 - y1) / 4 + t) + 65
                If t > 30 And t < 40 Then h = 30 * Sin(x1 / 2 + t) + 30 * Sin(y1 / 2 + t) + 65
                If t > 40 And t < 50 Then h = 60 * Sin((x1 + y1) / 4 + t) + 65
                If t > 50 And t < 60 Then h = 60 * Sin(d * .3 + t) + 65
                If opt = 1 Then
                    'TOP
                    ccc = _RGB32(242 + .1 * h, 242 + .1 * h, h)
                    filltri x, y - h, x + 10, y + 5 - h, x + 20, y - h, ccc
                    filltri x, y - h, x + 10, y - 5 - h, x + 20, y - h, ccc
                    'FRONT-LEFT
                    ccc = _RGB(255, 80, 0)
                    filltri x, y - h, x + 10, y + 5 - h, x + 10, y, ccc
                    filltri x, y - h, x, y - 5, x + 10, y, ccc
                    'FRONT-RIGHT
                    ccc = _RGB32(255, 150, 0)
                    filltri x + 10, y + 5 - h, x + 10, y, x + 20, y - 5, ccc
                    filltri x + 10, y + 5 - h, x + 20, y - h, x + 20, y - 5, ccc
                Else
                    Color _RGB32(242 + .1 * h, 242 + .1 * h, h)
                    filltri2 x, y - h, x + 10, y + 5 - h, x + 20, y - h
                    filltri2 x, y - h, x + 10, y - 5 - h, x + 20, y - h
                    'FRONT-LEFT
                    Color _RGB32(255, 80, 0)
                    filltri2 x, y - h, x + 10, y + 5 - h, x + 10, y
                    filltri2 x, y - h, x, y - 5, x + 10, y
                    Color _RGB32(255, 150, 0)
                    filltri2 x + 10, y + 5 - h, x + 10, y, x + 20, y - 5
                    filltri2 x + 10, y + 5 - h, x + 20, y - h, x + 20, y - 5
                End If

                If InKey$ = Chr$(27) Then End
            Next
        Next
        _Display
        _Limit 200
    Next
Wend

'Andy Amaya's modified FillTriangle
Sub filltri2 (xx1, yy1, xx2, yy2, xx3, yy3)
    'make copies before swapping
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3
    'thanks Andy Amaya!
    'triangle coordinates must be ordered: where x1 < x2 < x3
    If x2 < x1 Then Swap x1, x2: Swap y1, y2
    If x3 < x1 Then Swap x1, x3: Swap y1, y3
    If x3 < x2 Then Swap x2, x3: Swap y2, y3
    If x1 <> x3 Then slope1 = (y3 - y1) / (x3 - x1)

    'draw the first half of the triangle
    length = x2 - x1
    If length <> 0 Then
        slope2 = (y2 - y1) / (x2 - x1)
        For x = 0 To length
            Line (Int(x + x1), Int(x * slope1 + y1))-(Int(x + x1), Int(x * slope2 + y1))
            'lastx2% = lastx%
            lastx% = Int(x + x1)
        Next
    End If

    'draw the second half of the triangle
    y = length * slope1 + y1: length = x3 - x2
    If length <> 0 Then
        slope3 = (y3 - y2) / (x3 - x2)
        For x = 0 To length
            'IF INT(x + x2) <> lastx% AND INT(x + x2) <> lastx2% THEN  'works! but need 2nd? check
            If Int(x + x2) <> lastx% Then
                Line (Int(x + x2), Int(x * slope1 + y))-(Int(x + x2), Int(x * slope3 + y2))
            End If
        Next
    End If
End Sub

' found at QB64.net:    http://www.qb64.net/forum/index.php?topic=14425.0
Sub filltri (x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest 0
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub