1 ! Copyright (C) 2011-2012 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors assocs colors combinators fonts io io.styles
5 kernel math math.order namespaces pdf.text pdf.wrap sequences
12 TUPLE: margin left right top bottom ;
16 TUPLE: canvas x y width height margin col-width font stream
17 foreground background page-color inset line-height metrics ;
19 : <canvas> ( -- canvas )
25 54 54 54 54 <margin> >>margin
27 sans-serif-font 12 >>size >>font
31 dup font>> font-metrics >>metrics ;
33 : set-style ( canvas style -- canvas )
36 font-name of "sans-serif" or {
37 { "sans-serif" [ "Helvetica" ] }
38 { "serif" [ "Times" ] }
39 { "monospace" [ "Courier" ] }
40 [ " is unsupported" append throw ]
41 } case [ dup font>> ] dip >>name drop
45 [ dup font>> ] dip >>size drop
48 font-style of [ dup font>> ] dip {
51 { bold-italic [ t t ] }
53 } case [ >>bold? ] [ >>italic? ] bi* drop
55 [ foreground of COLOR: black or >>foreground ]
56 [ background of f or >>background ]
57 [ page-color of f or >>page-color ]
58 [ inset of { 0 0 } or >>inset ]
60 dup font>> font-metrics
61 [ >>metrics ] [ height>> '[ _ max ] change-line-height ] bi ;
63 ! introduce positioning of elements versus canvas?
65 : margin-x ( canvas -- n )
66 margin>> [ left>> ] [ right>> ] bi + ;
68 : margin-y ( canvas -- n )
69 margin>> [ top>> ] [ bottom>> ] bi + ;
71 : (width) ( canvas -- n )
72 [ width>> ] [ margin>> [ left>> ] [ right>> ] bi + ] bi - ;
74 : width ( canvas -- n )
75 [ (width) ] [ col-width>> ] bi min ;
77 : height ( canvas -- n )
78 [ height>> ] [ margin>> [ top>> ] [ bottom>> ] bi + ] bi - ;
81 [ margin>> left>> ] [ x>> ] bi + ;
84 [ height>> ] [ margin>> top>> ] [ y>> ] tri + - ;
86 : inc-x ( canvas n -- )
87 '[ _ + ] change-x drop ;
89 : inc-y ( canvas n -- )
90 '[ _ + ] change-y drop ;
94 : (line-height) ( canvas -- n )
95 line-height>> +line-height+ get [ * >integer ] when* ;
99 : line-height ( canvas -- n )
100 [ (line-height) ] [ inset>> first 2 * ] bi + ;
102 : line-break ( canvas -- )
103 [ (line-height) ] keep [ + ] change-y 0 >>x
104 dup metrics>> height>> >>line-height drop ;
106 : ?line-break ( canvas -- )
107 dup x>> 0 > [ line-break ] [ drop ] if ;
109 : ?break ( canvas -- )
110 dup x>> 0 > [ ?line-break ] [
111 [ 7 + ] change-y 0 >>x drop
114 : inc-lines ( canvas n -- )
115 [ 0 >>x ] dip [ dup line-break ] times drop ;
117 : avail-width ( canvas -- n )
118 [ width ] [ x>> ] bi [-] ;
120 : avail-height ( canvas -- n )
121 [ height ] [ y>> ] bi [-] ;
123 : avail-lines ( canvas -- n )
124 [ avail-height ] [ line-height>> ] bi /i ; ! FIXME: 1 +
126 : text-fits? ( canvas string -- ? )
127 [ dup font>> ] [ word-split1 drop ] bi*
128 text-width swap avail-width <= ;
130 : draw-page-color ( canvas -- ) ! FIXME:
134 [ 0 0 ] dip [ width>> ] [ height>> ] bi
138 : draw-background ( canvas line -- )
142 [ drop [ x ] [ y ] bi ]
143 [ [ font>> ] [ text-dim first2 neg ] bi* ] 2bi
147 : draw-text1 ( canvas line -- canvas )
148 [ draw-background ] [
150 over font>> text-size
151 over foreground>> [ foreground-color ] when*
152 over [ x ] [ y ] [ metrics>> ascent>> - ] tri text-location
153 over dup font>> pick text-width inc-x
158 : draw-text ( canvas lines -- )
161 [ [ draw-text1 dup line-break ] each ]
162 [ [ draw-text1 ] when* ] bi* drop
165 : draw-line ( canvas width -- )
166 swap [ x ] [ y ] [ line-height>> 2 / - ] tri
167 [ line-move ] [ [ + ] [ line-line ] bi* ] 2bi