basis/wrap/wrap.factor

   1 ! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences kernel namespaces make splitting
   4 math math.order fry assocs accessors ;
   5 IN: wrap
   6
   7 ! Word wrapping/line breaking -- not Unicode-aware
   8
   9 TUPLE: word key width break? ;
  10
  11 C: <word> word
  12
  13 <PRIVATE
  14
  15 SYMBOL: width
  16
  17 : break-here? ( column word -- ? )
  18     break?>> not [ width get > ] [ drop f ] if ;
  19
  20 : walk ( n words -- n )
  21     ! If on a break, take the rest of the breaks
  22     ! If not on a break, go back until you hit a break
  23     2dup bounds-check? [
  24         2dup nth break?>>
  25         [ [ break?>> not ] find-from drop ]
  26         [ [ break?>> ] find-last-from drop 1+ ] if
  27    ] [ drop ] if ;
  28
  29 : find-optimal-break ( words -- n )
  30     [ 0 ] keep
  31     [ [ width>> + dup ] keep break-here? ] find drop nip
  32     [ 1 max swap walk ] [ drop f ] if* ;
  33
  34 : (wrap) ( words -- )
  35     [
  36         dup find-optimal-break
  37         [ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if*
  38     ] unless-empty ;
  39
  40 : intersperse ( seq elt -- seq' )
  41     [ '[ _ , ] [ , ] interleave ] { } make ;
  42
  43 : split-lines ( string -- words-lines )
  44     string-lines [
  45         " \t" split harvest
  46         [ dup length f <word> ] map
  47         " " 1 t <word> intersperse
  48     ] map ;
  49
  50 : join-words ( wrapped-lines -- lines )
  51     [
  52         [ break?>> ] trim-slice
  53         [ key>> ] map concat
  54     ] map ;
  55
  56 : join-lines ( strings -- string )
  57     "\n" join ;
  58
  59 PRIVATE>
  60
  61 : wrap ( words width -- lines )
  62     width [
  63         [ (wrap) ] { } make
  64     ] with-variable ;
  65
  66 : wrap-lines ( lines width -- newlines )
  67     [ split-lines ] dip '[ _ wrap join-words ] map concat ;
  68
  69 : wrap-string ( string width -- newstring )
  70     wrap-lines join-lines ;
  71
  72 : wrap-indented-string ( string width indent -- newstring )
  73     [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;