1#lang racket/base 2(require racket/contract 3 compiler/private/pe-rsrc) 4 5(provide ico? 6 (contract-out 7 [ico-width (ico? . -> . exact-positive-integer?)] 8 [ico-height (ico? . -> . exact-positive-integer?)] 9 [ico-depth (ico? . -> . (or/c 1 2 4 8 16 24 32))] 10 [ico-format (ico? . -> . (or/c 'bmp 'png))] 11 12 [read-icos ((or/c path-string? input-port?) . -> . (listof ico?))] 13 [read-icos-from-exe ((or/c path-string? input-port?) . -> . (listof ico?))] 14 15 [write-icos ([(listof ico?) (or/c path-string? output-port?)] 16 [#:exists (or/c 'error 'append 'update 'can-update 17 'replace 'truncate 18 'must-truncate 'truncate/replace)] 19 . ->* . 20 void?)] 21 [replace-icos ((listof ico?) path-string? . -> . void?)] 22 [replace-all-icos ((listof ico?) path-string? . -> . void?)] 23 24 [ico->argb (ico? . -> . bytes?)] 25 [ico->png-bytes (ico? . -> . bytes?)] 26 [argb->ico ([(integer-in 1 256) (integer-in 1 256) bytes? ] 27 [#:depth (one-of/c 1 2 4 8 24 32)] 28 . ->* . 29 ico?)] 30 [png-bytes->ico ([bytes?] 31 [] 32 . ->* . 33 ico?)])) 34 35;; parse-ico build-ico 36 37(define (byte->integer p) 38 (read-byte p)) 39(define (word->integer p) 40 (integer-bytes->integer (read-bytes 2 p) #f #f)) 41(define (dword->integer p) 42 (integer-bytes->integer (read-bytes 4 p) #f #f)) 43 44;; The 0 added in the alpha position apparently means "ignore the alpha 45;; and use the mask, instead" 46(define (3/2word->integer p) 47 (integer-bytes->integer (bytes-append (read-bytes 3 p) #"\0") #f #f)) 48 49(define (integer->word i p) 50 (display (integer->integer-bytes i 2 #f #f) p)) 51(define (integer->dword i p) 52 (display (integer->integer-bytes i 4 #f #f) p)) 53(define (integer->3/2word i p) 54 (display (subbytes (integer->integer-bytes i 4 #f #f) 0 3) p)) 55 56(define-struct ico (desc data) #:mutable) 57;; desc is (list width height colors 0 planes bitcount) 58;; data is (cons pos bytes) 59 60(define (ico-width i) (let ([v (car (ico-desc i))]) 61 (if (= v 0) 62 (if (eq? (ico-format i) 'bmp) 63 256 64 (ico-png-width i)) 65 v))) 66(define (ico-height i) (let ([v (cadr (ico-desc i))]) 67 (if (= v 0) 68 (if (eq? (ico-format i) 'bmp) 69 256 70 (ico-png-height i)) 71 v))) 72(define (ico-depth i) 73 (let ([cols (caddr (ico-desc i))]) 74 (if (zero? cols) 75 (list-ref (ico-desc i) 5) 76 (integer-length (sub1 cols))))) 77(define (ico-colors i) (num-colors (ico-desc i))) 78 79(define (ico-format i) 80 (define bstr (cdr (ico-data i))) 81 (define tag (subbytes bstr 0 2)) 82 (cond 83 [(and ((bytes-length bstr) . > . 4) 84 (equal? (subbytes bstr 0 4) #"\211PNG")) 85 'png] 86 [else 87 ;; Assume BMP 88 'bmp])) 89 90(define (ico-png-width i) 91 (png-width (cdr (ico-data i)))) 92(define (png-width bstr) 93 (integer-bytes->integer (subbytes bstr 16 20) #f #t)) 94(define (ico-png-height i) 95 (png-height (cdr (ico-data i)))) 96(define (png-height bstr) 97 (integer-bytes->integer (subbytes bstr 20 24) #f #t)) 98 99(define (num-colors l) 100 (let ([n (caddr l)]) 101 (if (zero? n) 102 (arithmetic-shift 1 (list-ref l 5)) 103 n))) 104 105(define (replace-icos ico-icos exe-file) 106 (let ([exe-icos (read-icos-from-exe exe-file)]) 107 (let ([p (open-output-file exe-file #:exists 'update)]) 108 (dynamic-wind 109 void 110 (lambda () 111 (for-each (lambda (exe-ico) 112 (let ([best-ico-ico 113 ;; Find exact match? 114 (ormap (lambda (ico-ico) 115 (let ([le (ico-desc exe-ico)] 116 [li (ico-desc ico-ico)]) 117 (and (= (ico-width exe-ico) (ico-width ico-ico)) 118 (= (ico-height exe-ico) (ico-height ico-ico)) 119 (= (num-colors li) (num-colors le)) 120 (= (bytes-length (cdr (ico-data exe-ico))) 121 (bytes-length (cdr (ico-data ico-ico)))) 122 ico-ico))) 123 ico-icos)]) 124 (let ([ico-ico (or best-ico-ico 125 ;; Look for a conversion, if we 126 ;; need a 16x16, 32x32, or 48x48 127 ;; ico 128 (and 129 (= (ico-width exe-ico) 130 (ico-height exe-ico)) 131 (memq (car (ico-desc exe-ico)) 132 '(16 32 48)) 133 (let ([biggest-colorest #f]) 134 (for-each 135 (lambda (ico-ico) 136 (let ([w (ico-width ico-ico)] 137 [exew (ico-width exe-ico)]) 138 (when (and 139 (= w (ico-width ico-ico)) 140 (memq w '(16 32 48)) 141 (or 142 (not biggest-colorest) 143 (and (= w exew) 144 (not (= exew (ico-width biggest-colorest)))) 145 (and (= w exew) 146 (> (num-colors (ico-desc ico-ico)) 147 (num-colors (ico-desc biggest-colorest)))) 148 (and (not (= exew (ico-width biggest-colorest))) 149 (or (> w (ico-width biggest-colorest)) 150 (> (num-colors (ico-desc ico-ico)) 151 (num-colors (ico-desc biggest-colorest))))))) 152 (set! biggest-colorest ico-ico)))) 153 ico-icos) 154 (and 155 biggest-colorest 156 ;; Convert... 157 (let* ([src-size (ico-width biggest-colorest)] 158 [dest-size (ico-width exe-ico)] 159 [src (parse-ico biggest-colorest)] 160 [image (list-ref src 3)] 161 [mask (list-ref src 4)] 162 [has-alpha? (<= 256 (num-colors (ico-desc biggest-colorest)))]) 163 (if (= src-size dest-size) 164 (build-ico exe-ico 165 (if has-alpha? 166 image 167 (mask->alpha image mask)) 168 mask 169 #t) 170 (let ([cvt 171 (cond 172 [(and (= src-size 32) (= dest-size 16)) 173 (lambda (i) (48->16 (32->48 i)))] 174 [(and (= src-size 32) (= dest-size 48)) 175 32->48] 176 [(and (= src-size 48) (= dest-size 16)) 177 48->16] 178 [(and (= src-size 48) (= dest-size 32)) 179 48->32] 180 [(and (= src-size 16) (= dest-size 32)) 181 16->32] 182 [(and (= src-size 16) (= dest-size 48)) 183 (lambda (i) (32->48 (16->32 i)))])]) 184 (let ([mask (cvt mask)]) 185 (build-ico exe-ico 186 (if has-alpha? 187 (cvt image) 188 (mask->alpha (cvt image) mask)) 189 mask 190 #t)))))))))]) 191 (unless ico-ico (log-error "no icon conversion available to ~a" (ico-desc exe-ico))) 192 (when ico-ico 193 (file-position p (let ([d (car (ico-data exe-ico))]) 194 (if (vector? d) 195 (vector-ref d 0) 196 d))) 197 (display (cdr (ico-data ico-ico)) p))))) 198 exe-icos)) 199 (lambda () (close-output-port p)))))) 200 201(define (replace-all-icos ico-list exe-file) 202 (define-values (pe rsrcs) 203 (call-with-input-file* 204 exe-file 205 read-pe+resources)) 206 (define-values (type name language icos file-pos) 207 (resource-ref/path rsrcs 14 #f #f)) 208 (define old-icos 209 (if icos 210 (get-icos (open-input-bytes icos) rsrcs) 211 null)) 212 (define (ico-res-type i) (vector-ref (car (ico-data i)) 1)) 213 (define (ico-res-name i) (vector-ref (car (ico-data i)) 2)) 214 (define (ico-res-language i) (vector-ref (car (ico-data i)) 3)) 215 (define cleaned-rsrcs 216 (for/fold ([rsrcs rsrcs]) ([old-i (in-list old-icos)]) 217 (resource-remove rsrcs 218 (ico-res-type old-i) 219 (ico-res-name old-i) 220 (ico-res-language old-i)))) 221 ;; Replace individual icons where size and depth match 222 (define-values (new-rsrcs named-icos) 223 (for/fold ([rsrcs cleaned-rsrcs] [named-icos null]) ([i (in-list ico-list)]) 224 (define old-i (for/or ([old-i (in-list old-icos)]) 225 (and (= (ico-width i) (ico-width old-i)) 226 (= (ico-height i) (ico-height old-i)) 227 (= (ico-depth i) (ico-depth old-i)) 228 old-i))) 229 (define name 230 (cond 231 [old-i (ico-res-name old-i)] 232 [else 233 ;; Generate next unused id: 234 (let loop ([id 1]) 235 (if (resource-ref rsrcs 3 id 1033) 236 (loop (add1 id)) 237 id))])) 238 (values (resource-set rsrcs 239 3 240 name 241 1033 242 (cdr (ico-data i))) 243 (cons (ico (ico-desc i) 244 (cons (vector #f 4 name 1033) 245 (cdr (ico-data i)))) 246 named-icos)))) 247 ;; Update ico: 248 (define ready-rsrcs 249 (resource-set new-rsrcs type name language (make-icos-header named-icos))) 250 ;; Write new resources: 251 (update-resources exe-file pe ready-rsrcs)) 252 253(define (make-icos-header icos) 254 (define o (open-output-bytes)) 255 (integer->word 0 o) 256 (integer->word 1 o) 257 (integer->word (length icos) o) 258 (for ([i (in-list icos)]) 259 (define desc (ico-desc i)) 260 (write-byte (list-ref desc 0) o) 261 (write-byte (list-ref desc 1) o) 262 (write-byte (list-ref desc 2) o) 263 (write-byte (list-ref desc 3) o) 264 (integer->word (list-ref desc 4) o) 265 (integer->word (list-ref desc 5) o) 266 (integer->dword (bytes-length (cdr (ico-data i))) o) 267 (integer->word (vector-ref (car (ico-data i)) 2) o)) 268 (get-output-bytes o)) 269 270;; ------------------------------ 271;; Image parsing 272;; ------------------------------ 273 274(define (get-icos file rsrcs) 275 (let ([p (if (input-port? file) 276 file 277 (open-input-file file))]) 278 (dynamic-wind 279 void 280 (lambda () 281 (unless (= 0 (word->integer p)) 282 (error 'get-icos "~a doesn't start with 0" file)) 283 (unless (= 1 (word->integer p)) 284 (error "type isn't 1")) 285 (let ([cnt (word->integer p)]) 286 (let ([icos (let loop ([i 0]) 287 (if (= i cnt) 288 null 289 (cons 290 (make-ico 291 (list (byte->integer p) ; w 292 (byte->integer p) ; h 293 (byte->integer p) ; colors 294 (byte->integer p) ; 0 295 (word->integer p) ; planes 296 (word->integer p)) ; bitcount 297 (list (dword->integer p) ; bytes 298 ((if rsrcs ; where or icon id 299 word->integer 300 dword->integer) 301 p))) 302 (loop (add1 i)))))]) 303 ;; (printf "~a\n" icos) 304 (for-each (lambda (ico) 305 (set-ico-data! 306 ico 307 (let ([size (car (ico-data ico))] 308 [where (cadr (ico-data ico))]) 309 (cond 310 [rsrcs 311 (define-values (type name lang bstr file-pos) 312 (resource-ref/path rsrcs 3 where #f)) 313 (cons (vector file-pos type name lang) 314 bstr)] 315 [else 316 (file-position p where) 317 (cons where 318 (read-bytes size p))]))) 319 ;; If colors, planes, and bitcount are all 0, 320 ;; get the info from the DIB data 321 (let ([desc (ico-desc ico)]) 322 (when (and (zero? (list-ref desc 2)) 323 (zero? (list-ref desc 4)) 324 (zero? (list-ref desc 5))) 325 (let ([bi (bitmapinfo ico)]) 326 (set-ico-desc! ico 327 (list* 328 (list-ref desc 0) 329 (list-ref desc 1) 330 (list-ref desc 2) 331 (list-ref desc 3) 332 (list-ref bi 3) 333 (list-ref bi 4) 334 (list-tail desc 6))))))) 335 icos) 336 icos))) 337 (lambda () 338 (when (path-string? file) 339 (close-input-port p)))))) 340 341(define (bitmapinfo ico) 342 (let ([p (open-input-bytes (cdr (ico-data ico)))]) 343 (list (dword->integer p) ; size == 40 in practice 344 (dword->integer p) ; width 345 (dword->integer p) ; height 346 (word->integer p) ; planes 347 (word->integer p) ; bitcount 348 (dword->integer p) ; compression == 0 349 (dword->integer p) ; size image 350 (dword->integer p) ; x pixels per meter == 0 351 (dword->integer p) ; y pixels per meter == 0 352 (dword->integer p) ; used == 0 353 (dword->integer p)))) ; important == 0 354 355;; Assumes that bits-per-pixel is 1, 2, 4, 8, 16, 24, or 32. 356;; Also assumes that (bits-per-pixel * width) is a multiple of 8. 357(define (parse-dib ico) 358 (let* ([bi (bitmapinfo ico)] 359 [header-size (list-ref bi 0)] 360 [num-colors (caddr (ico-desc ico))] 361 [w (list-ref bi 1)] 362 [h (/ (list-ref bi 2) 2)] 363 [bits-per-pixel (list-ref bi 4)]) 364 (let ([p (open-input-bytes (cdr (ico-data ico)))]) 365 ;; Skip header 366 (read-bytes header-size p) 367 (let* ([read-n 368 (lambda (n read-one combine) 369 (let loop ([i n][r null]) 370 (if (= i 0) 371 (reverse r) 372 (loop (sub1 i) 373 (combine (read-one p) r)))))] 374 [read-lines 375 (lambda (w h read-one combine) 376 (if (zero? (modulo w 4)) 377 (read-n (* w h) read-one combine) 378 (let loop ([h h]) 379 (if (zero? h) 380 null 381 (append (read-n w read-one combine) 382 (begin 383 ;; pad line to dword: 384 (read-n (- 4 (modulo w 4)) byte->integer cons) 385 ;; read next line: 386 (loop (sub1 h))))))))] 387 [split-bits (lambda (b) 388 (list 389 (bitwise-and b 1) 390 (arithmetic-shift (bitwise-and b 2) -1) 391 (arithmetic-shift (bitwise-and b 4) -2) 392 (arithmetic-shift (bitwise-and b 8) -3) 393 (arithmetic-shift (bitwise-and b 16) -4) 394 (arithmetic-shift (bitwise-and b 32) -5) 395 (arithmetic-shift (bitwise-and b 64) -6) 396 (arithmetic-shift (bitwise-and b 128) -7)))]) 397 (let ([main-image 398 (cond 399 [(= bits-per-pixel 32) 400 ;; RGB mode: 401 (read-n (* w h) dword->integer cons)] 402 [(= bits-per-pixel 24) 403 ;; RGB mode: 404 (read-n (* w h) 3/2word->integer cons)] 405 [else 406 ;; Index mode: 407 (let ([color-table (list->vector 408 (read-n (if (zero? num-colors) 409 (arithmetic-shift 1 bits-per-pixel) 410 num-colors) 411 dword->integer cons))] 412 [image (read-lines (/ w (/ 8 bits-per-pixel)) 413 h 414 (lambda (p) 415 (let ([b (byte->integer p)]) 416 (case bits-per-pixel 417 [(1) (split-bits b)] 418 [(2) 419 (list 420 (bitwise-and b 3) 421 (arithmetic-shift (bitwise-and b 12) -2) 422 (arithmetic-shift (bitwise-and b 48) -4) 423 (arithmetic-shift (bitwise-and b 192) -6))] 424 [(4) 425 (list 426 (bitwise-and b 15) 427 (arithmetic-shift (bitwise-and b 240) -4))] 428 [(8) (list b)]))) 429 append)]) 430 (map (lambda (i) (vector-ref color-table i)) image))])]) 431 (let ([mask (read-lines (/ w 8) 432 h 433 (lambda (p) (split-bits (byte->integer p))) 434 append)]) 435 ;; The following check is commented out, because the "start.ico" file 436 ;; for the GUI package manager has an extra 128 0s --- and I don't know 437 ;; why. Maybe extra padding is allowed. 438 #; 439 (unless (eof-object? (read-byte p)) 440 (error 'parse-dib "not extactly at end")) 441 (list main-image mask))))))) 442 443;; rgb->indexed 444;; The color-reduction strategy isn't great, and because it 445;; depends on hash-table order, it's non-deterministic in 446;; principle. But the actual hash-table implementation is 447;; deterministic, of course. Also, the re-ordering of the 448;; image via the hash tables tends to produce better 449;; (pseudo-random) representatives of the image for colors. 450(define (rgb->indexed image num-colors) 451 (let ([image (map (lambda (i) (bitwise-and #xFFFFFF i)) image)] ; drop alphas, if any 452 [table (make-vector num-colors 0)] 453 [ht (make-hash)] 454 [map-ht (make-hash)] 455 [color-dist (lambda (a b) 456 (sqrt (+ (expt (- (bitwise-and #xFF a) 457 (bitwise-and #xFF b)) 458 2) 459 (expt (- (arithmetic-shift (bitwise-and #xFF00 a) -8) 460 (arithmetic-shift (bitwise-and #xFF00 b) -8)) 461 2) 462 (expt (- (arithmetic-shift (bitwise-and #xFF0000 a) -16) 463 (arithmetic-shift (bitwise-and #xFF0000 b) -16)) 464 2))))]) 465 (for-each (lambda (c) 466 (hash-set! 467 ht 468 c 469 (add1 470 (hash-ref ht c 0)))) 471 image) 472 (let ([kv-sorted (sort (hash-map ht cons) 473 (lambda (a b) (< (cdr a) (cdr b))))]) 474 (let ([n 0]) 475 (for-each (lambda (kv) 476 (let ([key (car kv)]) 477 (let ([n (if (< n (sub1 num-colors)) 478 n 479 ;; Find closest match: 480 (let ([n 0]) 481 (let loop ([i 1]) 482 (unless (= i num-colors) 483 (when (< (color-dist key (vector-ref table i)) 484 (color-dist key (vector-ref table n))) 485 (set! n i)) 486 (loop (add1 i)))) 487 n))]) 488 (vector-set! table n key) 489 (hash-set! map-ht key n)) 490 (when (< n (sub1 num-colors)) 491 (set! n (add1 n))))) 492 kv-sorted))) 493 (values (vector->list table) 494 (map (lambda (c) (hash-ref map-ht c)) image)))) 495 496;; Assumes that bits-per-pixel is 1, 2, 4, 8, or 32. 497;; Also assumes that (bits-per-pixel * width) is a multiple of 8. 498(define (build-dib ico image mask check?) 499 (let* ([bi (bitmapinfo ico)] 500 [header-size (list-ref bi 0)] 501 [num-colors (caddr (ico-desc ico))] 502 [w (list-ref bi 1)] 503 [h (/ (list-ref bi 2) 2)] 504 [bits-per-pixel (list-ref bi 4)]) 505 (let ([orig-p (open-input-bytes (cdr (ico-data ico)))] 506 [result-p (open-output-bytes)]) 507 ;; Copy header: 508 (display (read-bytes header-size orig-p) result-p) 509 (let ([get-lines (lambda (image bits-per-pixel) 510 (map (lambda (line) 511 ;; pad line to dword boundary 512 (let ([line-bytes (/ (* w bits-per-pixel) 8)]) 513 (if (zero? (modulo line-bytes 4)) 514 line 515 (append line 516 (vector->list 517 (make-vector (* (- 4 (modulo line-bytes 4)) 518 (/ 8 bits-per-pixel)) 519 0)))))) 520 ;; break out lines 521 (let loop ([l image]) 522 (if (null? l) 523 null 524 (cons (let loop ([l l][i 0]) 525 (if (= i w) 526 null 527 (cons (car l) (loop (cdr l) (add1 i))))) 528 (loop (list-tail l w)))))))] 529 [bits->dwords (lambda (l bpp) 530 (let ([chunk-size (/ 32 bpp)] 531 [1byte (lambda (l) 532 (bitwise-ior 533 (arithmetic-shift (list-ref l 0) 7) 534 (arithmetic-shift (list-ref l 1) 6) 535 (arithmetic-shift (list-ref l 2) 5) 536 (arithmetic-shift (list-ref l 3) 4) 537 (arithmetic-shift (list-ref l 4) 3) 538 (arithmetic-shift (list-ref l 5) 2) 539 (arithmetic-shift (list-ref l 6) 1) 540 (arithmetic-shift (list-ref l 7) 0)))] 541 [2byte (lambda (l) 542 (bitwise-ior 543 (arithmetic-shift (list-ref l 0) 6) 544 (arithmetic-shift (list-ref l 1) 4) 545 (arithmetic-shift (list-ref l 2) 2) 546 (arithmetic-shift (list-ref l 3) 0)))] 547 [4byte (lambda (l) 548 (bitwise-ior 549 (arithmetic-shift (list-ref l 0) 4) 550 (arithmetic-shift (list-ref l 1) 0)))]) 551 (let loop ([l l]) 552 (if (null? l) 553 null 554 (cons (case bpp 555 [(1) (bitwise-ior 556 (arithmetic-shift (1byte (list-tail l 0)) 0) 557 (arithmetic-shift (1byte (list-tail l 8)) 8) 558 (arithmetic-shift (1byte (list-tail l 16)) 16) 559 (arithmetic-shift (1byte (list-tail l 24)) 24))] 560 [(2) (bitwise-ior 561 (2byte l) 562 (arithmetic-shift (2byte (list-tail l 4)) 8) 563 (arithmetic-shift (2byte (list-tail l 8)) 16) 564 (arithmetic-shift (2byte (list-tail l 12)) 24))] 565 [(4) (bitwise-ior 566 (4byte l) 567 (arithmetic-shift (4byte (list-tail l 2)) 8) 568 (arithmetic-shift (4byte (list-tail l 4)) 16) 569 (arithmetic-shift (4byte (list-tail l 6)) 24))] 570 [(8) (bitwise-ior 571 (car l) 572 (arithmetic-shift (list-ref l 1) 8) 573 (arithmetic-shift (list-ref l 2) 16) 574 (arithmetic-shift (list-ref l 3) 24))]) 575 (loop (list-tail l chunk-size)))))))]) 576 (cond 577 [(= bits-per-pixel 32) 578 (for-each (lambda (col) (integer->dword col result-p)) 579 image)] 580 [(= bits-per-pixel 24) 581 (for-each (lambda (col) (integer->3/2word col result-p)) 582 image)] 583 [else 584 (let-values ([(colors indexed-image) (rgb->indexed image (arithmetic-shift 1 bits-per-pixel))]) 585 ;; color table 586 (for-each (lambda (col) (integer->dword col result-p)) 587 colors) 588 (let* ([lines (get-lines indexed-image bits-per-pixel)] 589 [dwords (apply append (map (lambda (l) (bits->dwords l bits-per-pixel)) 590 lines))]) 591 (for-each (lambda (col) (integer->dword col result-p)) 592 dwords)))]) 593 (let* ([lines (get-lines mask 1)] 594 [dwords (apply append (map (lambda (l) (bits->dwords l 1)) lines))]) 595 (for-each (lambda (col) (integer->dword col result-p)) 596 dwords)) 597 (let ([s (get-output-bytes result-p)]) 598 (when check? 599 (unless (= (bytes-length s) (bytes-length (cdr (ico-data ico)))) 600 (error 'build-dib "bad result size ~a != ~a" 601 (bytes-length s) (bytes-length (cdr (ico-data ico)))))) 602 s))))) 603 604(define (parse-ico ico) 605 (let ([image (parse-dib ico)]) 606 (list (ico-width ico) 607 (ico-height ico) 608 (ico-colors ico) 609 (car image) ; list of image pixels 610 (cadr image)))) ; list of mask pixels 611 612(define (ico->argb ico) 613 (unless (eq? 'bmp (ico-format ico)) 614 (error 'ico->argb "icon not in BMP format")) 615 (let* ([image (parse-ico ico)] 616 [pixels (list-ref image 3)] 617 [len (length pixels)] 618 [bstr (make-bytes (* 4 len))] 619 [w (ico-width ico)] 620 [h (ico-height ico)] 621 [has-alpha? (= 32 (ico-depth ico))]) 622 (for ([p (in-list pixels)] 623 [m (in-list (list-ref image 4))] 624 [i (in-naturals)]) 625 (let* ([y (- h (quotient i w) 1)] 626 [x (modulo i w)] 627 [i (+ x (* w y))]) 628 (bytes-set! bstr (+ 0 (* i 4)) (if has-alpha? 629 (bitwise-and #xff (arithmetic-shift p -24)) 630 (if (zero? m) 255 0))) 631 (bytes-set! bstr (+ 1 (* i 4)) (bitwise-and #xff (arithmetic-shift p -16))) 632 (bytes-set! bstr (+ 2 (* i 4)) (bitwise-and #xff (arithmetic-shift p -8))) 633 (bytes-set! bstr (+ 3 (* i 4)) (bitwise-and #xff p)))) 634 bstr)) 635 636(define (ico->png-bytes ico) 637 (unless (eq? 'png (ico-format ico)) 638 (error 'ico->argb "icon not in PNG format")) 639 (cdr (ico-data ico))) 640 641(define (build-ico base-ico image mask check?) 642 (make-ico (ico-desc base-ico) 643 (cons (car (ico-data base-ico)) 644 (build-dib base-ico image mask check?)))) 645 646(define (read-icos ico-file) 647 (get-icos ico-file #f)) 648 649(define (read-icos-from-exe exe-file) 650 (define-values (pe rsrcs) 651 (call-with-input-file* 652 exe-file 653 read-pe+resources)) 654 (define icos (resource-ref rsrcs 14 #f #f)) 655 (get-icos (open-input-bytes icos) rsrcs)) 656 657(define (write-header w h depth o) 658 (integer->dword 40 o) ; size 659 (integer->dword w o) ; width 660 (integer->dword (* 2 h) o) ; height 661 (integer->word 1 o) ; planes 662 (integer->word depth o) ; bitcount 663 (integer->dword 0 o) ; compression 664 (integer->dword 0 o) ; size image 665 (integer->dword 0 o) ; x pixels per meter 666 (integer->dword 0 o) ; y pixels per meter 667 (integer->dword 0 o) ; used 668 (integer->dword 0 o)) ; important 669 670(define (png-bytes->ico bstr) 671 (define (256+->0 v) (if (v . >= . 256) 0 v)) 672 (ico (list (256+->0 (png-width bstr)) (256+->0 (png-height bstr)) 0 0 1 32) 673 (cons #f bstr))) 674 675(define (argb->ico w h argb #:depth [depth 32]) 676 (let ([o (open-output-bytes)]) 677 (write-header w h 32 o) 678 ;; Got ARGB, need BGRA 679 (let* ([flip-pixels (lambda (s) 680 (let ([s (bytes-copy s)]) 681 (let loop ([p 0]) 682 (unless (= p (bytes-length s)) 683 (let ([a (bytes-ref s p)] 684 [r (bytes-ref s (+ p 1))] 685 [g (bytes-ref s (+ p 2))] 686 [b (bytes-ref s (+ p 3))]) 687 (bytes-set! s p b) 688 (bytes-set! s (+ p 1) g) 689 (bytes-set! s (+ p 2) r) 690 (bytes-set! s (+ p 3) a) 691 (loop (+ p 4))))) 692 s))] 693 [rgba (flip-pixels argb)] 694 [row-size (if (zero? (modulo w 32)) 695 w 696 (+ w (- 32 (remainder w 32))))] 697 [mask (make-bytes (* h row-size 1/8) 0)]) 698 (let loop ([i (* w h 4)]) 699 (unless (zero? i) 700 (let ([alpha (bytes-ref rgba (- i 1))]) 701 (when (< alpha 10) 702 ;; white mask -> zero alpha; add white pixel to mask 703 (bytes-set! rgba (- i 1) 0) 704 (let ([pos (+ (* (quotient (sub1 (/ i 4)) w) row-size) 705 (remainder (sub1 (/ i 4)) w))]) 706 (bytes-set! mask 707 (quotient pos 8) 708 (bitwise-ior 709 (arithmetic-shift 1 (- 7 (remainder pos 8))) 710 (bytes-ref mask (quotient pos 8))))))) 711 (loop (- i 4)))) 712 ;; Windows icos are upside-down: 713 (let ([flip (lambda (str row-width) 714 (apply 715 bytes-append 716 (reverse 717 (let loop ([pos 0]) 718 (if (= pos (bytes-length str)) 719 null 720 (cons (subbytes str pos (+ pos row-width)) 721 (loop (+ pos row-width))))))))]) 722 (display (flip rgba (* w 4)) o) 723 (display (flip mask (/ row-size 8)) o)) 724 (define (256->0 v) (if (= v 256) 0 v)) 725 (let ([ico (make-ico (list (256->0 w) (256->0 h) 0 0 1 32) 726 (cons 0 (get-output-bytes o)))]) 727 (cond 728 [(= depth 32) ico] 729 [else (let ([o (open-output-bytes)]) 730 (write-header w h depth o) 731 (define image (parse-dib ico)) 732 (build-ico (make-ico (list (256->0 w) (256->0 h) 733 (if (depth . <= . 8) 734 (256->0 (expt 2 depth)) 735 0) 736 0 1 depth) 737 (cons 0 (get-output-bytes o))) 738 (car image) 739 (cadr image) 740 #f))]))))) 741 742 743(define (write-icos icos file #:exists [exists 'error]) 744 (let ([p #f]) 745 (dynamic-wind 746 (lambda () 747 (set! p (if (output-port? file) 748 file 749 (open-output-file file #:exists exists)))) 750 (lambda () 751 (integer->word 0 p) 752 (integer->word 1 p) ; 1 = icon 753 (define count (length icos)) 754 (integer->word count p) 755 (for/fold ([offset (+ 6 (* 16 count))]) ([i (in-list icos)]) 756 (define size (bytes-length (cdr (ico-data i)))) 757 (write-byte (car (ico-desc i)) p) 758 (write-byte (cadr (ico-desc i)) p) 759 (write-byte (list-ref (ico-desc i) 2) p) 760 (write-byte 0 p) 761 (integer->word (list-ref (ico-desc i) 4) p) 762 (integer->word (list-ref (ico-desc i) 5) p) 763 (integer->dword size p) 764 (integer->dword offset p) 765 (+ offset size)) 766 (for ([i (in-list icos)]) 767 (write-bytes (cdr (ico-data i)) p))) 768 (lambda () 769 (unless (output-port? file) 770 (close-output-port p)))))) 771 772;; ------------------------------ 773;; Image conversion 774;; ------------------------------ 775 776(define (mask->alpha image mask) 777 (map (lambda (i m) 778 (if (zero? m) 779 (bitwise-ior #xFF000000 i) 780 m)) 781 image mask)) 782 783(define (first-n n l) 784 (let loop ([l l][i n]) 785 (if (zero? i) 786 null 787 (cons (car l) (loop (cdr l) (sub1 i)))))) 788 789(define (16->32 l) 790 (let loop ([l l]) 791 (if (null? l) 792 null 793 (let ([l2 (let loop ([l (first-n 16 l)]) 794 (if (null? l) 795 null 796 (list* (car l) (car l) (loop (cdr l)))))]) 797 (append l2 l2 798 (loop (list-tail l 16))))))) 799 800(define (32->48 l) 801 (let loop ([l l][dup? #t]) 802 (if (null? l) 803 null 804 (let ([l2 (let loop ([l (first-n 32 l)]) 805 (if (null? l) 806 null 807 (list* (car l) (car l) (cadr l) 808 (loop (cddr l)))))]) 809 (append l2 810 (if dup? l2 null) 811 (loop (list-tail l 32) (not dup?))))))) 812 813(define (48->16 l) 814 (let loop ([l l]) 815 (if (null? l) 816 null 817 (let ([l2 (let loop ([l (first-n 48 l)]) 818 (if (null? l) 819 null 820 (cons (car l) (loop (cdddr l)))))]) 821 (append l2 822 (loop (list-tail l 144))))))) 823 824(define (48->32 l) 825 (let loop ([l l][step 0]) 826 (if (null? l) 827 null 828 (let ([l2 (let loop ([l (first-n 48 l)][step 0]) 829 (if (null? l) 830 null 831 (if (= 1 (modulo step 3)) 832 (loop (cdr l) 2) 833 (cons (car l) (loop (cdr l) (add1 step))))))]) 834 (append (if (= 1 (modulo step 3)) null l2) 835 (loop (list-tail l 48) (add1 step))))))) 836