cl-jpeg-cvs

Download

cl-jpeg-cvs@common-lisp.net

May 2008

1 participants
1 discussions

[cl-jpeg-cvs] CVS cljl
by charmon 10 May '08

10 May '08

Update of /project/cl-jpeg/cvsroot/cljl In directory clnet:/tmp/cvs-serv27759 Modified Files: cl-jpeg.asd jpeg.lisp Log Message: jpeg 1.023 * added :name, :version and :licence to the asdf file * removed the cl-jpeg-system package from the asdf file * bumped version and fixed typo in the opening comments * added a define-constant macro for use where we used to use to define-constant for things that weren't necessarily eq when recompiling them, like vectors and lists. * use define-constant where appropriate * added an encode-image-stream and call this from encode-image to do the heavy lifting --- /project/cl-jpeg/cvsroot/cljl/cl-jpeg.asd 2007/02/23 23:48:36 1.1.1.1 +++ /project/cl-jpeg/cvsroot/cljl/cl-jpeg.asd 2008/05/10 05:53:19 1.2 @@ -1,8 +1,8 @@ ;;;; -*- Mode: Lisp; Package: User; -*- -(defpackage #:cl-jpeg-system (:use #:asdf #:cl)) -(in-package #:cl-jpeg-system) - -(defsystem :cl-jpeg +(asdf:defsystem :cl-jpeg + :name "cl-jpeg" + :version 1.023 + :licence "BSD" :components ((:file "jpeg"))) --- /project/cl-jpeg/cvsroot/cljl/jpeg.lisp 2007/02/24 00:00:12 1.2 +++ /project/cl-jpeg/cvsroot/cljl/jpeg.lisp 2008/05/10 05:53:19 1.3 @@ -1,14 +1,14 @@ ;; -*- Mode: LISP; Package: (JPEG :use (common-lisp)) -*- ;;; Generic Common Lisp JPEG encoder/decoder implementation -;;; $Id: jpeg.lisp,v 1.2 2007/02/24 00:00:12 ezaikonnikov Exp $ -;;; Version 1.022, June 1999. +;;; $Id: jpeg.lisp,v 1.3 2008/05/10 05:53:19 charmon Exp $ +;;; Version 1.023, May 2008 ;;; Written by Eugene Zaikonnikov [viking(a)funcall.org] ;;; Copyright [c] 1999, Eugene Zaikonnikov <viking(a)funcall.org> ;;; This software is distributed under the terms of BSD-like license ;;; [see LICENSE for details] -;;; That was qute some time ago - I'd wrote it better now [E.Z., 2001] +;;; That was quite some time ago - I'd wrote it better now [E.Z., 2001] -;;; Known to work with Lispworks 4 and Allegro CL 5 +;;; Known to work with Lispworks 4 and Allegro CL 5 and SBCL 1.0.16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Creation of this software was sponsored by Kelly E. Murray @@ -99,28 +99,32 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Here we define some constants (markers, quantization and huffman tables etc.) +(defmacro define-constant (name value &optional doc) + `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) + ,@(when doc (list doc)))) + (eval-when (:compile-toplevel :load-toplevel) ;;; Source huffman tables for the encoder -(defconstant *luminance-dc-bits* +(define-constant *luminance-dc-bits* #(#x00 #x01 #x05 #x01 #x01 #x01 #x01 #x01 #x01 #x00 #x00 #x00 #x00 #x00 #x00 #x00)) -(defconstant *luminance-dc-values* +(define-constant *luminance-dc-values* #(#x00 #x01 #x02 #x03 #x04 #x05 #x06 #x07 #x08 #x09 #x0a #x0b)) -(defconstant *chrominance-dc-bits* +(define-constant *chrominance-dc-bits* #(#x00 #x03 #x01 #x01 #x01 #x01 #x01 #x01 #x01 #x01 #x01 #x00 #x00 #x00 #x00 #x00)) -(defconstant *chrominance-dc-values* +(define-constant *chrominance-dc-values* #(#x00 #x01 #x02 #x03 #x04 #x05 #x06 #x07 #x08 #x09 #x0a #x0b)) -(defconstant *luminance-ac-bits* +(define-constant *luminance-ac-bits* #(#x00 #x02 #x01 #x03 #x03 #x02 #x04 #x03 #x05 #x05 #x04 #x04 #x00 #x00 #x01 #x7d)) -(defconstant *luminance-ac-values* +(define-constant *luminance-ac-values* #(#x01 #x02 #x03 #x00 #x04 #x11 #x05 #x12 #x21 #x31 #x41 #x06 #x13 #x51 #x61 #x07 #x22 #x71 #x14 #x32 #x81 #x91 #xa1 #x08 @@ -143,11 +147,11 @@ #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 #xf8 #xf9 #xfa)) -(defconstant *chrominance-ac-bits* +(define-constant *chrominance-ac-bits* #(#x00 #x02 #x01 #x02 #x04 #x04 #x03 #x04 #x07 #x05 #x04 #x04 #x00 #x01 #x02 #x77)) -(defconstant *chrominance-ac-values* +(define-constant *chrominance-ac-values* #(#x00 #x01 #x02 #x03 #x11 #x04 #x05 #x21 #x31 #x06 #x12 #x41 #x51 #x07 #x61 #x71 #x13 #x22 #x32 #x81 #x08 #x14 #x42 #x91 @@ -171,7 +175,7 @@ #xf9 #xfa)) ;;;Zigzag encoding matrix -(defconstant *zigzag-index* +(define-constant *zigzag-index* #(#(0 1 5 6 14 15 27 28) #(2 4 7 13 16 26 29 42) #(3 8 12 17 25 30 41 43) @@ -184,7 +188,7 @@ ;;; Temporary buffer for zigzag encoding and decoding (defvar *zz-result* (make-array 64 :element-type 'unsigned-byte)) -(defconstant *zzbuf* +(define-constant *zzbuf* #(#(0 0 0 0 0 0 0 0) #(0 0 0 0 0 0 0 0) #(0 0 0 0 0 0 0 0) @@ -293,10 +297,10 @@ (finish-output) ) -(defconstant *q-tables* (vector *q-luminance* *q-chrominance*)) +(define-constant *q-tables* (vector *q-luminance* *q-chrominance*)) ;;; This table is used to map coefficients into SSSS value -(defconstant *csize* (make-array 2047 +(define-constant *csize* (make-array 2047 :initial-contents (loop for i fixnum from 0 to 2046 collecting (integer-length (abs (minus i 1023)))))) @@ -881,127 +885,131 @@ (list ehufsi ehufco)))) ;;; Main encoder function (user interface) -(defun encode-image (filename image ncomp h w &key (q-tabs *q-tables*) (sampling '((2 2)(1 1)(1 1))) (q-factor 64)) +(defun encode-image-stream (out-stream image ncomp h w &key (q-tabs *q-tables*) (sampling '((2 2)(1 1)(1 1))) (q-factor 64)) (declare #.*optimize* (type fixnum ncomp h w q-factor) (type (simple-vector *) image)) + (when (= ncomp 1) + (setq sampling '((1 1)))) + (let* ((wd (loop for entry in sampling maximize (first entry))) + (ht (loop for entry in sampling maximize (second entry))) + (isampling (convert-sampling sampling wd ht)) + (height (ash ht 3)) + (width (ash wd 3)) + (YUV (make-array ncomp + :initial-contents + (loop for i fixnum from 0 below ncomp collecting + (make-array height + :initial-contents + (loop for j fixnum from 0 below height + collecting (make-array width)))))) + (sampled-buf (make-array (mul ht wd) + :initial-contents + (loop for b fixnum from 0 below (mul ht wd) + collecting (make-array 8 + :initial-contents + (loop for i fixnum from 0 to 7 + collecting (make-array 8)))))) + (preds (make-array ncomp :initial-element 0)) + (tqv (case ncomp + (3 #(0 1 1)) ;q-tables destinations for various component numbers + (1 #(0)) + (2 #(0 1)) + (4 #(0 1 2 3)) + (otherwise (error "Illegal number of components specified"))))) + (cond ((/= ncomp (length sampling)) + (error "Wrong sampling list for ~D component(s)" ncomp)) + ((> (length q-tabs) ncomp) + (error "Too many quantization tables specified")) + ((zerop q-factor) + (error "Q-factor should be nonzero!")) + ((> (count-relation sampling) 10) + (error "Invalid sampling specification!"))) + (when (< q-factor 64) + (let ((q-tabs2 (make-array (length q-tabs) + :initial-contents + (loop for k fixnum from 0 below (length q-tabs) + collecting (make-array 8 :initial-contents + (loop for i fixnum from 0 to 7 + collecting (make-array 8))))))) + (loop for entry across q-tabs + for entry2 across q-tabs2 do + (loop for x fixnum from 0 to 7 do + (loop for y fixnum from 0 to 7 do + (setf (dbref entry2 x y) (the fixnum (dbref entry x y)))))) + (setq q-tabs q-tabs2)) + (loop for entry across q-tabs do ;scaling all q-tables + (q-scale entry q-factor))) + (setq *prev-byte* 0) + (setq *prev-length* 0) + (if (and (/= ncomp 1) (/= ncomp 3)) + (write-marker *M_SOI* out-stream) + (prepare-JFIF-stream out-stream)) + (write-frame-header w h ncomp q-tabs sampling tqv out-stream) ;frame header + ;;writing scan header + (write-marker *M_SOS* out-stream) + (write-byte 0 out-stream) ;length + (write-byte (plus 6 (ash ncomp 1)) out-stream) + (write-byte ncomp out-stream) ;number of components in the scan + (loop for Cj from 0 below ncomp do + (write-byte Cj out-stream) ;component ID + (write-byte (if (zerop Cj) 0 17) out-stream)) ;TdTa + (write-byte 0 out-stream) ;Ss + (write-byte 63 out-stream) ;Se + (write-byte 0 out-stream) ;AhAl + + (let ((luminance-tabset (list + (build-tables *luminance-dc-bits* *luminance-dc-values*) + (build-tables *luminance-ac-bits* *luminance-ac-values*))) + (chrominance-tabset (list (build-tables *chrominance-dc-bits* *chrominance-dc-values*) + (build-tables *chrominance-ac-bits* *chrominance-ac-values*)))) + (loop for dy fixnum from 0 below h by height do + (loop for dx fixnum from 0 below w by width do + (multiple-value-bind (xlim ylim) + (if (= ncomp 3) + (colorspace-convert image YUV dx dy h w height width) + (crop-image image YUV dx dy h w height width ncomp)) + (declare (type fixnum xlim ylim) + (dynamic-extent xlim ylim)) + (loop for comp across YUV + for freq in sampling + for ifreq across isampling + for iH fixnum = (first ifreq) + for iV fixnum = (second ifreq) + for cn fixnum from 0 + for hufftabs = (if (zerop cn) + luminance-tabset + chrominance-tabset) + for q-tab = (svref q-tabs (svref tqv cn)) ;choosing appropriate q-table for a component + for H fixnum = (first freq) + for V fixnum = (second freq) do + (subsample comp sampled-buf H V (minus xlim dx) (minus ylim dy) iH iV) + (loop for y fixnum from 0 below V + for ypos fixnum = (if (> (plus dy (ash y 3)) ylim) + (mul (rem (ash ylim -3) V) H) + (mul y H)) do + (loop for x fixnum from 0 below H + for pos fixnum = (if (> (plus dx (ash x 3)) xlim) + (plus (rem (ash xlim -3) H) ypos) + (plus x ypos)) do + (crunch sampled-buf pos q-tab) + (setf (svref preds cn) + (encode-block (zigzag (svref sampled-buf pos)) + hufftabs (svref preds cn) out-stream))))))))) + (unless (zerop *prev-length*) + (write-stuffed (deposit-field #xff ;byte padding & flushing + (byte (minus 8 *prev-length*) 0) + (ash *prev-byte* (minus 8 *prev-length*))) + out-stream)) + (write-marker *M_EOI* out-stream))) + +(defun encode-image (filename image ncomp h w &rest args) (with-open-file (out-stream filename :direction :output :element-type 'unsigned-byte :if-exists :supersede) - (when (= ncomp 1) - (setq sampling '((1 1)))) - (let* ((wd (loop for entry in sampling maximize (first entry))) - (ht (loop for entry in sampling maximize (second entry))) - (isampling (convert-sampling sampling wd ht)) - (height (ash ht 3)) - (width (ash wd 3)) - (YUV (make-array ncomp - :initial-contents - (loop for i fixnum from 0 below ncomp collecting - (make-array height - :initial-contents - (loop for j fixnum from 0 below height - collecting (make-array width)))))) - (sampled-buf (make-array (mul ht wd) - :initial-contents - (loop for b fixnum from 0 below (mul ht wd) - collecting (make-array 8 - :initial-contents - (loop for i fixnum from 0 to 7 - collecting (make-array 8)))))) - (preds (make-array ncomp :initial-element 0)) - (tqv (case ncomp - (3 #(0 1 1)) ;q-tables destinations for various component numbers - (1 #(0)) - (2 #(0 1)) - (4 #(0 1 2 3)) - (otherwise (error "Illegal number of components specified"))))) - (cond ((/= ncomp (length sampling)) - (error "Wrong sampling list for ~D component(s)" ncomp)) - ((> (length q-tabs) ncomp) - (error "Too many quantization tables specified")) - ((zerop q-factor) - (error "Q-factor should be nonzero!")) - ((> (count-relation sampling) 10) - (error "Invalid sampling specification!"))) - (when (< q-factor 64) - (let ((q-tabs2 (make-array (length q-tabs) - :initial-contents - (loop for k fixnum from 0 below (length q-tabs) - collecting (make-array 8 :initial-contents - (loop for i fixnum from 0 to 7 - collecting (make-array 8))))))) - (loop for entry across q-tabs - for entry2 across q-tabs2 do - (loop for x fixnum from 0 to 7 do - (loop for y fixnum from 0 to 7 do - (setf (dbref entry2 x y) (the fixnum (dbref entry x y)))))) - (setq q-tabs q-tabs2)) - (loop for entry across q-tabs do ;scaling all q-tables - (q-scale entry q-factor))) - (setq *prev-byte* 0) - (setq *prev-length* 0) - (if (and (/= ncomp 1) (/= ncomp 3)) - (write-marker *M_SOI* out-stream) - (prepare-JFIF-stream out-stream)) - (write-frame-header w h ncomp q-tabs sampling tqv out-stream) ;frame header - ;;writing scan header - (write-marker *M_SOS* out-stream) - (write-byte 0 out-stream) ;length - (write-byte (plus 6 (ash ncomp 1)) out-stream) - (write-byte ncomp out-stream) ;number of components in the scan - (loop for Cj from 0 below ncomp do - (write-byte Cj out-stream) ;component ID - (write-byte (if (zerop Cj) 0 17) out-stream)) ;TdTa - (write-byte 0 out-stream) ;Ss - (write-byte 63 out-stream) ;Se - (write-byte 0 out-stream) ;AhAl - - (let ((luminance-tabset (list - (build-tables *luminance-dc-bits* *luminance-dc-values*) - (build-tables *luminance-ac-bits* *luminance-ac-values*))) - (chrominance-tabset (list (build-tables *chrominance-dc-bits* *chrominance-dc-values*) - (build-tables *chrominance-ac-bits* *chrominance-ac-values*)))) - (loop for dy fixnum from 0 below h by height do - (loop for dx fixnum from 0 below w by width do - (multiple-value-bind (xlim ylim) - (if (= ncomp 3) - (colorspace-convert image YUV dx dy h w height width) - (crop-image image YUV dx dy h w height width ncomp)) - (declare (type fixnum xlim ylim) - (dynamic-extent xlim ylim)) - (loop for comp across YUV - for freq in sampling - for ifreq across isampling - for iH fixnum = (first ifreq) - for iV fixnum = (second ifreq) - for cn fixnum from 0 - for hufftabs = (if (zerop cn) - luminance-tabset - chrominance-tabset) - for q-tab = (svref q-tabs (svref tqv cn)) ;choosing appropriate q-table for a component - for H fixnum = (first freq) - for V fixnum = (second freq) do - (subsample comp sampled-buf H V (minus xlim dx) (minus ylim dy) iH iV) - (loop for y fixnum from 0 below V - for ypos fixnum = (if (> (plus dy (ash y 3)) ylim) - (mul (rem (ash ylim -3) V) H) - (mul y H)) do - (loop for x fixnum from 0 below H - for pos fixnum = (if (> (plus dx (ash x 3)) xlim) - (plus (rem (ash xlim -3) H) ypos) - (plus x ypos)) do - (crunch sampled-buf pos q-tab) - (setf (svref preds cn) - (encode-block (zigzag (svref sampled-buf pos)) - hufftabs (svref preds cn) out-stream))))))))) - (unless (zerop *prev-length*) - (write-stuffed (deposit-field #xff ;byte padding & flushing - (byte (minus 8 *prev-length*) 0) - (ash *prev-byte* (minus 8 *prev-length*))) - out-stream)) - (write-marker *M_EOI* out-stream)))) + (apply #'encode-image-stream out-stream image ncomp h w args))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0