Screen Savers

[SierraKen]

Here is my version. It only stays as a triangle but I think it's cool. 

Code: (Select All)

_Title "Floating Triangle - by Sierraken"
Screen _NewImage(800, 800, 32)
dirrr = .1
dirx = -1
diry = 1
cenx = 400
ceny = 400
length1 = Rnd * 50
length2 = Rnd * 50
length3 = Rnd * 50

Do
    _Limit 15
    If cenx > 600 Then dirx = -1 * Rnd * 3
    If cenx < 200 Then dirx = 1 * Rnd * 3
    If ceny > 600 Then diry = -1 * Rnd * 3
    If ceny < 200 Then diry = 1 * Rnd * 3
    t = t + .1
    If t = 2 Then
        dirr = Int(Rnd * 4) + 1
        If dirr = 1 Then dirx = -1 * Rnd * 3
        If dirr = 2 Then dirx = 1 * Rnd * 3
        If dirr = 3 Then diry = -1 * Rnd * 3
        If dirr = 4 Then diry = 1 * Rnd * 3
        length1 = Rnd * 50
        length2 = Rnd * 50
        length3 = Rnd * 50
    End If
    If t = 6 Then
        dirr2 = Int(Rnd * 2)
        If dirr2 = 1 Then dirrr = -.1
        If dirr2 = 2 Then dirrr = .1
        length1 = Rnd * 50
        length2 = Rnd * 50
        length3 = Rnd * 50
    End If
    cenx = cenx + dirx
    ceny = ceny + diry
    seconds = seconds + dirrr
    s = (60 - seconds) * 6 + 180
    x = Int(Sin(s / 180 * 3.141592) * 125) + cenx
    y = Int(Cos(s / 180 * 3.141592) * 125) + ceny
    m = 180 - seconds * 6
    xx = Int(Sin(m / 180 * 3.141592) * 120) + x
    yy = Int(Cos(m / 180 * 3.141592) * 120) + y
    c1 = c1 + 1
    c2 = c2 + 1
    c3 = c3 + 1
    If c1 > 255 Then
        c1 = Rnd * 255
        c2 = Rnd * 255
        c3 = Rnd * 255
    End If
    For b = -5 To 5 Step .1
        Line (x + b + length3, y + b + length3)-(xx + b + length1, yy + b + length1), _RGB32(c1, c2, c3)
    Next b
    h = 360 - seconds * 30 + 180
    xxx = Int(Sin(h / 180 * 3.141592) * 100) + xx
    yyy = Int(Cos(h / 180 * 3.141592) * 100) + yy
    For b = -5 To 5 Step .1
        Line (xx + b + length1, yy + b + length1)-(xxx + b + length2, yyy + b + length2), _RGB32(c1, c2, c3)
    Next b
    For b = -5 To 5 Step .1
        Line (xxx + b + length2, yyy + b + length2)-(x + b + length3, y + b + length3), _RGB32(c1, c2, c3)
    Next b
    If t > 12 Then
        t = 0
    End If
    _Display
    Line (0, 0)-(800, 800), _RGB32(0, 0, 0, 30), BF
Loop Until InKey$ = Chr$(27)

[bplus]

Yeah that's sort of spirit of Mystify. Thick lined triangles, not sure how I would do that with lines

[bplus]

Trivial 2D Explosions

That was Stx's tiltle from which I made a fun mod. Trivial is wrong! Fun is not Trivial it is vital.

So here is better title for my mod anyway:

Fun Fake 3D Explosions!

Code: (Select All)

_Title "trivial 2D explosions B+ mod 2" 'STxAxTIC mod B+ 2019-02-03
' 2019-02-03 use a bg& for background instead of redraws each loop, that should cool down CPU
'  rounder rocks, more fiddle with numbers

Const xmax = 1200
Const ymax = 700
Screen _NewImage(xmax, ymax, 32)
'_ScreenMove 100, 20
_FullScreen
Randomize Timer

np = 500 'number of particles
Dim x(np), y(np), xold(np), yold(np), v0x(np), v0y(np), col(np) As _Unsigned Long

nr = 3500 'number of rocks
Dim rx(nr), ry(nr), rw(nr), rh(nr), rc(nr) As _Unsigned Long
For i = 0 To nr \ 2
    rx(i) = Rnd * xmax
    ry(i) = .5 * ymax + Rnd * .25 * ymax + rx(i) * .09
    rw(i) = ry(i) * ry(i) * .00015
    rh(i) = .3 * rw(i)
    r = 200 * Rnd
    rc(i) = _RGB32(r, .45 * r, .2 * r)
