'Yet Another Snow Demo for Qbasic/QB/MS basic flavours
'If you're using Windows then close down background apps, run
'full screen and allocate as many resources as possible to it,
'use a PiF if you ain't already got one

'Known bugs : lots !
'Credits    : me, me and me....I'm selfish
'Wierd FX   : don't blame me if your screen explodes
'Miscellany : a quick 'n dirty hack with absolutely no
'             regard to the niceties of programming

DEFINT A-Z
DECLARE SUB EndCredit ()
DECLARE SUB FadeSign ()
DECLARE SUB FadeText ()
DECLARE SUB Objects ()
DECLARE SUB Sign ()
DECLARE SUB WipeObjects ()
DECLARE SUB WipeScreen ()

'+++++++++++++++++++++ user options
  'number of snow flakes, 640 is about the max otherwise
  'the detect screen full algorithm incorrectly executes
CONST MaxSnow = 200

'following constants are either  0 = off  or  -1 = on

'set flake speed - slow speed gives a sparkly effect
'requires fast(ish) PC for this
'0 = fast  -1 = slow
CONST SuperSlow = -1

'sets snow flake movement from side to side
CONST Wander = -1

'displays text message
CONST Message = -1

'turns off that annoying tune
CONST Music = 0
'+++++++++++++++++++++ end of options

CONST MaxHeight = 188, MaxWidth = 319
CONST Mwidth& = 320
CONST Pi = 3.14159
 
DIM SnowFlake(MaxSnow, 4) AS INTEGER
DIM SHARED Pal(3, 36), Pal2(3, 36)

CONST MaxFcolour = 5
DIM FlakeColour(MaxFcolour)
FlakeColour(0) = 7
FlakeColour(1) = 7
FlakeColour(2) = 7
FlakeColour(3) = 7
FlakeColour(4) = 15
FlakeColour(5) = 15

MaxLines = 32
REDIM SHARED MsgText(MaxLines) AS STRING * 40
FOR i = 1 TO MaxLines
    READ MsgText(i)
    FOR b = 1 TO LEN(MsgText(i))
        c = ASC(MID$(MsgText(i), b, 1)) - 13
        MID$(MsgText(i), b, 1) = CHR$(c)
    NEXT
NEXT


RANDOMIZE TIMER
SCREEN 13
DEF SEG = &HA000
FOR i = 0 TO 36
  OUT &H3C6, &HFF
  OUT &H3C7, i
  Pal(1, i) = INP(&H3C9)
  Pal(2, i) = INP(&H3C9)
  Pal(3, i) = INP(&H3C9)
 
  Pal2(1, i) = 0
  Pal2(2, i) = 0
  Pal2(3, i) = 0
   
  OUT &H3C8, i
  OUT &H3C9, 0
  OUT &H3C9, 0
  OUT &H3C9, 0
NEXT i

IF Music THEN
  RESTORE Jingle
  ON PLAY(2) GOSUB GetTune
  PLAY ON
  PLAY "MB N0N0"  'init sound
END IF


DO
  'initial snow flake start co-ords
  FOR i = 1 TO MaxSnow
    'snow flake state
    '0 = inactive
    '1 = active
    '2 = moves left when hits object
    '3 = moves right when hits object
    SnowFlake(i, 1) = 1                     'flake is active
    SnowFlake(i, 2) = RND * MaxWidth        'x coord
    SnowFlake(i, 3) = RND * MaxHeight * .75 'y coord
    SnowFlake(i, 4) = 1                      'speed
         
    'make flakes move faster
    IF i < MaxSnow \ 4 THEN SnowFlake(i, 4) = 1 + RND * 1
       
    'use 3 speeds for super slow version
    IF SuperSlow THEN
      IF i < MaxSnow \ 2 THEN SnowFlake(i, 4) = 1 + RND * 2
    END IF
  NEXT

Objects
Sign

FOR hk = 0 TO 63
    FOR i = 2 TO 36
        OUT &H3C8, i
        OUT &H3C9, Pal2(1, i)
        OUT &H3C9, Pal2(2, i)
        OUT &H3C9, Pal2(3, i)
IF Pal2(1, i) < Pal(1, i) THEN Pal2(1, i) = Pal2(1, i) + 1
IF Pal2(2, i) < Pal(2, i) THEN Pal2(2, i) = Pal2(2, i) + 1
IF Pal2(3, i) < Pal(3, i) THEN Pal2(3, i) = Pal2(3, i) + 1
    NEXT
  
    WAIT &H3DA, 8
