Sunburst
#1
Code:
'Sunburst.bas for QB64 fork (B+=MGA) 2017-08-31

RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600
COMMON SHARED cN, pR, pG
SCREEN _NEWIMAGE(xmax, ymax, 32)
_TITLE "Sunburst by bplus"

'set working variables
midx = xmax / 2 - 100
cN = 1
horizon = ymax - 225
maxd = ((xmax - midx) ^ 2 + horizon ^ 2) ^ .5

WHILE 1
   land& = _NEWIMAGE(xmax, ymax, 32)
   _DEST land&
   drawLandscape
   _DEST 0

   WHILE 1
       CLS
       IF _KEYHIT = 32 THEN EXIT WHILE
       resetPlasma
       _PUTIMAGE , land&, 0
       FOR a = 0 TO _PI(2) STEP _PI(1 / 36)
           IF a = 0 THEN
               lastx = midx + maxd * COS(a)
               lasty = horizon + maxd * SIN(a)
           ELSE
               x1 = midx + maxd * COS(a)
               y1 = horizon + maxd * SIN(a)
               changePlasma
               filltri midx, horizon, lastx, lasty, x1, y1
               lastx = x1: lasty = y1
           END IF
       NEXT
       FOR r = 25 TO 0 STEP -1
           COLOR _RGBA(255, 255, 205, (25 - r) ^ 2 / 2.5)
           fillcirc midx, horizon, r
       NEXT
       _DISPLAY
       _LIMIT 5
   WEND
WEND

SUB changePlasma ()
   cN = cN + 1
   COLOR _RGBA(200 + 56 * SIN(pR * cN), 200 + 56 * SIN(pG * cN), 128, RND * 32)
END SUB

SUB resetPlasma ()
   pR = RND ^ 2: pG = RND ^ 2
END SUB

SUB midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
   COLOR _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
END SUB

FUNCTION rand% (lo%, hi%)
   rand% = (RND * (hi% - lo% + 1)) \ 1 + lo%
END FUNCTION

FUNCTION rdir% ()
   IF RND < .5 THEN rdir% = -1 ELSE rdir% = 1
END FUNCTION

FUNCTION dist# (x1%, y1%, x2%, y2%)
   dist# = ((x1% - x2%) ^ 2 + (y1% - y2%) ^ 2) ^ .5
END FUNCTION

FUNCTION rclr&& ()
   rclr&& = _RGB(rand(64, 255), rand(64, 255), rand(64, 255))
END FUNCTION

'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fillcirc (CX AS LONG, CY AS LONG, R AS LONG)
   DIM subRadius AS LONG, RadiusError AS LONG
   DIM X AS LONG, Y AS LONG

   subRadius = ABS(R)
   RadiusError = -subRadius
   X = subRadius
   Y = 0

   IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

   ' Draw the middle span here so we don't draw it twice in the main loop,
   ' which would be a problem with blending turned on.
   LINE (CX - X, CY)-(CX + X, CY), , 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), , BF
               LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
           END IF
           X = X - 1
           RadiusError = RadiusError - X * 2
       END IF
       Y = Y + 1
       LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
       LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
   WEND
END SUB

'Andy Amaya's triangle fill modified for QB64
SUB filltri (xx1, yy1, xx2, yy2, xx3, yy3)
   'make copies before swapping
   x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3

   '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) / length
       FOR x = 0 TO length
           LINE (INT(x + x1), INT(x * slope1 + y1))-(INT(x + x1), INT(x * slope2 + y1))
           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) / length
       FOR x = 0 TO length
           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

