8b87d1d3c71f — Leonard Ritter tip a day ago
* initial check-in uvmedit
M lib/tukan/main.sc +11 -0
@@ 92,6 92,17 @@ inline ()
                     'new-module app target_path
                 except (err)
                     handle-gui-error err
+        if (MenuItem "Open Module")
+            local target_path : (mutable rawstring)
+            let result =
+                NFD_OpenDialog "tuk"
+                    module-dir
+                    &target_path
+            if (result as integer == 1)
+                try
+                    'new-module app target_path
+                except (err)
+                    handle-gui-error err
     if (WithMenu "View")
         MenuItem "Show Demo Window"
             selected = test-window-visible

          
M lib/tukan/module.sc +20 -26
@@ 265,29 265,31 @@ type+ Act
         #assert (atom == digest)
         atom
 
-    fn load (self)
+    fn rootkey? (self)
+        let key = (dbkey (Atom))
+        let content =
+            try ('get self._txn self._db.blob key)
+            except (err)
+                return false
+        let digestsize digest = (unpack content)
+        if (digestsize != (sizeof Atom.DigestType))
+            return false
+        true
+
+    fn... load
+    case (self, cache : Atom.Set)
         let key = (dbkey (Atom))
         let content =
             try ('get self._txn self._db.blob key)
             except (err) (raise (err as ModuleError))
         let digestsize digest = (unpack content)
         assert (digestsize == (sizeof Atom.DigestType))
-
-        local cache :
-            Set Atom
-                inline (value)
-                    static-if ((typeof value) == Atom.DigestType)
-                        Atom.hash-from-digest value
-                    else
-                        hash value
-        va-map
-            inline (value)
-                'insert cache value
-            Atom;
-            Atom false
-            Atom true
-
-        load1 self content cache
+        _
+            load1 self content cache
+            cache
+    case (self)
+        local cache : Atom.Set
+        this-function self cache
 
 type+ EditAct
     fn... store1 (self, key : db.Value, value : Atom)

          
@@ 330,15 332,7 @@ type+ EditAct
         ;
 
     fn... store (self, root : Atom, root? : bool = true)
-        local done : (Set Atom)
-        va-map
-            inline (value)
-                local key = ('hashbits value)
-                'insert done value
-            Atom;
-            Atom false
-            Atom true
-
+        local done : Atom.Set
         fn recur (value ...)
             let self done = ...
             let recur = this-function

          
M lib/tukan/uvm.sc +50 -7
@@ 745,7 745,8 @@ struct Cell
             default;
         set self key (Atom)
 
-    fn... get (self, key : Atom)
+    fn... get
+    case (self, key : Atom, fallback : Atom)
         label do-regular-get
             dispatch key
             case Number (num)

          
@@ 755,19 756,21 @@ struct Cell
                         merge do-regular-get
                 return (get-index self index)
             default;
-        fn recur (keylimb valuelimb key depth)
+        fn recur (keylimb valuelimb key depth fallback)
             returning (uniqueof Atom -1)
             let mask = (((('hashbits key) >> (depth * IndexBits)) as u32) & IndexMask)
             if (('kind keylimb) == Atom.Kind.CellLimb) # branch
                 local newkl = (copy (keylimb as CellLimb))
                 local newvl = (copy (valuelimb as CellLimb))
                 return
-                    this-function (newkl.cells @ mask) (newvl.cells @ mask) key (depth + 1)
+                    this-function (newkl.cells @ mask) (newvl.cells @ mask) key (depth + 1) fallback
             elseif (keylimb == key) # found key
                 return (copy valuelimb)
             # key not found
-            return (Atom)
-        recur self.keys self.values key 0
+            return (copy fallback)
+        recur self.keys self.values key 0 fallback
+    case (self, key : Atom)
+        this-function self key (Atom)
 
     fn new (...)
         local table : this-type

          
@@ 829,6 832,25 @@ let
     UCell = (UType Cell)
 
 type+ Atom
+    let Set =
+        Set this-type
+            inline (value)
+                static-if ((typeof value) == Atom.DigestType)
+                    this-type.hash-from-digest value
+                else
+                    hash value
+
+    type+ Set
+        let _typecall = this-type.__typecall
+
+        inline __typecall (cls)
+            local self = (_typecall cls)
+            'insert self (Atom)
+            'insert self (Atom false)
+            'insert self (Atom true)
+            deref self
+        unlet _typecall
+
     enum Kind plain
         None = 0
         False

          
@@ 890,6 912,25 @@ type+ Atom
         viewing self
         ((ptrtoint (storagecast self) usize) & 0xf) as (storageof Kind) as Kind
 
+    inline cell? (self)
+        (kind self) == Kind.Cell
+
+    inline number? (self)
+        (kind self) == Kind.Number
+
+    fn bool? (self)
+        switch (kind self)
+        pass Kind.False
+        pass Kind.True
+        do true
+        default false
+
+    fn string? (self)
+        (kind self) == Kind.String
+
+    fn symbol? (self)
+        (kind self) == Kind.Symbol
+
     @@ memo
     inline __as (cls T)
         static-if (T == bool)

          
@@ 898,7 939,8 @@ type+ Atom
                 case Kind.False false
                 case Kind.True true
                 default
-                    assert false "Atom isn't a boolean"
+                    assert false
+                        .. (repr self) " isn't a boolean"
                     unreachable;
         elseif (T == Number)
             inline (self)

          
@@ 915,7 957,8 @@ type+ Atom
         elseif (T == String)
             inline (self)
                 switch (kind self)
-                pass Kind.String
+                pass Kind.Blob
+                pass Kind.Text
                 pass Kind.Symbol
                 do
                     (bitcast (topointer self) UString) . data

          
M testing/test_uvm.sc +13 -0
@@ 101,6 101,19 @@ fn testfunc ()
     assert (expr == expr2)
     assert (result1 == result2)
 
+    #
+        UVM specialization:
+
+        * count use of each expression
+        * track scope of each expression
+        * allocate temporary resources
+
+        function input:
+
+        list of events
+
+
+
 
 #
     print

          
M testing/testaudio.sc +4 -2
@@ 1,7 1,9 @@ 
 
-import ..tukan.audio
-using import ..tukan.sdl
 using import itertools
+
+import ..lib.tukan.use
+import tukan.audio
+using import tukan.sdl
 let audio = tukan.audio
 
 let BUFFERSIZE = 1024

          
M testing/testfragment.sc +7 -6
@@ 3,13 3,14 @@ using import glm
 using import glsl
 using import struct
 
-using import ..tukan.GLMain
-using import ..tukan.Screen
-using import ..tukan.GUI
+import ..lib.tukan.use
+using import tukan.GLMain
+using import tukan.Screen
+using import tukan.GUI
 
-using import ..tukan.gl
-using import ..tukan.sdl
-using import ..tukan.rotation
+using import tukan.gl
+using import tukan.sdl
+using import tukan.rotation
 
 let BUFFER_COUNT = 3
 

          
A => testing/uvmedit.sc +222 -0
@@ 0,0 1,222 @@ 
+
+using import Map
+using import String
+using import struct
+
+import ..lib.tukan.use
+using import tukan.gl
+using import tukan.sdl
+using import tukan.module
+using import tukan.uvm
+
+let controllerdb =
+    import tukan.gamecontrollerdb
+
+global DEFAULT_ROOT =
+    uquote
+        ;
+            : windows
+                ;
+                    : main
+                        ;
+                            : title "UVM"
+                            #: origin (100 100)
+                            : size (960 540)
+                            : resizable true
+                            : visible true
+
+let BOOT_FILEPATH =
+    .. module-dir "/boot.um"
+
+global module =
+    do
+        report "booting" BOOT_FILEPATH
+        try (Module.from-path BOOT_FILEPATH)
+        except (err)
+            raise (err as Error)
+
+global root =
+    do
+        try
+            let act = ('edit module)
+            if true #(not ('rootkey? act))
+                report "generating default object..."
+                'store act DEFAULT_ROOT
+                'commit act
+            let act = ('view module)
+            _ ('load act) ()
+        except (err)
+            raise (err as Error)
+
+fn set-root (newroot)
+    root = newroot
+    try
+        let act = ('edit module)
+        'store act root
+        'commit act
+    except (err)
+        raise (err as Error)
+
+#report
+    'tostring root
+
+SDL_SetHint "SDL_GAMECONTROLLERCONFIG" controllerdb
+
+SDL_Init
+    | SDL_INIT_AUDIO
+        SDL_INIT_VIDEO
+        SDL_INIT_GAMECONTROLLER
+        #SDL_INIT_JOYSTICK
+
+SDL_GL_SetAttribute SDL_GL_DOUBLEBUFFER 1
+
+SDL_GL_SetAttribute SDL_GL_STENCIL_SIZE 8
+SDL_GL_SetAttribute SDL_GL_DEPTH_SIZE 24
+
+SDL_GL_SetAttribute SDL_GL_CONTEXT_MAJOR_VERSION 4
+SDL_GL_SetAttribute SDL_GL_CONTEXT_MINOR_VERSION 5
+#if IS_OSX
+    SDL_GL_SetAttribute
+        SDL_GL_CONTEXT_PROFILE_MASK
+        SDL_GL_CONTEXT_PROFILE_CORE
+
+struct WindowContext
+    def : Atom
+    window : (returnof SDL_CreateWindow)
+    glcontext : (returnof SDL_GL_CreateContext)
+
+    fn __drop (self)
+        if (self.glcontext != null)
+            SDL_GL_DeleteContext self.glcontext
+        if (self.window != null)
+            SDL_DestroyWindow self.window
+
+
+global last-windows : Atom = (Cell)
+global active-windows :
+    Map Atom WindowContext
+
+fn add-remove-windows ()
+    let windows =
+        'get (root as Cell) 'windows
+    loop ()
+        if
+            for key ctx in active-windows
+                let windowinfo = ('get (windows as Cell) key)
+                if ('none? windowinfo)
+                    report "window closed"
+                    'discard active-windows (copy key)
+                    break true
+            else false
+            repeat;
+        else
+            break;
+    call
+        Cell.gen-each-pair
+            fn "update-window" (key value)
+                let windowinfo = (value as Cell)
+                if (not ('in? active-windows key))
+                    let title =
+                        ('get windowinfo 'title) as String as string
+                    let origin = ('get windowinfo 'origin)
+                    let size =
+                        ('get windowinfo 'size) as Cell
+                    let visible =
+                        ('get windowinfo 'visible) as bool
+                    let resizable =
+                        ('get windowinfo 'resizable) as bool
+                    let x y =
+                        if ('none? origin)
+                            _ SDL_WINDOWPOS_UNDEFINED SDL_WINDOWPOS_UNDEFINED
+                        else
+                            let origin = (origin as Cell)
+                            _
+                                ('get origin 0) as Number as integer
+                                ('get origin 1) as Number as integer
+                    # create
+                    let window =
+                        SDL_CreateWindow title x y
+                            ('get size 0) as Number as integer
+                            ('get size 1) as Number as integer
+                            | SDL_WINDOW_OPENGL
+                                ? visible SDL_WINDOW_SHOWN SDL_WINDOW_HIDDEN
+                                ? resizable (u32 SDL_WINDOW_RESIZABLE) 0:u32
+                    let context = (SDL_GL_CreateContext window)
+                    assert (context != null)
+                    SDL_GL_MakeCurrent window context
+                    SDL_GL_SetSwapInterval 1
+                    do
+                        let result = (GL.gladLoadGL)
+                        assert (result != 0) "failed to load GL core functions"
+                    print-gl-info;
+                    hook-gl-debug;
+                    'set active-windows (copy key)
+                        WindowContext (copy value) window context
+                else
+                    let ctx =
+                        try ('get active-windows (copy key))
+                        else
+                            return;
+                    if (ctx.def != value)
+                        report "window info changed..."
+                    ;
+
+        windows as Cell
+    last-windows = windows
+
+add-remove-windows;
+
+fn handle-events ()
+    local event = (SDL_Event)
+    loop (quit = false)
+        if ((SDL_PollEvent &event) == 0)
+            break quit
+        if (event.type == SDL_QUIT)
+            repeat true
+        elseif
+            &
+                event.type == SDL_WINDOWEVENT
+                event.window.event == (SDL_WINDOWEVENT_CLOSE as integer)
+            local windows =
+                copy (('get (root as Cell) 'windows) as Cell)
+            local quit = quit
+            for key ctx in active-windows
+                if (event.window.windowID == (SDL_GetWindowID ctx.window))
+                    if (key == 'main)
+                        quit = true
+                    else
+                        windows = ('del windows key)
+            set-root
+                'set (root as Cell) 'windows windows
+            repeat (deref quit)
+        else
+            #on-event
+                event = event
+                glmain = self
+            repeat quit
+
+loop ()
+    if (handle-events)
+        break;
+    add-remove-windows;
+
+    for k ctx in active-windows
+        local w = 0
+        local h = 0
+        SDL_GetWindowSize ctx.window &w &h
+        SDL_GL_MakeCurrent ctx.window ctx.glcontext
+        GL.BindFramebuffer GL.FRAMEBUFFER 0
+        GL.Viewport 0 0 w h
+        GL.ClearColor 0 0 0.5 1
+        GL.Clear GL.COLOR_BUFFER_BIT
+        SDL_GL_SwapWindow ctx.window
+        #SDL_GL_MakeCurrent ctx.window null
+    repeat;
+
+'clear active-windows
+SDL_Quit;
+
+report "done."
+
+
+;