1#lang racket/base
2(require ffi/unsafe
3         ffi/unsafe/define
4         ffi/unsafe/alloc
5         "../private/utils.rkt"
6         "../private/libs.rkt"
7         "callback.rkt")
8
9(define-runtime-lib png-lib
10  [(unix)
11   ;; Most Linux distros supply "libpng12", while other Unix
12   ;; variants often have just "libpng", etc.
13   (let loop ([alts '(("libpng16" ("16" ""))
14                      ("libpng15" ("15" ""))
15                      ("libpng12" ("0" "")))])
16     (cond
17      [(null? alts) (ffi-lib "libpng")]
18      [else (apply ffi-lib (car alts)
19                   #:fail (lambda ()
20                            (loop (cdr alts))))]))]
21  [(macosx) (ffi-lib "libpng16.16.dylib")]
22  [(windows)
23   (ffi-lib "zlib1.dll")
24   (ffi-lib "libpng16-16.dll")])
25
26(define-ffi-definer define-png png-lib
27  #:provide provide)
28
29(define-png png_access_version_number (_fun -> _uint32))
30
31;; We support version 1.2 and 1.4... and (WARNING!) we'll optimisitically
32;;  assume that other versions are also ok
33(define PNG_LIBPNG_VER_STRING (string->bytes/latin-1
34                               (let ([v (png_access_version_number)])
35                                 (format "~s.~s~a"
36                                         (quotient v 10000)
37                                         (quotient (remainder v 10000) 100)
38                                         (if (zero? (remainder v 100))
39                                             ""
40                                             (format ".~a" (remainder v 100)))))))
41
42(define _png_structp (_cpointer 'png_structp))
43(define _png_infop (_cpointer 'png_infop))
44(define _png_end_infop (_cpointer 'png_end_infop))
45(define _png_size_t _long)
46
47(define-cstruct _png_color_16 ([index _byte]
48                               [red _uint16]
49                               [green _uint16]
50                               [blue _uint16]
51                               [gray _uint16]))
52
53(define-png png_create_read_struct
54  (_fun _bytes
55        _pointer
56        (_fun #:keep (lambda (v) ((current-fun-keep) v))
57              #:atomic? callback-atomic?
58              _png_structp _string -> _void)
59        (_fun #:keep (lambda (v) ((current-fun-keep) v))
60              #:atomic? callback-atomic?
61              _png_structp _string -> _void)
62        -> _png_structp))
63
64(define png_destroy_read_struct1
65  (get-ffi-obj 'png_destroy_read_struct
66               png-lib
67               (_fun (_ptr i _png_structp)
68                     (_pointer = #f)
69                     (_pointer = #f)
70                     -> _void)))
71(define png_destroy_read_struct2
72  (get-ffi-obj 'png_destroy_read_struct
73               png-lib
74               (_fun (_ptr i _png_structp)
75                     (_ptr i _png_infop)
76                     (_pointer = #f)
77                     -> _void)))
78
79(define-png png_create_write_struct
80  (_fun _bytes
81        _pointer
82        (_fun #:keep (lambda (v) ((current-fun-keep) v))
83              #:atomic? callback-atomic?
84              _png_structp _string -> _void)
85        (_fun #:keep (lambda (v) ((current-fun-keep) v))
86              #:atomic? callback-atomic?
87              _png_structp _string -> _void)
88        -> _png_structp))
89(define png_destroy_write_struct1
90  (get-ffi-obj 'png_destroy_write_struct
91               png-lib
92               (_fun (_ptr i _png_structp)
93                     (_pointer = #f)
94                     -> _void)))
95(define png_destroy_write_struct2
96  (get-ffi-obj 'png_destroy_write_struct
97               png-lib
98               (_fun (_ptr i _png_structp)
99                     (_ptr i _png_infop)
100                     -> _void)))
101
102(define-png png_create_info_struct (_fun _png_structp -> _png_infop))
103(define-png png_read_info (_fun #:callback-exns? callback-atomic? _png_structp _png_infop -> _void))
104(define-png png_read_end (_fun #:callback-exns? callback-atomic? _png_structp _png_infop -> _void))
105(define-png png_write_info (_fun _png_structp _png_infop -> _void))
106
107(define-png png_read_update_info (_fun _png_structp _png_infop -> _void))
108
109(define-png png_get_IHDR (_fun _png_structp
110                               _png_infop
111                               (w : (_ptr o _uint32))
112                               (h : (_ptr o _uint32))
113                               (depth : (_ptr o _int))
114                               (color-type : (_ptr o _int))
115                               (interlace-type : (_ptr o _int))
116                               (compression-type : (_ptr o _int))
117                               (filter-type : (_ptr o _int))
118                               -> _void
119                               -> (values w h depth
120                                          color-type
121                                          interlace-type
122                                          compression-type
123                                          filter-type)))
124
125(define-png png_set_IHDR (_fun _png_structp
126                               _png_infop
127                               _uint32
128                               _uint32
129                               _int
130                               _int _int _int _int
131                               -> _void))
132
133(define current-fun-keep (make-parameter #f))
134
135(define-png png_set_read_fn (_fun _png_structp
136                                  _pointer
137                                  (_fun #:keep (lambda (v) ((current-fun-keep) v))
138                                        #:atomic? callback-atomic?
139                                        _png_structp
140                                        _pointer
141                                        _png_size_t
142                                        -> _void)
143                                  -> _void))
144(define-png png_set_write_fn (_fun _png_structp
145                                   _pointer
146                                   (_fun #:keep (lambda (v) ((current-fun-keep) v))
147                                         #:atomic? callback-atomic?
148                                         _png_structp
149                                         _pointer
150                                         _png_size_t
151                                         -> _void)
152                                   (_fun #:keep (lambda (v) ((current-fun-keep) v))
153                                         #:atomic? callback-atomic?
154                                         _png_structp
155                                         -> _void)
156                                   -> _void))
157(define-png png_get_io_ptr (_fun _png_structp -> _pointer))
158
159(define-png png_get_rowbytes (_fun #:callback-exns? callback-atomic? _png_structp _png_infop -> _uint32))
160(define-png png_read_rows (_fun #:callback-exns? callback-atomic? _png_structp _pointer #;(_vector i _bytes) _pointer _uint32 -> _void))
161(define-png png_write_image (_fun #:callback-exns? callback-atomic? _png_structp _pointer #;(_vector i _bytes) -> _void))
162
163(define-png png_write_end (_fun #:callback-exns? callback-atomic? _png_structp _png_infop -> _void))
164
165(define-png png_get_valid (_fun _png_structp _png_infop _uint32 -> _uint32))
166(define-png png_get_bKGD (_fun _png_structp _png_infop (p : (_ptr o _png_color_16-pointer/null)) -> (r : _bool) -> (and r p)))
167(define-png png_set_background (_fun _png_structp _png_color_16-pointer _int _int _double* -> _bool))
168(define-png png_get_gAMA (_fun _png_structp _png_infop (g : (_ptr o _double))
169                               -> (ok? : _bool)
170                               -> (and ok? g)))
171(define-png png_set_gamma (_fun _png_structp _double* _double* -> _void))
172(define-png png_set_filler (_fun _png_structp _uint32 _int -> _void))
173
174(define-png png_set_invert_alpha (_fun _png_structp -> _void))
175(define-png png_set_palette_to_rgb (_fun _png_structp -> _void))
176(define-png png_set_gray_to_rgb (_fun _png_structp -> _void))
177(define-png png_set_tRNS_to_alpha (_fun _png_structp -> _void))
178(define-png png_set_strip_16 (_fun _png_structp -> _void))
179(define-png png_set_strip_alpha (_fun _png_structp -> _void))
180(define-png png_set_gray_1_2_4_to_8 (_fun _png_structp -> _void)
181  #:fail (lambda () #f))
182(define-png png_set_expand_gray_1_2_4_to_8 (_fun _png_structp -> _void)
183  #:fail (lambda () #f))
184(define-png png_set_interlace_handling (_fun _png_structp -> _int))
185
186(define/provide PNG_COLOR_MASK_PALETTE    1)
187(define/provide PNG_COLOR_MASK_COLOR      2)
188(define/provide PNG_COLOR_MASK_ALPHA      4)
189
190(define/provide PNG_COLOR_TYPE_GRAY 0)
191(define/provide PNG_COLOR_TYPE_PALETTE  (bitwise-ior PNG_COLOR_MASK_COLOR PNG_COLOR_MASK_PALETTE))
192(define/provide PNG_COLOR_TYPE_RGB      PNG_COLOR_MASK_COLOR)
193(define/provide PNG_COLOR_TYPE_RGB_ALPHA  (bitwise-ior PNG_COLOR_MASK_COLOR PNG_COLOR_MASK_ALPHA))
194(define/provide PNG_COLOR_TYPE_GRAY_ALPHA PNG_COLOR_MASK_ALPHA)
195
196(define/provide PNG_INTERLACE_NONE        0)
197(define/provide PNG_INTERLACE_ADAM7       1)
198
199(define/provide PNG_FILTER_TYPE_BASE      0)
200(define/provide PNG_INTRAPIXEL_DIFFERENCING 64)
201(define/provide PNG_FILTER_TYPE_DEFAULT   PNG_FILTER_TYPE_BASE)
202
203(define/provide PNG_COMPRESSION_TYPE_BASE 0)
204(define/provide PNG_COMPRESSION_TYPE_DEFAULT PNG_COMPRESSION_TYPE_BASE)
205
206(define/provide PNG_BACKGROUND_GAMMA_UNKNOWN 0)
207(define/provide PNG_BACKGROUND_GAMMA_SCREEN  1)
208(define/provide PNG_BACKGROUND_GAMMA_FILE    2)
209(define/provide PNG_BACKGROUND_GAMMA_UNIQUE  3)
210
211(define/provide PNG_INFO_tRNS #x0010)
212
213(define PNG_FILLER_BEFORE 0)
214(define PNG_FILLER_AFTER  1)
215
216;; ----------------------------------------
217;; Reading
218
219(provide create-png-reader
220         read-png
221         destroy-png-reader)
222
223(define-struct reader ([png #:mutable] info ib num-passes w h))
224
225(define (error-esc v s)
226  (error 'png "~a" s))
227
228(define (read-png-bytes png p len)
229  (define bstr (make-bytes len))
230  (define n (read-bytes! bstr (car (ptr-ref (png_get_io_ptr png) _scheme))))
231  (cond
232    [(eof-object? n) 0]
233    [else
234     (memcpy p bstr n)
235     n]))
236
237(define free-cell ((deallocator) free-immobile-cell))
238(define make-cell ((allocator free-cell) malloc-immobile-cell))
239
240(define (create-png-reader in keep-alpha? bg-rgb)
241  (let* ([funs (box null)]
242         [fun-keep (lambda (v)
243                     (set-box! funs (cons v (unbox funs))))]
244         [png (parameterize ([current-fun-keep fun-keep])
245                (png_create_read_struct PNG_LIBPNG_VER_STRING #f error-esc void))]
246         [info (png_create_info_struct png)]
247         [ib (make-cell (cons (sanitize-input-port in) funs))])
248    (parameterize ([current-fun-keep fun-keep])
249      (png_set_read_fn png ib read-png-bytes))
250    (png_read_info png info)
251    (let-values ([(w h depth color-type
252                     interlace-type compression-type filter-type)
253                  (png_get_IHDR png info)])
254      (let* ([tRNS? (positive? (png_get_valid png info PNG_INFO_tRNS))]
255             [b&w? (and (= depth 1)
256                        (= color-type PNG_COLOR_TYPE_GRAY)
257                        (not tRNS?))]
258             [alpha? (and keep-alpha?
259                          (not b&w?)
260                          (or tRNS?
261                              (positive? (bitwise-ior color-type PNG_COLOR_MASK_ALPHA))))])
262        (unless b&w?
263          ;; Normalize formal of returned rows:
264          (when (= color-type PNG_COLOR_TYPE_PALETTE)
265            (png_set_palette_to_rgb png))
266          (when (or (= color-type PNG_COLOR_TYPE_GRAY)
267                    (= color-type PNG_COLOR_TYPE_GRAY_ALPHA))
268            (png_set_gray_to_rgb png))
269          (when tRNS?
270            (png_set_tRNS_to_alpha png))
271          (when (= depth 16)
272            (png_set_strip_16 png))
273          ;; Expand grayscale images to the full 8 bits from 1, 2, or 4 bits/pixel
274          ((or png_set_gray_1_2_4_to_8 png_set_expand_gray_1_2_4_to_8) png))
275        (unless (or alpha? b&w?)
276          ;; Set the background color to draw transparent and alpha images over.
277          (let* ([deep (lambda (n)
278                         (if (= depth 16)
279                             (+ n (arithmetic-shift n 8))
280                             n))]
281                 [bg (make-png_color_16 0 (deep 255) (deep 255) (deep 255) (deep 255))])
282            (cond
283             [bg-rgb (set-png_color_16-red! bg (deep (car bg-rgb)))
284                     (set-png_color_16-green! bg (deep (cadr bg-rgb)))
285                     (set-png_color_16-blue! bg (deep (caddr bg-rgb)))
286                     (set-png_color_16-gray! bg (deep (floor (/ (apply + bg-rgb) 3))))]
287             [else (let ([c (png_get_bKGD png info)])
288                     (when c
289                       (memcpy bg c (ctype-sizeof _png_color_16))))])
290            (png_set_background png bg
291                                (if bg-rgb
292                                    PNG_BACKGROUND_GAMMA_SCREEN
293                                    PNG_BACKGROUND_GAMMA_FILE)
294                                0 1.0)))
295        (let ([gamma (png_get_gAMA png info)])
296          (when gamma
297            (let* ([s (getenv "SCREEN_GAMMA")]
298                   [screen-gamma (and s (string->number s))])
299              (png_set_gamma png (if (and (real? screen-gamma)
300                                          (<= 0.0 screen-gamma 10.0))
301                                     screen-gamma
302                                     2.2)
303                             gamma))))
304        (cond
305         [alpha?
306          ;; Make sure there's an alpha or filler byte (before each RGB triplet):
307          (png_set_filler png 255 PNG_FILLER_AFTER)]
308         [tRNS?
309          ;; Make sure there's no alpha channel:
310          (png_set_strip_alpha png)])
311        (let ([num-passes (png_set_interlace_handling png)])
312          (png_read_update_info png info)
313          (values (make-reader png info ib num-passes w h)
314                  w h
315                  b&w?
316                  alpha?))))))
317
318(define (malloc-rows h row-bytes)
319  (let* ([align (lambda (v) (if (positive? (remainder v 8))
320                                (+ v (- 8 (remainder v 8)))
321                                v))]
322         [table-size (align (* h (ctype-sizeof _pointer)))]
323         [row-size (align row-bytes)]
324         [memory (malloc (+ table-size (* row-size h))
325                         'atomic-interior)]
326         [rows memory])
327    (for ([i (in-range h)])
328      (ptr-set! rows _pointer i (ptr-add memory (+ table-size (* i row-size)))))
329    rows))
330
331(define (read-png reader)
332  (let* ([row-bytes (png_get_rowbytes (reader-png reader) (reader-info reader))]
333         [rows (malloc-rows (reader-h reader) row-bytes)])
334    (for ([i (in-range (reader-num-passes reader))])
335      (png_read_rows (reader-png reader) rows #f (reader-h reader)))
336    (png_read_end (reader-png reader) (reader-info reader))
337    (list->vector
338     (for/list ([i (in-range (reader-h reader))])
339       (define p (ptr-ref rows _pointer i))
340       (define bstr (make-bytes row-bytes))
341       (memcpy bstr p row-bytes)
342       (void/reference-sink rows) ; keep alive until memcpy is done
343       bstr))))
344
345(define (destroy-png-reader reader)
346  (when (reader-png reader)
347    (png_destroy_read_struct2 (reader-png reader)
348                              (reader-info reader))
349    (free-cell (reader-ib reader))
350    (set-reader-png! reader #f)))
351
352;; ----------------------------------------
353;; Writing
354
355(provide create-png-writer
356         write-png
357         destroy-png-writer)
358
359(define-struct writer (png info ob))
360
361(define (write-png-bytes png p len)
362  (define bstr (make-bytes len))
363  (memcpy bstr p len)
364  (write-bytes bstr (car (ptr-ref (png_get_io_ptr png) _scheme))))
365
366(define (flush-png-bytes png)
367  (flush-output (car (ptr-ref (png_get_io_ptr png) _scheme))))
368
369(define (create-png-writer out w h b&w? alpha?)
370  (let* ([funs (box null)]
371         [fun-keep (lambda (v)
372                     (set-box! funs (cons v (unbox funs))))]
373         [png (parameterize ([current-fun-keep fun-keep])
374                (png_create_write_struct PNG_LIBPNG_VER_STRING #f error-esc void))]
375         [info (png_create_info_struct png)]
376         [ob (make-cell (cons (sanitize-output-port out #:key info) funs))])
377    (parameterize ([current-fun-keep fun-keep])
378      (png_set_write_fn png ob write-png-bytes flush-png-bytes))
379    (png_set_IHDR png info w h (if b&w? 1 8)
380                  (cond
381                   [b&w? PNG_COLOR_TYPE_GRAY]
382                   [alpha? PNG_COLOR_TYPE_RGB_ALPHA]
383                   [else PNG_COLOR_TYPE_RGB])
384                  PNG_INTERLACE_NONE PNG_COMPRESSION_TYPE_DEFAULT
385                  PNG_FILTER_TYPE_DEFAULT)
386    (png_write_info png info)
387    (make-writer png info ob)))
388
389(define (write-png writer vector-of-rows)
390  (if (zero? (vector-length vector-of-rows))
391      (png_write_image (writer-png writer) #f)
392      (let* ([h (vector-length vector-of-rows)]
393             [w (bytes-length (vector-ref vector-of-rows 0))]
394             [rows (malloc-rows h w)])
395        (for/list ([i (in-range h)])
396          (memcpy (ptr-ref rows _pointer i)
397                  (vector-ref vector-of-rows i)
398                  w))
399        (png_write_image (writer-png writer) rows)))
400  (png_write_end (writer-png writer) (writer-info writer))
401  (flush-sanitized-output (writer-info writer)))
402
403(define (destroy-png-writer writer)
404  (png_destroy_write_struct2 (writer-png writer)
405                             (writer-info writer))
406  (free-cell (writer-ob writer)))
407