/* OS/2 REXX: Convert Win ICO to XPM2 icon (incl. transparency)   */

/* Work in progress - XPM2 to Win ICO not yet implemented, usage: */
/* ico2xpm2 whatever.ICO                  (creates whatever.XPM)  */

/* Example output (16*16, 5 colours, encoded as ASCII . @ 0 1 2): */
/* ! XPM2                                                         */
/* 16 16 5 1                                                      */
/* . c #00FF00                                                    */
/* @ c #808080                                                    */
/* 0 c #000000                                                    */
/* 1 c #CCCCCC                                                    */
/* 2 c #800080                                                    */
/* ......00........                                               */
/* .....01100......                                               */
/* ....0111110.....                                               */
/* ....21@1@10.....                                               */
/* ....011111@.....                                               */
/* ....0102@110....                                               */
/* ..00111011112.0.                                               */
/* .011111111111010                                               */
/* 011111111111111@                                               */
/* .0@11111111@@@0.                                               */
/* ...@11111@0.....                                               */
/* ..0111111110....                                               */
/* .01111@@111@....                                               */
/* .@111@..@110....                                               */
/* ..011@...0110...                                               */
/* ...@0.....0@....                                               */
/* <http://purl.net/xyzzy/src/ico2xpm2.cmd>   (F.Ellermann, 2006) */

/* OFS   LEN   VAL   Some details of this ICO format are unclear: */
/*   0     2     0   Icon directory header                        */
/*   2     2     1   Type, hex. 0100 (little endian)              */
/*   4     2   <N>   Number of icons                              */
/*   6    16         1st icon directory entry (2nd at 22 etc.)    */
/*   6+u   1   <W>   Width   16, 32, 64 (?) \/ For a favicon.ico  */
/*   7+u   1   <H>   Width   16, 32, 64 (?) /\  16 * 16 is okay   */
/*   8+u   1   <C>   Colours  2,  8, 16 (?), or 0 for 256 colours */
/*   9+u   1     0   reserved / pad                               */
/*  10+u   2     0   Planes (?), might be also 1 (see below)      */
/*  12+u   2   <B>   Bits per pixel: 1, 4, 8 (?)                  */
/*  14+u   4   <S>   Size of icon bitmap (header+palette+XOR+AND) */
/*  18+u   4   <O>   Offset within ICO file (22 if only one icon) */
/*  22+w   4    40   Bitmap header size                           */
/*  26+w   4   <W>   Width , same as above                        */
/*  30+w   4   <H>   Height, twice as above (STRANGE)             */
/*  34+w   2     1   Planes                                       */
/*  36+w   2   <B>   Bits per pixel: 1, 4, 8, 24 (not for icons)  */
/*  38+w   4     0   Bitmap compression    \    /                 */
/*  42+w   4     0   Size of pixel data (?) \  /  The rest of the */
/*  46+w   4     0   X pixels per meter (?)  \/   bitmap header   */
/*  50+w   4     0   Y pixels per meter (?)  /\   CAN or MUST be  */
/*  54+w   4     0   Colours used       (?) /  \  0 for an icon   */
/*  58+w   4     0   Colours important  (?)/    \                 */
/*  62+x   4         Colour  0 (RGBquad hex. bbggrr00)            */
/*  66+x   4         Colour  1, etc. (not only the used colours)  */
/* ...+x                                                          */
/* 122+x   4         Colour  15 (example)                         */
/* 126+y   8         XOR row 0  (example @7E, 16*4 = width * bpp) */
/* ...+y   8         Rows are padded to get a multiple of 32 bits */
/* 246+y   8         XOR row 15 (example)                         */
/* 254+z   4         AND row 0  (example @FE, width bits, padded) */
/* ...+z   4         Rows are padded to get a multiple of 32 bits */
/* 314+z   4         AND row 15 (example, total size 318 bytes)   */

