basis/fonts/fonts.factor

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