856 lines
32 KiB
Scheme
856 lines
32 KiB
Scheme
|
|
(module winicon mzscheme
|
|
(require (lib "list.ss"))
|
|
(provide install-icon
|
|
extract-icons
|
|
parse-icon
|
|
build-icon)
|
|
|
|
(define (byte->integer p)
|
|
(read-byte p))
|
|
(define (word->integer p)
|
|
(integer-bytes->integer (read-bytes 2 p) #f #f))
|
|
(define (dword->integer p)
|
|
(integer-bytes->integer (read-bytes 4 p) #f #f))
|
|
|
|
;; The 0 added in the alpha position apparently means "ignore the alpha
|
|
;; and use the mask, instead"
|
|
(define (3/2word->integer p)
|
|
(integer-bytes->integer (bytes-append (read-bytes 3 p) #"\0") #f #f))
|
|
|
|
(define (integer->word i p)
|
|
(display (integer->integer-bytes i 2 #f #f) p))
|
|
(define (integer->dword i p)
|
|
(display (integer->integer-bytes i 4 #f #f) p))
|
|
|
|
(define (flag v)
|
|
(positive? (bitwise-and #x80000000 v)))
|
|
(define (value v)
|
|
(bitwise-and #x7FFFFFFF v))
|
|
|
|
(define (skip-to-image-headers-after-signature p)
|
|
;; p is expected to be a file port
|
|
(file-position p 60)
|
|
(let ([pos (word->integer p)])
|
|
;; pos points to IMAGE_NT_HEADERS
|
|
(file-position p pos)
|
|
(unless (= #x4550 (dword->integer p))
|
|
(error "bad signature"))
|
|
pos))
|
|
|
|
(define (get-image-base p)
|
|
(let ([pos (skip-to-image-headers-after-signature p)])
|
|
(file-position p (+ 4
|
|
20
|
|
28))
|
|
(dword->integer p)))
|
|
|
|
(define (find-section p find-name)
|
|
(let ([pos (skip-to-image-headers-after-signature p)])
|
|
(word->integer p) ; skip machine
|
|
(let ([num-sections (word->integer p)]
|
|
[_ (begin (dword->integer p)
|
|
(dword->integer p)
|
|
(dword->integer p))]
|
|
[size (word->integer p)])
|
|
(let ([pos (+ pos
|
|
4 ; Signature : DWORD
|
|
20 ; FileHeader: IMAGE_FILE_HEADER
|
|
size)]) ; "optional" header
|
|
(let sloop ([section 0][section-pos pos])
|
|
(if (= section num-sections)
|
|
(error 'find-section "can't find section: ~e" find-name)
|
|
(begin
|
|
(file-position p section-pos)
|
|
;; p points to an IMAGE_SECTION_HEADER
|
|
(let ([name (read-bytes 8 p)])
|
|
(if (bytes=? find-name name)
|
|
(let ([_ (dword->integer p)]) ; skip
|
|
(values (dword->integer p) ; virtual address
|
|
(dword->integer p) ; length
|
|
(dword->integer p))); file pos
|
|
(sloop (add1 section) (+ section-pos 40)))))))))))
|
|
|
|
(define (find-rsrc-start p re:rsrc)
|
|
(let-values ([(rsrc-virtual-addr rsrc-len rsrc-pos)
|
|
(find-section p #".rsrc\0\0\0")])
|
|
(let loop ([dir-pos 0][path ""])
|
|
(file-position p (+ rsrc-pos dir-pos 12))
|
|
(let ([num-named (word->integer p)]
|
|
[num-ided (word->integer p)])
|
|
(let iloop ([i 0])
|
|
(if (= i (+ num-ided num-named))
|
|
#f
|
|
(let ([name-delta (dword->integer p)]
|
|
[data-delta (dword->integer p)]
|
|
[next (file-position p)])
|
|
(or (let ([name (if (flag name-delta)
|
|
(begin
|
|
(file-position p (+ rsrc-pos (value name-delta)))
|
|
(let* ([len (word->integer p)])
|
|
;; len is in unicode chars...
|
|
(let ([unistr (read-bytes (* 2 len) p)])
|
|
;; Assume it fits into ASCII...
|
|
(regexp-replace* "\0"
|
|
(bytes->string/latin-1 unistr)
|
|
""))))
|
|
(value name-delta))])
|
|
;;(printf "Name: ~a~a = ~a~n" path name (+ rsrc-pos (value data-delta)))
|
|
(let ([full-name (format "~a~a" path name)])
|
|
(if (flag data-delta)
|
|
(loop (value data-delta) (string-append full-name "."))
|
|
;; Found the icon?
|
|
(and (regexp-match re:rsrc full-name)
|
|
;; Yes, so read IMAGE_RESOURCE_DATA_ENTRY
|
|
(begin
|
|
(file-position p (+ rsrc-pos (value data-delta)))
|
|
(cons
|
|
(+ (dword->integer p) ; offset (an RVA)
|
|
(- rsrc-pos
|
|
rsrc-virtual-addr))
|
|
(dword->integer p))))))) ; size
|
|
(begin
|
|
(file-position p next)
|
|
(iloop (add1 i)))))))))))
|
|
|
|
;; >>> Probably doesn't work <<<
|
|
(define (find-import-names p)
|
|
(let-values ([(seg-virtual-addr seg-len seg-pos)
|
|
(find-section p #".idata\0\0")])
|
|
(let loop ([pos seg-pos])
|
|
;; pos points to an IMAGE_IMPORT_DESCRIPTOR;
|
|
;; skip first 4 fields
|
|
(file-position p pos)
|
|
(if (zero? (dword->integer p)) ; 0 is terminator
|
|
null
|
|
(begin
|
|
(dword->integer p)
|
|
(dword->integer p)
|
|
;; next field is name
|
|
(let ([name-pos (+ (dword->integer p) ; RVA to nul-terminated name
|
|
(- seg-pos seg-virtual-addr))])
|
|
(file-position p name-pos)
|
|
(let ([name (regexp-match "^[^\0]*" p)])
|
|
(cons (cons (car name) name-pos)
|
|
(loop (+ pos 20))))))))))
|
|
|
|
;; >>> Doesn't work <<<
|
|
(define (find-delay-loads p)
|
|
(let-values ([(seg-virtual-addr seg-len seg-pos)
|
|
(find-section p #".text\0\0")])
|
|
(let ([pos (skip-to-image-headers-after-signature p)]
|
|
[image-base (get-image-base p)])
|
|
(let ([pos (+ pos
|
|
4 ; Signature : DWORD
|
|
20 ; FileHeader: IMAGE_FILE_HEADER
|
|
96 ; IMAGE_OPTIONAL_HEADER up to directory
|
|
104)] ; skip 13 directory entries
|
|
[vdelta image-base])
|
|
(file-position p pos)
|
|
(let loop ([delay-pos (dword->integer p)])
|
|
(printf "~a ~a~n" delay-pos vdelta)
|
|
(file-position p (+ delay-pos vdelta))
|
|
(dword->integer p) ; skip attributes
|
|
(let ([name-pos (dword->integer p)])
|
|
(printf "~a ~a~n" name-pos vdelta)
|
|
(file-position p (+ name-pos vdelta))
|
|
(let ([name (regexp-match "^[^\0]*" p)])
|
|
(printf "~a~n" name))))))))
|
|
|
|
(define-struct icon (desc data))
|
|
;; desc is (list width height colors 0 planes bitcount)
|
|
;; data is (cons pos string)
|
|
|
|
(define (num-colors l)
|
|
(let ([n (caddr l)])
|
|
(if (zero? n)
|
|
(arithmetic-shift 1 (list-ref l 5))
|
|
n)))
|
|
|
|
(define (install-icon exe-file ico-file . extra-icons)
|
|
(let ([ico-icons (append (if ico-file
|
|
(extract-icons ico-file)
|
|
null)
|
|
extra-icons)]
|
|
[exe-icons (extract-icons exe-file)])
|
|
(let ([p (open-output-file exe-file 'update)])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(for-each (lambda (exe-icon)
|
|
(let ([best-ico-icon
|
|
;; Find exact match?
|
|
(ormap (lambda (ico-icon)
|
|
(let ([le (icon-desc exe-icon)]
|
|
[li (icon-desc ico-icon)])
|
|
(and (= (car li) (car le))
|
|
(= (cadr li) (cadr le))
|
|
(= (num-colors li) (num-colors le))
|
|
(= (bytes-length (cdr (icon-data exe-icon)))
|
|
(bytes-length (cdr (icon-data ico-icon))))
|
|
ico-icon)))
|
|
ico-icons)])
|
|
(let ([ico-icon (or best-ico-icon
|
|
;; Look for a conversion, if we
|
|
;; need a 16x16, 32x32, or 48x48
|
|
;; icon
|
|
(and
|
|
(= (car (icon-desc exe-icon))
|
|
(cadr (icon-desc exe-icon)))
|
|
(memq (car (icon-desc exe-icon))
|
|
'(16 32 48))
|
|
(let ([biggest-colorest #f])
|
|
(for-each
|
|
(lambda (ico-icon)
|
|
(let ([w (car (icon-desc ico-icon))]
|
|
[exew (car (icon-desc exe-icon))])
|
|
(when (and
|
|
(= w
|
|
(cadr (icon-desc ico-icon)))
|
|
(memq w '(16 32 48))
|
|
(or
|
|
(not biggest-colorest)
|
|
(and (= w exew)
|
|
(not (= exew (car (icon-desc biggest-colorest)))))
|
|
(and (= w exew)
|
|
(> (num-colors (icon-desc ico-icon))
|
|
(num-colors (icon-desc biggest-colorest))))
|
|
(and (not (= exew (car (icon-desc biggest-colorest))))
|
|
(or (> w (car (icon-desc biggest-colorest)))
|
|
(> (num-colors (icon-desc ico-icon))
|
|
(num-colors (icon-desc biggest-colorest)))))))
|
|
(set! biggest-colorest ico-icon))))
|
|
ico-icons)
|
|
(and
|
|
biggest-colorest
|
|
;; Convert...
|
|
(let* ([src-size (car (icon-desc biggest-colorest))]
|
|
[dest-size (car (icon-desc exe-icon))]
|
|
[src (parse-icon biggest-colorest)]
|
|
[image (list-ref src 3)]
|
|
[mask (list-ref src 4)]
|
|
[has-alpha? (<= 256 (num-colors (icon-desc biggest-colorest)))])
|
|
(if (= src-size dest-size)
|
|
(build-icon exe-icon
|
|
(if has-alpha?
|
|
image
|
|
(mask->alpha image mask))
|
|
mask)
|
|
(let ([cvt
|
|
(cond
|
|
[(and (= src-size 32) (= dest-size 16))
|
|
(lambda (i) (48->16 (32->48 i)))]
|
|
[(and (= src-size 32) (= dest-size 48))
|
|
32->48]
|
|
[(and (= src-size 48) (= dest-size 16))
|
|
48->16]
|
|
[(and (= src-size 48) (= dest-size 32))
|
|
48->32]
|
|
[(and (= src-size 16) (= dest-size 32))
|
|
16->32]
|
|
[(and (= src-size 16) (= dest-size 48))
|
|
(lambda (i) (32->48 (16->32 i)))])])
|
|
(let ([mask (cvt mask)])
|
|
(build-icon exe-icon
|
|
(if has-alpha?
|
|
image
|
|
(mask->alpha (cvt image) mask))
|
|
mask)))))))))])
|
|
(unless ico-icon (printf "no! ~a~n" (icon-desc exe-icon)))
|
|
(when ico-icon
|
|
(file-position p (car (icon-data exe-icon)))
|
|
(display (cdr (icon-data ico-icon)) p)))))
|
|
exe-icons))
|
|
(lambda () (close-output-port p))))))
|
|
|
|
;; ------------------------------
|
|
;; Image parsing
|
|
;; ------------------------------
|
|
|
|
(define (get-icons file res?)
|
|
(let ([p (if (input-port? file)
|
|
file
|
|
(open-input-file file))])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(unless (= 0 (word->integer p))
|
|
(error 'get-icons "~a doesn't start with 0" file))
|
|
(unless (= 1 (word->integer p))
|
|
(error "type isn't 1"))
|
|
(let ([cnt (word->integer p)])
|
|
(let ([icons (let loop ([i 0])
|
|
(if (= i cnt)
|
|
null
|
|
(cons
|
|
(make-icon
|
|
(list (byte->integer p) ; w
|
|
(byte->integer p) ; h
|
|
(byte->integer p) ; colors
|
|
(byte->integer p) ; 0
|
|
(word->integer p) ; planes
|
|
(word->integer p)) ; bitcount
|
|
(list (dword->integer p) ; bytes
|
|
((if res? ; where or icon id
|
|
word->integer
|
|
dword->integer)
|
|
p)))
|
|
(loop (add1 i)))))])
|
|
;; (printf "~a~n" icons)
|
|
(for-each (lambda (icon)
|
|
(set-icon-data!
|
|
icon
|
|
(let ([size (car (icon-data icon))]
|
|
[where (cadr (icon-data icon))])
|
|
(let ([icon-pos (if res?
|
|
;; last number is icon id:
|
|
(car (find-rsrc-start p (format "^3[.]~a[.]" where)))
|
|
;; last number is file position:
|
|
where)])
|
|
(file-position p icon-pos)
|
|
(cons icon-pos
|
|
(read-bytes size p)))))
|
|
;; If colors, planes, and bitcount are all 0,
|
|
;; get the info from the DIB data
|
|
(let ([desc (icon-desc icon)])
|
|
(when (and (zero? (list-ref desc 2))
|
|
(zero? (list-ref desc 4))
|
|
(zero? (list-ref desc 5)))
|
|
(let ([bi (bitmapinfo icon)])
|
|
(set-car! (list-tail desc 4)
|
|
(list-ref bi 3))
|
|
(set-car! (list-tail desc 5)
|
|
(list-ref bi 4))))))
|
|
icons)
|
|
icons)))
|
|
(lambda ()
|
|
(when (path-string? file)
|
|
(close-input-port p))))))
|
|
|
|
(define (bitmapinfo icon)
|
|
(let ([p (open-input-bytes (cdr (icon-data icon)))])
|
|
(list (dword->integer p) ; size == 40 in practice
|
|
(dword->integer p) ; width
|
|
(dword->integer p) ; height
|
|
(word->integer p) ; planes
|
|
(word->integer p) ; bitcount
|
|
(dword->integer p) ; compression == 0
|
|
(dword->integer p) ; size image
|
|
(dword->integer p) ; x pixels per meter == 0
|
|
(dword->integer p) ; y pixels per meter == 0
|
|
(dword->integer p) ; used == 0
|
|
(dword->integer p)))) ; important == 0
|
|
|
|
;; Assumes that bits-per-pixel is 1, 2, 4, 8, 24, or 32.
|
|
;; Also assumes that (bits-per-pixel * width) is a multiple of 8.
|
|
(define (parse-dib icon)
|
|
(let* ([bi (bitmapinfo icon)]
|
|
[header-size (list-ref bi 0)]
|
|
[num-colors (caddr (icon-desc icon))]
|
|
[w (list-ref bi 1)]
|
|
[h (/ (list-ref bi 2) 2)]
|
|
[bits-per-pixel (list-ref bi 4)])
|
|
(let ([p (open-input-bytes (cdr (icon-data icon)))])
|
|
;; Skip header
|
|
(read-bytes header-size p)
|
|
(let* ([read-n
|
|
(lambda (n read-one combine)
|
|
(let loop ([i n][r null])
|
|
(if (= i 0)
|
|
(reverse! r)
|
|
(loop (sub1 i)
|
|
(combine (read-one p) r)))))]
|
|
[read-lines
|
|
(lambda (w h read-one combine)
|
|
(if (zero? (modulo w 4))
|
|
(read-n (* w h) read-one combine)
|
|
(let loop ([h h])
|
|
(if (zero? h)
|
|
null
|
|
(append (read-n w read-one combine)
|
|
(begin
|
|
;; pad line to dword:
|
|
(read-n (- 4 (modulo w 4)) byte->integer cons)
|
|
;; read next line:
|
|
(loop (sub1 h))))))))]
|
|
[split-bits (lambda (b)
|
|
(list
|
|
(bitwise-and b 1)
|
|
(arithmetic-shift (bitwise-and b 2) -1)
|
|
(arithmetic-shift (bitwise-and b 4) -2)
|
|
(arithmetic-shift (bitwise-and b 8) -3)
|
|
(arithmetic-shift (bitwise-and b 16) -4)
|
|
(arithmetic-shift (bitwise-and b 32) -5)
|
|
(arithmetic-shift (bitwise-and b 64) -6)
|
|
(arithmetic-shift (bitwise-and b 128) -7)))])
|
|
(let ([main-image
|
|
(cond
|
|
[(= bits-per-pixel 32)
|
|
;; RGB mode:
|
|
(read-n (* w h) dword->integer cons)]
|
|
[(= bits-per-pixel 24)
|
|
;; RGB mode:
|
|
(read-n (* w h) 3/2word->integer cons)]
|
|
[else
|
|
;; Index mode:
|
|
(let ([color-table (list->vector
|
|
(read-n (if (zero? num-colors)
|
|
(arithmetic-shift 1 bits-per-pixel)
|
|
num-colors)
|
|
dword->integer cons))]
|
|
[image (read-lines (/ w (/ 8 bits-per-pixel))
|
|
h
|
|
(lambda (p)
|
|
(let ([b (byte->integer p)])
|
|
(case bits-per-pixel
|
|
[(1) (split-bits b)]
|
|
[(2)
|
|
(list
|
|
(bitwise-and b 3)
|
|
(arithmetic-shift (bitwise-and b 12) -2)
|
|
(arithmetic-shift (bitwise-and b 48) -4)
|
|
(arithmetic-shift (bitwise-and b 192) -6))]
|
|
[(4)
|
|
(list
|
|
(bitwise-and b 15)
|
|
(arithmetic-shift (bitwise-and b 240) -4))]
|
|
[(8) (list b)])))
|
|
append)])
|
|
(map (lambda (i) (vector-ref color-table i)) image))])])
|
|
(let ([mask (read-lines (/ w 8)
|
|
h
|
|
(lambda (p) (split-bits (byte->integer p)))
|
|
append)])
|
|
(unless (eof-object? (read-char p))
|
|
(error 'parse-dib "not extactly at end"))
|
|
(list main-image mask)))))))
|
|
|
|
;; rgb->indexed
|
|
;; The color-reduction strategy isn't great, and because it
|
|
;; depends on hash-table order, it's non-deterministic in
|
|
;; principle. But the actual hash-table implementatin is
|
|
;; deterministic, of course. Also, the re-ordering of the
|
|
;; image via the hash tables tends to produce better
|
|
;; (pseudo-random) representatives of the image for colors.
|
|
(define (rgb->indexed image num-colors)
|
|
(let ([image (map (lambda (i) (bitwise-and #xFFFFFF i)) image)] ; drop alphas, if any
|
|
[table (make-vector num-colors 0)]
|
|
[ht (make-hash-table 'equal)]
|
|
[map-ht (make-hash-table 'equal)]
|
|
[color-dist (lambda (a b)
|
|
(sqrt (+ (expt (- (bitwise-and #xFF a)
|
|
(bitwise-and #xFF b))
|
|
2)
|
|
(expt (- (arithmetic-shift (bitwise-and #xFF00 a) -8)
|
|
(arithmetic-shift (bitwise-and #xFF00 b) -8))
|
|
2)
|
|
(expt (- (arithmetic-shift (bitwise-and #xFF0000 a) -16)
|
|
(arithmetic-shift (bitwise-and #xFF0000 b) -16))
|
|
2))))])
|
|
(for-each (lambda (c)
|
|
(hash-table-put!
|
|
ht
|
|
c
|
|
(add1
|
|
(hash-table-get ht c (lambda () 0)))))
|
|
image)
|
|
(let ([kv-sorted
|
|
(quicksort (hash-table-map ht cons)
|
|
(lambda (a b)
|
|
(< (cdr a) (cdr b))))])
|
|
(let ([n 0])
|
|
(for-each (lambda (kv)
|
|
(let ([key (car kv)])
|
|
(let ([n (if (< n (sub1 num-colors))
|
|
n
|
|
;; Find closest match:
|
|
(let ([n 0])
|
|
(let loop ([i 1])
|
|
(unless (= i num-colors)
|
|
(when (< (color-dist key (vector-ref table i))
|
|
(color-dist key (vector-ref table n)))
|
|
(set! n i))
|
|
(loop (add1 i))))
|
|
n))])
|
|
(vector-set! table n key)
|
|
(hash-table-put! map-ht key n))
|
|
(when (< n (sub1 num-colors))
|
|
(set! n (add1 n)))))
|
|
kv-sorted)))
|
|
(values (vector->list table)
|
|
(map (lambda (c) (hash-table-get map-ht c)) image))))
|
|
|
|
;; Assumes that bits-per-pixel is 1, 2, 4, 8, or 32.
|
|
;; Also assumes that (bits-per-pixel * width) is a multiple of 8.
|
|
(define (build-dib icon image mask)
|
|
(let* ([bi (bitmapinfo icon)]
|
|
[header-size (list-ref bi 0)]
|
|
[num-colors (caddr (icon-desc icon))]
|
|
[w (list-ref bi 1)]
|
|
[h (/ (list-ref bi 2) 2)]
|
|
[bits-per-pixel (list-ref bi 4)])
|
|
(let ([orig-p (open-input-bytes (cdr (icon-data icon)))]
|
|
[result-p (open-output-bytes)])
|
|
;; Copy header:
|
|
(display (read-bytes header-size orig-p) result-p)
|
|
(let ([get-lines (lambda (image bits-per-pixel)
|
|
(map (lambda (line)
|
|
;; pad line to dword boundary
|
|
(let ([line-bytes (/ (* w bits-per-pixel) 8)])
|
|
(if (zero? (modulo line-bytes 4))
|
|
line
|
|
(append line
|
|
(vector->list
|
|
(make-vector (* (- 4 (modulo line-bytes 4))
|
|
(/ 8 bits-per-pixel))
|
|
0))))))
|
|
;; break out lines
|
|
(let loop ([l image])
|
|
(if (null? l)
|
|
null
|
|
(cons (let loop ([l l][i 0])
|
|
(if (= i w)
|
|
null
|
|
(cons (car l) (loop (cdr l) (add1 i)))))
|
|
(loop (list-tail l w)))))))]
|
|
[bits->dwords (lambda (l bpp)
|
|
(let ([chunk-size (/ 32 bpp)]
|
|
[1byte (lambda (l)
|
|
(bitwise-ior
|
|
(arithmetic-shift (list-ref l 0) 7)
|
|
(arithmetic-shift (list-ref l 1) 6)
|
|
(arithmetic-shift (list-ref l 2) 5)
|
|
(arithmetic-shift (list-ref l 3) 4)
|
|
(arithmetic-shift (list-ref l 4) 3)
|
|
(arithmetic-shift (list-ref l 5) 2)
|
|
(arithmetic-shift (list-ref l 6) 1)
|
|
(arithmetic-shift (list-ref l 7) 0)))]
|
|
[2byte (lambda (l)
|
|
(bitwise-ior
|
|
(arithmetic-shift (list-ref l 0) 6)
|
|
(arithmetic-shift (list-ref l 1) 4)
|
|
(arithmetic-shift (list-ref l 2) 2)
|
|
(arithmetic-shift (list-ref l 3) 0)))]
|
|
[4byte (lambda (l)
|
|
(bitwise-ior
|
|
(arithmetic-shift (list-ref l 0) 4)
|
|
(arithmetic-shift (list-ref l 1) 0)))])
|
|
(let loop ([l l])
|
|
(if (null? l)
|
|
null
|
|
(cons (case bpp
|
|
[(1) (bitwise-ior
|
|
(arithmetic-shift (1byte (list-tail l 0)) 0)
|
|
(arithmetic-shift (1byte (list-tail l 8)) 8)
|
|
(arithmetic-shift (1byte (list-tail l 16)) 16)
|
|
(arithmetic-shift (1byte (list-tail l 24)) 24))]
|
|
[(2) (bitwise-ior
|
|
(2byte l)
|
|
(arithmetic-shift (2byte (list-tail l 4)) 8)
|
|
(arithmetic-shift (2byte (list-tail l 8)) 16)
|
|
(arithmetic-shift (2byte (list-tail l 12)) 24))]
|
|
[(4) (bitwise-ior
|
|
(4byte l)
|
|
(arithmetic-shift (4byte (list-tail l 2)) 8)
|
|
(arithmetic-shift (4byte (list-tail l 4)) 16)
|
|
(arithmetic-shift (4byte (list-tail l 6)) 24))]
|
|
[(8) (bitwise-ior
|
|
(car l)
|
|
(arithmetic-shift (list-ref l 1) 8)
|
|
(arithmetic-shift (list-ref l 2) 16)
|
|
(arithmetic-shift (list-ref l 3) 24))])
|
|
(loop (list-tail l chunk-size)))))))])
|
|
(if (= bits-per-pixel 32)
|
|
(for-each (lambda (col) (integer->dword col result-p))
|
|
image)
|
|
(let-values ([(colors indexed-image) (rgb->indexed image (arithmetic-shift 1 bits-per-pixel))])
|
|
;; color table
|
|
(for-each (lambda (col) (integer->dword col result-p))
|
|
colors)
|
|
(let* ([lines (get-lines indexed-image bits-per-pixel)]
|
|
[dwords (apply append (map (lambda (l) (bits->dwords l bits-per-pixel))
|
|
lines))])
|
|
(for-each (lambda (col) (integer->dword col result-p))
|
|
dwords))))
|
|
(let* ([lines (get-lines mask 1)]
|
|
[dwords (apply append (map (lambda (l) (bits->dwords l 1)) lines))])
|
|
(for-each (lambda (col) (integer->dword col result-p))
|
|
dwords))
|
|
(let ([s (get-output-bytes result-p)])
|
|
(unless (= (bytes-length s) (bytes-length (cdr (icon-data icon))))
|
|
(error 'build-dib "bad result size ~a != ~a"
|
|
(bytes-length s) (bytes-length (cdr (icon-data icon)))))
|
|
s)))))
|
|
|
|
(define (parse-icon icon)
|
|
(let ([image (parse-dib icon)])
|
|
(list (car (icon-desc icon))
|
|
(cadr (icon-desc icon))
|
|
(let ([cols (caddr (icon-desc icon))])
|
|
(if (zero? cols)
|
|
(expt 2 (list-ref (icon-desc icon) 5))
|
|
cols))
|
|
(car image)
|
|
(cadr image))))
|
|
|
|
(define (build-icon base-icon image mask)
|
|
(make-icon (icon-desc base-icon)
|
|
(cons (car (icon-desc base-icon))
|
|
(build-dib base-icon image mask))))
|
|
|
|
(define (extract-icons file)
|
|
(if (regexp-match #rx"[.]ico$" (if (path? file)
|
|
(path->string file)
|
|
file))
|
|
(get-icons-in-ico file)
|
|
(get-icons-in-exe file)))
|
|
|
|
(define (get-icons-in-ico ico-file)
|
|
(get-icons ico-file #f))
|
|
|
|
(define (get-icons-in-exe exe-file)
|
|
(let ([p (open-input-file exe-file)])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(let ([pos+size (find-rsrc-start p "^14[.]")])
|
|
(file-position p (car pos+size))
|
|
(get-icons p #t)))
|
|
(lambda () (close-input-port p)))))
|
|
|
|
;; The following is useful for bitmap->icon,
|
|
;; but it uses MrEd, and this module is used by
|
|
;; Setup PLT. Probably this code should just be
|
|
;; moved somewhere else.
|
|
#;
|
|
(begin
|
|
(require (lib "mred.ss" "mred")
|
|
(lib "class.ss"))
|
|
(define (bitmap%->icon bm)
|
|
(let* ([w (send bm get-width)]
|
|
[h (send bm get-height)]
|
|
[argb (make-bytes (* w h 4))]
|
|
[mdc (make-object bitmap-dc% bm)])
|
|
(send mdc get-argb-pixels 0 0 w h argb)
|
|
(send mdc set-bitmap #f)
|
|
;; Get mask (inverse alpha), if any:
|
|
(let ([mask-argb (make-bytes (* w h 4) #o377)]
|
|
[mbm (send bm get-loaded-mask)])
|
|
(when mbm
|
|
(send mdc set-bitmap mbm)
|
|
(send mdc get-argb-pixels 0 0 w h mask-argb)
|
|
(send mdc set-bitmap #f))
|
|
(bitmap->icon w h argb mask-argb)))))
|
|
|
|
(define (bitmap->icon w h argb mask-argb)
|
|
(let ([o (open-output-bytes)])
|
|
(integer->dword 40 o) ; size
|
|
(integer->dword w o) ; width
|
|
(integer->dword (* 2 h) o) ; height
|
|
(integer->word 1 o) ; planes
|
|
(integer->word 32 o) ; bitcount
|
|
(integer->dword 0 o) ; compression
|
|
(integer->dword 0 o) ; size image
|
|
(integer->dword 0 o) ; x pixels per meter
|
|
(integer->dword 0 o) ; y pixels per meter
|
|
(integer->dword 0 o) ; used
|
|
(integer->dword 0 o) ; important
|
|
;; Got ARGB, need BGRA
|
|
(let* ([flip-pixels (lambda (s)
|
|
(let ([s (bytes-copy s)])
|
|
(let loop ([p 0])
|
|
(unless (= p (bytes-length s))
|
|
(let ([a (bytes-ref s p)]
|
|
[r (bytes-ref s (+ p 1))]
|
|
[g (bytes-ref s (+ p 2))]
|
|
[b (bytes-ref s (+ p 3))])
|
|
(bytes-set! s p b)
|
|
(bytes-set! s (+ p 1) g)
|
|
(bytes-set! s (+ p 2) r)
|
|
(bytes-set! s (+ p 3) a)
|
|
(loop (+ p 4)))))
|
|
s))]
|
|
[rgba (flip-pixels argb)]
|
|
[mask-rgba (flip-pixels mask-argb)]
|
|
[row-size (if (zero? (modulo w 32))
|
|
w
|
|
(+ w (- 32 (remainder w 32))))]
|
|
[mask (make-bytes (* h row-size 1/8) 0)])
|
|
(let loop ([i (* w h 4)])
|
|
(unless (zero? i)
|
|
(let ([mr (bytes-ref mask-rgba (- i 2))]
|
|
[mg (bytes-ref mask-rgba (- i 3))]
|
|
[mb (bytes-ref mask-rgba (- i 4))]
|
|
[a (- i 1)])
|
|
(let ([alpha (- 255
|
|
(floor (/ (+ mr mg mb)
|
|
3)))])
|
|
(if (< alpha 10)
|
|
;; white mask -> zero alpha; add white pixel to mask
|
|
(begin
|
|
(bytes-set! rgba a 0)
|
|
(let ([pos (+ (* (quotient (sub1 (/ i 4)) w) row-size)
|
|
(remainder (sub1 (/ i 4)) w))])
|
|
(bytes-set! mask
|
|
(quotient pos 8)
|
|
(bitwise-ior
|
|
(arithmetic-shift 1 (- 7 (remainder pos 8)))
|
|
(bytes-ref mask (quotient pos 8))))))
|
|
;; non-white mask -> non-zero alpha
|
|
(bytes-set! rgba a alpha))))
|
|
(loop (- i 4))))
|
|
;; Windows icons are upside-down:
|
|
(let ([flip (lambda (str row-width)
|
|
(apply
|
|
bytes-append
|
|
(reverse
|
|
(let loop ([pos 0])
|
|
(if (= pos (bytes-length str))
|
|
null
|
|
(cons (subbytes str pos (+ pos row-width))
|
|
(loop (+ pos row-width))))))))])
|
|
(display (flip rgba (* w 4)) o)
|
|
(display (flip mask (/ row-size 8)) o))
|
|
(make-icon (list w h 0 0 1 32)
|
|
(cons 0 (get-output-bytes o))))))
|
|
|
|
;; ------------------------------
|
|
;; Image conversion
|
|
;; ------------------------------
|
|
|
|
(define (mask->alpha image mask)
|
|
(map (lambda (i m)
|
|
(if (zero? m)
|
|
(bitwise-ior #xFF000000 i)
|
|
m))
|
|
image mask))
|
|
|
|
(define (first-n n l)
|
|
(let loop ([l l][i n])
|
|
(if (zero? i)
|
|
null
|
|
(cons (car l) (loop (cdr l) (sub1 i))))))
|
|
|
|
(define (16->32 l)
|
|
(let loop ([l l])
|
|
(if (null? l)
|
|
null
|
|
(let ([l2 (let loop ([l (first-n 16 l)])
|
|
(if (null? l)
|
|
null
|
|
(list* (car l) (car l) (loop (cdr l)))))])
|
|
(append l2 l2
|
|
(loop (list-tail l 16)))))))
|
|
|
|
(define (32->48 l)
|
|
(let loop ([l l][dup? #t])
|
|
(if (null? l)
|
|
null
|
|
(let ([l2 (let loop ([l (first-n 32 l)])
|
|
(if (null? l)
|
|
null
|
|
(list* (car l) (car l) (cadr l)
|
|
(loop (cddr l)))))])
|
|
(append l2
|
|
(if dup? l2 null)
|
|
(loop (list-tail l 32) (not dup?)))))))
|
|
|
|
(define (48->16 l)
|
|
(let loop ([l l])
|
|
(if (null? l)
|
|
null
|
|
(let ([l2 (let loop ([l (first-n 48 l)])
|
|
(if (null? l)
|
|
null
|
|
(cons (car l) (loop (cdddr l)))))])
|
|
(append l2
|
|
(loop (list-tail l 144)))))))
|
|
|
|
(define (48->32 l)
|
|
(let loop ([l l][step 0])
|
|
(if (null? l)
|
|
null
|
|
(let ([l2 (let loop ([l (first-n 48 l)][step 0])
|
|
(if (null? l)
|
|
null
|
|
(if (= 1 (modulo step 3))
|
|
(loop (cdr l) 2)
|
|
(cons (car l) (loop (cdr l) (add1 step))))))])
|
|
(append (if (= 1 (modulo step 3)) null l2)
|
|
(loop (list-tail l 48) (add1 step))))))))
|
|
|
|
#|
|
|
|
|
;; ----------------------------------------
|
|
;; Test code
|
|
|
|
(define icons (extract-icons "e:/matthew/plt/mred.exe"))
|
|
|
|
(define (show-icon w h col-count image mask)
|
|
(let* ([f (make-object frame% (format "~a x ~a (~a) Image" w h col-count))]
|
|
[bm (make-object bitmap% w h)]
|
|
[mbm (make-object bitmap% w h)]
|
|
[c (instantiate canvas% (f)
|
|
[paint-callback (lambda (c dc)
|
|
(send dc draw-bitmap bm 0 0)
|
|
(send dc draw-bitmap mbm w 0))])])
|
|
(let ([mdc (make-object bitmap-dc% bm)]
|
|
[col (make-object color%)])
|
|
(let loop ([l image][i 0][j 0])
|
|
(unless (= j h)
|
|
(let ([v (car l)])
|
|
(send col set
|
|
(bitwise-and v #xFF)
|
|
(arithmetic-shift (bitwise-and v #xFF00) -8)
|
|
(arithmetic-shift (bitwise-and v #xFF0000) -16))
|
|
(send mdc set-pixel i j col)
|
|
(if (= (add1 i) w)
|
|
(loop (cdr l) 0 (add1 j))
|
|
(loop (cdr l) (add1 i) j)))))
|
|
(send mdc set-bitmap mbm)
|
|
(let loop ([l (if (col-count . > . 256) image mask)][i 0][j 0])
|
|
(unless (= j h)
|
|
(let ([v (if (col-count . > . 256)
|
|
(- 255 (arithmetic-shift (bitwise-and (car l) #xFF000000) -24))
|
|
(if (zero? (car l))
|
|
0
|
|
255))])
|
|
(send col set v v v)
|
|
(send mdc set-pixel i j col)
|
|
(if (= (add1 i) w)
|
|
(loop (cdr l) 0 (add1 j))
|
|
(loop (cdr l) (add1 i) j)))))
|
|
|
|
(send mdc set-bitmap #f))
|
|
(send c min-client-width (* 2 w))
|
|
(send c min-client-height h)
|
|
(send c stretchable-width #f)
|
|
(send c stretchable-height #f)
|
|
|
|
(send f show #t)))
|
|
|
|
(define (find-icon icons w h colors)
|
|
(ormap (lambda (i)
|
|
(let ([p (parse-icon i)])
|
|
(and (= w (car p))
|
|
(= h (cadr p))
|
|
(= colors (caddr p))
|
|
i)))
|
|
icons))
|
|
|
|
(let ([orig (find-icon icons 48 48 (expt 2 32))]
|
|
[target (find-icon icons 32 32 256)])
|
|
(apply show-icon (parse-icon orig))
|
|
(apply show-icon (parse-icon target))
|
|
(apply show-icon
|
|
(parse-icon
|
|
(let* ([p (parse-icon orig)]
|
|
[mask (48->32(list-ref p 4))]
|
|
[image (mask->alpha (48->32 (list-ref p 3)) mask)])
|
|
(build-icon target image mask)))))
|
|
|
|
;; ----------------------------------------
|
|
;; End test code
|
|
|
|
|#
|