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 kernel math math.order sequences wrap wrap.words
   4 arrays fry ui.gadgets ui.gadgets.labels ui.gadgets.packs.private
   5 ui.render ui.baseline-alignment ;
   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 < gadget margin ;
  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 <word> ;
  32
  33 TUPLE: line words height ;
  34
  35 : <line> ( words -- line )
  36     dup [ key>> ] map dup pref-dims measure-height line boa ;
  37
  38 : wrap-paragraph ( paragraph -- wrapped-paragraph )
  39     [ children>> [ gadget>word ] map ] [ margin>> ] bi
  40     dup wrap-words [ <line> ] map ;
  41
  42 : line-width ( wrapped-line -- n )
  43     [ break?>> ] trim-tail-slice [ width>> ] sigma ;
  44
  45 : max-line-width ( wrapped-paragraph -- x )
  46     [ words>> line-width ] [ max ] map-reduce ;
  47
  48 : sum-line-heights ( wrapped-paragraph -- y )
  49     [ height>> ] sigma ;
  50
  51 M: paragraph pref-dim*
  52     wrap-paragraph [ max-line-width ] [ sum-line-heights ] bi 2array ;
  53
  54 : line-y-coordinates ( wrapped-paragraph -- ys )
  55     0 [ height>> + ] accumulate nip ;
  56
  57 : word-x-coordinates ( wrapped-line -- xs )
  58     0 [ width>> + ] accumulate nip ;
  59
  60 : layout-word ( word x y -- )
  61     [ key>> ] 2dip 2array >>loc prefer ;
  62
  63 : layout-line ( wrapped-line y -- )
  64     [
  65         words>>
  66         [ ]
  67         [ word-x-coordinates ]
  68         [ [ key>> ] map align-baselines ] tri
  69     ] dip '[ _ + layout-word ] 3each ;
  70
  71 M: paragraph layout*
  72     wrap-paragraph dup line-y-coordinates
  73     [ layout-line ] 2each ;
  74
  75 M: paragraph baseline
  76     wrap-paragraph [ f ] [
  77         first words>>
  78         [ key>> ] map
  79         dup [ pref-dim ] map
  80         measure-metrics drop
  81     ] if-empty ;
  82
  83 M: paragraph cap-height pack-cap-height ;
  84
  85 PRIVATE>