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