From 4ebfd1ef3a84e9788a85d4b4386c2b6b0fb83305 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 15 Feb 2010 14:04:11 -0800
Subject: [PATCH] you have to parse the .ico file yourself and update
 individual RT_ICON and RT_GROUP_ICON resources. lame

---
 basis/tools/deploy/windows/ico/ico.factor | 72 +++++++++++++++++++++++
 basis/tools/deploy/windows/windows.factor | 12 +---
 2 files changed, 74 insertions(+), 10 deletions(-)
 create mode 100755 basis/tools/deploy/windows/ico/ico.factor
 mode change 100644 => 100755 basis/tools/deploy/windows/windows.factor

diff --git a/basis/tools/deploy/windows/ico/ico.factor b/basis/tools/deploy/windows/ico/ico.factor
new file mode 100755
index 0000000000..8ea7af348d
--- /dev/null
+++ b/basis/tools/deploy/windows/ico/ico.factor
@@ -0,0 +1,72 @@
+USING: accessors alien alien.c-types arrays classes.struct combinators
+io.backend kernel locals math sequences specialized-arrays
+tools.deploy.windows windows.kernel32 windows.types ;
+IN: tools.deploy.windows.ico
+
+<PRIVATE
+
+STRUCT: ico-header
+    { Reserved WORD }
+    { Type WORD }
+    { ImageCount WORD } ;
+
+STRUCT: ico-directory-entry
+    { Width        BYTE  }
+    { Height       BYTE  }
+    { Colors       BYTE  }
+    { Reserved     BYTE  }
+    { Planes       WORD  }
+    { BitsPerPixel WORD  }
+    { ImageSize    DWORD }
+    { ImageOffset  DWORD } ;
+SPECIALIZED-ARRAY: ico-directory-entry
+
+STRUCT: group-directory-entry
+    { Width        BYTE  }
+    { Height       BYTE  }
+    { Colors       BYTE  }
+    { Reserved     BYTE  }
+    { Planes       WORD  }
+    { BitsPerPixel WORD  }
+    { ImageSize    DWORD }
+    { ImageResourceID WORD } ;
+
+: ico>group-directory-entry ( ico i -- group )
+    [ {
+        [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
+        [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
+    } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
+
+: ico-icon ( directory-entry bytes -- subbytes )
+    [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
+
+:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
+    bytes ico-header memory>struct :> header
+
+    ico-header heap-size bytes <displaced-alien> 
+    header ImageCount>> <direct-ico-directory-entry-array> :> directory
+
+    directory dup length iota [ ico>group-directory-entry ] { } 2map-as
+        :> group-directory
+    directory [ bytes ico-icon ] { } map-as :> icon-bytes
+
+    header clone >c-ptr group-directory concat append
+    icon-bytes ; inline
+
+PRIVATE>
+
+:: embed-icon-resource ( exe ico-bytes id -- )
+    exe normalize-path 1 BeginUpdateResource :> hUpdate
+    hUpdate [
+        ico-bytes ico-group-and-icons :> ( group icons )
+        hUpdate RT_GROUP_ICON id 0 group dup byte-length
+        UpdateResource drop
+
+        icons [| icon i |
+            hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
+            UpdateResource drop
+        ] each-index
+
+        hUpdate 0 EndUpdateResource drop
+    ] when ;
+
diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor
old mode 100644
new mode 100755
index 9df13a9cdd..9f0b22847b
--- a/basis/tools/deploy/windows/windows.factor
+++ b/basis/tools/deploy/windows/windows.factor
@@ -5,7 +5,7 @@ io.encodings.ascii kernel namespaces
 sequences locals system splitting tools.deploy.backend
 tools.deploy.config tools.deploy.config.editor assocs hashtables
 prettyprint combinators windows.kernel32 windows.shell32 windows.user32
-alien.c-types vocabs.metadata vocabs.loader ;
+alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico ;
 IN: tools.deploy.windows
 
 CONSTANT: app-icon-resource-id "APPICON"
@@ -22,17 +22,9 @@ CONSTANT: app-icon-resource-id "APPICON"
     dup copy-dll
     deploy-ui? get ".exe" ".com" ? copy-vm ;
 
-:: (embed-ico) ( vm ico-bytes -- )
-    vm 0 BeginUpdateResource :> hUpdate
-    hUpdate [
-        hUpdate RT_ICON app-icon-resource-id 0 ico-bytes dup byte-length
-        UpdateResource drop
-        hUpdate 0 EndUpdateResource drop
-    ] when ;
-
 : embed-ico ( vm vocab -- )
     dup vocab-windows-icon-path vocab-append-path dup exists?
-    [ binary file-contents (embed-ico) ]
+    [ binary file-contents app-icon-resource-id embed-icon-resource ]
     [ 2drop ] if ;
 
 M: winnt deploy*