'===========================================================================
' Subject: TV-TEST SCREEN                    Date: 06-03-98 (19:13)       
' Author:  Viktor Rootselainen               Code: QB, QBasic, PDS        
' Origin:  viktor.rootselainen@pp.inet.fi  Packet: GRAPHICS.ABC
'===========================================================================
'TV-test v1.0  1998 (c)Viktor Rootselainen   
'this program is freeware(z)

DEFINT A-Z
DECLARE SUB dely (time%)
DECLARE SUB DrawTV ()
DECLARE SUB GfxPrint (txt$, x%, y%)
DECLARE SUB Makepal ()
DECLARE SUB pal (r%, g%, b%, c%)
DECLARE SUB palsub (Act$, delaytime%)
COMMON SHARED orgpal$, tvtext$
DIM SHARED palr(255), palg(255), palb(255)
tvtext$ = "Nelonen": RANDOMIZE TIMER
IF LEN(COMMAND$) THEN tvtext$ = COMMAND$   '<-- remove this line in Qbasic
IF LEN(tvtext$) > 14 THEN tvtext$ = LEFT$(tvtext$, 14)
SCREEN 13

DrawTV
SLEEP 10
palsub "save", 0: palsub "BW", 0    ': palsub "fadeout", 30

DEF SEG = &HA000
FOR x = 0 TO 319: FOR y = 0 TO 199
  POKE y * 320& + x, RND * 255       'RND is very slow...
NEXT: NEXT

FOR i = 1 TO 20: k$ = INKEY$: NEXT   'clear keyboard buffer
'palsub "fadein", 20

DO
 pal RND * 63, RND * 63, RND * 63, (RND * 254) + 1
LOOP WHILE INKEY$ = ""

palsub "fadeout", 15
SCREEN 0: WIDTH 80, 25

palsub "save", 0: palsub "blackout", 0
PRINT "TV-test screen  by Viktor Rootselainen   1998"
palsub "fadein", 10

DATA 31,14,11,10,13,12,9,0

' Millisecond delay routine
' The time variable can be any integer value
' 1 = one millisecond, 1000 = one second 32767 = 32 seconds.
SUB dely (time)

OUT &H61, INP(&H61) AND &HFC
OUT &H43, &HB4
OUT &H42, 166
OUT &H42, 4
OUT &H61, INP(&H61) OR 1

FOR N = 1 TO time STEP 1
    DO
        OUT &H43, &H80
        t = INP(&H42)
    LOOP WHILE INP(&H42) > 2
    DO
        OUT &H43, &H80
        t = INP(&H42)
    LOOP WHILE INP(&H42) <= 2
NEXT N
END SUB

SUB DrawTV
boxstep = 20

FOR i = 0 TO 63: pal -i, 0, 0, i + 100: NEXT    'red
FOR i = 0 TO 63: pal 0, 0, -i, i + 163: NEXT    'blue
FOR i = 0 TO 5: pal 63, 47 + i, 0, 44 + i: NEXT
pal 45, 49, 45, 42


FOR x = 0 TO 320 STEP boxstep
  LINE (x, 0)-(x, 200): LINE (0, x)-(320, x): NEXT
FOR x = 1 TO 320 STEP boxstep: FOR y = 1 TO 200 STEP boxstep
  PAINT (x, y), 8, 15
NEXT: NEXT

LINE (60, 19)-(260, 180), 15, BF
FOR i = 61 TO 240 STEP 25
READ colr: LINE (i, 20)-(i + 24, 60), colr, BF: NEXT
LINE (260, 19)-(260, 70), 15

LINE (61, 61)-(99, 90), 17, BF
LINE (99, 61)-(137, 90), 25, BF
LINE (137, 61)-(175, 90), 27, BF
LINE (175, 61)-(213, 90), 28, BF
LINE (98, 92)-(213, 105), 0, BF
LINE (79, 106)-(259, 123), 28, BF
LINE (200, 106)-(250, 123), 43, BF
FOR x = 0 TO 5
LINE (195 + x, 106)-(195 + x, 123), 48 - x, BF
LINE (247 + x, 106)-(247 + x, 123), 43 + x, BF
NEXT

FOR i = 0 TO 24: IF i AND 1 THEN COLOR 15 ELSE COLOR 0
LINE (170 + i, 106)-(170 + i, 123): NEXT

FOR i = 0 TO 25: IF temp <= 1 THEN COLOR 0 ELSE COLOR 15
  LINE (125 + i, 106)-(125 + i, 123): temp = temp + 1: IF temp > 3 THEN temp = 0
NEXT: temp = 3
  
FOR i = 0 TO 34: IF temp < 3 THEN COLOR 0 ELSE COLOR 25 + temp
  LINE (84 + i, 106)-(84 + i, 123): temp = temp + 1: IF temp > 6 THEN temp = 0
NEXT

LINE (157, 124)-(157, 150), 0: LINE (163, 124)-(157, 150), 0
LINE (157, 124)-(163, 124): PAINT (159, 130), 0

LINE (160, 60)-(160, 123), 15
LINE (61, 140)-(120, 160), 101, BF
LINE (61, 161)-(120, 179), 9, BF
colr = 100: FOR x = 117 TO 180
colr = colr + 1
FOR y = 140 TO 160: PSET (x, y), colr: NEXT
FOR y = 161 TO 179: PSET (x, y), colr + 63: NEXT: NEXT
LINE (180, 140)-(259, 179), 42, BF
LINE (220, 140)-(220, 179), 15
COLOR 15: GfxPrint tvtext$, 94, 95
CIRCLE (160, 100), 118, 15

