'===========================================================================
' Subject: TEXT PLASMA IMAGE VIEWER V.330    Date: 07-28-98 (06:43)       
' Author:  Andrew S. Gibson                  Code: QB, PDS                
' Origin:  zapf_dingbat@juno.com           Packet: GRAPHICS.ABC
'===========================================================================
' * YOU MUST LOAD QuickBASIC 4.X WITH /L/AH TO USE THIS PROGRAM *
' * (This code should be BASIC Professional Development System 7.1 / VBDOS
' * (compatible.)  If you can use this read all the comments before running *
' * Will run under windows, in full screen only. Windows may not emulate text
' * mode correctly so you might have to increase the Vertical Retrace Delay.
' * read internal help for instructions..
'
' -----Compilation for maximum speed is optional, but recommended!
' (after testing)  Have a clear line of sight to 'The Great White
' Throne' Handy. >:]
'
' This first appeared in the July ABC packet (07/98) / Month of publication.
'
' Text Plasma Image Viewer - Version .330 (you must have Text Plasma 2.6010á
' to create Text Plasma Image files <TPI files>)
'
' Features:
' o All 64 palette colors are used (text mode has 64 usable colors).
' o WOW ! The Palette can slide, to you or way from you !
' o You can adjust the Vertical Retrace Delay. !
' o New palette creation for, using the same palette routines in
'   Text Plasma 2.6010á. (can't be saved back to disk.)
'
' See the internal help...by typing 'TPIVIEW' (if compiled) !
'
' Bugs: `The Black Screen of Death' most common during new palette
'       generation (number overflow). I need to reduce some numbers.
'       If you in DOS just type 'MODE CO80' to return to normal.
'       In windows DOS shell you'll might need to press any key.
'
' Note: Errors aren't trapped yet, and this program verifies that the file
'       is a true TPI file and due to user error can create a null file.
'       (Normally that null file is destroyed.) You might run out of
'       space to open new files. Failures during loading can cause
'       `The Black Screen of Death'. The correct file size for a Text
'       Plasma Image file is 32,776 bytes. Any size below this indicates
'       a save failure...and the program automatically kills the file.
'
' Disclamer: I hearby disclaim all warranties to the fitness of this
'            program - I cannot be held liable for unpredicted events
'            that may happen while you used the revised version of
'            Text Plasma. I have tested this on 2 computers and it
'            works, although I will not (cannot) guarantee
'            functionality under your computer system's environment.
'
' Text Plasma Image Viewer - Version .330 (beta) by
' Zapf_DingBat@JUNO.COM (It's my Email address) It's ok to write...

DEFINT A-Z
DECLARE FUNCTION Monitor% (VSSegment)
DECLARE FUNCTION VerifyTPIHeader (NAME$, RETPIHEAD$)
DECLARE SUB ColorSelect ()
DECLARE SUB Delay (Period!)
DECLARE SUB Help ()
DECLARE SUB LoadTPIFile (NAME$)
DECLARE SUB STDOUT (MESSAGETEXT$)
DECLARE SUB PalGet (col%, R%, G%, B%)
DECLARE SUB PalSet (col%, R%, G%, B%)

'REGTYPE.BAS - Include file for CALL INTERRUPT & CALL INTERRUPTX
TYPE RegType
  AX    AS INTEGER
  BX    AS INTEGER
  CX    AS INTEGER
  DX    AS INTEGER
  BP    AS INTEGER
  SI    AS INTEGER
  DI    AS INTEGER
  flags AS INTEGER
  DS    AS INTEGER
  ES    AS INTEGER
END TYPE

' don't change the constants !
CONST TRUE = -1, FALSE = 0, SAVEINCMPLT = -2
CONST TPIHeader$ = "Text Plasma 2.40á - SnapShot Format Version .01á /TrueName:"
CONST Extension$ = ".TPI", TPIVIEWVersion$ = "Text Plasma Image Viewer - Version .330"
DIM SHARED Registers AS RegType
DIM SHARED CurrentPalR(0 TO 63), CurrentPalG(0 TO 63), CurrentPalB(0 TO 63)
DIM SHARED XRed(0 TO 63), XGrn(0 TO 63), XBlu(0 TO 63), PalSlide, Backwards

'set variable defaults
PalSlide = FALSE: Backwards = FALSE 'Default no Pal Sliding, rotation in Forward direction
RetraceDelay = 1 'Loop begins at Zero so this is two cycles

