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

vocabs.hierarchy: some cleanup and minor speedups.

db4
John Benediktsson 2012-07-15 15:48:39 -07:00
parent 3da5efa25b
commit 260b75f4bf
1 changed files with 9 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
basis/vocabs/hierarchy/hierarchy.factor
View File

@ -39,13 +39,13 @@ ERROR: vocab-root-required root ;
: (child-vocabs) ( root prefix -- vocabs ) : (child-vocabs) ( root prefix -- vocabs )
ensure-vocab-root/prefix ensure-vocab-root/prefix
[ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ] [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
[ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ] [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]
[ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ] [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]
2tri ; 2tri ;
: ((child-vocabs-recursive)) ( root prefix -- ) : ((child-vocabs-recursive)) ( root prefix -- )
dupd vocab-name (child-vocabs) dupd vocab-name (child-vocabs) [ % ] keep
[ dup , ((child-vocabs-recursive)) ] with each ; [ ((child-vocabs-recursive)) ] with each ;
: (child-vocabs-recursive) ( root prefix -- seq ) : (child-vocabs-recursive) ( root prefix -- seq )
[ ((child-vocabs-recursive)) ] { } make ; [ ((child-vocabs-recursive)) ] { } make ;
@ -53,7 +53,7 @@ ERROR: vocab-root-required root ;
: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ; : no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;
: one-level-only? ( name prefix -- ? ) : one-level-only? ( name prefix -- ? )
?head [ "." split1 nip not ] dip and ; ?head [ "." split1 nip not ] [ drop f ] if ;
: unrooted-child-vocabs ( prefix -- seq ) : unrooted-child-vocabs ( prefix -- seq )
[ vocabs no-rooted ] dip [ vocabs no-rooted ] dip
@ -87,7 +87,7 @@ PRIVATE>
: child-vocabs ( prefix -- assoc ) : child-vocabs ( prefix -- assoc )
[ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ] [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]
[ unrooted-child-vocabs [ lookup-vocab ] map f swap 2array ] [ unrooted-child-vocabs [ lookup-vocab ] map! f swap 2array ]
bi suffix ; bi suffix ;
: all-vocabs ( -- assoc ) : all-vocabs ( -- assoc )
@ -95,17 +95,17 @@ PRIVATE>
: child-vocabs-recursive ( prefix -- assoc ) : child-vocabs-recursive ( prefix -- assoc )
[ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ] [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]
[ unrooted-child-vocabs-recursive [ lookup-vocab ] map f swap 2array ] [ unrooted-child-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]
bi suffix ; bi suffix ;
MEMO: all-vocabs-recursive ( -- assoc ) MEMO: all-vocabs-recursive ( -- assoc )
"" child-vocabs-recursive ; "" child-vocabs-recursive ;
: all-vocab-names ( -- seq ) : all-vocab-names ( -- seq )
all-vocabs-recursive filter-vocabs [ vocab-name ] map ; all-vocabs-recursive filter-vocabs [ vocab-name ] map! ;
: child-vocab-names ( prefix -- seq ) : child-vocab-names ( prefix -- seq )
child-vocabs filter-vocabs [ vocab-name ] map ; child-vocabs filter-vocabs [ vocab-name ] map! ;
<PRIVATE <PRIVATE