NEXT

 
  IF SuperSlow THEN
    're-start after 8 minutes for super slow version
    EndTime# = TIMER + 60 * 8
  ELSE
    EndTime# = TIMER + 60 * 4
  END IF


'main program loop
DO
  IF SuperSlow THEN DelayTime# = TIMER + .01

  FOR i = 1 TO MaxSnow
    IF SnowFlake(i, 1) = 0 THEN
      'snow flake inactive, get new co-ords
      SnowFlake(i, 1) = 1             'active
      SnowFlake(i, 3) = 1             'y coord
                   
'move horizontal position if off screen
IF SnowFlake(i, 2) MOD MaxWidth = 0 OR RND * 10 > 9 THEN
  SnowFlake(i, 2) = 1 + RND * MaxWidth 'x coord
END IF
          
    ELSE
      'check for object below current snow flake
      Hit = POINT(SnowFlake(i, 2), SnowFlake(i, 3) + 1)
      IF Hit = 7 OR Hit = 15 THEN
        Hit = POINT(SnowFlake(i, 2), SnowFlake(i, 3) + 2)
        IF Hit = 7 OR Hit = 15 THEN
          Hit = POINT(SnowFlake(i, 2), SnowFlake(i, 3) + 3)
        END IF
      END IF

      IF Hit = 0 THEN
        'not hit object so erase previous snow flake
        'PSET (SnowFlake(i, 2), SnowFlake(i, 3)), Hit
        POKE (SnowFlake(i, 3) * Mwidth&) + SnowFlake(i, 2), 0

        IF Wander THEN
          IF SnowFlake(i, 1) = 1 THEN
            'active so add movement from side to side
            SnowFlake(i, 2) = SnowFlake(i, 2) + 1 - RND * 2
          END IF
        END IF

      ELSE  'hit object
                    
        'reset it in case dropped off object such
        'as a tree branch and is in mid-air
        SnowFlake(i, 1) = 1

        IF POINT(SnowFlake(i, 2) + 1, SnowFlake(i, 3)) = 0 THEN
        IF POINT(SnowFlake(i, 2) + 1, SnowFlake(i, 3) + 1) = 0 THEN
          SnowFlake(i, 1) = 3
        END IF
        END IF
                       
        IF POINT(SnowFlake(i, 2) - 1, SnowFlake(i, 3)) = 0 THEN
        IF POINT(SnowFlake(i, 2) - 1, SnowFlake(i, 3) + 1) = 0 THEN
          SnowFlake(i, 1) = 2
        END IF
        END IF
                 
        'stop slopes getting too geometric
        IF RND * 10 > 9 THEN SnowFlake(i, 1) = 1

        IF SnowFlake(i, 1) = 2 THEN 'moving left
          SnowFlake(i, 2) = SnowFlake(i, 2) - 1
        ELSE
          SnowFlake(i, 2) = SnowFlake(i, 2) + 1
        END IF
                   
        IF SnowFlake(i, 1) > 0 THEN
          'hit bottom of snow trough or object ?
        IF POINT(SnowFlake(i, 2), SnowFlake(i, 3) + 1) > 0 THEN
          SnowFlake(i, 1) = 0
          IF SnowFlake(i, 3) < 10 THEN EXIT DO
        END IF
        END IF

      END IF
                    
      IF SnowFlake(i, 2) >= MaxWidth THEN SnowFlake(i, 1) = 0
      IF SnowFlake(i, 2) < 1 THEN SnowFlake(i, 1) = 0
              
      IF SnowFlake(i, 1) THEN
        SnowFlake(i, 3) = SnowFlake(i, 3) + SnowFlake(i, 4)

'PSET (SnowFlake(i, 2), SnowFlake(i, 3)), FlakeColour(RND * MaxFcolour)
POKE (SnowFlake(i, 3) * Mwidth&) + SnowFlake(i, 2), FlakeColour(RND * MaxFcolour)
      END IF
              
    END IF
  NEXT


  IF LEN(INKEY$) THEN       'user exits here
    EndCredit
    END
  END IF
   
  IF Message THEN FadeText
  FadeSign
 
  IF SuperSlow THEN
    WHILE TIMER < DelayTime#
    WEND
  ELSE
    'wait for retrace
    WAIT &H3DA, 8
  END IF
 
