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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: pixbuf.lisp,v 1.3 2005-04-23 16:48:50 espen Exp $
  24
  25
  26 (in-package "GDK")
  27
  28 (defbinding pixbuf-get-option () (copy-of string)
  29   (pixbuf pixbuf)
  30   (key string))
  31
  32 (defbinding %pixbuf-new-from-file () (referenced pixbuf)
  33   (filename pathname)
  34   (nil gerror :out))
  35
  36 (defbinding %pixbuf-new-from-file-at-size () (referenced pixbuf)
  37   (filename pathname)
  38   (width int)
  39   (height int)
  40   (nil gerror :out))
  41
  42 #+gtk2.6
  43 (defbinding %pixbuf-new-from-file-at-scale () (referenced pixbuf)
  44   (filename pathname)
  45   (width int)
  46   (height int)
  47   (preserve-aspect-ratio boolean)
  48   (nil gerror :out))
  49
  50 (defun pixbuf-load (filename &key width height size (preserve-aspect-ratio t))
  51   #-gtk2.6
  52   (unless preserve-aspect-ratio
  53     (warn ":preserve-aspect-ratio not supported with this version of Gtk"))
  54
  55   (multiple-value-bind (pixbuf gerror)
  56       (cond
  57        (size
  58         #-gtk2.6(%pixbuf-new-from-file-at-size filename size size)
  59         #+gtk2.6(%pixbuf-new-from-file-at-scale filename size size preserve-aspect-ratio))
  60        ((and width height)
  61         #-gtk2.6(%pixbuf-new-from-file-at-size filename width height)
  62         #+gtk2.6(%pixbuf-new-from-file-at-scale filename width height preserve-aspect-ratio))
  63        ((or width height)
  64         (error "Both :width and :height must be specified"))
  65        (t (%pixbuf-new-from-file filename)))
  66     (if gerror
  67         (signal-gerror gerror)
  68       pixbuf)))
  69
  70
  71 ;; (defbinding pixbuf-get-file-info () (copy-of pixbuf-format)
  72 ;;   (filename pathname)
  73 ;;   (width int :out)
  74 ;;   (height int :out))
  75
  76 (defbinding %pixbuf-savev () boolean
  77   (pixbuf pixbuf)
  78   (filename pathname)
  79   (type string)
  80   (keys strings)
  81   (values string)
  82   (nil gerror :out))
  83
  84 (defun pixbuf-save (pixbuf filename type &rest options)
  85   (let ((keys (make-array 0 :adjustable t :fill-pointer t))
  86         (values (make-array 0 :adjustable t :fill-pointer t)))
  87     (loop
  88      as (key value . rest) = options then rest
  89      do (vector-push-extend (string-downcase key) keys)
  90         (vector-push-extend
  91          (etypecase value
  92            (string value)
  93            (symbol (string-downcase value))
  94            (number (format nil "~A" value)))
  95          values))
  96     (multiple-value-bind (ok-p gerror)
  97         (%pixbuf-savev pixbuf filename type keys values)
  98       (unless ok-p
  99         (signal-gerror gerror)))))
 100
 101 (defbinding pixbuf-new-from-xpm-data () (referenced pixbuf)
 102   (data (vector string)))
 103
 104 (defbinding %pixbuf-new-subpixbuf () pixbuf ;; or (referenced pixbuf)?
 105   (pixbuf pixbuf)
 106   (x int) (y int) (width int) (height int))
 107
 108 (defbinding %pixbuf-copy () (referenced pixbuf)
 109   (pixbuf pixbuf))
 110
 111 (defun copy-pixbuf (pixbuf &optional x y width height)
 112   (if (and (not x) (not y) (not width) (not height))
 113       (%pixbuf-copy pixbuf)
 114     (%pixbuf-new-subpixbuf pixbuf x y width height)))
 115
 116
 117 ;;; Utilities
 118
 119 (defbinding pixbuf-add-alpha
 120     (pixbuf &optional substitute-color (red 255) (green 255) (blue 255))
 121     (referenced pixbuf)
 122   (pixbuf pixbuf)
 123   (substitute-color boolean)
 124   (red (unsigned 8))
 125   (green (unsigned 8))
 126   (blue (unsigned 8)))