Screen Savers

[SierraKen]

LOL B+ this is the best! I like how the saucers come down to the trees like a swarm of birds. There is one thing I noticed, half-way to the trees everything stops for about 1/2 a second and then starts again. It could just be my computer. Pretty amazing!

[bplus]

Thanks Ken and TempodiBasic upstairs there

I never noticed a pause when developing the code. There is a purposeful delay once all the ships are roosted in the "trees".

There have been reports of time shifts happening when large numbers of ships occupy a small space, 448 is enough I guess.

[SpriggsySpriggs]

These are very pretty, bplus. Thanks for sharing!

[bplus]

Thanks Spriggsy!

I think I will throw this in before it gets buried, I think it is cool and looking to try this effect on something else:

Xor 2 Fans

Code: (Select All)

_Title "Xor 2 fans" 'b+ 2022-09-10 just saw at JB
' hmm... how to do this in QB64?
Screen _NewImage(800, 600, 32)
_FullScreen
f1& = _NewImage(800, 600, 32)
f2& = _NewImage(800, 600, 32)
Color , &HFF990000
Do
    Cls
    ao1 = ao1 + .012: ao2 = ao2 - .012
    _Dest f1&
    Line (0, 0)-(799, 599), _RGB32(0, 0, 0), BF
    drawFan 300, 300, 295, 32, &HFFFFFFFF, ao1

    _Dest f2&
    Line (0, 0)-(799, 599), _RGB32(0, 0, 0), BF
    drawFan 500, 300, 295, 32, &HFFFFFFFF, ao2

    _Dest 0
    For y = 0 To 599
        For x = 0 To 799
            _Source f1&
            If Point(x, y) = _RGB32(0, 0, 0) Then p1 = 0 Else p1 = -1
            _Source f2&
            If Point(x, y) = _RGB32(0, 0, 0) Then p2 = 0 Else p2 = -1
            If p1 Xor p2 Then PSet (x, y), &HFFAAAAAA ' tone it down a bit
        Next
    Next
    _Display
    _Limit 60 'Draw as fast as you can!
Loop While _KeyDown(27) = 0

Sub drawFan (x, y, r, nBlades, colr As _Unsigned Long, ao)
    angle = _Pi(1 / nBlades)
    For i = 0 To 2 * nBlades - 1 Step 2
        x1 = x + r * Cos(i * angle + ao)
        y1 = y + r * Sin(i * angle + ao)
        x2 = x + r * Cos((i + 1) * angle + ao)
        y2 = y + r * Sin((i + 1) * angle + ao)
        ftri x, y, x1, y1, x2, y2, colr
    Next
End Sub

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

   

[bplus]

Using PixelCollision code I've perfected my

 Creepy Screen Saver

Code: (Select All)

Option _Explicit
_Title "Spiders with Box and Pixel Collisions Experiment 2" 'b+ 2023-01-30/31
' 2023-01-30 Another experiment in handling Spider collisions,
' At collision, no reversal nor turn, jump ahead alittle!
' Tweaked number of spiders, speeds, colors and sizes and sound if collide

' !!!!!!!!!!!!!!!!!!!          Escape to Quit         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

'                 !!! Speaker volume around 20 maybe! !!!

Randomize Timer
Dim Shared xmax As Integer, ymax As Integer
xmax = _DesktopWidth
ymax = _DesktopHeight
Const nSpinners = 40
Type SpinnerType
    As Single x, y, dx, dy, sz
    c As _Unsigned Long
End Type
Dim Shared s(1 To nSpinners) As SpinnerType

Type boxType ' for PixelCollison&
    As Long img, x, y, w, h
    c As _Unsigned Long
End Type

Dim As Long i, j, iImg, jImg, lc, i2, sc, intx, inty
Dim As boxType sIo, sJo

sc = _ScreenImage
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 0, 0
_FullScreen
For i = 1 To nSpinners
    newSpinner i
