Happy New Year with old style Ansii

[bplus]

Here is fun little Ascii Fireworks to celebrate presented in (QB64):

Code Select Expand


_TITLE "ASCII Fireworks" '2020-01-01
' 2020-01-02 update with graivity effect by tsh73 from JB forum
' 2020-01-02 mod for Syntax Bomb Forum

DEFINT A-Z
CONST xmax = 1280, ymax = 720, maxCol = 160, maxRow = 45
CONST nR = maxCol / 15, t = "     Happy New Year Syntax Bomb Forum, ASCII Fireworks Brought To You By Bplus Inspired By Recent Efforts At QB64 Forum, Gravity Effect By tsh73 at JB Froum, Go With Peace In 2020....."
TYPE rocket
    x AS SINGLE
    y AS SINGLE
    bang AS INTEGER
    age AS INTEGER
    c AS INTEGER
END TYPE
DIM SHARED r(1 TO nR) AS rocket
FOR i = 1 TO nR
    new i
NEXT

SCREEN _NEWIMAGE(xmax, ymax, 12)  '<<< the 12 here sets up 16 color system of old QB
_SCREENMOVE 65, 5  ' to center screen (and get it off my tool bar)

DO
    CLS
    lc = lc + 1
    IF lc MOD 2 = 0 THEN p = (p + 1) MOD LEN(t)
    rocs = rocs + 1
    IF rocs > nR THEN rocs = nR
    FOR i = 1 TO rocs
        drawRocket i
    NEXT
    COLOR 13
    LOCATE 44, INT(.25 * maxCol): PRINT MID$(t, p + 1, INT(.5 * maxCol));
    _DISPLAY
    _LIMIT 15
LOOP UNTIL _KEYDOWN(27)
SYSTEM

SUB new (i)
    r(i).x = RND * (maxCol - 30) + 10
    r(i).y = maxRow - 3
    r(i).bang = INT(RND * (maxRow - 25)) + 2
    r(i).age = 0
    r(i).c = INT(RND * 15) + 1
END SUB

