From c47f8feaab6b2753271117a3ba1a2a573423d7ac Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 13 Jan 2009 19:09:47 -0600
Subject: [PATCH] Clean up scroller code, and fix a cosmetic issue
---
basis/ui/gadgets/scrollers/scrollers.factor | 11 +++---
basis/ui/gadgets/viewports/viewports.factor | 39 +++++++++++++--------
2 files changed, 30 insertions(+), 20 deletions(-)
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 37f6e83e0c..93f6b8bb40 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -37,13 +37,14 @@ scroller H{
new-frame
t >>root?
<scroller-model> >>model
- faint-boundary
- dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
- dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
+ dup model>> dependencies>>
+ [ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ]
+ [ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi
- tuck model>> <viewport> >>viewport
- dup viewport>> @center grid-add ; inline
+ tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi
+
+ faint-boundary ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor
index f01ef3bf42..73782a1e3d 100644
--- a/basis/ui/gadgets/viewports/viewports.factor
+++ b/basis/ui/gadgets/viewports/viewports.factor
@@ -1,18 +1,23 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: ui.gadgets.viewports
USING: accessors arrays ui.gadgets ui.gadgets.borders
-kernel math namespaces sequences models math.vectors math.geometry.rect ;
+kernel math namespaces sequences models math.vectors
+math.geometry.rect ;
+IN: ui.gadgets.viewports
-: viewport-gap { 3 3 } ; inline
+CONSTANT: viewport-gap { 3 3 }
+CONSTANT: scroller-border { 1 1 }
TUPLE: viewport < gadget ;
: find-viewport ( gadget -- viewport )
[ viewport? ] find-parent ;
+: viewport-padding ( -- padding )
+ viewport-gap 2 v*n scroller-border v+ ;
+
: viewport-dim ( viewport -- dim )
- gadget-child pref-dim viewport-gap 2 v*n v+ ;
+ gadget-child pref-dim viewport-padding v+ ;
: <viewport> ( content model -- viewport )
viewport new-gadget
@@ -21,11 +26,11 @@ TUPLE: viewport < gadget ;
swap add-gadget ;
M: viewport layout*
- [
- [ rect-dim viewport-gap 2 v*n v- ]
+ [ gadget-child ] [
+ [ dim>> viewport-padding v- ]
[ gadget-child pref-dim ]
bi vmax
- ] [ gadget-child ] bi (>>dim) ;
+ ] bi >>dim drop ;
M: viewport focusable-child*
gadget-child ;
@@ -37,13 +42,17 @@ M: viewport pref-dim* viewport-dim ;
M: viewport model-changed
nip
- dup relayout-1
- dup scroller-value
- vneg viewport-gap v+
- swap gadget-child (>>loc) ;
+ [ relayout-1 ]
+ [
+ [ gadget-child ]
+ [
+ scroller-value vneg
+ viewport-gap v+
+ scroller-border v+
+ ] bi
+ >>loc drop
+ ] bi ;
: visible-dim ( gadget -- dim )
dup parent>> viewport?
- [ parent>> rect-dim viewport-gap 2 v*n v- ]
- [ rect-dim ]
- if ;
+ [ parent>> rect-dim viewport-gap 2 v*n v- ] [ dim>> ] if ;