Next
For i = nr \ 2 + 1 To nr
    rx(i) = Rnd * xmax
    ry(i) = .5 * ymax + Rnd * .75 * ymax + rx(i) * .09
    rw(i) = ry(i) * ry(i) * .00015
    rh(i) = .3 * rw(i)
    r = 200 * Rnd
    rc(i) = _RGB32(r, .45 * r, .2 * r)
Next

no = 80 'number of rock bounce reflectors
Dim ox(no), oy(no), ow(no), oh(no)
For i = 0 To no
    ox(i) = Rnd * xmax
    oy(i) = .5 * ymax + Rnd * .75 * ymax + ox(i) * .09
    ow(i) = oy(i) * oy(i) * .00015
    oh(i) = .3 * ow(i)
Next


Dim wallcol As _Unsigned Long
wallcol = _RGB32(200, 100, 50)
g = 95
xdamp = .07
ydamp = .07
exploderadius = 10

'draw background
bgrd& = _NewImage(xmax, ymax, 32)
_Dest bgrd&
'sky
For y = 0 To ymax
    Line (0, y)-(xmax, y), _RGB32(.1 * y, .1 * y, .15 * y), BF
Next
'rocks
For i = 0 To nr
    EllipseFill rx(i), ry(i), rw(i), rh(i), rc(i)
    'LINE (rx(i), ry(i))-STEP(rw(i), rh(i)), rc(i), BF
Next i

'Draw obstacles randomly
For i = o To no
    EllipseFill ox(i), oy(i), ow(i), oh(i), wallcol
    'LINE (ox(i), oy(i))-STEP(ow(i), oh(i)), wallcol, BF
Next i

_Dest 0

start:
iterations = 0
'Toggle for random starting position.
xshift = Rnd * xmax
yshift = Rnd * ymax * .6


For i = 1 To np
    speed = Rnd * 150 + 1
    ang1 = Rnd * 2 * 3.141592653589793#
    ang2 = Rnd * 2 * 3.141592653589793#
    x(i) = xshift + Rnd * exploderadius * Cos(ang1)
    y(i) = yshift + Rnd * exploderadius * Sin(ang1)
    v0x(i) = speed * Cos(ang2)
    v0y(i) = speed * Sin(ang2)
    dotcol:
    col(i) = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
    If col(i) = bgcol Or col(i) = wallcol Then GoTo dotcol
    If Point(x(i), y(i)) = wallcol Or x(i) < 0 Or x(i) > xmax Or y(i) < 0 Or y(i) > ymax Then i = i - 1
    dv = Sqr((v0x(i)) ^ 2 + (v0y(i)) ^ 2)
    If dv > vmax Then vmax = dv
Next
dt = .995 / vmax

Do
    _PutImage , bgrd&, 0
    iterations = iterations + 1
    smax = 0
    For i = 1 To np
        xold(i) = x(i)
        yold(i) = y(i)
        v0x(i) = v0x(i) + .1 * dt
        v0y(i) = v0y(i) + g * dt + .2 'more gravity
        xtmp = x(i) + v0x(i) * dt
        ytmp = y(i) + v0y(i) * dt
        If Point(xtmp, yold(i)) = wallcol Then v0x(i) = v0x(i) * -1 * xdamp
        If Point(xold(i), ytmp) = wallcol Then v0y(i) = v0y(i) * -1 * ydamp
        x(i) = x(i) + v0x(i) * dt
        y(i) = y(i) + v0y(i) * dt
        EllipseFill x(i), y(i), 3, 3, col(i)
        ds = Sqr((y(i) - yold(i)) ^ 2 + (x(i) - xold(i)) ^ 2)
        If ds > smax Then smax = ds
    Next
    If smax > .95 Then dt = dt * (1 - .01)
    If smax < .9 Then dt = dt * (1 + .01)
    _Display
    _Limit 200
    If iterations > 1500 Then GoTo start
Loop Until InKey$ <> ""

' with Steve's EllipseFill, who needs CircleFill?
Sub EllipseFill (cx As Integer, cy As Integer, rx As Integer, ry As Integer, c As _Unsigned Long)
    Dim a As Long, b As Long
    Dim x As Long, y As Long
    Dim xx As Long, yy As Long
    Dim sx As Long, sy As Long
    Dim e As Long

    a = 2 * rx * rx
    b = 2 * ry * ry
    x = rx
    xx = ry * ry * (1 - rx - rx)
    yy = rx * rx
    sx = b * rx

    Do While sx >= sy
        Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
        If y <> 0 Then Line (cx - x, cy + y)-(cx + x, cy + y), c, BF

        y = y + 1
        sy = sy + a
        e = e + yy
        yy = yy + a

        If (e + e + xx) > 0 Then
            x = x - 1
            sx = sx - b
            e = e + xx
            xx = xx + b
        End If
    Loop

    x = 0
    y = ry
    xx = rx * ry
    yy = rx * rx * (1 - ry - ry)
    e = 0
    sx = 0
    sy = a * ry

    Do While sx <= sy
        Line (cx - x, cy - y)-(cx + x, cy - y), c, BF
        Line (cx - x, cy + y)-(cx + x, cy + y), c, BF

        Do
            x = x + 1
            sx = sx + b
            e = e + xx
            xx = xx + b
        Loop Until (e + e + yy) > 0

        y = y - 1
        sy = sy - a
        e = e + yy
        yy = yy + a

    Loop

