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

ui.traverse: some cleanup, use locals to understand logic better.

factor-shell
John Benediktsson 2017-10-25 18:06:47 -07:00
parent c22e55ce48
commit e06b1d7ded
1 changed files with 33 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
basis/ui/traverse/traverse.factor
View File

@ -1,73 +1,59 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces make sequences kernel math arrays io USING: accessors arrays combinators fry generic io kernel locals
ui.gadgets generic combinators fry sets ; make math namespaces sequences sets ui.gadgets ;
IN: ui.traverse IN: ui.traverse
TUPLE: node value children ; TUPLE: node value children ;
: traverse-step ( path gadget -- path' gadget' ) : traverse-step ( path gadget -- path' gadget' )
[ unclip ] dip children>> ?nth ; [ unclip-slice ] dip children>> ?nth ;
: make-node ( quot -- ) { } make node boa , ; inline : make-node ( value quot -- node ) { } make node boa ; inline
: traverse-to-path ( topath gadget -- ) :: traverse-to-path ( topath gadget -- )
dup not [ gadget [
2drop topath empty? [
] [
over empty? [
nip ,
] [
[ [
[ children>> swap first head-slice % ] gadget children>> topath first head-slice %
[ nip ] topath gadget traverse-step traverse-to-path
[ traverse-step traverse-to-path ]
2tri
] make-node ] make-node
] if ] unless ,
] if ; ] when* ;
: traverse-from-path ( frompath gadget -- ) :: traverse-from-path ( frompath gadget -- )
dup not [ gadget [
2drop frompath empty? [
] [
over empty? [
nip ,
] [
[ [
[ traverse-step traverse-from-path ] frompath gadget traverse-step traverse-from-path
[ nip ] gadget children>> frompath first 1 + tail-slice %
[ children>> swap first 1 + tail-slice % ]
2tri
] make-node ] make-node
] if ] unless ,
] if ; ] when* ;
: traverse-pre ( frompath gadget -- ) : traverse-pre ( frompath gadget -- )
traverse-step traverse-from-path ; traverse-step traverse-from-path ;
: (traverse-middle) ( frompath topath gadget -- )
[ first 1 + ] [ first ] [ children>> ] tri* <slice> % ;
: traverse-post ( topath gadget -- ) : traverse-post ( topath gadget -- )
traverse-step traverse-to-path ; traverse-step traverse-to-path ;
: traverse-middle ( frompath topath gadget -- ) :: traverse-middle ( frompath topath gadget -- )
[ gadget [
3dup nip traverse-pre frompath gadget traverse-pre
3dup (traverse-middle) frompath first 1 + topath first gadget children>> <slice> %
2dup traverse-post topath gadget traverse-post
2nip ] make-node , ;
] make-node ;
DEFER: (gadget-subtree) DEFER: gadget-subtree%
: traverse-child ( frompath topath gadget -- ) :: traverse-child ( frompath topath gadget -- )
[ 2nip ] 3keep gadget [
[ [ rest-slice ] 2dip traverse-step (gadget-subtree) ] frompath rest-slice
make-node ; topath gadget traverse-step
gadget-subtree%
] make-node , ;
: (gadget-subtree) ( frompath topath gadget -- ) : gadget-subtree% ( frompath topath gadget -- )
{ {
{ [ dup not ] [ 3drop ] } { [ dup not ] [ 3drop ] }
{ [ pick empty? pick empty? and ] [ 2nip , ] } { [ pick empty? pick empty? and ] [ 2nip , ] }
@ -78,7 +64,7 @@ DEFER: (gadget-subtree)
} cond ; } cond ;
: gadget-subtree ( frompath topath gadget -- seq ) : gadget-subtree ( frompath topath gadget -- seq )
[ (gadget-subtree) ] { } make ; [ gadget-subtree% ] { } make ;
M: node gadget-text* M: node gadget-text*
[ children>> ] [ value>> ] bi gadget-seq-text ; [ children>> ] [ value>> ] bi gadget-seq-text ;