d705250693f0 — Leonard Ritter 3 months ago
* initial CADAG GUI work
2 files changed, 63 insertions(+), 24 deletions(-)

M lib/tukan/CADAG/init.sc
M lib/tukan/imgui/init.sc
M lib/tukan/CADAG/init.sc +62 -23
@@ 682,6 682,7 @@ type+ CADAG
             struct (do name) < this-type
                 words : (Array u32)
                 temp : (Array u32)
+                ids : (Array u32) # id -> offset in words buffer
                 dedup_map : (Map u256 u32)
 
                 let instance = (new-env-data)

          
@@ 750,6 751,9 @@ type+ CADAG
                 words @ 0 = 0:u32 # typeid
                 words @ 1 = 0:u32 # size
                 words @ 2 = 0:u32 # root id
+                let ids = self.ids
+                'resize ids 1
+                ids @ 0 = 0:u32
             deref self
 
     fn... temp-allocate (self, typeid : u32, wordcount : u32)

          
@@ 767,13 771,15 @@ type+ CADAG
 
     fn _commit-raw (self ptr size)
         let cls = (typeof self)
-        let words = self.words
+        from self let words ids
         # replace tail index
         let offset = ((countof words) as u32)
         let endoffset = (offset + size)
         'resize words endoffset
         memcpy (& (words @ offset)) ptr (size * u32_size)
-        bitcast offset cls.AnyId
+        let id = ((countof ids) as u32)
+        'append ids offset
+        bitcast id cls.AnyId
 
     fn commit-from (self ptr)
         let cls = (typeof self)

          
@@ 809,7 815,7 @@ type+ CADAG
     inline alloc-func (cls typeid)
         let T = (('typeinfo typeid) . T)
         let ET = (flexible-struct-type T)
-        IdType := cls.AnyId # (cls.Id typeid)
+        #IdType := cls.AnyId # (cls.Id typeid)
         static-assert ((alignof T) <= 4)
             .. "type " (tostring T) " must have alignment <= 4, but has "
                 tostring (alignof T)

          
@@ 830,24 836,36 @@ type+ CADAG
     inline... alloc (self, typeid : TypeId, ...)
         (alloc-func (typeof self) typeid) self ...
 
-    fn... handleof (self, offset : u32)
+    fn... handleofoffset (self, offset : u32)
         let cls = (typeof self)
-        let typeid sz = ('headerof self offset)
+        let typeid sz = ('headerofoffset self offset)
         let ptr = (& (self.words @ offset))
         bitcast
             ((storageof cls.HandleType) typeid sz ptr)
             cls.HandleType
 
-    fn... headerof (self, offset : u32)
+    fn... headerofoffset (self, offset : u32)
         let cls = (typeof self)
         _
             bitcast (deref (self.words @ offset)) cls.TypeId
             deref (self.words @ (offset + 1))
 
-    fn... typeidof (self, offset : u32)
+    fn... typeidofoffset (self, offset : u32)
         let cls = (typeof self)
         bitcast (deref (self.words @ offset)) cls.TypeId
 
+    inline... headeroffsetof (self, id : Id)
+        copy (self.ids @ id)
+
+    fn... handleof (self, id : Id)
+        handleofoffset self ('headeroffsetof self id)
+
+    fn... headerof (self, id : Id)
+        headerofoffset self ('headeroffsetof self id)
+
+    fn... typeidof (self, id : Id)
+        typeidofoffset self ('headeroffsetof self id)
+
     struct StackEntry plain
         id : u32
         offset : u32

          
@@ 891,15 909,29 @@ type+ CADAG
             va-option on-leave ...
                 inline (module id)
                     let handle = ('handleof module id)
-                    report "done" id (string handle.typeid.name)
+                    #report "done" id (string handle.typeid.name)
+                    ;
         let on-enter =
             va-option on-enter ...
                 inline (module id) true
-        local stack : DescendStack
         local seen : (Set u32)
+        let on-enter-param =
+            va-option on-enter-param ...
+                inline (module id index paramid)
+                    if (not ('in? seen paramid))
+                        'insert seen paramid
+                        true
+                    else false
+        let on-leave-param =
+            va-option on-leave-param ...
+                inline (module id index paramid)
         'insert seen 0:u32
-        if (on-enter (view self) root)
-            'push stack self root
+        local stack : DescendStack
+        if (on-enter-param (view self) cls.NoId 0 root)
+            if (on-enter (view self) root)
+                'push stack self root
+            else
+                return;
         else
             return;
         loop ()

          
@@ 907,21 939,29 @@ type+ CADAG
             let ofs = ('enum-id-offset ((copy md.typeid) as cls.TypeId) (copy md.refindex))
             let wordofs = (ofs // u32_size)
             if (wordofs >= md.size)
-                let oldid = (copy md.id)
-                on-leave (view self) (bitcast oldid cls.AnyId)
+                let oldid = (bitcast (copy md.id) cls.AnyId)
+                on-leave (view self) oldid
                 # clear
                 'pop stack
                 if (empty? stack)
+                    on-leave-param self cls.NoId 0 oldid
                     return;
+                else
+                    let md = ('peek stack)
+                    on-leave-param self (bitcast (copy md.id) cls.AnyId)
+                        \ ((copy md.refindex) - 1) oldid
             else
                 assert ((ofs % u32_size) == 0)
                 let ofs = (md.offset + wordofs)
                 md.refoffset = (ofs as u32)
+                let nextid = (copy (self.words @ ofs))
+                let nextid = (bitcast nextid cls.AnyId)
+                let parentid = (bitcast (copy md.id) cls.AnyId)
+                let enter? = (on-enter-param (view self) parentid
+                    (copy md.refindex) nextid)
                 md.refindex += 1
-                let nextid = (copy (self.words @ ofs))
-                if (not ('in? seen nextid))
-                    'insert seen nextid
-                    if (on-enter (view self) (bitcast nextid cls.AnyId))
+                if enter?
+                    if (on-enter (view self) nextid)
                         'push stack self nextid
 
     struct TransformStack

          
@@ 1181,12 1221,11 @@ type+ CADAG
     inline... store (self, typeid : TypeId, ...)
         (store-func typeid) self ...
 
-    fn offsetof (self id)
-        (id as u32) + 2
+    inline... offsetof (self, id : Id)
+        ('headeroffsetof self id) + 2:u32
 
-    fn... load (self, id : u32)
-        offset := (id as u32) + 2
-        & (self.words @ offset)
+    fn... load (self, id : Id)
+        & (self.words @ ('offsetof self id))
 
     fn... repr
     case (self, handle : Handle)

          
@@ 1212,7 1251,7 @@ type+ CADAG
                 body
         else body
 
-    fn... tostring (self, id : u32)
+    fn... tostring (self, id : Id)
         let cls = (typeof self)
         let typeid sz = ('headerof self id)
         let ptr = ('load self id)

          
M lib/tukan/imgui/init.sc +1 -1
@@ 305,7 305,7 @@ inline ShowDemoWindow (p_open)
         else extra_flags
 
 inline CalcTextSize (text text_end hide_text_after_double_hash wrap_width)
-    igCalcTextSize text
+    vec2-getter2 igCalcTextSize text
         static-if (none? text_end) null
         else text_end
         static-if (none? hide_text_after_double_hash) false