basis/ui/gadgets/paragraphs/paragraphs.factor

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