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.1 2004-12-28 20:26:01 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 null))
  30
  31 (defbinding %pixbuf-new-from-file-at-size () (referenced pixbuf)
  32   (filename pathname)
  33   (width int)
  34   (height int)
  35   (nil null))
  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 null))
  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   (cond
  51    (size
  52     #-gtk2.6(%pixbuf-new-from-file-at-size filename size size)
  53     #+gtk2.6(%pixbuf-new-from-file-at-scale filename size size preserve-aspect-ratio))
  54    ((and width height)
  55     #-gtk2.6(%pixbuf-new-from-file-at-size filename width height)
  56     #+gtk2.6(%pixbuf-new-from-file-at-scale filename width height preserve-aspect-ratio))
  57    ((or width height)
  58     (error "Both :width and :height must be specified"))
  59    ((%pixbuf-new-from-file filename))))
  60
  61
  62 ;; (defbinding pixbuf-get-file-info () (copy-of pixbuf-format)
  63 ;;   (filename pathname)
  64 ;;   (width int :out)
  65 ;;   (height int :out))
  66
  67 (defbinding %pixbuf-savev () boolean
  68   (pixbuf pixbuf)
  69   (filename pathname)
  70   (type string)
  71   (keys (vector (or null string)))
  72   (values (vector (or null string)))
  73   (nil null))
  74
  75 (defun pixbuf-save (pixbuf filename type &rest options)
  76   (let ((keys (make-array 0 :adjustable t :fill-pointer t))
  77         (values (make-array 0 :adjustable t :fill-pointer t)))
  78     (loop
  79      as (key value . rest) = options then rest
  80      do (vector-push-extend (string-downcase key) keys)
  81         (vector-push-extend
  82          (etypecase value
  83            (string value)
  84            (symbol (string-downcase value))
  85            (number (format nil "~A" value)))
  86          values))
  87     (vector-push-extend nil keys)
  88     (vector-push-extend nil values)
  89     (%pixbuf-savev pixbuf filename type keys values)))
  90
  91 (defbinding pixbuf-new-from-xpm-data () (referenced pixbuf)
  92   (data (vector string)))
  93
  94 (defbinding %pixbuf-new-subpixbuf () pixbuf ;; or (referenced pixbuf)?
  95   (pixbuf pixbuf)
  96   (x int) (y int) (width int) (height int))
  97
  98 (defbinding %pixbuf-copy () (referenced pixbuf)
  99   (pixbuf pixbuf))
 100
 101 (defun copy-pixbuf (pixbuf &optional x y width height)
 102   (if (and (not x) (not y) (not width) (not height))
 103       (%pixbuf-copy pixbuf)
 104     (%pixbuf-new-subpixbuf pixbuf x y width height)))
 105
 106
 107 ;;; Utilities
 108
 109 (defbinding pixbuf-add-alpha
 110     (pixbuf &optional substitute-color (red 255) (green 255) (blue 255))
 111     (referenced pixbuf)
 112   (pixbuf pixbuf)
 113   (substitute-color boolean)
 114   (red (unsigned 8))
 115   (green (unsigned 8))
 116   (blue (unsigned 8)))