extra/ui/gadgets/paragraphs/paragraphs.factor

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