basis/ui/gadgets/panes/panes.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays hashtables io kernel namespaces sequences
   4 strings quotations math opengl combinators memoize math.vectors
   5 sorting splitting assocs classes.tuple models continuations
   6 destructors accessors math.rectangles fry fonts ui.pens.solid
   7 ui.images ui.gadgets ui.gadgets.private ui.gadgets.borders
   8 ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
   9 ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
  10 ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
  11 ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks
  12 ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment
  13 colors io.styles ;
  14 FROM: io.styles => foreground background ;
  15 IN: ui.gadgets.panes
  16
  17 TUPLE: pane < track
  18 output current input last-line prototype scrolls?
  19 selection-color caret mark selecting? ;
  20
  21 TUPLE: pane-stream pane ;
  22
  23 C: <pane-stream> pane-stream
  24
  25 M: pane-stream stream-element-type drop +character+ ;
  26
  27 <PRIVATE
  28
  29 : clear-selection ( pane -- pane )
  30     f >>caret f >>mark ; inline
  31
  32 : prepare-last-line ( pane -- )
  33     [ last-line>> ] keep
  34     [ current>> f track-add ]
  35     [ input>> [ 1 track-add ] when* ] bi
  36     drop ; inline
  37
  38 : init-current ( pane -- pane )
  39     dup prototype>> clone >>current ; inline
  40
  41 : focus-input ( pane -- )
  42     input>> [ request-focus ] when* ;
  43
  44 : next-line ( pane -- )
  45     clear-selection
  46     [ input>> unparent ]
  47     [ init-current prepare-last-line ]
  48     [ focus-input ] tri ;
  49
  50 : pane-caret&mark ( pane -- caret mark )
  51     [ caret>> ] [ mark>> ] bi ; inline
  52
  53 : selected-subtree ( pane -- seq )
  54     [ pane-caret&mark sort-pair ] keep gadget-subtree ;
  55
  56 M: pane gadget-selection? pane-caret&mark and ;
  57
  58 M: pane gadget-selection ( pane -- string/f )
  59     selected-subtree gadget-text ;
  60
  61 : init-prototype ( pane -- pane )
  62     <shelf> +baseline+ >>align >>prototype ; inline
  63
  64 : init-output ( pane -- pane )
  65     <incremental> [ >>output ] [ f track-add ] bi ; inline
  66
  67 : pane-theme ( pane -- pane )
  68     1 >>fill
  69     selection-color >>selection-color ; inline
  70
  71 : init-last-line ( pane -- pane )
  72     horizontal <track> 0 >>fill +baseline+ >>align
  73     [ >>last-line ] [ 1 track-add ] bi
  74     dup prepare-last-line ; inline
  75
  76 M: pane selected-children
  77     dup gadget-selection? [
  78         [ selected-subtree leaves ]
  79         [ selection-color>> ]
  80         bi
  81     ] [ drop f f ] if ;
  82
  83 : scroll-pane ( pane -- )
  84     dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
  85
  86 : smash-line ( current -- gadget )
  87     dup children>> {
  88         { [ dup empty? ] [ 2drop "" <label> ] }
  89         { [ dup length 1 = ] [ nip first ] }
  90         [ drop ]
  91     } cond ;
  92
  93 : pane-nl ( pane -- )
  94     [
  95         [ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
  96         add-incremental
  97     ] [ next-line ] bi ;
  98
  99 : smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
 100
 101 : pane-write ( seq pane -- )
 102     [ pane-nl ] [ current>> stream-write ]
 103     bi-curry interleave ;
 104
 105 : pane-format ( seq style pane -- )
 106     [ nip pane-nl ] [ current>> stream-format ]
 107     bi-curry bi-curry interleave ;
 108
 109 : do-pane-stream ( pane-stream quot -- )
 110     [ pane>> ] dip keep scroll-pane ; inline
 111
 112 M: pane-stream stream-nl
 113     [ pane-nl ] do-pane-stream ;
 114
 115 M: pane-stream stream-write1
 116     [ current>> stream-write1 ] do-pane-stream ;
 117
 118 M: pane-stream stream-write
 119     [ [ string-lines ] dip pane-write ] do-pane-stream ;
 120
 121 M: pane-stream stream-format
 122     [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
 123
 124 M: pane-stream dispose drop ;
 125
 126 M: pane-stream stream-flush drop ;
 127
 128 M: pane-stream make-span-stream
 129     swap <style-stream> <ignore-close-stream> ;
 130
 131 PRIVATE>
 132
 133 : new-pane ( input class -- pane )
 134     [ vertical ] dip new-track
 135         swap >>input
 136         pane-theme
 137         init-prototype
 138         init-output
 139         init-current
 140         init-last-line ; inline
 141
 142 : <pane> ( -- pane ) f pane new-pane ;
 143
 144 GENERIC: write-gadget ( gadget stream -- )
 145
 146 M: pane-stream write-gadget ( gadget pane-stream -- )
 147     pane>> current>> swap add-gadget drop ;
 148
 149 M: style-stream write-gadget
 150     stream>> write-gadget ;
 151
 152 : print-gadget ( gadget stream -- )
 153     [ write-gadget ] [ nip stream-nl ] 2bi ;
 154
 155 : gadget. ( gadget -- )
 156     output-stream get print-gadget ;
 157
 158 : pane-clear ( pane -- )
 159     clear-selection
 160     [ output>> clear-incremental ]
 161     [ current>> clear-gadget ]
 162     bi ;
 163
 164 : with-pane ( pane quot -- )
 165     [ [ scroll>top ] [ pane-clear ] [ <pane-stream> ] tri ] dip
 166     with-output-stream* ; inline
 167
 168 : make-pane ( quot -- gadget )
 169     [ <pane> ] dip [ with-pane ] [ drop smash-pane ] 2bi ; inline
 170
 171 TUPLE: pane-control < pane quot ;
 172
 173 M: pane-control model-changed ( model pane-control -- )
 174     [ value>> ] [ dup quot>> ] bi*
 175     '[ _ call( value -- ) ] with-pane ;
 176
 177 : <pane-control> ( model quot -- pane )
 178     f pane-control new-pane
 179         swap >>quot
 180         swap >>model ;
 181
 182 ! Character styles
 183 <PRIVATE
 184
 185 MEMO: specified-font ( assoc -- font )
 186     #! We memoize here to avoid creating lots of duplicate font objects.
 187     [ monospace-font <font> ] dip
 188     {
 189         [ font-name swap at >>name ]
 190         [
 191             font-style swap at {
 192                 { f [ ] }
 193                 { plain [ ] }
 194                 { bold [ t >>bold? ] }
 195                 { italic [ t >>italic? ] }
 196                 { bold-italic [ t >>bold? t >>italic? ] }
 197             } case
 198         ]
 199         [ font-size swap at >>size ]
 200         [ foreground swap at >>foreground ]
 201         [ background swap at >>background ]
 202     } cleave
 203     derive-font ;
 204
 205 : apply-font-style ( style gadget -- style gadget )
 206     { font-name font-style font-size foreground background }
 207     pick extract-keys specified-font >>font ;
 208
 209 : apply-style ( style gadget key quot -- style gadget )
 210     [ pick at ] dip when* ; inline
 211
 212 : apply-presentation-style ( style gadget -- style gadget )
 213     presented [ <presentation> ] apply-style ;
 214
 215 : apply-image-style ( style gadget -- style gadget )
 216     image [ nip <image-name> <icon> ] apply-style ;
 217
 218 : apply-background-style ( style gadget -- style gadget )
 219     background [ <solid> >>interior ] apply-style ;
 220
 221 : style-label ( style gadget -- gadget )
 222     apply-font-style
 223     apply-background-style
 224     apply-presentation-style
 225     apply-image-style
 226     nip ; inline
 227
 228 : <styled-label> ( style text -- gadget )
 229     <label> style-label ;
 230
 231 ! Paragraph styles
 232
 233 : apply-wrap-style ( style pane -- style pane )
 234     wrap-margin [
 235         2dup <paragraph> >>prototype drop
 236         <paragraph> >>current
 237     ] apply-style ;
 238
 239 : apply-border-color-style ( style gadget -- style gadget )
 240     border-color [ <solid> >>boundary ] apply-style ;
 241
 242 : apply-page-color-style ( style gadget -- style gadget )
 243     page-color [ <solid> >>interior ] apply-style ;
 244
 245 : apply-inset-style ( style gadget -- style gadget )
 246     inset [ <border> ] apply-style ;
 247
 248 : style-pane ( style pane -- pane )
 249     apply-inset-style
 250     apply-border-color-style
 251     apply-page-color-style
 252     apply-presentation-style
 253     nip ;
 254
 255 TUPLE: nested-pane-stream < pane-stream style parent ;
 256
 257 : new-nested-pane-stream ( style parent class -- stream )
 258     new
 259         swap >>parent
 260         swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
 261     inline
 262
 263 : unnest-pane-stream ( stream -- child parent )
 264     [ [ style>> ] [ pane>> smash-pane ] bi style-pane ] [ parent>> ] bi ;
 265
 266 TUPLE: pane-block-stream < nested-pane-stream ;
 267
 268 M: pane-block-stream dispose
 269     unnest-pane-stream write-gadget ;
 270
 271 M: pane-stream make-block-stream
 272     pane-block-stream new-nested-pane-stream ;
 273
 274 ! Tables
 275 : apply-table-gap-style ( style grid -- style grid )
 276     table-gap [ >>gap ] apply-style ;
 277
 278 : apply-table-border-style ( style grid -- style grid )
 279     table-border [ <grid-lines> >>boundary ]
 280     apply-style ;
 281
 282 : styled-grid ( style grid -- grid )
 283     <grid>
 284     f >>fill?
 285     apply-table-gap-style
 286     apply-table-border-style
 287     nip ;
 288
 289 TUPLE: pane-cell-stream < nested-pane-stream ;
 290
 291 M: pane-cell-stream dispose drop ;
 292
 293 M: pane-stream make-cell-stream
 294     pane-cell-stream new-nested-pane-stream ;
 295
 296 M: pane-stream stream-write-table
 297     [
 298         swap [ [ pane>> smash-pane ] map ] map
 299         styled-grid
 300     ] dip write-gadget ;
 301
 302 ! Stream utilities
 303 M: pack dispose drop ;
 304
 305 M: paragraph dispose drop ;
 306
 307 : gadget-write ( string gadget -- )
 308     swap dup empty?
 309     [ 2drop ] [ <label> text-theme add-gadget drop ] if ;
 310
 311 M: pack stream-write gadget-write ;
 312
 313 : gadget-bl ( style stream -- )
 314     swap " " <word-break-gadget> style-label add-gadget drop ;
 315
 316 M: paragraph stream-write
 317     swap " " split
 318     [ H{ } over gadget-bl ] [ over gadget-write ] interleave
 319     drop ;
 320
 321 : gadget-write1 ( char gadget -- )
 322     [ 1string ] dip stream-write ;
 323
 324 M: pack stream-write1 gadget-write1 ;
 325
 326 M: paragraph stream-write1
 327     over CHAR: \s =
 328     [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
 329
 330 : empty-output? ( string style -- ? )
 331     [ empty? ] [ image swap key? not ] bi* and ;
 332
 333 : gadget-format ( string style stream -- )
 334     [ [ empty-output? ] 2keep ] dip
 335     '[ _ _ swap <styled-label> _ swap add-gadget drop ] unless ;
 336
 337 M: pack stream-format
 338     gadget-format ;
 339
 340 M: paragraph stream-format
 341     over { presented image } [ swap key? ] with any? [
 342         gadget-format
 343     ] [
 344         [ " " split ] 2dip
 345         [ gadget-bl ] [ gadget-format ] bi-curry bi-curry
 346         interleave
 347     ] if ;
 348
 349 : caret>mark ( pane -- )
 350     dup caret>> >>mark relayout-1 ;
 351
 352 GENERIC: sloppy-pick-up* ( loc gadget -- n )
 353
 354 M: pack sloppy-pick-up* ( loc gadget -- n )
 355     [ orientation>> ] [ children>> ] bi
 356     [ loc>> ] (fast-children-on) ;
 357
 358 M: gadget sloppy-pick-up*
 359     children>> [ contains-point? ] with find-last drop ;
 360
 361 M: f sloppy-pick-up*
 362     2drop f ;
 363
 364 : wet-and-sloppy ( loc gadget n -- newloc newgadget )
 365     swap nth-gadget [ loc>> v- ] keep ;
 366
 367 : sloppy-pick-up ( loc gadget -- path )
 368     2dup sloppy-pick-up* dup
 369     [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
 370     [ 3drop { } ]
 371     if ;
 372
 373 : move-caret ( pane loc -- )
 374     over screen-loc v- over sloppy-pick-up >>caret
 375     relayout-1 ;
 376
 377 : begin-selection ( pane -- )
 378     f >>selecting?
 379     dup hand-loc get move-caret
 380     f >>mark
 381     drop ;
 382
 383 : extend-selection ( pane -- )
 384     hand-moved? [
 385         [
 386             dup selecting?>> [
 387                 hand-loc get move-caret
 388             ] [
 389                 dup hand-clicked get child? [
 390                     t >>selecting?
 391                     [ hand-clicked set-global ]
 392                     [ hand-click-loc get move-caret ]
 393                     [ caret>mark ]
 394                     tri
 395                 ] [ drop ] if
 396             ] if
 397         ] [ dup caret>> gadget-at-path scroll>gadget ] bi
 398     ] [ drop ] if ;
 399
 400 : end-selection ( pane -- )
 401     dup selecting?>> hand-moved? or
 402     [ f >>selecting? ] dip
 403     [ [ com-copy-selection ] [ request-focus ] bi ]
 404     [ [ relayout-1 ] [ focus-input ] bi ]
 405     if ;
 406
 407 : select-to-caret ( pane -- )
 408     t >>selecting?
 409     [ dup mark>> [ dup caret>mark ] unless hand-loc get move-caret ]
 410     [ com-copy-selection ]
 411     [ request-focus ]
 412     tri ;
 413
 414 : pane-menu ( pane -- ) { com-copy } show-commands-menu ;
 415
 416 PRIVATE>
 417
 418 pane H{
 419     { T{ button-down } [ begin-selection ] }
 420     { T{ button-down f { S+ } 1 } [ select-to-caret ] }
 421     { T{ button-up f { S+ } 1 } [ end-selection ] }
 422     { T{ button-up } [ end-selection ] }
 423     { T{ drag { # 1 } } [ extend-selection ] }
 424     { copy-action [ com-copy ] }
 425     { T{ button-down f f 3 } [ pane-menu ] }
 426 } set-gestures