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