gmane.lisp.mcclim.cvs

CVS mcclim

CVS User afuchs — 2011-07-28T03:56:49

Update of /project/mcclim/cvsroot/mcclim
In directory tiger.common-lisp.net:/tmp/cvs-serv3961

Modified Files:
clim-listener.asd 
Log Message:
Fix a misdeclared dependency in clim-listener.asd

asdf.lisp requires things from file-types.lisp.
Discovered by Zach Beane and Bart Botta.


--- /project/mcclim/cvsroot/mcclim/clim-listener.asd2009/06/07 08:48:001.6
+++ /project/mcclim/cvsroot/mcclim/clim-listener.asd2011/07/28 03:56:491.7
< at >< at > -16,7 +16,7 < at >< at >
                (:file "util" :depends-on ("package"))
                (:file "icons" :depends-on ("package" "util"))
                (:file "file-types" :depends-on ("package" "icons" "util"))
-               (:file "asdf" :depends-on ("package"))
+               (:file "asdf" :depends-on ("file-types"))
                (:file "dev-commands" 
                       :depends-on ("package" "appearance" "icons" "file-types" "util" "asdf"))
                (:file "wholine" :depends-on ("package" "dev-commands" "util"))

CVS mcclim/Experimental/freetype

ahefner — 2010-01-31T15:51:54

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype
In directory cl-net:/tmp/cvs-serv1616/freetype

Modified Files:
xrender-fonts.lisp 
Log Message:
Fall back to DejaVu instead of Vera, and fix serif italic filename.

It's not clear to me whether there used to be a serif oblique font which
has been superceded by the italic version, or whether the DejaVu filenames
have been broken since their inception and just were never fully tested.
Hopefully the latter.


--- /project/mcclim/cvsroot/mcclim/Experimental/freetype/xrender-fonts.lisp2009/06/14 18:37:391.2
+++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/xrender-fonts.lisp2010/01/31 15:51:531.3
< at >< at > -346,7 +346,7 < at >< at >
     ((:FIX (:ITALIC :BOLD)) . "DejaVuSansMono-BoldOblique.ttf") 
     ((:FIX :BOLD) . "DejaVuSansMono-Bold.ttf")
     ((:SERIF :ROMAN) . "DejaVuSerif.ttf") 
-    ((:SERIF :ITALIC) . "DejaVuSerif-Oblique.ttf")
+    ((:SERIF :ITALIC) . "DejaVuSerif-Italic.ttf")
     ((:SERIF (:BOLD :ITALIC)) . "DejaVuSerif-BoldOblique.ttf")
     ((:SERIF (:ITALIC :BOLD)) . "DejaVuSerif-BoldOblique.ttf") 
     ((:SERIF :BOLD) . "DejaVuSerif-Bold.ttf")
< at >< at > -356,7 +356,7 < at >< at >
     ((:SANS-SERIF (:ITALIC :BOLD)) . "DejaVuSans-BoldOblique.ttf")
     ((:SANS-SERIF :BOLD) . "DejaVuSans-Bold.ttf")))
 
