From _deepfire at feelingofgreen.ru  Tue Sep  1 00:49:39 2009
From: _deepfire at feelingofgreen.ru (Samium Gromoff)
Date: Tue, 01 Sep 2009 04:49:39 +0400 (MSD)
Subject: [mcclim-devel] how to subclass a pane in good style?
Message-ID: <20090901.044939.285224927943268054._deepfire@feelingofgreen.ru>


Good day folks,

the included patch (also available via git[1]) adds a bridge
to PNG-READ by Jakub Higersberger, adding pure CL PNG support to McCLIM.

diff --git a/Extensions/Bitmap-formats/png.lisp b/Extensions/Bitmap-formats/png.lisp
new file mode 100644
index 0000000..3c75b13
--- /dev/null
+++ b/Extensions/Bitmap-formats/png.lisp
@@ -0,0 +1,44 @@
+;;; -*- 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))
diff --git a/mcclim-png-bitmaps.asd b/mcclim-png-bitmaps.asd
new file mode 100644
index 0000000..0a63f70
--- /dev/null
+++ b/mcclim-png-bitmaps.asd
@@ -0,0 +1,24 @@
+;;; -*- 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")))


regards,
  Samium Gromoff
--
1. git://git.feelingofgreen.ru/mcclim, branch 'png-bitmaps'


                                 _deepfire-at-feelingofgreen.ru
O< ascii ribbon campaign - stop html mail - www.asciiribbon.org
 



From _deepfire at feelingofgreen.ru  Tue Sep  1 00:58:50 2009
From: _deepfire at feelingofgreen.ru (Samium Gromoff)
Date: Tue, 01 Sep 2009 04:58:50 +0400 (MSD)
Subject: [mcclim-devel] PNG read support for McCLIM.
Message-ID: <20090901.045850.290331435832568093._deepfire@feelingofgreen.ru>


Good day folks,

the included patch (also available via git[1]) adds a bridge
to PNG-READ[2] by Jakub Higersberger, adding pure CL PNG support to McCLIM.


diff --git a/Extensions/Bitmap-formats/png.lisp b/Extensions/Bitmap-formats/png.lisp
new file mode 100644
index 0000000..3c75b13
--- /dev/null
+++ b/Extensions/Bitmap-formats/png.lisp
@@ -0,0 +1,44 @@
+;;; -*- 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))
diff --git a/mcclim-png-bitmaps.asd b/mcclim-png-bitmaps.asd
new file mode 100644
index 0000000..0a63f70
--- /dev/null
+++ b/mcclim-png-bitmaps.asd
@@ -0,0 +1,24 @@
+;;; -*- 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")))


regards,
  Samium Gromoff
--
1. git://git.feelingofgreen.ru/mcclim, branch 'png-bitmaps'
2. git://github.com/Ramarren/png-read.git

                                 _deepfire-at-feelingofgreen.ru
O< ascii ribbon campaign - stop html mail - www.asciiribbon.org



From _deepfire at feelingofgreen.ru  Wed Sep  2 04:20:12 2009
From: _deepfire at feelingofgreen.ru (Samium Gromoff)
Date: Wed, 02 Sep 2009 08:20:12 +0400 (MSD)
Subject: [mcclim-devel] A stab at MEDIUM-DRAW-IMAGE-DESIGN* implementation
	for gtkairo
Message-ID: <20090902.082012.288557565252589126._deepfire@feelingofgreen.ru>


Dear list,

the included patch (also available in git[1]) provides an initial
attempt at implementation of image design drawing for gtkairo.

It's lacking masking support, as well as might leak memory
(I'm not sure why cairo doesn't let me to destroy the surface
I myself has created, for instance), so any comments would be
very appreciated.

diff --git a/Backends/gtkairo/cairo.lisp b/Backends/gtkairo/cairo.lisp
index 1db8406..0600912 100644
--- a/Backends/gtkairo/cairo.lisp
+++ b/Backends/gtkairo/cairo.lisp
@@ -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)
diff --git a/Backends/gtkairo/ffi.lisp b/Backends/gtkairo/ffi.lisp
index 1fb7207..993e6ab 100644
--- a/Backends/gtkairo/ffi.lisp
+++ b/Backends/gtkairo/ffi.lisp
@@ -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 *



regards,
  Samium Gromoff
--
1. git://git.feelingofgreen.ru/mcclim, the 'gtkairo-mdid' branch


                                 _deepfire-at-feelingofgreen.ru
O< ascii ribbon campaign - stop html mail - www.asciiribbon.org