home *** CD-ROM | disk | FTP | other *** search
/ 17 Bit Software 2: Collection B / 17Bit_Collection_B.iso / files / 1843.dms / in.adf / Mandelbrot / ilbm_write.nd2 < prev    next >
Encoding:
Text File  |  1992-03-31  |  7.1 KB  |  228 lines
  1. \ Copyright 1989 NerveWare
  2. \ No portion of this code may used for commercial purposes,
  3. \ nor may any executable version of this code be disributed for 
  4. \ commercial purposes without the author's express written permission.
  5. \ This code is shareware, all rights reserved.
  6. \ Nick Didkovsky.
  7.  
  8. \ Some changes to Phil Burk's ilbm writing stuff.
  9. \ MOD: Put CMAP before BODY                                        ND 2/6/89
  10. \ MOD: split bitmap write into header, followed by cmap, then body ND 2/6/89
  11. \ MOD: bodyptr freeblock                                ND 2/18/89
  12.  
  13. \ MOD: Allocate memory for only 20 rows at a time,pack,write,repeat ND 3/28/89
  14. \ Memory allocation often ABORTed this program when user tried 
  15. \ to save a 640x400 mandelbrot image.  Instead of allocating a buffer
  16. \ for the whole image, these routines grab and process 20 rows of the image 
  17. \ at a time.  That way, the most that ever has to be allocated
  18. \ is 20 rows of a 640x400 image = 6400 bytes instead of all 400 rows = 128000.
  19. \ For lores 320x400 or 320x200, only need 4000 bytes.
  20. \ MOD: added CRNG chunks so dpaint won't hallucinate its own and crash. 5/3/89
  21.  
  22.  
  23. include? ilbm.write.bitmap jiff:ilbm_maker
  24. include? open.mandelscreen variscreen.jf
  25.  
  26. anew task_write-ilbm.ND
  27.  
  28. decimal
  29.  
  30. variable ND-PAD 16 allot    \ used to hold body size
  31. variable ND-CRNG-PAD 8 allot
  32.  
  33. \ These IFF.WRITE's are just like PLB's except they don't do an evenup 
  34. \ on #bytes. Only even-up when done, since these write's are called 
  35. \ once for every 20 rows.
  36.  
  37. \ 
  38. : IFF.WRITE.ND ( addr #bytes -- #bytes , write to open IFF file)
  39.     iff-fileid @ -rot    fwrite
  40. ;
  41.  
  42. : IFF.WRITE?.ND ( addr #bytes -- , write to open IFF file or IFF.ERROR)
  43.     dup>r iff.write.nd r> -
  44.     IF ." IFF.WRITE?.ND failed!" cr iff.error
  45.     THEN
  46. ;
  47.  
  48. : ILBM.WRITE.BM.HEADER.ND ( bitmap -- , write BitMap header to file)
  49.    { bmap | bodyptr bsize -- }
  50. \ Write BitMapHeader
  51.     bmap ilbm-header ilbm.header.setup
  52.     ilbm-header sizeof() BitMapheader 'BMHD' iff.write.chunk
  53. ;
  54.  
  55. \ pack 20 rows up
  56. : BITMAP>BODY.20  { bmap bodyptr bsize compr startrow | bresult -- bsize'|-1 }
  57.     compr 0= compr 1 = OR 0=
  58.     IF ." Illegal compression = " compr . 0 exit
  59.     THEN
  60.     bodyptr -> bresult
  61.     startrow 20 + startrow    \ for 20 rows beginning at startrow
  62.     DO bmap ..@ bm_depth 0 ( for each plane )
  63.     DO
  64. \ next plane base
  65.         bmap .. bm_planes i cells + @ >rel ( src )
  66. \ offset to row
  67.         j bmap ..@ bm_bytesperrow * +
  68. \ place to put bytes
  69.             bodyptr  ( dst )
  70.         ( -- current-row body )
  71.         bmap ..@ bm_bytesperrow
  72.         bsize
  73.             compr 0=
  74.             IF pcopyrow  
  75.             ELSE packrow
  76.             THEN  ( -- dst' dst_many error? )
  77.         IF .s 2drop
  78.            -1 -> bresult
  79.            leave
  80.         THEN
  81.         -> bsize
  82.         -> bodyptr
  83.     LOOP
  84.     bresult 0= IF leave THEN
  85.     LOOP
  86.     bresult -1 -
  87.     IF bodyptr bresult -  ( calculate size )
  88.     ELSE -1
  89.     THEN
  90. ;
  91.  
  92.  
  93. : ILBM.MAKE.20.ROWS.ND { bmap bsize compr bodyptr startrow  --  bsize|-1 }
  94. \ Pack bitmap into BODY, 20 rows at a time
  95.         bmap bodyptr bsize compr startrow bitmap>body.20 dup -> bsize 0<
  96.         IF  bodyptr freeblock -1
  97.         ELSE bsize
  98.         THEN
  99. ;
  100.  
  101. variable even-up-byte
  102. : EVEN? ( num -- flag ) dup even-up = ;
  103.  
  104. \ Generate BODY in chunks of 20 rows, pack, write, repeat until done. ND
  105.  
  106. : ILBM.WRITE.BODY.ND ( bitmap -- , write BitMap BODY to ILBM, 20 row chunks )
  107.    { bmap | bodyptr bsizeout bsize -- }
  108. even-up-byte off
  109. \ remember where this chunk starts to update #bytes when done
  110.     iff.where                    ( -- BODYstartpos)
  111.     0 'BODY' iff.write.chkid            ( -- BODYstartpos)
  112.     0  ( memory type)
  113.     bmap ..@ bm_bytesPerRow  20 * bmap ..@ bm_depth *    
  114.     dup -> bsize allocblock ?dup     \ only 20 rows allocated
  115.         if -> bodyptr
  116. \                bsize . space ." bytes allocated" cr ( testing only)
  117.         else ." Couldn't allocate ILBM 20 row buffer" cr 
  118.              iff.close ABORT 
  119.         then
  120.     bmap ..@ bm_rows 20 /  0 DO        \ go by increments of 20 rows
  121.           bmap 
  122.      bsize 
  123.      ilbm-header ..@ bmh_compression 
  124.      bodyptr 
  125.      i 20 *             \ pass it the starting row#
  126.      ILBM.MAKE.20.ROWS.ND
  127.          -> bsizeout
  128.           bsizeout 0<
  129.          IF  ." ILBM.WRITE.BODY.ND - Couldn't make 'BODY'!" cr
  130.             iff.close iff.error
  131.          ELSE bodyptr bsizeout iff.write?.nd     \ tack on the new packed 20 rows
  132.         THEN
  133.     LOOP                    ( -- BODYstartpos)
  134. \ use nd-pad, calc BODY size, rewind, write it, fast forward, done!
  135.     dup>r            ( -- BODYstartpos) ( -r- BODYstartpos)
  136.     iff.where dup>r swap - 8 -    ( -- BODYsize)     ( -r- BODYstartpos endpos)
  137.     ND-PAD !            ( -- ,store size in pad)
  138.     r> r>            ( -- endpos BODYstartpos) ( -r- )
  139.     cell+ iff.seek        ( -- endpos ,go to count field)
  140.     ND-PAD cell iff.write?    ( -- endpos ,write BODY bytecount to file)
  141.     iff.seek            ( -- ,fastforward to end of BODY chunk)
  142. \ next line evens-up the file size
  143.     nd-pad @ even? if-not even-up-byte 1 iff.write?.nd    then    
  144.     bodyptr freeblock        ( -- ,cleanup)
  145. ;
  146.  
  147. \ CRNG chunk is:
  148.  
  149. \ WORD pad1   -- reserved for future use according to EA, store 0 here
  150. \ WORD rate   -- steps per second where decimal 16384 = 60 steps/sec
  151. \ WORD active -- store any nonzero value here to cycle colors
  152. \ UBYTE low   -- start cycling at this color register...
  153. \ UBYTE high  -- ... up through this color register
  154.  
  155. \ mandelbrot! iff images cycle from color reg 1 up through numcolors-1
  156.  
  157. \ create CRNG data depending on the number of colors in image
  158. : SET.CRNG.ND ( depth -- )
  159.   1- 2 swap ashift 1-            ( -- high color register)
  160.   nd-crng-pad 7 + c!            ( -- , store high color register)
  161.   1 nd-crng-pad 6 +  c!            ( -- , store low color register)
  162.   1 nd-crng-pad cell+  w!          ( -- , store active value)
  163.   $ 00002000 nd-crng-pad !        ( -- , store 0 and speed as 1 long word)
  164. ;
  165.  
  166. \ keep dpaint happy with stupid data
  167. : SET.CRNG.STUPID ( -- )
  168.   0 nd-crng-pad 7 + c!            ( -- , store high color register)
  169.   0 nd-crng-pad 6 +  c!            ( -- , store low color register)
  170.   1 nd-crng-pad cell+  w!          ( -- , store active value)
  171.   $ 00000AAA nd-crng-pad !        ( -- , store 0 and speed as 1 long word)
  172. ;
  173.  
  174. : ILBM.WRITE.ILBM.ND  { bmap ctable ctable# -- , write bitmap in ILBM file}
  175.     iff-fileid @ 0=
  176.     IF ." You must open an IFF file first using $IFF.OPEN" cr
  177.         abort
  178.     THEN
  179.     'ilbm' iff.begin.form  ( -- formpos )
  180.  
  181.   bmap ilbm.write.bm.header.nd
  182. \ Generate CMAP and write it.
  183.     ctable
  184.     IF  ctable pad ctable# ctable>cmap  ( use pad to pack cmap )
  185.         pad ctable# 3 * 'CMAP' iff.write.chunk
  186.     THEN
  187.  
  188. \ write one useful CRNG chunk for color cycling
  189.    bmap ..@ bm_depth set.crng.nd
  190.    nd-crng-pad 8 'CRNG' iff.write.chunk
  191. \ write three stupid CRNG chunks to keep dpaint happy
  192.    set.crng.stupid
  193.    nd-crng-pad 8 'CRNG' iff.write.chunk
  194.    nd-crng-pad 8 'CRNG' iff.write.chunk
  195.    nd-crng-pad 8 'CRNG' iff.write.chunk
  196.  
  197. \ Write Bitmap            ( -- formpos )
  198.     bmap ilbm.write.body.nd    ( -- formpos )
  199.  
  200. \ Close out 'FORM'
  201.     ( -- formpos ) iff.end.form
  202. ;
  203.  
  204. : $SCREEN>IFF.ND ( screen $filename -- , write screen IFF file )
  205.     new $iff.open
  206.     dup
  207.     .. sc_bitmap
  208.     swap .. sc_viewport
  209.     ..@ vp_colormap >rel
  210.     dup ..@ cm_ColorTable >rel
  211.     swap ..@ cm_count
  212.     ilbm.write.ilbm.ND
  213.     iff.close
  214. ;
  215.  
  216.  
  217. : TEST.SAVE ( -- )
  218. open.mandelscreen
  219. alldraw
  220. \ 0 0 gr.move
  221. \ 1 gr.color!
  222. \ 100 100 gr.draw
  223. \ 2 gr.color!
  224. \ 200 200 gr.draw
  225. new mscreen-ptr @ " ram:test2.iff" $screen>iff.nd
  226. close.mandelscreen
  227. ;
  228.