'test for help
IF COMMAND$ = "" OR COMMAND$ = "?" OR COMMAND$ = "/?" THEN Help
'test video capability
SELECT CASE Monitor%(SSeg)
       CASE 4, 5
           FOR CurPalSave = 0 TO 63 'save user's text mode palette
              PalGet CurPalSave, XRS, XGS, XBS
              CurrentPalR(CurPalSave) = XRS: CurrentPalG(CurPalSave) = XGS
              CurrentPalB(CurPalSave) = XBS
           NEXT CurPalSave
       CASE ELSE
           STDOUT "VGA or EGA Graphics adapter is required to view Text Plasma Images." + CHR$(10) + CHR$(13)
           END
END SELECT

STDOUT TPIVIEWVersion$ + CHR$(10) + CHR$(13) + CHR$(10)
FileNameTest = VerifyTPIHeader(COMMAND$, ReturnedHEADER$)
SELECT CASE FileNameTest
   CASE FALSE
      STDOUT COMMAND$ + CHR$(10) + CHR$(13)
      STDOUT "That wasn't a Text Plasma Image File." + CHR$(10) + CHR$(13)
      GOTO Term
   CASE TRUE
      IF LEN(COMMAND$) >= 49 THEN
         STDOUT COMMAND$ + CHR$(10) + CHR$(13)
         STDOUT "is a Text Plasma Image File." + CHR$(10) + CHR$(13)
      ELSE
         STDOUT COMMAND$ + CHR$(32) + "is a Text Plasma Image File." + CHR$(10) + CHR$(13)
      END IF
      STDOUT "Header: " + ReturnedHEADER$ + CHR$(10) + CHR$(13)
      Delay 3
   CASE SAVEINCMPLT
      IF LEN(COMMAND$) >= 18 THEN
         STDOUT COMMAND$ + CHR$(10) + CHR$(13)
         STDOUT "had a proper TPI File Header, but wasn't saved properly." + CHR$(10) + CHR$(13)
      ELSE
         STDOUT COMMAND$ + CHR$(32) + "had a proper TPI File Header, but wasn't saved properly." + CHR$(10) + CHR$(13)
      END IF
      STDOUT "File was deleted automatically...." + CHR$(10) + CHR$(13)
      GOTO Term
END SELECT

LoadTPIFile COMMAND$

FOR XBP = 0 TO 3
OUT 97, INP(97) OR &H3: OUT 67, 182
OUT 66, 80: OUT 66, 5: FOR ZZZ! = 0 TO 300: NEXT ZZZ!
OUT 97, INP(97) AND &HFC
Delay .11
NEXT XBP

'Seed the psuedo-random number generator with the current time.
DEF SEG = &H40
NewSeed& = PEEK(&H6C) + PEEK(&H6D) * 256& + PEEK(&H6E) * 65536
DEF SEG
NewSeed# = NewSeed& * 64& ^ 4& ' convert to huge integer
RANDOMIZE NewSeed#
     
DO

' Vertical retrace delay
FOR I = 0 TO RetraceDelay
 WAIT &H3DA, 8, 8
 WAIT &H3DA, 8, 0
NEXT I

'do palette sliding if enabled
IF PalSlide = TRUE THEN GOSUB MovePalette

    XXXX$ = UCASE$(INKEY$)
    IF XXXX$ = CHR$(27) THEN 'Exit
        EXIT DO
    END IF
    IF XXXX$ = CHR$(43) THEN 'Set rate of Retrace Delay, MORE WAITING
       RetraceDelay = RetraceDelay + 1
       IF RetraceDelay >= 400 THEN RetraceDelay = 400
    END IF
    IF XXXX$ = CHR$(45) THEN 'Set rate of Retrace Delay, LESS WAITING
       RetraceDelay = RetraceDelay - 1
       IF RetraceDelay <= 0 THEN RetraceDelay = 0
    END IF
    IF XXXX$ = CHR$(66) THEN 'set direction of palette sliding,
                             'Backwards = FALSE - forward rotation
                             'Backwards = TRUE - backward rotation
       Backwards = NOT Backwards
       'write colors again to prevent replicative fading
       FOR ColorWrite = 0 TO 63
        PalSet ColorWrite, XRed(ColorWrite), XGrn(ColorWrite), XBlu(ColorWrite)
       NEXT ColorWrite
    END IF
    IF XXXX$ = CHR$(73) THEN 'Invert Palette
       FOR IC = 0 TO 63
        PalGet IC, Red, Green, Blue
        PalSet IC, NOT Red, NOT Green, NOT Blue
        'recapture palette for storage
        PalGet IC, Red, Green, Blue
        XRed(IC) = Red: XGrn(IC) = Green: XBlu(IC) = Blue
       NEXT IC
    END IF
    IF XXXX$ = CHR$(78) THEN 'New palette
       ColoringMethod = INT(RND * 13)
       'ColoringMethod = 13 'used for testing
       ColorSelect
    END IF
    IF XXXX$ = CHR$(80) THEN 'Palette sliding on
       PalSlide = NOT PalSlide
    END IF