LOOP UNTIL TIMER > EndTime#
LOOP


'encrypted message
DATA "-:-\u-{|-.-v4€-†r-n{|ur-ezn€-qrz|-:-"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"
DATA "-du†-nr-ur†-€|-}|}‚yn-L-„un-v€-ur--"
DATA "-}|v{-|s-urz-L-n{q-„un-v€-ur-n{€„r-"
DATA "-|-yvsr9-ur-‚{vƒr€r-nzq-rƒr†uv{t-L-"
DATA "----::::-du|-pnr€9-w‚€-q|-v-.-::::---"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"
DATA "-[|„-n-zr€€ntr-s|z-|‚-€}|{€|€-:-o‚†--"
DATA "-z|r-[r„pn€yr-O|„{-orr-G6-----------"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"
DATA "-aun-€{|„4€-u†}{|vp9-„npu-ur-€{|„---"
DATA "-synxr€-t|-onpx-n{q-s|u9-onpx-n{q-----"
DATA "-s|u9-†|‚4r-srryv{t-vrq-n{q-ƒr†---"
DATA "-€yrr}†;;;onpx-n{q-s|u;;;†|‚-„vyy-{|„-"
DATA "-t|-|-€yrr}-s|-|{r-u|‚-n{q-„ur{-†|‚--"
DATA "-„nxr-‚}-†|‚-„vyy-or-€|-un}}†-un-†|‚--"
DATA "-„vyy-€r{q-zr;;;;;;;nyy-†|‚-z|{r†-G6---"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"
DATA "-;;;‡‡‡‡‡‡‡‡‡‡‡‡‡‡;;;nr-„r-o|rq-†r-L-"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"
DATA "-d|„-.-V-nz-nzn‡rq9--uv€-qrz|-un€-{|--"
DATA "-rƒr{-zr{v|{rq-ur-„|q-4p||y4-v{-v---"
DATA "-;;;qnz{-.-V4ƒr-w‚€-€nvq-v;-----------"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"
DATA "-T|ooyr9-t|ooyr9-t|ooyr9-t|ooyr9-t|ooyr-"
DATA "-t|ooyr9-t|ooyr9-t|ooyr9-t|ooyr-:-yn€--"
DATA "-„|q€-|s-?==8-zvyyv|{-‚xr†€-_V]------"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"
DATA "---auv€-}|tnz-v€-n-o‚t-un-„|x€-.---"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"
DATA "--:-auv€-v€-n-[nss„nr-Yq;-_ryrn€r-:---"
DATA "--;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;--"

GetTune:
  READ a$
  IF a$ = "END" THEN
    PLAY OFF
  ELSE
    PLAY a$
  END IF
RETURN

'a really annoying tune, coded by unknown author
Jingle:
DATA "T200l4o2mneel2el4eel2el4egl3cl8dl1el4ffl3fl8fl4fel2e"
DATA "l8eel4eddel2dgl4eel2el4eel2el4egl3cl8dl1el4ffl3fl8"
DATA "fl4fel2el8efl4ggfdl2c"
DATA "END"

DEFSNG A-Z
SUB EndCredit

PLAY OFF

WipeScreen

DEF SEG
   
SCREEN 0
WIDTH 80
COLOR 15
text$ = "cadwright@aol.com"
PLAY "MBO1L48"

FOR i = 1 TO LEN(text$)
a$ = ""
FOR cc = 36 - i TO 46 - i STEP 2
    a$ = a$ + "N" + LTRIM$(STR$(cc))
NEXT
PLAY a$

FOR b = 24 TO 3 STEP -1
  LOCATE b, i + 3: PRINT MID$(text$, i, 1);
  LOCATE b + 1, i + 3: PRINT " ";

  WAIT &H3DA, 8
NEXT
NEXT
LOCATE 4, 4: PRINT "owns up to coding this useless demo :)"
COLOR 7
LOCATE 2, 1: PRINT STRING$(60, CHR$(205));
LOCATE 6, 1: PRINT STRING$(60, CHR$(205))
PRINT

END SUB

DEFINT A-Z
SUB FadeSign STATIC

