Paste: Tuple Depiction
Author: | Dave Carlton |
Mode: | factor |
Date: | Fri, 15 Jan 2021 20:00:39 |
Plain Text |
USING: accessors assocs classes classes.tuple graphviz graphviz.dot
graphviz.notation graphviz.render grouping io.encodings.utf8 kernel
math math.parser sequences sequences.deep slots splitting ui.gadgets.tracks
sequences.private variables vocabs.parser words present arrays ;
IN: sequences
: each-integer-initially -- ... )
[ ] curry 2dip (each-integer) ; inline
: each-index-initially
-- ... )
(each-index) rot each-integer-initially ; inline
IN: prographer.tuple
VAR: fValue
: (detuple)
"| <f" fValue number>string append
"> " append swap append
fValue 1+ set: fValue
;
: slots@
"slots" word-prop ;
: super@
"superclass" word-prop ;
: tupleslots
slots@
[ name>> search ] filter
[ name>> search ] map
[ tuple-class? ] filter
;
: tchain
dup
[ dup super@ ] [ super@ dup ] produce
nip swap prefix ;
: >labels
"| " split [ "" = not ] filter
2 group [ reverse ] map
rest ;
: node>labels
attributes>> label>> >labels ;
FROM: graphviz => node ;
TUPLE: tuple-node < node tuple slots next# ;
: <tuple-node>
tuple-node new
over >>tuple
swap name>> present >>id
{ } >>slots
;
:: tuple>node
tuple props>> :> pl
tuple super@ :> sc
"slots" pl at :> sl
tuple <tuple-node>
"record" =shape
"<f0>" tuple name>> append
sc
[
"|<f1>" sc name>> append append
2 set: fValue
]
[ 1 set: fValue ]
if
sl [
[ name>> (detuple) append ] each
] unless-empty
=label
;
: superlabel
dup tuple>> super@
[ name>> "|<f1>" prepend
over attributes>> label>> prepend =label
2 >>next# ]
[ 1 >>next# ]
if*
;
: index>label
+ number>string "|<f" prepend ">" append ;
: slot>label
[ dup ] 2dip
rot
index>label
swap
name>> append
;
: slots>labels
dup
next#>>
over tuple>> "slots" word-prop
[ slot>label ] map-index
2nip
;
: tuple>nodes
<tuple-node>
"record" =shape
dup id>> "<f0>" prepend =label
superlabel
[ slots>labels ] keep
[ attributes>> label>> ] keep
[ swap [ append ] each ] dip
swap =label
;
: tuples>nodes
[ tuple>nodes ] map
;
: slot-nodes
node>labels keys
[ search ] filter
[ search ] map
;
VAR: prevNode
:: tuple-connections
f :> prevNode! V{ } clone :> edgeNodes!
nodes
[ prevNode
[ prevNode over id>> <edge>
edgeNodes swap suffix! edgeNodes!
dup slot-nodes
[ edgeNodes swap tuple>node suffix! edgeNodes! ] each
id>> prevNode!
]
[ id>> prevNode! ]
if
] each
edgeNodes
;
: <tuple-graph>
<digraph> over name>> >>id
[graph "LR" =rankdir "8,8" =size ];
[node 8 =fontsize "record" =shape ];
swap
;
: tuple-tree
[ <tuple-graph>
tchain [ tuple>nodes ] map
[ add ] each
]
[ f ]
if*
;
: tuple-tree.
tuple-tree
[ preview ] when* ;
: tuple-tree-test
\ track
[ tuple-tree
[ dup preview "~/tuple.dot" utf8 write-dot ] when*
] when*
;
USING: accessors assocs classes classes.tuple graphviz graphviz.dot
graphviz.notation graphviz.render grouping io.encodings.utf8 kernel
math math.parser sequences sequences.deep slots splitting ui.gadgets.tracks
sequences.private variables vocabs.parser words present arrays ;
IN: sequences
: each-integer-initially -- ... )
[ ] curry 2dip (each-integer) ; inline
: each-index-initially
-- ... )
(each-index) rot each-integer-initially ; inline
IN: prographer.tuple
VAR: fValue
: (detuple)
"| <f" fValue number>string append
"> " append swap append
fValue 1+ set: fValue
;
: slots@
"slots" word-prop ;
: super@
"superclass" word-prop ;
: tupleslots
slots@
[ name>> search ] filter
[ name>> search ] map
[ tuple-class? ] filter
;
: tchain
dup
[ dup super@ ] [ super@ dup ] produce
nip swap prefix ;
: >labels
"| " split [ "" = not ] filter
2 group [ reverse ] map
rest ;
: node>labels
attributes>> label>> >labels ;
FROM: graphviz => node ;
TUPLE: tuple-node < node tuple slots next# ;
: <tuple-node>
tuple-node new
over >>tuple
swap name>> present >>id
{ } >>slots
;
:: tuple>node
tuple props>> :> pl
tuple super@ :> sc
"slots" pl at :> sl
tuple <tuple-node>
"record" =shape
"<f0>" tuple name>> append
sc
[
"|<f1>" sc name>> append append
2 set: fValue
]
[ 1 set: fValue ]
if
sl [
[ name>> (detuple) append ] each
] unless-empty
=label
;
: superlabel
dup tuple>> super@
[ name>> "|<f1>" prepend
over attributes>> label>> prepend =label
2 >>next# ]
[ 1 >>next# ]
if*
;
: index>label
+ number>string "|<f" prepend ">" append ;
: slot>label
[ dup ] 2dip
rot
index>label
swap
name>> append
;
: slots>labels
dup
next#>>
over tuple>> "slots" word-prop
[ slot>label ] map-index
2nip
;
: tuple>nodes
<tuple-node>
"record" =shape
dup id>> "<f0>" prepend =label
superlabel
[ slots>labels ] keep
[ attributes>> label>> ] keep
[ swap [ append ] each ] dip
swap =label
;
: tuples>nodes
[ tuple>nodes ] map
;
: slot-nodes
node>labels keys
[ search ] filter
[ search ] map
;
VAR: prevNode
:: tuple-connections
f :> prevNode! V{ } clone :> edgeNodes!
nodes
[ prevNode
[ prevNode over id>> <edge>
edgeNodes swap suffix! edgeNodes!
dup slot-nodes
[ edgeNodes swap tuple>node suffix! edgeNodes! ] each
id>> prevNode!
]
[ id>> prevNode! ]
if
] each
edgeNodes
;
: <tuple-graph>
<digraph> over name>> >>id
[graph "LR" =rankdir "8,8" =size ];
[node 8 =fontsize "record" =shape ];
swap
;
: tuple-tree
[ <tuple-graph>
tchain [ tuple>nodes ] map
[ add ] each
]
[ f ]
if*
;
: tuple-tree.
tuple-tree
[ preview ] when* ;
: tuple-tree-test
\ track
[ tuple-tree
[ dup preview "~/tuple.dot" utf8 write-dot ] when*
] when*
;
New Annotation