SUB drawLandscape
   'the sky
   FOR i = 0 TO ymax
       midInk 50, 25, 128, 100, 200, 255, i / ymax
       LINE (0, i)-(xmax, i)
   NEXT
   'the land
   startH = ymax - 200
   rr = 70: gg = 70: bb = 90
   FOR mountain = 1 TO 6
       Xright = 0
       y = startH
       WHILE Xright < xmax
           ' upDown = local up / down over range, change along Y
           ' range = how far up / down, along X
           upDown = (RND * .8 - .35) * (mountain * .5)
           range = Xright + rand%(15, 25) * 2.5 / mountain
           lastx = Xright - 1
           FOR X = Xright TO range
               y = y + upDown
               COLOR _RGB(rr, gg, bb)
               LINE (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
               lastx = X
           NEXT
           Xright = range
       WEND
       rr = rand%(rr - 15, rr): gg = rand%(gg - 15, gg): bb = rand%(bb - 25, bb)
       IF rr < 0 THEN rr = 0
       IF gg < 0 THEN gg = 0
       IF bb < 0 THEN bb = 0
       startH = startH + rand%(5, 20)
   NEXT
END SUB


Attached Files Thumbnail(s)

B += x
Reply
#2
Sunburst? I think maybe either Pulsar or Supernova... Quite impressive!

J
May your journey be free of incident.

Live long and prosper.
Reply
#3
Thanks Johnno, this is first real use of _RGBA. I like having another dimension for coloring.

Hotter sun, maybe going nova? OK

Code:
'Sunburst 2.bas for QB64 fork (B+=MGA) 2017-08-31
'maybe too much sun

RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600
COMMON SHARED cN, pR, pG
SCREEN _NEWIMAGE(xmax, ymax, 32)
_TITLE "Sunburst 2 by bplus"

'set working variables
midx = xmax / 2 - 100
cN = 1
horizon = ymax - 425
maxd = ((xmax - midx) ^ 2 + (ymax - horizon) ^ 2) ^ .5

WHILE 1
   land& = _NEWIMAGE(xmax, ymax, 32)
   _DEST land&
   drawLandscape
   _DEST 0

   WHILE 1
       CLS
       IF _KEYHIT = 32 THEN EXIT WHILE
       resetPlasma
       _PUTIMAGE , land&, 0
       FOR a = 0 TO _PI(2) STEP _PI(1 / 36)
           IF a = 0 THEN
               lastx = midx + maxd * COS(a)
               lasty = horizon + maxd * SIN(a)
           ELSE
               x1 = midx + maxd * COS(a)
               y1 = horizon + maxd * SIN(a)
               changePlasma
               filltri midx, horizon, lastx, lasty, x1, y1
               lastx = x1: lasty = y1
           END IF
       NEXT
       FOR i = 1 TO 500
           ra = RND * _PI(2): rd = RND * 150
           changePlasma
           filltri midx + 5, horizon, midx - 5, horizon, midx + rd * COS(ra), horizon + rd * SIN(ra)
           filltri midx, horizon + 5, midx, horizon - 5, midx + rd * COS(ra), horizon + rd * SIN(ra)
       NEXT
       FOR r = 25 TO 0 STEP -1
           COLOR _RGBA(255, 255, 205, (25 - r) ^ 2 / 2.5)
           fillcirc midx, horizon, r
       NEXT
       _DISPLAY
       _DELAY 1.5
   WEND
WEND

SUB changePlasma ()
   cN = cN + 1
   COLOR _RGBA(200 + 56 * SIN(pR * cN), 200 + 56 * SIN(pG * cN), 128, RND * 32)
END SUB

SUB resetPlasma ()
   pR = RND ^ 2: pG = RND ^ 2
END SUB

SUB midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
   COLOR _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
END SUB

FUNCTION rand% (lo%, hi%)
   rand% = (RND * (hi% - lo% + 1)) \ 1 + lo%
END FUNCTION

'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fillcirc (CX AS LONG, CY AS LONG, R AS LONG)
   DIM subRadius AS LONG, RadiusError AS LONG
   DIM X AS LONG, Y AS LONG

   subRadius = ABS(R)
   RadiusError = -subRadius
   X = subRadius
   Y = 0

   IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

   ' Draw the middle span here so we don't draw it twice in the main loop,
   ' which would be a problem with blending turned on.
   LINE (CX - X, CY)-(CX + X, CY), , 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), , BF
               LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
           END IF
           X = X - 1
           RadiusError = RadiusError - X * 2
       END IF
       Y = Y + 1
       LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
       LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
   WEND
END SUB

'Andy Amaya's triangle fill modified for QB64
SUB filltri (xx1, yy1, xx2, yy2, xx3, yy3)
   'make copies before swapping
   x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3

   '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) / length
       FOR x = 0 TO length
           LINE (INT(x + x1), INT(x * slope1 + y1))-(INT(x + x1), INT(x * slope2 + y1))
           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) / length
       FOR x = 0 TO length
           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