IF Bright THEN
  IF Pal2(1, 13) > Pal2(1, 8) + 4 THEN
    Pal2(1, 13) = Pal2(1, 13) - 1
  ELSE
    Bright = NOT Bright
  END IF
  Pal2(2, 13) = Pal2(2, 13) - 1
  Pal2(3, 13) = Pal2(3, 13) - 1
 
  IF Pal2(1, 14) < 51 THEN Pal2(1, 14) = Pal2(1, 14) + 1
  IF Pal2(2, 14) < 51 THEN Pal2(2, 14) = Pal2(2, 14) + 2
  IF Pal2(3, 14) < 51 THEN Pal2(3, 14) = Pal2(3, 14) + 1

ELSE
  IF Pal2(1, 14) > Pal2(1, 8) + 4 THEN
    Pal2(1, 14) = Pal2(1, 14) - 1
  ELSE
    Bright = NOT Bright
  END IF
  IF Pal2(2, 14) > Pal2(2, 8) THEN Pal2(2, 14) = Pal2(2, 14) - 1
  IF Pal2(3, 14) > Pal2(3, 8) THEN Pal2(3, 14) = Pal2(3, 14) - 1
 
  IF Pal2(1, 13) < 51 THEN Pal2(1, 13) = Pal2(1, 13) + 1
  IF Pal2(2, 13) < 51 THEN Pal2(2, 13) = Pal2(2, 13) + 2
  IF Pal2(3, 13) < 51 THEN Pal2(3, 13) = Pal2(3, 13) + 1
  
END IF
  
OUT &H3C8, 14
OUT &H3C9, Pal2(1, 14)
OUT &H3C9, Pal2(2, 14)
OUT &H3C9, Pal2(3, 14)

OUT &H3C8, 13
OUT &H3C9, Pal2(1, 13)
OUT &H3C9, Pal2(2, 13)
OUT &H3C9, Pal2(3, 13)

END SUB

SUB FadeText STATIC

IF Bright THEN
  IF Pal2(1, 1) < 63 THEN Pal2(1, 1) = Pal2(1, 1) + 1
  IF Pal2(2, 1) < 63 THEN Pal2(2, 1) = Pal2(2, 1) + 1
  IF Pal2(3, 1) < 63 THEN Pal2(3, 1) = Pal2(3, 1) + 1
 
  IF Pal2(1, 1) > 62 THEN Bright = NOT Bright

ELSE
  Pal2(1, 1) = Pal2(1, 1) - 1
  Pal2(2, 1) = Pal2(2, 1) - 1
  Pal2(3, 1) = Pal2(3, 1) - 1
 
  IF Pal2(1, 1) < 1 THEN
    Bright = NOT Bright
    CurrMsg = CurrMsg + 1
    IF CurrMsg > UBOUND(MsgText) THEN CurrMsg = 0
    COLOR 1
    LOCATE 25, 1: PRINT MsgText(CurrMsg);
  END IF

END IF
   
OUT &H3C8, 1
OUT &H3C9, Pal2(1, 1)
OUT &H3C9, Pal2(2, 1)
OUT &H3C9, Pal2(3, 1)

END SUB

SUB Objects STATIC

IF SecondCall THEN WipeObjects
SecondCall = 1

LINE (0, 0)-(MaxWidth, MaxHeight), 0, BF

Smid = 128
FOR i = 1 TO 8
  CIRCLE (Smid, 167), 20 - i, 23 + i
  PAINT (Smid, 167), 23 + i, 23 + i
NEXT

FOR i = 1 TO 7
  CIRCLE (Smid, 141), 14 - i, 24 + i
  PAINT (Smid, 141), 24 + i, 24 + i
NEXT

CIRCLE (Smid - 5, 137), 1, 0
PAINT (Smid - 5, 137), 0, 0
CIRCLE (Smid + 5, 137), 1, 0
PAINT (Smid + 5, 137), 0, 0

CIRCLE (Smid, 141), 1, 12
PAINT (Smid, 141), 12, 12

CIRCLE (Smid, 141), 7, 0, Pi * 1.2, 0

FOR x! = 0 TO 3 * Pi STEP .02
  PSET (x! * 50, SIN(x!) * 6 + (MaxHeight - 12)), 15
NEXT
PAINT (1, MaxHeight - 1), 15, 15

LINE (0, 199)-(MaxWidth, MaxHeight + 1), 0, BF

