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 selection-color >>selection-color ;
  19
  20 GENERIC: line-leading* ( gadget -- n )
  21
  22 M: line-gadget line-leading*
  23     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*
  37     font>> font-metrics height>> ceiling >integer ;
  38
  39 GENERIC: line-height ( gadget -- n )
  40
  41 M: line-gadget line-height
  42     dup line-height>>
  43     [ ] [
  44         [ line-height* ] [ ] [ layout-state>> ] tri
  45         [ drop ] [ dupd line-height<< ] if
  46     ] ?if ;
  47
  48 : y>line ( y gadget -- n ) line-height /i ;
  49
  50 : line>y ( n gadget -- y ) line-height * >integer ;
  51
  52 : validate-line ( m gadget -- n )
  53     control-value [ drop f ] [ length 1 - min 0 max ] if-empty ;
  54
  55 : valid-line? ( n gadget -- ? )
  56     control-value length 1 - 0 swap between? ;
  57
  58 : visible-line ( gadget quot -- n )
  59     '[
  60         [ clip get @ origin get [ second ] bi@ - ] dip
  61         y>line
  62     ] keep validate-line ; inline
  63
  64 : first-visible-line ( gadget -- n )
  65     [ loc>> ] visible-line ;
  66
  67 : last-visible-line ( gadget -- n )
  68     [ [ loc>> ] [ dim>> ] bi v+ ] visible-line 1 + ;
  69
  70 : each-slice-index ( from to seq quot -- )
  71     [ [ <slice> ] [ drop [a..b) ] 3bi ] dip 2each ; inline
  72
  73 GENERIC: draw-line ( line index gadget -- )
  74
  75 : draw-lines ( gadget -- )
  76     {
  77         [ first-visible-line ]
  78         [ last-visible-line ]
  79         [ control-value ]
  80         [ line-height ]
  81         [ ]
  82     } cleave '[
  83         0 over _ * >integer 2array
  84         [ _ draw-line ] with-translation
  85     ] each-slice-index ;
  86
  87 <PRIVATE
  88
  89 : clamp ( dim unit min max -- dim' )
  90     [ -1/0. or 1 max * ] [ 1/0. or 1 max * ] bi-curry* bi
  91     [ max ] [ min ] bi* ;
  92
  93 : em ( font -- x ) "m" text-width ;
  94
  95 PRIVATE>
  96
  97 : line-gadget-width ( pref-dim gadget -- w )
  98     [ first ] [ [ font>> em ] [ min-cols>> ] [ max-cols>> ] tri ] bi* clamp ;
  99
 100 : line-gadget-height ( pref-dim gadget -- h )
 101     [ second ] [ [ line-height ] [ min-rows>> ] [ max-rows>> ] tri ] bi* clamp ;
 102
 103 : line-gadget-dim ( pref-dim gadget -- dim )
 104     [ line-gadget-width ] [ line-gadget-height ] 2bi 2array ;
 105
 106 : pref-viewport-dim* ( gadget -- dim )
 107     [ pref-dim ] [ line-gadget-dim ] bi ;
 108
 109 M: line-gadget pref-viewport-dim
 110     dup pref-viewport-dim>>
 111     [ ] [
 112         [ pref-viewport-dim* ] [ ] [ layout-state>> ] tri
 113         [ drop ] [ dupd pref-viewport-dim<< ] if
 114     ] ?if ;
 115
 116 M: line-gadget pref-dim* { 0 0 } swap line-gadget-dim ;
 117
 118 : visible-lines ( gadget -- n )
 119     [ visible-dim second ] [ line-height ] bi /i ;