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