The QBasic Forum     RULES     Other Subforums, Links and Downloads    Index of Threads

 Return to Index  

Revised version - ball is rounder, pole is thinner, confetti more random.

January 1 2006 at 12:57 PM
Solitaire  (Login Solitaire1)
S


Response to Happy New Year - Times Square program.

This version uses ASCII characters for the pole and ball rather than spaces to paint them as a color background, so it's not as boxy as before. A DO loop avoids covering the ball or pole with random confetti so RANDOMIZE TIMER can be used instead of a fixed random arrangement for the confetti, and every time the program is run, the confetti display will be different. In case some random confetti covers the year or message, the text is reprinted at the end.
=============================================================================

DECLARE SUB Ball (x AS INTEGER, y AS INTEGER, w AS INTEGER, tint() AS INTEGER)
DIM x AS INTEGER, y AS INTEGER, w AS INTEGER, t AS SINGLE, E AS STRING
DIM year AS STRING, month AS STRING, yr AS INTEGER, mo AS INTEGER
DIM tint(0 TO 20) AS INTEGER
DIM song(1 TO 5) AS STRING

RANDOMIZE TIMER
year$ = RIGHT$(DATE$, 4)
month$ = LEFT$(DATE$, 2)
yr = VAL(year$)
mo = VAL(month$)
IF mo >= 9 THEN yr = yr + 1
year$ = LTRIM$(RTRIM$(STR$(yr)))
song$(1) = "p8mbmlO2T220"                   'song - Auld Lang Syne
song$(2) = "ccfffeffaagggfgg"
song$(3) = "agffffaa>ccddddd"
song$(4) = "p8ddccc<aaaffgggfgg"
song$(5) = "agfffdddccfffff"
CLS
LOCATE 7, 22: PRINT "TIMES SQUARE AT NEW YEAR'S EVE"
PRINT TAB(22); STRING$(30, "_")
LOCATE 19, 20: PRINT "Press Alt-Enter for a full screen."
PRINT TAB(15); "Program will not work properly in a window."
LOCATE 24, 24: PRINT "Press any key to begin...";
E$ = INPUT$(1)

CLS
FOR x = 0 TO 20             'changing colors of ball as it drops
    READ tint(x)            'assigned to array
NEXT x
COLOR 6                   'color of pole
FOR x = 2 TO 20
    LOCATE x + 4, 38
    PRINT CHR$(186)
NEXT x
PRINT TAB(35); CHR$(201); STRING$(2, CHR$(205)); CHR$(202); STRING$(2, CHR$(205)); CHR$(187);
x = 2
y = 10
w = 1
CALL Ball(x, y, w, tint())
w = 0
COLOR 7, 0
LOCATE 25, 1: PRINT "Press any key to begin countdown ";
PRINT TAB(50); "Press Esc to stop";
E$ = INPUT$(1)
IF E$ = CHR$(27) THEN CLS : SYSTEM
LOCATE 25, 1: PRINT SPACE$(70);
s = 260
COLOR 8
LOCATE 10, 12: PRINT "Goodbye..."
LOCATE 10, 54: PRINT yr - 1
FOR x = 1 TO 20
    ex$ = INKEY$
    IF ex$ = CHR$(27) THEN COLOR 7, 0: CLS : EXIT FOR
    SOUND s, 10             'sound heard while ball is dropping
    s = s + 9
    IF x MOD 2 = 0 THEN     'countdown from 10 to 1
        y = y - 1
    END IF
    CALL Ball(x, y, w, tint())
    t = TIMER
    DO WHILE t + .5 >= TIMER AND t + .5 <= 86400: LOOP
NEXT x
IF ex$ <> CHR$(27) THEN
    COLOR 30, 0
    LOCATE 10, 10
    PRINT "HAPPY NEW YEAR!"
    LOCATE 10, 55
    PRINT year$
    LOCATE x, 38
    COLOR , 3
    PRINT CHR$(1)                       'happy face replaces countdown number
    LOCATE x + 1, 38
    PRINT "*"
    FOR i = 1 TO 5                      'song - Auld Lang Syne
        ex$ = INKEY$
        IF ex$ = CHR$(27) THEN COLOR 7, 0: CLS : EXIT FOR
        PLAY song$(i)
    NEXT i
    c = 16
