2006-03-26 16:36:05 -05:00
|
|
|
! Copyright (C) 2006 Slava Pestov.
|
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
|
IN: help
|
2006-05-15 01:01:47 -04:00
|
|
|
USING: arrays generic graphs hashtables io kernel
|
2006-03-27 03:10:58 -05:00
|
|
|
namespaces sequences strings words ;
|
2006-03-26 16:36:05 -05:00
|
|
|
|
|
|
|
|
: all-articles ( -- seq )
|
2006-06-17 01:03:56 -04:00
|
|
|
articles get hash-keys all-words append ;
|
2006-03-26 16:36:05 -05:00
|
|
|
|
|
|
|
|
GENERIC: elements* ( elt-type element -- )
|
|
|
|
|
|
|
|
|
|
M: simple-element elements* [ elements* ] each-with ;
|
|
|
|
|
|
|
|
|
|
M: object elements* 2drop ;
|
|
|
|
|
|
|
|
|
|
M: array elements*
|
|
|
|
|
[ [ elements* ] each-with ] 2keep
|
|
|
|
|
[ first eq? ] keep swap [ , ] [ drop ] if ;
|
|
|
|
|
|
|
|
|
|
: elements ( elt-type element -- seq ) [ elements* ] { } make ;
|
|
|
|
|
|
2006-06-17 01:18:46 -04:00
|
|
|
: collect-elements ( element seq -- elements )
|
2006-06-17 01:03:56 -04:00
|
|
|
[
|
|
|
|
|
[
|
|
|
|
|
swap elements [
|
|
|
|
|
1 swap tail [ dup set ] each
|
|
|
|
|
] each
|
|
|
|
|
] each-with
|
|
|
|
|
] make-hash hash-keys ;
|
|
|
|
|
|
|
|
|
|
SYMBOL: link-graph
|
2006-03-26 16:36:05 -05:00
|
|
|
|
|
|
|
|
: links-out ( article -- seq )
|
2006-06-17 01:03:56 -04:00
|
|
|
article-content { $link $see-also } collect-elements ;
|
2006-03-26 16:36:05 -05:00
|
|
|
|
2006-06-17 01:03:56 -04:00
|
|
|
: ?link dup link? [ link-name ] when ;
|
2006-03-27 03:10:58 -05:00
|
|
|
|
2006-06-16 23:12:40 -04:00
|
|
|
: links-in ( article -- seq )
|
2006-06-17 01:03:56 -04:00
|
|
|
?link link-graph get in-edges ;
|
|
|
|
|
|
|
|
|
|
SYMBOL: parent-graph
|
|
|
|
|
|
2006-06-17 01:18:46 -04:00
|
|
|
DEFER: $subsection
|
|
|
|
|
|
2006-06-17 01:03:56 -04:00
|
|
|
: children ( article -- seq )
|
|
|
|
|
article-content { $subsection } collect-elements ;
|
|
|
|
|
|
|
|
|
|
: ?link dup link? [ link-name ] when ;
|
|
|
|
|
|
|
|
|
|
: parents ( article -- seq )
|
|
|
|
|
?link parent-graph get in-edges ;
|
|
|
|
|
|
|
|
|
|
: (where) ( article -- )
|
|
|
|
|
dup , parents [ word? not ] subset dup empty?
|
|
|
|
|
[ drop ] [ [ (where) ] each ] if ;
|
|
|
|
|
|
|
|
|
|
: where ( article -- seq )
|
|
|
|
|
[ (where) ] { } make 1 swap tail ;
|
2006-03-27 03:10:58 -05:00
|
|
|
|
2006-06-17 01:18:46 -04:00
|
|
|
: $where ( article -- )
|
|
|
|
|
where dup empty? [
|
|
|
|
|
drop
|
|
|
|
|
] [
|
|
|
|
|
where-style [
|
|
|
|
|
[ "Parent topics: " write $links ] ($block)
|
|
|
|
|
] with-style
|
|
|
|
|
] if ;
|
|
|
|
|
|
2006-03-27 03:10:58 -05:00
|
|
|
: xref-article ( article -- )
|
2006-06-17 01:03:56 -04:00
|
|
|
dup
|
|
|
|
|
[ links-out ] link-graph get add-vertex
|
|
|
|
|
[ children ] parent-graph get add-vertex ;
|
2006-03-27 03:10:58 -05:00
|
|
|
|
|
|
|
|
: unxref-article ( article -- )
|
2006-06-17 01:03:56 -04:00
|
|
|
dup [ links-out ] link-graph get remove-vertex
|
|
|
|
|
[ children ] parent-graph get remove-vertex ;
|
2006-03-27 03:10:58 -05:00
|
|
|
|
|
|
|
|
: xref-articles ( -- )
|
2006-06-17 01:03:56 -04:00
|
|
|
all-articles dup
|
|
|
|
|
[ links-out ] link-graph get build-graph
|
|
|
|
|
[ children ] parent-graph get build-graph ;
|
2006-03-26 16:36:05 -05:00
|
|
|
|
|
|
|
|
: links-in. ( article -- )
|
|
|
|
|
links-in [ links-in. ] help-outliner ;
|