90 lines
2.0 KiB
Factor
90 lines
2.0 KiB
Factor
|
! Copyright (C) 2011 Alex Vondrak.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: accessors fry generic generic.parser generic.standard
|
||
|
|
kernel present quotations sequences slots words
|
||
|
|
graphviz
|
||
|
|
graphviz.attributes
|
||
|
|
;
|
||
|
|
IN: graphviz.notation
|
||
|
|
|
||
|
|
<<
|
||
|
|
|
||
|
|
<PRIVATE
|
||
|
|
|
||
|
|
! GENERIC# =attr 1 ( graphviz-obj val -- graphviz-obj' )
|
||
|
|
! M: edge/node =attr
|
||
|
|
! present over attributes>> attr<< ;
|
||
|
|
! M: sub/graph =attr
|
||
|
|
! <graph-attributes> swap present >>attr add ;
|
||
|
|
! M: edge/node/graph-attributes =attr
|
||
|
|
! present >>attr ;
|
||
|
|
|
||
|
|
: =attr-generic ( name -- generic )
|
||
|
|
"=" prepend "graphviz.notation" 2dup lookup
|
||
|
|
[ 2nip ] [
|
||
|
|
create dup
|
||
|
|
1 <standard-combination>
|
||
|
|
(( graphviz-obj val -- graphviz-obj' ))
|
||
|
|
define-generic
|
||
|
|
] if* ;
|
||
|
|
|
||
|
|
: =attr-method ( class name -- method name )
|
||
|
|
[ =attr-generic create-method-in ] keep ;
|
||
|
|
|
||
|
|
: sub/graph-=attr ( attr -- )
|
||
|
|
[ graph subgraph ] dip [
|
||
|
|
=attr-method
|
||
|
|
setter-word 1quotation
|
||
|
|
'[ <graph-attributes> swap present @ add ]
|
||
|
|
define
|
||
|
|
] curry bi@ ;
|
||
|
|
|
||
|
|
: edge/node-=attr ( class attr -- )
|
||
|
|
=attr-method
|
||
|
|
writer-word 1quotation '[ present over attributes>> @ ]
|
||
|
|
define ;
|
||
|
|
|
||
|
|
: graph-obj-=attr ( class attr -- )
|
||
|
|
over graph =
|
||
|
|
[ nip sub/graph-=attr ]
|
||
|
|
[ edge/node-=attr ] if ;
|
||
|
|
|
||
|
|
: attrs-obj-=attr ( class attr -- )
|
||
|
|
=attr-method
|
||
|
|
setter-word 1quotation '[ present @ ]
|
||
|
|
define ;
|
||
|
|
|
||
|
|
: define-=attrs ( base-class attrs-class -- )
|
||
|
|
dup "slots" word-prop [
|
||
|
|
name>>
|
||
|
|
[ attrs-obj-=attr ] keep
|
||
|
|
graph-obj-=attr
|
||
|
|
] with with each ;
|
||
|
|
|
||
|
|
PRIVATE>
|
||
|
|
|
||
|
|
graph graph-attributes define-=attrs
|
||
|
|
edge edge-attributes define-=attrs
|
||
|
|
node node-attributes define-=attrs
|
||
|
|
|
||
|
|
>>
|
||
|
|
|
||
|
|
ALIAS: -> add-edge
|
||
|
|
ALIAS: -- add-edge
|
||
|
|
ALIAS: ~-> add-path
|
||
|
|
ALIAS: ~-- add-path
|
||
|
|
|
||
|
|
ALIAS: graph[ <graph-attributes>
|
||
|
|
ALIAS: node[ <node-attributes>
|
||
|
|
ALIAS: edge[ <edge-attributes>
|
||
|
|
|
||
|
|
ALIAS: add-node[ <node>
|
||
|
|
ALIAS: add-edge[ <edge>
|
||
|
|
ALIAS: ->[ <edge>
|
||
|
|
ALIAS: --[ <edge>
|
||
|
|
|
||
|
|
ALIAS: ]; add
|
||
|
|
|
||
|
|
! Can't really do add-path[ & add-nodes[ this way, since they
|
||
|
|
! involve multiple objects.
|