basis/ui/gadgets/borders/borders.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays ui.gadgets kernel math
   4 namespaces vectors sequences math.vectors math.geometry.rect ;
   5 IN: ui.gadgets.borders
   6
   7 TUPLE: border < gadget
   8 { size initial: { 0 0 } }
   9 { fill initial: { 0 0 } }
  10 { align initial: { 1/2 1/2 } } ;
  11
  12 : new-border ( child class -- border )
  13     new-gadget swap add-gadget ; inline
  14
  15 : <border> ( child gap -- border )
  16     swap border new-border
  17         swap dup 2array >>size ;
  18
  19 : <filled-border> ( child gap -- border )
  20     <border> { 1 1 } >>fill ;
  21
  22 M: border pref-dim*
  23     [ size>> 2 v*n ] keep
  24     gadget-child pref-dim v+ ;
  25
  26 : border-major-dim ( border -- dim )
  27     [ dim>> ] [ size>> 2 v*n ] bi v- ;
  28
  29 : border-minor-dim ( border -- dim )
  30     gadget-child pref-dim ;
  31
  32 : scale ( a b s -- c )
  33     tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
  34
  35 : border-dim ( border -- dim )
  36     [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
  37
  38 : border-loc ( border dim -- loc )
  39     [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
  40     v- v* v+ [ >fixnum ] map ;
  41
  42 : border-child-rect ( border -- rect )
  43     dup border-dim [ border-loc ] keep <rect> ;
  44
  45 M: border layout*
  46     dup border-child-rect swap gadget-child
  47     over loc>> >>loc
  48     swap dim>> >>dim
  49     drop ;
  50
  51 M: border focusable-child*
  52     gadget-child ;