steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up scroller code, and fix a cosmetic issue

db4
Slava Pestov 2009-01-13 19:09:47 -06:00
parent d06996a6aa
commit c47f8feaab
2 changed files with 30 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
basis/ui/gadgets/scrollers/scrollers.factor
View File

@ -37,13 +37,14 @@ scroller H{
new-frame new-frame
t >>root? t >>root?
<scroller-model> >>model <scroller-model> >>model
faint-boundary
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add dup model>> dependencies>>
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add [ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ]
[ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi
tuck model>> <viewport> >>viewport tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi
dup viewport>> @center grid-add ; inline
faint-boundary ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ; : <scroller> ( gadget -- scroller ) scroller new-scroller ;

39
basis/ui/gadgets/viewports/viewports.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
IN: ui.gadgets.viewports
USING: accessors arrays ui.gadgets ui.gadgets.borders 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 ; TUPLE: viewport < gadget ;
: find-viewport ( gadget -- viewport ) : find-viewport ( gadget -- viewport )
[ viewport? ] find-parent ; [ viewport? ] find-parent ;
: viewport-padding ( -- padding )
viewport-gap 2 v*n scroller-border v+ ;
: viewport-dim ( viewport -- dim ) : 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> ( content model -- viewport )
viewport new-gadget viewport new-gadget
@ -21,11 +26,11 @@ TUPLE: viewport < gadget ;
swap add-gadget ; swap add-gadget ;
M: viewport layout* M: viewport layout*
[ [ gadget-child ] [
[ rect-dim viewport-gap 2 v*n v- ] [ dim>> viewport-padding v- ]
[ gadget-child pref-dim ] [ gadget-child pref-dim ]
bi vmax bi vmax
] [ gadget-child ] bi (>>dim) ; ] bi >>dim drop ;
M: viewport focusable-child* M: viewport focusable-child*
gadget-child ; gadget-child ;
@ -37,13 +42,17 @@ M: viewport pref-dim* viewport-dim ;
M: viewport model-changed M: viewport model-changed
nip nip
dup relayout-1 [ relayout-1 ]
dup scroller-value [
vneg viewport-gap v+ [ gadget-child ]
swap gadget-child (>>loc) ; [
scroller-value vneg
viewport-gap v+
scroller-border v+
] bi
>>loc drop
] bi ;
: visible-dim ( gadget -- dim ) : visible-dim ( gadget -- dim )
dup parent>> viewport? dup parent>> viewport?
[ parent>> rect-dim viewport-gap 2 v*n v- ] [ parent>> rect-dim viewport-gap 2 v*n v- ] [ dim>> ] if ;
[ rect-dim ]
if ;