From rstrandh at common-lisp.net  Wed Sep  2 05:20:40 2009
From: rstrandh at common-lisp.net (rstrandh)
Date: Wed, 02 Sep 2009 01:20:40 -0400
Subject: [mcclim-cvs] CVS mcclim
Message-ID: <E1MiiGu-0004kl-7h@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim
In directory cl-net:/tmp/cvs-serv15355

Added Files:
	mcclim-png-bitmaps.asd 
Log Message:
Added support for reading PNG files contributed by Samium Gromoff.  Thanks! 




--- /project/mcclim/cvsroot/mcclim/mcclim-png-bitmaps.asd	2009/09/02 05:20:40	NONE
+++ /project/mcclim/cvsroot/mcclim/mcclim-png-bitmaps.asd	2009/09/02 05:20:40	1.1
;;; -*- Mode: Lisp -*-

;;;  (c) copyright 2009 by 
;;;           Samium Gromoff (_deepfire at feelingofgreen.ru)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(asdf:defsystem :mcclim-png-bitmaps
  :description "Support for PNG images in McCLIM bitmap reading functions."
  :depends-on (:mcclim :png-read)
  :components ((:file "png" :pathname #P"Extensions/Bitmap-formats/png")))



From rstrandh at common-lisp.net  Wed Sep  2 05:20:40 2009
From: rstrandh at common-lisp.net (rstrandh)
Date: Wed, 02 Sep 2009 01:20:40 -0400
Subject: [mcclim-cvs] CVS mcclim/Extensions/Bitmap-formats
Message-ID: <E1MiiGu-0004kt-AS@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats
In directory cl-net:/tmp/cvs-serv15355/Extensions/Bitmap-formats

Added Files:
	png.lisp 
Log Message:
Added support for reading PNG files contributed by Samium Gromoff.  Thanks! 




--- /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/png.lisp	2009/09/02 05:20:40	NONE
+++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/png.lisp	2009/09/02 05:20:40	1.1
;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*-

;;;  (c) copyright 2009 by
;;;           Samium Gromoff (_deepfire at feelingofgreen.ru)

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

(in-package :clim-internals)

(define-bitmap-file-reader :png (image-pathname)
  (let* ((png-state (png-read:read-png-file image-pathname))
         (data (png-read:image-data png-state))
         (depth (png-read:bit-depth png-state))
         (height (png-read:height png-state))
         (width (png-read:width png-state))
         (array (make-array (list height width) :element-type '(unsigned-byte 32))))
    (unless (member depth '(8 32))
      (error "~@<PNG-encoded images with bit depth ~D are not supported. The only supported bit depths are 8 and 32.~:@>" depth))
    (dotimes (y height)
      (dotimes (x width)
        (case depth
          ((8 32)
           (let ((red (aref data x y 0))
                 (green (aref data x y 1))
                 (blue (aref data x y 2)))
             (setf (aref array y x)
                   (dpb red (byte 8 0)
                        (dpb green (byte 8 8)
                             (dpb blue (byte 8 16)
                                  (dpb (- 255 0) (byte 8 24) 0))))))))))
    array))



From rstrandh at common-lisp.net  Wed Sep  2 05:29:01 2009
From: rstrandh at common-lisp.net (rstrandh)
Date: Wed, 02 Sep 2009 01:29:01 -0400
Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo
Message-ID: <E1MiiOz-0005iZ-Vo@common-lisp.net>

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory cl-net:/tmp/cvs-serv21922

Modified Files:
	cairo.lisp ffi.lisp 
Log Message:
Added support for image design drawing in the gtkairo backend. 
Thanks to Samium Gromoff for contributing this patch.



--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp	2007/07/11 15:26:20	1.4
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp	2009/09/02 05:29:01	1.5
@@ -534,6 +534,103 @@
 	    (cairo_move_to cr (df x) (df (+ y y2))))
 	  (pango_cairo_show_layout cr layout))))))
 
+;; Stolen from the CLX backend.
+(defmethod climi::medium-draw-image-design*
+    ((medium cairo-medium) (design climi::rgb-image-design) x y)
+  (destructuring-bind (&optional surface buffer mask)
+      (slot-value design 'climi::medium-data)
+    (unless surface
+      (let* ((image (slot-value design 'climi::image)))
+        (setf (values surface buffer) (image-to-cairosurface image))
+        (when (climi::image-alpha-p image)
+          (error "~@<Drawing of images with alpha component is not supported.~:@>"))
+        (setf (slot-value design 'climi::medium-data) (list surface buffer mask))))
+    (when mask
+      (error "~@<A mask in your image design.~:@>"))
+    (with-medium (medium)
+      (multiple-value-bind (x y)
+          (transform-position
+           (sheet-device-transformation (medium-sheet medium))
+           x y)
+        (setf x (float x 0d0))
+        (setf y (float y 0d0))
+        (with-slots (cr) medium
+          (cairo_set_source_surface cr surface x y)
+          (cond
+            #+ (or)
+            (mask
+             (xlib:with-gcontext (gcontext 
+                                  :clip-mask mask
+                                  :clip-x x
+                                  :clip-y y)
+               (xlib:copy-area pixmap gcontext 0 0 width height
+                               da x y)))
+            (t
+             (cairo_paint cr))))))))
+
+(defmethod climi::medium-free-image-design
+    ((medium cairo-medium) (design climi::rgb-image-design))
+  (destructuring-bind (&optional surface buffer mask)
+      (slot-value design 'climi::medium-data)
+    (when surface
+      #+ (or)
+      ;; This one bites, no idea why.
+      (cairo_destroy surface)
+      (cffi:foreign-free buffer)
+      (setf (slot-value design 'climi::medium-data) nil))))
+
+;; Was: CLX/compute-rgb-image-mask
+#+ (or)
+(defun compute-rgb-image-mask (drawable image)
+  (let* ((width (climi::image-width image))
+         (height (climi::image-height image))
+         (bitmap (xlib:create-pixmap :drawable drawable
+                                     :width width 
+                                     :height height
+                                     :depth 1))
+         (gc (xlib:create-gcontext :drawable bitmap
+				   :foreground 1
+				   :background 0))
+         (idata (climi::image-data image))
+         (xdata (make-array (list height width)
+			    :element-type '(unsigned-byte 1)))
+         (im (xlib:create-image :width width
+                                :height height
+                                :depth 1
+                                :data xdata)) )
+    (dotimes (y width)
+      (dotimes (x height)
+        (if (> (aref idata x y) #x80000000)
+            (setf (aref xdata x y) 0)
+	    (setf (aref xdata x y) 1))))
+    (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here
+      (xlib:put-image bitmap gc im :src-x 0 :src-y 0
+		      :x 0 :y 0 :width width :height height
+		      :bitmap-p nil))
+    (xlib:free-gcontext gc)
+    bitmap))
+
+;; Was: CLX/image-to-ximage
+(defun image-to-cairosurface (image)
+  (let* ((width (climi::image-width image))
+         (height (climi::image-height image))
+         (idata (climi::image-data image))
+         (stride (cairo_format_stride_for_width :rgb24 width))
+         (cairodata (cffi:foreign-alloc :uint8 :count (* stride height))))
+    (declare (type (simple-array (unsigned-byte 32) (* *)) idata))
+    (loop :for row-offset :from 0 :by stride
+       :for y :from 0 :below height
+       :do (loop :for offset :from row-offset :by 4
+              :for x :from 0 :below width
+              :do (let ((px (aref idata y x)))
+                    (setf (cffi:mem-ref cairodata :uint32 offset)
+                          (dpb (ldb (byte 8 0) px) (byte 8 16)
+                               (dpb (ldb (byte 8 8) px) (byte 8 8)
+                                    (dpb (ldb (byte 8 16) px) (byte 8 0)
+                                         0)))))))
+    (values (cairo_image_surface_create_for_data cairodata :rgb24 width height stride)
+            cairodata)))
+
 (defmethod medium-finish-output ((medium cairo-medium))
   (with-medium (medium)
     (when (cr medium)
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp	2007/03/03 12:09:51	1.18
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp	2009/09/02 05:29:01	1.19
@@ -333,6 +333,12 @@
   (arg0 :pointer)                       ;cairo_font_face_t *
   )
 
+(defcfun "cairo_format_stride_for_width"
+    :int
+  (arg0 cairo_format_t)
+  (arg1 :int)
+  )
+
 (defcfun "cairo_get_font_face"
     :pointer
   (arg0 :pointer)                       ;cairo_t *
@@ -643,6 +649,14 @@
   (arg4 :double)                        ;double
   )
 
+(defcfun "cairo_set_source_surface"
+    :void
+  (arg0 :pointer)                       ;cairo_t *
+  (arg1 :pointer)                       ;cairo_surface_t *
+  (arg2 :double)
+  (arg3 :double)
+  )
+
 (defcfun "cairo_set_tolerance"
     :void
   (arg0 :pointer)                       ;cairo_t *