basis/ui/gadgets/panes/panes.factor

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