Next
i2 = 1
While InKey$ <> Chr$(27)
    '_Title Str$(i2) + " spiders"     ' when testing spider speeds
    _PutImage , sc, 0
    lc = lc + 1
    If lc Mod 50 = 49 Then
        lc = 0
        If i2 < nSpinners Then i2 = i2 + 1
    End If
    For i = 1 To i2

        'ready for collision check

        ' max sz = .75 which needs 140 x 140 image square  +++++++++++++++++++++++++
        iImg = _NewImage(140, 140, 32)
        _Dest iImg
        drawSpinner iImg, 70, 70, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c
        _Dest 0
        sIo.x = s(i).x - 70
        sIo.y = s(i).y - 70
        sIo.w = 140
        sIo.h = 140 ' this meets requirements for collision obj1
        sIo.img = iImg ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++

        For j = i + 1 To i2
            ' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++
            jImg = _NewImage(140, 140, 32)
            _Dest jImg
            drawSpinner jImg, 70, 70, s(j).sz, _Atan2(s(j).dy, s(j).dx), s(j).c
            _Dest 0
            sJo.x = s(j).x - 70
            sJo.y = s(j).y - 70
            sJo.w = 140
            sJo.h = 140 ' this meets requirements for collision obj1
            sJo.img = jImg
            If PixelCollision&(sIo, sJo, intx, inty) Then '+++++++++++++++++++++++++++++++++++++++
                If Rnd < .1 Then Sound Rnd * 7000 + 4000, .05
                s(i).x = s(i).x + s(i).dx + rndCW(0, 3.5)
                s(i).y = s(i).y + s(i).dy + rndCW(0, 3.5)
                s(j).x = s(j).x + s(j).dx + rndCW(0, 3.5)
                s(j).y = s(j).y + s(j).dy + rndCW(0, 3.5)
                Exit For
            End If
            _FreeImage jImg
        Next
        s(i).x = s(i).x + s(i).dx + rndCW(0, 3.5)
        s(i).y = s(i).y + s(i).dy + rndCW(0, 3.5)
        If s(i).x < -100 Or s(i).x > xmax + 100 Or s(i).y < -100 Or s(i).y > ymax + 100 Then newSpinner i
        _PutImage (s(i).x - 70, s(i).y - 70), iImg, 0
        _FreeImage iImg
    Next
    _Display
    _Limit 30
Wend

Sub newSpinner (i As Integer) 'set Spinners dimensions start angles, color?
    Dim r
    s(i).sz = rndCW(.5, .25) ' * .55 + .2
    If Rnd < .5 Then r = -1 Else r = 1
    s(i).dx = (s(i).sz * Rnd * 8 + 1) * r * 2: s(i).dy = (s(i).sz * Rnd * 8 + 1) * r * 2
    r = Int(Rnd * 4)
    Select Case r
        Case 0: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = 0: If s(i).dy < 0 Then s(i).dy = -s(i).dy
        Case 1: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = ymax: If s(i).dy > 0 Then s(i).dy = -s(i).dy
        Case 2: s(i).x = 0: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx < 0 Then s(i).dx = -s(i).dx
        Case 3: s(i).x = xmax: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx > 0 Then s(i).dx = -s(i).dx
    End Select
    r = Rnd * 80 + 40
    s(i).c = _RGB32(r, 20 + rndCW(.5 * r, 15), 10 + rndCW(.25 * r, 10))
End Sub

Sub drawSpinner (idest&, x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
    Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green
    Static switch As Integer
    switch = switch + 2
    switch = switch Mod 16 + 1
    red = _Red32(c): green = _Green32(c): blue = _Blue32(c)
    r = 10 * scale
    x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
    r = 2 * r 'lg lengths
    For lg = 1 To 8
        If lg < 5 Then
            a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
        Else
            a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
        End If
        x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
        drawLink idest&, x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5)
        If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
        a1 = a + d * _Pi(1 / 12)
        x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
        drawLink idest&, x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8)
        rd = Int(Rnd * 8) + 1
        a2 = a1 + d * _Pi(1 / 8) * rd / 8
        x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
        drawLink idest&, x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12)
    Next
    r = r * .5
    fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5)
    x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
    fcirc x2, y2, r * .2, &HFF000000
    x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
    fcirc x2, y2, r * .2, &HFF000000
    r = r * 2
    x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
    TiltedEllipseFill idest&, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue)
End Sub

