\ Copyright 1989 NerveWare \ No portion of this code may used for commercial purposes, \ nor may any executable version of this code be disributed for \ commercial purposes without the author's express written permission. \ This code is shareware, all rights reserved. \ Nick Didkovsky. \ Some changes to Phil Burk's ilbm writing stuff. \ MOD: Put CMAP before BODY ND 2/6/89 \ MOD: split bitmap write into header, followed by cmap, then body ND 2/6/89 \ MOD: bodyptr freeblock ND 2/18/89 \ MOD: Allocate memory for only 20 rows at a time,pack,write,repeat ND 3/28/89 \ Memory allocation often ABORTed this program when user tried \ to save a 640x400 mandelbrot image. Instead of allocating a buffer \ for the whole image, these routines grab and process 20 rows of the image \ at a time. That way, the most that ever has to be allocated \ is 20 rows of a 640x400 image = 6400 bytes instead of all 400 rows = 128000. \ For lores 320x400 or 320x200, only need 4000 bytes. \ MOD: added CRNG chunks so dpaint won't hallucinate its own and crash. 5/3/89 include? ilbm.write.bitmap jiff:ilbm_maker include? open.mandelscreen variscreen.jf anew task_write-ilbm.ND decimal variable ND-PAD 16 allot \ used to hold body size variable ND-CRNG-PAD 8 allot \ These IFF.WRITE's are just like PLB's except they don't do an evenup \ on #bytes. Only even-up when done, since these write's are called \ once for every 20 rows. \ : IFF.WRITE.ND ( addr #bytes -- #bytes , write to open IFF file) iff-fileid @ -rot fwrite ; : IFF.WRITE?.ND ( addr #bytes -- , write to open IFF file or IFF.ERROR) dup>r iff.write.nd r> - IF ." IFF.WRITE?.ND failed!" cr iff.error THEN ; : ILBM.WRITE.BM.HEADER.ND ( bitmap -- , write BitMap header to file) { bmap | bodyptr bsize -- } \ Write BitMapHeader bmap ilbm-header ilbm.header.setup ilbm-header sizeof() BitMapheader 'BMHD' iff.write.chunk ; \ pack 20 rows up : BITMAP>BODY.20 { bmap bodyptr bsize compr startrow | bresult -- bsize'|-1 } compr 0= compr 1 = OR 0= IF ." Illegal compression = " compr . 0 exit THEN bodyptr -> bresult startrow 20 + startrow \ for 20 rows beginning at startrow DO bmap ..@ bm_depth 0 ( for each plane ) DO \ next plane base bmap .. bm_planes i cells + @ >rel ( src ) \ offset to row j bmap ..@ bm_bytesperrow * + \ place to put bytes bodyptr ( dst ) ( -- current-row body ) bmap ..@ bm_bytesperrow bsize compr 0= IF pcopyrow ELSE packrow THEN ( -- dst' dst_many error? ) IF .s 2drop -1 -> bresult leave THEN -> bsize -> bodyptr LOOP bresult 0= IF leave THEN LOOP bresult -1 - IF bodyptr bresult - ( calculate size ) ELSE -1 THEN ; : ILBM.MAKE.20.ROWS.ND { bmap bsize compr bodyptr startrow -- bsize|-1 } \ Pack bitmap into BODY, 20 rows at a time bmap bodyptr bsize compr startrow bitmap>body.20 dup -> bsize 0< IF bodyptr freeblock -1 ELSE bsize THEN ; variable even-up-byte : EVEN? ( num -- flag ) dup even-up = ; \ Generate BODY in chunks of 20 rows, pack, write, repeat until done. ND : ILBM.WRITE.BODY.ND ( bitmap -- , write BitMap BODY to ILBM, 20 row chunks ) { bmap | bodyptr bsizeout bsize -- } even-up-byte off \ remember where this chunk starts to update #bytes when done iff.where ( -- BODYstartpos) 0 'BODY' iff.write.chkid ( -- BODYstartpos) 0 ( memory type) bmap ..@ bm_bytesPerRow 20 * bmap ..@ bm_depth * dup -> bsize allocblock ?dup \ only 20 rows allocated if -> bodyptr \ bsize . space ." bytes allocated" cr ( testing only) else ." Couldn't allocate ILBM 20 row buffer" cr iff.close ABORT then bmap ..@ bm_rows 20 / 0 DO \ go by increments of 20 rows bmap bsize ilbm-header ..@ bmh_compression bodyptr i 20 * \ pass it the starting row# ILBM.MAKE.20.ROWS.ND -> bsizeout bsizeout 0< IF ." ILBM.WRITE.BODY.ND - Couldn't make 'BODY'!" cr iff.close iff.error ELSE bodyptr bsizeout iff.write?.nd \ tack on the new packed 20 rows THEN LOOP ( -- BODYstartpos) \ use nd-pad, calc BODY size, rewind, write it, fast forward, done! dup>r ( -- BODYstartpos) ( -r- BODYstartpos) iff.where dup>r swap - 8 - ( -- BODYsize) ( -r- BODYstartpos endpos) ND-PAD ! ( -- ,store size in pad) r> r> ( -- endpos BODYstartpos) ( -r- ) cell+ iff.seek ( -- endpos ,go to count field) ND-PAD cell iff.write? ( -- endpos ,write BODY bytecount to file) iff.seek ( -- ,fastforward to end of BODY chunk) \ next line evens-up the file size nd-pad @ even? if-not even-up-byte 1 iff.write?.nd then bodyptr freeblock ( -- ,cleanup) ; \ CRNG chunk is: \ WORD pad1 -- reserved for future use according to EA, store 0 here \ WORD rate -- steps per second where decimal 16384 = 60 steps/sec \ WORD active -- store any nonzero value here to cycle colors \ UBYTE low -- start cycling at this color register... \ UBYTE high -- ... up through this color register \ mandelbrot! iff images cycle from color reg 1 up through numcolors-1 \ create CRNG data depending on the number of colors in image : SET.CRNG.ND ( depth -- ) 1- 2 swap ashift 1- ( -- high color register) nd-crng-pad 7 + c! ( -- , store high color register) 1 nd-crng-pad 6 + c! ( -- , store low color register) 1 nd-crng-pad cell+ w! ( -- , store active value) $ 00002000 nd-crng-pad ! ( -- , store 0 and speed as 1 long word) ; \ keep dpaint happy with stupid data : SET.CRNG.STUPID ( -- ) 0 nd-crng-pad 7 + c! ( -- , store high color register) 0 nd-crng-pad 6 + c! ( -- , store low color register) 1 nd-crng-pad cell+ w! ( -- , store active value) $ 00000AAA nd-crng-pad ! ( -- , store 0 and speed as 1 long word) ; : ILBM.WRITE.ILBM.ND { bmap ctable ctable# -- , write bitmap in ILBM file} iff-fileid @ 0= IF ." You must open an IFF file first using $IFF.OPEN" cr abort THEN 'ilbm' iff.begin.form ( -- formpos ) bmap ilbm.write.bm.header.nd \ Generate CMAP and write it. ctable IF ctable pad ctable# ctable>cmap ( use pad to pack cmap ) pad ctable# 3 * 'CMAP' iff.write.chunk THEN \ write one useful CRNG chunk for color cycling bmap ..@ bm_depth set.crng.nd nd-crng-pad 8 'CRNG' iff.write.chunk \ write three stupid CRNG chunks to keep dpaint happy set.crng.stupid nd-crng-pad 8 'CRNG' iff.write.chunk nd-crng-pad 8 'CRNG' iff.write.chunk nd-crng-pad 8 'CRNG' iff.write.chunk \ Write Bitmap ( -- formpos ) bmap ilbm.write.body.nd ( -- formpos ) \ Close out 'FORM' ( -- formpos ) iff.end.form ; : $SCREEN>IFF.ND ( screen $filename -- , write screen IFF file ) new $iff.open dup .. sc_bitmap swap .. sc_viewport ..@ vp_colormap >rel dup ..@ cm_ColorTable >rel swap ..@ cm_count ilbm.write.ilbm.ND iff.close ; : TEST.SAVE ( -- ) open.mandelscreen alldraw \ 0 0 gr.move \ 1 gr.color! \ 100 100 gr.draw \ 2 gr.color! \ 200 200 gr.draw new mscreen-ptr @ " ram:test2.iff" $screen>iff.nd close.mandelscreen ;