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
|
;;;; 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))
(eval-when (load eval)
(let ((m
(load-foreign
(find-if #'probe-file
(list (format nil "~A/~A/lib/jpegmemcd.so" *eusdir*
(cond ((member :solaris2 *features*) "SunOS5")
((member :irix *features*) "IRIX")
((member :irix6 *features*) "IRIX6")
((member :darwin *features*) "Darwin")
((member :sh4 *features*) "LinuxSH4")
((member :linux *features*)
(cond
((member :x86_64 *features*)
"Linux64")
((member :arm *features*)
"LinuxARM")
(t "Linux")))
((member :SunOS4.1 *features*) "SunOS4")
((member :Windows *features*) "Windows")
((member :Windows95 *features*) "Win95")
((member :WindowsNT *features*) "WinNT")
((member :alpha *features*) "Alpha")
((member :cygwin *features*) "Cygwin")))
(format nil "/usr/lib/~A/euslisp/jpegmemcd.so" lisp::*deb-host-multiarch*))))))
(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) |# )
;; jpeg-image is a raw jpeg binary 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 width height result-image)
;; 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$")
|
