/* ---------------------------------------------------------------- */ /* GIFBUILD.REX */ /* Builds a simple GIF file (one image, no local color tables) */ /* Syntax: GIFBUILD infile outfile */ /* E.g.: GIFBUILD zero.ini zero.gif */ /* See also GIFPARSE.REX which produces an input file */ /* 15 Jul 1999 Rex Swain, Independent Consultant, www.rexswain.com */ /* ---------------------------------------------------------------- */ parse arg infile outfile /* ===== Hardwired Parameters ===================================== */ compress = 1 /* Use LZW compression? */ defcomm = '' /* Default comment */ /* ===== Verify Arguments ========================================= */ if infile = '' then call err 'Input file must be specified' if lines(infile) = 0 then call err 'Input file not found:' infile if chars(outfile) > 0 then call err 'Output file already exists:' outfile /* ===== Parse Input File ========================================= */ say 'GifBuild starting file "' || infile || '" ...' do while lines(infile) i = linein(infile) if i = '' then iterate /* Blank line */ c = left(i,1) if c == '[' then iterate /* Section */ if c == ';' then iterate /* Comment */ parse var i p '=' v p = space(p) ini.p = strip(v,'L') end call lineout infile /* Close the file */ /* ===== Begin Input Data ========================================= */ interlace = ini('Interlace Flag',0) bgcolor = ini('Background Color Index',0) comment = ini('Comment Text',defcomm) transparent = ini('Transparent Color Flag',0) trcolor = ini('Transparent Color Index',0) width = ini('Image Width') height = ini('Image Height') /* Image pixel data: indices into the Global Color Table */ do i = 1 to height row.i = ini('Row' i) end /* Global Color Table: RGB triplets */ gctz = ini('Size of Global Color Table') do i = 0 to gctz-1 gct.i = ini('GCT' i) end /* ===== Start Building GIF File ================================== */ /* ----- Header (Signature & Version) (6 bytes) ------------------- */ say '[Header]' if comment = '' & transparent = 0 then call append 'GIF87a' else call append 'GIF89a' /* ----- Logical Screen Descriptor (7 bytes) ---------------------- */ say '[Logical Screen Descriptor]' call append d2c2(width) /* Logical Screen Width */ call append d2c2(height) /* Logical Screen Height */ b = '1' /* Global Color Table Flag */ bits = log2(gctz) /* Bits required for color */ cr = d2b(bits-1) cr = right(cr,3,'0') b = b || cr /* Color Resolution */ b = b || '0' /* Sort Flag */ b = b || cr /* Size of Global Color Table */ call append b2c(b) /* Flush bits */ call append d2c(bgcolor) /* Background Color Index */ call append d2c(0) /* Pixel Aspect Ratio */ /* ----- Global Color Table --------------------------------------- */ say '[Global Color Table]' do i = 0 to gctz-1 call append x2c(gct.i) end /* ----- Comment -------------------------------------------------- */ if comment \= '' then do say '[Comment]' call append x2c('21') /* Extension Block */ call append x2c('FE') /* Comment Extension */ call append d2c(length(comment)) /* Block size */ call append comment /* Block data */ call append d2c(0) /* Block size */ end /* ----- Transparent ---------------------------------------------- */ if transparent then do say '[Transparent]' call append x2c('21') /* Extension Block */ call append x2c('F9') /* Graphic Control Extension */ call append d2c(4) /* Block size */ b = '000' /* Reserved bits */ b = b || '000' /* Disposal Method */ b = b || '0' /* User Input Flag */ b = b || '1' /* Transparent Color Flag */ call append b2c(b) /* Flush bits */ call append d2c2(0) /* Delay Time */ call append d2c(trcolor) /* Transparent Color Index */ call append d2c(0) /* Block Terminator */ end /* ----- Image ---------------------------------------------------- */ say '[Image Descriptor]' call append x2c('2C') /* Image Descriptor */ call append d2c2(0) /* Image Left Origin */ call append d2c2(0) /* Image Top Origin */ call append d2c2(width) /* Image Width */ call append d2c2(height) /* Image Height */ b = '0' /* Local Color Table Flag */ b = b || interlace /* Interlace Flag */ b = b || '0' /* Sort Flag */ b = b || '00' /* Reserved bits */ b = b || '000' /* Size of Local Color Table */ call append b2c(b) /* Flush bits */ /* ----- Interlace ------------------------------------------------ */ d = '' /* Uncompressed data stream */ if interlace then do say '[Interlace]' do i = 1 to height by 8 ; d = d || x2c(row.i) ; end do i = 5 to height by 8 ; d = d || x2c(row.i) ; end do i = 3 to height by 4 ; d = d || x2c(row.i) ; end do i = 2 to height by 2 ; d = d || x2c(row.i) ; end end else do do i = 1 to height ; d = d || x2c(row.i) ; end end /* ----- Compress or Encode --------------------------------------- */ say '[Compress/Encode]' if compress then d = lzwc(bits,d) /* Compressed data stream */ else d = encode(d) /* Encoded data stream */ /* ----- Image Data ----------------------------------------------- */ say '[Raster Data]' call append left(d,1) /* Code Size */ n = length(d) /* Length of data */ p = 1 /* Pointer into data */ do forever b = n - p /* Bytes remaining */ b = min(255,b) /* Max block size 255 */ call append d2c(b) /* Send block size */ if b = 0 then leave /* Nothing left? */ call append substr(d,p+1,b) /* Send block */ p = p + b /* Bump pointer */ end /* ----- Trailer -------------------------------------------------- */ say '[Trailer]' call append x2c('3B') /* Trailer */ /* ----- Done ----------------------------------------------------- */ say 'GIFbuild finished' EXIT /* ===== Misc Subroutines ========================================= */ err: procedure /* Error */ parse arg a say 'GifBuild error:' a say 'GifBuild finished' EXIT append: procedure expose outfile /* Append to outfile */ parse arg a call charout outfile,a return d2c2: procedure /* Decimal to 2 chars */ parse arg d return d2c(d//256) || d2c(d%256) d2b: procedure /* Decimal to binary */ parse arg d return x2b(d2x(d)) b2c: procedure /* Binary to character */ parse arg b return x2c(b2x(b)) log2: procedure parse arg n r = 0 do until 2**r >= n r = r + 1 end return r ini: procedure expose ini. /* Get value from ini file */ parse arg p,d /* Parameter, default value */ if symbol('ini.p') == 'VAR' then /* Has a value? */ return ini.p if arg() == 2 then /* Default given? */ return d say 'Required parameter not found:' p exit /* ===== LZW-Compatible Encode ==================================== */ encode: procedure /* Encode GIF image raster data without LZW compression */ /* Packs data such that LZW decompression still works on it */ /* Avoids the Unisys LZW patent issue */ /* Faster than LZW, but adds ~13% to the native size of data */ /* For speed, assumes 8 bits necessary to encode each pixel */ /* Argument and result same as lzwc(); see comments there */ /* 21 Jun 1999 Rex Swain, Independent Consultant, www.rexswain.com */ parse arg in in = x2b(c2x(in)) /* Convert all to 8 bits each */ n = length(in) - 7 /* Last substr position */ out = '' /* Initialize */ /* Make 9-bit codes by adding a leading 0 before each 8-bit byte */ do i = 1 to n by 2032 /* 2032 = 254*8 */ out = '100000000' || out /* Clear every 254 bytes */ m = min(n,i+2031) do j = i to m by 8 out = '0' || substr(in,j,8) || out end end out = '100000001' || out /* EOI code */ out = x2c(b2x(out)) /* Convert to chars (b2c) */ out = reverse(out) /* Reverse all bytes */ out = d2c(8) || out /* Add code size to front */ return out /* ===== LZW Compression ========================================== */ lzwc: procedure /* LZW compression for a GIF image */ /* Syntax: out = lzwc(bits,in) */ /* bits is number of bits required to represent size of color table */ /* e.g., 8 (for 256 colors) */ /* in is the raster data stream (pointers into the color table) */ /* i.e., width*height bytes */ /* Returns compressed string of bytes, including leading code size */ /* (one byte), but not including the Block Size bytes */ /* I.e., while building a GIF file, once at the raster data... */ /* out = lzwc(bits,in) /* Compress the data */ */ /* call charout gif,left(out,1) /* Send code size */ */ /* n = length(out) /* Length of out */ */ /* p = 1 /* Pointer into out */ */ /* do forever */ /* d = n - p /* Bytes remaining */ */ /* d = min(255,d) /* Max block size 255 */ */ /* call charout gif,d2c(d) /* Send block size */ */ /* if d = 0 then leave /* Nothing left? */ */ /* call charout gif,substr(out,p+1,d) /* Send block */ */ /* p = p + d /* Bump pointer */ */ /* end */ /* For GIF, we use character strings for both input and output */ /* Warning: LZW compression is apparently patented by Unisys */ /* Requires several subroutines named lzwc_xxx */ /* 18 Jun 1999 Rex Swain, Independent Consultant, www.rexswain.com */ parse arg bits, in n = length(in) /* Length of input stream */ bits = max(2,bits) /* GIF LZW minimum code size */ lim = 246 /* Longest REXX tail allowed */ tsz = 2 ** bits /* Initial table size */ clr = tsz /* Clear code */ eoi = tsz + 1 /* End Of Information code */ call lzwc_reset /* Create string table */ out = lzwc_d2b(clr) /* Initialize result: clear */ old = '' /* First pass: no old string */ buf = '' /* Output byte buffer */ do i = 1 to n /* For each input byte */ new = substr(in,i,1) /* Next char */ str = old || new /* Old string + character */ if lzwc_find(str) >= 0 then do /* S+C already in table? */ old = str /* Make S+C the old string */ iterate /* Next input byte */ end /* S+C is not in table, so output old code and add S+C to table */ d = lzwc_find(old) /* Find old string in table */ out = lzwc_d2b(d) || out /* Output code for old string */ old = new /* Make char the old string */ call lzwc_add str,nxt /* Add S+C to the table */ nxt = nxt + 1 /* Next available code number */ /* Do we need to expand the code size now? */ if nxt <= max then iterate /* Next input byte */ /* Just for a little more speed, convert bits we have to bytes */ call lzwc_buffer /* Expand the code size (if it would not exceed GIF's limit) */ if csz < 12 then do /* 12 is maximum code size */ csz = csz + 1 /* Bump code size */ max = 2 ** csz /* New code limit */ /* FYI, if csz = 12, some GIF encoders deduct 1 from max now */ iterate /* Next input byte */ end /* Code size was already at limit; must reset table */ out = lzwc_d2b(clr) || out /* Output clear code */ call lzwc_reset /* Reset table */ end /* Next input byte */ d = lzwc_find(old) /* Find in table */ out = lzwc_d2b(d) || out /* Flush last code */ out = lzwc_d2b(eoi) || out /* EOI code */ out = x2c(b2x(out)) /* Convert to bytes (b2c) */ out = out || buf /* Add bytes we already did */ out = reverse(out) /* Reverse all bytes */ out = d2c(bits) || out /* Add code size to front */ return out lzwc_reset: procedure expose tab. long. tsz bits csz max nxt drop tab. long. /* Recover storage */ tab. = -1 /* Default -1 means undefined */ do i = 0 to tsz-1 /* Initialize the table */ c = d2c(i) tab.c = i end long.0 = 0 /* Number of long entries */ csz = bits + 1 /* Initial code size */ max = 2 ** csz /* Initial code limit */ nxt = tsz + 2 /* Next available code value */ return lzwc_d2b: procedure expose csz /* Decimal to binary */ parse arg d /* Decimal */ b = x2b(d2x(d)) /* Convert to binary (d2b) */ return right(b,csz,'0') /* Pad to code size */ lzwc_add: procedure expose tab. long. lim parse arg str, nxt /* But for REXX implementation limit on length of stem.tail, this */ /* would be just: tab.str = nxt */ if length(str) <= lim then do /* Easy case (note: g > 1) */ tab.str = nxt return end n = 1 + long.0 /* Else add a new long string */ long.0 = n long.n = str long.n.0 = nxt return lzwc_find: procedure expose tab. long. lim parse arg str /* But for REXX implementation limit on length of stem.tail, this */ /* would be just: return tab.str */ if length(str) <= lim then /* Easy case */ return tab.str do i = 1 to long.0 /* Else search long strings */ if str == long.i then return long.i.0 end return -1 lzwc_buffer: procedure expose out buf /* Move whole bytes from out to buf. This is totally unnecessary */ /* for functionality, but speeds things up significantly. */ g = length(out) /* How many bits do we have */ s = g // 8 /* How many "spare" bits */ b = g - s /* Round down to whole bytes */ b = right(out,b) /* All but spare bits */ c = x2c(b2x(b)) /* Convert to chars (b2c) */ buf = c || buf /* Add to buffer */ out = left(out,s) /* Now just spare bits */ return