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