1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors colors combinators kernel math namespaces ;
6 CONSTANT: default-serif-font-name "serif"
7 CONSTANT: default-sans-serif-font-name "sans-serif"
8 CONSTANT: default-monospace-font-name "monospace"
10 CONSTANT: default-font-size 12
12 SYMBOL: default-font-foreground-color
13 COLOR: black default-font-foreground-color set-global
15 SYMBOL: default-font-background-color
16 COLOR: white default-font-background-color set-global
18 TUPLE: font name size bold? italic? foreground background ;
22 default-font-foreground-color get >>foreground
23 default-font-background-color get >>background ; inline
25 : font-with-foreground ( font color -- font' )
26 [ clone ] dip >>foreground ; inline
28 : font-with-background ( font color -- font' )
29 [ clone ] dip >>background ; inline
31 : font-with-size ( font size -- font' )
32 [ clone ] dip >>size ; inline
34 : reverse-video-font ( font -- font )
36 [ foreground>> >>background ]
37 [ background>> >>foreground ] bi ;
39 : derive-font ( base font -- font' )
42 [ [ name>> ] either? >>name ]
43 [ [ size>> ] either? >>size ]
44 [ [ bold?>> ] either? >>bold? ]
45 [ [ italic?>> ] either? >>italic? ]
46 [ [ foreground>> ] either? >>foreground ]
47 [ [ background>> ] either? >>background ]
51 : serif-font ( -- font )
53 default-serif-font-name >>name
54 default-font-size >>size ;
56 : sans-serif-font ( -- font )
58 default-sans-serif-font-name >>name
59 default-font-size >>size ;
61 : monospace-font ( -- font )
63 default-monospace-font-name >>name
64 default-font-size >>size ;
66 : strip-font-colors ( font -- font' )
67 clone f >>background f >>foreground ;
69 TUPLE: metrics width ascent descent height leading cap-height x-height ;
71 : compute-height ( metrics -- metrics )
72 dup [ ascent>> ] [ descent>> ] bi + >>height ; inline
74 TUPLE: selection string start end color ;
76 C: <selection> selection