END IF
FOR blink = 1 TO 120
    IF ex$ = CHR$(27) THEN COLOR 7, 0: CLS : EXIT FOR
    ex$ = INKEY$
    c = c + 1
    IF c = 32 THEN c = 17
    COLOR c, 0
    IF blink > 110 THEN COLOR 30    'messages blink and switch places
    IF blink = 120 THEN COLOR 14
    SELECT CASE blink
        CASE 1 TO 16, 33 TO 48, 65 TO 80, IS > 97
            LOCATE 10, 10
            PRINT "HAPPY NEW YEAR!"
            LOCATE 10, 55
            PRINT year$; SPACE$(11)
        CASE ELSE
            LOCATE 10, 10
            PRINT year$; SPACE$(11)
            LOCATE 10, 55
            PRINT "HAPPY NEW YEAR!"
    END SELECT
    DO
        row = INT(21 * RND) + 2         'confetti fills the sky
        col = INT(75 * RND) + 3         'does not cover ball or pole
    LOOP WHILE row > 17 AND col > 32 AND col < 44 OR col = 38
    tint = INT(15 * RND) + 1
    confetti$ = CHR$(INT(6 * RND) + 1)
    LOCATE row, col
    COLOR tint, 0
    IF blink > 105 THEN
        confetti$ = "*"             'last confetti stars remain blinking
        COLOR tint + 16, 0
    END IF
    PRINT confetti$
    t = TIMER
    DO WHILE t + .15 >= TIMER AND t + .15 <= 86400: LOOP
NEXT blink
COLOR 30                            'blinking yellow
LOCATE 10, 55: PRINT year           'covers any random confetti
LOCATE 10, 10: PRINT "HAPPY NEW YEAR!"
COLOR 7, 0
LOCATE 24, 55: PRINT "by Solitaire";
DATA 3,3,2,2,3,3,5,5,3,3,2,2,3,3,5,5,3,3,2,2,3,3,3
SYSTEM

SUB Ball (x AS INTEGER, y AS INTEGER, w AS INTEGER, tint() AS INTEGER)
STATIC t AS INTEGER
IF x > 2 THEN               'clear top of ball
    LOCATE x - 1, 36
    PRINT SPACE$(5)         'space prints background color
END IF
LOCATE x, 34: PRINT " "
LOCATE x, 42: PRINT " "
LOCATE x, 35: PRINT SPACE$(7)
COLOR 6
IF x > 2 THEN               'redraw pole on top
    LOCATE x - 1, 38
    PRINT CHR$(186)
END IF
COLOR tint(t)             'redraw descending ball with changing color
IF x > 1 THEN
    LOCATE x, 36
    PRINT CHR$(220); STRING$(3, CHR$(219)); CHR$(220)
END IF
FOR z = 1 TO 2
    IF x = 1 THEN
        LOCATE x + z, 37
        PRINT STRING$(3, CHR$(219))
    ELSE
        LOCATE x + z, 34
        IF z = 1 THEN
            PRINT CHR$(220); STRING$(7, CHR$(219)); CHR$(220)
        ELSE
            PRINT CHR$(223); STRING$(7, CHR$(219)); CHR$(223)
        END IF
    END IF
NEXT z
LOCATE x + 3, 36
IF x > 1 THEN PRINT CHR$(223); STRING$(3, CHR$(219)); CHR$(223)
IF y = 10 THEN
    IF w = 1 THEN
        LOCATE 3, 36
    ELSE
        LOCATE x + 2, 36
    END IF
ELSE
    LOCATE x + 1, 37
END IF
COLOR 0, tint(t)         'background color of countdown number
PRINT y;                'countdown number
COLOR 7, 0
LOCATE 1, 30
PRINT "TIMES SQUARE BALL"
t = t + 1               'static counter
END SUB



    
This message has been edited by Solitaire1 on Jan 2, 2006 10:04 AM
This message has been edited by Solitaire1 on Jan 1, 2006 1:03 PM


 
 Respond to this message   
Response TitleAuthorDate
 Much better improved version of New Year programSolitaireJan 5, 2006