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 pdf.text pdf.wrap sequences
   6 ui.text ;
   7
   8 IN: pdf.canvas
   9
  10 TUPLE: margin left right top bottom ;
  11
  12 C: <margin> margin
  13
  14 TUPLE: canvas x y width height margin col-width font stream
  15 foreground background page-color inset line-height metrics ;
  16
  17 : <canvas> ( -- canvas )
  18     canvas new
  19         0 >>x
  20         0 >>y
  21         612 >>width
  22         792 >>height
  23         54 54 54 54 <margin> >>margin
  24         612 >>col-width
  25         sans-serif-font 12 >>size >>font
  26         SBUF" " >>stream
  27         0 >>line-height
  28         { 0 0 } >>inset
  29     dup font>> font-metrics >>metrics ;
  30
  31 : set-style ( canvas style -- canvas )
  32     {
  33         [
  34             font-name of "sans-serif" or {
  35                 { "sans-serif" [ "Helvetica" ] }
  36                 { "serif"      [ "Times"     ] }
  37                 { "monospace"  [ "Courier"   ] }
  38                 [ " is unsupported" append throw ]
  39             } case [ dup font>> ] dip >>name drop
  40         ]
  41         [
  42             font-size of 12 or
  43             [ dup font>> ] dip >>size drop
  44         ]
  45         [
  46             font-style of [ dup font>> ] dip {
  47                 { bold        [ t f ] }
  48                 { italic      [ f t ] }
  49                 { bold-italic [ t t ] }
  50                 [ drop f f ]
  51             } case [ >>bold? ] [ >>italic? ] bi* drop
  52         ]
  53         [ foreground of COLOR: black or >>foreground ]
  54         [ background of f or >>background ]
  55         [ page-color of f or >>page-color ]
  56         [ inset of { 0 0 } or >>inset ]
  57     } cleave
  58     dup font>> font-metrics
  59     [ >>metrics ] [ height>> '[ _ max ] change-line-height ] bi ;
  60
  61 ! introduce positioning of elements versus canvas?
  62
  63 : margin-x ( canvas -- n )
  64     margin>> [ left>> ] [ right>> ] bi + ;
  65
  66 : margin-y ( canvas -- n )
  67     margin>> [ top>> ] [ bottom>> ] bi + ;
  68
  69 : (width) ( canvas -- n )
  70     [ width>> ] [ margin>> [ left>> ] [ right>> ] bi + ] bi - ;
  71
  72 : width ( canvas -- n )
  73     [ (width) ] [ col-width>> ] bi min ;
  74
  75 : height ( canvas -- n )
  76     [ height>> ] [ margin>> [ top>> ] [ bottom>> ] bi + ] bi - ;
  77
  78 : x ( canvas -- n )
  79     [ margin>> left>> ] [ x>> ] bi + ;
  80
  81 : y ( canvas -- n )
  82     [ height>> ] [ margin>> top>> ] [ y>> ] tri + - ;
  83
  84 : inc-x ( canvas n -- )
  85     '[ _ + ] change-x drop ;
  86
  87 : inc-y ( canvas n -- )
  88     '[ _ + ] change-y drop ;
  89
  90 : line-height ( canvas -- n )
  91     [ line-height>> ] [ inset>> first 2 * ] bi + ;
  92
  93 : line-break ( canvas -- )
  94     [ line-height>> ] keep [ + ] change-y 0 >>x
  95     dup metrics>> height>> >>line-height drop ;
  96
  97 : ?line-break ( canvas -- )
  98     dup x>> 0 > [ line-break ] [ drop ] if ;
  99
 100 : ?break ( canvas -- )
 101     dup x>> 0 > [ ?line-break ] [
 102         [ 7 + ] change-y 0 >>x drop
 103     ] if ;
 104
 105 : inc-lines ( canvas n -- )
 106     [ 0 >>x ] dip [ dup line-break ] times drop ;
 107
 108 : avail-width ( canvas -- n )
 109     [ width ] [ x>> ] bi [-] ;
 110
 111 : avail-height ( canvas -- n )
 112     [ height ] [ y>> ] bi [-] ;
 113
 114 : avail-lines ( canvas -- n )
 115     [ avail-height ] [ line-height>> ] bi /i ; ! FIXME: 1 +
 116
 117 : text-fits? ( canvas string -- ? )
 118     [ dup font>> ] [ word-split1 drop ] bi*
 119     text-width swap avail-width <= ;
 120
 121 : draw-page-color ( canvas -- ) ! FIXME:
 122     dup page-color>> [
 123         "0.0 G" print
 124         foreground-color
 125         [ 0 0 ] dip [ width>> ] [ height>> ] bi
 126         rectangle fill
 127     ] [ drop ] if* ;
 128
 129 : draw-background ( canvas line -- )
 130     over background>> [
 131         "0.0 G" print
 132         foreground-color
 133         [ drop [ x ] [ y ] bi ]
 134         [ [ font>> ] [ text-dim first2 neg ] bi* ] 2bi
 135         rectangle fill
 136     ] [ 2drop ] if* ;
 137
 138 : draw-text1 ( canvas line -- canvas )
 139     [ draw-background ] [
 140         text-start
 141         over font>> text-size
 142         over foreground>> [ foreground-color ] when*
 143         over [ x ] [ y ] [ metrics>> ascent>> - ] tri text-location
 144         over dup font>> pick text-width inc-x
 145         text-write
 146         text-end
 147     ] 2bi ;
 148
 149 : draw-text ( canvas lines -- )
 150     [ drop ] [
 151         unclip-last
 152         [ [ draw-text1 dup line-break ] each ]
 153         [ [ draw-text1 ] when* ] bi* drop
 154     ] if-empty ;
 155
 156 : draw-line ( canvas width -- )
 157     swap [ x ] [ y ] [ line-height>> 2 / - ] tri
 158     [ line-move ] [ [ + ] [ line-line ] bi* ] 2bi
 159     stroke ;