basis/ui/gadgets/line-support/line-support.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators fry kernel math math.order
   4 math.ranges math.vectors namespaces opengl sequences ui.gadgets
   5 ui.render ui.text ;
   6 IN: ui.gadgets.line-support
   7
   8 ! Some code shared by table and editor gadgets
   9 SLOT: font
  10
  11 GENERIC: line-leading ( gadget -- n )
  12
  13 M: gadget line-leading font>> font-metrics leading>> ;
  14
  15 GENERIC: line-height ( gadget -- n )
  16
  17 M: gadget line-height font>> font-metrics height>> ;
  18
  19 : y>line ( y gadget -- n )
  20     [ line-leading ] [ line-height ] bi
  21     [ [ - ] keep ] dip + /i ;
  22
  23 : line>y ( n gadget -- y )
  24     [ line-height ] [ line-leading ] bi
  25     [ + * ] keep - ;
  26
  27 : validate-line ( m gadget -- n )
  28     control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
  29
  30 : visible-line ( gadget quot -- n )
  31     '[
  32         [ clip get @ origin get [ second ] bi@ - ] dip
  33         y>line
  34     ] keep validate-line ; inline
  35
  36 : first-visible-line ( gadget -- n )
  37     [ loc>> ] visible-line ;
  38
  39 : last-visible-line ( gadget -- n )
  40     [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1+ ;
  41
  42 : each-slice-index ( from to seq quot -- )
  43     [ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
  44
  45 GENERIC: draw-line ( line index gadget -- )
  46
  47 : draw-lines ( gadget -- )
  48     {
  49         [ first-visible-line ]
  50         [ last-visible-line ]
  51         [ control-value ]
  52         [ [ line-leading ] [ line-height ] bi + ]
  53         [ ]
  54     } cleave '[
  55         0 over _ * 2array
  56         [ _ draw-line ] with-translation
  57     ] each-slice-index ;