REM - SaveILBM
REM -  by Carolyn Scheppner  CBM  04/86

REM - This program saves a demo custom
REM -  screen as an IFF ILBM file.
REM -  (Graphicraft,Deluxe Paint, etc.)

REM - No icon is created for the file.
REM -  If you need one, copy the .info
REM -  file of a Graphicraft pic and
REM -  call it filename.info

REM - Color cycling variables are
REM -  saved as a Graphicraft CCRT
REM -  chunk.  The program could be
REM -  modified to save color cycling
REM -  information as DPaint CRNG
REM -  chunks.

REM - Requires exec, graphics and dos
REM -  .bmaps (Use NewConvertFD)
REM

Main:

PRINT "SaveILBM --- Saves a screen as an IFF ILBM file"
PRINT 
PRINT " This program creates a demo screen and saves it as an"
PRINT "IFF ILBM pic file which can be loaded in Graphicraft,"
PRINT "DPaint, or Images.  (For Images, add '.pic' to filename)"
PRINT
PRINT " Color cycling data is saved as a Graphicraft CCRT chunk."
PRINT "No icon is created for the save file.  If you need one,"
PRINT "copy the .info file of one of your paint package's pics"
PRINT "and rename it to match the name of your saved pic file."
PRINT:PRINT
PRINT:PRINT "ENTER FILESPEC:"
PRINT "( Try Screen.ILBM )"
PRINT "( Enter <RETURN> for NO save file )"
PRINT
INPUT "FileSpec for ILBM save file";ILBMname$
PRINT


DIM bPlane&(5), cTabSave%(32)

REM - Functions from dos.library                   
DECLARE FUNCTION xOpen&  LIBRARY
DECLARE FUNCTION xRead&  LIBRARY
DECLARE FUNCTION xWrite& LIBRARY
DECLARE FUNCTION IoErr&  LIBRARY
REM - xClose returns no value

REM - Functions from exec.library
DECLARE FUNCTION AllocMem&() LIBRARY
REM - FreeMem returns no value

PRINT:PRINT "Looking for bmaps ... ";
LIBRARY "dos.library"
LIBRARY "exec.library"
LIBRARY "graphics.library"
PRINT "found them."

REM  Custom Screen, some graphics
w = 320: h = 200: d = 5

AvailRam& = FRE(-1)
NeededRam& = ((w/8)*h*(d+1))+5000
IF AvailRam& < NeededRam& THEN
   PRINT "Not enough free ram"
   GOTO Mcleanup2
END IF   

SCREEN 2,w,h,d,1
t$=" SaveILBM"
WINDOW 2,t$,,15,2
PALETTE 0,1,1,1
PALETTE 1,0.2,0.4,0.8

REM - Get Screen structure addresses
GOSUB GetScrAddrs

REM - Init color cycling variables
REM - (Init to 0 for no cycling)
REM - These variables must be initialized
REM - because this version of SaveILBM
REM - always saves a Graphicraft CCRT chunk
ccrtDir%   = 1
ccrtStart% = 1
ccrtEnd%   = nColors% - 1
ccrtSecs&  = 0
ccrtMics&  = 2000

REM - Draw some lines to cycle  
cReg = ccrtStart% 
x = 20 
FOR y = 0 TO 80
     LINE (x,y)-(w-x-10,180-y),cReg,b
     x = x + 1
     cReg = cReg + 1: IF cReg > ccrtEnd% THEN cReg = ccrtStart%
NEXT

REM - Demo color cycling
REM - Save colors
FOR kk = 0 TO nColors% -1
   cTabSave%(kk) = PEEKW(colorTab&+(kk*2))   
NEXT
   
REM - Cycle colors
deSecs& = ccrtSecs& * 3000
deMics& = ccrtMics& / 500
cStart& = colorTab& + (2*ccrtStart%)
cEnd&   = colorTab& + (2*ccrtEnd%)
repeat  = 80

IF ccrtDir% = 1 THEN GOSUB Fcycle :ELSE GOSUB Bcycle

REM - Restore colors
CALL LoadRGB4&(sViewPort&,VARPTR(cTabSave%(0)),nColors%)


REM - Save screen as ILBM file
IF (ILBMname$<>"") THEN
   saveError$ = ""
   GOSUB SaveILBM
END IF

Mcleanup:
FOR de = 1 TO 5000:NEXT
WINDOW CLOSE 2
SCREEN CLOSE 2

Mcleanup2:
LIBRARY CLOSE
IF saveError$ <> "" THEN PRINT saveError$
END


Fcycle:
FOR kk = 0 TO repeat
   cTemp% = PEEKW(cStart&)
   FOR jj& = cStart& + 2 TO cEnd& STEP 2
      POKEW(jj&-2), PEEKW(jj&)
   NEXT
   POKEW cEnd&, cTemp%
   CALL LoadRGB4&(sViewPort&,colorTab&,nColors%)
   FOR d1& = 0 TO deSecs&
      FOR d2& = 0 TO deMics&:NEXT
   NEXT   
NEXT
RETURN

Bcycle:   
FOR kk = 0 TO repeat   
   cTemp% = PEEKW(cEnd&)
   FOR jj& = cEnd& - 2 TO cStart& STEP -2
      POKEW(jj&+2), PEEKW(jj&)
   NEXT
   POKEW(cStart&) = cTemp%
   CALL LoadRGB4&(sViewPort&,colorTab&,nColors%)
   FOR d1& = 0 TO deSecs&
      FOR d2& = 0 TO deMics&:NEXT
   NEXT   
NEXT
RETURN


