math.rectangles.positioning: New popup-rect word

basis/math/rectangles/positioning/positioning-tests.factor

@@ -3,44 +3,51 @@
 USING: tools.test math.rectangles math.rectangles.positioning ;
 IN: math.rectangles.positioning.tests
 
-[ { 0 1 } ] [
+[ T{ rect f { 0 1 } { 30 30 } } ] [
     { 0 0 } { 1 1 } <rect>
     { 30 30 }
     { 100 100 }
-    popup-loc
+    popup-rect
 ] unit-test
 
-[ { 10 21 } ] [
+[ T{ rect f { 10 21 } { 30 30 } } ] [
     { 10 20 } { 1 1 } <rect>
     { 30 30 }
     { 100 100 }
-    popup-loc
+    popup-rect
 ] unit-test
 
-[ { 10 30 } ] [
+[ T{ rect f { 10 30 } { 30 30 } } ] [
     { 10 20 } { 1 10 } <rect>
     { 30 30 }
     { 100 100 }
-    popup-loc
+    popup-rect
 ] unit-test
 
-[ { 20 20 } ] [
+[ T{ rect f { 20 20 } { 80 30 } } ] [
     { 40 10 } { 1 10 } <rect>
     { 80 30 }
     { 100 100 }
-    popup-loc
+    popup-rect
 ] unit-test
 
-[ { 50 20 } ] [
+[ T{ rect f { 50 20 } { 50 50 } } ] [
     { 50 70 } { 0 0 } <rect>
     { 50 50 }
     { 100 100 }
-    popup-loc
+    popup-rect
 ] unit-test
 
-[ { 0 20 } ] [
+[ T{ rect f { 0 20 } { 50 50 } } ] [
     { -50 70 } { 0 0 } <rect>
     { 50 50 }
     { 100 100 }
-    popup-loc
+    popup-rect
+] unit-test
+
+[ T{ rect f { 0 50 } { 50 50 } } ] [
+    { 0 50 } { 0 0 } <rect>
+    { 50 60 }
+    { 100 100 }
+    popup-rect
 ] unit-test

basis/math/rectangles/positioning/positioning.factor

@@ -1,6 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel accessors math math.order arrays ;
+USING: sequences kernel accessors math math.vectors
+math.rectangles math.order arrays locals
+combinators.short-circuit ;
 IN: math.rectangles.positioning
 
 ! Some geometry code for positioning popups and menus
@@ -15,11 +17,21 @@ IN: math.rectangles.positioning
 : alternate-y ( visible-rect popup-dim -- y )
     [ loc>> ] dip [ second ] bi@ - ;
 
-: popup-fits? ( visible-rect popup-dim screen-dim -- ? )
+: preferred-fit? ( visible-rect popup-dim screen-dim -- ? )
     [ [ preferred-y ] [ second ] bi* + ] dip second < ;
 
+: alternate-fit? ( visible-rect popup-dim -- ? )
+    alternate-y 0 >= ;
+
 : popup-y ( visible-rect popup-dim screen-dim -- y )
-    3dup popup-fits? [ 2drop preferred-y ] [ drop alternate-y ] if ;
+    3dup { [ preferred-fit? not ] [ drop alternate-fit? ] } 3&&
+    [ drop alternate-y ] [ 2drop preferred-y ] if ;
 
 : popup-loc ( visible-rect popup-dim screen-dim -- loc )
     [ popup-x ] [ popup-y ] 3bi 2array ;
+
+:: popup-dim ( loc popup-dim screen-dim -- dim )
+    screen-dim loc v- popup-dim vmin ;
+
+: popup-rect ( visible-rect popup-dim screen-dim -- rect )
+    [ popup-loc dup ] 2keep popup-dim <rect> ;