LOOP

'set screen mode
Registers.AX = &H3
CALL InterruptX(&H10, Registers, Registers)
Registers.AX = &H1003 'turn blinking on !
Registers.BX = &H1
CALL InterruptX(&H10, Registers, Registers)

Term:
FOR CurPalRest = 0 TO 63 'restore user's text mode palette
PalSet CurPalRest, CurrentPalR(CurPalRest), CurrentPalG(CurPalRest), CurrentPalB(CurPalRest)
NEXT CurPalRest
END

MovePalette:
IF Backwards = FALSE THEN
   PalGet 0, ored1%, ogrn1%, oblu1%
   FOR t% = 0 TO 63  'This loop rotates the palette outward (forward).
     PalGet t% + 1, Red%, Grn%, Blu%
     PalSet t%, Red%, Grn%, Blu%
   NEXT t%
   PalSet 63, ored1%, ogrn1%, oblu1%
 ELSE
   PalGet 63, ored2%, ogrn2%, oblu2%
   FOR t% = 62 TO 0 STEP -1 'This loop rotates the palette inward (Backward).
       PalGet t%, Red%, Grn%, Blu%
       PalSet t% + 1, Red%, Grn%, Blu%
   NEXT
   PalSet 0, ored2%, ogrn2%, oblu2%
END IF
RETURN

SUB ColorSelect
SELECT CASE ColoringMethod
  CASE IS = 0
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 63
     PalSet I, I - R, I - G, I - B
    NEXT I
  CASE IS = 1
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 31
     PalSet I, I * R, I * G, I * B
    NEXT I
    FOR I = 32 TO 63
     PalSet I, (15 - I) * R, (15 - I) * G, (15 - I) * B
    NEXT I
  CASE IS = 2
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 31
     PalSet I, (I / R) * 127, (I / G) * 127, (I / B) * 126
    NEXT I
    FOR I = 32 TO 63
     PalSet I, ((15 - I) / R), ((15 - I) / G), ((15 - I) / B)
    NEXT I
  CASE IS = 3
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 31
     PalSet I, (I / R), (I / G), (I / B)
    NEXT I
    FOR I = 32 TO 63
     PalSet I, ((15 - I) / R) * 127, ((15 - I) / G) * 127, ((15 - I) / B) * 127
    NEXT I
  CASE IS = 4
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 31
     PalSet I, (I / R) * 127, (I / G) * 127, (I / B) * 127
    NEXT I
    FOR I = 32 TO 63
     PalSet I, ((15 - I) / R) * 127, ((15 - I) / G) * 127, ((15 - I) / B) * 127
    NEXT I
  CASE IS = 5
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 63
     PalSet I, INT(R + R2), INT(G + G2), INT(B + B2)
     R2 = (R + 1) * I ^ .11: G2 = (G + 1) * I ^ .22: B2 = (B + 1) * I ^ .33
    NEXT I
  CASE IS = 6
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 63
     PalSet I, INT(R + R2), INT(G + G2), INT(B + B2)
     R2 = (R + 1) * I ^ .22: G2 = (G + 1) * I ^ .33: B2 = (B + 1) * I ^ .11
    NEXT I
  CASE IS = 7
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 63
     PalSet I, INT(R + R2), INT(G + G2), INT(B + B2)
     R2 = (R + 1) * I ^ .33: G2 = (G + 1) * I ^ .11: B2 = (B + 1) * I ^ .22
    NEXT I
  CASE IS = 8
   R = (RND * 63): G = (RND * 63): B = (RND * 63)
    FOR I = 0 TO 63
     PalSet I, INT(R + R2), INT(G + G2), INT(B + B2)
     R2 = ((R + 1 + I) * .11): G2 = ((G + 1 + I * .59)): B2 = ((B + 1 + I * .3))
    NEXT I
  CASE IS = 9 'GRAY 1
   R = (RND * 63): G = R: B = R
    FOR I = 0 TO 63
     PalSet I, XC, XC, XC
     R2 = ((R + 1 + I) * .11): G2 = ((G + 1 + I * .59)): B2 = ((B + 1 + I * .3))
     XC = INT(R2 + G2 + B2)
    NEXT I
  CASE IS = 10 'GRAY 2
   R = (RND * 63): G = R: B = R
    FOR I = 0 TO 63
     PalSet I, XC, XC, XC
     R2 = ((R + 1 + I) * .11) ^ 2: G2 = ((G + 1 + I * .59)): B2 = ((B + 1 + I * .3))
     XC = INT(R2 + G2 + B2)
    NEXT I
  CASE IS = 11 'GRAY 3
   R = (RND * 63): G = R: B = R
    FOR I = 0 TO 63
     PalSet I, XC, XC, XC
     R2 = ((R + 1 + I) * .11): G2 = ((G + 1 + I * .59)) ^ 2: B2 = ((B + 1 + I * .3))
     XC = INT(R2 + G2 + B2)
    NEXT I
  CASE IS = 12 'GRAY 4
   R = (RND * 63): G = R: B = R
    FOR I = 0 TO 63
     PalSet I, XC, XC, XC
     R2 = ((R + 1 + I) * .11): G2 = ((G + 1 + I * .59)): B2 = ((B + 1 + I * .3)) ^ 2
     XC = INT(R2 + G2 + B2)
    NEXT I
  CASE IS = 13
   R = (RND * 63): G = R: B = R
    FOR I = 0 TO 63
     PalSet I, XC \ 2, XC \ 4, XC \ 8
     R2 = ((R + 1 + I) * .11): G2 = ((G + 1 + I * .59)): B2 = ((B + 1 + I * .3)) ^ 2
     XC = INT(R2 + G2 + B2)
    NEXT I