SUB drawLandscape
   'the sky
   FOR i = 0 TO ymax
       midInk 50, 25, 128, 100, 200, 255, i / ymax
       LINE (0, i)-(xmax, i)
   NEXT
   'the land
   startH = ymax - 200
   rr = 70: gg = 70: bb = 90
   FOR mountain = 1 TO 6
       Xright = 0
       y = startH
       WHILE Xright < xmax
           ' upDown = local up / down over range, change along Y
           ' range = how far up / down, along X
           upDown = (RND * .8 - .35) * (mountain * .5)
           range = Xright + rand%(15, 25) * 2.5 / mountain
           lastx = Xright - 1
           FOR X = Xright TO range
               y = y + upDown
               COLOR _RGB(rr, gg, bb)
               LINE (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
               lastx = X
           NEXT
           Xright = range
       WEND
       rr = rand%(rr - 15, rr): gg = rand%(gg - 15, gg): bb = rand%(bb - 25, bb)
       IF rr < 0 THEN rr = 0
       IF gg < 0 THEN gg = 0
       IF bb < 0 THEN bb = 0
       startH = startH + rand%(5, 20)
   NEXT
END SUB


Attached Files Thumbnail(s)

B += x
Reply
#4
Just as impressive! Very cool landscape generator. Reminds me of Perlin noise... this qb64 is fast... didn't even see the landscape 'draw'... nicely done.

J
May your journey be free of incident.

Live long and prosper.
Reply
#5
You can use spacebar to change landscape. In the first Sunburst, you can sometimes get the sun just peeking over a mountain ledge, so the rays make more sense. Sometimes you can get the sun coming from inside a mountain, which makes no sense. What luck...
B += x
Reply
#6
Modern Sun Dial (now with spiral rays and 2 views switch):
Code:
'Sunburst 3.bas for QB64 fork (B+=MGA) 2017-09-01
'spiral rays anyone?  throw in the kitchen clock too...

RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600
COMMON SHARED cN, pR, pG
SCREEN _NEWIMAGE(xmax, ymax, 32)
_TITLE "Modern Sun Dial by bplus, press spacebar for new view"

'set working variables
midx = xmax / 2
cN = 1
horizon = ymax / 2
maxd = ((xmax - midx) ^ 2 + (ymax - horizon) ^ 2) ^ .5
switch = -1
WHILE 1
    land& = _NEWIMAGE(xmax, ymax, 32)
    _DEST land&
    drawLandscape
    _DEST 0
    switch = NOT switch
    WHILE 1
        CLS
        IF _KEYHIT = 32 THEN EXIT WHILE
        resetPlasma
        _PUTIMAGE , land&, 0
        IF switch THEN
            FOR a = 0 TO _PI(2) STEP _PI(1 / 36)
                IF a = 0 THEN
                    lastx = midx + maxd * COS(a)
                    lasty = horizon + maxd * SIN(a)
                ELSE
                    x1 = midx + maxd * COS(a)
                    y1 = horizon + maxd * SIN(a)
                    changePlasma
                    filltri midx, horizon, lastx, lasty, x1, y1
                    lastx = x1: lasty = y1
                END IF
            NEXT
        END IF
        radius = 0: angle = sangle
        WHILE radius < 400
            x = COS(angle) * radius
            y = SIN(angle) * radius
            r2 = (x ^ 2 + y ^ 2) ^ .5
            size = 4 * r2 ^ .25
            angle = angle - .4
            radius = radius + 2
            COLOR _RGBA(200 + RND * 55, 255, 0, 30)
            sx = midx + 5 * COS(angle + _PI(1 / 2))
            sy = horizon + 5 * SIN(angle + _PI(1 / 2))
            sx1 = midx + 5 * COS(angle - _PI(1 / 2))
            sy1 = horizon + 5 * SIN(angle - _PI(1 / 2))
            filltri sx, sy, sx1, sy1, midx + x, horizon + y
        WEND
        sangle = sangle + _PI(1 / 18)
        IF switch THEN
            FOR r = 25 TO 0 STEP -1
                COLOR _RGBA(255, 255, 205, (25 - r) ^ 2 / 2.45)
                fillcirc midx, horizon, r
            NEXT
        END IF

        now$ = TIME$
        min = VAL(MID$(now$, 4, 2)) / 60
        h = VAL(MID$(now$, 1, 2)) + min
        IF h > 12 THEN h = h - 12
        hourA = h * _PI(1 / 6) - _PI(1 / 2)
        minA = min * _PI(2) - _PI(1 / 2)

        COLOR _RGBA(255, 255, 255, 48)
        sx = midx + 5 * COS(hourA + _PI(1 / 2))
        sy = horizon + 5 * SIN(hourA + _PI(1 / 2))
        sx1 = midx + 5 * COS(hourA - _PI(1 / 2))
        sy1 = horizon + 5 * SIN(hourA - _PI(1 / 2))
        filltri sx, sy, sx1, sy1, midx + 150 * COS(hourA), horizon + 150 * SIN(hourA)


        sx = midx + 5 * COS(minA + _PI(1 / 2))
        sy = horizon + 5 * SIN(minA + _PI(1 / 2))
        sx1 = midx + 5 * COS(minA - _PI(1 / 2))
        sy1 = horizon + 5 * SIN(minA - _PI(1 / 2))
        filltri sx, sy, sx1, sy1, midx + 250 * COS(minA), horizon + 250 * SIN(minA)

        _DISPLAY
        _LIMIT 1
    WEND
WEND

SUB changePlasma ()
    cN = cN + 1
    COLOR _RGBA(200 + 56 * SIN(pR * cN), 200 + 56 * SIN(pG * cN), 128, RND * 32)
END SUB

SUB resetPlasma ()
    pR = RND ^ 2: pG = RND ^ 2
END SUB

SUB midInk (r1%, g1%, b1%, r2%, g2%, b2%, fr##)
    COLOR _RGB(r1% + (r2% - r1%) * fr##, g1% + (g2% - g1%) * fr##, b1% + (b2% - b1%) * fr##)
END SUB

FUNCTION rand% (lo%, hi%)
    rand% = (RND * (hi% - lo% + 1)) \ 1 + lo%
END FUNCTION

'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fillcirc (CX AS LONG, CY AS LONG, R AS LONG)
    DIM subRadius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG

    subRadius = ABS(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    LINE (CX - X, CY)-(CX + X, CY), , 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), , BF
                LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            END IF
            X = X - 1
            RadiusError = RadiusError - X * 2
        END IF
        Y = Y + 1
        LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    WEND
END SUB

'Andy Amaya's triangle fill modified for QB64
SUB filltri (xx1, yy1, xx2, yy2, xx3, yy3)
    'make copies before swapping
    x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2: x3 = xx3: y3 = yy3

    '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) / length
        FOR x = 0 TO length
            LINE (INT(x + x1), INT(x * slope1 + y1))-(INT(x + x1), INT(x * slope2 + y1))
            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) / length
        FOR x = 0 TO length
            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

SUB drawLandscape
    'the sky
    FOR i = 0 TO ymax
        midInk 50, 25, 128, 100, 200, 255, i / ymax
        LINE (0, i)-(xmax, i)
    NEXT
    'the land
    startH = ymax - 200
    rr = 70: gg = 70: bb = 90
    FOR mountain = 1 TO 6
        Xright = 0
        y = startH
        WHILE Xright < xmax
            ' upDown = local up / down over range, change along Y
            ' range = how far up / down, along X
            upDown = (RND * .8 - .35) * (mountain * .5)
            range = Xright + rand%(15, 25) * 2.5 / mountain
            lastx = Xright - 1
            FOR X = Xright TO range
                y = y + upDown
                COLOR _RGB(rr, gg, bb)
                LINE (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
                lastx = X
            NEXT
            Xright = range
        WEND
        rr = rand%(rr - 15, rr): gg = rand%(gg - 15, gg): bb = rand%(bb - 25, bb)
        IF rr < 0 THEN rr = 0
        IF gg < 0 THEN gg = 0
        IF bb < 0 THEN bb = 0
        startH = startH + rand%(5, 20)
    NEXT
END SUB
B += x
Reply
#7
@bplus

I thought I made this post yesterday, but I guess I closed the browser before I sent it.

Anyway, this demo is the types of demos I really love, the abstract art created procedurally.

Thank you for sharing.


Walter Whitman
The Joyful Programmer
Dedicated to empowering computer programming hobbyists, tinkerers, amateurs, and enthusiasts.
profile for Walter Whitman at Stack Overflow, Q&A for professional and enthusiast programmers


Reply
#8
This is really AWESOME!!!! Big Grin
Reply
#9
Thanks guys!

Yes Walter, to me this stuff is great kind of art and I love to see the dynamics of movement or change. It is more alive or life like than a still shot.
B += x
Reply
#10
Pete gave me an idea from QB64.net today.


Attached Files Thumbnail(s)

.zip   Special Delivary for Pete.zip (Size: 1.28 MB / Downloads: 6)
B += x
Reply
#11
@bplus

Now that is a cool idea! That got my creative juices flowing.


Walter Whitman
The Joyful Programmer
Dedicated to empowering computer programming hobbyists, tinkerers, amateurs, and enthusiasts.
profile for Walter Whitman at Stack Overflow, Q&A for professional and enthusiast programmers


Reply