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
|
;;;; eusjpeg.l
;;; (c) 1997, Toshihiro Matsui, Electrotechnical Laboratory
;;;
;;; links libjpeg.so library and makes entries to jpeg_compress and
;;; jpeg_decompress. Support routines defined in jmemcd.c handles
;;; stream I/O with image data stored in core.
;;; jpegmemcd.so, which needs /usr/local/lib/libjpeg.so, must be
;;; generated first.
;;;
;;; Aug 1999 allocation of memory for decompressing is optimized.
;;; Aug 1999 decompressed image is always returnd as a color-image24.
(in-package "IMAGE")
(export '(jpeg-compress jpeg-decompress
read-jpeg-file write-jpeg-file))
(let ((m (load-foreign "jpegmemcd.so")))
(defforeign jpeg_header m "JPEG_header" () :integer)
(defforeign jpeg_decompress m "JPEG_decompress" () :integer)
(defforeign jpeg_compress m "JPEG_compress" () :integer))
(defun jpeg-compress (rgb-image &optional (quality 50) (jpeg-buffer) )
(let* ((w (send rgb-image :width))
(h (send rgb-image :height))
jpeg-size
)
(setq rgb-image (send rgb-image :to24))
(if (not (derivedp rgb-image color-image24))
(error "jpeg-compress expected 24-bit color-image, but ~s~%"
rgb-image))
;; We cannot predict exact size of the compressed file.
;; So, prepare a buffer for no compression.
(if (null jpeg-buffer)
(setq jpeg-buffer (make-string (* w h 3))))
(setq jpeg-size
(jpeg_compress (send rgb-image :entity) w h
jpeg-buffer (length jpeg-buffer) quality))
(list jpeg-buffer jpeg-size)
) )
(defun write-jpeg-file (fname rgb-image &optional (quality 80))
;; rgb-image is either a long-pixel-image or deep-pixel-image
;;
(let (r)
(setq r (jpeg-compress rgb-image))
(setq fname (merge-pathnames fname ".jpg"))
(with-open-file (f fname :direction :output)
(unix:write f (car r) (second r)))
fname))
;****************************************************************
;; jpeg-decompress and read-jpeg-file
;; return a color-image24 object.
;;
(defun jpeg-decompress (jpeg-image #| byte vector (string) |# )
;; returns a list of rgb-image, width, and height.
;; rgp-image might be supplied as the second argument to this function
(let ((width-return (integer-vector 0))
(height-return (integer-vector 0))
(components-return (integer-vector 0))
(image-return (integer-vector 0))
decomp-image-address decomp-image-string
total-size)
;; identify the jpeg output image size
(setq total-size
(jpeg_header jpeg-image (length jpeg-image)
width-return height-return components-return))
(if (zerop total-size)
(return-from jpeg-decompress nil))
;; allocate output image memory
(setq result-image (make-string total-size))
(jpeg_decompress jpeg-image (length jpeg-image)
result-image
width-return height-return)
;;
(setq width (aref width-return 0) height (aref height-return 0))
(instance img:color-image24 :init width height result-image)
) )
(defun read-jpeg-file (fname)
(setq fname (merge-pathnames fname ".jpg"))
(if (probe-file fname)
(let ((decomp-image (jpeg-decompress (read-binary-file fname))))
;; put the file name in the name attribute
(send decomp-image :name (namestring fname))
decomp-image)
nil)
)
(defun catalog-jpeg-files (&optional (dir "."))
(let ((xwins) (pictures) (pic) (xx))
(dolist (f (directory dir))
(setq pic (read-jpeg-file f))
(when pic
(setq xx (instance x:xwindow :create :width (send pic :width)
:height (send pic :height)))
(setq pic (send pic :to24))
(swap-rgb pic)
(send xx :putimage (pic . entity))
(push pic pictures)
(push xx xwins)) )
(list xwins pictures) )
)
(provide :jpeg "#(@)$Id: eusjpeg.l,v 1.1.1.1 2003/11/20 07:53:25 eus Exp $")
|
