basis/ui/gadgets/panes/panes.factor

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