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

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel locals math math.functions
   4 math.order sequences ui.gadgets ;
   5 IN: ui.baseline-alignment
   6
   7 SYMBOL: +baseline+
   8
   9 TUPLE: aligned-gadget < gadget baseline cap-height ;
  10
  11 GENERIC: baseline* ( gadget -- y )
  12
  13 GENERIC: baseline ( gadget -- y )
  14
  15 M: gadget baseline drop f ;
  16
  17 M: aligned-gadget baseline
  18     [ baseline>> ] [
  19         [ baseline* ] [ ] [ layout-state>> ] tri
  20         [ drop ] [ dupd baseline<< ] if
  21     ] ?unless ;
  22
  23 GENERIC: cap-height* ( gadget -- y )
  24
  25 GENERIC: cap-height ( gadget -- y )
  26
  27 M: gadget cap-height drop f ;
  28
  29 M: aligned-gadget cap-height
  30     [ cap-height>> ] [
  31         [ cap-height* ] [ ] [ layout-state>> ] tri
  32         [ drop ] [ dupd cap-height<< ] if
  33     ] ?unless ;
  34
  35 <PRIVATE
  36
  37 ! Text has ascent/descent/cap-height slots, graphics does not.
  38 TUPLE: gadget-metrics height ascent descent cap-height ;
  39
  40 : <gadget-metrics> ( gadget dim -- metrics )
  41     second swap [ baseline ] [ cap-height ] bi
  42     [ dup [ 2dup - ] [ f ] if ] dip
  43     gadget-metrics boa ; inline
  44
  45 : ?maximum ( seq -- n/f )
  46     sift [ f ] [ maximum ] if-empty ;
  47
  48 : max-ascent ( seq -- n/f )
  49     [ ascent>> ] map ?maximum ;
  50
  51 : max-cap-height ( seq -- n/f )
  52     [ cap-height>> ] map ?maximum ;
  53
  54 : max-descent ( seq -- n/f )
  55     [ descent>> ] map ?maximum ;
  56
  57 : max-graphics-height ( seq -- n )
  58     [ ascent>> ] reject [ height>> ] map ?maximum 0 or ;
  59
  60 :: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
  61     ascent [
  62         cap-height 0 or 2 / :> mid-line
  63         graphics-height 2 /
  64         [ ascent mid-line - max mid-line + floor >integer ]
  65         [ descent mid-line + max mid-line - ceiling >integer ] bi
  66     ] [ f f ] if ;
  67
  68 : (measure-metrics) ( children sizes -- graphics-height ascent descent cap-height )
  69     [ <gadget-metrics> ] 2map
  70     {
  71         [ max-graphics-height ]
  72         [ max-ascent ]
  73         [ max-descent ]
  74         [ max-cap-height ]
  75     } cleave ;
  76
  77 PRIVATE>
  78
  79 :: align-baselines ( gadgets -- ys )
  80     gadgets [ dup pref-dim <gadget-metrics> ] map
  81     dup max-ascent 0 or :> max-ascent
  82     dup max-cap-height 0 or :> max-cap-height
  83     dup max-graphics-height :> max-graphics-height
  84
  85     max-cap-height max-graphics-height + 2 /i :> critical-line
  86     critical-line max-ascent [-] :> text-leading
  87     max-ascent critical-line [-] :> graphics-leading
  88
  89     [
  90         dup ascent>>
  91         [ ascent>> max-ascent swap - text-leading ]
  92         [ height>> max-graphics-height swap - 2 /i graphics-leading ] if +
  93     ] map ;
  94
  95 : measure-metrics ( children sizes -- ascent descent )
  96     (measure-metrics) combine-metrics ;
  97
  98 : measure-height ( children sizes -- height )
  99     (measure-metrics) [ combine-metrics + ] [ 2drop ] if* ;
 100
 101 : measure-height-metrics ( children sizes -- height ascent descent )
 102     (measure-metrics) [ dup ] 3dip
 103     [ combine-metrics ] keep [ [ + nip ] 2keep ] when ;