basis/tools/deploy/windows/ico/ico.factor

   1 USING: accessors alien alien.c-types arrays classes.struct combinators
   2 io.backend kernel locals math sequences specialized-arrays
   3 tools.deploy.windows windows.kernel32 windows.types ;
   4 IN: tools.deploy.windows.ico
   5
   6 <PRIVATE
   7
   8 STRUCT: ico-header
   9     { Reserved WORD }
  10     { Type WORD }
  11     { ImageCount WORD } ;
  12
  13 STRUCT: ico-directory-entry
  14     { Width        BYTE  }
  15     { Height       BYTE  }
  16     { Colors       BYTE  }
  17     { Reserved     BYTE  }
  18     { Planes       WORD  }
  19     { BitsPerPixel WORD  }
  20     { ImageSize    DWORD }
  21     { ImageOffset  DWORD } ;
  22 SPECIALIZED-ARRAY: ico-directory-entry
  23
  24 STRUCT: group-directory-entry
  25     { Width        BYTE  }
  26     { Height       BYTE  }
  27     { Colors       BYTE  }
  28     { Reserved     BYTE  }
  29     { Planes       WORD  }
  30     { BitsPerPixel WORD  }
  31     { ImageSize    DWORD }
  32     { ImageResourceID WORD } ;
  33
  34 : ico>group-directory-entry ( ico i -- group )
  35     [ {
  36         [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
  37         [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
  38     } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
  39
  40 : ico-icon ( directory-entry bytes -- subbytes )
  41     [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
  42
  43 :: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
  44     bytes ico-header memory>struct :> header
  45
  46     ico-header heap-size bytes <displaced-alien>
  47     header ImageCount>> <direct-ico-directory-entry-array> :> directory
  48
  49     directory dup length iota [ ico>group-directory-entry ] { } 2map-as
  50         :> group-directory
  51     directory [ bytes ico-icon ] { } map-as :> icon-bytes
  52
  53     header clone >c-ptr group-directory concat append
  54     icon-bytes ; inline
  55
  56 PRIVATE>
  57
  58 :: embed-icon-resource ( exe ico-bytes id -- )
  59     exe normalize-path 1 BeginUpdateResource :> hUpdate
  60     hUpdate [
  61         ico-bytes ico-group-and-icons :> ( group icons )
  62         hUpdate RT_GROUP_ICON id 0 group dup byte-length
  63         UpdateResource drop
  64
  65         icons [| icon i |
  66             hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
  67             UpdateResource drop
  68         ] each-index
  69
  70         hUpdate 0 EndUpdateResource drop
  71     ] when ;
  72