af835d492377 — Leonard Ritter 8 days ago
* improved dot styling
3 files changed, 99 insertions(+), 106 deletions(-)

M lib/tukan/CADAG/dot.sc
M lib/tukan/CADAG/init.sc
M testing/tukdag.sc
M lib/tukan/CADAG/dot.sc +24 -20
@@ 6,16 6,6 @@ using import ..File
 
 let system = (extern 'system (function i32 rawstring))
 
-fn translate-color (v)
-    let h s v = (unpack v)
-    .. "\""
-        tostring h
-        " "
-        tostring s
-        " "
-        tostring v
-        "\""
-
 # graphviz support for CADAG
 type+ CADAG
     """"generates dot output by calling function fstream with String values

          
@@ 28,9 18,12 @@ type+ CADAG
         'append tmp
             """"digraph "CADAG" {
                     ranksep=0.2 rankdir="TB";
+                    bgcolor = "#1d1f21";
                     splines=ortho;
-                    node [shape=box height=0.01 fontsize=8 fontname="sans"];
-                    edge [arrowsize=0.3 fontsize=7 fontname="sans"];
+                    node [color="#c5c8c6" fillcolor="#1d1f21" fontcolor="#c5c8c6"
+                        style="rounded, filled" shape=box height=0.01 fontsize=8
+                        fontname="mono bold"];
+                    edge [arrowsize=0.3 fontsize=7 fontname="sans" fontcolor="#c5c8c6" color="#969896"];
         commit tmp
 
         'descend self root

          
@@ 48,29 41,40 @@ type+ CADAG
                         'append tmp "="
                         'append tmp value
                         'append tmp " "
+                    inline writestrattr (name value)
+                        if (not (empty? value))
+                            writeattr name (tostring value)
                     let handle = ('handleof module id)
                     writeattr "label"
                         tostring
                             .. "%" idstr " = " (string handle.typeid.name)
                     let typeid = (unpack handle)
-                    'dispatch typeid
-                        inline "#hidden" (code cls)
-                            let info = ('typeinfo cls code)
-                            writeattr "fillcolor"
-                                translate-color info.fillcolor
-                            writeattr "textcolor"
-                                translate-color info.textcolor
-                            writeattr "style" "filled"
+                    let fontcolor =
+                        'dispatch typeid
+                            inline "#hidden" (code cls)
+                                let info = ('typeinfo cls code)
+                                let fontcolor = info.dot.fontcolor
+                                writestrattr "fillcolor" info.dot.fillcolor
+                                writestrattr "fontcolor" fontcolor
+                                writestrattr "color" info.dot.color
+                                _ fontcolor
                     'append tmp "];\n"
                     commit;
                     for k srcid in (enumerate ('sources handle))
                         srcidstr := (tostring srcid)
+                        let typeid = ('headerof module srcid)
                         'append tmp "    "
                         'append tmp srcidstr
                         'append tmp " -> "
                         'append tmp idstr
                         'append tmp " ["
                         writeattr "headlabel" (tostring k)
+                        writestrattr "fontcolor" fontcolor
+                        'dispatch typeid
+                            inline "#hidden" (code cls)
+                                let info = ('typeinfo cls code)
+                                #writestrattr "fillcolor" info.dot.fillcolor
+                                writestrattr "color" info.dot.color
                         'append tmp "]"
                         'append tmp ";\n"
                         commit;

          
M lib/tukan/CADAG/init.sc +11 -8
@@ 191,8 191,11 @@ struct TypeInfo plain
     name : string
     dedup? : bool = true
     userattrs : type = Nothing
-    textcolor : vec3 = (vec3 0)
-    fillcolor : vec3 = (vec3 0 0 0.9)
+    dot :
+        struct DotAttrs plain
+            fontcolor : string = ""
+            fillcolor : string = ""
+            color : string = ""
 
 struct CADAGEnvData
     typeid->info-map : (Map u32 TypeInfo)

          
@@ 366,10 369,12 @@ type CADAG < Struct
                 ti.dedup? = (v as bool)
             case 'userattrs
                 ti.userattrs = (v as type)
-            case 'textcolor
-                ti.textcolor = (v as vec3)
-            case 'fillcolor
-                ti.fillcolor = (v as vec3)
+            case 'dot.fontcolor
+                ti.dot.fontcolor = (v as string)
+            case 'dot.fillcolor
+                ti.dot.fillcolor = (v as string)
+            case 'dot.color
+                ti.dot.color = (v as string)
             default;
         let name =
             if (name == "") (tostring T)

          
@@ 483,9 488,7 @@ type Handle
         'vacount typeid sz
 
     inline sources (self)
-        let cls = (typeof self)
         let typeid sz ptr = (unpack (storagecast self))
-        let cls = cls.CADAGType
         Generator
             inline () (_ 0:u32 (('enum-id-offset typeid 0:u32) // u32_size))
             inline (i wordofs) (wordofs < sz)

          
M testing/tukdag.sc +64 -78
@@ 66,47 66,50 @@ let FIR = (CADAG "FIR")
 from FIR let AnyId NoId Id
 from (methodsof FIR) let define-type
 
-let typecolor = (vec3 0.15 0.5 1.0)
-let constcolor = (vec3 0.07 0.5 1.0)
-let stringcolor = (vec3 0.22 0.4 1.0)
-let purecolor = (vec3 0.6 0.3 1.0)
-let instrcolor = (vec3 0.98 0.3 1.0)
+let
+    typecolor... = (_ (dot.fontcolor = "#f0c674") (dot.color = "#f0c674"))
+    constcolor... = (_ (dot.fontcolor = "#de935f") (dot.color = "#de935f"))
+    stringcolor... = (_ (dot.fontcolor = "#b5bd68") (dot.color = "#b5bd68"))
+    funccolor... = (_ (dot.fontcolor = "#81a2be") (dot.color = "#81a2be"))
+    kwcolor... = (_ (dot.fontcolor = "#b294bb") (dot.color = "#b294bb"))
+    instrcolor... = (_ (dot.fontcolor = "#de5f84") (dot.color = "#de5f84"))
+    commentcolor... = (_ (dot.fontcolor = "#969896") (dot.color = "#969896"))
 
 define-type "ILSymbol"          (RIFF "ISYM") (tuple (size = u32) (str = (array char)))
-    fillcolor = constcolor
+    constcolor...
 define-type "ILString"          (RIFF "ISTR") (tuple (size = u32) (str = (array char)))
-    fillcolor = stringcolor
+    stringcolor...
 define-type "ILConstInt"        (RIFF "ICIN") (tuple (type = AnyId) (value = u32))
-    fillcolor = constcolor
+    constcolor...
 define-type "ILParams"          (RIFF "IPMS") (tuple (level = i32) (count = i32))
     dedup = false
 define-type "ILVAGet"           (RIFF "IGET") (tuple (index = i32) (args = AnyId))
 define-type "ILVA"              (RIFF "ILVA") (tuple (args = (array AnyId)))
 define-type "ILTemplate"        (RIFF "ITMP") (tuple (params = AnyId) (body = AnyId))
     dedup = false
-    fillcolor = purecolor
+    funccolor...
 define-type "ILDo"              (RIFF "IRDO") (tuple (scoped? = bool) (body = (array AnyId)))
     dedup = false
-    fillcolor = instrcolor
+    instrcolor...
 define-type "ILCall"            (RIFF "ICAL") (tuple (callee = AnyId) (args = (array AnyId)))
     dedup = false
-    fillcolor = instrcolor
+    instrcolor...
 define-type "ILNoReturnType"    (RIFF "INRT") (tuple)
-    fillcolor = typecolor
+    typecolor...
 define-type "ILIntegerType"     (RIFF "IINT") (tuple (width = i32) (signed? = bool))
-    fillcolor = typecolor
+    typecolor...
 define-type "ILArgumentsType"   (RIFF "IATY") (tuple (types = (array AnyId)))
-    fillcolor = typecolor
+    typecolor...
 define-type "ILStringType"      (RIFF "ISTY") (tuple)
-    fillcolor = typecolor
+    typecolor...
 define-type "ILFunctionType"    (RIFF "IFTY") (tuple (return = AnyId) (raise = AnyId) (params = (array AnyId)))
-    fillcolor = typecolor
+    typecolor...
 define-type "ILGlobal"          (RIFF "IGLO")
     tuple (name = AnyId) (type = AnyId) (flags = u32) (storage = AnyId) (attrs = (array AnyId))
-    fillcolor = purecolor
+    funccolor...
 define-type "ILIf"              (RIFF "ILIF") (tuple (cond = AnyId) (then = AnyId) (else = AnyId))
     dedup = false
-    fillcolor = instrcolor
+    instrcolor...
 define-type "ILXValue"          (RIFF "ILXV")
     type ILXValueType <: (tuple u32 u32 u32 u32)
         @@ memo

          
@@ 127,24 130,39 @@ define-type "ILXValue"          (RIFF "I
             repr (self as Value)
 
 define-type "vec"       (RIFF "VECT") (tuple i32)
+    typecolor...
 define-type "vec2"      (RIFF "VEC2") (tuple AnyId AnyId)
 define-type "vec3"      (RIFF "VEC3") (tuple AnyId AnyId AnyId)
 define-type "vec4"      (RIFF "VEC4") (tuple AnyId AnyId AnyId AnyId)
 define-type "input"     (RIFF "INPT") (tuple AnyId SystemKey)
-define-type "output"    (RIFF "OUTP") (tuple SystemKey AnyId)
+    instrcolor...
+define-type "output"    (RIFF "OUTP") (tuple (array (tuple SystemKey AnyId)))
+    instrcolor...
 define-type "uconst"    (RIFF "U32C") u32
+    constcolor...
 define-type "fconst"    (RIFF "F32C") f32
+    constcolor...
 define-type "range"     (RIFF "RANG") (tuple AnyId AnyId)
+    stringcolor...
 define-type "comp"      (RIFF "COMP") (tuple i32 AnyId)
 define-type "and"       (RIFF "BAND") (tuple AnyId AnyId)
+    funccolor...
 define-type "xor"       (RIFF "BXOR") (tuple AnyId AnyId)
+    funccolor...
 define-type "utof"      (RIFF "UTOF") (tuple AnyId)
+    funccolor...
 define-type "sin"       (RIFF "FSIN") (tuple AnyId)
+    funccolor...
 define-type "cos"       (RIFF "FCOS") (tuple AnyId)
+    funccolor...
 define-type "fadd"      (RIFF "FADD") (tuple AnyId AnyId)
+    funccolor...
 define-type "fmul"      (RIFF "FMUL") (tuple AnyId AnyId)
+    funccolor...
 define-type "fdiv"      (RIFF "FDIV") (tuple AnyId AnyId)
+    funccolor...
 define-type "sample"    (RIFF "SAMP") (tuple AnyId AnyId)
+    instrcolor...
 
 ################################################################################
 

          
@@ 384,12 402,16 @@ fn generate-IL (self)
 
 ################################################################################
 
+fn translate-FIR (self)
+
+################################################################################
+
 # instantiate a module
 local module : FIR
 
 from (methodsof module) let rootid transform descend
 
-do
+#do
     from (methodsof module.builder) let ILGlobal ILSymbol ILFunctionType
         \ ILArgumentsType ILNoReturnType ILStringType ILSymbol ILTemplate ILParams
         \ ILCall ILString ILDo ILIf ILConstInt ILInteger ILVAGet ILVA ILEmbed

          
@@ 408,7 430,7 @@ do
             ILVA param0 param0
 
 
-#do
+do
     from (methodsof module.builder) let vec vec2 vec3 vec4 input output uconst
         \ fconst range comp and xor utof sin cos fadd fmul fdiv sample
         \ nativefn symbol

          
@@ 427,63 449,27 @@ do
                     comp 1 pos
                 utof (xor (and x (uconst 1)) (and y (uconst 1)))
 
-        output SystemKey.Screen
-            do
-                # frame time
-                let it = (fdiv (utof inpit) (fconst 60.0))
-                # screen size
-                let w h =
-                    comp 0 inpss
-                    comp 1 inpss
-                let pos = (range w h)
-                let x y =
-                    comp 0 pos
-                    comp 1 pos
-                let u = (fdiv (utof x) (utof w))
-                let v = (fdiv (utof y) (utof h))
-                let q = (sample checkers_texture (vec2 u v))
-                #let q = (fconst 1.0)
-                let u = (fmul q u)
-                let v = (fmul q v)
-                let z = (fmul q (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5)))
-                vec4 u v z (fconst 1)
-
-
-        nativefn (symbol "test")
-
-# perform a topological transform where we increment the constant values
-#let newmodule newid =
-    transform (rootid)
-        visit =
-            capture (module handle finalize) {}
-                dispatch handle
-                case const (self)
-                    print self
-                    self += 1
-                case const2 (self)
-                    return (('const module.builder (self + 10)) as u32)
-                case vec3 (self)
-                    print (self @ 0) (self @ 1) (self @ 2)
-                    dispatch ('handleof module (self @ 0))
-                    case const (self)
-                        print "yes is a const"
-                    default;
-                case u32x (self)
-                    print ('vacount handle)
-                case str (self)
-                    ptr := self @ 0
-                    # find last nonzero char
-                    let count =
-                        for i in (rrange ('vacount handle))
-                            if ((ptr @ i) != 0:char)
-                                break (i + 1)
-                        else 0:u32
-                    print
-                        repr
-                            string (& (ptr @ 0)) count
-                default
-                    print "unhandled:" (string handle.name)
-                finalize;
+        output
+            tupleof SystemKey.Screen
+                do
+                    # frame time
+                    let it = (fdiv (utof inpit) (fconst 60.0))
+                    # screen size
+                    let w h =
+                        comp 0 inpss
+                        comp 1 inpss
+                    let pos = (range w h)
+                    let x y =
+                        comp 0 pos
+                        comp 1 pos
+                    let u = (fdiv (utof x) (utof w))
+                    let v = (fdiv (utof y) (utof h))
+                    let q = (sample checkers_texture (vec2 u v))
+                    #let q = (fconst 1.0)
+                    let u = (fmul q u)
+                    let v = (fmul q v)
+                    let z = (fmul q (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5)))
+                    (vec4 u v z (fconst 1)) as AnyId
 
 # perform an identity transform and swap out the new module
     all transformations are immutable.