chiark - git - mdw - clg/blob - gdk/pixbuf.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2004 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: pixbuf.lisp,v 1.2 2005-02-14 00:46:31 espen Exp $
  19
  20
  21 (in-package "GDK")
  22
  23 (defbinding pixbuf-get-option () (copy-of string)
  24   (pixbuf pixbuf)
  25   (key string))
  26
  27 (defbinding %pixbuf-new-from-file () (referenced pixbuf)
  28   (filename pathname)
  29   (nil gerror :out))
  30
  31 (defbinding %pixbuf-new-from-file-at-size () (referenced pixbuf)
  32   (filename pathname)
  33   (width int)
  34   (height int)
  35   (nil gerror :out))
  36
  37 #+gtk2.6
  38 (defbinding %pixbuf-new-from-file-at-scale () (referenced pixbuf)
  39   (filename pathname)
  40   (width int)
  41   (height int)
  42   (preserve-aspect-ratio boolean)
  43   (nil gerror :out))
  44
  45 (defun pixbuf-load (filename &key width height size (preserve-aspect-ratio t))
  46   #-gtk2.6
  47   (unless preserve-aspect-ratio
  48     (warn ":preserve-aspect-ratio not supported with this version of Gtk"))
  49
  50   (multiple-value-bind (pixbuf gerror)
  51       (cond
  52        (size
  53         #-gtk2.6(%pixbuf-new-from-file-at-size filename size size)
  54         #+gtk2.6(%pixbuf-new-from-file-at-scale filename size size preserve-aspect-ratio))
  55        ((and width height)
  56         #-gtk2.6(%pixbuf-new-from-file-at-size filename width height)
  57         #+gtk2.6(%pixbuf-new-from-file-at-scale filename width height preserve-aspect-ratio))
  58        ((or width height)
  59         (error "Both :width and :height must be specified"))
  60        (t (%pixbuf-new-from-file filename)))
  61     (if gerror
  62         (signal-gerror gerror)
  63       pixbuf)))
  64
  65
  66 ;; (defbinding pixbuf-get-file-info () (copy-of pixbuf-format)
  67 ;;   (filename pathname)
  68 ;;   (width int :out)
  69 ;;   (height int :out))
  70
  71 (defbinding %pixbuf-savev () boolean
  72   (pixbuf pixbuf)
  73   (filename pathname)
  74   (type string)
  75   (keys strings)
  76   (values string)
  77   (nil gerror :out))
  78
  79 (defun pixbuf-save (pixbuf filename type &rest options)
  80   (let ((keys (make-array 0 :adjustable t :fill-pointer t))
  81         (values (make-array 0 :adjustable t :fill-pointer t)))
  82     (loop
  83      as (key value . rest) = options then rest
  84      do (vector-push-extend (string-downcase key) keys)
  85         (vector-push-extend
  86          (etypecase value
  87            (string value)
  88            (symbol (string-downcase value))
  89            (number (format nil "~A" value)))
  90          values))
  91     (multiple-value-bind (ok-p gerror)
  92         (%pixbuf-savev pixbuf filename type keys values)
  93       (unless ok-p
  94         (signal-gerror gerror)))))
  95
  96 (defbinding pixbuf-new-from-xpm-data () (referenced pixbuf)
  97   (data (vector string)))
  98
  99 (defbinding %pixbuf-new-subpixbuf () pixbuf ;; or (referenced pixbuf)?
 100   (pixbuf pixbuf)
 101   (x int) (y int) (width int) (height int))
 102
 103 (defbinding %pixbuf-copy () (referenced pixbuf)
 104   (pixbuf pixbuf))
 105
 106 (defun copy-pixbuf (pixbuf &optional x y width height)
 107   (if (and (not x) (not y) (not width) (not height))
 108       (%pixbuf-copy pixbuf)
 109     (%pixbuf-new-subpixbuf pixbuf x y width height)))
 110
 111
 112 ;;; Utilities
 113
 114 (defbinding pixbuf-add-alpha
 115     (pixbuf &optional substitute-color (red 255) (green 255) (blue 255))
 116     (referenced pixbuf)
 117   (pixbuf pixbuf)
 118   (substitute-color boolean)
 119   (red (unsigned 8))
 120   (green (unsigned 8))
 121   (blue (unsigned 8)))