END SELECT

'capture new colors into arrary
FOR ColorCapture = 0 TO 63
 PalGet ColorCapture, XR, XG, XB
 XRed(ColorCapture) = XR: XGrn(ColorCapture) = XG: XBlu(ColorCapture) = XB
NEXT ColorCapture
END SUB

SUB Delay (Period!)
Begin! = TIMER
DO UNTIL (TIMER - Begin! > Period!) OR (TIMER - Begin! < 0)
LOOP
END SUB

SUB Help
STDOUT TPIVIEWVersion$ + CHR$(10) + CHR$(13)
STDOUT CHR$(10) + CHR$(13)
STDOUT "Purpose: Views images made with Text Plasma program." + CHR$(10) + CHR$(13)
STDOUT "Usage: TPIVIEW filename.ext" + CHR$(10) + CHR$(13) + CHR$(10)
STDOUT "Once a TPI file is loaded, you can use these functions." + CHR$(10) + CHR$(13) + CHR$(10)
STDOUT "Press N for a new fresh & zesty palette." + CHR$(10) + CHR$(13)
STDOUT "Press P to slide the current palette, default is off (toggle switch)." + CHR$(10) + CHR$(13)
STDOUT "Press B to slide the current backwards, default is forward (toggle switch)." + CHR$(10) + CHR$(13)
STDOUT "Press + to increase the Vertical Retrace Delay. (minimum 0)" + CHR$(10) + CHR$(13)
STDOUT "Press - to decrease the Vertical Retrace Delay. (maximum 400)" + CHR$(10) + CHR$(13)
END
END SUB

SUB LoadTPIFile (NAME$)
'set screen mode
Registers.AX = &H3
CALL InterruptX(&H10, Registers, Registers)
OUT &H3D4, 9: OUT &H3D5, 1  'Two Scan lines
Registers.AX = &H1003 'turn blinking off !
Registers.BX = &H0
CALL InterruptX(&H10, Registers, Registers)

' begin loading file
OPEN NAME$ FOR BINARY AS #1
SEEK #1, 73 'seek past header

RGB$ = SPACE$(3) 'load stored palette
FOR LoadPalette = 0 TO 63 'load stored palette
GET #1, , RGB$
XRR$ = MID$(RGB$, 1, 1): XGR$ = MID$(RGB$, 2, 1): XBR$ = MID$(RGB$, 3, 1)
IF XRR$ = "" THEN XRR$ = CHR$(0) 'quick way to get around that damn ASC bug
IF XGR$ = "" THEN XGR$ = CHR$(0) 'quick way to get around that damn ASC bug
IF XBR$ = "" THEN XBR$ = CHR$(0) 'quick way to get around that damn ASC bug
XRR = ASC(XRR$): XGR = ASC(XGR$): XBR = ASC(XBR$)
PalSet LoadPalette, XRR, XGR, XBR
NEXT LoadPalette

