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