basis/fonts/fonts.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors colors combinators kernel math namespaces ;
   4 IN: fonts
   5
   6 CONSTANT: default-serif-font-name "serif"
   7 CONSTANT: default-sans-serif-font-name "sans-serif"
   8 CONSTANT: default-monospace-font-name "monospace"
   9
  10 CONSTANT: default-font-size 12
  11
  12 SYMBOL: default-font-foreground-color
  13 COLOR: black default-font-foreground-color set-global
  14
  15 SYMBOL: default-font-background-color
  16 COLOR: white default-font-background-color set-global
  17
  18 TUPLE: font name size bold? italic? foreground background ;
  19
  20 : <font> ( -- font )
  21     font new
  22         default-font-foreground-color get >>foreground
  23         default-font-background-color get >>background ; inline
  24
  25 : font-with-foreground ( font color -- font' )
  26     [ clone ] dip >>foreground ; inline
  27
  28 : font-with-background ( font color -- font' )
  29     [ clone ] dip >>background ; inline
  30
  31 : font-with-size ( font size -- font' )
  32     [ clone ] dip >>size ; inline
  33
  34 : reverse-video-font ( font -- font )
  35     clone dup
  36     [ foreground>> >>background ]
  37     [ background>> >>foreground ] bi ;
  38
  39 : derive-font ( base font -- font' )
  40     [
  41         [ clone ] dip over {
  42             [ [ name>> ] either? >>name ]
  43             [ [ size>> ] either? >>size ]
  44             [ [ bold?>> ] either? >>bold? ]
  45             [ [ italic?>> ] either? >>italic? ]
  46             [ [ foreground>> ] either? >>foreground ]
  47             [ [ background>> ] either? >>background ]
  48         } 2cleave
  49     ] when* ;
  50
  51 : serif-font ( -- font )
  52     <font>
  53         default-serif-font-name >>name
  54         default-font-size >>size ;
  55
  56 : sans-serif-font ( -- font )
  57     <font>
  58         default-sans-serif-font-name >>name
  59         default-font-size >>size ;
  60
  61 : monospace-font ( -- font )
  62     <font>
  63         default-monospace-font-name >>name
  64         default-font-size >>size ;
  65
  66 : strip-font-colors ( font -- font' )
  67     clone f >>background f >>foreground ;
  68
  69 TUPLE: metrics width ascent descent height leading cap-height x-height ;
  70
  71 : compute-height ( metrics -- metrics )
  72     dup [ ascent>> ] [ descent>> ] bi + >>height ; inline
  73
  74 TUPLE: selection string start end color ;
  75
  76 C: <selection> selection