664a8e813f58 — Leonard Ritter a month ago
* fixed test_tmt6
M lib/tukan/FIR.sc +16 -0
@@ 164,6 164,20 @@ let
     mutinstrcolor... = (_ (dot.fontcolor = "#ff4040") (dot.color = "#ff4040"))
     commentcolor... = (_ (dot.fontcolor = "#969896") (dot.color = "#969896"))
 
+# FIR Level 3
+################################################################################
+
+define-type "cell" (RIFF "CELL") (tuple (items = (array AnyId)))
+    instrcolor...
+define-type "text" (RIFF "TEXT") (tuple (chars = (array char)))
+    stringcolor...
+define-type "symbol" (RIFF "SYMN") (tuple (string = AnyId))
+    stringcolor...
+define-type "iconst" (RIFF "I32C") (tuple (value = i32))
+    constcolor...
+define-type "bconst" (RIFF "BOOC") (tuple (value = bool))
+    constcolor...
+
 # FIR Level 2
 ################################################################################
 

          
@@ 2701,6 2715,8 @@ sugar FIRfn (name (args...) body...)
         list let name '= expr
     else expr
 
+################################################################################
+
 #sugar FIRstatic ((args... '= init...) ('break break...) ('repeat repeat...))
     print args...
     print init...

          
M lib/tukan/gl.sc +12 -0
@@ 246,6 246,17 @@ typedef GLframebuffer < GLobject :: GLui
 
 #-------------------------------------------------------------------------------
 
+using GL filter "^(Create|Delete)Renderbuffers$"
+
+typedef GLrenderbuffer < GLobject :: GLuint
+    inline __typecall (cls)
+        bitcast (gen1 CreateRenderbuffers) this-type
+
+    inline __drop (self)
+        del1 DeleteRenderbuffers self
+
+#-------------------------------------------------------------------------------
+
 inline error-message-func (msg)
     inline ()
         static-error msg

          
@@ 264,6 275,7 @@ let GL =
                 GLtexture GL_TEXTURE_2D
         Buffer = GLbuffer
         Framebuffer = GLframebuffer
+        Renderbuffer = GLrenderbuffer
         Query = GLquery
         QueryTimeElapsed =
             inline ()

          
M lib/tukan/raytrace.sc +1 -1
@@ 12,7 12,7 @@ using import struct
     vec4 tmax = (p + sd) * invd;
     near = max(max(tmin.x, tmin.y),max(tmin.z, tmin.w));
     far = min(min(tmax.x, tmax.y),min(tmax.z, tmax.w));
