Coverage report: /home/ellis/comp/core/lib/dat/png.lisp

Kind	Covered	All	%
expression	0	624	0.0
branch	0	28	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; dat/png.lisp --- PNG image format

2

3

;; based on ZPNG by Zachary Beane

4

5

;;; Code:

6

(in-package :dat/png)

7

8

;;; ZPNG

9

10

11

;;;; Specials

12

(defvar *color-types*

13

'((:grayscale . 0)

14

(:truecolor . 2)

15

(:indexed-color . 3)

16

(:grayscale-alpha . 4)

17

(:truecolor-alpha . 6)))

18

19

(defvar *png-signature*

20

(make-array 8

21

:element-type '(unsigned-byte 8)

22

:initial-contents '(137 80 78 71 13 10 26 10)))

23

24

(defconstant +png-compression-method+ 0)

25

(defconstant +png-filtering+ 0)

26

(defconstant +png-interlace+ 0)

27

28

;;;; Utils

29

(defun write-uint32 (integer stream)

30

(write-byte (ldb (byte 8 24) integer) stream)

31

(write-byte (ldb (byte 8 16) integer) stream)

32

(write-byte (ldb (byte 8 8) integer) stream)

33

(write-byte (ldb (byte 8 0) integer) stream))

34

35

(defun checksum (data count)

36

(let ((checksum (ironclad:make-digest :crc32)))

37

(ironclad:update-digest checksum data :start 0 :end count)

38

(ironclad:produce-digest checksum)))

39

40

(defclass chunk ()

41

((buffer :initarg :buffer :reader buffer)

42

(pos :initform 4 :accessor pos)))

43

44

(defun chunk-write-byte (byte chunk)

45

"Save one byte to CHUNK."

46

(setf (aref (buffer chunk) (pos chunk)) byte)

47

(incf (pos chunk)))

48

49

(defun chunk-write-uint32 (integer chunk)

50

"Save INTEGER to CHUNK as four bytes."

51

(let ((buffer (buffer chunk))

52

(i (pos chunk)))

53

(setf (aref buffer (+ i 0)) (ldb (byte 8 24) integer)

54

(aref buffer (+ i 1)) (ldb (byte 8 16) integer)

55

(aref buffer (+ i 2)) (ldb (byte 8 8) integer)

56

(aref buffer (+ i 3)) (ldb (byte 8 0) integer)

57

(pos chunk) (+ i 4))))

58

59

(defun make-chunk (a b c d size)

60

"Make a chunk that uses A, B, C, and D as the signature bytes, with

61

data size SIZE."

62

(let ((buffer (make-array (+ size 4) :element-type '(unsigned-byte 8))))

63

(setf (aref buffer 0) a

64

(aref buffer 1) b

65

(aref buffer 2) c

66

(aref buffer 3) d)

67

(make-instance 'chunk

68

:buffer buffer)))

69

70

(defun write-chunk (chunk stream)

71

(write-uint32 (- (pos chunk) 4) stream)

72

(write-sequence (buffer chunk) stream :end (pos chunk))

73

(write-uint32 (checksum (buffer chunk) (pos chunk)) stream))

74

75

;;;; Conditions

76

(define-condition png-error (dat-error) ())

77

78

(define-condition invalid-size (png-error)

79

((width

80

:initarg :width

81

:reader invalid-size-width)

82

(height

83

:initarg :height

84

:reader invalid-size-height))

85

(:report (lambda (condition stream)

86

(format stream "Invalid PNG size ~Ax~A; ~

87

both width and height must be positive"

88

(invalid-size-width condition)

89

(invalid-size-height condition)))))

90

91

(define-condition invalid-row-length (png-error)

92

((expected-length

93

:initarg :expected-length

94

:accessor invalid-row-length-expected-length)

95

(actual-length

96

:initarg :actual-length

97

:accessor invalid-row-length-actual-length))

98

(:report (lambda (condition stream)

99

(format stream "Invalid row length ~A (expected ~A)"

100

(invalid-row-length-actual-length condition)

101

(invalid-row-length-expected-length condition)))))

102

103

(define-condition insufficient-rows (png-error)

104

((written

105

:initarg :written

106

:accessor insufficient-rows-written)

107

(needed

108

:initarg :needed

109

:accessor insufficient-rows-needed))

110

(:report (lambda (condition stream)

111

(format stream "Insufficient rows written; need ~A, but only ~A ~

112

written"

113

(insufficient-rows-needed condition)

114

(insufficient-rows-written condition)))))

115

116

(define-condition incomplete-row (png-error)

117

((written

118

:initarg :written

119

:accessor incomplete-row-written)

120

(needed

121

:initarg :needed

122

:accessor incomplete-row-needed))

123

(:report (lambda (condition stream)

124

(format stream "Incomplete row started; need ~A, but only ~A ~

125

written"

126

(incomplete-row-needed condition)

127

(incomplete-row-written condition)))))

128

129

(define-condition too-many-rows (png-error)

130

((count

131

:initarg :count

132

:accessor too-many-rows-count))

133

(:report (lambda (condition stream)

134

(format stream "Too many rows written for PNG; maximum row count ~

135

is ~A"

136

(too-many-rows-count condition)))))

137

138

(define-condition color-type-mismatch (png-error)

139

((given

140

:initarg :given

141

:accessor color-type-mismatch-given)

142

(expected

143

:initarg :expected

144

:accessor color-type-mismatch-expected))

145

(:report (lambda (condition stream)

146

(format stream "Wrong number of samples for PNG pixel; need ~A, ~

147

but only ~A written"

148

(color-type-mismatch-expected condition)

149

(color-type-mismatch-given condition)))))

150

151

;;;; PNG

152

(defclass base-png ()

153

((width :initarg :width :reader width)

154

(height :initarg :height :reader height)

155

(color-type :initform :truecolor :initarg :color-type :reader color-type)

156

(bpp :initform 8 :initarg :bpp :reader bpp)))

157

158

(defclass png (base-png)

159

((image-data :initarg :image-data :reader image-data

160

:writer (setf %image-data))

161

(data-array :reader data-array

162

:writer (setf %data-array))))

163

164

(defclass streamed-png (base-png)

165

((rows-written

166

:initarg :rows-written

167

:accessor rows-written)

168

(row-data

169

:initarg :row-data

170

:accessor row-data)

171

(compressor

172

:initarg :compressor

173

:accessor compressor)

174

(output-stream

175

:initarg :output-stream

176

:accessor output-stream))

177

(:default-initargs

178

:rows-written 0))

179

180

(defclass pixel-streamed-png (streamed-png)

181

((current-offset

182

:initform 0

183

:accessor current-offset)))

184

185

(defgeneric ihdr-color-type (png))

186

(defgeneric samples-per-pixel (png))

187

(defgeneric scanline-offset (png scanline))

188

(defgeneric rowstride (png))

189

190

(defgeneric write-png-header (png stream))

191

(defgeneric write-ihdr (png stream))

192

(defgeneric write-idat (png stream))

193

(defgeneric write-iend (png stream))

194

195

(defgeneric copy-png (png))

196

(defgeneric png= (png1 png2))

197

198

(defgeneric write-png-stream (png stream))

199

(defgeneric write-png (png pathname &key if-exists))

200

201

(defgeneric start-png (png stream))

202

(defgeneric write-row (row png &key start end))

203

(defgeneric finish-png (png))

204

(defgeneric rows-left (png))

205

(defgeneric reset-streamed-png (png))

206

207

(defgeneric write-pixel (pixel png))

208

(defgeneric pixels-left-in-row (png))

209

210

(defmethod slot-unbound (class (png png) (slot (eql 'data-array)))

211

(let ((array (make-array (list (height png)

212

(width png)

213

(samples-per-pixel png))

214

:displaced-to (image-data png)

215

:element-type '(unsigned-byte 8))))

216

(setf (%data-array png) array)))

217

218

(defun check-size (png)

219

(let ((width (width png))

220

(height (height png)))

221

(unless (and (plusp width) (plusp height))

222

(error 'invalid-size

223

:width width

224

:height height))))

225

226

(defmethod initialize-instance :after ((png png) &rest args &key image-data)

227

(declare (ignore args))

228

(check-size png)

229

(unless (or image-data (slot-boundp png 'image-data))

230

(setf (%image-data png)

231

(make-array (* (height png) (rowstride png))

232

:initial-element 0

233

:element-type '(unsigned-byte 8)))))

234

235

(defmethod ihdr-color-type (png)

236

(cdr (assoc (color-type png) *color-types*)))

237

238

(defmethod samples-per-pixel (png)

239

(ecase (color-type png)

240

(:grayscale 1)

241

(:truecolor 3)

242

(:indexed-color 1)

243

(:grayscale-alpha 2)

244

(:truecolor-alpha 4)))

245

246

(defmethod rowstride (png)

247

(* (width png) (samples-per-pixel png)))

248

249

(defmethod scanline-offset (png scanline)

250

(* scanline (rowstride png)))

251

252

253

(defmethod write-png-header (png stream)

254

(write-sequence *png-signature* stream))

255

256

(defmethod write-ihdr (png stream)

257

(let ((chunk (make-chunk 73 72 68 82 13)))

258

(chunk-write-uint32 (width png) chunk)

259

(chunk-write-uint32 (height png) chunk)

260

(chunk-write-byte (bpp png) chunk)

261

(chunk-write-byte (ihdr-color-type png) chunk)

262

(chunk-write-byte +png-compression-method+ chunk)

263

(chunk-write-byte +png-filtering+ chunk)

264

(chunk-write-byte +png-interlace+ chunk)

265

(write-chunk chunk stream)))

266

267

(defun make-idat-callback (stream)

268

(let* ((idat (make-chunk 73 68 65 84 16384))

269

(buffer (buffer idat)))

270

(lambda (data end)

271

(replace buffer data :start1 4 :end2 end)

272

(setf (pos idat) (+ end 4))

273

(write-chunk idat stream))))

274

275

(defmethod write-idat (png stream)

276

(let ((callback (make-idat-callback stream)))

277

;; TODO 2025-06-11:

278

(io/flate:with-compressor (compressor 'io/deflate:zlib-compressor

279

:callback callback)

280

(dotimes (i (height png))

281

(let* ((start-offset (scanline-offset png i))

282

(end-offset (+ start-offset (rowstride png))))

283

(io/flate:compress-octet 0 compressor)

284

(io/flate:compress-octet-vector (image-data png)

285

compressor

286

:start start-offset

287

:end end-offset))))))

288

289

(defmethod write-iend (png stream)

290

(let ((chunk (make-chunk 73 69 78 68 0)))

291

(write-chunk chunk stream)))

292

293

294

(defmethod write-png-stream (png stream)

295

(check-size png)

296

(write-png-header png stream)

297

(write-ihdr png stream)

298

(write-idat png stream)

299

(write-iend png stream))

300

301

(defmethod write-png (png file &key (if-exists :supersede))

302

(check-size png)

303

(with-open-file (stream file

304

:direction :output

305

:if-exists if-exists

306

:if-does-not-exist :create

307

:element-type '(unsigned-byte 8))

308

(write-png-stream png stream)

309

(truename file)))

310

311

(defmethod copy-png (orig)

312

(make-instance 'png

313

:width (width orig)

314

:height (height orig)

315

:color-type (color-type orig)

316

:bpp (bpp orig)

317

:image-data (copy-seq (image-data orig))))

318

319

(defmethod png= (png1 png2)

320

(or (eq png1 png2)

321

(and (= (width png1) (width png2))

322

(= (height png1) (height png2))

323

(= (bpp png1) (bpp png2))

324

(eq (color-type png1) (color-type png2))

325

(let ((png1.data (image-data png1))

326

(png2.data (image-data png2)))

327

(not (mismatch png1.data png2.data))))))

328

329

330

;;; Streamed PNG methods

331

332

(defmethod slot-unbound (class (png streamed-png) (slot (eql 'row-data)))

333

(let ((data (make-array (rowstride png) :element-type '(unsigned-byte 8)

334

:initial-element 0)))

335

(setf (row-data png) data)))

336

337

(defmethod start-png ((png streamed-png) stream)

338

(setf (output-stream png) stream)

339

(write-png-header png stream)

340

(write-ihdr png stream)

341

(setf (compressor png)

342

(make-instance 'zlib-compressor

343

:callback (make-idat-callback stream)))

344

stream)

345

346

(defmethod start-png ((png pixel-streamed-png) stream)

347

(setf (current-offset png) 0)

348

(call-next-method))

349

350

(defmethod write-row (row (png streamed-png) &key (start 0) end)

351

(let ((rowstride (rowstride png)))

352

(setf end (or end (+ start rowstride)))

353

(let ((row-length (- end start)))

354

(unless (= (- end start) (rowstride png))

355

(error 'invalid-row-length

356

:expected-length rowstride

357

:actual-length row-length))

358

(unless (< (rows-written png) (height png))

359

(error 'too-many-rows :count (height png)))

360

(let ((compressor (compressor png)))

361

(io/flate:compress-octet 0 compressor)

362

(io/flate:compress-octet-vector row compressor :start start :end end)

363

(incf (rows-written png))))))

364

365

(defmethod reset-streamed-png ((png streamed-png))

366

(setf (rows-written png) 0)

367

(slot-makunbound png 'compressor)

368

(slot-makunbound png 'output-stream)

369

(fill (row-data png) 0))

370

371

(defmethod reset-streamed-png ((png pixel-streamed-png))

372

(setf (current-offset png) 0)

373

(call-next-method))

374

375

(defmethod finish-png ((png streamed-png))

376

(when (/= (rows-written png) (height png))

377

(error 'insufficient-rows

378

:written (rows-written png)

379

:needed (height png)))

380

(io/flate:finish-compression (compressor png))

381

(write-iend png (output-stream png))

382

(reset-streamed-png png)

383

png)

384

385

(defmethod finish-png ((png pixel-streamed-png))

386

(let* ((color-channels (samples-per-pixel png))

387

(columns (/ (current-offset png) color-channels)))

388

(unless (zerop columns)

389

(error 'incomplete-row

390

:written columns

391

:needed (/ (length (row-data png)) color-channels))))

392

(call-next-method))

393

394

(defmethod rows-left ((png streamed-png))

395

(- (height png) (rows-written png)))

396

397

(defmethod write-pixel (pixel (png pixel-streamed-png))

398

(let ((row-data (row-data png))

399

(samples-per-pixel (length pixel))

400

(samples-per-pixel-expected (samples-per-pixel png)))

401

(unless (= samples-per-pixel samples-per-pixel-expected)

402

(error 'color-type-mismatch

403

:given samples-per-pixel

404

:expected samples-per-pixel-expected))

405

(replace row-data pixel :start1 (current-offset png))

406

(when (= (incf (current-offset png) samples-per-pixel) (rowstride png))

407

(write-row row-data png)

408

(setf (current-offset png) 0)))

409

png)

410

411

(defmethod pixels-left-in-row ((png pixel-streamed-png))

412

(/ (- (current-offset png) (rowstride png)) (samples-per-pixel png)))