CLEAR ,40000 InitalizeParms: OPEN "com1:300,N,8,1" AS 1 speak$ = TRANSLATE$ ("Welcome") SAY (speak$) Main: DIM bPlane&(5), cTabWork%(32), cTabSave%(32) REM - Functions from dos.library DECLARE FUNCTION xOpen& LIBRARY DECLARE FUNCTION xRead& LIBRARY DECLARE FUNCTION xWrite& 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." ACBMname$="Title" IF (ACBMname$ = "") GOTO Mcleanup2 PRINT REM - Load the ACBM pic loadError$ = "" GOSUB LoadACBM IF loadError$ <> "" THEN GOTO Mcleanup REM - Demo Graphicraft color cycling IF foundCCRT AND ccrtDir% THEN REM - Save colors FOR kk = 0 TO nColors% -1 cTabSave%(kk) = PEEKW(colorTab&+(kk*2)) cTabWork%(kk) = cTabSave%(kk) NEXT REM - Cycle colors FOR kk = 0 TO 80 IF ccrtDir% = 1 THEN GOSUB Fcycle ELSE GOSUB Bcycle END IF CALL LoadRGB4&(sViewPort&,VARPTR(cTabWork%(0)),nColors%) REM - Delays approximated FOR de1 = 0 TO ccrtSecs& * 3000 FOR de2 = 0 TO ccrtMics& / 500 NEXT NEXT NEXT REM - Restore colors CALL LoadRGB4&(sViewPort&,VARPTR(cTabSave%(0)),nColors%) END IF Mcleanup: FOR n = 1 TO 2000 NEXT Mcleanup2: LIBRARY CLOSE IF loadError$ <> "" THEN PRINT loadError$ CHAIN"loader" END Bcycle: 'Backward color cycle cTemp% = cTabWork%(ccrtEnd%) FOR jj = ccrtEnd%-1 TO ccrtStart% STEP -1 cTabWork%(jj+1) = cTabWork%(jj) NEXT cTabWork%(ccrtStart%) = cTemp% RETURN Fcycle: 'Forward color cycle cTemp% = cTabWork%(ccrtStart%) FOR jj = ccrtStart%+1 TO ccrtEnd% cTabWork%(jj-1) = cTabWork%(jj) NEXT cTabWork%(ccrtEnd%) = cTemp% RETURN LoadACBM: REM - Requires the following variables REM - to have been initialized: REM - ACBMname$ (ACBM filespec) REM - init variables f$ = ACBMname$ fHandle& = 0 mybuf& = 0 foundBMHD = 0 foundCMAP = 0 foundCAMG = 0 foundCCRT = 0 foundABIT = 0 REM - From include/libraries/dos.h REM - MODE_NEWFILE = 1006 REM - MODE_OLDFILE = 1005 filename$ = f$ + CHR$(0) fHandle& = xOpen&(SADD(filename$),1005) IF fHandle& = 0 THEN loadError$ = "Can't open/find pic file" GOTO Lcleanup END IF REM - Alloc ram for work buffers ClearPublic& = 65537 mybufsize& = 360 mybuf& = AllocMem&(mybufsize&,ClearPublic&) IF mybuf& = 0 THEN loadError$ = "Can't alloc buffer" GOTO Lcleanup END IF inbuf& = mybuf& cbuf& = mybuf& + 120 ctab& = mybuf& + 240 REM - Should read FORMnnnnACBM rLen& = xRead&(fHandle&,inbuf&,12) tt$ = "" FOR kk = 8 TO 11 tt% = PEEK(inbuf& + kk) tt$ = tt$ + CHR$(tt%) NEXT IF tt$ <> "ACBM" THEN loadError$ = "Not an ACBM pic file" GOTO Lcleanup END IF REM - Read ACBM chunks ChunkLoop: REM - Get Chunk name/length rLen& = xRead&(fHandle&,inbuf&,8) icLen& = PEEKL(inbuf& + 4) tt$ = "" FOR kk = 0 TO 3 tt% = PEEK(inbuf& + kk) tt$ = tt$ + CHR$(tt%) NEXT IF tt$ = "BMHD" THEN 'BitMap header foundBMHD = 1 rLen& = xRead&(fHandle&,inbuf&,icLen&) iWidth% = PEEKW(inbuf&) iHeight% = PEEKW(inbuf& + 2) iDepth% = PEEK(inbuf& + 8) iCompr% = PEEK(inbuf& + 10) scrWidth% = PEEKW(inbuf& + 16) scrHeight% = PEEKW(inbuf& + 18) iRowBytes% = iWidth% /8 scrRowBytes% = scrWidth% / 8 nColors% = 2^(iDepth%) REM - Enough free ram to display ? AvailRam& = FRE(-1) NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000 IF AvailRam& < NeededRam& THEN loadError$ = "Not enough free ram." GOTO Lcleanup END IF kk = 1 IF scrWidth% > 320 THEN kk = kk + 1 IF scrHeight% > 200 THEN kk = kk + 2 SCREEN 2,scrWidth%,scrHeight%,iDepth%,kk WINDOW 3,"LoadACBM",,7,2 REM - Get addresses of structures GOSUB GetScrAddrs REM - Black out screen CALL LoadRGB4&(sViewPort&,ctab&,nColors%) ELSEIF tt$ = "CMAP" THEN 'ColorMap foundCMAP = 1 rLen& = xRead&(fHandle&,cbuf&,icLen&) REM - Build Color Table FOR kk = 0 TO nColors% - 1 red% = PEEK(cbuf&+(kk*3)) gre% = PEEK(cbuf&+(kk*3)+1) blu% = PEEK(cbuf&+(kk*3)+2) regTemp% = (red%*16)+(gre%)+(blu%/16) POKEW(ctab&+(2*kk)),regTemp% NEXT ELSEIF tt$ = "CAMG" THEN 'Amiga ViewPort Modes foundCAMG = 1 rLen& = xRead&(fHandle&,inbuf&,icLen&) camgModes& = PEEKL(inbuf&) ELSEIF tt$ = "CCRT" THEN 'Graphicraft color cycle info foundCCRT = 1 rLen& = xRead&(fHandle&,inbuf&,icLen&) ccrtDir% = PEEKW(inbuf&) ccrtStart% = PEEK(inbuf& + 2) ccrtEnd% = PEEK(inbuf& + 3) ccrtSecs& = PEEKL(inbuf& + 4) ccrtMics& = PEEKL(inbuf& + 8) ELSEIF tt$ = "ABIT" THEN 'Contiguous BitMap foundABIT = 1 REM - This only handles full size BitMaps, not brushes REM - Very fast - reads in entire BitPlanes plSize& = (scrWidth%/8) * scrHeight% FOR pp = 0 TO iDepth% -1 rLen& = xRead&(fHandle&,bPlane&(pp),plSize&) NEXT ELSE REM - Reading unknown chunk FOR kk = 1 TO icLen& rLen& = xRead&(fHandle&,inbuf&,1) NEXT REM - If odd length, read 1 more byte IF (icLen& OR 1) = icLen& THEN rLen& = xRead&(fHandle&,inbuf&,1) END IF END IF REM - Done if got all chunks IF foundBMHD AND foundCMAP AND foundABIT THEN GOTO GoodLoad END IF REM - Good read, get next chunk IF rLen& > 0 THEN GOTO ChunkLoop IF rLen& < 0 THEN 'Read error loadError$ = "Read error" GOTO Lcleanup END IF REM - rLen& = 0 means EOF IF (foundBMHD=0) OR (foundABIT=0) OR (foundCMAP=0) THEN loadError$ = "Needed ILBM chunks not found" GOTO Lcleanup END IF GoodLoad: loadError$ ="" REM Load proper Colors IF foundCMAP THEN CALL LoadRGB4&(sViewPort&,ctab&,nColors%) END IF Lcleanup: 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