End Sub

STx's code is almost interesting too:

Code: (Select All)

'#lang "qb"              ' freebasic edit 2011-06
delayconst = 900000 ' freebasic edit 2011-06
'CLEAR                  ' freebasic edit 2011-06

CLS
SCREEN 12
RANDOMIZE TIMER

LOCATE 1, 2: INPUT "Enter number of particles (default is 80): ", num
IF num = 0 THEN num = 80
DIM x(num), y(num), xold(num), yold(num), v0x(num), v0y(num), col(num)

start:
CLS
iterations = 0
'g = RND * 10 + 20
g = RND * 15 + 25
xdamp = RND * .15 + .55
ydamp = RND * .15 + .55
exploderadius = 200 '75
numobstacles = 0
iterationmax = 1200

choosecol:
bgcol = INT(RND * 14)
wallcol = 0 'INT(RND * 14)'change to zero for spider mode
IF bgcol = wallcol THEN GOTO choosecol

LINE (1, 1)-(639, 479), bgcol, BF
LINE (1, 1)-(639, 479), wallcol, B

'Draw obstacles randomly.
FOR i = 1 TO numobstacles
    LINE (RND * 640, RND * 480)-(RND * 640, RND * 480), wallcol, B
NEXT i

'Make predetermined obstacles.
'LINE (50, 75)-(600, 125), wallcol, B

'Toggle for random starting position.
xshift = RND * 640
yshift = RND * 480
'Toggle for fixed starting position
'xshift = 100
'yshift = 100

FOR i = 1 TO num
    speed = RND * 90
    ang1 = RND * 2 * 3.141592653589793#
    ang2 = RND * 2 * 3.141592653589793#
    x(i) = xshift + RND * exploderadius * COS(ang1)
    y(i) = yshift + RND * exploderadius * SIN(ang1)
    v0x(i) = 1.5 * speed * COS(ang2)
    v0y(i) = speed * SIN(ang2)
    dotcol:
    col(i) = INT(RND * 13 + 1)
    IF col(i) = bgcol OR col(i) = wallcol THEN GOTO dotcol
    IF POINT(x(i), y(i)) = wallcol OR x(i) < 1 OR x(i) > 639 OR y(i) < 1 OR y(i) > 479 THEN i = i - 1
    dv = SQR((v0x(i)) ^ 2 + (v0y(i)) ^ 2)
    IF dv > vmax THEN vmax = dv
    PSET (x(i), y(i)), col(i)
NEXT

dt = .995 / vmax
'PRINT dt

SLEEP 1

DO
    idel = 0: DO: idel = idel + 1: LOOP UNTIL idel > delayconst ' freebasic edit 2011-06

    iterations = iterations + 1
    smax = 0
    FOR i = 1 TO num
        xold(i) = x(i)
        yold(i) = y(i)
        v0x(i) = v0x(i) + 0 * dt
        v0y(i) = v0y(i) + g * dt
        xtmp = x(i) + v0x(i) * dt
        ytmp = y(i) + v0y(i) * dt
        IF POINT(xtmp, yold(i)) = wallcol THEN v0x(i) = v0x(i) * -1 * xdamp
        IF POINT(xold(i), ytmp) = wallcol THEN v0y(i) = v0y(i) * -1 * ydamp
        x(i) = x(i) + v0x(i) * dt
        y(i) = y(i) + v0y(i) * dt
        'Recolor stagnant particles.
        xx = x(i) - xold(i)
        yy = y(i) - yold(i)
        IF SQR(xx ^ 2 + yy ^ 2) < .05 THEN col(i) = bgcol
        PSET (xold(i), yold(i)), 0 'bgcol
        PSET (x(i), y(i)), col(i)
        ds = SQR((y(i) - yold(i)) ^ 2 + (x(i) - xold(i)) ^ 2)
        IF ds > smax THEN smax = ds
    NEXT
    IF smax > .95 THEN dt = dt * (1 - .01)
    IF smax < .9 THEN dt = dt * (1 + .01)
    IF iterations > iterationmax THEN
        SLEEP 2
        GOTO start
    END IF
    LINE (19, 459)-(151, 471), wallcol, B
    LINE (20, 460)-(20 + 130 * (iterations / iterationmax), 470), 15, BF
