basis/ui/gadgets/borders/borders.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors fry kernel math math.rectangles math.vectors
   4 opengl sequences ui.baseline-alignment ui.gadgets ;
   5 IN: ui.gadgets.borders
   6
   7 TUPLE: border < aligned-gadget
   8     { size initial: { 0 0 } }
   9     { fill initial: { 0 0 } }
  10     { align initial: { 1/2 1/2 } }
  11     { min-dim initial: { 0 0 } } ;
  12
  13 : new-border ( child class -- border )
  14     new swap add-gadget ; inline
  15
  16 : <border> ( child gap -- border )
  17     [ border new-border ] dip >>size ;
  18
  19 : <filled-border> ( child gap -- border )
  20     <border> { 1 1 } >>fill ;
  21
  22 : border-pref-dim ( border child-dim -- pref-dim )
  23     '[ size>> 2 v*n _ v+ ] [ min-dim>> ] bi vmax [ gl-round ] map ;
  24
  25 M: border pref-dim*
  26     dup gadget-child pref-dim border-pref-dim ;
  27
  28 <PRIVATE
  29
  30 : border-major-dim ( border -- dim )
  31     [ dim>> ] [ size>> 2 v*n ] bi v- ;
  32
  33 : border-minor-dim ( border -- dim )
  34     gadget-child pref-dim ;
  35
  36 : scale ( a b s -- c )
  37     [ v* ] [ { 1 1 } swap v- v* ] bi-curry bi* v+ ;
  38
  39 : border-dim ( border -- dim )
  40     [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
  41
  42 : border-loc ( border dim -- loc )
  43     [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
  44     v- v* v+ [ >fixnum ] map ;
  45
  46 : border-child-rect ( border -- rect )
  47     dup border-dim [ border-loc ] keep <rect> ;
  48
  49 : border-metric ( border quot -- n )
  50     [ drop size>> second ] [ [ gadget-child ] dip call ] 2bi
  51     dup [ + ] [ nip ] if ; inline
  52
  53 PRIVATE>
  54
  55 M: border baseline* [ baseline ] border-metric ;
  56
  57 M: border cap-height* [ cap-height ] border-metric ;
  58
  59 M: border layout*
  60     [ border-child-rect ] [ gadget-child ] bi set-rect-bounds ;
  61
  62 M: border focusable-child*
  63     gadget-child ;