FOR b = 1 TO 2
  TreeX = 65
  IF b = 2 THEN TreeX = 265
  IF b = 3 THEN TreeX = 230
    
  LINE (TreeX - 2, MaxHeight - 45)-(TreeX + 2, MaxHeight - 4 * b), 6, BF
  FOR i = 1 TO 10
    PSET (TreeX - 1 + RND * 2, MaxHeight - 45 + RND * 35), 2
  NEXT

  FOR d = 1 TO 3
  TreeTop = MaxHeight - 125 - b * 8
  FOR i = TreeTop TO MaxHeight - 30 - (b - 1) * 4
    Colour = 2
    IF RND * 10 > 7 THEN Colour = 10
        
    Branch = 1 + RND * 8
    IF RND * 10 > 5 THEN
      LINE (TreeX, i)-(TreeX - 5 + i \ 6, i + Branch), Colour
    ELSE
      LINE (TreeX, i)-(TreeX + 5 - i \ 6, i + Branch), Colour
    END IF
  NEXT
  NEXT
NEXT

Sign

END SUB

SUB Sign STATIC

Smid = 214
Sheight = 157
LINE (Smid - 2, Sheight)-(Smid + 2, Sheight + 18), 8, BF
LINE (Smid + 2, Sheight)-(Smid + 2, Sheight + 18), 7, BF

b = 0
FOR i = Smid - 18 TO Smid + 23
b = b + 1
LINE (i, Sheight - 25 - b / 2)-(i, Sheight + b \ 2), 8
NEXT
LINE (i, Sheight - 25 - b / 2)-(i + 1, Sheight + b \ 2), 7, BF

DRAW "C14 S1 BM198,144"
DRAW "M204,133  BM199,135 M204,145"
DRAW "BM207,145 M207,131  M210,136 M214,128  M214,146"
DRAW "BM217,147 M220,126  M223,147 BM219,139 M222,138"
DRAW "BM226,145 M227,147  M233,147  M234,132 M226,134  M226,125"
DRAW "M232,123 M233,124"

DRAW "C13 S1 BM197,154"
DRAW "M202,157 M202,148 M197,148 BM198,148 M198,154"
DRAW "BM205,148 NM211,149 M205,159 M211,162 BM205,152 M209,154"
DRAW "BM215,164 M215,150  M218,156 M222,150  M222,167"
DRAW "BM226,153 M228,151 M233,151 M235,154 M235,170 M233,172"
DRAW "M227,169 M226,167 M226,153"

END SUB

SUB WipeObjects

  'do something mildly interesting
  DelayTime# = TIMER + 10
  b = RND * 3

  SELECT CASE b
  CASE 0
    WHILE TIMER < DelayTime# AND LEN(INKEY$) = 0
        PSET (RND * MaxWidth, RND * MaxHeight), 0
    WEND
  CASE 1
    WHILE TIMER < DelayTime# AND LEN(INKEY$) = 0
        FOR y = 198 TO 0 STEP -2
        FOR x = 0 TO 318 STEP 2
            b = POINT(x, y)
            IF b THEN
                LINE (x, y)-(x + 1, y + 3), b - 1, BF
            END IF
        NEXT
        NEXT
        WAIT &H3DA, 8
    WEND
  CASE ELSE
    WHILE TIMER < DelayTime# AND LEN(INKEY$) = 0
        x = x + 2 - RND * 4
        y = y + 2 - RND * 4
        IF x < 0 THEN x = MaxWidth
        IF x > MaxWidth THEN x = 0
        IF y < 0 THEN y = MaxHeight
        IF y > MaxHeight THEN y = 0
        PSET (x, y), 12
        PSET (x + 1, y + 1), 12
    WEND
  END SELECT

END SUB

SUB WipeScreen

FOR hk = 0 TO 63
    FOR i = 0 TO 36
        OUT &H3C8, i
        OUT &H3C9, Pal2(1, i)
        OUT &H3C9, Pal2(2, i)
        OUT &H3C9, Pal2(3, i)
   
        IF Pal2(1, i) > 0 THEN Pal2(1, i) = Pal2(1, i) - 1
        IF Pal2(2, i) > 0 THEN Pal2(2, i) = Pal2(2, i) - 1
        IF Pal2(3, i) > 0 THEN Pal2(3, i) = Pal2(3, i) - 1
    NEXT
   
    WAIT &H3DA, 8
NEXT

LINE (0, 0)-(MaxWidth, MaxHeight), 0, BF

END SUB