[closure-cvs] CVS closure/src/imagelib - closure-cvs@common-lisp.net - mailman3.common-lisp.net

3 Jan 2007


      Update of /project/closure/cvsroot/closure/src/imagelib
In directory clnet:/tmp/cvs-serv3503
Added Files:
    gif.lisp jpeg.lisp 
Log Message:
New files for the "organic" GIF support.
--- /project/closure/cvsroot/closure/src/imagelib/gif.lisp	2007/01/03 16:09:13	NONE
+++ /project/closure/cvsroot/closure/src/imagelib/gif.lisp	2007/01/03 16:09:13	1.1
;;; gif.lisp --- render GIF files in Closure
;;;
;;; Author: Eric Marsden eric.marsden@free.fr
;;
;;
;; Read GIF files using the Skippy library
;; (http://www.xach.com/lisp/skippy/) and convert them to Closure's
;; internal AIMAGE format.
(in-package :imagelib)
(defgeneric flexi-stream-from (thing))
(defmethod flexi-stream-from ((thing cl:pathname))
  (let ((data (make-array 1024 :element-type '(unsigned-byte 8)
                          :fill-pointer 0
                          :adjustable t)))
    (with-open-file (in thing :direction :input
                        :element-type '(unsigned-byte 8))
      (loop :for b = (read-byte in nil nil)
            :while b
            :do (vector-push-extend b data)))
    (flexi-streams:make-in-memory-input-stream data)))
(defmethod flexi-stream-from ((gstream glisp:gstream))
  (let ((data (make-array 1024 :element-type '(unsigned-byte 8)
                          :fill-pointer 0
                          :adjustable t)))
    (loop :for b = (g/read-byte gstream nil nil)
          :while b
          :do (vector-push-extend b data))
    (g/close gstream)
    (flexi-streams:make-in-memory-input-stream data)))
(defmethod flexi-stream-from ((stream flexi-streams:flexi-stream))
  stream)
(defmethod flexi-stream-from ((stream flexi-streams:in-memory-stream))
  stream)
(defun gif-stream->aimage (stream)
  (let* ((data-stream (skippy:read-data-stream (flexi-stream-from stream)))
         (image (skippy:last-image data-stream))
         (gif-color-table (skippy:color-table data-stream))
         (aimage (make-aimage (skippy:width image)
                              (skippy:height image) :alpha-p nil))
         (aimage-data (aimage-data aimage)))
    (dotimes (x (skippy:width image))
      (dotimes (y (skippy:height image))
        (multiple-value-bind (r g b)
            (skippy:color-rgb
             (skippy:color-table-entry gif-color-table (skippy:pixel-ref image x y)))
          (setf (aref aimage-data y x)
                (dpb r (byte 8 0)
                     (dpb g (byte 8 8)
                          (dpb b (byte 8 16)
                               (dpb (- 255 0) (byte 8 24) 0))))))))
    aimage))
;; this is the historical version of GIF-STREAM->AIMAGE, that calls
;; the external program gif2png
(defun gif-stream->aimage/gif2png (input)
  (with-temporary-file (temp-filename)
    (let ((png-filename (merge-pathnames (make-pathname :type "png")
                                         temp-filename)))
      (with-open-file (sink temp-filename
                       :direction :output
                       :if-exists :overwrite
                       :element-type '(unsigned-byte 8))
        (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink)))
          (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8))))
            (do ((n (g/read-byte-sequence tmp input)
    	    (g/read-byte-sequence tmp input)))
                ((= n 0))
              (g/write-byte-sequence tmp sink :end n)))))
      (unwind-protect
          (progn
            (run-unix-shell-command
             (format nil "gif2png -r ~A >/dev/null 2>/dev/null"
                     (namestring (truename temp-filename))))
            (with-open-file (input png-filename
                             :direction :input
                             :element-type '(unsigned-byte 8))
              (let ((i (make-instance 'cl-byte-stream :cl-stream input)))
                (png:png-stream->aimage i))))
        (ignore-errors
         (mapc #'(lambda (x) (ignore-errors (delete-file x)))
               (directory (merge-pathnames (make-pathname :type :wild)
                                           temp-filename)))) ))))
;; EOF
--- /project/closure/cvsroot/closure/src/imagelib/jpeg.lisp	2007/01/03 16:09:13	NONE
+++ /project/closure/cvsroot/closure/src/imagelib/jpeg.lisp	2007/01/03 16:09:13	1.1
;;; jpeg.lisp -- render JPEG files in Closure
;;;
;;; Author: Eric Marsden eric.marsden@free.fr
;;
;;
;; This will soon be replaced by an implementation based on cl-jpeg.
(in-package :imagelib)
(defun jpeg-stream->aimage (input)
  (any->aimage-by-filter "djpeg" input))
;; EOF