Update of /project/cl-jpeg/cvsroot/cljl
In directory clnet:/tmp/cvs-serv25374
Modified Files:
jpeg.lisp
Log Message:
pending patch applied
--- /project/cl-jpeg/cvsroot/cljl/jpeg.lisp 2007/02/23 23:48:36 1.1.1.1
+++ /project/cl-jpeg/cvsroot/cljl/jpeg.lisp 2007/02/24 00:00:12 1.2
@@ -1,6 +1,6 @@
;; -*- Mode: LISP; Package: (JPEG :use (common-lisp)) -*-
;;; Generic Common Lisp JPEG encoder/decoder implementation
-;;; $Id: jpeg.lisp,v 1.1.1.1 2007/02/23 23:48:36 ezaikonnikov Exp $
+;;; $Id: jpeg.lisp,v 1.2 2007/02/24 00:00:12 ezaikonnikov Exp $
;;; Version 1.022, June 1999.
;;; Written by Eugene Zaikonnikov [viking(a)funcall.org]
;;; Copyright [c] 1999, Eugene Zaikonnikov <viking(a)funcall.org>
@@ -59,11 +59,14 @@
;;; to the Independent JPEG Group - colorspace conversion and DCT algorithms were adopted from their sources;
;;; to Jeff Dalton for his wise paper "Common Lisp Pitfalls".
-(defpackage #:jpeg (:use #:common-lisp))
-(in-package #:jpeg)
+(defpackage #:jpeg
+ (:use #:common-lisp)
+ (:export #:encode-image
+ #:decode-stream
+ #:decode-image
+ #:jpeg-to-bmp))
-(eval-when (compile)
- (export '(encode-image decode-image jpeg-to-bmp)))
+(in-package #:jpeg)
(declaim (inline csize write-stuffed quantize get-average zigzag encode-block llm-dct descale crunch colorspace-convert subsample
inverse-llm-dct dequantize upsample extend recieve decode-ac decode-dc decode-block izigzag write-bits))
@@ -651,7 +654,7 @@
;;; Function that maps value into SSSS
(defun csize (n)
- (declare #.*optimize* (type fixnum n val LSB MSB))
+ (declare #.*optimize* (type fixnum n))
(svref *csize* (plus n 1023)))
;;; zigzag ordering
@@ -731,7 +734,7 @@
;;; Encodes block using specified huffman tables, returns new pred (DC prediction value)
;;; and last code written to stream for padding
(defun encode-block (block tables pred s)
- (declare #.*optimize* (type fixnum pred newpred diff dcpos)
+ (declare #.*optimize* (type fixnum pred)
(type (simple-vector *) block))
(let* ((ehufsi-dc (first (first tables)))
(ehufco-dc (second (first tables)))
@@ -740,7 +743,7 @@
(newpred (svref block 0))
(diff (minus newpred pred))
(dcpos (csize diff)))
- (declare (type fixnum pred newpred diff pos)
+ (declare (type fixnum pred newpred diff dcpos)
(dynamic-extent diff dcpos))
;; writing dc code first
(write-bits (svref ehufco-dc dcpos) (svref ehufsi-dc dcpos) s)
@@ -1589,25 +1592,31 @@
(when (= (descriptor-ncomp image) 3)
(inverse-colorspace-convert image))))
+(defun decode-stream (stream)
+ (unless (= (read-marker stream) *M_SOI*)
+ (error "Unrecognized JPEG format"))
+ (let* ((image (make-descriptor))
+ (marker (interpret-markers image 0 stream)))
+ (cond ((= *M_SOF0* marker) (decode-frame image stream)
+ (values (descriptor-buffer image)
+ (descriptor-height image)
+ (descriptor-width image)
+ (descriptor-ncomp image)))
+ (t (error "Unsupported JPEG format")))))
+
;;; Top level decoder function
(defun decode-image (filename)
- (with-open-file
- (s filename :direction :input :element-type 'unsigned-byte)
- (unless (= (read-marker s) *M_SOI*)
- (error "Unrecognized JPEG format"))
- (let* ((image (make-descriptor))
- (marker (interpret-markers image 0 s)))
- (cond ((= *M_SOF0* marker) (decode-frame image s)
- (values (descriptor-buffer image) (descriptor-height image) (descriptor-width image)))
- (t (error "Unsupported JPEG format"))))))
+ (with-open-file (in filename :direction :input :element-type 'unsigned-byte)
+ (decode-stream in)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Here's some useful routines
+;;; Here are some useful routines
;;; Produces outfile (Windows 24-bit bitmap) from a JPEG infile
(defun jpeg-to-bmp (&key infile outfile)
(with-open-file (o outfile :direction :output :element-type 'unsigned-byte)
- (multiple-value-bind (rgb h w)
+ (multiple-value-bind (rgb h w number-components)
(decode-image infile)
(let* ((compl (rem w 4))
(len (+ 54 (* h w 3) (mul compl h))))
@@ -1644,15 +1653,25 @@
(write-byte 24 o) ;bitcount, 24-bit BMP
(write-byte 0 o)
(write-sequence (make-array 24 :initial-element 0 :element-type 'unsigned-byte) o) ;the rest of header
- (loop for y fixnum from (1- h) downto 0
- for ypos fixnum = (* y 3 w) do
- (loop for x fixnum from ypos to (plus ypos (* (1- w) 3)) by 3 do
- (write-byte (the unsigned-byte (svref rgb x)) o)
- (write-byte (the unsigned-byte (svref rgb (1+ x))) o)
- (write-byte (the unsigned-byte (svref rgb (plus 2 x))) o))
- (loop for i fixnum from 0 below compl do ;adjusting to double-word
- (write-byte 0 o)))))))
-
+ (ecase number-components
+ (1
+ (loop :for y :from (1- h) :downto 0 :do
+ (loop :for x :from (1- w) :downto 0 :do
+ (let ((grey (svref rgb (+ x (* y w)))))
+ (write-byte grey o)
+ (write-byte grey o)
+ (write-byte grey o)))
+ (dotimes (i compl)
+ (write-byte 0 o))))
+ (3
+ (loop for y fixnum from (1- h) downto 0
+ for ypos fixnum = (* y 3 w) do
+ (loop for x fixnum from ypos to (plus ypos (* (1- w) 3)) by 3 do
+ (write-byte (the unsigned-byte (svref rgb x)) o)
+ (write-byte (the unsigned-byte (svref rgb (1+ x))) o)
+ (write-byte (the unsigned-byte (svref rgb (plus 2 x))) o))
+ (loop for i fixnum from 0 below compl do ;adjusting to double-word
+ (write-byte 0 o)))))))))
;;; Provides simple user interface for encoder: quality may vary 1 to 5 (decreasing)