'Load stored ScreenGarbage
GarbageFontBank$ = SPACE$(512)
GET #1, , GarbageFontBank$
Registers.AX = &H1100 'AX tells call DOS set font routine
Registers.BX = &H200  'BX tells DOS to store 08 lines per char and font bank 0
Registers.CX = &H100  'CX tells DOS to change all characters
Registers.DX = 0      'DX tells DOS which char to start from
' for PDS change VARSEG to SSEG
Registers.ES = VARSEG(GarbageFontBank$) ' ES tells DOS where the segment is
Registers.BP = SADD(GarbageFontBank$)   ' BP tells DOS where the address is
CALL InterruptX(&H10, Registers, Registers) ' call int 10 and make changes
GarbageFontBank$ = ""

' load stored characters and attributes
DWORDBuffer$ = SPACE$(8)
DEF SEG = &HB800
FOR SCRLoad = 0 TO 31999 STEP 8
GET #1, , DWORDBuffer$
FOR WNL = 0 TO 7
WNL$ = MID$(DWORDBuffer$, WNL + 1, 1)
IF WNL$ = "" THEN WNL$ = CHR$(0) 'quick way to get around that damn ASC bug
BYT = ASC(WNL$): POKE SCRLoad + WNL, BYT
NEXT WNL
NEXT SCRLoad
DEF SEG
CLOSE

FOR PC = 0 TO 63
 'capture palette for storage & manipulation
 PalGet PC, Red, Green, Blue
 XRed(PC) = Red: XGrn(PC) = Green: XBlu(PC) = Blue
NEXT PC
END SUB

FUNCTION Monitor% (VSSegment)
DEF SEG = 0              'first see if it's color or mono
VSSegment = &HB800         'assume color
IF PEEK(&H463) = &HB4 THEN
  VSSegment = &HB000       'assign the monochrome segment
  Status = INP(&H3BA)    'get the current video status
  FOR X = 1 TO 30000     'test for a Hercules 30000 times
    IF INP(&H3BA) <> Status THEN
      Monitor% = 2       'the port changed, it's a Herc
      EXIT FUNCTION      'all done
    END IF
  NEXT
  Monitor% = 1           'it's a plain monochrome
ELSE                     'it's some sort of color monitor
  Registers.AX = &H1A00     'first test for VGA
  CALL InterruptX(&H10, Registers, Registers)
  IF (Registers.AX AND &HFF) = &H1A THEN
    Monitor% = 5         'it's a VGA
    EXIT FUNCTION        'all done
  END IF
  Registers.AX = &H1200     'now test for EGA
  Registers.BX = &H10
  CALL InterruptX(&H10, Registers, Registers)
  IF (Registers.BX AND &HFF) = &H10 THEN
    Monitor% = 3         'if BL is still &H10 it's a CGA
  ELSE
    Monitor% = 4         'otherwise it's an EGA
  END IF
END IF
DEF SEG
END FUNCTION

SUB PalGet (col%, R%, G%, B%)
OUT &H3C7, col%: R = INP(&H3C9): G = INP(&H3C9): B = INP(&H3C9)
END SUB

SUB PalSet (col%, R%, G%, B%)
OUT &H3C8, col%: OUT &H3C9, R: OUT &H3C9, G: OUT &H3C9, B
END SUB

SUB STDOUT (MESSAGETEXT$)
'writes text to dos's standard output
Registers.AX = &H4000
Registers.BX = &H1
Registers.CX = LEN(MESSAGETEXT$)
' for PDS change VARSEG to SSEG
Registers.DS = VARSEG(MESSAGETEXT$)
Registers.DX = SADD(MESSAGETEXT$)
CALL InterruptX(&H21, Registers, Registers)
END SUB

FUNCTION VerifyTPIHeader (NAME$, RETPIHEAD$)
OPEN NAME$ FOR BINARY AS #1
CompleteHeader$ = SPACE$(71): GET #1, , CompleteHeader$: FileLen& = LOF(1)
CLOSE
IF LEFT$(CompleteHeader$, 59) = TPIHeader$ THEN
   VerifyTPIHeader = TRUE: RETPIHEAD$ = CompleteHeader$
   'test for complete save failure
   IF FileLen& <> 32776 THEN KILL NAME$: VerifyTPIHeader = SAVEINCMPLT
ELSE
   VerifyTPIHeader = FALSE: RETPIHEAD$ = ""
   IF FileLen& = 0 THEN KILL NAME$
END IF
END FUNCTION