Sub drawLink (idest&, x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
    Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
    a = _Atan2(y2 - y1, x2 - x1)
    a1 = a + _Pi(1 / 2)
    a2 = a - _Pi(1 / 2)
    x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
    x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
    x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
    x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
    fquad idest&, x3, y3, x4, y4, x5, y5, x6, y6, c
    fcirc x1, y1, r1, c
    fcirc x2, y2, r2, c
End Sub

'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (idest&, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
    ftri idest&, x1, y1, x2, y2, x4, y4, c
    ftri idest&, x3, y3, x4, y4, x1, y1, c
End Sub

Sub ftri (idest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
    Dim a&
    a& = _NewImage(1, 1, 32)
    _Dest a&
    PSet (0, 0), K
    _Dest idest&
    _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
    _FreeImage a& '<<< this is important!
End Sub

Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub

Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
    Dim TEmax As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
    Dim prc As _Unsigned Long, tef As Long
    prc = _RGB32(255, 255, 255, 255)
    If a > b Then TEmax = a + 1 Else TEmax = b + 1
    mx2 = TEmax + TEmax
    tef = _NewImage(mx2, mx2)
    _Dest tef
    _Source tef 'point wont read without this!
    For k = 0 To 6.2832 + .05 Step .1
        i = TEmax + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
        j = TEmax + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
        If k <> 0 Then
            Line (lasti, lastj)-(i, j), prc
        Else
            PSet (i, j), prc
        End If
        lasti = i: lastj = j
    Next
    Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
    For y = 0 To mx2
        x = 0
        While Point(x, y) <> prc And x < mx2
            x = x + 1
        Wend
        xleft(y) = x
        While Point(x, y) = prc And x < mx2
            x = x + 1
        Wend
        While Point(x, y) <> prc And x < mx2
            x = x + 1
        Wend
        If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
    Next
    _Dest destHandle&
    For y = 0 To mx2
        If xleft(y) <> mx2 Then Line (xleft(y) + x0 - TEmax, y + y0 - TEmax)-(xright(y) + x0 - TEmax, y + y0 - TEmax), c, BF
    Next
    _FreeImage tef
End Sub

Function BoxCollision% (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h)
    ' x, y represent the box left most x and top most y
    ' w, h represent the box width and height which is the usual way sprites / tiles / images are described
    ' such that boxbottom = by + bh
    '        and boxright = bx + bw

    If (b1y + b1h < b2y) Or (b1y > b2y + b2h) Or (b1x > b2x + b2w) Or (b1x + b1w < b2x) Then
        BoxCollision% = 0
    Else
        BoxCollision% = -1
    End If
End Function

' this needs max, min functions as well as BoxCollision%
Sub Intersect2Boxes (b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h, bix As Long, biy As Long, biw As Long, bih As Long)
    If b2x >= b1x And b2x <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'top left corner in 2nd box
        bix = b2x: biy = b2y
        If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x
        If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y
    ElseIf b2x >= b1x And b2x <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'bottom left corner of 2nd box in first
        bix = b2x
        If b2x + b2w <= b1x + b1w Then biw = b2w Else biw = b1x + b1w - b2x
        If b2y <= b1y Then biy = b1y: bih = b2y + b2h - b1y Else biy = b2y: bih = b2h
    ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y >= b1y And b2y <= b1y + b1h Then 'right top corner 2nd box in first
        If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x
        biy = b2y
        If b2y + b2h <= b1y + b1h Then bih = b2h Else bih = b1y + b1h - b2y
    ElseIf b2x + b2w >= b1x And b2x + b2w <= b1x + b1w And b2y + b2h >= b1y And b2y + b2h <= b1y + b1h Then 'left bottom corners in first box
        If b2x >= b1x Then bix = b2x: biw = b2w Else bix = b1x: biw = b2x + b2w - b1x
        If b2y >= b1y Then biy = b2y: bih = b2h Else biy = b1y: bih = b2y + b2h - b1y
    ElseIf BoxCollision%(b1x, b1y, b1w, b1h, b2x, b2y, b2w, b2h) Then
        bix = max(b1x, b2x): biy = max(b1y, b2y)
        biw = min(b1x + b1w, b2x + b2w) - bix: bih = min(b1y + b1h, b2y + b2h) - biy
    Else 'no intersect
        bix = -1: biy = -1: biw = 0: bih = 0
    End If
End Sub

Function max (a, b)
    If a > b Then max = a Else max = b
End Function

Function min (a, b)
    If a < b Then min = a Else min = b
End Function

' this sub needs Intersect2Boxes which uses  max, min, and BoxCollision Functions
Function PixelCollision& (img1 As boxType, img2 As boxType, intx As Long, inty As Long)
    ' boxType here needs at least an x, y, w, h and img
    Dim As Long x, y, ix, iy, iw, ih
    Dim As _Unsigned Long p1, p2
    intx = -1: inty = -1 ' no collision set
    Intersect2Boxes img1.x, img1.y, img1.w, img1.h, img2.x, img2.y, img2.w, img2.h, ix, iy, iw, ih
    If ix <> -1 Then ' the boxes intersect
        y = iy: x = ix
        Do
            _Source img1.img
            p1 = Point(x - img1.x, y - img1.y) ' point minus img x, y location = location in image I hope
            _Source img2.img
            p2 = Point(x - img2.x, y - img2.y)
            If (p1 <> 0) And (p2 <> 0) Then
                PixelCollision& = -1: intx = x: inty = y: Exit Function
            End If
            If (x + 1) > (ix + iw - 1) Then ' get rid of 2 slow For Loops
                x = ix: y = y + 1
                If y >= (iy + ih - 1) Then
                    _Source 0: Exit Function
                Else
                    y = y + 1
                End If
            Else
                x = x + 1
            End If
        Loop
    End If
End Function

Function rndCW (C As Single, range As Single) 'center +/-range weights to center
    rndCW = C + Rnd * range - Rnd * range
End Function

   

[vince]

looks like JB is 3rd after smallbasic and qb64pe but still good that's in the top 3

[bplus]

looks like JB is 3rd after smallbasic and qb64pe but still good that's in the top 3

Probably 2nd, sb editor really sucks and JB's ain't a whole lot better. 

QB64 by far and away #1!

[bplus]

Hexagonal Star Tiling

Code: (Select All)

_Title "Hexagonal Star Tiling 3" 'B+ 2019-04-19
' Trying to duplicate results shown here by Daniel Shiffman
' https://www.youtube.com/watch?v=sJ6pMLp_IaI&list=PLRqwX-V7Uu6ZiZxtDDRCi6uhfTH4FilpH&index=70
' but using a completely different method for drawing the tile
' 2019-04-17 Yes! the star tile can be generalized to any N sided regular polygon!
' 2019-04-17 This version try Hexagonal Tiling.
' 2019-04-17 Hexagonal Star Tiling 2, prep one tile and rubber stamp the grid with image.
' 2019-04-18 Go for a dynamic tile, image constantly changing

Const xmax = 1380 'bigger than your screen can hold
Const ymax = 800
Screen _NewImage(xmax, ymax, 32)
'_SCREENMOVE _MIDDLE
_FullScreen
Randomize Timer

Dim Shared tile&, polyRadius, triColor As _Unsigned Long

polyRadius = 60
gridheight = polyRadius * Sqr(3) / 2
triColor = _RGB32(0, 0, 255)
rd = 10
dm = 20
prepTile polyRadius, rd, dm
rDir = 1: dDir = 1
While _KeyDown(27) = 0
    If rDir = 1 Then
        If rd + 1 <= polyRadius * .5 Then
            rd = rd + 1: prepTile polyRadius, rd, dm
        Else

            If Rnd > .8 Then
                polyRadius = rand(20, 200)
                triColor = _RGB32(128 * Rnd + 127, 128 * Rnd + 127, 128 * Rnd + 127)
                rDir = -1: dm = Rnd * polyRadius * .5: rd = Rnd * polyRadius * .5 \ 1
                Color , _RGB32(128 * Rnd, 128 * Rnd, 128 * Rnd)
            Else
                rDir = -1
            End If
        End If
    End If
    If rDir = -1 Then
        If rd - 1 >= 0 Then
            rd = rd - 1: prepTile polyRadius, rd, dm
        Else
            If Rnd > .8 Then
                triColor = _RGB32(128 * Rnd, 128 * Rnd, 128 * Rnd)
                polyRadius = rand(20, 200)
                rDir = 1: dm = Rnd * polyRadius * .5: rd = Rnd * polyRadius * .5 \ 1
                Color , _RGB32(128 * Rnd + 127, 128 * Rnd + 127, 128 * Rnd + 127)
            Else
                rDir = 1
            End If
        End If
    End If

    Cls
    gridheight = polyRadius * Sqr(3) / 2
    xoff = 0
    For y = -polyRadius To ymax + gridheight Step gridheight
        xoff = (xoff + 1) Mod 2
        For x = -polyRadius To xmax Step 3 * polyRadius
            _PutImage (x + xoff * 1.5 * polyRadius, y), tile&, 0
        Next
    Next
    _Display
    _Limit .1 * polyRadius
Wend
End

Sub prepTile (pRadius, innerStarRadius, midPtDist)
    If tile& Then _FreeImage tile&
    tile& = _NewImage(2 * pRadius, 2 * pRadius, 32)
    _Dest tile&
    drawRegPolyStar pRadius, pRadius, pRadius, 6, innerStarRadius, midPtDist, triColor
    _Dest 0
End Sub

Sub drawRegPolyStar (cx, cy, pRadius, nSides, innerStarRadius, midPtDist, c1 As _Unsigned Long)
    Dim tilePtsX(1 To nSides), tilePtsY(1 To nSides)
    Dim innerStarX(1 To nSides), innerStarY(1 To nSides)

    pA = _Pi(2 / nSides)
    For i = 1 To nSides
        tilePtsX(i) = cx + pRadius * Cos(pA * i)
        tilePtsY(i) = cy + pRadius * Sin(pA * i)
        'on the same line the innerStar pts
        innerStarX(i) = cx + innerStarRadius * Cos(pA * i)
        innerStarY(i) = cy + innerStarRadius * Sin(pA * i)
        'CIRCLE (innerStarX(i), innerStarY(i)), 3, _RGB32(255, 255, 0)
        'draw tile
        If i > 1 Then
            Line (tilePtsX(i), tilePtsY(i))-(tilePtsX(i - 1), tilePtsY(i - 1)), _RGB32(255, 0, 0, 200)
            If i = nSides Then
                Line (tilePtsX(i), tilePtsY(i))-(tilePtsX(1), tilePtsY(1)), _RGB32(255, 0, 0, 200)
            End If
        End If
        '_DELAY .5
    Next

    'from each innerStarPt 2 lines connect to side midpoints
    'lets calc all the midpoints +/- midPtDist
    Dim mpdX(1 To 2 * nSides), mpdY(1 To 2 * nSides)
    For i = 1 To nSides
        If i - 1 = 0 Then ei = nSides Else ei = i - 1
        mx = (tilePtsX(ei) + tilePtsX(i)) / 2
        my = (tilePtsY(ei) + tilePtsY(i)) / 2
        'check
        'CIRCLE (mx, my), 2, _RGB32(0, 0, 255)
        '_DELAY .5

        'from each mx, my we need a point midPtDist along the angle from mx, my to the ei index point
        a = _Atan2(tilePtsY(ei) - my, tilePtsX(ei) - mx)
        mdx = mx + midPtDist * Cos(a)
        mdy = my + midPtDist * Sin(a)
        'the other point is 180 degrees in opposite direction
        mdx2 = mx + midPtDist * Cos(a - _Pi)
        mdy2 = my + midPtDist * Sin(a - _Pi)
        'check
        'CIRCLE (mdx, mdy), 2, _RGB32(255, 255, 0)
        'CIRCLE (mdx2, mdy2), 2, _RGB32(255, 0, 255)

        'OK store all these points for drawing lines later
        mpdX(2 * i - 1) = mdx: mpdY(2 * i - 1) = mdy
        mpdX(2 * i) = mdx2: mpdY(2 * i) = mdy2

    Next
    Color c1
    'from each point in inner star Radius draw 2 lines to the poly edges
    For i = 1 To nSides
        'now figure the pattern: sequence maps are to 2*i +2 and to 2*i - 1
        If 2 * i + 2 > 2 * nSides Then map = 2 * i + 2 - 2 * nSides Else map = 2 * i + 2
        Line (innerStarX(i), innerStarY(i))-(mpdX(map), mpdY(map))

        If 2 * i - 1 < 1 Then map2 = 2 * i - 1 + 2 * nSides Else map2 = 2 * i - 1
        Line (innerStarX(i), innerStarY(i))-(mpdX(map2), mpdY(map2))

        ftri innerStarX(i), innerStarY(i), mpdX(map), mpdY(map), mpdX(map2), mpdY(map2), c1
        '_DELAY .5
    Next

End Sub

Function rand% (lo%, hi%)
    rand% = Int(Rnd * (hi% - lo% + 1)) + lo%
End Function

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

   

[vince]

the hexagon is the most efficient shape, nice mod

[bplus]

All the bees agree.