File: png.lisp

package info (click to toggle)
cl-pdf 166-1
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 1,520 kB
  • ctags: 639
  • sloc: lisp: 6,902; makefile: 39
file content (159 lines) | stat: -rw-r--r-- 7,540 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html

(in-package #:pdf)

;;; PNG Images code proposal by Dmitri Ivanov
;;; Notes:
;;;  The /ProcSet entry of page resource dictionary should be expanded to
;;;	[/PDF /Text /ImageB /ImageC /ImageI]
;;;  for compatibility with existing viewer applications.
;;;  It is considered obsolete in PDF 1.4 (section 9.1)
;;; 
;;;  Acrobat error "There was an error processing a page. A drawing error occurred"
;;;  Reason: Acrobat 5 has a bug and is unable to display transparent monochrome images.
;;;  Workaround: Remove transparency or save your image in 16 colors (4 bits per pixel)
;;;  or more. 


(declaim (ftype (function (stream) (unsigned-byte 16)) read-byte16)
         (inline read-byte16))

(defun read-byte16 (stream)
 ;;; Read a 2-byte integer
  (the (unsigned-byte 16) (+ (ash (read-byte stream) 8) (read-byte stream))))

(declaim (ftype (function (stream) (unsigned-byte 32)) read-byte32))
(defun read-byte32 (stream)
 ;;; Read a 4-byte integer
  (the (unsigned-byte 32)
        (+ (ash (read-byte stream) 24) (ash (read-byte stream) 16)
           (ash (read-byte stream) 8) (read-byte stream))))

(defun read-base-string (stream byte-count)
  (let ((result (make-string byte-count :element-type 'base-char)))
    (dotimes (i byte-count result)
      (declare (fixnum i))
      (setf (schar result i) (code-char (read-byte stream))))))

(defclass png-image (bitmap-image)
 ((bits-per-color :accessor bits-per-color :initarg :bits-per-color)
  ;(color-space :accessor color-space :initarg :color-space)
  (palette :accessor palette :initarg :palette)
  (mask :accessor mask :initarg :mask)))

(defun read-png-file (pathname)
  (with-open-file (stream pathname :direction :input :element-type '(unsigned-byte 8))
   (flet ((skip-octets (octet-length)
            (dotimes (i octet-length) (read-byte stream))
            (values)))
    (declare (ftype (function (fixnum) (values)) skip-octets))
    ;; Check signature
    (unless (and (= (read-byte stream) 137)
                 (= (read-byte stream) #.(char-code #\P))
                 (= (read-byte stream) #.(char-code #\N))
                 (= (read-byte stream) #.(char-code #\G))
                 (= (read-byte stream) 13)
                 (= (read-byte stream) 10)
                 (= (read-byte stream) 26)
                 (= (read-byte stream) 10))
      (error "Incorrect PNG file ~s - wrong signature." pathname))

    ;; Read header
    (skip-octets 4)
    (when (string/= (read-base-string stream 4) "IHDR")
      (error "Incorrect PNG file ~s - wrong header." pathname))
    (let* ((width (read-byte32 stream))
           (height (read-byte32 stream))
           (bits-per-color (read-byte stream))
           (cs (read-byte stream))
           (color-space (case cs
                          (0 "DeviceGray")
                          (2 "DeviceRGB")
                          (3 "Indexed")
                          (otherwise (error "Alpha channel not supported ~s" pathname))))
           palette mask data)
      (when (> bits-per-color 8) (error "16-bit depth not supported ~s" pathname))
      (when (/= (read-byte stream) 0) (error "Unknown compression method ~s" pathname))
      (when (/= (read-byte stream) 0) (error "Unknown filter method ~s" pathname))
      (when (/= (read-byte stream) 0) (error "Interlacing not supported ~s" pathname))
      (skip-octets 4)

      ;; Extract palette, transparency and data if any
      (do ((octet-length (read-byte32 stream) (read-byte32 stream))
           (marker (read-base-string stream 4) (read-base-string stream 4)))
          ((= octet-length 0))
        ;(declare (type (unsigned-byte 32) octet-length)
        (cond ((string= marker "PLTE")
	       ;; Palette: octet-length should be a multiple of 3
               (setq palette (make-array octet-length :element-type '(unsigned-byte 8)))
               (read-sequence palette stream))
              ((string= marker "tRNS")				; transparency info
               (let ((trns (make-array octet-length :element-type '(unsigned-byte 8))))
                 (read-sequence trns stream)
                 (setq mask (case cs
                              (0				; DeviceGray
                               (list (aref trns 1)))
                              (2				; DeviceRGB
                               (list (aref trns 1) (aref trns 3) (aref trns 5)))
                              (otherwise			; Indexed
                               (let ((position (position 0 trns)))
                                 (when position (list position))))))))
              ((string= marker "IDAT")				; image data block
               (let ((start 0))
                 (if (null data)
                     (setf data (make-array octet-length
                                            :element-type '(unsigned-byte 8)
                                            :adjustable t))
                     (progn
                       (setf start (first (array-dimensions data)))
                       (adjust-array data (+ start octet-length))))
                 (read-sequence data stream :start start)))
              ((string= marker "IEND")
               (return))
              (t		;"pHYs"
               (skip-octets octet-length)))
        (skip-octets 4))

      (when (and (= cs 3) (null palette))			; Indexed
        (error "Palette is missing in ~s" pathname))
      (make-instance 'png-image :nb-components color-space
		     :width width :height height  :data data
                     :bits-per-color bits-per-color  :palette palette  :mask mask)))))

(defmethod make-image ((png png-image) &key &allow-other-keys)
  ;; For color key masking, the Mask entry is an array of 2*N integers,
  ;; [min1 max1 ... minN maxN], where N is the number of color components in the
  ;; image's color space.
  (let* ((nb-components (nb-components png))
         (palette (palette png))
         (lookup
          (if palette ;(string= nb-components "Indexed")
              (make-instance 'indirect-object :content	; comperess is controlled by config
                (make-instance 'pdf-stream
                               ;:dict-values `(("/Filter" . ,filter))
                               :content palette
			       :no-compression t))))
         (mask (mask png)))
    (make-instance 'pdf:image
         :bits (data png)
         :width (width png) :height (height png)
         :color-space (if (string= nb-components "Indexed")
                          (vector (pdf-name nb-components)
                            "/DeviceRGB"			; base
                            (1- (truncate (length palette) 3))	; maximum valid index value
                            lookup)
                          (pdf-name nb-components))
         :bits-per-color (bits-per-color png)
         :decode (if (string= nb-components "DeviceCMYK") #(1 0 1 0 1 0 1 0))
         :mask (when mask
                 (apply #'vector (mapcan (lambda (i) (list i i)) mask)))
         :filter "/FlateDecode"				; the only method we recognize
         :decode-parms `(("/Predictor" . 15)
                         ("/Colors" . ,(if (string= nb-components "DeviceRGB") 3 1))
                         ("/BitsPerComponent" . ,(bits-per-color png))
                         ("/Columns" . ,(width png)))
         :no-compression t)))				; data bits already come compressed