basis/fonts/fonts.factor

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