Refactor ui.gadgets.paragraphs to use wrap

basis/ui/gadgets/packs/packs.factor

@@ -28,8 +28,10 @@ TUPLE: pack < gadget
     [ align>> ] [ dim>> ] bi '[ [ _ _ ] dip v- n*v ] map ;
 
 : baseline-aligned-locs ( pack -- seq )
-    children>> [ baseline ] map [ supremum ] keep
+    children>> [ { } ] [
-    [ - 0 swap 2array ] with map ;
+        [ baseline ] map [ supremum ] keep
+        [ - 0 swap 2array ] with map
+    ] if-empty ;
 
 : aligned-locs ( sizes pack -- seq )
     dup align>> +baseline+ eq?
@@ -77,7 +79,7 @@ M: pack pref-dim*
     children>> [ 0 ] [ first baseline ] if-empty ;
 
 : horizontal-baseline ( pack -- y )
-    children>> [ baseline ] map supremum ;
+    children>> [ baseline ] [ max ] map-reduce ;
 
 PRIVATE>
 

basis/ui/gadgets/paragraphs/paragraphs-tests.factor

@@ -0,0 +1,31 @@
+IN: ui.gadgets.paragraphs.tests
+USING: ui.gadgets.paragraphs ui.gadgets.paragraphs.private
+ui.gadgets accessors tools.test namespaces sequences kernel ;
+
+TUPLE: fake-break < gadget ;
+
+: <fake-break> ( -- gadget ) fake-break new-gadget { 5 5 } >>dim ;
+
+INSTANCE: fake-break word-break
+
+100 <paragraph>
+<gadget> { 40 30 } >>dim dup "a" set add-gadget
+<fake-break> add-gadget
+<gadget> { 40 15 } >>dim dup "b" set add-gadget
+<fake-break> add-gadget
+<gadget> { 50 20 } >>dim dup "c" set add-gadget
+"p" set
+
+[ { 4 1 } ] [ "p" get wrap-paragraph [ length ] map ] unit-test
+
+[ { 85 50 } ] [ "p" get pref-dim ] unit-test
+
+[ ] [ "p" get prefer ] unit-test
+
+[ ] [ "p" get layout ] unit-test
+
+[ { 0 0 } ] [ "a" get loc>> ] unit-test
+
+[ { 45 0 } ] [ "b" get loc>> ] unit-test
+
+[ { 0 30 } ] [ "c" get loc>> ] unit-test

basis/ui/gadgets/paragraphs/paragraphs.factor

@@ -1,10 +1,11 @@
-! Copyright (C) 2005, 2008 Slava Pestov
+! Copyright (C) 2005, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gadgets ui.gadgets.labels ui.render
+USING: accessors kernel math math.order sequences wrap arrays fry
-kernel math namespaces sequences math.order math.geometry.rect
+ui.gadgets ui.gadgets.labels ui.render ;
-locals ;
 IN: ui.gadgets.paragraphs
 
+MIXIN: word-break
+
 ! A word break gadget
 TUPLE: word-break-gadget < label ;
 
@@ -13,6 +14,8 @@ TUPLE: word-break-gadget < label ;
 
 M: word-break-gadget draw-gadget* drop ;
 
+INSTANCE: word-break-gadget word-break
+
 ! A gadget that arranges its children in a word-wrap style.
 TUPLE: paragraph < gadget margin ;
 
@@ -21,60 +24,43 @@ TUPLE: paragraph < gadget margin ;
     horizontal >>orientation
     swap >>margin ;
 
-SYMBOL: x SYMBOL: max-x
+<PRIVATE
 
-SYMBOL: y SYMBOL: max-y
+: gadget>word ( gadget -- word )
+    [ ] [ pref-dim first ] [ word-break? ] tri <word> ;
 
-SYMBOL: line-height
+: wrap-paragraph ( paragraph -- wrapped-paragraph )
+    [ children>> [ gadget>word ] map ] [ margin>> ] bi wrap ;
 
-SYMBOL: margin
+: line-width ( wrapped-line -- n )
+    [ break?>> ] trim-tail-slice [ width>> ] sigma ;
 
-: overrun? ( width -- ? ) x get + margin get > ;
+: max-line-width ( wrapped-paragraph -- x )
+    [ line-width ] [ max ] map-reduce ;
 
-: zero-vars ( seq -- ) [ 0 swap set ] each ;
+: line-height ( wrapped-line -- ys )
+    [ key>> pref-dim second ] [ max ] map-reduce ;
 
-: wrap-line ( -- )
+: sum-line-heights ( wrapped-paragraph -- y )
-    line-height get y +@
+    [ line-height ] sigma ;
-    { x line-height } zero-vars ;
-
-: wrap-pos ( -- pos ) x get y get 2array ; inline
-
-: advance-x ( x -- )
-    x +@
-    x get max-x [ max ] change ;
-
-: advance-y ( y -- )
-    dup line-height [ max ] change
-    y get + max-y [ max ] change ;
-
-:: wrap-step ( quot child -- )
-    child pref-dim
-    [
-        child
-        [
-            word-break-gadget?
-            [ drop ] [ first overrun? [ wrap-line ] when ] if
-        ]
-        [ wrap-pos quot call ] bi
-    ]
-    [ first advance-x ]
-    [ second advance-y ]
-    tri ; inline
-
-: wrap-dim ( -- dim ) max-x get max-y get 2array ;
-
-: init-wrap ( paragraph -- )
-    margin>> margin set
-    { x max-x y max-y line-height } zero-vars ;
-
-: do-wrap ( paragraph quot -- dim )
-    [
-        swap dup init-wrap
-        [ wrap-step ] with each-child wrap-dim
-    ] with-scope ; inline
 
 M: paragraph pref-dim*
-    [ 2drop ] do-wrap ;
+    wrap-paragraph [ max-line-width ] [ sum-line-heights ] bi 2array ;
+
+: line-y-coordinates ( wrapped-paragraph -- ys )
+    0 [ line-height + ] accumulate nip ;
+
+: word-x-coordinates ( wrapped-line -- xs )
+    0 [ width>> + ] accumulate nip ;
+
+: layout-word ( word x y -- )
+    [ key>> ] 2dip 2array >>loc prefer ;
+
+: layout-line ( wrapped-line y -- )
+    [ dup word-x-coordinates ] dip '[ _ layout-word ] 2each ;
 
 M: paragraph layout*
-    [ swap dup prefer (>>loc) ] do-wrap drop ;
+    wrap-paragraph dup line-y-coordinates
+    [ layout-line ] 2each ;
+
+PRIVATE>