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