From e80ab7d28be79932d7fb9a4076baf36a28b713c0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 16 Feb 2009 04:24:14 -0600
Subject: [PATCH] ui.gadgets.scrollers: add support for column headers

---
 basis/ui/gadgets/scrollers/scrollers.factor | 51 ++++++++++++++++-----
 basis/ui/gadgets/viewports/viewports.factor | 13 ++++--
 2 files changed, 48 insertions(+), 16 deletions(-)

diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 5162e2c635..38986e5657 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -7,13 +7,17 @@ models models.range models.compose combinators math.vectors
 classes.tuple math.rectangles combinators.short-circuit ;
 IN: ui.gadgets.scrollers
 
-TUPLE: scroller < frame viewport x y follows ;
+TUPLE: scroller < frame column-header viewport x y follows ;
 
 ! Scrollable gadget protocol; optional
 GENERIC: pref-viewport-dim ( gadget -- dim )
 
 M: gadget pref-viewport-dim pref-dim ;
 
+GENERIC: viewport-column-header ( gadget -- gadget/f )
+
+M: gadget viewport-column-header drop f ;
+
 : find-scroller ( gadget -- scroller/f )
     [ scroller? ] find-parent ;
 
@@ -102,20 +106,43 @@ M: scroller focusable-child*
 M: scroller model-changed
     f >>follows 2drop ;
 
+: build-scroller ( scroller -- scroller )
+    dup x>> { 0 1 } grid-add
+    dup y>> { 1 0 } grid-add
+    dup viewport>> { 0 0 } grid-add ; inline
+
+: <column-header-viewport> ( scroller -- viewport )
+    [ column-header>> ] [ model>> ] bi
+    <viewport> horizontal >>constraint ;
+
+: build-header-scroller ( scroller -- scroller )
+    dup <column-header-viewport> { 0 0 } grid-add
+    dup x>> { 0 2 } grid-add
+    dup y>> { 1 1 } grid-add
+    dup viewport>> { 0 1 } grid-add ; inline
+
+: init-scroller ( column-header scroller -- scroller )
+    { 1 1 } >>gap
+    over { 0 1 } { 0 0 } ? >>filled-cell
+    t >>root?
+    <scroller-model> >>model
+    swap >>column-header ; inline
+
+: build-children ( gadget scroller -- scroller )
+    dup model>> dependencies>>
+    [ first horizontal <slider> >>x ]
+    [ second vertical <slider> >>y ] bi
+    [ nip ] [ model>> <viewport> ] 2bi >>viewport ; inline
+
 PRIVATE>
 
 : <scroller> ( gadget -- scroller )
-    2 2 scroller new-frame
-        { 1 1 } >>gap
-        { 0 0 } >>filled-cell
-        t >>root?
-        <scroller-model> >>model
-
-        dup model>> dependencies>>
-        [ first horizontal <slider> [ >>x ] [ { 0 1 } grid-add ] bi ]
-        [ second vertical <slider> [ >>y ] [ { 1 0 } grid-add ] bi ] bi
-
-        tuck model>> <viewport> [ >>viewport ] [ { 0 0 } grid-add ] bi ; inline
+    dup viewport-column-header
+    dup [ 2 3 ] [ 2 2 ] if scroller new-frame
+        init-scroller
+        build-children
+        dup column-header>>
+        [ build-header-scroller ] [ build-scroller ] if ;
 
 : scroll>rect ( rect gadget -- )
     dup find-scroller* dup [
diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor
index d5581f2c23..c14c7f01fb 100644
--- a/basis/ui/gadgets/viewports/viewports.factor
+++ b/basis/ui/gadgets/viewports/viewports.factor
@@ -5,13 +5,13 @@ kernel math namespaces sequences models math.vectors
 math.rectangles ;
 IN: ui.gadgets.viewports
 
-TUPLE: viewport < gadget ;
+TUPLE: viewport < gadget { constraint initial: { 1 1 } } ;
 
 : find-viewport ( gadget -- viewport )
     [ viewport? ] find-parent ;
 
 : <viewport> ( content model -- viewport )
-    viewport new-gadget
+    viewport new
         swap >>model
         t >>clipped?
         swap add-gadget ;
@@ -24,12 +24,17 @@ M: viewport focusable-child*
     gadget-child ;
 
 : scroller-value ( scroller -- loc )
-    model>> range-value [ >fixnum ] map ;
+    model>> range-value [ >integer ] map ;
 
 M: viewport model-changed
     nip
     [ relayout-1 ]
-    [ [ gadget-child ] [ scroller-value vneg ] bi >>loc drop ] bi ;
+    [
+        [ gadget-child ]
+        [ scroller-value vneg ]
+        [ constraint>> ]
+        tri v* >>loc drop
+    ] bi ;
 
 : visible-dim ( gadget -- dim )
     dup parent>> viewport? [ parent>> ] when dim>> ;