extra/pango/cairo/gadgets/gadgets.factor

   1 ! Copyright (C) 2008 Matthew Willis.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: pango.cairo cairo cairo.ffi
   4 cairo.gadgets namespaces arrays
   5 fry accessors ui.gadgets assocs
   6 sequences shuffle opengl opengl.gadgets
   7 alien.c-types kernel math ;
   8 IN: pango.cairo.gadgets
   9
  10 SYMBOL: textures
  11 SYMBOL: dims
  12 SYMBOL: refcounts
  13
  14 : init-cache ( symbol -- )
  15     dup get [ drop ] [ H{ } clone swap set-global ] if ;
  16
  17 textures init-cache
  18 dims init-cache
  19 refcounts init-cache
  20
  21 TUPLE: pango-gadget < cairo-gadget text font ;
  22
  23 : cache-key ( gadget -- key )
  24     [ font>> ] [ text>> ] bi 2array ;
  25
  26 : refcount-change ( gadget quot -- )
  27     >r cache-key refcounts get
  28     [ [ 0 ] unless* ] r> compose change-at ;
  29
  30 : <pango-gadget> ( font text -- gadget )
  31     pango-gadget construct-gadget
  32         swap >>text
  33         swap >>font ;
  34
  35 : setup-layout ( {font,text} -- quot )
  36     first2 '[ , layout-font , layout-text ] ;
  37
  38 M: pango-gadget quot>> ( gadget -- quot )
  39     cache-key setup-layout [ show-layout ] compose
  40     [ with-pango ] curry ;
  41
  42 M: pango-gadget dim>> ( gadget -- dim )
  43     cache-key dims get [ setup-layout layout-size ] cache ;
  44
  45 M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
  46
  47 : release-texture ( gadget -- )
  48     cache-key textures get delete-at* [ delete-texture ] [ drop ] if ;
  49
  50 M: pango-gadget ungraft* ( gadget -- )
  51     dup [ 1- ] refcount-change
  52     dup cache-key refcounts get at
  53     zero? [ release-texture ] [ drop ] if ;
  54
  55 M: pango-gadget render* ( gadget -- )
  56     [ gen-texture ] [ cache-key textures get set-at ] bi
  57     call-next-method ;
  58
  59 M: pango-gadget tex>> ( gadget -- texture )
  60     dup cache-key textures get at
  61     [ nip ] [ dup render* tex>> ] if* ;
  62
  63 USE: ui.gadgets.panes
  64 : hello "Sans 50" "hello" <pango-gadget> gadget. ;