basis/ui/baseline-alignment/baseline-alignment.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays kernel locals math math.order math.vectors
   4 sequences ui.gadgets accessors ;
   5 IN: ui.baseline-alignment
   6
   7 SYMBOL: +baseline+
   8
   9 GENERIC: baseline ( gadget -- y )
  10
  11 M: gadget baseline drop f ;
  12
  13 GENERIC: cap-height ( gadget -- y )
  14
  15 M: gadget cap-height drop f ;
  16
  17 <PRIVATE
  18
  19 ! Text has ascent/descent/cap-height slots, graphics does not.
  20 TUPLE: gadget-metrics height ascent descent cap-height ;
  21
  22 : <gadget-metrics> ( gadget dim -- metrics )
  23     second swap [ baseline ] [ cap-height ] bi
  24     [ dup [ 2dup - ] [ f ] if ] dip
  25     gadget-metrics boa ; inline
  26
  27 : max-ascent ( seq -- n )
  28     0 [ ascent>> [ max ] when* ] reduce ; inline
  29
  30 : max-descent ( seq -- n )
  31     0 [ descent>> [ max ] when* ] reduce ; inline
  32
  33 : max-text-height ( seq -- y )
  34     0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
  35
  36 : max-graphics-height ( seq -- y )
  37     0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
  38
  39 : combine-metrics ( graphics-height ascent descent -- ascent' descent' )
  40     [ [ [-] 2 /i ] keep ] dip [ + ] [ max ] bi-curry* bi ;
  41
  42 PRIVATE>
  43
  44 :: align-baselines ( gadgets -- ys )
  45     gadgets [ dup pref-dim <gadget-metrics> ] map
  46     dup max-ascent :> max-ascent
  47     dup max-graphics-height :> max-height
  48     max-height max-ascent [-] 2 /i :> offset-text
  49     max-ascent max-height [-] 2 /i :> offset-graphics
  50     [
  51         dup ascent>> [
  52             ascent>>
  53             max-ascent
  54             offset-text
  55         ] [
  56             height>>
  57             max-height
  58             offset-graphics
  59         ] if [ swap - ] dip +
  60     ] map ;
  61
  62 : measure-metrics ( children sizes -- ascent descent )
  63     [ <gadget-metrics> ] 2map
  64     [ max-graphics-height ] [ max-ascent ] [ max-descent ] tri
  65     combine-metrics ;
  66
  67 : measure-height ( children sizes -- height )
  68     measure-metrics + ;