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.functions math.order math.vectors
   4 sequences ui.gadgets accessors combinators ;
   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 : ?supremum ( seq -- n/f )
  28     sift [ f ] [ supremum ] if-empty ;
  29
  30 : max-ascent ( seq -- n )
  31     [ ascent>> ] map ?supremum ;
  32
  33 : max-cap-height ( seq -- n )
  34     [ cap-height>> ] map ?supremum ;
  35
  36 : max-descent ( seq -- n )
  37     [ descent>> ] map ?supremum ;
  38
  39 : max-text-height ( seq -- y )
  40     [ ascent>> ] filter [ height>> ] map ?supremum ;
  41
  42 : max-graphics-height ( seq -- y )
  43     [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
  44
  45 :: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
  46     ascent [
  47         cap-height 2 / :> mid-line
  48         graphics-height 2 /
  49         [ ascent mid-line - max mid-line + floor >integer ]
  50         [ descent mid-line + max mid-line - ceiling >integer ] bi
  51     ] [ f f ] if ;
  52
  53 : (measure-metrics) ( children sizes -- graphics-height ascent descent cap-height )
  54     [ <gadget-metrics> ] 2map
  55     {
  56         [ max-graphics-height ]
  57         [ max-ascent ]
  58         [ max-descent ]
  59         [ max-cap-height ]
  60     } cleave ;
  61
  62 PRIVATE>
  63
  64 :: align-baselines ( gadgets -- ys )
  65     gadgets [ dup pref-dim <gadget-metrics> ] map
  66     dup max-ascent 0 or :> max-ascent
  67     dup max-cap-height 0 or :> max-cap-height
  68     dup max-graphics-height :> max-graphics-height
  69
  70     max-cap-height max-graphics-height + 2 /i :> critical-line
  71     critical-line max-ascent [-] :> text-leading
  72     max-ascent critical-line [-] :> graphics-leading
  73
  74     [
  75         dup ascent>>
  76         [ ascent>> max-ascent swap - text-leading ]
  77         [ height>> max-graphics-height swap - 2/ graphics-leading ] if +
  78     ] map ;
  79
  80 : measure-metrics ( children sizes -- ascent descent )
  81     (measure-metrics) combine-metrics ;
  82
  83 : measure-height ( children sizes -- height )
  84     (measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ;