From 49d0b36dacf2524cdf11c61708d617fb3ad0676c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 3 Dec 2018 20:46:45 -0800 Subject: [PATCH] gbye --- pitfall/pitfall/png-reader.rkt | 69 +--------------------------------- pitfall/pitfall/png.rkt | 46 +++++++++++++---------- 2 files changed, 28 insertions(+), 87 deletions(-) diff --git a/pitfall/pitfall/png-reader.rkt b/pitfall/pitfall/png-reader.rkt index d44172fb..8a57b6d2 100644 --- a/pitfall/pitfall/png-reader.rkt +++ b/pitfall/pitfall/png-reader.rkt @@ -2,7 +2,7 @@ (require "racket.rkt") (require "zlib.rkt") -(provide read-png decodePixels) +(provide read-png) #| Grab key chunks from PNG. Doesn't require heavy lifting from libpng. @@ -77,73 +77,6 @@ Grab key chunks from PNG. Doesn't require heavy lifting from libpng. (read-bytes 4) ; skip crc (loop)])))) -(define/contract (decodePixels imgData pixelBitLength width height) - (bytes? number? number? number? . -> . bytes?) - (define pixelBytes (/ pixelBitLength 8)) - (define scanlineLength (* pixelBytes width)) - (define pixels (make-bytes (* scanlineLength height))) - - (define (left-byte idx c) (if (< idx pixelBytes) - 0 - (bytes-ref pixels (- c pixelBytes)))) - - (define (upper-byte row col idx) - (if (zero? row) 0 (bytes-ref pixels (+ (* (sub1 row) scanlineLength) - (* col pixelBytes) - (modulo idx pixelBytes))))) - - (define (get-col i) ((i . - . (modulo i pixelBytes)) . / . pixelBytes)) - - (define (fold/scanline c-in proc) - (for/fold ([c c-in]) - ([idx (in-range scanlineLength)] - [byte (in-port read-byte)]) - (bytes-set! pixels c (proc c idx byte)) - (add1 c))) - - (parameterize ([current-input-port (open-input-bytes (inflate imgData))]) - (for/fold ([c 0]) - ([row (in-naturals)] - #:break (eof-object? (peek-byte))) - (case (read-byte) - ;; none - [(0) (fold/scanline c (λ (c idx byte) byte))] - ;; sub - [(1) (fold/scanline c (λ (c idx byte) (modulo (+ byte (left-byte idx c)) 256)))] - ;; up - [(2) (fold/scanline c (λ (c idx byte) (modulo (+ (upper-byte row (get-col idx) idx) byte) 256)))] - ;; ; average - [(3) (fold/scanline c (λ (c idx byte) (modulo (+ byte (floor (/ (+ (left-byte idx c) (upper-byte row (get-col idx) idx)) 2))) 256)))] - [(4) ; paeth - (fold/scanline c (λ (c idx byte) - (define col (get-col idx)) - (match-define (list upper upperLeft) - (cond - [(zero? row) (list 0 0)] - [else (define upper (upper-byte row col idx)) - (define upperLeft (if (zero? col) - col - (bytes-ref pixels - (+ (* (sub1 row) scanlineLength) - (* (sub1 col) pixelBytes) - (modulo idx pixelBytes))))) - (list upper upperLeft)])) - - (define left (left-byte idx c)) - - (match-define (list pa pb pc) - (for/list ([x (in-list (list left upper upperLeft))]) - (define p (+ left upper (- upperLeft))) - (abs (- p x)))) - - (define paeth (cond - [(and (<= pa pb) (<= pa pc)) left] - [(<= pb pc) upper] - [else upperLeft])) - - (modulo (+ byte paeth) 256)))] - [else (error 'invalid-png-filter-algorithm )]))) - pixels) (define (read-32bit-integer) diff --git a/pitfall/pitfall/png.rkt b/pitfall/pitfall/png.rkt index a76f7245..1a5468d9 100644 --- a/pitfall/pitfall/png.rkt +++ b/pitfall/pitfall/png.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang debug racket/base (require "racket.rkt") (require "png-reader.rkt" "zlib.rkt") @@ -86,29 +86,37 @@ ;; embed the actual image data (send (· this obj) end (· this imgData))) -(require sugar/debug) +(require sugar/debug racket/draw) ;; todo: this function is too slow. ;; switch to draw/unsafe/png (define/contract (splitAlphaChannel this) (->m void?) - #;(report 'pixels) + (define pixels - (decodePixels (· this imgData) (· this pixelBitlength) (· this width) (· this height))) - #;(report '(imgBytes alphaBytes)) + (let () + (define ip (· this data)) + (port-position ip 0) + (define bmap (read-bitmap ip 'png/alpha)) + (define bs (make-bytes (* 4 (· this width) (· this height)))) + (send bmap get-argb-pixels 0 0 (· this width) (· this height) bs) + bs + #;(decodePixels (· this imgData) (· this pixelBitlength) (· this width) (· this height)))) + + #;(report 'unpacking-argb) (define-values (imgBytes alphaBytes) - (for/fold ([img-bytes empty] - [alpha-bytes empty]) - ([b (in-bytes pixels)] - [which (in-cycle '(img img img alpha))]) - (if (eq? which 'alpha) - (values img-bytes (cons b alpha-bytes)) - (values (cons b img-bytes) alpha-bytes)))) + (time (for/fold ([img-bytes empty] + [alpha-bytes empty]) + ([pixel (in-port (λ (p) (read-bytes 4 p)) (open-input-bytes pixels))]) + (values (cons (subbytes pixel 1 4) img-bytes) + (cons (subbytes pixel 0 1) alpha-bytes))))) - #;(report 'deflate-imgBytes) - (set-field! imgData this (deflate (apply bytes (reverse imgBytes)))) - #;(report 'deflate-alphaBytes) - (set-field! alphaChannel this (deflate (apply bytes (reverse alphaBytes))))) + (report 'deflate-imgBytes) + (set-field! imgData this (time (deflate (apply bytes-append (reverse imgBytes))))) + (report 'deflate-alphaBytes) + (set-field! alphaChannel this (time (deflate (apply bytes-append (reverse alphaBytes)))))) -#;(module+ test - (define pic (make-object PNG (file->bytes "test/assets/test.png"))) - (splitAlphaChannel pic)) \ No newline at end of file +;; test files +;; http://www.libpng.org/pub/png/png-sitemap.html#images +(module+ test + (define pic (make-object PNG (open-input-file "../ptest/assets/test.png"))) + (splitAlphaChannel pic)) \ No newline at end of file