basis/math/rectangles/positioning/positioning.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences kernel accessors math math.vectors
   4 math.rectangles math.order arrays locals fry
   5 combinators.short-circuit ;
   6 IN: math.rectangles.positioning
   7
   8 ! Some geometry code for positioning popups and menus
   9 ! in a semi-intelligent manner
  10
  11 <PRIVATE
  12
  13 : adjust-visible-rect ( visible-rect popup-dim screen-dim -- visible-rect' )
  14     [ drop clone ] dip '[ _ vmin ] change-loc ;
  15
  16 : popup-x ( visible-rect popup-dim screen-dim -- x )
  17     [ loc>> first ] 2dip swap [ first ] bi@ - min 0 max ;
  18
  19 : preferred-y ( visible-rect -- y )
  20     rect-bounds [ second ] bi@ + ;
  21
  22 : alternate-y ( visible-rect popup-dim -- y )
  23     [ loc>> ] dip [ second ] bi@ - ;
  24
  25 : preferred-fit? ( visible-rect popup-dim screen-dim -- ? )
  26     [ [ preferred-y ] [ second ] bi* + ] dip second < ;
  27
  28 : alternate-fit? ( visible-rect popup-dim -- ? )
  29     alternate-y 0 >= ;
  30
  31 : popup-y ( visible-rect popup-dim screen-dim -- y )
  32     3dup { [ preferred-fit? not ] [ drop alternate-fit? ] } 3&&
  33     [ drop alternate-y ] [ 2drop preferred-y ] if ;
  34
  35 : popup-loc ( visible-rect popup-dim screen-dim -- loc )
  36     [ popup-x ] [ popup-y ] 3bi 2array ;
  37
  38 :: popup-dim ( loc popup-dim screen-dim -- dim )
  39     screen-dim loc v- popup-dim vmin ;
  40
  41 PRIVATE>
  42
  43 : popup-rect ( visible-rect popup-dim screen-dim -- rect )
  44     [ adjust-visible-rect ] 2keep
  45     [ popup-loc dup ] 2keep popup-dim <rect> ;