Author Topic: Happy New Year 2018  (Read 1272 times)

B+

  • Guest
Happy New Year 2018
« on: December 30, 2017, 05:53:16 PM »
From a little challenge at the QB64.net forum:
Code: [Select]
_TITLE "Happy Trails 2018"
' 2017-12-29 another redesign of fireworks
' 2017-12-28 redesign fireworks
' now with lake refelction 2017-12-27 forget the bouncing sparks
' combine Welcome Plasma Font with landscape
'_title "Fireworks 3 translation to QB64 2017-12-26 bplus"
'fireworks 3.bas SmallBASIC 0.12.2 [B+=MGA] 2015-05-09
'fireworks 2.bas 2016-05-05 now with Gravity, Newtonian bounce, smoke debris
'fireworks 3.bas try with map variables make bursts around a central point


RANDOMIZE TIMER
CONST xmax = 1200
CONST ymax = 720
CONST waterline = 600 ' 600 = ratio 5 to 1 sky to water
'                       raise and lower waterline as desired  highest about 400?
CONST lTail = 15
CONST bluey = 5 * 256 ^ 2 + 256 * 5 + 5
CONST debrisMax = 28000

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 120, 20

TYPE fireWorkType
    x AS INTEGER
    y AS INTEGER
    seed AS INTEGER
    age AS INTEGER
    life AS INTEGER
END TYPE


TYPE debrisType
    x AS SINGLE
    y AS SINGLE
    c AS LONG
END TYPE

COMMON SHARED fw() AS fireWorkType
COMMON SHARED debris() AS debrisType
COMMON SHARED cN, pR!, pG!, pB!

SCREEN _NEWIMAGE(xmax, ymax, 32)

'prepare message font
mess$ = " Happy New Year 2018"
PRINT mess$
w = 8 * LEN(mess$): h = 16
DIM p(w, h)
black&& = POINT(0, 10)
FOR y = 0 TO h
    FOR x = 0 TO w
        IF POINT(x, y) <> black&& THEN
            p(x, y) = 1
        END IF
    NEXT
NEXT
xo = 0: yo = 15: m = 7.2
resetPlasma

'prepare landscape
CLS
land& = _NEWIMAGE(xmax, ymax, 32)
_DEST land&
drawLandscape
_DEST 0

'prepare fire works
nFW = 3
DIM fw(1 TO 10) AS fireWorkType
FOR i = 1 TO nFW
    initFireWork (i)
NEXT

'debris feild
DIM debris(debrisMax) AS debrisType

'OK start the show
WHILE 1
    'cls screen with land image
    _PUTIMAGE , land&, 0

    'draw fireworks
    FOR f = 1 TO nFW
        IF fw(f).age <= fw(f).life THEN drawfw (f) ELSE initFireWork f
    NEXT

    'debris
    FOR i = 0 TO debrisStack
        PSET (debris(i).x, debris(i).y), debris(i).c
        debris(i).x = debris(i).x + RND * 3 - 1.5
        debris(i).y = debris(i).y + RND * 3.5 - 1.5
        IF debris(i).x < 0 OR debris(i).y < 0 OR debris(i).x > xmax OR debris(i).y > waterline + RND * 20 THEN NewDebris (i)
    NEXT

    'text message in plasma
    FOR y = 0 TO h - 1
        FOR x = 0 TO w - 1
            IF p(x, y) THEN
                changePlasma
            ELSE
                COLOR 0
            END IF
            LINE (xo + x * m, yo + y * m)-(xo + x * m + m, yo + y * m + m), , BF
        NEXT
    NEXT
    lc = lc + 1
    IF lc MOD 200 = 0 THEN resetPlasma

    'reflect sky
    skyWaterRatio = waterline / (ymax - waterline) - .05
    FOR y = waterline TO ymax
        FOR x = 0 TO xmax
            c&& = POINT(x, waterline - ((y - waterline - 1) * skyWaterRatio) + RND * 5)
            PSET (x, y + 1), c&& + bluey
        NEXT
    NEXT

    _DISPLAY
    _LIMIT 50 'no limit needed on my system!

    'accumulate debris
    IF lc MOD 2000 THEN
        IF debrisStack < debrisMax THEN
            FOR i = 1 TO 2
                NewDebris i + debrisStack
            NEXT
            debrisStack = debrisStack + 2
        END IF
    END IF
WEND