-(defvar *families/faces* *vera-families/faces*)
+(defparameter *families/faces* *dejavu-families/faces*)
 
 (defparameter *truetype-font-path* #p"/usr/share/fonts/truetype/ttf-dejavu/")

CVS mcclim

rstrandh — 2009-12-16T13:15:39

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

Modified Files:
presentations.lisp 
Log Message:
Fixed a typo. 

Thanks to Stas Boukarev.


--- /project/mcclim/cvsroot/mcclim/presentations.lisp2008/02/01 17:02:551.85
+++ /project/mcclim/cvsroot/mcclim/presentations.lisp2009/12/16 13:15:381.86
< at >< at > -71,7 +71,7 < at >< at >
 `(flet ((,continuation ()
   ,< at >decls
   ,< at >with-body))
-   (declare (dynamic-extent #'continuation))
+   (declare (dynamic-extent #',continuation))
    (if (and (output-recording-stream-p ,stream)
     *allow-sensitive-inferiors*)
        (with-new-output-record

CVS mcclim/Examples

rstrandh — 2009-12-08T05:26:29

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

Modified Files:
font-selector.lisp 
Log Message:
Fixed the font-selector demo so that it doesn't crash.  The problem
was that when the family changes, it tries to initialize the face to
one with the same name as the selected one in the old family.  When
there is no such face in the new family, it got initialized to nil. 

However, the demo is still not working properly.  Sometimes a
displayed face becomes non-clickable, and sometimes two faces are
highlighted simultaneously.  



--- /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp2008/01/21 01:08:581.2
+++ /project/mcclim/cvsroot/mcclim/Examples/font-selector.lisp2009/12/08 05:26:291.3
< at >< at > -99,10 +99,11 < at >< at >
     (reset-list-pane face-list new-faces)
     (when old-face
       (setf (gadget-value face-list :invoke-callback t)
-    (find (font-face-name old-face)
-  new-faces
-  :key #'font-face-name
-  :test #'equal)))))
+    (or (find (font-face-name old-face)
+                      new-faces
+                      :key #'font-face-name
+                      :test #'equal)
+                (first new-faces))))))
 
 (defun face-changed (pane value)
   (declare (ignore pane))

CVS mcclim/Examples

rstrandh — 2009-12-07T14:04:39

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

Modified Files:
sliderdemo.lisp 
Log Message:
Fixed a bug that made this demo not work (thanks to "lhz" on #lisp).

Improved the code somewhat to avoid too much code duplication.  It
could be made better still.  On the other hand, this demo should
probably be redone or removed, since it involves the calculator as
well, which doesn't seem reasonable.



--- /project/mcclim/cvsroot/mcclim/Examples/sliderdemo.lisp2006/12/19 04:08:581.5
+++ /project/mcclim/cvsroot/mcclim/Examples/sliderdemo.lisp2009/12/07 14:04:391.6
< at >< at > -24,10 +24,7 < at >< at >
 (defparameter calc '(0))
 (defvar *text-field* nil)
 
-(defun slidertest ()
-  (loop for port in climi::*all-ports*
-      do (destroy-port port))
-  (setq climi::*all-ports* nil)
+(defun sliderdemo ()
   (let ((frame (make-application-frame 'sliderdemo)))
     (run-frame-top-level frame)))
 
< at >< at > -38,7 +35,8 < at >< at >
        (if (numberp last-item)
    (setf (car (last calc)) (+ (* 10 last-item) ,int))
    (setf calc (nconc calc (list ,int))))
-       (setf (gadget-value *text-field*) (princ-to-string (first (last calc)))))))
+       (setf (gadget-value *text-field*)
+             (princ-to-string (first (last calc)))))))
 
 (defmacro queue-operator (operator)
   `(lambda (gadget)
< at >< at > -76,100 +74,69 < at >< at >
 
 (defun find-text-field (frame)
   (first (member-if #'(lambda (gadget) (typep gadget 'text-field))
-    (frame-panes frame))))
+    (frame-current-panes frame))))
 