LOOP UNTIL INKEY$ <> ""
END

How the heck did I get from his post to mine? They look so different!

[SierraKen]

Way cool B+ and Stx! Stx did the framework and you finished the job.

[vince]

great mod, B+! thanks to Steve's ellipsefill you made something almost interesting interesting

[bplus]

So "almost" a thumbs up then, OK LOL!

[bplus]

Celebrate The Fourth With Some Fake Fireworks 

Code: (Select All)

DefInt A-Z
_Title "ASCII Fireworks  Move Mousewheel to Expand or Contract #2" '2020-01-01
' 2020-01-02 update with graivity effect by tsh73 from JB forum
' 2020-08-11 modified for xpanding and contracting screen size
' 2020-08-11 Steve catches memory leak, fixed!
' 2020-08-12 manstersoft gives me idea for Font 8, added more works and switched color to more! RGB32
' 2022-07-04 mods for The Forth
Const nR = 9, t = "     Celebrating July 4th, 2022 at QB64 PE Forum, ASCII Fireworks Brought To You By Bplus Inspired by Pete, TempodiBasic and Code Hunter Recent Efforts, Gravity Effect by tsh73 at JB Forum, Thanks Steve for saving memory and manstersoft for Font 8 idea, Let Freedom Ring!....."
Type rocket
    x As Single
    y As Single
    bang As Integer
    age As Integer
    c As _Unsigned Long
End Type

Dim Shared r(1 To nR) As rocket
For i = 1 To nR
    new i
Next
Dim Shared fire&
fire& = _NewImage(640, 400, 32)
_ScreenMove 0, 0
Dim tmp&(0 To 10)
lastt = 20
sc& = _NewImage(640, 350, 32)
_Font 8
Do
    _Dest fire&
    _Font 16
    Cls
    Color &HFFFF88AA
    lc = lc + 1
    If lc Mod 3 = 0 Then p = (p + 1) Mod Len(t)
    Locate 2, 20: Print Mid$(t, p + 1, 40);
    _Font 8
    rocs = rocs + 1
    If rocs > nR Then rocs = nR
    For i = 1 To rocs
        drawRocket i
    Next


    _Dest 0
    While _MouseInput
        scroll = scroll + _MouseWheel
    Wend
    If scroll < 800 And scroll > -400 And .56 * scroll < _DesktopHeight Then
        tp = (tp + 1) Mod 10
        tmp&(tp) = _NewImage(640 + scroll, 358 + .56 * scroll, 32)
        Screen tmp&(tp)
        _PutImage , fire&, 0
    Else
        lastt = 20
    End If

    'debug
    'COLOR qb(15)
    'LOCATE 1, 1: PRINT lastt, tp, scroll

    If lastt <> 20 Then _FreeImage tmp&(lastt)
    lastt = tp

    _Display
    _Limit 20
Loop Until _KeyDown(27)

Sub new (i)
    r(i).x = Rnd * 60 + 10
    r(i).y = 50
    r(i).bang = Rnd * 30
    r(i).age = 0
    r(i).c = _RGB32(200 * Rnd + 55, 200 * Rnd + 55, 200 * Rnd + 55)
End Sub

Sub drawRocket (i)
    If r(i).y > r(i).bang Then
        Color r(i).c
        Locate r(i).y, r(i).x: Print Chr$(24);
        r(i).y = r(i).y - 1
    Else
        r(i).age = r(i).age + 1
        If r(i).age > 50 Then
            new i
        Else
            Color r(i).c
            If r(i).age > 4 Then start = r(i).age - 4 Else start = 1
            For a = start To r(i).age
                For j = 1 To 12
                    xx = r(i).x + 1 * a * Cos(j * _Pi / 6)
                    yy = r(i).y + .5 * a * Sin(j * _Pi / 6)
                    yy = yy + (r(i).y - a) ^ 2 / 15 '<<<< tsh73 gravity
                    If xx > 0 And xx < 81 And yy > 0 And yy < 51 Then
                        Locate Int(yy), Int(xx)
                        Print "*";
                    End If
                Next
            Next
        End If
    End If
End Sub

   

[Kernelpanic]

Nice @bplus, but what is a screensaver without the right background music? 

Note the women how they wielding the swords. . . from 01:27 (Corrected!)

Kazachka

[bplus]

Yeah, they swing a mean sword or 2 that's for sure but can they code in QB64? ;-))

[Kernelpanic]

Yeah, they swing a mean sword or 2 that's for sure but can they code in QB64?  ;-))

I don't know,   (Corrected: 01:27) but this scene should one be incorporated into a screensaver. So incorporate the scene as a video. Is that possible with QB64?

I once had a program with which one could isolate video sequences. . . Let's see.

PS: In "Fireworks" that would fit well. The video should appear and disappear erratically.