diff --git a/basis/wrap/strings/strings.factor b/basis/wrap/strings/strings.factor index 7009352f2a..f5ab777444 100644 --- a/basis/wrap/strings/strings.factor +++ b/basis/wrap/strings/strings.factor @@ -8,11 +8,11 @@ IN: wrap.strings : split-lines ( string -- elements-lines ) string-lines [ " \t" split harvest - [ dup length 1 ] map - ] map ; + [ dup length 1 ] map! + ] map! ; : join-elements ( wrapped-lines -- lines ) - [ " " join ] map ; + [ " " join ] map! ; : join-lines ( strings -- string ) "\n" join ; @@ -20,10 +20,10 @@ IN: wrap.strings PRIVATE> : wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ; + [ split-lines ] dip '[ _ dup wrap join-elements ] map! concat ; : wrap-string ( string width -- newstring ) wrap-lines join-lines ; : wrap-indented-string ( string width indent -- newstring ) - [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ; + [ length - wrap-lines ] keep '[ _ prepend ] map! join-lines ; diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor index 90113c289e..40387559d4 100644 --- a/basis/wrap/words/words.factor +++ b/basis/wrap/words/words.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: sequences kernel splitting.monotonic accessors grouping wrap ; +USING: accessors grouping kernel math sequences +sequences.private splitting.monotonic wrap ; IN: wrap.words TUPLE: word key width break? ; @@ -13,9 +14,11 @@ C: word : make-element ( whites blacks -- element ) [ append ] [ [ words-length ] bi@ ] 2bi ; - + : ?first2 ( seq -- first/f second/f ) - [ ?first ] [ ?second ] bi ; + dup length dup 1 > [ first2-unsafe ] [ + 0 > [ first-unsafe f ] [ drop f f ] if + ] if ; : split-words ( seq -- half-elements ) [ [ break?>> ] same? ] monotonic-split ; @@ -26,7 +29,7 @@ C: word [ f ] if ; : make-elements ( seq f/element -- elements ) - [ 2 [ ?first2 make-element ] map ] dip + [ 2 group [ ?first2 make-element ] map! ] dip [ prefix ] when* ; : words>elements ( seq -- newseq ) @@ -35,5 +38,5 @@ C: word PRIVATE> : wrap-words ( words line-max line-ideal -- lines ) - [ words>elements ] 2dip wrap [ concat ] map ; + [ words>elements ] 2dip wrap [ concat ] map! ; diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index b28b0bcbff..0f091fad17 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences math arrays locals fry accessors +USING: combinators kernel sequences math arrays locals fry accessors lists splitting make combinators.short-circuit namespaces grouping splitting.monotonic ; IN: wrap @@ -12,18 +12,12 @@ C: element : element-length ( element -- n ) [ black>> ] [ white>> ] bi + ; -TUPLE: paragraph lines head-width tail-cost ; +TUPLE: paragraph line-max line-ideal lines head-width tail-cost ; C: paragraph -SYMBOL: line-max -SYMBOL: line-ideal - -: deviation ( length -- n ) - line-ideal get - sq ; - : top-fits? ( paragraph -- ? ) [ head-width>> ] - [ lines>> 1list? line-ideal line-max ? get ] bi <= ; + [ dup lines>> 1list? [ line-ideal>> ] [ line-max>> ] if ] bi <= ; : fits? ( paragraph -- ? ) ! Make this not count spaces at end @@ -37,7 +31,7 @@ SYMBOL: line-ideal : paragraph-cost ( paragraph -- cost ) dup lines>> 1list? [ drop 0 ] [ - [ head-width>> deviation ] + [ [ head-width>> ] [ line-ideal>> ] bi - sq ] [ tail-cost>> ] bi + ] if ; @@ -45,16 +39,20 @@ SYMBOL: line-ideal [ paragraph-cost ] min-by ; : new-line ( paragraph element -- paragraph ) - [ [ lines>> ] [ 1list ] bi* swons ] - [ nip black>> ] - [ drop paragraph-cost ] 2tri - ; + { + [ drop [ line-max>> ] [ line-ideal>> ] bi ] + [ [ lines>> ] [ 1list ] bi* swons ] + [ nip black>> ] + [ drop paragraph-cost ] + } 2cleave ; : glue ( paragraph element -- paragraph ) - [ [ lines>> unswons ] dip swons swons ] - [ [ head-width>> ] [ element-length ] bi* + ] - [ drop tail-cost>> ] 2tri - ; + { + [ drop [ line-max>> ] [ line-ideal>> ] bi ] + [ [ lines>> unswons ] dip swons swons ] + [ [ head-width>> ] [ element-length ] bi* + ] + [ drop tail-cost>> ] + } 2cleave ; : wrap-step ( paragraphs element -- paragraphs ) [ '[ _ glue ] map ] @@ -62,25 +60,19 @@ SYMBOL: line-ideal 2bi prefix [ fits? ] filter ; -: 1paragraph ( element -- paragraph ) - [ 1list 1list ] - [ black>> ] bi - 0 ; +: 1paragraph ( line-max line-ideal element -- paragraph ) + [ 1list 1list ] [ black>> ] bi 0 ; : post-process ( paragraph -- array ) lines>> [ [ contents>> ] lmap>array ] lmap>array ; -: initialize ( elements -- elements paragraph ) - unclip-slice 1paragraph 1array ; +: initialize ( line-max line-ideal elements -- elements paragraph ) + unclip-slice [ -rot ] dip 1paragraph 1array ; : wrap ( elements line-max line-ideal -- paragraph ) - [ - line-ideal set - line-max set - [ { } ] [ - initialize - [ wrap-step ] reduce - min-cost - post-process - ] if-empty - ] with-scope ; + rot [ 2drop { } ] [ + initialize + [ wrap-step ] reduce + min-cost + post-process + ] if-empty ;