-(defmethod sliderdemo-frame-top-level ((frame application-frame)
-       &key (command-parser 'command-line-command-parser)
-       (command-unparser 'command-line-command-unparser)
-       (partial-command-parser
-'command-line-read-remaining-arguments-for-partial-command)
-       (prompt "Command: "))
+(defmethod sliderdemo-frame-top-level
+    ((frame application-frame)
+     &key (command-parser 'command-line-command-parser)
+     (command-unparser 'command-line-command-unparser)
+     (partial-command-parser
+      'command-line-read-remaining-arguments-for-partial-command)
+     (prompt "Command: "))
   (declare (ignore command-parser command-unparser partial-command-parser prompt))
   (setf *text-field* (find-text-field frame))
   (clim-extensions:simple-event-loop))
 
-(define-application-frame sliderdemo () ()
-  (:panes
-   (plus             :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "+"
-     :activate-callback (queue-operator #'+))
-   (dash             :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "-"
-     :activate-callback (queue-operator #'-))
-   (multiplicate     :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "*"
-     :activate-callback (queue-operator #'*))
-   (divide           :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "/"
-     :activate-callback (queue-operator #'round))
-   (result           :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "="
-     :activate-callback #'do-operation)
-   (one              :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "1"
-     :activate-callback (queue-number 1))
-   (two              :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "2"
-     :activate-callback (queue-number 2))
-   (three            :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "3"
-     :activate-callback (queue-number 3))
-   (four             :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "4"
-     :activate-callback (queue-number 4))
-   (five             :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "5"
-     :activate-callback (queue-number 5))
-   (six              :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "6"
-     :activate-callback (queue-number 6))
-   (seven            :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "7"
-     :activate-callback (queue-number 7))
-   (eight            :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "8"
-     :activate-callback (queue-number 8))
-   (nine             :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "9"
-     :activate-callback (queue-number 9))
-   (zero             :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "0"
-     :activate-callback (queue-number 0))
-  (screen            :text-field
-     :value "0"
-     :space-requirement (make-space-requirement :width 200 :height 50))
-  (ac                :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "AC"
-     :activate-callback #'initac)
-  (ce                :push-button
-     :space-requirement (make-space-requirement :width 50 :height 50)
-     :label "CE"
-     :activate-callback #'initce)
-  (slider            :slider
-     :value-changed-callback #'slide
-     :min-value 0
-     :max-value 100
-     :value 0
-     :normal +white+
-     :highlighted +cyan+
-     :pushed-and-highlighted +blue+))
+(eval-when (:compile-toplevel)
+  (defun make-operator-button-form (name label operator)
+    `(,name :push-button
+            :space-requirement (make-space-requirement
+                                :width 50 :height 50)
+            :label ,label
+            :activate-callback (queue-operator #',operator)))
+
+  (defun make-number-button-form (name label number)
+    `(,name :push-button
+            :space-requirement (make-space-requirement
+                                :width 50 :height 50)
+            :label ,label
+            :activate-callback (queue-number ,number))))
 
+(define-application-frame sliderdemo () ()
+  (:panes #.(make-operator-button-form 'plus "+" '+)
+          #.(make-operator-button-form 'dash "-" '-)
+          #.(make-operator-button-form 'multiply "*" '*)
+          #.(make-operator-button-form 'divide "/" 'round)
+          #.(make-operator-button-form 'result "=" 'do-operation)
+          #.(make-number-button-form 'one "1" 1)
+          #.(make-number-button-form 'two "2" 2)
+          #.(make-number-button-form 'three "3" 3)
+          #.(make-number-button-form 'four "4" 4)
+          #.(make-number-button-form 'five "5" 5)
+          #.(make-number-button-form 'six "6" 6)
+          #.(make-number-button-form 'seven "7" 7)
+          #.(make-number-button-form 'eight "8" 8)
+          #.(make-number-button-form 'nine "9" 9)
+          #.(make-number-button-form 'zero "0" 0)
+          (screen :text-field
+                  :value "0"
+                  :space-requirement (make-space-requirement :width 200 :height 50))
+          (ac     :push-button
+                  :space-requirement (make-space-requirement :width 50 :height 50)
+                  :label "AC"
+                  :activate-callback #'initac)
+          (ce     :push-button
+                  :space-requirement (make-space-requirement :width 50 :height 50)
+                  :label "CE"
+                  :activate-callback #'initce)
+          (slider :slider
+                  :value-changed-callback #'slide
+                  :min-value 0
+                  :max-value 100
+                  :value 0
+                  :normal +white+
+                  :highlighted +cyan+
+                  :pushed-and-highlighted +blue+))
   (:layouts
    (defaults (horizontally ()
         (vertically ()
< at >< at > -178,7 +145,7 < at >< at >
    (tabling ()
       (list one two plus)
       (list three four dash)
-      (list five six multiplicate)
+      (list five six multiply)
       (list seven eight divide)
       (list nine zero result)))
 slider)))

CVS mcclim/Examples

rstrandh — 2009-12-07T08:47:04

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

Modified Files:
traffic-lights.lisp 
Log Message:
Removed dead code.  Added my copyright.  Fixed some comments.


--- /project/mcclim/cvsroot/mcclim/Examples/traffic-lights.lisp2002/07/29 06:04:021.6
+++ /project/mcclim/cvsroot/mcclim/Examples/traffic-lights.lisp2009/12/07 08:47:041.7
< at >< at > -2,6 +2,8 < at >< at >
 
 ;;;  (c) copyright 2001 by
 ;;;           Julien Boninfante (boninfan-lSGHico1bM/5RUk1v0J4UFAUjnlXr6A1< at >public.gmane.org)
+;;;  (c) copyright 2009 by
+;;;           Robert Strandh (strandh-BktLLJ5BOkI< at >public.gmane.org)
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Library General Public
< at >< at > -29,26 +31,18 < at >< at >
 
 (in-package :clim-internals)
 
-;; example gadget definition
+;;; example gadget definition
 (defclass light-pane (standard-gadget) ())
 
-#+nil
-(defmethod dispatch-repaint ((pane light-pane) region)
-  (repaint-sheet pane region))
-
 (defmethod handle-repaint ((pane light-pane) region)
   (declare (ignore region))
   (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region pane))
-    (display-gadget-background pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1))))
-
-#+nil
-(defmethod handle-event ((pane light-pane) (event window-repaint-event))
-  (declare (ignorable event))
-  (dispatch-repaint pane (sheet-region pane)))
+    (display-gadget-background
+     pane (gadget-current-color pane) 0 0 (- x2 x1) (- y2 y1))))
 
 (in-package :clim-demo)
 
-;; callback functions
+;;; callback functions
 
 (defmethod handle-event :after ((pane clim-internals::light-pane) (event pointer-event))
   (declare (ignorable event))
< at >< at > -95,7 +89,7 < at >< at >
     (setf (clim-internals::gadget-current-color (slot-value *application-frame* 'light))
   (clim-internals::gadget-pushed-and-highlighted-color (slot-value *application-frame* 'light)))))
 
-;; test functions
+;;; test functions
 
 (defun traffic-lights ()
   (loop for port in climi::*all-ports*

CVS mcclim/Examples

rstrandh — 2009-12-07T08:41:37

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

Removed Files:
fire.lisp 
Log Message:
This file was old, and has been replaced by traffic-lights.lisp.

CVS mcclim/Backends/CLX

ahefner — 2009-11-15T11:27:27

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory cl-net:/tmp/cvs-serv4276

Modified Files:
medium.lisp 
Log Message:
Faster IMAGE-TO-XIMAGE translator, courtesy of Nikodemus Siivola.


--- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp2009/04/20 10:21:001.90
+++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp2009/11/15 11:27:261.91
< at >< at > -1311,24 +1311,36 < at >< at >
     (let ((l (integer-length (logxor mask (1- (ash 1 h))))))
       (byte (- h l) l))))
 
+
 ;; fixme!  This is not just incomplete, but also incorrect: The original
 ;; true color code knew how to deal with non-linear RGB value
 ;; allocation.
+
+(defvar *translator-cache-lock* (clim-sys:make-lock "translator cache lock"))
+(defvar *translator-cache* (make-hash-table :test #'equal))
+
 (defun pixel-translator (colormap)
   (unless (eq (xlib:visual-info-class (xlib:colormap-visual-info colormap))
       :true-color)
     (error "sorry, cannot draw rgb image for non-true-color drawable yet"))
-  colormap
   (let* ((info (xlib:colormap-visual-info colormap))
  (rbyte (mask->byte (xlib:visual-info-red-mask info)))
  (gbyte (mask->byte (xlib:visual-info-green-mask info)))
- (bbyte (mask->byte (xlib:visual-info-blue-mask info))))
-    (lambda (x y sample)
-      (declare (ignore x y))
-      (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample))
-   rbyte
-   (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample))
-gbyte
-(dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample))
-     bbyte
-     0))))))
+ (bbyte (mask->byte (xlib:visual-info-blue-mask info)))
+         (key (list rbyte gbyte bbyte)))
+    (clim-sys:with-lock-held (*translator-cache-lock*)
+      (or (gethash key *translator-cache*)
+          ;; COMPILE instead of a closure, because out-of-line byte specifiers
+          ;; are universally slow. Getting them inline like this is *much*
+          ;; faster.
+          (setf (gethash key *translator-cache*)
+                (compile nil
+                         `(lambda (x y sample)
+                            (declare (ignore x y))
+                            (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample))
+                                 ',rbyte
+                                 (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample))
+                                      ',gbyte
+                                      (dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample))
+                                           ',bbyte
+                                           0))))))))))

CVS mcclim

ahefner — 2009-10-29T14:05:05

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

Modified Files:
gadgets.lisp 
Log Message:
Fix dynamic extent declarations in with-output-as-gadget.


--- /project/mcclim/cvsroot/mcclim/gadgets.lisp2008/11/09 19:49:171.112
+++ /project/mcclim/cvsroot/mcclim/gadgets.lisp2009/10/29 14:05:041.113
< at >< at > -2678,8 +2678,8 < at >< at >
       (gadget-output-record-constructor ()
 (make-instance 'gadget-output-record
        ,< at >options :x ,x :y ,y)))
- (declare (dynamic-extent with-output-as-gadget-continuation
-  gadget-output-record-constructor))
+ (declare (dynamic-extent #'with-output-as-gadget-continuation
+  #'gadget-output-record-constructor))
  (let ((,gadget-output-record
 (invoke-with-output-to-output-record
  ,stream

CVS mcclim

rstrandh — 2009-10-16T04:57:00

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

Modified Files:
dialog.lisp 
Log Message:
Fixed problem with Cancel button in accepting-values.

Thanks to Kilian Sprotte for the patch. 



--- /project/mcclim/cvsroot/mcclim/dialog.lisp2009/08/01 22:17:021.32
+++ /project/mcclim/cvsroot/mcclim/dialog.lisp2009/10/16 04:57:001.33
< at >< at > -271,12 +271,11 < at >< at >
               (format stream "OK"))))
         (formatting-cell (stream)
           (with-output-as-presentation
-              (stream nil 'abort-button) (with-output-as-presentation
-              (stream nil 'exit-button)
+              (stream nil 'abort-button)
             (surrounding-output-with-border
-                (stream :shape :rounded :radius 6
-                        :background +gray80+ :highlight-background +gray90+)
-              (format stream "Cancel")))))))
+     (stream :shape :rounded :radius 6
+     :background +gray80+ :highlight-background +gray90+)
+     (format stream "Cancel"))))))
     (terpri stream)))
 
 (defmethod stream-accept ((stream accepting-values-stream) type

CVS mcclim/Backends/gtkairo

rstrandh — 2009-09-02T05:29:01

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.lisp2007/07/11 15:26:201.4
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo.lisp2009/09/02 05:29:011.5
< at >< at > -534,6 +534,103 < at >< at >
     (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 "~< at ><Drawing of images with alpha component is not supported.~:< at >>"))
+        (setf (slot-value design 'climi::medium-data) (list surface buffer mask))))
+    (when mask
+      (error "~< at ><A mask in your image design.~:< at >>"))
+    (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.lisp2007/03/03 12:09:511.18
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp2009/09/02 05:29:011.19
< at >< at > -333,6 +333,12 < at >< at >
   (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 *
< at >< at > -643,6 +649,14 < at >< at >
   (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 *

CVS mcclim/Extensions/Bitmap-formats

rstrandh — 2009-09-02T05:20:40

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.lisp2009/09/02 05:20:40NONE
+++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/png.lisp2009/09/02 05:20:401.1
;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*-

;;;  (c) copyright 2009 by
;;;           Samium Gromoff (_deepfire-NeA5vRaJqP8ol7YZXgNtG4dd74u8MsAO< at >public.gmane.org)

;;; 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 "~< at ><PNG-encoded images with bit depth ~D are not supported. The only supported bit depths are 8 and 32.~:< at >>" 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))

CVS mcclim

rstrandh — 2009-09-02T05:20:40

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.asd2009/09/02 05:20:40NONE
+++ /project/mcclim/cvsroot/mcclim/mcclim-png-bitmaps.asd2009/09/02 05:20:401.1
;;; -*- Mode: Lisp -*-

;;;  (c) copyright 2009 by 
;;;           Samium Gromoff (_deepfire-NeA5vRaJqP8ol7YZXgNtG4dd74u8MsAO< at >public.gmane.org)
;;;
;;; 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")))