'Subprogram to save screen to ILBM file.
'Based on saveILBM program on Extras disk.

'The following 6 lines need to be in the calling program.
'DECLARE FUNCTION xOpen&  LIBRARY                    
'DECLARE FUNCTION xRead&  LIBRARY
'DECLARE FUNCTION xWrite& LIBRARY
'DECLARE FUNCTION AllocMem&() LIBRARY   
'CALL saveILBM(w,h,d,file$)
'IF sError$ <> "" THEN PRINT sError$

'The files dos.bmap and exec.bmap should be in the libs directory.
'w,h,d are width, height and depth of screen to be saved.
'if sub is called with file$="" filesave will not occur.

SUB saveILBM(w!,h!,d!,ILBMname$) STATIC
SHARED sError$
LIBRARY "dos.library"
LIBRARY "exec.library"
AvailRam& = FRE(-1)
NeededRam& = ((w!/8)*h!*(d!+1))+5000
IF AvailRam&<NeededRam& THEN sError$="Not enough free ram":GOTO Mcleanup
GOSUB GetScrAddrs
ccrtDir%   = 1: ccrtStart% = 1: ccrtEnd% = nColors% - 1
ccrtSecs&  = 0: ccrtMics&  = 2000
IF ILBMname$<>""  THEN  sError$ = "": GOSUB saveILBM

Mcleanup:  LIBRARY CLOSE
EXIT SUB
saveILBM:   f$ = ILBMname$
fHandle& = 0 :mybuf&=0
filename$ = f$ + CHR$(0)
fHandle& = xOpen&(SADD(filename$),1006)
IF fHandle&=0 THEN sError$= "Can't open output file":GOTO Scleanup
ClearPublic& = 65537& :mybufsize& = 120
mybuf& = AllocMem&(mybufsize&,ClearPublic&)
IF mybuf& = 0 THEN  sError$ = "Can't alloc buffer":GOTO Scleanup
cbuf& = mybuf& : GOSUB GetScrAddrs
zero& = 0 :pad%  = 0 :aspect% = &HA0B:BMHDsize& = 20 
CMAPsize& = (2^scrDepth%) * 3: CAMGsize& = 4 : CCRTsize& = 14
BODYsize& = (scrWidth%/8) * scrHeight% * scrDepth%
FORMsize& = BMHDsize&+CMAPsize&+CAMGsize&+CCRTsize&+BODYsize&+44
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 sError$= "Error writing FORM header":GOTO Scleanup
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  sError$ = "Error writing BMHD": GOTO Scleanup
tt$ = "CMAP"  : wLen& = xWrite&(fHandle&,SADD(tt$),4)
wLen& = xWrite&(fHandle&,VARPTR(CMAPsize&),4)
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 sError$ = "Error writing CMAP":GOTO Scleanup
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  sError$ = "Error writing CAMG" :   GOTO Scleanup
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    sError$ = "Error writing CCRT" :   GOTO Scleanup
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 sError$= "Error writing BODY":GOTO Scleanup
   NEXT
NEXT

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

GetScrAddrs:   
   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)
   scrWidth%  = PEEKW(sScreen& + 12)     
   scrHeight% = PEEKW(sScreen& + 14)
   scrDepth%  = PEEK(sBitMap& + 5)
   nColors%   = 2^scrDepth%
   FOR kk% = 0 TO scrDepth% - 1
      bPlane&(kk%) = PEEKL(sBitMap&+8+(kk%*4))
   NEXT
RETURN
END SUB