YOUR JOYFUL MEMBERSHIP CREDENTIALS HAVE NOT BEEN IDENTIFIED. PLEASE ENTER YOUR CREDENTIALS OR JOIN OUR JOYFUL COMMUNITY.
ENTER YOUR JOYFUL MEMBER CREDENTIALS REQUEST ACCESS TO OUR JOYFUL COMMUNITY


Happy New Year 2018
12-30-2017, 02:06 PM (This post was last modified: 12-30-2017 02:15 PM by bplus.)
Post: #1
 (Print Post)
This might be my final cut for New Year's Fireworks challenge at QB64.net. It is last post from my dinosaur laptop since I got a new one for Christmas.

Code Snippet: [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 dinosaur but about 50 on my new laptop

   '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

Happy New Year to All!


Attached File(s) Image(s)
   

For a bad joke 
http://www.laughfactory.com/jokes/joke-of-the-day 
worse than Pete's Big Grin
Find all posts by this user
Like Post
12-30-2017, 09:23 PM (This post was last modified: 12-31-2017 07:33 PM by Waltersmind.)
Post: #2
 (Print Post)
Nothing changes on New Years Day:



Erik.

Games: DNDDOOR - https://bit.ly/EriksDNDDoor DUNGEON - https://bit.ly/EriksDungeon
Interpreter - https://bit.ly/EriksSICK Hex Editor - https://bit.ly/EriksHexEditor Utilities - https://bit.ly/EriksUtils

QB45 files: - https://bit.ly/EriksQB45 QB64shell - https://bit.ly/QB64shell Some old QB64 versions: - https://bit.ly/OldQB64 
Find all posts by this user
Like Post
12-31-2017, 12:22 AM
Post: #3
 (Print Post)
Happy new year everyone!

I like to program in BASIC
With code that is simple and slick
I learnt it in school
And it is still cool
So it is my number one pick
Find all posts by this user
Like Post
12-31-2017, 12:39 PM
Post: #4
 (Print Post)
U2      ; - ) )

For a bad joke 
http://www.laughfactory.com/jokes/joke-of-the-day 
worse than Pete's Big Grin
Find all posts by this user
Like Post
12-31-2017, 07:34 PM
Post: #5
 (Print Post)
Happy New Year to ever one as well!

@Bplus,

Very nice fireworks demo! Thank you for sharing.

Dedicated to working with computer programming hobbyists, tinkerers, amateurs, and enthusiasts.
Find all posts by this user
Like Post



Forum Jump:


User(s) browsing this thread: 1 Guest(s)




QB64 Member Project - Touche
QB64 Member Project - Foursight
QB64 Member Project - Kobolts Monopoly
QB64 Member Project - Inside Moves
QB64 Member Project - Blokus
QB64 Member Project - Pivet version one
QB64 Member Project - Algeria Weather
QB64 Member Project - Color Rotating Text
QB64 Member Project - Dreamy Clock
QB64 Member Project - Color Triangles
QB64 Member Project - Othello
QB64 Member Project - Amazon
QB64 Member Project - Basic Dithering
QB64 Member Project - Splatter
QB64 Member Project - Pivot version two
QB64 Member Project - Martin Fractals version two
QB64 Member Project - Input
QB64 Member Project - RGB Color Wheel
QB64 Member Project - Martin Fractals version three
QB64 Member Project - Quarto
QB64 Member Project - ARB Checkers
QB64 Member Project - Bowditch curve
QB64 Member Project - Martin Fractals version one
QB64 Member Project - Rotating Background
QB64 Member Project - Isolation
QB64 Member Project - Qubic
QB64 Member Project - Martin Fractals version four
QB64 Member Project - Point Blank
QB64 Member Project - Spinning Color Wheel
QB64 Member Project - Kings Court
QB64 Member Project - Dakapo
QB64 Member Project - 9 Board
QB64 Member Project - Score 4
QB64 Member Project - MAPTRIANGLE
QB64 Member Project - Connect Four
QB64 Member Project - Kings Valley verion one
QB64 Member Project - Overboard
QB64 Member Project - Exit
QB64 Member Project - Swirl
QB64 Member Project - Domain
QB64 Member Project - Sabotage
QB64 Member Project - Spiro Roses
QB64 Member Project - STxAxTIC 3D World
QB64 Member Project - Full Color LED Sign
QB64 Member Project - Kings Vallery version two
QB64 Member Project - Rubix's Magic
QB64 Member Project - Line Thickness
QB64 Member Project - Red Scrolling LED Sign
QB64 Member Project - OpenGL Triangles