factor/basis/fonts/fonts.factor

78 lines
2.1 KiB
Factor

! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors.constants combinators kernel math
namespaces ;
IN: fonts
CONSTANT: default-serif-font-name "serif"
CONSTANT: default-sans-serif-font-name "sans-serif"
CONSTANT: default-monospace-font-name "monospace"
CONSTANT: default-font-size 12
SYMBOL: default-font-foreground-color
COLOR: black default-font-foreground-color set-global
SYMBOL: default-font-background-color
COLOR: white default-font-background-color set-global
TUPLE: font name size bold? italic? foreground background ;
: <font> ( -- font )
font new
default-font-foreground-color get >>foreground
default-font-background-color get >>background ; inline
: font-with-foreground ( font color -- font' )
[ clone ] dip >>foreground ; inline
: font-with-background ( font color -- font' )
[ clone ] dip >>background ; inline
: font-with-size ( font size -- font' )
[ clone ] dip >>size ; inline
: reverse-video-font ( font -- font )
clone dup
[ foreground>> >>background ]
[ background>> >>foreground ] bi ;
: derive-font ( base font -- font' )
[
[ clone ] dip over {
[ [ name>> ] either? >>name ]
[ [ size>> ] either? >>size ]
[ [ bold?>> ] either? >>bold? ]
[ [ italic?>> ] either? >>italic? ]
[ [ foreground>> ] either? >>foreground ]
[ [ background>> ] either? >>background ]
} 2cleave
] when* ;
: serif-font ( -- font )
<font>
default-serif-font-name >>name
default-font-size >>size ;
: sans-serif-font ( -- font )
<font>
default-sans-serif-font-name >>name
default-font-size >>size ;
: monospace-font ( -- font )
<font>
default-monospace-font-name >>name
default-font-size >>size ;
: strip-font-colors ( font -- font' )
clone f >>background f >>foreground ;
TUPLE: metrics width ascent descent height leading cap-height x-height ;
: compute-height ( metrics -- metrics )
dup [ ascent>> ] [ descent>> ] bi + >>height ; inline
TUPLE: selection string start end color ;
C: <selection> selection