-	return near <= far && far >= 0.0;
+    return near <= far && far >= 0.0;
 
 fn iCube (ro rd)
     """"For ``ro + rd * t`` returns near and far ``t`` that intersect with

          
M lib/tukan/vm.sc +1 -1
@@ 309,7 309,7 @@ fn... runvm (
             if continue?
                 on-draw vm
                 'swap glmain
-            vm.screensize = (uvec2 ('size glmain))
+            vm.screensize = (uvec2 glmain.size)
             if (not continue?)
                 vm.close? = true
                 inflags |= InputFlags.Close

          
M testing/solid_angle.sc +2 -0
@@ 458,3 458,5 @@ do
     test_probe L (vec3 0 0.5 0.5)
     test_probe L (vec3 0 0 1)
 
+print "sh basis dot"
+    dot SH1_Basis SH1_Basis

          
M testing/test_cadag_gui2.sc +1 -1
@@ 242,7 242,7 @@ type+ App
         fill;
 
         fill-color TextColor
-        font-size 12
+        font-size 24
         font-face self.monofont
         text 200 200 "The Quick Brown Fox Yadda Yadda" null
 

          
M testing/test_tmt6.sc +16 -16
@@ 1417,23 1417,23 @@ inline main ()
 
     let NUM_CMD_BUFFERS = 1
 
-    global compute_cmd_buffers = (GL.CreateBuffer)
+    global compute_cmd_buffers = (GL.Buffer)
     setup-ssbo compute_cmd_buffers buf-compute-cmd NUM_CMD_BUFFERS
 
-    global draw_cmd_buffers = (GL.CreateBuffer)
+    global draw_cmd_buffers = (GL.Buffer)
     setup-ssbo draw_cmd_buffers buf-draw-cmd NUM_CMD_BUFFERS
 
     let NUM_BUFFERS = 2
 
     global cell_info_buffers =
         arrayof GL.uint
-            GL.CreateBuffer;
-            GL.CreateBuffer;
+            GL.Buffer;
+            GL.Buffer;
 
     global cell_buffers =
         arrayof GL.uint
-            GL.CreateBuffer;
-            GL.CreateBuffer;
+            GL.Buffer;
+            GL.Buffer;
     let cell_info_buffer_sz = (sizeof u32)
     let cell_buffer_sz = ((sizeof u32) * MAX_VOXELS)
     for i in (range (NUM_BUFFERS as u32))

          
@@ 1446,11 1446,11 @@ inline main ()
         GL.BindBufferRange GL.SHADER_STORAGE_BUFFER (BINDING_BUF_CELLS_IN + i)
             \ buf 0:i64 (i64 cell_buffer_sz)
 
-    global vertex_buffer = (GL.CreateBuffer)
+    global vertex_buffer = (GL.Buffer)
     let vertex_buffer_sz = ((sizeof CubeData) * MAX_VOXELS)
     GL.NamedBufferData vertex_buffer (i32 vertex_buffer_sz) null GL.STREAM_COPY
 
-    global fb-scene-color = (GL.CreateTexture GL.TEXTURE_2D)
+    global fb-scene-color = (GL.Texture GL.TEXTURE_2D)
     'setup fb-scene-color
         size = (ivec2 2048 2048)
         format = GL.RGBA32F

          
@@ 1458,17 1458,17 @@ inline main ()
         let h = 2048
         GL.ClearTexImage fb-scene-color 0 GL.RGBA GL.FLOAT null
 
-    global rb-scene-depth = (GL.CreateRenderbuffer)
+    global rb-scene-depth = (GL.Renderbuffer)
     setup-renderbuffer rb-scene-depth 2048 2048
         format = GL.DEPTH_COMPONENT
-    global fb-scene = (GL.CreateFramebuffer)
+    global fb-scene = (GL.Framebuffer)
     setup-framebuffer fb-scene
         color = fb-scene-color
         rb-depth = rb-scene-depth
 
-    global vao-empty = (GL.CreateVertexArray)
+    global vao-empty = (GL.VertexArray)
 
-    global pg-rasterize = (GL.CreateProgram)
+    global pg-rasterize = (GL.Program)
     call
         attach-shaders (deref pg-rasterize)
             vertex = rasterize-vert

          
@@ 1476,24 1476,24 @@ inline main ()
             fragment = rasterize-frag
             #debug = true
 
-    global pg-supershader = (GL.CreateProgram)
+    global pg-supershader = (GL.Program)
     call
         attach-shaders (deref pg-supershader)
             compute = supershader
 
-    global pg-simplify = (GL.CreateProgram)
+    global pg-simplify = (GL.Program)
     call
         attach-shaders (deref pg-simplify)
             compute = simplify
             #debug = true
 
-    global pg-setup-compute = (GL.CreateProgram)
+    global pg-setup-compute = (GL.Program)
     call
         attach-shaders (deref pg-setup-compute)
             compute = setup-compute-command
             #debug = true
 
-    global pg-setup-draw = (GL.CreateProgram)
+    global pg-setup-draw = (GL.Program)
     call
         attach-shaders (deref pg-setup-draw)
             compute = setup-draw-arrays-command

          
M testing/test_vertexpainter.sc +1 -1
@@ 1,7 1,7 @@ 
 
 using import glm
 
-import ..tukan.use
+import ..lib.tukan.use
 using import tukan.VertexPainter
 using import tukan.GLMain
 using import tukan.gl

          
M testing/testfragment.sc +9 -7
@@ 2,6 2,7 @@ 
 using import glm
 using import glsl
 using import struct
+using import Capture
 
 import ..lib.tukan.use
 using import tukan.GLMain

          
@@ 47,7 48,7 @@ inline render-fragment-shader (func opts
     print "escape: toggle mouse capture"
     print "wsadrf: move"
 
-    let screen = (Screen)
+    global screen = (Screen)
 
     let frame-setup shader-func = (func)
 

          
@@ 243,8 244,7 @@ inline render-fragment-shader (func opts
         GL.UseProgram 0
         GL.EndQuery GL.TIME_ELAPSED
 
-    @@ 'on GLMain.on-event
-    inline (event glmain)
+    inline handle-event (event glmain)
         switch (event.type as (typeof SDL_KEYDOWN))
         case SDL_MOUSEMOTION
             if capturing

          
@@ 280,12 280,14 @@ inline render-fragment-shader (func opts
             ;;
 
 
-    @@ 'on GLMain.on-draw
-    inline (time size glmain)
-        render-view size
-    let gui = (GUI glmain)
+    #let gui = (GUI glmain)
 
     'run glmain
+        capture (event) {(view glmain)}
+            handle-event event glmain
+
+        capture () {(view glmain)}
+            render-view (deref glmain.size)
 
 do
     let render-fragment-shader shglobals

          
M testing/tukdag.sc +115 -3
@@ 255,8 255,8 @@ inline gen-level2-test-geometry ()
                         ftou (fmul v (utof TS))
                     fetch cube_texture (uvec2 u v)
                 let tex =
-                    hardcube u v
-                    #softcube u v
+                    #hardcube u v
+                    softcube u v
                 inline tform (x)
                     fmul (fadd (fmul x (fconst 0.5)) (fconst 0.5)) tex
                 let r = (tform r)

          
@@ 360,6 360,108 @@ inline gen-level2-test ()
                 repeat (va 1 result)
     funccolor...
 
+fn... parse-scopes-list (module : FIR, value : Value)
+    returning (viewof AnyId 1)
+    raising Error
+
+    let builder = module.builder
+    from (methodsof builder) let iconst uconst fconst bconst
+
+    let recur = this-function
+    let T = ('typeof value)
+    match T
+    case list
+        let l = (value as list)
+        let count = (countof l)
+        let items = (malloc-array AnyId count)
+        for i entry in (enumerate l u32)
+            items @ i = (recur module entry)
+        let expr =
+            'alloc module TypeId.typeid_expr (countof l)
+        let args = expr.items
+        for i in (range count)
+            args @ i = items @ i
+        free items
+        return ('commit module)
+    case string
+        return ('string builder (value as string))
+    case Symbol
+        let sym = (value as Symbol as string)
+        return ('symbol builder ('string builder (sym as string)))
+    case Nothing
+        return NoId
+    case bool
+        return (bconst (value as bool))
+    default
+        let ST = ('storageof T)
+        let tk = ('kind ST)
+        switch tk
+        case type-kind-integer
+            let value = (sc_const_int_extract value)
+            if (value > 0xffffffff:u64)
+                error "64-bit numerals not supported"
+            if ('signed? ST)
+                return (iconst (value as i32))
+            else
+                return (uconst (value as u32))
+        case type-kind-real
+            return (fconst ((sc_const_real_extract value) as f32))
+        default;
+        report "unable to handle type" (repr T)
+        error (.. "unable to handle type " (repr T))
+
+inline gen-level3-test ()
+    let data =
+        sugar-quote 2 3.1 "test" true yes no
+    parse-scopes-list module data
+
+#
+    from (methodsof module.builder) let uvec fvec2 fvec3 fvec4 input output uconst
+        \ fconst comp and xor utof sin cos fadd fmul fdiv sample fsub
+        \ outputs sub unpack-comp udiv urem primitive fragment selectfragment
+        \ clear depthtest overlay map uvec2 compute globalid
+    let fir-module = module
+
+    let inpit = (input SystemKey.Iteration)
+
+    let TS = (uconst 32)
+    let checkers_texture1 =
+        compute (uvec2 TS TS)
+            do
+                let x y =
+                    unpack-comp (globalid) 2
+                utof (xor (and x (uconst 1)) (and y (uconst 1)))
+
+    let TS = (uconst 16)
+    let checkers_texture2 =
+        compute (uvec2 TS TS)
+            do
+                let x y =
+                    unpack-comp (globalid) 2
+                utof (xor (and x (uconst 1)) (and y (uconst 1)))
+
+    let w h =
+        unpack-comp (input SystemKey.ScreenSize) 2
+
+    outputs
+        output SystemKey.Screen
+            compute (input SystemKey.ScreenSize)
+                do
+                    let x y =
+                        unpack-comp (globalid) 2
+                    # frame time
+                    let it = (fdiv (utof inpit) (fconst 60.0))
+                    let itsin = (fadd (fmul (sin it) (fconst 0.5)) (fconst 0.5))
+                    # screen size
+                    let u = (fdiv (utof x) (utof w))
+                    let v = (fdiv (utof y) (utof h))
+                    let q0 = (sample checkers_texture1 (fvec2 (fadd u itsin) v))
+                    let q1 = (sample checkers_texture2 (fvec2 u (fadd v itsin)))
+                    #let q = (fconst 1.0)
+                    let u = (fmul q0 u)
+                    let v = (fmul q1 v)
+                    let z = (fmul (fadd q0 q1) itsin)
+                    fvec4 u v z (fconst 1)
 
 # perform an identity transform and swap out the new module
     all transformations are immutable.

          
@@ 386,8 488,18 @@ inline graphviz (rootid)
 
 #let prog = (gen-level1-test-geometry)
 #let prog = (gen-level1-test)
+let prog =
+    do
+        let prog = (gen-level3-test)
+        let prog = (cleanup prog)
+        #'dump module prog
+        #if true
+            exit 0
+        #dump-types prog
+        print "lowering..."
+        'lower module prog
 
-let prog =
+#let prog =
     do
         let prog = (gen-level2-test-geometry)
         let prog = (cleanup prog)