basis/ui/gadgets/paragraphs/paragraphs.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays fry kernel math math.order sequences
   4 ui.baseline-alignment ui.gadgets ui.gadgets.labels
   5 ui.gadgets.packs.private ui.render wrap.words ;
   6 IN: ui.gadgets.paragraphs
   7
   8 MIXIN: word-break
   9
  10 ! A word break gadget
  11 TUPLE: word-break-gadget < label ;
  12
  13 : <word-break-gadget> ( text -- gadget )
  14     word-break-gadget new-label ;
  15
  16 M: word-break-gadget draw-gadget* drop ;
  17
  18 INSTANCE: word-break-gadget word-break
  19
  20 ! A gadget that arranges its children in a word-wrap style.
  21 TUPLE: paragraph < aligned-gadget margin wrapped ;
  22
  23 : <paragraph> ( margin -- gadget )
  24     paragraph new
  25     horizontal >>orientation
  26     swap >>margin ;
  27
  28 <PRIVATE
  29
  30 : gadget>word ( gadget -- word )
  31     [ ] [ pref-dim first ] [ word-break? ] tri <wrapping-word> ;
  32
  33 : line-width ( words -- n )
  34     [ break?>> ] trim-tail-slice [ width>> ] map-sum ;
  35
  36 TUPLE: line words width height baseline ;
  37
  38 : <line> ( words -- line )
  39     [ ] [ line-width ] [ [ key>> ] map dup pref-dims ] tri
  40     measure-height-metrics drop line boa ;
  41
  42 : wrap-paragraph ( paragraph -- wrapped-paragraph )
  43     [ children>> [ gadget>word ] map ] [ margin>> ] bi
  44     wrap-words [ <line> ] map! ;
  45
  46 : cached-wrapped ( paragraph -- wrapped-paragraph )
  47     dup wrapped>>
  48     [ ] [ [ wrap-paragraph dup ] keep wrapped<< ] ?if ;
  49
  50 : max-line-width ( wrapped-paragraph -- x )
  51     [ width>> ] [ max ] map-reduce ;
  52
  53 : sum-line-heights ( wrapped-paragraph -- y )
  54     [ height>> ] map-sum ;
  55
  56 M: paragraph pref-dim*
  57     cached-wrapped [
  58         { 0 0 }
  59     ] [
  60         [ max-line-width ] [ sum-line-heights ] bi 2array
  61     ] if-empty ;
  62
  63 : line-y-coordinates ( wrapped-paragraph -- ys )
  64     0 [ height>> + ] accumulate nip ;
  65
  66 : word-x-coordinates ( wrapped-line -- xs )
  67     0 [ width>> + ] accumulate nip ;
  68
  69 : layout-word ( word x y -- )
  70     [ key>> ] 2dip 2array >>loc prefer ;
  71
  72 : layout-line ( wrapped-line y -- )
  73     [
  74         words>>
  75         [ ]
  76         [ word-x-coordinates ]
  77         [ [ key>> ] map align-baselines ] tri
  78     ] dip '[ _ + layout-word ] 3each ;
  79
  80 M: paragraph layout*
  81     f >>wrapped
  82     cached-wrapped dup line-y-coordinates [ layout-line ] 2each ;
  83
  84 M: paragraph baseline*
  85     cached-wrapped [ f ] [ first baseline>> ] if-empty ;
  86
  87 M: paragraph cap-height* pack-cap-height ;
  88
  89 PRIVATE>