SaveILBM:
REM - Saves current window's screen
REM -  as an IFF ILBM file with a
REM -  Graphicraft CCRT cycling chunk.
REM - Requires the following variables
REM -  to have been initialized:
REM -    ILBMname$ (ILBM filespec)
REM - Also, cycling variables
REM -    ccrtDir% (1,-1, or 0 = none)
REM -    ccrtStart% (low cycle reg)
REM -    ccrtEnd%   (high cycle reg)
REM -    ccrtSecs&  (cycle time in seconds)
REM -    ccrtMics&  (cycle time in microseconds)
REM 


REM - init variables
f$ = ILBMname$
fHandle& = 0
mybuf& = 0

filename$ = f$ + CHR$(0)
fHandle& = xOpen&(SADD(filename$),1006)
IF fHandle& = 0 THEN
   saveError$ = "Can't open output file"
   GOTO Scleanup
END IF

REM - Alloc ram for work buffers
ClearPublic& = 65537
mybufsize& = 120
mybuf& = AllocMem&(mybufsize&,ClearPublic&)
IF mybuf& = 0 THEN
   saveError$ = "Can't alloc buffer"
   GOTO Scleanup
END IF

cbuf& = mybuf&

REM - Get addresses of screen structures
GOSUB GetScrAddrs

zero& = 0
pad%  = 0
aspect% = &Ha0b

REM - Compute chunk sizes
BMHDsize& = 20
CMAPsize& = (2^scrDepth%) * 3
CAMGsize& = 4
CCRTsize& = 14
BODYsize& = (scrWidth%/8) * scrHeight% * scrDepth%
REM - FORMsize& = Chunk sizes + 8 bytes per Chunk header + "ILBM"
FORMsize& = BMHDsize&+CMAPsize&+CAMGsize&+CCRTsize&+BODYsize&+44

REM - Write FORM header
tt$ = "FORM"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(FORMsize&),4)
tt$ = "ILBM"
wLen& = xWrite&(fHandle&,SADD(tt$),4)

IF wLen& <= 0 THEN
   saveError$ = "Error writing FORM header"
   GOTO Scleanup
END IF   

REM - Write out BMHD chunk
tt$ = "BMHD"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(BMHDsize&),4)
wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)
wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
temp% = (256 * scrDepth%)
wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
wLen& = xWrite&(fHandle&,VARPTR(zero&),4)
wLen& = xWrite&(fHandle&,VARPTR(aspect%),2)
wLen& = xWrite&(fHandle&,VARPTR(scrWidth%),2)
wLen& = xWrite&(fHandle&,VARPTR(scrHeight%),2)

IF wLen& <= 0 THEN
   saveError$ = "Error writing BMHD"
   GOTO Scleanup
END IF   

REM - Write CMAP chunk
tt$ = "CMAP"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CMAPsize&),4)

REM - Build IFF ColorMap
FOR kk = 0 TO nColors% - 1
   regTemp% = PEEKW(colorTab& + (2*kk))
   POKE(cbuf&+(kk*3)),(regTemp% AND &Hf00) / 16
   POKE(cbuf&+(kk*3)+1),(regTemp% AND &Hf0) 
   POKE(cbuf&+(kk*3)+2),(regTemp% AND &Hf) * 16
NEXT

wLen& = xWrite&(fHandle&,cbuf&,CMAPsize&)

IF wLen& <= 0 THEN
   saveError$ = "Error writing CMAP"
   GOTO Scleanup
END IF   

REM - Write CAMG chunk
tt$ = "CAMG"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CAMGsize&),4)
vpModes& = PEEKW(sViewPort& + 32)
wLen& = xWrite&(fHandle&,VARPTR(vpModes&),4)

IF wLen& <= 0 THEN
   saveError$ = "Error writing CAMG"
   GOTO Scleanup
END IF   


REM - Write CCRT chunk
tt$ = "CCRT"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CCRTsize&),4)
wLen& = xWrite&(fHandle&,VARPTR(ccrtDir%),2)
temp% = (256*ccrtStart%) + ccrtEnd%
wLen& = xWrite&(fHandle&,VARPTR(temp%),2)
wLen& = xWrite&(fHandle&,VARPTR(ccrtSecs&),4)
wLen& = xWrite&(fHandle&,VARPTR(ccrtMics&),4)
wLen& = xWrite&(fHandle&,VARPTR(pad%),2)

IF wLen& <= 0 THEN
   saveError$ = "Error writing CCRT"
   GOTO Scleanup
END IF   


REM - Write BODY chunk
tt$ = "BODY"
wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(BODYsize&),4)

scrRowBytes% = scrWidth% / 8
FOR rr = 0 TO scrHeight% -1
   FOR pp = 0 TO scrDepth% -1
      scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
      wLen& = xWrite&(fHandle&,scrRow&,scrRowBytes%)   
      IF wLen& <= 0 THEN
         saveError$ = "Error writing BODY"
         GOTO Scleanup
      END IF   
   NEXT
NEXT

   
saveError$ = ""

Scleanup:
IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
RETURN



GetScrAddrs:
REM - Get addresses of screen structures
   sWindow&   = WINDOW(7)
   sScreen&   = PEEKL(sWindow& + 46)
   sViewPort& = sScreen& + 44
   sRastPort& = sScreen& + 84
   sColorMap& = PEEKL(sViewPort& + 4)
   colorTab&  = PEEKL(sColorMap& + 4)
   sBitMap&   = PEEKL(sRastPort& + 4)

   REM - Get screen parameters
   scrWidth%  = PEEKW(sScreen& + 12)
   scrHeight% = PEEKW(sScreen& + 14)
   scrDepth%  = PEEK(sBitMap& + 5)
   nColors%   = 2^scrDepth%

   REM - Get addresses of Bit Planes 
   FOR kk = 0 TO scrDepth% - 1
      bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
   NEXT
RETURN