From c811c423c3a61d8ac0d4de7e7291d4393869d6d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Sep 2005 21:00:49 +0000 Subject: [PATCH] fix typo in scrolling code --- library/collections/sequences-epilogue.factor | 13 ++++++--- library/compiler/intrinsics.factor | 2 +- library/inference/branches.factor | 4 +-- library/inference/call-optimizers.factor | 2 +- library/inference/inline-methods.factor | 2 +- library/test/kernel.factor | 2 +- library/test/sequences.factor | 29 +++++-------------- library/ui/scrolling.factor | 17 ++++++----- 8 files changed, 33 insertions(+), 38 deletions(-) diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 83ef63fdb4..1c19ad098d 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -89,10 +89,15 @@ M: object find ( seq quot -- i elt ) : subset-with ( obj seq quot -- seq | quot: obj elt -- ? ) swap [ with rot ] subset 2nip ; inline -: every? ( seq quot -- ? | quot: elt elt -- ? ) - #! Tests if all elements are equivalent under the relation. - over empty? - [ 2drop t ] [ >r [ first ] keep r> all-with? ] ifte ; inline +: (monotonic) ( quot seq i -- ? ) + 2dup 1 + swap nth >r swap nth r> rot call ; inline + +: monotonic? ( seq quot -- ? | quot: elt elt -- ? ) + #! Eg, { 1 2 3 4 } [ < ] monotonic? ==> t + #! { 1 3 2 4 } [ < ] monotonic? ==> f + swap dup length 1 - [ + pick pick >r >r (monotonic) r> r> rot + ] all? 2nip ; inline ! Operations M: object like drop ; diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index 1330b3a280..cfeb6f8f92 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -63,7 +63,7 @@ sequences vectors words ; : value-tag ( value node -- n/f ) #! If the tag is known, output it, otherwise f. node-classes hash dup [ - types [ type-tag ] map dup [ = ] every? + types [ type-tag ] map dup [ = ] monotonic? [ first ] [ drop f ] ifte ] [ drop f diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 52394eb2ed..2543350a00 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -16,7 +16,7 @@ namespaces parser prettyprint sequences strings vectors words ; : unify-values ( seq -- value ) #! If all values in list are equal, return the value. #! Otherwise, unify. - dup [ eq? ] every? [ first ] [ ] ifte ; + dup [ eq? ] monotonic? [ first ] [ ] ifte ; : unify-stacks ( seq -- stack ) #! Replace differing literals in stacks with unknown @@ -24,7 +24,7 @@ namespaces parser prettyprint sequences strings vectors words ; unify-lengths flip [ unify-values ] map ; : balanced? ( in out -- ? ) - [ swap length swap length - ] 2map [ = ] every? ; + [ swap length swap length - ] 2map [ = ] monotonic? ; : unify-effect ( in out -- in out ) 2dup balanced? diff --git a/library/inference/call-optimizers.factor b/library/inference/call-optimizers.factor index 6d981787f1..f4768b2e9f 100644 --- a/library/inference/call-optimizers.factor +++ b/library/inference/call-optimizers.factor @@ -65,7 +65,7 @@ SYMBOL: @ ] 2map conjunction ; : values-match? ( values template -- ? ) - [ @ = [ drop f ] unless ] 2map [ ] subset [ eq? ] every? ; + [ @ = [ drop f ] unless ] 2map [ ] subset [ eq? ] monotonic? ; : apply-identity? ( values identity -- ? ) first 2dup literals-match? >r values-match? r> and ; diff --git a/library/inference/inline-methods.factor b/library/inference/inline-methods.factor index d8e67ab1d8..81486d7778 100644 --- a/library/inference/inline-methods.factor +++ b/library/inference/inline-methods.factor @@ -34,7 +34,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ; dup dispatching-classes dup empty? [ 2drop f ] [ - dup [ = ] every? [ + dup [ = ] monotonic? [ first swap node-param order min-class ] [ 2drop f diff --git a/library/test/kernel.factor b/library/test/kernel.factor index 7fbf2dc8b1..1b5c4fe768 100644 --- a/library/test/kernel.factor +++ b/library/test/kernel.factor @@ -2,4 +2,4 @@ IN: scratchpad USING: kernel memory sequences test ; [ 0 ] [ f size ] unit-test -[ t ] [ [ \ = \ = ] [ = ] every? ] unit-test +[ t ] [ [ \ = \ = ] [ = ] monotonic? ] unit-test diff --git a/library/test/sequences.factor b/library/test/sequences.factor index 2fbdfbf5d0..c66801e987 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -72,12 +72,13 @@ unit-test [ [ "a" 43 [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test -[ f ] [ [ { } { } "Hello" ] [ = ] every? ] unit-test -[ f ] [ [ { 2 } { } { } ] [ = ] every? ] unit-test -[ t ] [ [ ] [ = ] every? ] unit-test -[ t ] [ [ 1/2 ] [ = ] every? ] unit-test -[ t ] [ [ 1.0 10/10 1 ] [ = ] every? ] unit-test - +[ f ] [ [ { } { } "Hello" ] [ = ] monotonic? ] unit-test +[ f ] [ [ { 2 } { } { } ] [ = ] monotonic? ] unit-test +[ t ] [ [ ] [ = ] monotonic? ] unit-test +[ t ] [ [ 1/2 ] [ = ] monotonic? ] unit-test +[ t ] [ [ 1.0 10/10 1 ] [ = ] monotonic? ] unit-test +[ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test +[ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test [ [ 2 3 4 ] ] [ 1 [ 1 2 3 ] [ + ] map-with ] unit-test [ 1 ] [ 0 [ 1 2 ] nth ] unit-test @@ -148,23 +149,9 @@ unit-test [ [ ] ] [ [ ] number-sort ] unit-test -: pairs ( seq quot -- ) - swap dup length 1 - [ - [ 2dup 1 + swap nth >r swap nth r> rot call ] 3keep - ] repeat 2drop ; - -: map-pairs ( seq quot -- seq | quot: elt -- elt ) - over [ - length 1 - rot - [ 2swap [ slip push ] 2keep ] pairs nip - ] keep like ; inline - -: sorted? ( seq quot -- ? ) - map-pairs [ 0 <= ] all? ; - [ t ] [ 100 [ drop - 1000 [ drop 0 1000 random-int ] map number-sort [ - ] sorted? + 1000 [ drop 0 1000 random-int ] map number-sort [ <= ] monotonic? ] all? ] unit-test diff --git a/library/ui/scrolling.factor b/library/ui/scrolling.factor index 2ef1abe698..9444a96cfc 100644 --- a/library/ui/scrolling.factor +++ b/library/ui/scrolling.factor @@ -43,18 +43,21 @@ M: viewport pref-dim gadget-child pref-dim ; 2dup over scroller-x update-slider over scroller-y update-slider ; +: (scroll>bottom) ( viewport scroller -- ) + over viewport-bottom? [ + f pick set-viewport-bottom? + 2dup swap viewport-dim scroll + ] when 2drop ; + : update-scroller ( scroller -- ) dup scroller-origin scroll ; : update-viewport ( viewport scroller -- ) - over viewport-bottom? [ - f pick set-viewport-bottom? - over viewport-dim - ] [ - dup scroller-origin - ] ifte vneg nip swap gadget-child dup prefer set-rect-loc ; + scroller-origin vneg + swap gadget-child dup prefer set-rect-loc ; M: viewport layout* ( viewport -- ) - dup find-scroller dup update-scroller update-viewport ; + dup find-scroller dup update-scroller + 2dup (scroll>bottom) update-viewport ; M: viewport focusable-child* ( viewport -- gadget ) gadget-child ;