core/ui/gadgets/paragraphs.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets-paragraphs
   4 USING: arrays gadgets gadgets-labels generic kernel math
   5 namespaces sequences ;
   6
   7 ! A word break gadget
   8 TUPLE: word-break-gadget ;
   9
  10 C: word-break-gadget ( gadget -- gadget )
  11     [ set-delegate ] keep ;
  12
  13 M: word-break-gadget draw-gadget* drop ;
  14
  15 ! A gadget that arranges its children in a word-wrap style.
  16 TUPLE: paragraph margin ;
  17
  18 C: paragraph ( margin -- gadget )
  19     [ set-paragraph-margin ] keep dup delegate>gadget ;
  20
  21 SYMBOL: x SYMBOL: max-x
  22
  23 SYMBOL: y SYMBOL: max-y
  24
  25 SYMBOL: line-height
  26
  27 SYMBOL: margin
  28
  29 : overrun? ( width -- ? ) x get + margin get >= ;
  30
  31 : wrap-line ( -- )
  32     line-height get y +@
  33     0 { x line-height } [ set ] each-with ;
  34
  35 : wrap-pos ( -- pos ) x get y get 2array ;
  36
  37 : advance-x ( x -- )
  38     x +@
  39     x get max-x [ max ] change ;
  40
  41 : advance-y ( y -- )
  42     dup line-height [ max ] change
  43     y get + max-y [ max ] change ;
  44
  45 : wrap-step ( quot child -- )
  46     dup pref-dim [
  47         over word-break-gadget? [
  48             dup first overrun? [ wrap-line ] when
  49         ] unless drop wrap-pos rot call
  50     ] keep first2 advance-y advance-x ; inline
  51
  52 : wrap-dim ( -- dim ) max-x get max-y get 2array ;
  53
  54 : init-wrap ( paragraph -- )
  55     paragraph-margin margin set
  56     0 { x max-x y max-y line-height } [ set ] each-with ;
  57
  58 : do-wrap ( paragraph quot -- dim )
  59     [
  60         swap dup init-wrap
  61         [ wrap-step ] each-child-with wrap-dim
  62     ] with-scope ; inline
  63
  64 M: paragraph pref-dim*
  65     [ 2drop ] do-wrap ;
  66
  67 M: paragraph layout*
  68     [ swap dup prefer set-rect-loc ] do-wrap drop ;