extra/pdf/canvas/canvas.factor

   1 ! Copyright (C) 2011-2012 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors assocs colors.constants combinators fonts fry
   5 io io.styles kernel math math.order namespaces pdf.text pdf.wrap
   6 sequences ui.text ;
   7
   8 IN: pdf.canvas
   9
  10 SYMBOL: +line-height+
  11
  12 TUPLE: margin left right top bottom ;
  13
  14 C: <margin> margin
  15
  16 TUPLE: canvas x y width height margin col-width font stream
  17 foreground background page-color inset line-height metrics ;
  18
  19 : <canvas> ( -- canvas )
  20     canvas new
  21         0 >>x
  22         0 >>y
  23         612 >>width
  24         792 >>height
  25         54 54 54 54 <margin> >>margin
  26         612 >>col-width
  27         sans-serif-font 12 >>size >>font
  28         SBUF" " >>stream
  29         0 >>line-height
  30         { 0 0 } >>inset
  31     dup font>> font-metrics >>metrics ;
  32
  33 : set-style ( canvas style -- canvas )
  34     {
  35         [
  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
  42         ]
  43         [
  44             font-size of 12 or
  45             [ dup font>> ] dip >>size drop
  46         ]
  47         [
  48             font-style of [ dup font>> ] dip {
  49                 { bold        [ t f ] }
  50                 { italic      [ f t ] }
  51                 { bold-italic [ t t ] }
  52                 [ drop f f ]
  53             } case [ >>bold? ] [ >>italic? ] bi* drop
  54         ]
  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 ]
  59     } cleave
  60     dup font>> font-metrics
  61     [ >>metrics ] [ height>> '[ _ max ] change-line-height ] bi ;
  62
  63 ! introduce positioning of elements versus canvas?
  64
  65 : margin-x ( canvas -- n )
  66     margin>> [ left>> ] [ right>> ] bi + ;
  67
  68 : margin-y ( canvas -- n )
  69     margin>> [ top>> ] [ bottom>> ] bi + ;
  70
  71 : (width) ( canvas -- n )
  72     [ width>> ] [ margin>> [ left>> ] [ right>> ] bi + ] bi - ;
  73
  74 : width ( canvas -- n )
  75     [ (width) ] [ col-width>> ] bi min ;
  76
  77 : height ( canvas -- n )
  78     [ height>> ] [ margin>> [ top>> ] [ bottom>> ] bi + ] bi - ;
  79
  80 : x ( canvas -- n )
  81     [ margin>> left>> ] [ x>> ] bi + ;
  82
  83 : y ( canvas -- n )
  84     [ height>> ] [ margin>> top>> ] [ y>> ] tri + - ;
  85
  86 : inc-x ( canvas n -- )
  87     '[ _ + ] change-x drop ;
  88
  89 : inc-y ( canvas n -- )
  90     '[ _ + ] change-y drop ;
  91
  92 <PRIVATE
  93
  94 : (line-height) ( canvas -- n )
  95     line-height>> +line-height+ get [ * >integer ] when* ;
  96
  97 PRIVATE>
  98
  99 : line-height ( canvas -- n )
 100     [ (line-height) ] [ inset>> first 2 * ] bi + ;
 101
 102 : line-break ( canvas -- )
 103     [ (line-height) ] keep [ + ] change-y 0 >>x
 104     dup metrics>> height>> >>line-height drop ;
 105
 106 : ?line-break ( canvas -- )
 107     dup x>> 0 > [ line-break ] [ drop ] if ;
 108
 109 : ?break ( canvas -- )
 110     dup x>> 0 > [ ?line-break ] [
 111         [ 7 + ] change-y 0 >>x drop
 112     ] if ;
 113
 114 : inc-lines ( canvas n -- )
 115     [ 0 >>x ] dip [ dup line-break ] times drop ;
 116
 117 : avail-width ( canvas -- n )
 118     [ width ] [ x>> ] bi [-] ;
 119
 120 : avail-height ( canvas -- n )
 121     [ height ] [ y>> ] bi [-] ;
 122
 123 : avail-lines ( canvas -- n )
 124     [ avail-height ] [ line-height>> ] bi /i ; ! FIXME: 1 +
 125
 126 : text-fits? ( canvas string -- ? )
 127     [ dup font>> ] [ word-split1 drop ] bi*
 128     text-width swap avail-width <= ;
 129
 130 : draw-page-color ( canvas -- ) ! FIXME:
 131     dup page-color>> [
 132         "0.0 G" print
 133         foreground-color
 134         [ 0 0 ] dip [ width>> ] [ height>> ] bi
 135         rectangle fill
 136     ] [ drop ] if* ;
 137
 138 : draw-background ( canvas line -- )
 139     over background>> [
 140         "0.0 G" print
 141         foreground-color
 142         [ drop [ x ] [ y ] bi ]
 143         [ [ font>> ] [ text-dim first2 neg ] bi* ] 2bi
 144         rectangle fill
 145     ] [ 2drop ] if* ;
 146
 147 : draw-text1 ( canvas line -- canvas )
 148     [ draw-background ] [
 149         text-start
 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
 154         text-write
 155         text-end
 156     ] 2bi ;
 157
 158 : draw-text ( canvas lines -- )
 159     [ drop ] [
 160         unclip-last
 161         [ [ draw-text1 dup line-break ] each ]
 162         [ [ draw-text1 ] when* ] bi* drop
 163     ] if-empty ;
 164
 165 : draw-line ( canvas width -- )
 166     swap [ x ] [ y ] [ line-height>> 2 / - ] tri
 167     [ line-move ] [ [ + ] [ line-line ] bi* ] 2bi
 168     stroke ;