/* There is a shorter (12 bytes) variant of the bitmap header,    */
/* but presumably it is never used for icons:                     */
/*  22+w   4    12   Bitmap header size (deprecated core format)  */
/*  26+w   2   <W>   Width                                        */
/*  28+w   2   <H>   Height (see above for a potential oddity)    */
/*  30+w   2     1   Planes                                       */
/*  32+w   2   <B>   Bits per pixel                               */
/*  34+x   3         Colour 0  (core format uses rrggbb triples)  */
/*  37+x   3         Colour 1                                     */
/* ...+x                                                          */
/*  79+x   3         Colour 15 (untested example)                 */
/*  82+y   8         XOR row 0 (untested example), etc. as above  */

/* Credits for info about the (partially obscure) Win ICO format: */
/* J.Daub (daubnet.com), M.S.Benkmann (winterdrache.de, png2ico)  */

/* XPM supports transparency as "c none", but (AFAIK) XPM has no  */
/* "XOR" concept to "invert" background colours.  Therefore this  */
/* script assumes a white background resulting in (example):      */
/* XOR reference 000000, AND 0, output colour 000000 (black)      */
/* XOR reference 123456, AND 0, output colour 123456 (unmodified) */
/* XOR reference FFFFFF, AND 0, output colour FFFFFF (white)      */
/* XOR reference 000000, AND 1, output colour none (transparency) */
/* XOR reference 123456, AND 1, output colour EDCBA9 (inverse)    */
/* XOR reference FFFFFF, AND 1, output colour 000000 (black)      */

   signal on  novalue  name TRAP    ;  signal on  syntax name TRAP
   signal on  failure  name TRAP    ;  signal on  halt   name TRAP
   signal on  notready name TRAP       /* missing bytes are fatal */

   SRC = translate( strip( strip( strip( arg( 1 )), /**/, '"' )))
   if SRC =  ''   then  do
      parse source . . SRC          ;  SRC = 'usage:' SRC 'source'
      TYP = 'source can be a Windows ICO or a file with XPM2 icons'
      exit WARN( SRC || x2c( 0D0A ) || TYP ) +1
   end
   if SRC <> ''   then  SRC = stream( SRC, 'c', 'query exists' )
   if SRC =  ''   then  exit WARN( 'not found:' arg( 1 )) +1

   TYP = charin( SRC, 1, 4 )
   if TYP <> x2c( '00000100' ) & TYP <> '! XP'
      then  exit WARN( arg(1 ) 'is no supported icon fomat' ) +1

   TMP = lastpos( '/', translate( SRC, '/', '\' ))
   DST = lastpos( '.', substr( SRC, TMP + 1 ))
   if DST > 0        then  DST = left( SRC, TMP + DST - 1 )
                     else  DST = SRC
   if TYP = '! XP'   then  exit  ICON( SRC, DST || '.ico' )
                     else  exit  XPM2( SRC, DST || '.xpm' )

XPM2: procedure
   parse arg SRC, DST               ;  OFS = 6
   NUM = c2d( reverse( charin( SRC,, 2 )))
   CHK = OFS + NUM * 16

   do ICO = 1 to NUM
      W.ICO = c2d( charin( SRC ))      /* width  16, 32, etc.     */
      H.ICO = c2d( charin( SRC ))      /* height 16, 32, etc.     */
      C.ICO = c2d( charin( SRC ))      /* colours 2, 16, 0 (256)  */
      say ICO || ':' W.ICO '*' H.ICO
      TRASH = charin( SRC, , 3 )    ;  OFS = OFS + 16
      if TRASH <> x2c( '000000' ) & TRASH <> x2c( '000100' )
         then  exit WARN( 'unexpected entry @' OFS - 13 ) +1
      B.ICO = c2d( reverse( charin( SRC, , 2 )))
      S.ICO = c2d( reverse( charin( SRC, , 4 )))
      O.ICO = c2d( reverse( charin( SRC, , 4 )))
      if O.ICO <> CHK
         then  exit WARN( 'expected offset' CHK 'got' O.ICO ) +1
         else  CHK = CHK + S.ICO
   end ICO

   do ICO = 1 to NUM
      if OFS <> O.ICO
         then  exit WARN( 'offset' OFS '<>' O.ICO ) +1

      Q.ICO = c2d( reverse( charin( SRC, , 4 )))
      select
         when Q.ICO = 40   then  do
            TRASH = c2d( reverse( charin( SRC, , 4 )))
            if W.ICO = 0   then  W.ICO = TRASH
            if W.ICO <> TRASH | TRASH = 0
               then  exit WARN( 'width' TRASH W.ICO ) +1
            TRASH = c2d( reverse( charin( SRC, , 4 )))
            if H.ICO = 0   then  H.ICO = TRASH % 2
            if H.ICO * 2 <> TRASH | TRASH = 0
               then  exit WARN( 'height' TRASH H.ICO ) +1
            TRASH = c2x( reverse( charin( SRC, , 2 )))
            if TRASH <> 1              /* using 1 = 0001 in REXX  */
               then  exit WARN( 'plane' TRASH '@' OFS + 12 ) +1
            TRASH = c2d( reverse( charin( SRC, , 2 )))
            if B.ICO = 0   then  B.ICO = TRASH
            if B.ICO <> TRASH | pos( TRASH, '1 4 8 24' ) = 0
               then  exit WARN( 'bpp' TRASH B.ICO '@' OFS + 14 ) +1
            TRASH = c2d( reverse( charin( SRC, , 4 )))
            if TRASH <> 0
               then  exit WARN( 'compressed BMP @' OFS + 16 ) +1

            L.ICO = LPAD( W.ICO, B.ICO )
            CHK   = H.ICO * L.ICO      /* image size is not very  */
            M.ICO = LPAD( W.ICO, 1 )   /* reliable, try 3 values: */
            BYTES = H.ICO * M.ICO + CHK
            TRASH = c2d( reverse( charin( SRC, , 4 )))
            if TRASH <> 0 & TRASH <> BYTES & TRASH <> CHK
               then  exit WARN( 'size' TRASH BYTES '@' OFS + 20 ) +1
            TRASH = Q.ICO + BYTES      /* total size must be okay */
            if B.ICO < 24  then  TRASH = TRASH + 4 * ( 2 ** B.ICO )
            if S.ICO <> TRASH          /* check pixel + full size */
               then  exit WARN( 'size' TRASH S.ICO ) +1
            TRASH = charin( SRC,, 16 ) /* skip four unused values */
         end
         when Q.ICO = 12   then  do
            TRASH = c2d( reverse( charin( SRC, , 2 )))
            if W.ICO = 0   then  W.ICO = TRASH
            if W.ICO <> TRASH | TRASH = 0
               then  exit WARN( 'width' TRASH W.ICO ) +1
            TRASH = c2d( reverse( charin( SRC, , 2 )))
            if H.ICO = 0   then  H.ICO = TRASH % 2
            if H.ICO * 2 <> TRASH | TRASH = 0
               then  exit WARN( 'height' TRASH H.ICO ) +1
            TRASH = c2x( reverse( charin( SRC, , 2 )))
            if TRASH <> 1              /* using 1 = 0001 in REXX  */
               then  exit WARN( 'plane' TRASH '@' OFS + 8 ) +1
            TRASH = c2d( reverse( charin( SRC, , 2 )))
            if B.ICO = 0   then  B.ICO = TRASH
            if B.ICO <> TRASH | pos( TRASH, '1 4 8 24' ) = 0
               then  exit WARN( 'bpp' B.ICO TRASH '@' OFS + 10 )
            L.ICO = LPAD( W.ICO, B.ICO )
            M.ICO = LPAD( W.ICO, 1 )
         end
         otherwise   exit WARN( 'unknown header for icon' ICO ) +1
      end
      OFS = OFS + Q.ICO                /* 12 or 40 bytes header   */

      if B.ICO = 24  then  exit WARN( 'true colour unsupported' ) +1
      X = 2 ** B.ICO
      do N = 0 to X - 1                /* read source ICO palette */
         if Q.ICO =  40
            then  PAL.N = substr( reverse( charin( SRC, , 4 )), 2 )
            else  PAL.N = charin( SRC, , 3 )
      end N
      OFS = OFS + X * ( 4 - ( Q.ICO <> 40 ))

      do ROW = 0 to H.ICO - 1
         OFS = OFS + L.ICO
         BIT = x2b( c2x( charin( SRC, , L.ICO )))
         do COL = 0 to W.ICO - 1
            PIX.ROW.COL = x2d( b2x( left( BIT, B.ICO )))
            BIT = substr( BIT, B.ICO + 1 )
         end COL
      end ROW

      do ROW = 0 to H.ICO - 1
         OFS = OFS + M.ICO
         BIT = x2b( c2x( charin( SRC, , M.ICO )))
         do COL = 0 to W.ICO - 1
            CHK = left( BIT, 1 ) ;  BIT = substr( BIT, 2 )
            RGB = PIX.ROW.COL    ;  RGB = PAL.RGB
            select
               when  CHK = 0              then  PIX.ROW.COL = RGB
               when  RGB = x2c( 000000 )  then  PIX.ROW.COL = ''
               otherwise   PIX.ROW.COL = bitxor( RGB, 'FFFFFF'x )
            end                  /* note transparent 000000 as '' */
         end COL                 /* else XOR all bits for AND = 1 */
      end ROW

      PAL.0 = 0                  ;  PAL.. = 0
      do ROW = 0 to H.ICO - 1    /* new palette from scratch      */
         do COL = 0 to W.ICO - 1
            if PIX.ROW.COL = ''  then  do
               PAL.. = 1         ;  iterate COL
            end                  /* PAL.. = 1 (transparency used) */
            do N = 1 to PAL.0    /* PAL.0 is the colour counter   */
               if PAL.N = PIX.ROW.COL  then  iterate COL
            end                  /* PAL.N = RGB of used colours   */
            PAL.0 = N            ;  PAL.N = PIX.ROW.COL
         end COL
      end ROW

      CPP = 1 + ( N > 64 )       /* characters per pixel (1 or 2) */
      call lineout DST, '! XPM2' ;  N = PAL.0 + PAL..
      call lineout DST, W.ICO H.ICO N CPP

      CHK = 'abcdefghijklmnopqrstuvwxyz'
      CHK = translate( CHK ) || CHK || '0123456789+/'
      if PAL.. then  do          /* using dot(s) for transparency */
         PAL.. = copies( '.', CPP )
         call lineout DST, PAL 'c none'
      end
      do N = 1 to PAL.0
         X = substr( CHK, ( N - 1 ) // 64 + 1, 1 )
         if CPP - 1  then  do    /* intentional error for bad CPP */
            X = X || substr( ":|!'", ( N - 1 ) % 64, 1 )
         end
         RGB = PAL.N             ;  NDX.RGB = X
         call lineout DST, X 'c #' || c2x( RGB )
      end N                      /* NDX.RGB for reverse lookup    */

      do ROW = H.ICO - 1 to 0 by -1
         X = ''
         do COL = 0 to W.ICO - 1
            RGB = PIX.ROW.COL
            if RGB = '' then  X = X || PAL..
                        else  X = X || NDX.RGB
         end COL
         call lineout DST, X
      end ROW
   end ICO

   if chars( SRC ) > 0
      then  exit WARN( 'ignoring' chars( SRC ) 'trailing bytes' ) +1
      else  return 0

LPAD: procedure                  /* length is multiple of 32 bits */
   arg LEN, TMP                  ;  LEN = LEN * TMP
   TMP = LEN // 32               ;  if TMP <> 0 then  TMP = 32 - TMP
   return ( LEN + TMP ) / 8

ICON: procedure
   parse arg SRC, DST
   return WARN( 'XPM2 to' DST 'not yet implemented' ) +1

/* see <URL:http://purl.net/xyzzy/rexxtrap.htm>, (c) F. Ellermann */

WARN: procedure                  /* try RxMessageBox, then STDERR */
   parse source . . THIS         ;  signal on syntax name WARN.TRAP
   return ( RxMessageBox( arg( 1 ), THIS, /**/, 'HAND' ) <> 1 )
WARN.TRAP:
   parse version THIS .          ;  signal on syntax name TRAP
   if THIS = 'REXXSAA'           /* fails if no more file handle: */
      then return lineout( 'STDERR'  , arg( 1 ))
      else return lineout( '\dev\con', arg( 1 ))

TRAP:                            /* select REXX exception handler */
   call trace 'O' ;  trace N           /* don't trace interactive */
   parse source TRAP                   /* source on separate line */
   TRAP = x2c( 0D ) || right( '+++', 10 ) TRAP || x2c( 0D0A )
   TRAP = TRAP || right( '+++', 10 )   /* = standard trace prefix */
   TRAP = TRAP strip( condition( 'c' ) 'trap:' condition( 'd' ))
   select
      when wordpos( condition( 'c' ), 'ERROR FAILURE' ) > 0 then do
         if condition( 'd' ) > ''      /* need an additional line */
            then TRAP = TRAP || x2c( 0D0A ) || right( '+++', 10 )
         TRAP = TRAP '(RC' rc || ')'   /* any system error codes  */
         if condition( 'c' ) = 'FAILURE' then rc = -3
      end
      when wordpos( condition( 'c' ), 'HALT SYNTAX'   ) > 0 then do
         if condition( 'c' ) = 'HALT' then rc = 4
         if condition( 'd' ) > '' & condition( 'd' ) <> rc then do
            if condition( 'd' ) <> errortext( rc ) then do
               TRAP = TRAP || x2c( 0D0A ) || right( '+++', 10 )
               TRAP = TRAP errortext( rc )
            end                        /* future condition( 'd' ) */
         end                           /* may use errortext( rc ) */
         else  TRAP = TRAP errortext( rc )
         rc = -rc                      /* rc < 0: REXX error code */
      end
      when condition( 'c' ) = 'NOVALUE'  then rc = -2 /* dubious  */
      when condition( 'c' ) = 'NOTREADY' then rc = -1 /* dubious  */
      otherwise                        /* force non-zero whole rc */
         if datatype( value( 'RC' ), 'W' ) = 0 then rc = 1
         if rc = 0                             then rc = 1
         if condition() = '' then TRAP = TRAP arg( 1 )
   end                                 /* direct: TRAP( message ) */

   TRAP = TRAP || x2c( 0D0A ) || format( sigl, 6 )
   signal on syntax name TRAP.SIGL     /* throw syntax error 3... */
   if 0 < sigl & sigl <= sourceline()  /* if no handle for source */
      then TRAP = TRAP '*-*' strip( sourceline( sigl ))
      else TRAP = TRAP '+++ (source line unavailable)'
TRAP.SIGL:                             /* ...catch syntax error 3 */
   if abbrev( right( TRAP, 2 + 6 ), x2c( 0D0A )) then do
      TRAP = TRAP '+++ (source line unreadable)'   ;  rc = -rc
   end
   select
      when 0 then do                   /* in pipes STDERR: output */
         parse version TRAP.REXX       /* REXX/Personal: \dev\con */
         if abbrev( TRAP.REXX, 'REXXSAA ' ) |                /**/ ,
            6 <= word( TRAP.REXX, 2 )  then  TRAP.REXX = 'STDERR'
                                       else  TRAP.REXX = '\dev\con'
         signal on syntax name TRAP.FAIL
         call lineout TRAP.REXX , TRAP /* fails if no more handle */
      end
      when 1 then do                   /* OS/2 PM or ooREXX on NT */
         signal on syntax name TRAP.FAIL
         call RxMessageBox translate( TRAP, ' ', x2c( 0D )), /**/ ,
            'Trap' time(),, 'ERROR'
      end
      otherwise   say TRAP ; trace ?L  /* interactive Label trace */
   end

   if condition() = 'SIGNAL' then signal TRAP.EXIT
TRAP.CALL:  return rc                  /* continue after CALL ON  */
TRAP.FAIL:  say TRAP ;  rc = 0 - rc    /* force TRAP error output */
TRAP.EXIT:  exit   rc                  /* exit for any SIGNAL ON  */