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

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