SUB NewDebris (i)
    debris(i).x = RND * xmax
    debris(i).y = RND * ymax
    c = RND * 155
    debris(i).c = _RGB32(c, c, c)
END SUB

SUB changePlasma ()
    cN = cN + .01
    COLOR _RGB(127 + 127 * SIN(pR! * .3 * cN), 127 + 127 * SIN(pG! * .3 * cN), 127 + 127 * SIN(pB! * .3 * cN))
END SUB

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

SUB drawLandscape
    'the sky
    FOR i = 0 TO ymax
        midInk 0, 0, 0, 78, 28, 68, i / ymax
        LINE (0, i)-(xmax, i)
    NEXT
    'the land
    startH = waterline - 80
    rr = 10: gg = 20: bb = 15
    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) * (1 / (1 * mountain))
            range = Xright + rand&&(5, 35) * 2.5 / mountain
            lastx = Xright - 1
            FOR X = Xright TO range
                y = y + upDown
                COLOR _RGB32(rr, gg, bb)
                LINE (lastx, y)-(X, ymax), , BF 'just lines weren't filling right
                lastx = X
            NEXT
            Xright = range
        WEND
        rr = rand&&(rr + 5, rr): gg = rand&&(gg + 5, gg): bb = rand&&(bb + 4, bb)
        IF rr < 0 THEN rr = 0
        IF gg < 0 THEN gg = 0
        IF bb < 0 THEN bb = 0
        startH = startH + rand&&(1, 10)
    NEXT
    'LINE (0, waterline)-(xmax, ymax), _RGB32(0, 0, 0), BF
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&& = INT(RND * (hi&& - lo&& + 1)) + lo&&
END FUNCTION

SUB drawfw (i)
    'here's how to "save" a bunch of random numbers without data and arrays but tons of redundant calculations
    RANDOMIZE USING fw(i).seed 'this repeats all random numbers generated by seed in same sequence
    'recreate our firework from scratch!
    red = rand&&(200, 255)
    green = rand&&(200, 255)
    blue = rand&&(200, 255)
    x = rand&&(1, 4)
    IF x = 1 THEN
        red = 0
    ELSEIF x = 2 THEN
        green = 0
    ELSEIF x = 3 THEN
        blue = 0
    ELSE
        x = rand&&(1, 4)
        IF x = 1 THEN
            red = 0: green = 0
        ELSEIF x = 2 THEN
            green = 0: blue = 0
        ELSEIF x = 3 THEN
            blue = 0: red = 0
        END IF
    END IF
    ne = rand&&(80, 300)
    DIM embers(ne, 1)
    FOR e = 0 TO ne
        r = RND * 3
        embers(e, 0) = r * COS(e * _PI(2) / 101)
        embers(e, 1) = r * SIN(e * _PI(2) / 101)
    NEXT
    start = fw(i).age - lTail ' don't let tails get longer than lTail const
    IF start < 1 THEN start = 1
    FOR e = 0 TO ne
        cx = fw(i).x: cy = fw(i).y: dx = embers(e, 0): dy = embers(e, 1)
        FOR t = 1 TO fw(i).age
            cx = cx + dx
            cy = cy + dy
            IF t >= start THEN
                'too much like a flower?
                midInk 60, 60, 60, red, green, blue, (t - start) / lTail
                'midInk 60, 60, 60, 128, 160, 150, (t - start) / lTail
                fcirc cx, cy, (t - start) / lTail
            END IF

            dx = dx * .99 'air resitance
            dy = dy + .01 'gravity
        NEXT
        COLOR _RGB32(255, 255, 255)
        'COLOR _RGB32(red, green, blue)
        cx = cx + dx: cy = cy + dy
        fcirc cx, cy, (t - start) / lTail
    NEXT
    fw(i).age = fw(i).age + 1
END SUB

SUB initFireWork (i)
    fw(i).x = rand&&(.1 * xmax, .9 * xmax)
    fw(i).y = rand&&(.1 * ymax, .5 * ymax)
    fw(i).seed = rand&&(0, 32000)
    fw(i).age = 0
    fw(i).life = rand&&(20, 120)
END SUB

'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fcirc (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

Maybe last post from the "dinosaur", got a new laptop where the limit in main loop is actually needed!

jj2007

  • Guest
Re: Happy New Year 2018
« Reply #1 on: January 02, 2018, 05:53:56 PM »
Nice demo, B+!
Happy New Year to everybody :)