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
   4 math.functions math.order math.ranges math.vectors namespaces
   5 opengl sequences ui.gadgets ui.gadgets.scrollers
   6 ui.gadgets.viewports ui.render ui.text ui.theme ;
   7 IN: ui.gadgets.line-support
   8
   9 ! Some code shared by table and editor gadgets
  10 TUPLE: line-gadget < gadget
  11 font selection-color
  12 min-rows max-rows
  13 min-cols max-cols
  14 line-leading line-height
  15 pref-viewport-dim ;
  16
  17 : new-line-gadget ( class -- gadget )
  18     new
  19         selection-color >>selection-color ;
  20
  21 GENERIC: line-leading* ( gadget -- n )
  22
  23 M: line-gadget line-leading* font>> font-metrics leading>> ;
  24
  25 GENERIC: line-leading ( gadget -- n )
  26
  27 M: line-gadget line-leading
  28     dup line-leading>>
  29     [ ] [
  30         [ line-leading* ] [ ] [ layout-state>> ] tri
  31         [ drop ] [ dupd line-leading<< ] if
  32     ] ?if ;
  33
  34 GENERIC: line-height* ( gadget -- n )
  35
  36 M: line-gadget line-height* font>> font-metrics height>> ceiling ;
  37
  38 GENERIC: line-height ( gadget -- n )
  39
  40 M: line-gadget line-height
  41     dup line-height>>
  42     [ ] [
  43         [ line-height* ] [ ] [ layout-state>> ] tri
  44         [ drop ] [ dupd line-height<< ] if
  45     ] ?if ;
  46
  47 : y>line ( y gadget -- n ) line-height /i ;
  48
  49 : line>y ( n gadget -- y ) line-height * >integer ;
  50
  51 : validate-line ( m gadget -- n )
  52     control-value [ drop f ] [ length 1 - min 0 max ] if-empty ;
  53
  54 : valid-line? ( n gadget -- ? )
  55     control-value length 1 - 0 swap between? ;
  56
  57 : visible-line ( gadget quot -- n )
  58     '[
  59         [ clip get @ origin get [ second ] bi@ - ] dip
  60         y>line
  61     ] keep validate-line ; inline
  62
  63 : first-visible-line ( gadget -- n )
  64     [ loc>> ] visible-line ;
  65
  66 : last-visible-line ( gadget -- n )
  67     [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1 + ;
  68
  69 : each-slice-index ( from to seq quot -- )
  70     [ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
  71
  72 GENERIC: draw-line ( line index gadget -- )
  73
  74 : draw-lines ( gadget -- )
  75     {
  76         [ first-visible-line ]
  77         [ last-visible-line ]
  78         [ control-value ]
  79         [ line-height ]
  80         [ ]
  81     } cleave '[
  82         0 over _ * >integer 2array
  83         [ _ draw-line ] with-translation
  84     ] each-slice-index ;
  85
  86 <PRIVATE
  87
  88 : clamp ( dim unit min max -- dim' )
  89     [ -1/0. or * ] [ 1/.0 or * ] bi-curry* bi
  90     [ max ] [ min ] bi* ;
  91
  92 : em ( font -- x ) "m" text-width ;
  93
  94 PRIVATE>
  95
  96 : line-gadget-width ( pref-dim gadget -- w )
  97     [ first ] [ [ font>> em ] [ min-cols>> ] [ max-cols>> ] tri ] bi* clamp ;
  98
  99 : line-gadget-height ( pref-dim gadget -- h )
 100     [ second ] [ [ line-height ] [ min-rows>> ] [ max-rows>> ] tri ] bi* clamp ;
 101
 102 : pref-viewport-dim* ( gadget -- dim )
 103     [ pref-dim ] [ ] bi
 104     [ line-gadget-width ]
 105     [ line-gadget-height ]
 106     2bi 2array ; inline
 107
 108 M: line-gadget pref-viewport-dim
 109     dup pref-viewport-dim>>
 110     [ ] [
 111         [ pref-viewport-dim* ] [ ] [ layout-state>> ] tri
 112         [ drop ] [ dupd pref-viewport-dim<< ] if
 113     ] ?if ;
 114
 115 : visible-lines ( gadget -- n )
 116     [ visible-dim second ] [ line-height ] bi /i ;