basis/ui/gadgets/frames/frames.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays generic kernel math namespaces sequences
   4 words splitting grouping math.vectors ui.gadgets.grids
   5 ui.gadgets.grids.private ui.gadgets math.order math.rectangles
   6 fry ;
   7 IN: ui.gadgets.frames
   8
   9 TUPLE: frame < grid filled-cell ;
  10
  11 <PRIVATE
  12
  13 TUPLE: glue < gadget ;
  14
  15 M: glue pref-dim* drop { 0 0 } ;
  16
  17 : <glue> ( -- glue ) glue new ;
  18
  19 : <frame-grid> ( cols rows -- grid )
  20     swap '[ _ [ <glue> ] replicate ] replicate ;
  21
  22 : (fill- ( frame grid-layout quot1 quot2 -- pref-dim gap filled-cell dims )
  23     [ '[ [ dim>> ] [ gap>> ] [ filled-cell>> ] tri _ tri@ ] dip ] dip call ; inline
  24
  25 : available-space ( pref-dim gap dims -- avail )
  26     length 1 + * [-] ; inline
  27
  28 : -center) ( pref-dim gap filled-cell dims -- )
  29     [ nip available-space ] 2keep [ remove-nth sum [-] ] 2keep set-nth ; inline
  30
  31 : (fill-center) ( frame grid-layout quot1 quot2 -- ) (fill- -center) ; inline
  32
  33 : fill-center ( frame grid-layout -- )
  34     [ [ first ] [ column-widths>> ] (fill-center) ]
  35     [ [ second ] [ row-heights>> ] (fill-center) ] 2bi ;
  36
  37 : <frame-layout> ( frame -- grid-layout )
  38     dup <grid-layout> [ fill-center ] keep ;
  39
  40 PRIVATE>
  41
  42 M: frame layout*
  43     [ grid>> ] [ <frame-layout> ] bi grid-layout ;
  44
  45 : new-frame ( cols rows class -- frame )
  46     [ <frame-grid> ] dip new-grid ; inline
  47
  48 : <frame> ( cols rows -- frame )
  49     frame new-frame ;