END SUB

SUB GfxPrint (txt$, x, y)
DIM bitmask(7)
FOR a = 0 TO 7
bitmask(a) = 2 ^ (7 - a)
NEXT a

DEF SEG = &HF000
FOR luuppi = 1 TO LEN(txt$)
FOR loopx = 0 TO 7
FOR loopy = 0 TO 7
IF PEEK(&HFA6E + (ASC(MID$(txt$, luuppi, 1)) * 8) + loopy) AND bitmask(loopx) THEN PSET (loopx + luuppi * 8 + x, loopy + y)
NEXT: NEXT: NEXT
DEF SEG
END SUB

SUB Makepal
PRINT "wait a moment..."

pal2$ = orgpal$: pal3$ = orgpal$
MYPI! = 8 * ATN(1) / 240
FOR colr = 0 TO 239
                R1 = 32 + SIN((colr + 0) * MYPI!) * 31
                G1 = 32 + SIN((colr + 80) * MYPI!) * 31
                B1 = 32 + SIN((colr + 160) * MYPI!) * 31
                R2 = 32 + SIN((colr + 10) * MYPI!) * 31
                G2 = 32 + SIN((colr + 30) * MYPI!) * 31
                B2 = 32 + SIN((colr + 50) * MYPI!) * 31
                OFFSET = ((colr + 16) * 3)
                MID$(pal2$, OFFSET + 1, 1) = CHR$(R1)  '* RED
                MID$(pal2$, OFFSET + 2, 1) = CHR$(G1)  '* GREEN
                MID$(pal2$, OFFSET + 3, 1) = CHR$(B1)  '* BLUE
                MID$(pal3$, OFFSET + 1, 1) = CHR$(R2)  '* RED
                MID$(pal3$, OFFSET + 2, 1) = CHR$(G2)  '* GREEN
                MID$(pal3$, OFFSET + 3, 1) = CHR$(B2)  '* BLUE
NEXT colr
CLS
END SUB

SUB pal (r, g, b, c)
OUT &H3C8, c
OUT &H3C9, r
OUT &H3C9, g
OUT &H3C9, b
END SUB

SUB palsub (Act$, delaytime)
   SELECT CASE UCASE$(Act$)
   ' "save","fadein","fadeout","restore","blackout","bw"
      CASE "SAVE"
         FOR colour% = 0 TO 255
            OUT &H3C7, colour%        ' Set color to read
            palr(colour%) = INP(&H3C9)   ' read red value
            palg(colour%) = INP(&H3C9)   ' read green value
            palb(colour%) = INP(&H3C9)   ' read blue value
         NEXT
      CASE "FADEIN"
         DO
            done% = 0
            FOR colour% = 0 TO 255
               OUT &H3C7, colour%       ' Set color to read
               Red% = INP(&H3C9)        ' read red value
               grn% = INP(&H3C9)        ' read green value
               blu% = INP(&H3C9)        ' read blue value
               ' Test the color values, decrementing if necessary.
               ' Set loop variable if saved palette not in use.
               IF Red% < palr(colour%) THEN Red% = Red% + 1: done% = 1
               IF grn% < palg(colour%) THEN grn% = grn% + 1: done% = 1
               IF blu% < palb(colour%) THEN blu% = blu% + 1: done% = 1
               WAIT &H3DA, 8, 8
               OUT &H3C8, colour%       ' Set color to write
               OUT &H3C9, Red%          ' write red value
               OUT &H3C9, grn%          ' write green value
               OUT &H3C9, blu%          ' write blue value
            NEXT
            IF delaytime THEN dely delaytime
         LOOP WHILE done% <> 0
      CASE "FADEOUT"
         DO
            visible% = 0
            FOR colour% = 0 TO 255
               OUT &H3C7, colour%       ' Set color to read
               Red% = INP(&H3C9)        ' read red value
               grn% = INP(&H3C9)        ' read green value
               blu% = INP(&H3C9)        ' read blue value
               ' Test the color values, decrementing if necessary.
               ' Set loop variable if colors are still visible.
               IF Red% > 0 THEN Red% = Red% - 1: visible% = 1
               IF grn% > 0 THEN grn% = grn% - 1: visible% = 1
               IF blu% > 0 THEN blu% = blu% - 1: visible% = 1
               WAIT &H3DA, 8, 8
               OUT &H3C8, colour%       ' Set color to write
               OUT &H3C9, Red%          ' write red value
               OUT &H3C9, grn%          ' write green value
               OUT &H3C9, blu%          ' write blue value
            NEXT
            IF delaytime THEN dely delaytime
         LOOP WHILE visible% <> 0
      CASE "RESTORE"
         FOR colour% = 0 TO 255
            OUT &H3C8, colour%          ' Set color to write
            OUT &H3C9, palr(colour%)     ' write red value
            OUT &H3C9, palg(colour%)     ' write green value
            OUT &H3C9, palb(colour%)     ' write blue value
         NEXT
      CASE "BLACKOUT"
         FOR colour% = 0 TO 255
            OUT &H3C8, colour%          ' Set color to write
            OUT &H3C9, 0                ' write red value
            OUT &H3C9, 0                ' write green value
            OUT &H3C9, 0                ' write blue value
         NEXT
      CASE "BW"   'blackwhite is not correct
        FOR c = 0 TO 255
            a = (palr(c) + palg(c) + palb(c)) / 3: pal a, a, a, c
         NEXT
   END SELECT
END SUB