steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ui.gadgets.panes: rewrite a few words

db4
Eduardo Cavazos 2008-07-16 00:12:47 -05:00
parent 19919bb130
commit 344ee0aa5d
1 changed files with 50 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
extra/ui/gadgets/panes/panes.factor
View File

@ -1,66 +1,55 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
hashtables io kernel namespaces sequences io.styles strings hashtables io kernel namespaces sequences io.styles strings
quotations math opengl combinators math.vectors quotations math opengl combinators math.vectors
sorting splitting io.streams.nested assocs sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines classes.tuple models continuations ui.gadgets.grid-lines classes.tuple models continuations
destructors accessors math.geometry.rect ; destructors accessors math.geometry.rect ;
IN: ui.gadgets.panes IN: ui.gadgets.panes
TUPLE: pane < pack TUPLE: pane < pack
output current prototype scrolls? output current prototype scrolls?
selection-color caret mark selecting? ; selection-color caret mark selecting? ;
: clear-selection ( pane -- ) : clear-selection ( pane -- pane ) f >>caret f >>mark ;
f >>caret
f >>mark
drop ;
: add-output ( current pane -- ) : add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
[ set-pane-output ] [ swap add-gadget drop ] 2bi ; : add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
: add-current ( current pane -- ) : prepare-line ( pane -- pane )
[ set-pane-current ] [ swap add-gadget drop ] 2bi ; clear-selection
dup prototype>> clone add-current ;
: prepare-line ( pane -- ) : pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;
[ clear-selection ]
[ [ pane-prototype clone ] keep add-current ] bi ;
: pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ;
: selected-children ( pane -- seq ) : selected-children ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ; [ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ; M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
selected-children gadget-text ;
: pane-clear ( pane -- ) : pane-clear ( pane -- )
[ clear-selection ] clear-selection
[ pane-output clear-incremental ] [ pane-output clear-incremental ]
[ pane-current clear-gadget ] [ pane-current clear-gadget ]
tri ; bi ;
: pane-theme ( pane -- pane )
selection-color >>selection-color ; inline
: new-pane ( class -- pane ) : new-pane ( class -- pane )
new-gadget new-gadget
{ 0 1 } >>orientation { 0 1 } >>orientation
<shelf> >>prototype <shelf> >>prototype
<incremental> over add-output <incremental> add-output
dup prepare-line prepare-line
pane-theme ; selection-color >>selection-color ;
: <pane> ( -- pane ) : <pane> ( -- pane ) pane new-pane ;
pane new-pane ;
GENERIC: draw-selection ( loc obj -- ) GENERIC: draw-selection ( loc obj -- )
@ -102,25 +91,25 @@ C: <pane-stream> pane-stream
: smash-pane ( pane -- gadget ) pane-output smash-line ; : smash-pane ( pane -- gadget ) pane-output smash-line ;
: pane-nl ( pane -- ) : pane-nl ( pane -- pane )
dup pane-current dup unparent smash-line dup pane-current dup unparent smash-line
over pane-output add-incremental over pane-output add-incremental
prepare-line ; prepare-line ;
: pane-write ( pane seq -- ) : pane-write ( pane seq -- )
[ dup pane-nl ] [ pane-nl ]
[ over pane-current stream-write ] [ over pane-current stream-write ]
interleave drop ; interleave drop ;
: pane-format ( style pane seq -- ) : pane-format ( style pane seq -- )
[ dup pane-nl ] [ pane-nl ]
[ 2over pane-current stream-format ] [ 2over pane-current stream-format ]
interleave 2drop ; interleave 2drop ;
GENERIC: write-gadget ( gadget stream -- ) GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget M: pane-stream write-gadget ( gadget pane-stream -- )
pane-stream-pane pane-current swap add-gadget drop ; pane>> current>> swap add-gadget drop ;
M: style-stream write-gadget M: style-stream write-gadget
stream>> write-gadget ; stream>> write-gadget ;
@ -148,8 +137,8 @@ M: style-stream write-gadget
TUPLE: pane-control < pane quot ; TUPLE: pane-control < pane quot ;
M: pane-control model-changed M: pane-control model-changed ( model pane-control -- )
swap model-value swap dup pane-control-quot with-pane ; [ value>> ] [ dup quot>> ] bi* with-pane ;
: <pane-control> ( model quot -- pane ) : <pane-control> ( model quot -- pane )
pane-control new-pane pane-control new-pane
@ -160,7 +149,7 @@ M: pane-control model-changed
>r pane-stream-pane r> keep scroll-pane ; inline >r pane-stream-pane r> keep scroll-pane ; inline
M: pane-stream stream-nl M: pane-stream stream-nl
[ pane-nl ] do-pane-stream ; [ pane-nl drop ] do-pane-stream ;
M: pane-stream stream-write1 M: pane-stream stream-write1
[ pane-current stream-write1 ] do-pane-stream ; [ pane-current stream-write1 ] do-pane-stream ;
@ -337,8 +326,9 @@ M: paragraph stream-format
2drop 2drop
] if ; ] if ;
: caret>mark ( pane -- ) : caret>mark ( pane -- pane )
dup pane-caret over set-pane-mark relayout-1 ; dup caret>> >>mark
dup relayout-1 ;
GENERIC: sloppy-pick-up* ( loc gadget -- n ) GENERIC: sloppy-pick-up* ( loc gadget -- n )
@ -362,25 +352,25 @@ M: f sloppy-pick-up*
[ 3drop { } ] [ 3drop { } ]
if ; if ;
: move-caret ( pane -- ) : move-caret ( pane -- pane )
dup hand-rel dup hand-rel
over sloppy-pick-up over sloppy-pick-up
over set-pane-caret over set-pane-caret
relayout-1 ; dup relayout-1 ;
: begin-selection ( pane -- ) : begin-selection ( pane -- )
dup move-caret f swap set-pane-mark ; move-caret f swap set-pane-mark ;
: extend-selection ( pane -- ) : extend-selection ( pane -- )
hand-moved? [ hand-moved? [
dup selecting?>> [ dup selecting?>> [
dup move-caret move-caret
] [ ] [
dup hand-clicked get child? [ dup hand-clicked get child? [
t >>selecting? t >>selecting?
dup hand-clicked set-global dup hand-clicked set-global
dup move-caret move-caret
dup caret>mark caret>mark
] when ] when
] if ] if
dup dup pane-caret gadget-at-path scroll>gadget dup dup pane-caret gadget-at-path scroll>gadget
@ -395,8 +385,8 @@ M: f sloppy-pick-up*
] if ; ] if ;
: select-to-caret ( pane -- ) : select-to-caret ( pane -- )
dup pane-mark [ dup caret>mark ] unless dup pane-mark [ caret>mark ] unless
dup move-caret move-caret
dup request-focus dup request-focus
com-copy-selection ; com-copy-selection ;