extra/graphviz/notation/notation.factor

   1 ! Copyright (C) 2011 Alex Vondrak.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors fry generic generic.parser generic.standard
   4 kernel present quotations sequences slots words
   5 graphviz
   6 graphviz.attributes
   7 ;
   8 IN: graphviz.notation
   9
  10 <<
  11
  12 <PRIVATE
  13
  14 ! GENERIC# =attr 1 ( graphviz-obj val -- graphviz-obj' )
  15 ! M: edge/node =attr
  16 !   present over attributes>> attr<< ;
  17 ! M: sub/graph =attr
  18 !   <graph-attributes> swap present >>attr add ;
  19 ! M: edge/node/graph-attributes =attr
  20 !   present >>attr ;
  21
  22 : =attr-generic ( name -- generic )
  23     "=" prepend "graphviz.notation" 2dup lookup-word
  24     [ 2nip ] [
  25         create-word dup
  26         1 <standard-combination>
  27         ( graphviz-obj val -- graphviz-obj' )
  28         define-generic
  29     ] if* ;
  30
  31 : =attr-method ( class name -- method name )
  32     [ =attr-generic create-method-in ] keep ;
  33
  34 : sub/graph-=attr ( attr -- )
  35     [ graph subgraph ] dip [
  36         =attr-method
  37         setter-word 1quotation
  38         '[ <graph-attributes> swap present @ add ]
  39         define
  40     ] curry bi@ ;
  41
  42 : edge/node-=attr ( class attr -- )
  43     =attr-method
  44     writer-word 1quotation '[ present over attributes>> @ ]
  45     define ;
  46
  47 : graph-obj-=attr ( class attr -- )
  48     over graph =
  49     [ nip sub/graph-=attr ]
  50     [ edge/node-=attr ] if ;
  51
  52 : attrs-obj-=attr ( class attr -- )
  53     =attr-method
  54     setter-word 1quotation '[ present @ ]
  55     define ;
  56
  57 : define-=attrs ( base-class attrs-class -- )
  58     dup "slots" word-prop [
  59         name>>
  60         [ attrs-obj-=attr ] keep
  61         graph-obj-=attr
  62     ] 2with each ;
  63
  64 PRIVATE>
  65
  66 graph graph-attributes define-=attrs
  67 edge edge-attributes define-=attrs
  68 node node-attributes define-=attrs
  69
  70 >>
  71
  72 ALIAS: -> add-edge
  73 ALIAS: -- add-edge
  74 ALIAS: ~-> add-path
  75 ALIAS: ~-- add-path
  76
  77 ALIAS: [graph <graph-attributes>
  78 ALIAS: [node <node-attributes>
  79 ALIAS: [edge <edge-attributes>
  80
  81 ALIAS: [add-node <node>
  82 ALIAS: [add-edge <edge>
  83 ALIAS: [-> <edge>
  84 ALIAS: [-- <edge>
  85
  86 ALIAS: ]; add
  87
  88 ! Can't really do add-path[ & add-nodes[ this way, since they
  89 ! involve multiple objects.