<commit_before>! Copyright (C) 2005, 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models models.range models.compose combinators math.vectors
classes.tuple math.rectangles combinators.short-circuit ;
IN: ui.gadgets.scrollers

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 ;

: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;

: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;

: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;

: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;

<PRIVATE

: do-mouse-scroll ( scroller -- )
    scroll-direction get-global
    [ first swap x>> slide-by-line ]
    [ second swap y>> slide-by-line ]
    2bi ;

scroller H{
    { mouse-scroll [ do-mouse-scroll ] }
} set-gestures

: <scroller-model> ( -- model )
    0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;

M: viewport pref-dim* gadget-child pref-viewport-dim ;

: scroll ( value scroller -- )
    [
        viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
        4array flip
    ] keep
    2dup control-value = [ 2drop ] [ set-control-value ] if ;

: (scroll>rect) ( rect scroller -- )
    [ [ loc>> ] [ dim>> ] bi <rect> ] dip
    {
        [ scroller-value vneg offset-rect ]
        [ viewport>> dim>> rect-min ]
        [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
        [ scroller-value v+ ]
        [ scroll ]
    } cleave ;

: relative-scroll-rect ( rect gadget scroller -- newrect )
    viewport>> gadget-child relative-loc offset-rect ;

: find-scroller* ( gadget -- scroller/f )
    dup find-scroller
    { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
    2&& ;

: (update-scroller) ( scroller -- )
    [ scroller-value ] keep scroll ;

: (scroll>gadget) ( gadget scroller -- )
    2dup swap child? [<commit_msg>Fix scroll>rect flaw<commit_after>! Copyright (C) 2005, 2009 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models models.range models.compose combinators math.vectors
classes.tuple math.rectangles combinators.short-circuit ;
IN: ui.gadgets.scrollers

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 ;

: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;

: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;

: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;

: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;

<PRIVATE

: do-mouse-scroll ( scroller -- )
    scroll-direction get-global
    [ first swap x>> slide-by-line ]
    [ second swap y>> slide-by-line ]
    2bi ;

scroller H{
    { mouse-scroll [ do-mouse-scroll ] }
} set-gestures

: <scroller-model> ( -- model )
    0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;

M: viewport pref-dim* gadget-child pref-viewport-dim ;

: scroll ( value scroller -- )
    [
        viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
        4array flip
    ] keep
    2dup control-value = [ 2drop ] [ set-control-value ] if ;

: (scroll>rect) ( rect scroller -- )
    [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
    {
        [ scroller-value vneg offset-rect ]
        [ viewport>> dim>> rect-min ]
        [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
        [ scroller-value v+ ]
        [ scroll ]
    } cleave ;

: relative-scroll-rect ( rect gadget scroller -- newrect )
    viewport>> gadget-child relative-loc offset-rect ;

: find-scroller* ( gadget -- scroller/f )
    dup find-scroller
    { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
    2&& ;

: (update-scroller) ( scroller -- )
    [ scroller-value ] keep scroll ;

: (scroll>gadget) ( gadget scroller -- )
    2dup swap child? [
{'fraction_non_alphanumeric': 0.14378238341968913, 'fraction_numerical': 0.01468048359240069, 'mean_word_length': 2.6595576619273302, 'pattern_counts': {'":': 0, '<': 19, '<?xml version=': 0, '>': 80, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5990321', 'n_tokens_mistral': 1681, 'n_tokens_neox': 1635, 'n_words': 423}