chiark - git - mdw - clg/blob - gtk/gtkstyle.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-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: gtkstyle.lisp,v 1.2 2005/04/17 21:43:16 espen Exp $
  19
  20 (in-package "GTK")
  21
  22
  23 ;;; Styles
  24
  25 (eval-when (:compile-toplevel :load-toplevel :execute)
  26   (defbinding %style-font-desc-offset () int))
  27
  28 (defclass style (gobject)
  29   ((fg
  30     :allocation :virtual
  31     :getter style-fg
  32     :setter (setf style-fg)
  33     :initarg :fg)
  34    (bg
  35     :allocation :virtual
  36     :getter style-bg
  37     :setter (setf style-bg)
  38     :initarg :bg)
  39    (light
  40     :allocation :virtual
  41     :getter style-light
  42     :setter (setf style-light)
  43     :initarg :light)
  44    (dark
  45     :allocation :virtual
  46     :getter style-dark
  47     :setter (setf style-dark)
  48     :initarg :dark)
  49    (mid
  50     :allocation :virtual
  51     :getter style-mid
  52     :setter (setf style-mid)
  53     :initarg :mid)
  54    (text
  55     :allocation :virtual
  56     :getter style-text
  57     :setter (setf style-text)
  58     :initarg :text)
  59    (base
  60     :allocation :virtual
  61     :getter style-base
  62     :setter (setf style-base)
  63     :initarg :base)
  64    (text-aa
  65     :allocation :virtual
  66     :getter style-text-aa
  67     :setter (setf style-text-aa)
  68     :initarg :text-aa)
  69    (black
  70     :allocation :virtual
  71     :getter style-black
  72     :setter (setf style-black)
  73     :initarg :black)
  74    (white
  75     :allocation :virtual
  76     :getter style-white
  77     :setter (setf style-white)
  78     :initarg :white)
  79
  80    (font-desc
  81     :offset #.(%style-font-desc-offset)
  82     :allocation :alien
  83     :accessor style-font-desc
  84     :initarg :font-desc
  85     :type pango:font-description)
  86    (xthickness
  87     :allocation :alien
  88     :accessor style-xthickness
  89     :initarg :xthickness
  90     :type int)
  91    (ythickness
  92     :allocation :alien
  93     :accessor style-ythickness
  94     :initarg :ythickness
  95     :type int)
  96
  97    (fg-gc
  98     :allocation :virtual
  99     :getter style-fg-gc)
 100    (bg-gc
 101     :allocation :virtual
 102     :getter style-bg-gc)
 103    (light-gc
 104     :allocation :virtual
 105     :getter style-light-gc)
 106    (dark-gc
 107     :allocation :virtual
 108     :getter style-dark-gc)
 109    (mid-gc
 110     :allocation :virtual
 111     :getter style-mid-gc)
 112    (text-gc
 113     :allocation :virtual
 114     :getter style-text-gc)
 115    (base-gc
 116     :allocation :virtual
 117     :getter style-base-gc)
 118    (text-aa-gc
 119     :allocation :virtual
 120     :getter style-text-aa-gc)
 121    (black-gc
 122     :allocation :virtual
 123     :getter style-black-gc)
 124    (white-gc
 125     :allocation :virtual
 126     :getter style-white-gc))
 127   (:metaclass gobject-class))
 128
 129
 130 (defbinding style-copy () style
 131   (style style))
 132
 133 (defbinding style-attach () style
 134   (style style)
 135   (window window))
 136
 137 (defbinding style-detach () style
 138   (style style))
 139
 140
 141 (deftype color-type ()
 142   '(enum :fg :bg :light :dark :mid :text :base :text-aa :white :black))
 143
 144 (defbinding %style-get-color () (copy-of gdk:color)
 145   (style style)
 146   (color-type color-type)
 147   (state state-type))
 148
 149 (defbinding %style-set-color () nil
 150   (style style)
 151   (color-type color-type)
 152   (state state-type)
 153   (color gdk:color))
 154
 155 (defbinding %style-get-gc () gdk:gc
 156   (style style)
 157   (color-type color-type)
 158   (state state-type))
 159
 160 (defun %style-get-color-vector (style color-type)
 161   (loop
 162    with states = (enum-mapping 'state-type)
 163    with vector = (make-array (length states))
 164    for (symbol index) in states
 165    do (setf (svref vector index) (%style-get-color style color-type symbol))
 166    finally (return vector)))
 167
 168 (defun %style-set-color-vector (style color-type vector)
 169   (loop
 170    for (symbol index) in (enum-mapping 'state-type)
 171    do (%style-set-color style color-type symbol (svref vector index))))
 172
 173 (defun %style-get-gc-vector (style color-type)
 174   (loop
 175    with states = (enum-mapping 'state-type)
 176    with vector = (make-array (length states))
 177    for (symbol index) in states
 178    do (setf (svref vector index) (%style-get-gc style color-type symbol))
 179    finally (return vector)))
 180
 181 (defmacro define-style-color-accessor (name type)
 182   `(progn
 183      (defun ,name (style &optional state)
 184        (if state
 185            (%style-get-color style ,type state)
 186          (%style-get-color-vector style ,type)))
 187      (defun (setf ,name) (color style &optional state)
 188        (if state
 189            (%style-set-color style ,type state color)
 190          (%style-set-color-vector style ,type color)))))
 191
 192 (define-style-color-accessor style-fg :fg)
 193 (define-style-color-accessor style-bg :bg)
 194 (define-style-color-accessor style-light :light)
 195 (define-style-color-accessor style-dark :dark)
 196 (define-style-color-accessor style-mid :mid)
 197 (define-style-color-accessor style-text :text)
 198 (define-style-color-accessor style-base :base)
 199 (define-style-color-accessor style-text-aa :text-aa)
 200
 201 (defun style-black (style)
 202   (%style-get-color style :black :normal))
 203
 204 (defun style-white (style)
 205   (%style-get-color style :black :normal))
 206
 207 (defmacro define-style-gc-reader (name type)
 208   `(defun ,name (style &optional state)
 209      (if state
 210          (%style-get-gc style ,type state)
 211        (%style-get-gc-vector style ,type))))
 212
 213 (define-style-gc-reader style-fg-gc :fg)
 214 (define-style-gc-reader style-bg-gc :bg)
 215 (define-style-gc-reader style-light-gc :light)
 216 (define-style-gc-reader style-dark-gc :dark)
 217 (define-style-gc-reader style-mid-gc :mid)
 218 (define-style-gc-reader style-text-gc :text)
 219 (define-style-gc-reader style-base-gc :base)
 220 (define-style-gc-reader style-text-aa-gc :text-aa)
 221
 222 (defun style-black-gc (style)
 223   (%style-get-gc style :black :normal))
 224
 225 (defun style-white-gc (style)
 226   (%style-get-gc style :white :normal))
 227
 228 (export
 229  '(style-fg style-bg style-light style-dark style-mid style-text style-base
 230    style-text-aa style-fg-gc style-bg-gc style-light-gc style-dark-gc
 231    style-mid-gc style-text-gc style-base-gc style-text-aa-gc))