SUB drawRocket (i)
    IF r(i).y >= r(i).bang THEN
        COLOR 15
        LOCATE INT(r(i).y), INT(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 > 25 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 < maxCol + 1 AND yy > 0 AND yy < maxRow + 1 THEN
                        LOCATE INT(yy), INT(xx)
                        PRINT "*";
                    END IF
                NEXT
            NEXT
        END IF
    END IF
END SUB



[bplus]

Here is JustBasic version, I have a code template to simulate old QB environment in Graphics Window and avoid using the GUI available, sort of a de-evolved environment  But perfect for a little Ascii code for color you can't get in JB's mainwin where the normal LOCATE, PRINT, INPUT, CLS would be used (without color? what was Carl thinking?  )

Code Select Expand


'Ascii Fireworks with Mainscreen Commands for Graphics Window.txt for JB B+ 2020-01-01
' 2020-01-02 tsh73 adds nice gravity effect!
' 2020-01-02 escape now quits
' 2020-01-02 now with trails
'
' PLUS Color!!! Plus the print is a little bigger for us older folks.

'  Use: setup title$, desiredWidth, desiredHeight 'to setup a graphics window #gr

'Then use you can use these command substitutes for the graphics window:
'  locate = call locateG characterColumn, characterRow
'   print = call printG text$ '(strings only)
'   input = call inputG prompt$, variable$ '(string variable only)
'   color = call colorG fore$, back$ 'takes only string arguments
'           for colors I set up function QBcolr$(colrNum) to return QB color string for numbers 0 to 15
'     cls = call clsG 'clears to last colorG fore$, back$ used
' PLUS inkee$ is a global variable you have access to use like QB inkey$

' finish your code section with a wait command

call setup "ASCII Fireworks with Main Window Commands for Graphic Windows", 1200, 720 '100 x 30? characters check
global nR, t$, PI, maxCol, maxRow '<<< maxRow??? maxCol??? WTH why doesn't Globals in Setup work???????????????
maxRow = 30
maxCol = 100
PI = 3.141592
nR = 5
t$ = "     Happy New Year Just Basic Forum, ASCII Fireworks Brought To You By Bplus Inspired By Recent Efforts at QB64 Forum, Gravity Effect by tsh73, Go In Peace 2020..."

DIM x(nR), y(nR), bang(nR), age(nR), c(nR)
FOR i = 1 TO nR
    call new i
    'print x(i), y(i), bang(i), age(i), c(i)
NEXT

while asc(inkee$) <> 27
    scan
    call clsG
    call colorG QBcolr$(13), QBcolr$(0)
    lc = lc + 1
    IF lc MOD 5 = 0 THEN p = (p + 1) MOD LEN(t$)
    call locateG .25 * maxCol, 2
    s$ = mid$(t$, p+1, int(.5 * maxCol))
    call printG s$
    rocs = rocs + 1
    IF rocs > nR THEN rocs = nR
    FOR i = 1 TO rocs
        call drawRocket i
    NEXT
    call pause 40
wend
wait

SUB new i
    x(i) = INT(RND(1) * (maxCol - 20)) + 10
    y(i) = maxRow - 1
    bang(i) = INT(RND(1) * (maxRow - 10))
    age(i) = 0
    c(i) = INT(RND(1) * 15) + 1
END SUB

SUB drawRocket i
    IF y(i) > bang(i) THEN
        call colorG QBcolr$(15), QBcolr$(0)
        call locateG x(i), y(i)
        call printG "^"
        y(i) = y(i) - 1
    ELSE
        age(i) = age(i) + 1
        IF age(i) > 25 THEN
            call new i
        ELSE
            call colorG QBcolr$(c(i)), QBcolr$(0)
            if age(i) > 4 then start = age(i) - 4 else start = 1
            for a = start to age(i)
            'a = age(i)
            FOR j = 1 TO 12
                xx = x(i) +  1 * a * COS(j * PI / 6)
                yy = y(i) + .5 * a * SIN(j * PI / 6)
                yy = yy + (y(i) - a) ^ 2 / 15  '<<<< tsh73 gravity
                IF xx > 0 AND xx < maxCol AND yy > 0 AND yy < maxRow THEN
                    call locateG xx, yy
                    call printG "*"
                END IF
            NEXT
            next
        END IF
    END IF
END SUB


wait ' end code input section ==========================

' Copy Paste these Procedures so you can do a graphics setup

'  Use: setup title$, desiredWidth, desiredHeight 'to setup a graphics window #gr
'Then use you can use these command substitutes for the graphics window:
'  locate = call locateG characterColumn, characterRow
'   print = call printG text$ '(strings only)
'   input = call inputG prompt$, variable$ '(string variable only)
'   color = call colorG fore$, back$ 'takes only string arguments
'           for colors I set up function QBcolr$(colrNum) to return QB color string for numbers 0 to 15
'     cls = call clsG 'clears to last colorG fore$, back$ used
' PLUS inkee$ is a global variable you have access to use like QB inkey$

' finish your code section with a wait command

'setup graphics window with specified title$, width and height with handle #gr, AKA h$
sub setup title$, wWidth, wHeight
    global xmax, ymax  'screen width and height
    xmax = wWidth : ymax = wHeight  '<<<<<< set this as you need or from plug-in notes

    global cellW, cellH
    'do not mess with cellW and cellH globals for printing
    cellW = 12 'pixels wide for characters
    cellH = 24 'pixels high for characters

    global maxRow, maxCol
    'and then these are calculated from above globals
    maxCol = int(xmax / cellW)  'these control printing characters
    maxRow = int(ymax / cellH)

    global lastC, lastR 'for LocateG (locate), printG (print a line), lp (locate and print)
    lastC = 1 : lastR = 1

    'key events update globals with latest info
    global inkee$, h$

    h$ = "#gr"

    global wFG$, wBG$
    wFG$ = "white" : wBG$ = "black"

    nomainwin

    WindowWidth = xmax + 8
    WindowHeight = ymax + 32
    UpperLeftX = (DisplayWidth-WindowWidth) / 2
    UpperLeftY = (DisplayHeight-WindowHeight) / 2

    open title$ for graphics_nsb_nf as #gr
    #gr "trapclose quit"

    'fonts that don't work arial, tahoma, verdana
    '#gr "font arial ";cellW;" ";cellH
    '#gr "font dejavu_sans_mono ";cellW;" ";cellH

    'fonts that work
    '#gr "font courier_new ";cellW;" ";cellH
    #gr "font consolas ";cellW;" ";cellH

    '#gr "home"                  '< check drawing area
    '#gr "posxy w2 h2"           '<<<<<<<<<<<<<<<<<<
    'notice "Screen Drawing Check";chr$(13);"Size:" + chr$(13) + "Width (w2*2) = ";w2*2;",  Height (h2*2) = ";h2*2

    #gr "setfocus"
    #gr "when characterInput charIn"
    #gr "down"
    call colorG "white", "black"
    call clsG
end sub

sub printG mess$ 'print (with "line feed") for graphics window
    startR = lastR
    for i = 1 to len(mess$)
        scan
        call lp lastC, lastR, mid$(mess$, i, 1)
        if lastR <> startR then exit for
    next
    lastC = 1
    lastR = startR + 1
    if lastR > maxRow then lastR = maxRow 'yuck!
end sub

sub clsG  'cls for graphics window
    #gr "fill ";wBG$
    lastC = 1 : lastR = 1
end sub

sub colorG fore$, back$ 'set color fore and back to color string names, see QBcolr$ function
    wFG$ = fore$ : wBG$ = back$
    #gr "color ";wFG$
    #gr "backcolor ";wBG$
end sub

sub locateG x, y   'locate xColumnCell, yRowCell for printing
    if 0 < x and x < maxCol + 1 and 0 < y and y < maxRow + 1 then
        lastC = x
        lastR = y
    end if
end sub

sub inputG prmpt$, byref var$   'input for a graphics screen
    'prints prompt at lastC, lastR and leaves lastC = 1 lastR = pRow + 1

    inkee$ = "" 'clear last key (new fix for DE5)
    call lp lastC, lastR, prmpt$;"{"
    'this will update lastR and lastC to the starting point of input variable
    pRow = lastR : pCol = lastC 'save these for redrawing var
    call lp pCol, pRow, "}"
    OK$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZ abcdefghijklmnopqrstuvwxyz"
    OK$ = OK$+ chr$(8)+ chr$(27) + chr$(13) + "1234567890!@#$%^&*()_-+={}[]|\:;'<,>.?/"
    do
        scan
        if instr(OK$, inkee$) then
            if inkee$ = Chr$(8) then
                if t$ <> "" then
                    if Len(t$)=1 then t$="" else t$=Left$(t$,Len(t$)-1)
                end if
            else
                if inkee$=Chr$(13) or inkee$=Chr$(27) then
                    'new D5, I was expecting nothing in return for my esc
                    if inkee$ = chr$(27) then t$ = ""
                    exit do
                else
                    t$=t$;inkee$
                end if
            end if
            call lp pCol, pRow, t$;"} "
            inkee$ = ""
        end if
    loop until done
    var$ = t$
    lastC = 1 : lastR = pRow + 1
end sub

function QBcolr$(colrNum)
    select case colrNum
    case 0   : QBcolr$ = "black"
    case 1   : QBcolr$ = "darkblue"
    case 2   : QBcolr$ = "brown"
    case 3   : QBcolr$ = "darkcyan"
    case 4   : QBcolr$ = "darkred"
    case 5   : QBcolr$ = "darkpink"
    case 6   : QBcolr$ = "darkgreen"
    case 7   : QBcolr$ = "lightgray"
    case 8   : QBcolr$ = "darkgray"
    case 9   : QBcolr$ = "blue"
    case 10  : QBcolr$ = "green"
    case 11  : QBcolr$ = "cyan"
    case 12  : QBcolr$ = "red"
    case 13  : QBcolr$ = "pink"
    case 14  : QBcolr$ = "yellow"
    case 15  : QBcolr$ = "white"
    end select
end function

function rndColor$()
    rndColor$ = QBcolr$( int( rnd(0) * 16) )
end function

sub lp x, y, mess$ 'locate x, y : print mess$ lp = locate and print
    'if locate = x col and y row then and top left corner locates as 1, 1
    c = x - 1: r = y
    if 0 < x and x < maxCol + 1 and 0 < y and y < maxRow + 1 then
        #gr "place ";c * cellW;" ";r * cellH - 4
        #gr "|";mess$
        lastC = x + len(mess$)
        if lastC > maxCol then lastC = 1 : lastR = lastR + 1
        if lastR > maxRow then lastR = maxRow 'yuck!
    end if
end sub

sub cp y,cpText$ 'cp Center Print on line y the cpText$
    call lp int((maxCol - len(cpText$))/2 + 1.5), y, cpText$
    lastC = 1 : lastR = y + 1
end sub

sub at xPix, yPix, char$  'print a string at pixel x, y This pin point locating.
    #gr "place ";xPix;" ";yPix
    #gr "|";char$
end sub

sub pause mil   'tsh version has scan built-in
    t0 = time$("ms")
    while time$("ms") < t0 + mil : scan : wend
end sub

sub charIn hdl$, c$
    inkee$ = c$
end sub

sub quit hdl$
    timer 0
    close #gr
    end
end sub


Fun to see other's approach to same Ascii fireworks but only if fun!

[bplus]

A better QB64 version with sound, toggle between Ascii and graphics:

(Source code has embedded sound file that makes it too big to post.)

[Naughty Alien]

..it will be nice to include a screenshot, for us who cant run this code, just to see how whole thing actually looks like 

[bplus]

..it will be nice to include a screenshot, for us who cant run this code, just to see how whole thing actually looks like 

Better to see it in action, here is a couple

[bplus]

Oops! I got a comment why no red and it turns out I had reversed red and alpha numbers, blah!

So since I have to redo this I will do the sound file separate so I can post source if someone has Linux or Mac and QB64 they can compile, the EXE in zip is for Windows 10-64. So zip has BAS source, EXE for W10-64 and distant.wav

Code Select Expand


_TITLE "Fireworks use spacebar to toggle between graphics and Ansii" '2020-01-01

RANDOMIZE TIMER
CONST xmax = 1280, ymax = 720, maxCol = 160, maxRow = 45
CONST nR = maxCol \ 35 'make sure this is integer
TYPE rocket
    x AS SINGLE
    y AS SINGLE
    bang AS SINGLE
    seed AS INTEGER
    age AS INTEGER
    fini AS INTEGER
    c AS _UNSIGNED LONG
END TYPE
DIM SHARED r(1 TO nR) AS rocket, mode, distant AS LONG
FOR i = 1 TO nR
    new i
NEXT
distant = _SNDOPEN("distant.wav", "vol,sync")
SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 65, 5
DIM rocs AS INTEGER
COLOR , 0
DO
    FOR i = 0 TO ymax
        LINE (0, i)-(xmax, i), _RGB32(20, 0, i * 44 / ymax), BF
    NEXT
    IF INKEY$ = " " THEN mode = 1 - mode
    lc = lc + 1
    IF lc MOD 30 = 1 AND rocs < nR THEN rocs = rocs + 1: lc = 1
    FOR i = 1 TO rocs
        drawRocket i
    NEXT
    _DISPLAY
    _LIMIT 30
LOOP UNTIL _KEYDOWN(27)
SYSTEM

SUB new (i)
    RANDOMIZE TIMER
    r(i).x = RND * (xmax - 30) + 10
    r(i).y = ymax - 60
    r(i).bang = .5 * ymax * RND + 30
    r(i).seed = INT(32000 * RND) + 1
    r(i).age = 0
    r(i).fini = RND * 75 + 25
    r(i).c = _RGBA32(RND * 255, RND * 255, RND * 255, 25)
END SUB

SUB drawRocket (i)
    IF r(i).y >= r(i).bang THEN
        COLOR r(i).c
        FOR k = 1 TO 12
            LOCATE r(i).y \ 16, r(i).x \ 8: PRINT CHR$(24);
        NEXT
        r(i).y = r(i).y - 16
    ELSE
        IF r(i).age = 0 THEN
            LINE (0, 0)-(xmax, ymax), &H44FFFFFF, BF: _DISPLAY
            _SNDVOL distant, .9
            _SNDPLAY distant
        END IF
        r(i).age = r(i).age + 1
        IF r(i).age > r(i).fini THEN
            new i
        ELSE
            RANDOMIZE USING r(i).seed
            ne = RND * 500 + 100
            DIM embers(ne - 1, 1)
            FOR e = 0 TO ne - 1
                R = RND * 12
                a = RND * _PI(2)
                embers(e, 0) = R * COS(a)
                embers(e, 1) = R * SIN(a)
            NEXT
            IF r(i).age > 10 THEN start = r(i).age - 10 ELSE start = 1 ' don't let tails get longer than lTail const
            FOR e = 0 TO ne - 1
                cx = r(i).x: cy = r(i).y: dx = embers(e, 0): dy = embers(e, 1)
                FOR tt = 1 TO r(i).age
                    cx = cx + dx
                    cy = cy + dy
                    IF tt > start THEN
                        IF mode THEN
                            IF tt <> r(i).age THEN
                                CIRCLE (cx, cy), 1, r(i).c
                            ELSE
                                FOR R = 0 TO 2 STEP .5
                                    CIRCLE (cx, cy), R, &H88FFFFFF
                                NEXT
                            END IF
                        ELSE
                            col = cx \ 8 + 1: row = cy \ 16 + 1
                            IF col > 0 AND col <= maxCol AND row > 0 AND row < maxRow THEN
                                LOCATE row, col
                                IF tt <> r(i).age THEN
                                    COLOR r(i).c: PRINT "b";
                                ELSE
                                    COLOR &H88FFFFFF: PRINT "Q";
                                END IF
                            END IF
                        END IF
                    END IF
                    dx = dx * .97 'air resitance
                    dy = .97 * dy + .1 'gravity
                NEXT
            NEXT
        END IF
    END IF
END SUB



and here are fresh screen shots with zip: