'===========================================================================
'  Here's some code for SWAG to dump the current mode $13 screen to a
'  PCX file.  Feel free to use/modify, just give credit.  Also, if you
'  do a good mod of it (ie, A mode X version, faster compression, whatever),
'  I'd love to see it.
'
'  Reference: Bit-Mapped Graphics (2nd Edition)
'    Steve Rimmer
'    ISBN 0-8306-4209-9
'    (C code but still pretty useful)
'
'  PCX is of course (tm) Z-Soft Corp.
'
'  Copyright 1995 Kevin M. Luck  <-- Original Turbo Pascal code.
'---------------------------------------------------------------------------
' Thanks Kevin.  This code has been converted to BASIC by William Yu (12/96)
'
' Remember what good programmers do:  Give credit where credit is due!
'
' Somewhat useless with all the screen capture utilities out there ;)
' But an excellent tool for use with your own paint programs and such...
'
' This only supports 1 plane video modes, but I'm working on a 4 plane one.
'===========================================================================

DEFINT A-Z
DECLARE SUB WriteHeader (PCXName$)
DECLARE SUB EncodeLine (Ln)
DECLARE SUB GetPal (ColorNo, R, G, B)
DECLARE SUB WritePalette ()
DECLARE SUB SavePCX (PCXName$)

DIM SHARED PCXFile AS INTEGER

  SCREEN 13
  RANDOMIZE TIMER
  I = 0
  DO
    X = RND * 319
    Y = RND * 199
    R = RND * 50
    I = I + 1
    CIRCLE (X, Y), R, I    ' Let's draw random circles.
  LOOP UNTIL I = 150

  SavePCX "IMAGE.PCX"

END

' Color Palette Setting.  Can't make any sense out of this.
' You'll find that with 4 plane modes or other PCX codes use
' the palette scheme from Black --> Bright White.
' (ie.  0,0,0 = Black  255,255,255 = Bright White)

DATA 0,0,0,216,152,56,120,116,4,112,108,4,236
DATA 172,76,248,196,128,64,36,36,36,40,20,248
DATA 188,104,212,144,156,60,36,36,116,112,8
DATA 120,116,8,124,120,8,52,48,4,240,196,136

SUB EncodeLine (Ln)
'**********************************************
'  Encode the current image on screen
'
'  Kevin Luck seems to be on the lazy side :)
'  This will only work for 1 plane video modes.
'  Hehe, that would limit it to SCREEN 13 Doh!
'***********************************************

DIM P(0 TO 321) AS INTEGER

  T = 0
  DEF SEG = &HA000                  ' Must be a faster way using
  FOR N = 0 TO 320                  ' buffered routines.
    P(N) = PEEK((Ln * 320!) + N)    ' MOVE Addr(Ln*320) --> P()
    POKE ((Ln * 320!) + N), 0       ' Erase screen.  Remove if desired.
  NEXT N
  WHILE T < 320
    I = 0
    WHILE ((P(T + I) = P(T + I + 1)) AND ((T + I) < 320) AND (I < 63))
      I = I + 1                ' Same colour
    WEND
    IF I > 0 THEN              ' How many times does the same colour occur?
      A$ = CHR$(I OR 192)      ' Limit of 63.
      PUT #PCXFile, , A$
      A$ = CHR$(P(T))          ' Write pixel colour
      PUT #PCXFile, , A$
      T = T + I
    ELSE
      IF (P(T) AND 192) = 192 THEN  ' It's greater than 192
         A$ = CHR$(193)             ' Weird stuff...
         PUT #PCXFile, , A$
      END IF
      A$ = CHR$(P(T))               ' Write Pixel colour.
      PUT #PCXFile, , A$
      T = T + 1
    END IF
  WEND
END SUB

SUB GetPal (ColorNo, R, G, B)
'*********************************************************************
'  Get Current Palette Scheme (Does not change unless you change it)
'*********************************************************************
  OUT &H3C7, ColorNo    ' Read Color's...
  R = INP(&H3C9)        ' Red Intensity
  G = INP(&H3C9)        ' Green Intensity
  B = INP(&H3C9)        ' Blue Intensity
END SUB

SUB SavePCX (PCXName$)
  WriteHeader PCXName$
  FOR Ln = 0 TO 199
    EncodeLine Ln
  NEXT Ln
  WritePalette
  CLOSE PCXFile
END SUB

SUB WriteHeader (PCXName$)
'************************************
'  Dump the default header to file
'************************************

DIM OldPal(1 TO 48) AS INTEGER

  PCXFile = FREEFILE
  OPEN PCXName$ FOR BINARY AS PCXFile
  B$ = CHR$(10)               ' Manufacturer.  ZSoft of course.
  PUT #PCXFile, , B$
  B$ = CHR$(5)                ' Version, in case it matters.
                              ' 0 = Version 2.5 of PC Paintbrush
                              ' 2 = Version 2.8 w/palette information
                              ' 3 = Version 2.8 w/o palette information
                              ' 4 = PC Paintbrush for Windows(Plus for Windows uses Ver 5)
                              ' 5 = Version 3.0 and > of PC Paintbrush and PC Paintbrush +, includes
  PUT #PCXFile, , B$          ' Publisher's Paintbrush . Includes 24-bit .PCX files
  B$ = CHR$(1)                ' Encoding
  PUT #PCXFile, , B$
  B$ = CHR$(8)                ' Bytes Per Pixel (1 for 4 plane)
  PUT #PCXFile, , B$
  B$ = CHR$(0) + CHR$(0)      ' Min X (Integer deserves 2 bytes)
  PUT #PCXFile, , B$
  B$ = CHR$(0) + CHR$(0)      ' Min Y
  PUT #PCXFile, , B$
  B$ = CHR$(63) + CHR$(1)     ' Max X  (In this case it's 319)
  PUT #PCXFile, , B$          ' Try 319 AND &HFF and you'll see
  B$ = CHR$(199) + CHR$(0)    ' Max Y
  PUT #PCXFile, , B$
  B$ = CHR$(64) + CHR$(1)     ' Horizontal Resolution
  PUT #PCXFile, , B$
  B$ = CHR$(200) + CHR$(0)    ' Vertical Resolution
  PUT #PCXFile, , B$          ' Default Palette
  FOR I = 1 TO 48
    READ OldPal(I)            ' Mem [Seg (OldPal):Ofs (OldPal)],48)
    B$ = CHR$(OldPal(I))      ' I'm sure there's a faster way to do this
    PUT #PCXFile, , B$        ' But I'm not good with converting that TP code
  NEXT I
  B$ = CHR$(0)                ' Reserved
  PUT #PCXFile, , B$
  B$ = CHR$(1)                ' Color Planes (4 = Intense, Red, Green, Blue)
  PUT #PCXFile, , B$
  B$ = CHR$(64) + CHR$(1)     ' Bytes Per Line Per Plane (In this case 320)
  PUT #PCXFile, , B$
  B$ = CHR$(0) + CHR$(0)      ' Palette Type
  PUT #PCXFile, , B$
  B$ = STRING$(58, CHR$(0))   ' Fill rest of header to viola!  128 bytes.
  PUT #PCXFile, , B$          ' Actually byte 70-74 is for Paint Brush IV/IV+
                              ' so it should be 54, but who cares.
END SUB

SUB WritePalette
'************************************
'  Dump the current Palette to file
'************************************
  L$ = CHR$(12)
  PUT #PCXFile, , L$
  FOR L = 0 TO 255
    GetPal L, R, G, B
    R = R * 4
    G = G * 4
    B = B * 4
    R$ = CHR$(R)
    G$ = CHR$(G)
    B$ = CHR$(B)
    PUT #PCXFile, , R$
    PUT #PCXFile, , G$
    PUT #PCXFile, , B$
  NEXT L
END SUB