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 io.styles strings quotations math opengl combinators memoize
   5 math.vectors sorting splitting assocs classes.tuple models
   6 continuations destructors accessors math.geometry.rect fry
   7 fonts ui.gadgets ui.gadgets.borders ui.gadgets.buttons
   8 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
   9 ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
  10 ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
  11 ui.text ui.gadgets.presentations ui.gadgets.grids
  12 ui.gadgets.grid-lines colors ;
  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 -- )
  29     clear-selection
  30     dup prototype>> clone add-current drop ;
  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         dup 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         [ selection-color>> gl-color ]
  81         [
  82             [ [ origin get ] dip loc>> v- ] keep selected-children
  83             [ draw-selection ] with each
  84         ] bi
  85     ] [ drop ] 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 -- )
 104     [
 105         [ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
 106         add-incremental
 107     ]
 108     [ prepare-line ] bi ;
 109
 110 : pane-write ( seq pane -- )
 111     [ '[ _ pane-nl ] ]
 112     [ '[ _ current>> stream-write ] ] bi
 113     interleave ;
 114
 115 : pane-format ( seq style pane -- )
 116     [ '[ _ drop _ pane-nl ] ]
 117     [ '[ _ _ current>> stream-format ] ] 2bi
 118     interleave ;
 119
 120 GENERIC: write-gadget ( gadget stream -- )
 121
 122 M: pane-stream write-gadget ( gadget pane-stream -- )
 123     pane>> current>> swap add-gadget drop ;
 124
 125 M: style-stream write-gadget
 126     stream>> write-gadget ;
 127
 128 : print-gadget ( gadget stream -- )
 129     [ write-gadget ] [ nip stream-nl ] 2bi ;
 130
 131 : gadget. ( gadget -- )
 132     output-stream get print-gadget ;
 133
 134 : ?nl ( stream -- )
 135     dup pane>> current>> children>> empty?
 136     [ dup stream-nl ] unless drop ;
 137
 138 : with-pane ( pane quot -- )
 139     over scroll>top
 140     over pane-clear [ <pane-stream> ] dip
 141     over [ with-output-stream* ] dip ?nl ; inline
 142
 143 : make-pane ( quot -- gadget )
 144     <pane> [ swap with-pane ] keep smash-pane ; inline
 145
 146 : <scrolling-pane> ( -- pane ) <pane> t >>scrolls? ;
 147
 148 TUPLE: pane-control < pane quot ;
 149
 150 M: pane-control model-changed ( model pane-control -- )
 151     [ value>> ] [ dup quot>> ] bi* with-pane ;
 152
 153 : <pane-control> ( model quot -- pane )
 154     pane-control new-pane
 155         swap >>quot
 156         swap >>model ;
 157
 158 : do-pane-stream ( pane-stream quot -- )
 159     [ pane>> ] dip keep scroll-pane ; inline
 160
 161 M: pane-stream stream-nl
 162     [ pane-nl ] do-pane-stream ;
 163
 164 M: pane-stream stream-write1
 165     [ current>> stream-write1 ] do-pane-stream ;
 166
 167 M: pane-stream stream-write
 168     [ [ string-lines ] dip pane-write ] do-pane-stream ;
 169
 170 M: pane-stream stream-format
 171     [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
 172
 173 M: pane-stream dispose drop ;
 174
 175 M: pane-stream stream-flush drop ;
 176
 177 M: pane-stream make-span-stream
 178     swap <style-stream> <ignore-close-stream> ;
 179
 180 ! Character styles
 181
 182 MEMO: specified-font ( assoc -- font )
 183     #! We memoize here to avoid creating lots of duplicate font objects.
 184     [ <font> ] dip
 185     {
 186         [ font-name swap at "monospace" or >>name ]
 187         [
 188             font-style swap at {
 189                 { f [ ] }
 190                 { plain [ ] }
 191                 { bold [ t >>bold? ] }
 192                 { italic [ t >>italic? ] }
 193                 { bold-italic [ t >>bold? t >>italic? ] }
 194             } case
 195         ]
 196         [ font-size swap at 12 or >>size ]
 197         [ foreground swap at black or >>foreground ]
 198         [ background swap at white or >>background ]
 199     } cleave ;
 200
 201 : apply-font-style ( style gadget -- style gadget )
 202     { font-name font-style font-size foreground background }
 203     pick extract-keys specified-font >>font ;
 204
 205 : apply-style ( style gadget key quot -- style gadget )
 206     [ pick at ] dip when* ; inline
 207
 208 : apply-presentation-style ( style gadget -- style gadget )
 209     presented [ <presentation> ] apply-style ;
 210
 211 : style-label ( style gadget -- gadget )
 212     apply-font-style
 213     apply-presentation-style
 214     nip ; inline
 215
 216 : <styled-label> ( style text -- gadget )
 217     <label> style-label ;
 218
 219 ! Paragraph styles
 220
 221 : apply-wrap-style ( style pane -- style pane )
 222     wrap-margin [
 223         2dup <paragraph> >>prototype drop
 224         <paragraph> >>current
 225     ] apply-style ;
 226
 227 : apply-border-color-style ( style gadget -- style gadget )
 228     border-color [ solid-boundary ] apply-style ;
 229
 230 : apply-page-color-style ( style gadget -- style gadget )
 231     page-color [ solid-interior ] apply-style ;
 232
 233 : apply-border-width-style ( style gadget -- style gadget )
 234     border-width [ <border> ] apply-style ;
 235
 236 : style-pane ( style pane -- pane )
 237     apply-border-width-style
 238     apply-border-color-style
 239     apply-page-color-style
 240     apply-presentation-style
 241     nip ;
 242
 243 TUPLE: nested-pane-stream < pane-stream style parent ;
 244
 245 : new-nested-pane-stream ( style parent class -- stream )
 246     new
 247         swap >>parent
 248         swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
 249     inline
 250
 251 : unnest-pane-stream ( stream -- child parent )
 252     dup ?nl
 253     dup style>>
 254     over pane>> smash-pane style-pane
 255     swap parent>> ;
 256
 257 TUPLE: pane-block-stream < nested-pane-stream ;
 258
 259 M: pane-block-stream dispose
 260     unnest-pane-stream write-gadget ;
 261
 262 M: pane-stream make-block-stream
 263     pane-block-stream new-nested-pane-stream ;
 264
 265 ! Tables
 266 : apply-table-gap-style ( style grid -- style grid )
 267     table-gap [ >>gap ] apply-style ;
 268
 269 : apply-table-border-style ( style grid -- style grid )
 270     table-border [ <grid-lines> >>boundary ]
 271     apply-style ;
 272
 273 : styled-grid ( style grid -- grid )
 274     <grid>
 275     f >>fill?
 276     apply-table-gap-style
 277     apply-table-border-style
 278     nip ;
 279
 280 TUPLE: pane-cell-stream < nested-pane-stream ;
 281
 282 M: pane-cell-stream dispose ?nl ;
 283
 284 M: pane-stream make-cell-stream
 285     pane-cell-stream new-nested-pane-stream ;
 286
 287 M: pane-stream stream-write-table
 288     [
 289         swap [ [ pane>> smash-pane ] map ] map
 290         styled-grid
 291     ] dip print-gadget ;
 292
 293 ! Stream utilities
 294 M: pack dispose drop ;
 295
 296 M: paragraph dispose drop ;
 297
 298 : gadget-write ( string gadget -- )
 299     swap dup empty?
 300     [ 2drop ] [ <label> text-theme add-gadget drop ] if ;
 301
 302 M: pack stream-write gadget-write ;
 303
 304 : gadget-bl ( style stream -- )
 305     swap " " <word-break-gadget> style-label add-gadget drop ;
 306
 307 M: paragraph stream-write
 308     swap " " split
 309     [ H{ } over gadget-bl ] [ over gadget-write ] interleave
 310     drop ;
 311
 312 : gadget-write1 ( char gadget -- )
 313     [ 1string ] dip stream-write ;
 314
 315 M: pack stream-write1 gadget-write1 ;
 316
 317 M: paragraph stream-write1
 318     over CHAR: \s =
 319     [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
 320
 321 : gadget-format ( string style stream -- )
 322     '[ _ swap <styled-label> _ swap add-gadget drop ] unless-empty ;
 323
 324 M: pack stream-format
 325     gadget-format ;
 326
 327 M: paragraph stream-format
 328     presented pick at [
 329         gadget-format
 330     ] [
 331         [ " " split ] 2dip
 332         [ '[ _ _ gadget-bl ] ]
 333         [ '[ _ _ gadget-format ] ] 2bi
 334         interleave
 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     { copy-action [ com-copy ] }
 410     { T{ button-down f f 3 } [ pane-menu ] }
 411 } set-gestures