From b0961c9e23faa152bdc0aa63a003f2d84eb1578e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Mon, 27 Apr 2026 18:37:17 -0400 Subject: [PATCH 01/20] Restore shapes, arcs, fills --- builtin-programs/display/arc.folk | 125 +++++++++++++++++++++--------- builtin-programs/draw/fill.folk | 43 ++++++---- builtin-programs/draw/line.folk | 52 +++++++++---- builtin-programs/draw/shapes.folk | 87 +++++++++++++++++++++ 4 files changed, 240 insertions(+), 67 deletions(-) create mode 100644 builtin-programs/draw/shapes.folk diff --git a/builtin-programs/display/arc.folk b/builtin-programs/display/arc.folk index f6a0c678..81b59144 100644 --- a/builtin-programs/display/arc.folk +++ b/builtin-programs/display/arc.folk @@ -1,39 +1,90 @@ -# Example: -# When $this has region /r/ { -# lassign [region centroid $r] x y -# Wish to draw an arc with x $x y $y start 0 arclen 1 thickness 3 radius 100 color green -# } - -Wish the GPU compiles pipeline "arc" {{vec2 center float start float arclen float radius float thickness vec4 color} { - float r = radius + thickness; - vec2 vertices[4] = vec2[4]( - center - r, - vec2(center.x + r, center.y - r), - vec2(center.x - r, center.y + r), - center + r - ); - return vec4(vertices[gl_VertexIndex], 0.0, 1.0); -} { - #define M_TWO_PI 6.283185307179586 - start = clamp(start, 0, M_TWO_PI); - arclen = clamp(arclen, 0, M_TWO_PI); - - float dist = length(gl_FragCoord.xy - center) - radius; - float angle = atan(-(gl_FragCoord.y - center.y), gl_FragCoord.x - center.x); - - // Shift angle from [-pi, pi) to [0, 2*pi] - angle = (angle < 0) ? (angle + M_TWO_PI) : angle; - float end = start + arclen; - - return ((dist < thickness && dist > 0.0) && - ((end < M_TWO_PI && angle > start && angle < end) || - (end >= M_TWO_PI && (angle > start || angle < end-M_TWO_PI)))) ? color : vec4(0, 0, 0, 0); - -}} - -When /someone/ wishes to draw an arc with /...options/ { - dict with options { - Wish the GPU draws pipeline "arc" with arguments \ - [list [list $x $y] $start $arclen $radius $thickness [getColor $color]] +# Example +# When the clock time is /t/ { +# # Draw a spinning cyan arc +# set spinAngle [expr {fmod($t, 6.28318)}] +# +# Wish to draw an arc onto $this with \ +# center {0.05 0.05} \ +# radius 0.04 \ +# thickness 0.005 \ +# start $spinAngle \ +# arclen 3.14159 \ +# color "cyan" +# } + +Wish the GPU compiles pipeline "arc" { + {vec2 viewport mat3 surfaceToClip + vec2 center float radius float thickness float start float arclen vec4 color} { + + // Pad the bounding box with the thickness so the arc doesn't get clipped + float r = radius + thickness; + + // 6 vertices to make 2 triangles (a standard quad) + vec2 vertices[6] = vec2[6]( + center - r, + vec2(center.x + r, center.y - r), + vec2(center.x - r, center.y + r), + vec2(center.x + r, center.y - r), + center + r, + vec2(center.x - r, center.y + r) + ); + + vec3 v = surfaceToClip * vec3(vertices[gl_VertexIndex], 1.0); + return vec4(v.xy/v.z, 0.0, 1.0); + + } { + // Map screen coordinates back to tabletop surface coordinates + vec2 clipXy = (gl_FragCoord.xy / viewport) * 2.0 - 1.0; + vec3 surfaceXy = inverse(surfaceToClip) * vec3(clipXy, 1.0); + surfaceXy /= surfaceXy.z; + + float M_TWO_PI = 6.283185307179586; + float c_start = clamp(start, 0.0, M_TWO_PI); + float c_arclen = clamp(arclen, 0.0, M_TWO_PI); + + // Use the transformed surfaceXy instead of gl_FragCoord + float dist = length(surfaceXy.xy - center) - radius; + + // Y is inverted because Folk/screen-space Y goes down, but atan math expects Y up + float angle = atan(-(surfaceXy.y - center.y), surfaceXy.x - center.x); + + // Shift angle from [-pi, pi) to [0, 2*pi] + angle = (angle < 0.0) ? (angle + M_TWO_PI) : angle; + float end = c_start + c_arclen; + + // Determine if the pixel falls within the stroked ring AND within the angle slice + if (dist < thickness && dist > 0.0) { + if ((end < M_TWO_PI && angle > c_start && angle < end) || + (end >= M_TWO_PI && (angle > c_start || angle < end - M_TWO_PI))) { + return color; + } + } + + return vec4(0.0); } } + +When the color map is /colorMap/ &\ + /p/ has canvas /id/ with /...wiOptions/ &\ + /p/ has canvas projection /surfaceToClip/ &\ + /someone/ wishes to draw an arc onto /p/ with /...options/ { + + set center [dict getdef $options center ""] + if {$center eq ""} { set center [list [dict get $options x] [dict get $options y]] } + + set radius [dict get $options radius] + set thickness [dict get $options thickness] + set start [dict get $options start] + set arclen [dict get $options arclen] + + set color [dict get $options color] + set color [dict getdef $colorMap $color $color] + set layer [dict getdef $options layer 0] + + set wiResolution [list [dict get $wiOptions width] [dict get $wiOptions height]] + + Wish the GPU draws pipeline "arc" onto canvas $id with arguments \ + [list $wiResolution $surfaceToClip \ + $center $radius $thickness $start $arclen $color] \ + layer $layer +} \ No newline at end of file diff --git a/builtin-programs/draw/fill.folk b/builtin-programs/draw/fill.folk index 4e977c1e..a54e5f48 100644 --- a/builtin-programs/draw/fill.folk +++ b/builtin-programs/draw/fill.folk @@ -10,14 +10,17 @@ Wish the GPU compiles pipeline "fillTriangle" { When the color map is /colorMap/ { -When /someone/ wishes to draw a triangle with /...options/ { +When /someone/ wishes to draw a triangle onto /p/ with /...options/ &\ + /p/ has canvas /id/ with /...wiOptions/ &\ + /p/ has canvas projection /surfaceToClip/ { dict with options { if {![info exists layer]} { set layer 0 } set color [dict getdef $colorMap $color $color] - Wish the GPU draws pipeline "fillTriangle" with arguments \ - [list $p0 $p1 $p2 $color] layer $layer + Wish the GPU draws pipeline "fillTriangle" onto canvas $id with arguments \ + [list $surfaceToClip $p0 $p1 $p2 $color] layer $layer } } + When /someone/ wishes to draw a quad onto /p/ with /...options/ &\ /p/ has canvas /id/ with /...wiOptions/ &\ /p/ has canvas projection /surfaceToClip/ { @@ -30,7 +33,11 @@ When /someone/ wishes to draw a quad onto /p/ with /...options/ &\ [list $surfaceToClip $p0 $p1 $p3 $color] layer $layer } } -When /someone/ wishes to draw a polygon with /...options/ { + +When /someone/ wishes to draw a polygon onto /p/ with /...options/ &\ + /p/ has canvas /id/ with /...wiOptions/ &\ + /p/ has canvas projection /surfaceToClip/ { + set points [dict get $options points] set color [dict get $options color] set layer [dict getdef $options layer 0] @@ -39,31 +46,39 @@ When /someone/ wishes to draw a polygon with /...options/ { if {$num_points < 3} { error "At least 3 points are required to form a polygon." } elseif {$num_points == 3} { - Wish to draw a triangle with \ + Wish to draw a triangle onto $p with \ p0 [lindex $points 0] p1 [lindex $points 1] p2 [lindex $points 2] \ color $color layer $layer } elseif {$num_points == 4} { - Wish to draw a quad with \ + Wish to draw a quad onto $p with \ p0 [lindex $points 0] p1 [lindex $points 1] p2 [lindex $points 2] p3 [lindex $points 3] \ color $color layer $layer } else { # Get the first point in the list as the "base" point of the triangles set p0 [lindex $points 0] - set color [dict getdef $colorMap $color $color] + + # Batch the fanned-out triangles into a single GPU instance list + set instances [list] for {set i 1} {$i < $num_points - 1} {incr i} { set p1 [lindex $points $i] set p2 [lindex $points [expr {$i+1}]] - Wish the GPU draws pipeline "fillTriangle" with arguments \ - [list $p0 $p1 $p2 $color] layer $layer + lappend instances [list $surfaceToClip $p0 $p1 $p2 $color] } + Wish the GPU draws pipeline "fillTriangle" onto canvas $id \ + with instances $instances layer $layer } } -} - When /someone/ wishes /page/ is filled with /...options/ &\ - /page/ has region /region/ { - set points [region vertices $region] - Wish to draw a polygon with points $points {*}$options + /page/ has resolved geometry /geom/ { + dict with geom { + set points [list [list 0 0] \ + [list $width 0] \ + [list $width $height] \ + [list 0 $height]] + } + Wish to draw a polygon onto $page with points $points {*}$options } + +} \ No newline at end of file diff --git a/builtin-programs/draw/line.folk b/builtin-programs/draw/line.folk index 96215309..673f412e 100644 --- a/builtin-programs/draw/line.folk +++ b/builtin-programs/draw/line.folk @@ -1,18 +1,23 @@ Wish the GPU compiles pipeline "line" { {vec2 viewport mat3 surfaceToClip - vec2 from vec2 to float thickness vec4 color} { + vec2 from vec2 to float thickness vec4 color float capFrom float capTo} { + vec2 dir = normalize(to - from); - vec2 perp = vec2(-dir.y, dir.x) * thickness/2.0; + vec2 perp = vec2(-dir.y, dir.x) * (thickness / 2.0); + + // Push the quad outward so the rounded caps don't get clipped by the geometry bounds + vec2 ext = dir * (thickness / 2.0); vec2 vertices[6] = vec2[6]( - from + perp, - from - perp, - to - perp, + (from - ext) + perp, + (from - ext) - perp, + (to + ext) - perp, - from + perp, - to - perp, - to + perp + (from - ext) + perp, + (to + ext) - perp, + (to + ext) + perp ); + vec3 v = surfaceToClip * vec3(vertices[gl_VertexIndex], 1.0); return vec4(v.xy/v.z, 0.0, 1.0); } { @@ -20,12 +25,19 @@ Wish the GPU compiles pipeline "line" { vec3 surfaceXy = inverse(surfaceToClip) * vec3(clipXy, 1.0); surfaceXy /= surfaceXy.z; - float l = length(to - from); - vec2 d = (to - from) / l; - vec2 q = (surfaceXy.xy - (from + to)*0.5); - q = mat2(d.x, -d.y, d.y, d.x) * q; - q = abs(q) - vec2(l, thickness)*0.5; - float dist = length(max(q, 0.0)) + min(max(q.x, q.y), 0.0); + vec2 pa = surfaceXy.xy - from; + vec2 ba = to - from; + + // Calculate where the pixel projects along the line segment + float h_unclamped = dot(pa, ba) / dot(ba, ba); + + // Dynamically slice off the rounded ends based on our Tcl flags + if (capFrom > 0.5 && h_unclamped < 0.0) return vec4(0.0); + if (capTo > 0.5 && h_unclamped > 1.0) return vec4(0.0); + + // Clamp the remainder to calculate the capsule distance + float h = clamp(h_unclamped, 0.0, 1.0); + float dist = length(pa - ba * h) - (thickness / 2.0); return (dist < 0.0) ? color : vec4(0.0); } @@ -44,10 +56,18 @@ When the color map is /colorMap/ &\ set wiResolution [list [dict get $wiOptions width] [dict get $wiOptions height]] set instances [list] - for {set i 0} {$i < [llength $points] - 1} {incr i} { + set numPoints [llength $points] + + for {set i 0} {$i < $numPoints - 1} {incr i} { set from [lindex $points $i] set to [lindex $points [+ $i 1]] - lappend instances [list $wiResolution $surfaceToClip $from $to $width $color] + + # 1.0 = flat + # 0.0 = round + set capFrom [expr {$i == 0 ? 1.0 : 0.0}] + set capTo [expr {$i == ($numPoints - 2) ? 1.0 : 0.0}] + + lappend instances [list $wiResolution $surfaceToClip $from $to $width $color $capFrom $capTo] } Wish the GPU draws pipeline "line" onto canvas $id \ diff --git a/builtin-programs/draw/shapes.folk b/builtin-programs/draw/shapes.folk new file mode 100644 index 00000000..288d97f0 --- /dev/null +++ b/builtin-programs/draw/shapes.folk @@ -0,0 +1,87 @@ +When /someone/ wishes /p/ draws a /shape/ with /...options/ & \ + /p/ has resolved geometry /geom/ { + + # --- Scope-Safe Math Helpers --- + local proc parseShapeOffset {offset geom} { + set w [dict get $geom width]; set h [dict get $geom height] + set x [expr {$w / 2.0}]; set y [expr {$h / 2.0}] + + # If it's already a list of 2 numbers, use it as meters + if {[llength $offset] == 2 && [string is double -strict [lindex $offset 0]]} { + return $offset + } + # Parse "right 50%" style strings + if {[regexp {^(\w+)\s+([\d.]+)%$} $offset -> dir percent]} { + set p [expr {$percent / 100.0}] + switch $dir { + right { set x [expr {$w * $p}] } + left { set x [expr {$w * (1.0 - $p)}] } + down { set y [expr {$h * $p}] } + up { set y [expr {$h * (1.0 - $p)}] } + } + } + return [list $x $y] + } + + local proc getRegularPolygon {center radius sides} { + lassign $center cx cy + set pts [list] + for {set i 0} {$i < $sides} {incr i} { + set angle [expr {$i * 2.0 * 3.14159 / $sides - 1.5708}] + lappend pts [list [expr {$cx + $radius * cos($angle)}] \ + [expr {$cy + $radius * sin($angle)}]] + } + return $pts + } + + # --- Option Parsing --- + set radius [dict getdef $options radius 0.02] + set color [dict getdef $options color "white"] + set filled [dict getdef $options filled false] + set thickness [dict getdef $options thickness 0.002] + set layer [dict getdef $options layer 1] + + set offsetArg [dict getdef $options offset ""] + set offset [parseShapeOffset $offsetArg $geom] + + # --- Routing to Primitives --- + if {$shape eq "circle"} { + Wish to draw a circle onto $p with \ + center $offset radius $radius color $color \ + thickness $thickness filled $filled layer $layer + return + } + + set pts [list] + switch $shape { + triangle { set pts [getRegularPolygon $offset $radius 3] } + square { set pts [getRegularPolygon $offset [expr {$radius * 1.2}] 4] } + pentagon { set pts [getRegularPolygon $offset $radius 5] } + hexagon { set pts [getRegularPolygon $offset $radius 6] } + septagon { set pts [getRegularPolygon $offset $radius 7] } + octagon { set pts [getRegularPolygon $offset $radius 8] } + nonagon { set pts [getRegularPolygon $offset $radius 9] } + rect { + set rw [dict getdef $options width 0.04] + set rh [dict getdef $options height 0.02] + lassign $offset cx cy + set pts [list [list [expr {$cx-$rw/2}] [expr {$cy-$rh/2}]] \ + [list [expr {$cx+$rw/2}] [expr {$cy-$rh/2}]] \ + [list [expr {$cx+$rw/2}] [expr {$cy+$rh/2}]] \ + [list [expr {$cx-$rw/2}] [expr {$cy+$rh/2}]]] + } + } + + if {[llength $pts] == 0} return + + if {$filled eq "true" || $filled == 1} { + Wish to draw a polygon onto $p with points $pts color $color layer $layer + } else { + lappend pts [lindex $pts 0] + Wish to draw a line onto $p with points $pts width $thickness color $color layer $layer + } +} + +When /someone/ wishes /p/ draws a /shape/ { + Wish $p draws a $shape with offset "" color white filled true +} \ No newline at end of file From 5c7f9f23536e87d497ddb3bc7527fd1e39cec119 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 04:21:51 -0400 Subject: [PATCH 02/20] Port drawing curve and shapes APIs --- README.md | 2 +- builtin-programs/demos.folk | 2 +- builtin-programs/display/curve.folk | 135 ---------- builtin-programs/draw/curve.folk | 79 ++++++ builtin-programs/draw/shapes.folk | 378 +++++++++++++++++++++++----- builtin-programs/shapes.folk | 357 -------------------------- 6 files changed, 397 insertions(+), 556 deletions(-) delete mode 100644 builtin-programs/display/curve.folk create mode 100644 builtin-programs/draw/curve.folk delete mode 100644 builtin-programs/shapes.folk diff --git a/README.md b/README.md index d5bdbd68..f1a8d698 100644 --- a/README.md +++ b/README.md @@ -514,7 +514,7 @@ Use it in an animation: ``` When the clock time is /t/ { - Wish $this draws a circle with offset [list [expr {sin($t) * 50}] 0] + Wish $this draws a circle with offset [list [expr {sin($t) * 0.05}] 0] radius 0.012 } ``` diff --git a/builtin-programs/demos.folk b/builtin-programs/demos.folk index 192afd23..4a28aee5 100644 --- a/builtin-programs/demos.folk +++ b/builtin-programs/demos.folk @@ -24,7 +24,7 @@ Claim 45004 has demo code { } Claim 45005 has demo code { When the clock time is /t/ { - Wish $this draws a circle offset [list expr {sin($t) * 50} 0] + Wish $this draws a circle with offset [list [expr {sin($t) * 0.05}] 0] radius 0.012 } } Claim 45006 has demo code { diff --git a/builtin-programs/display/curve.folk b/builtin-programs/display/curve.folk deleted file mode 100644 index 9082d117..00000000 --- a/builtin-programs/display/curve.folk +++ /dev/null @@ -1,135 +0,0 @@ - -# Bezier implementation from https://www.shadertoy.com/view/XdVBWd - -Wish the GPU compiles function "bboxBezier" {{vec2 p0 vec2 p1 vec2 p2 vec2 p3} vec4 { - // Exact BBox to a quadratic bezier - // extremes - vec2 mi = min(p0,p3); - vec2 ma = max(p0,p3); - - vec2 k0 = -1.0*p0 + 1.0*p1; - vec2 k1 = 1.0*p0 - 2.0*p1 + 1.0*p2; - vec2 k2 = -1.0*p0 + 3.0*p1 - 3.0*p2 + 1.0*p3; - - vec2 h = k1*k1 - k0*k2; - - if( h.x>0.0 ) - { - h.x = sqrt(h.x); - //float t = (-k1.x - h.x)/k2.x; - float t = k0.x/(-k1.x-h.x); - if( t>0.0 && t<1.0 ) - { - float s = 1.0-t; - float q = s*s*s*p0.x + 3.0*s*s*t*p1.x + 3.0*s*t*t*p2.x + t*t*t*p3.x; - mi.x = min(mi.x,q); - ma.x = max(ma.x,q); - } - //t = (-k1.x + h.x)/k2.x; - t = k0.x/(-k1.x+h.x); - if( t>0.0 && t<1.0 ) - { - float s = 1.0-t; - float q = s*s*s*p0.x + 3.0*s*s*t*p1.x + 3.0*s*t*t*p2.x + t*t*t*p3.x; - mi.x = min(mi.x,q); - ma.x = max(ma.x,q); - } - } - - if( h.y>0.0) - { - h.y = sqrt(h.y); - //float t = (-k1.y - h.y)/k2.y; - float t = k0.y/(-k1.y-h.y); - if( t>0.0 && t<1.0 ) - { - float s = 1.0-t; - float q = s*s*s*p0.y + 3.0*s*s*t*p1.y + 3.0*s*t*t*p2.y + t*t*t*p3.y; - mi.y = min(mi.y,q); - ma.y = max(ma.y,q); - } - //t = (-k1.y + h.y)/k2.y; - t = k0.y/(-k1.y+h.y); - if( t>0.0 && t<1.0 ) - { - float s = 1.0-t; - float q = s*s*s*p0.y + 3.0*s*s*t*p1.y + 3.0*s*t*t*p2.y + t*t*t*p3.y; - mi.y = min(mi.y,q); - ma.y = max(ma.y,q); - } - } - - return vec4( mi, ma ); -}} - -Wish the GPU compiles function sdSegmentSq {{vec2 p vec2 a vec2 b} float { - vec2 pa = p-a, ba = b-a; - float h = clamp( dot(pa,ba)/dot(ba,ba), 0.0, 1.0 ); - vec2 d = pa - ba*h; - return dot(d, d); -}} - -Wish the GPU compiles function udBezier {{vec2 p0 vec2 p1 vec2 p2 vec2 p3 vec2 pos} vec2 { - const int kNum = 50; - vec2 res = vec2(1e10,0.0); - vec2 a = p0; - for( int i=1; i dir percent]} { - set p [expr {$percent / 100.0}] - switch $dir { - right { set x [expr {$w * $p}] } - left { set x [expr {$w * (1.0 - $p)}] } - down { set y [expr {$h * $p}] } - up { set y [expr {$h * (1.0 - $p)}] } + } + + if {[llength $offset] == 2} { + set dir [lindex $offset 0] + set amount [lindex $offset 1] + switch -- $dir { + right { return [list [drawShapeScalar $amount $width] 0] } + left { + set value [drawShapeScalar $amount $width] + return [list [expr {-$value}] 0] + } + down { return [list 0 [drawShapeScalar $amount $height]] } + up { + set value [drawShapeScalar $amount $height] + return [list 0 [expr {-$value}]] + } + default { + return [list [drawShapeScalar $dir $width] \ + [drawShapeScalar $amount $height]] } } + } + + error "draw/shapes: expected offset like {x y} or {right 50%}, got $offset" +} + +proc drawShapePosition {options geom} { + if {[dict exists $options position]} { + return [drawShapePoint [dict get $options position] $geom] + } + if {[dict exists $options center]} { + return [drawShapePoint [dict get $options center] $geom] + } + if {[dict exists $options x] || [dict exists $options y]} { + set x [drawShapeScalar [dict getdef $options x 50%] [dict get $geom width]] + set y [drawShapeScalar [dict getdef $options y 50%] [dict get $geom height]] return [list $x $y] } - local proc getRegularPolygon {center radius sides} { - lassign $center cx cy - set pts [list] - for {set i 0} {$i < $sides} {incr i} { - set angle [expr {$i * 2.0 * 3.14159 / $sides - 1.5708}] - lappend pts [list [expr {$cx + $radius * cos($angle)}] \ - [expr {$cy + $radius * sin($angle)}]] + set pos [drawShapePageCenter $geom] + if {[dict exists $options offset]} { + set pos [vec2 add $pos [drawShapeOffset [dict get $options offset] $geom]] + } + return $pos +} + +proc drawShapeRadians {options} { + dict getdef $options radians [dict getdef $options angle 0] +} + +proc drawShapeRadius {options default} { + if {[dict exists $options diameter]} { + return [expr {[dict get $options diameter] / 2.0}] + } + dict getdef $options radius $default +} + +proc drawShapeRegularPolygon {center radius sides radians} { + lassign $center cx cy + set points [list] + for {set i 0} {$i < $sides} {incr i} { + set theta [expr {$radians + $i * 2.0 * 3.141592653589793 / $sides - 1.5707963267948966}] + lappend points [list [expr {$cx + $radius * cos($theta)}] \ + [expr {$cy + $radius * sin($theta)}]] + } + return $points +} + +proc drawShapeRectPoints {center width height radians} { + set hw [expr {$width / 2.0}] + set hh [expr {$height / 2.0}] + set points [list \ + [list [expr {-$hw}] [expr {-$hh}]] \ + [list $hw [expr {-$hh}]] \ + [list $hw $hh] \ + [list [expr {-$hw}] $hh]] + lmap point $points { + vec2 add $center [vec2 rotate $point $radians] + } +} + +proc drawShapePathPoints {points geom options} { + set radians [drawShapeRadians $options] + set origin [dict getdef $options origin center] + set absolute [expr {$origin in {absolute local topleft top-left}}] + if {$absolute} { + set base {0 0} + } else { + set base [drawShapePosition $options $geom] + } + + set transformed [list] + foreach point $points { + if {$absolute} { + set point [drawShapePoint $point $geom] + } else { + set point [drawShapeOffset $point $geom] } - return $pts + lappend transformed [vec2 add $base [vec2 rotate $point $radians]] } + return $transformed +} + +proc process_offset {offset regionOrGeom} { + if {[catch { + dict create width [dict get $regionOrGeom width] height [dict get $regionOrGeom height] + } geom]} { + set geom [dict create width [region width $regionOrGeom] height [region height $regionOrGeom]] + } + drawShapeOffset $offset $geom +} - # --- Option Parsing --- - set radius [dict getdef $options radius 0.02] - set color [dict getdef $options color "white"] - set filled [dict getdef $options filled false] +When /someone/ wishes /p/ draws a /shape/ with /...options/ &\ + /p/ has resolved geometry /geom/ { + set shape [drawShapeCanonical $shape $options] + set center [drawShapePosition $options $geom] + set color [dict getdef $options color white] + set filled [drawShapeTruthy [dict getdef $options filled false]] set thickness [dict getdef $options thickness 0.002] - set layer [dict getdef $options layer 1] - - set offsetArg [dict getdef $options offset ""] - set offset [parseShapeOffset $offsetArg $geom] + set layer [dict getdef $options layer 1] + set radians [drawShapeRadians $options] - # --- Routing to Primitives --- if {$shape eq "circle"} { + set radius [drawShapeRadius $options 0.02] Wish to draw a circle onto $p with \ - center $offset radius $radius color $color \ - thickness $thickness filled $filled layer $layer + center $center radius $radius thickness $thickness \ + color $color filled $filled layer $layer return } - set pts [list] - switch $shape { - triangle { set pts [getRegularPolygon $offset $radius 3] } - square { set pts [getRegularPolygon $offset [expr {$radius * 1.2}] 4] } - pentagon { set pts [getRegularPolygon $offset $radius 5] } - hexagon { set pts [getRegularPolygon $offset $radius 6] } - septagon { set pts [getRegularPolygon $offset $radius 7] } - octagon { set pts [getRegularPolygon $offset $radius 8] } - nonagon { set pts [getRegularPolygon $offset $radius 9] } - rect { - set rw [dict getdef $options width 0.04] - set rh [dict getdef $options height 0.02] - lassign $offset cx cy - set pts [list [list [expr {$cx-$rw/2}] [expr {$cy-$rh/2}]] \ - [list [expr {$cx+$rw/2}] [expr {$cy-$rh/2}]] \ - [list [expr {$cx+$rw/2}] [expr {$cy+$rh/2}]] \ - [list [expr {$cx-$rw/2}] [expr {$cy+$rh/2}]]] + if {$shape eq "rect"} { + set radius [drawShapeRadius $options 0.02] + set size [dict getdef $options size [expr {$radius * 2.0}]] + set rectWidth [dict getdef $options width $size] + set rectHeight [dict getdef $options height [dict getdef $options width $size]] + set points [drawShapeRectPoints $center $rectWidth $rectHeight $radians] + } else { + if {[dict exists $options sides]} { + set sides [dict get $options sides] + } elseif {[dict exists $drawShapeSides $shape]} { + set sides [dict get $drawShapeSides $shape] + } else { + error "draw/shapes: unknown shape $shape" } + set radius [drawShapeRadius $options 0.02] + set points [drawShapeRegularPolygon $center $radius $sides $radians] } - if {[llength $pts] == 0} return - - if {$filled eq "true" || $filled == 1} { - Wish to draw a polygon onto $p with points $pts color $color layer $layer + if {$filled} { + Wish to draw a polygon onto $p with points $points color $color layer $layer } else { - lappend pts [lindex $pts 0] - Wish to draw a line onto $p with points $pts width $thickness color $color layer $layer + lappend points [lindex $points 0] + Wish to draw a line onto $p with \ + points $points width $thickness color $color layer $layer } } When /someone/ wishes /p/ draws a /shape/ { - Wish $p draws a $shape with offset "" color white filled true -} \ No newline at end of file + Wish $p draws a $shape with color white filled true +} + +When /someone/ wishes /p/ draws an /shape/ { + Wish $p draws a $shape +} + +When /someone/ wishes /p/ draws an /shape/ with /...options/ { + Wish $p draws a $shape with {*}$options +} + +When /someone/ wishes /p/ draws a rect with width /width/ height /height/ { + Wish $p draws a rect with width $width height $height +} + +When /someone/ wishes /p/ draws a /shape/ with radius /radius/ { + Wish $p draws a $shape with radius $radius +} + +When /someone/ wishes /p/ draws text /text/ with /...options/ &\ + /p/ has resolved geometry /geom/ { + set position [drawShapePosition $options $geom] + set color [dict getdef $options color white] + set scale [dict getdef $options scale 0.01] + set layer [dict getdef $options layer 0] + set anchor [dict getdef $options anchor center] + set font [dict getdef $options font "PTSans-Regular"] + set radians [drawShapeRadians $options] + + Wish to draw text onto $p with \ + position $position scale $scale text $text \ + color $color radians $radians anchor $anchor font $font layer $layer +} + +When /someone/ wishes /p/ draws text /text/ { + Wish $p draws text $text with color white +} + +When /someone/ wishes /p/ draws a polyline /points/ with /...options/ &\ + /p/ has resolved geometry /geom/ { + set points [drawShapePathPoints $points $geom $options] + set color [dict getdef $options color white] + set width [dict getdef $options width [dict getdef $options thickness 0.002]] + set layer [dict getdef $options layer 1] + set dashed [drawShapeTruthy [dict getdef $options dashed false]] + + if {$dashed} { + set dashlength [dict getdef $options dashlength 0.01] + set dashoffset [dict getdef $options dashoffset 0] + Wish to draw a dashed line onto $p with \ + points $points width $width color $color \ + dashlength $dashlength dashoffset $dashoffset layer $layer + } else { + Wish to draw a line onto $p with \ + points $points width $width color $color layer $layer + } +} + +When /someone/ wishes /p/ draws points /points/ with /...options/ &\ + /p/ has resolved geometry /geom/ { + set points [drawShapePathPoints $points $geom $options] + set radius [drawShapeRadius $options 0.003] + set thickness [dict getdef $options thickness 0.001] + set color [dict getdef $options color white] + set filled [drawShapeTruthy [dict getdef $options filled true]] + set layer [dict getdef $options layer 1] + + foreach point $points { + Wish to draw a circle onto $p with \ + center $point radius $radius thickness $thickness \ + color $color filled $filled layer $layer + } +} + +When /someone/ wishes /p/ draws a set of points /points/ with /...options/ { + Wish $p draws points $points with {*}$options +} + +Claim $this has demo { + Wish $this draws a circle with radius 0.018 color white filled true + + set baseX -0.055 + set baseY -0.035 + set dx 0.037 + set dy 0.03 + + Wish $this draws text "triangle" with color skyblue offset [list $baseX [expr {$baseY - 0.018}]] scale 0.004 + Wish $this draws text "square" with color green offset [list [expr {$baseX + $dx}] [expr {$baseY - 0.018}]] scale 0.004 + Wish $this draws text "pentagon" with color gold offset [list [expr {$baseX + $dx * 2}] [expr {$baseY - 0.018}]] scale 0.004 + Wish $this draws text "rect" with color cyan offset [list [expr {$baseX + $dx * 3}] [expr {$baseY - 0.018}]] scale 0.004 + + Wish $this draws a triangle with color skyblue radius 0.012 thickness 0.001 offset [list $baseX $baseY] + Wish $this draws a square with color green radius 0.012 thickness 0.0015 radians 0.785398 offset [list [expr {$baseX + $dx}] $baseY] + Wish $this draws a pentagon with color gold radius 0.012 filled true offset [list [expr {$baseX + $dx * 2}] $baseY] + Wish $this draws a rect with width 0.026 height 0.014 color cyan radians 0.4 offset [list [expr {$baseX + $dx * 3}] $baseY] + + Wish $this draws a polyline [list {-0.055 0.01} {-0.035 0.025} {-0.015 0.008} {0.005 0.025}] \ + with color magenta width 0.0015 + Wish $this draws a polyline [list {0.02 0.012} {0.04 0.025} {0.06 0.012}] \ + with color orange width 0.001 dashed true dashlength 0.006 + Wish $this draws a set of points [list {-0.052 0.045} {-0.038 0.047} {-0.024 0.043} {-0.010 0.047}] \ + with color palegoldenrod radius 0.0025 + + When $this has resolved geometry /geom/ & the clock time is /t/ { + set x [expr {sin($t) * 0.028}] + set y [expr {cos($t * 1.5) * 0.018}] + Wish $this draws a circle with \ + radius 0.004 color palegoldenrod filled true offset [list $x $y] layer 4 + } + + When $this has resolved geometry /geom/ & the clock time is /t/ { + set filled [expr {round($t * 2) % 2 == 0}] + Wish $this draws a square with \ + radius 0.014 color white filled $filled offset {0.05 0.045} + Wish $this draws text $filled with \ + offset {0.05 0.045} scale 0.005 color red layer 5 + } + + Wish $this is outlined white +} diff --git a/builtin-programs/shapes.folk b/builtin-programs/shapes.folk deleted file mode 100644 index c67c7e43..00000000 --- a/builtin-programs/shapes.folk +++ /dev/null @@ -1,357 +0,0 @@ -set shapes [dict create triangle 3 square 4 pentagon 5 hexagon 6 septagon 7 octagon 8 nonagon 9] - -proc process_offset {offset region} { - if {![info exists region]} { - return $offset - } - - set w [region width $region] - set h [region height $region] - - if {[llength $offset] == 2 && - ![string match *%* $offset] && - ![string is alpha -strict [lindex $offset 0]]} { - return $offset - } - - # Handle simple percentage string: "50%" - if {[string match *%* $offset] && [llength $offset] == 1} { - set pct [expr {[string map {% ""} $offset] / 100.0}] - return [list [expr {$w * $pct}] 0] # Default to horizontal offset - } - - # Handle directional strings: "right", "left", "up", "down" - if {$offset eq "right"} { - return [list [expr {$w * 0.5}] 0] - } elseif {$offset eq "left"} { - return [list [expr {-$w * 0.5}] 0] - } elseif {$offset eq "up"} { - return [list 0 [expr {-$h * 0.5}]] - } elseif {$offset eq "down"} { - return [list 0 [expr {$h * 0.5}]] - } - - # Handle directional percentage: "right 50%", "left 25%", etc. - if {[llength $offset] == 2 && [string is alpha -strict [lindex $offset 0]]} { - set direction [lindex $offset 0] - set amount [lindex $offset 1] - - if {[string match *%* $amount]} { - set pct [expr {[string map {% ""} $amount] / 100.0}] - - switch $direction { - "right" { return [list [expr {$w * $pct}] 0] } - "left" { return [list [expr {-$w * $pct}] 0] } - "up" { return [list 0 [expr {-$h * $pct}]] } - "down" { return [list 0 [expr {$h * $pct}]] } - default { return [list 0 0] } - } - } - } - - # Handle x y vector where one or both components have percentage notation - if {[llength $offset] == 2} { - lassign $offset ox oy - - if {[string match *%* $ox]} { - set pct [expr {[string map {% ""} $ox] / 100.0}] - set ox [expr {$w * $pct}] - } - - if {[string match *%* $oy]} { - set pct [expr {[string map {% ""} $oy] / 100.0}] - set oy [expr {$h * $pct}] - } - - return [list $ox $oy] - } - - # Default fallback - return $offset -} - -When /someone/ wishes to draw a shape with /...options/ { - set isRect 0 - if {[dict exists $options type] && [dict get $options type] eq "rect"} { - set isRect 1 - } - - set c [dict_getdef $options center {0 0}] - - set color [dict_getdef $options color white] - set filled [dict_getdef $options filled false] - set thickness [dict_getdef $options thickness 1] - set layer [dict_getdef $options layer 0] - set angle [dict_getdef $options angle 0] - - if {$isRect} { - set w [dict_getdef $options width 100] - set h [dict_getdef $options height 100] - - set hw [expr {$w / 2.0}] - set hh [expr {$h / 2.0}] - - set points [lmap v [list \ - [list [expr {-$hw}] [expr {-$hh}]] \ - [list [expr {$hw}] [expr {-$hh}]] \ - [list [expr {$hw}] [expr {$hh}]] \ - [list [expr {-$hw}] [expr {$hh}]] \ - [list [expr {-$hw}] [expr {-$hh}]] \ - ] { - vec2 add [vec2 rotate $v $angle] $c - }] - } else { - set numPoints [dict_getdef $options sides 4] - if {[dict exists $options shape] && [dict exists $shapes [dict get $options shape]]} { - set numPoints [dict get $shapes [dict get $options shape]] - } - set r [dict_getdef $options radius 50] - - set points {{0 0}} - set centerPoint {0 0} - set polyAngle [expr {2 * 3.14159 / $numPoints + 3.14159}] - set angleIncr [expr {2 * 3.14159 / $numPoints}] - - for {set i 0} {$i < $numPoints} {incr i} { - set p [vec2 add [lindex $points end] [vec2 scale [list [expr {cos($polyAngle)}] [expr {sin($polyAngle)}]] $r]] - lappend points $p - set centerPoint [vec2 add $centerPoint $p] - set polyAngle [expr {$polyAngle + $angleIncr}] - } - - set points [lmap v $points { - vec2 add [vec2 rotate [vec2 sub $v [vec2 scale $centerPoint [expr {1.0/$numPoints}]]] $angle] $c - }] - } - - if {$filled} { - Wish to draw a polygon with points $points color $color layer $layer - } else { - Wish to draw a stroke with points $points width $thickness color $color layer $layer - } -} - -When /someone/ wishes /p/ draws a /shape/ { - Wish $p draws a $shape with color white -} - -# Handle "a" vs "an" grammar variations -When /someone/ wishes /p/ draws an /shape/ { - Wish $p draws a $shape -} - -When /someone/ wishes /p/ draws text /text/ with /...options/ & /p/ has region /r/ { - # As shapes.folk but for text. - lassign [region centroid $r] cx cy - set pageAngle [region angle $r] - - # Use the page's angle unless explicitly overwritten - set defaults [dict create \ - color white \ - scale 1.0 \ - layer 0 \ - angle $pageAngle \ - anchor center \ - font "PTSans-Regular" - ] - - set options [dict merge $defaults $options] - - set color [dict get $options color] - set scale [dict get $options scale] - set layer [dict get $options layer] - set angle [dict get $options angle] - set anchor [dict get $options anchor] - set font [dict get $options font] - - set offset [dict_getdef $options offset {0 0}] - set offset [::process_offset $offset $r] - set center [vec2 add [list $cx $cy] [vec2 rotate $offset $pageAngle]] - - Wish to draw text with position $center scale $scale text $text\ - color $color radians $angle anchor $anchor font $font -} - -When /someone/ wishes /p/ draws text /text/ { - Wish $p draws text $text with color white -} - -When /someone/ wishes /p/ draws a /shape/ with /...options/ & /p/ has region /r/ { - lassign [region centroid $r] cx cy - set angle [region angle $r] - - set color [dict_getdef $options color white] - set filled [dict_getdef $options filled false] - set thickness [dict_getdef $options thickness 5] - set layer [dict_getdef $options layer 0] - - set offset [dict_getdef $options offset {0 0}] - set offset [process_offset $offset $r] - - set center [vec2 add [list $cx $cy] [vec2 rotate $offset $angle]] - - if {$shape eq "circle"} { - set radius [dict_getdef $options radius 50] - - Wish to draw a circle with center $center radius $radius thickness $thickness \ - color $color filled $filled layer $layer - - } elseif {$shape eq "rect"} { - set w [dict_getdef $options width [region width $r]] - set h [dict_getdef $options height [region height $r]] - - Wish to draw a shape with type rect center $center width $w height $h angle $angle \ - color $color filled $filled thickness $thickness layer $layer - - } elseif {[dict exists $shapes $shape]} { - set radius [dict_getdef $options radius 50] - - Wish to draw a shape with sides [dict get $shapes $shape] center $center radius $radius \ - angle $angle color $color filled $filled thickness $thickness layer $layer - - } else { - set radius [dict_getdef $options radius 50] - - Wish to draw a shape with sides 4 center $center radius $radius \ - angle $angle color $color filled $filled thickness $thickness layer $layer - } -} - -# Pass through options for "an" version -When /someone/ wishes /p/ draws an /shape/ with /...options/ { - Wish $p draws a $shape with {*}$options -} - -When /someone/ wishes /p/ draws a rect with width /w/ height /h/ { - Wish $p draws a rect with width $w height $h -} - -When /someone/ wishes /p/ draws a /shape/ with radius /rad/ { - Wish $p draws a $shape with radius $rad -} - -When /someone/ wishes /page/ draws a set of points /points/ with /...options/ & /page/ has region /r/ { - set radius [dict_getdef $options radius 5] - set color [dict_getdef $options color white] - set filled [dict_getdef $options filled true] - set thickness [dict_getdef $options thickness 2] - set layer [dict_getdef $options layer 0] - - lassign [region centroid $r] cx cy - set angle [region angle $r] - set center [list $cx $cy] - - if {[dict exists $options offset]} { - set offset [dict get $options offset] - set offset [process_offset $offset $r] - set center [vec2 add $center [vec2 rotate $offset $angle]] - } - - foreach point $points { - set pointPos [vec2 add $center [vec2 rotate $point $angle]] - - Wish to draw a circle with center $pointPos radius $radius thickness $thickness \ - color $color filled $filled layer $layer - } -} - -When /someone/ wishes /page/ draws a polyline /points/ with /...options/ & /page/ has region /r/ { - set color [dict_getdef $options color white] - set thickness [dict_getdef $options thickness 2] - set layer [dict_getdef $options layer 0] - set dashed [dict_getdef $options dashed false] - set dashlength [dict_getdef $options dashlength 20] - set dashoffset [dict_getdef $options dashoffset 0] - - lassign [region centroid $r] cx cy - set angle [region angle $r] - set center [list $cx $cy] - - if {[dict exists $options offset]} { - set offset [dict get $options offset] - set offset [process_offset $offset $r] - set center [vec2 add $center [vec2 rotate $offset $angle]] - } - - set transformedPoints {} - foreach point $points { - lappend transformedPoints [vec2 add $center [vec2 rotate $point $angle]] - } - - if {$dashed} { - Wish to draw a dashed stroke with points $transformedPoints color $color width $thickness \ - dashlength $dashlength dashoffset $dashoffset layer $layer - } else { - Wish to draw a stroke with points $transformedPoints color $color width $thickness layer $layer - } -} - -Claim $this has demo { - # Center circle - Wish $this draws a circle - - # Grid of shapes with varying thickness - set baseX -850 - set baseY -200 - set gridSpacing 130 - - # Row 0: Title - Wish $this draws text "triangle" with color skyblue offset [list $baseX [expr {$baseY - ($gridSpacing / 2.0)}]] scale 0.9 - Wish $this draws text "square" with color green offset [list [expr {$baseX + $gridSpacing}] [expr {$baseY - ($gridSpacing / 2.0)}]] scale 0.9 - Wish $this draws text "pentagon" with color gold offset [list [expr {$baseX + $gridSpacing*2}] [expr {$baseY - ($gridSpacing / 2.0)}]] scale 0.9 - Wish $this draws text "hexagon" with color orange offset [list [expr {$baseX + $gridSpacing*3}] [expr {$baseY - ($gridSpacing / 2.0)}]] scale 0.9 - - # Row 1: Regular polygons with different colors and thickness - Wish $this draws a triangle with color skyblue thickness 2 offset [list $baseX [expr {$baseY}]] - Wish $this draws a square with color green thickness 4 offset [list [expr {$baseX + $gridSpacing}] [expr {$baseY}]] - Wish $this draws a pentagon with color gold thickness 6 offset [list [expr {$baseX + $gridSpacing*2}] [expr {$baseY}]] - Wish $this draws a hexagon with color orange thickness 8 offset [list [expr {$baseX + $gridSpacing*3}] [expr {$baseY}]] - - # Row 2: Filled shapes - Wish $this draws a triangle with color skyblue filled true offset [list $baseX [expr {$baseY + $gridSpacing}]] - Wish $this draws a square with color green filled true offset [list [expr {$baseX + $gridSpacing}] [expr {$baseY + $gridSpacing}]] - Wish $this draws a pentagon with color gold filled true offset [list [expr {$baseX + $gridSpacing*2}] [expr {$baseY + $gridSpacing}]] - Wish $this draws a hexagon with color orange filled true offset [list [expr {$baseX + $gridSpacing*3}] [expr {$baseY + $gridSpacing}]] - - # Row 3: Directional offset examples (replacing shift) - Wish $this draws a triangle with radius 40 offset "right 50%" color skyblue - Wish $this draws a square with radius 40 offset "left 50%" color green - Wish $this draws a pentagon with radius 40 offset "up 50%" color gold - Wish $this draws a hexagon with radius 40 offset "down 50%" color orange - - # Row 4: Rectangles with different properties - Wish $this draws a rect with width 80 height 50 color cyan thickness 3 offset [list $baseX [expr {$baseY + $gridSpacing*3}]] - Wish $this draws a rect with width 80 height 50 color magenta filled true offset [list [expr {$baseX + $gridSpacing}] [expr {$baseY + $gridSpacing*3}]] - Wish $this draws a rect with width 80 height 50 offset "right 50%" - Wish $this draws a rect with width 80 height 50 offset "left 50%" - -# Animated elements - When $this has region /r/ & the clock time is /t/ { - lassign [region angle $r] angle - for {set i 0} {$i < 8} {incr i} { - set offsetVector [list [sin [+ [- $i $t] $angle]] [* 2 [cos [+ [- $i $t] $angle]]]] - set vector [::vec2::scale $offsetVector [+ [* $i $i] 15]] - Wish $this draws a circle with radius $i color palegoldenrod offset $vector - } - } - - When $this has region /r/ & the clock time is /t/ { - lassign [region centroid $r] x y - set fillVal [expr {round(sin($t) * 2)}] - set fill [expr {$fillVal % 2 == 0}] - set y [- $y 150] - Wish to draw a shape with sides 4 center [list [- $x 200] $y] radius 60 color white filled $fill - Wish to draw text with position [list [- $x 200] [+ $y 14]] scale 1.5 text "$fillVal" color red - } - - When $this has region /r/ & the clock time is /t/ { - lassign [region centroid $r] x y - set fillVal [expr {round($t * 2)}] - set fill [expr {$fillVal % 2 == 0}] - set y [- $y 150] - Wish to draw a shape with sides 4 center [list [+ $x 200] $y] radius 60 color white filled $fill - Wish to draw text with position [list [+ $x 200] [+ $y 14]] scale 1.5 text "$fill" color red - } - - Wish $this is outlined white -} From 97178a0b05e0d6fc16ef6b2eb3a53eb5809bfc6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 04:44:12 -0400 Subject: [PATCH 03/20] Add physical drawing surfaces --- builtin-programs/draw/spaces.folk | 361 ++++++++++++++++++++++++++++++ builtin-programs/mask-tags.folk | 32 ++- builtin-programs/points-at.folk | 74 ++++-- builtin-programs/title.folk | 76 ++----- test/draw-spaces.folk | 33 +++ 5 files changed, 485 insertions(+), 91 deletions(-) create mode 100644 builtin-programs/draw/spaces.folk create mode 100644 test/draw-spaces.folk diff --git a/builtin-programs/draw/spaces.folk b/builtin-programs/draw/spaces.folk new file mode 100644 index 00000000..9f2c2299 --- /dev/null +++ b/builtin-programs/draw/spaces.folk @@ -0,0 +1,361 @@ +proc drawSpacePhysicalLength {value} { + if {[llength $value] != 1} { + error "draw/spaces: expected a scalar physical length, got $value" + } + + set unit "" + set amount $value + foreach suffix {mm cm m} { + if {[string match *$suffix $value]} { + set unit $suffix + set amount [string range $value 0 end-[string length $suffix]] + break + } + } + + if {![string is double -strict $amount]} { + error "draw/spaces: invalid physical length $value" + } + + switch -- $unit { + "" - cm { return [expr {double($amount) * 0.01}] } + mm { return [expr {double($amount) * 0.001}] } + m { return [expr {double($amount)}] } + default { error "draw/spaces: invalid physical unit $unit" } + } +} + +proc drawSpacePhysicalPoint {point} { + if {[llength $point] != 2} { + error "draw/spaces: expected a 2D physical point, got $point" + } + list [drawSpacePhysicalLength [lindex $point 0]] \ + [drawSpacePhysicalLength [lindex $point 1]] +} + +proc drawSpacePhysicalPoints {points} { + lmap point $points { + drawSpacePhysicalPoint $point + } +} + +proc drawSpaceSetLength {options key} { + if {[dict exists $options $key]} { + dict set options $key [drawSpacePhysicalLength [dict get $options $key]] + } + return $options +} + +proc drawSpaceSetPoint {options key} { + if {[dict exists $options $key]} { + set point [dict get $options $key] + if {$point ne ""} { + dict set options $key [drawSpacePhysicalPoint $point] + } + } + return $options +} + +proc drawSpaceSetPoints {options key} { + if {[dict exists $options $key]} { + dict set options $key [drawSpacePhysicalPoints [dict get $options $key]] + } + return $options +} + +proc drawSpaceNormalizeOptions {shape options} { + switch -- $shape { + line { + set options [drawSpaceSetPoints $options points] + set options [drawSpaceSetLength $options width] + } + dashed-line { + set options [drawSpaceSetPoints $options points] + set options [drawSpaceSetLength $options width] + set options [drawSpaceSetLength $options dashlength] + set options [drawSpaceSetLength $options dashoffset] + } + circle { + set options [drawSpaceSetPoint $options center] + set options [drawSpaceSetLength $options x] + set options [drawSpaceSetLength $options y] + set options [drawSpaceSetLength $options radius] + set options [drawSpaceSetLength $options thickness] + } + arc { + set options [drawSpaceSetPoint $options center] + set options [drawSpaceSetLength $options x] + set options [drawSpaceSetLength $options y] + set options [drawSpaceSetLength $options radius] + set options [drawSpaceSetLength $options thickness] + } + curve { + foreach key {p0 p1 p2 p3} { + set options [drawSpaceSetPoint $options $key] + } + set options [drawSpaceSetLength $options thickness] + } + text { + set options [drawSpaceSetPoint $options position] + set options [drawSpaceSetLength $options x] + set options [drawSpaceSetLength $options y] + set options [drawSpaceSetLength $options scale] + } + image { + set options [drawSpaceSetPoint $options position] + set options [drawSpaceSetLength $options x] + set options [drawSpaceSetLength $options y] + set options [drawSpaceSetLength $options width] + set options [drawSpaceSetLength $options height] + } + triangle { + foreach key {p0 p1 p2} { + set options [drawSpaceSetPoint $options $key] + } + } + quad { + foreach key {p0 p1 p2 p3} { + set options [drawSpaceSetPoint $options $key] + } + } + polygon { + set options [drawSpaceSetPoints $options points] + } + default { + error "draw/spaces: unknown primitive $shape" + } + } + return $options +} + +proc drawSpaceSurfaceTarget {target surface} { + list $target surface $surface +} + +proc drawSpaceDistance {a b} { + set sum 0.0 + foreach av $a bv $b { + set d [expr {$av - $bv}] + set sum [expr {$sum + $d * $d}] + } + expr {sqrt($sum)} +} + +proc drawSpaceDisplayPixelToClip {displayWidth displayHeight point} { + lassign $point x y + list [expr {2.0 * $x / $displayWidth - 1.0}] \ + [expr {2.0 * $y / $displayHeight - 1.0}] +} + +proc drawSpaceHomography {pointPairs} { + package require linalg + namespace import ::math::linearalgebra::solvePGauss + + set A [list] + set b [list] + foreach pair $pointPairs { + lassign $pair x y u v + lappend A [list $x $y 1 0 0 0 [expr {-$u * $x}] [expr {-$u * $y}]] + lappend b $u + lappend A [list 0 0 0 $x $y 1 [expr {-$v * $x}] [expr {-$v * $y}]] + lappend b $v + } + + set h [solvePGauss $A $b] + list [list [lindex $h 0] [lindex $h 1] [lindex $h 2]] \ + [list [lindex $h 3] [lindex $h 4] [lindex $h 5]] \ + [list [lindex $h 6] [lindex $h 7] 1.0] +} + +proc drawSpaceApplyHomography {H point} { + lassign $point x y + lassign [lindex $H 0] h00 h01 h02 + lassign [lindex $H 1] h10 h11 h12 + lassign [lindex $H 2] h20 h21 h22 + set hx [expr {$h00 * $x + $h01 * $y + $h02}] + set hy [expr {$h10 * $x + $h11 * $y + $h12}] + set hw [expr {$h20 * $x + $h21 * $y + $h22}] + list [expr {$hx / $hw}] [expr {$hy / $hw}] +} + +proc drawSpaceMeterPoint {point} { + lmap value $point { + append value m + } +} + +When /target/ has canvas /id/ with /...wiOptions/ &\ + /target/ has canvas projection for surface /surface/ /surfaceToClip/ { + set surfaceTarget [drawSpaceSurfaceTarget $target $surface] + Claim $surfaceTarget has canvas $id with {*}$wiOptions + Claim $surfaceTarget has canvas projection $surfaceToClip +} + +When /target/ has resolved geometry /geom/ &\ + /target/ has canvas projection /surfaceToClip/ { + Claim $target has canvas projection for surface local $surfaceToClip +} + +When the quad library is /quadLib/ &\ + the pose library is /poseLib/ &\ + the quad changer is /quadChange/ &\ + display /disp/ has width /displayWidth/ height /displayHeight/ &\ + display /disp/ has intrinsics /displayIntrinsics/ &\ + /thing/ has quad /quad/ { + fn quadChange + + set surface [list surface of $thing] + set displayQuad [quadChange $quad "display $disp"] + lassign [$quadLib vertices $displayQuad] topLeft topRight bottomRight bottomLeft + + set topWidth [drawSpaceDistance $topLeft $topRight] + set bottomWidth [drawSpaceDistance $bottomLeft $bottomRight] + set rightHeight [drawSpaceDistance $topRight $bottomRight] + set leftHeight [drawSpaceDistance $topLeft $bottomLeft] + set width [expr {($topWidth + $bottomWidth) / 2.0}] + set height [expr {($rightHeight + $leftHeight) / 2.0}] + + set surfacePoints [list \ + [list 0 0] \ + [list $width 0] \ + [list $width $height] \ + [list 0 $height]] + + set displayVertices [list $topLeft $topRight $bottomRight $bottomLeft] + set clipPoints [lmap vertex $displayVertices { + drawSpaceDisplayPixelToClip $displayWidth $displayHeight \ + [$poseLib project $displayIntrinsics $displayWidth $displayHeight $vertex] + }] + + set pointPairs [list] + foreach surfacePoint $surfacePoints clipPoint $clipPoints { + lassign $surfacePoint x y + lassign $clipPoint u v + lappend pointPairs [list $x $y $u $v] + } + + Claim $thing has physical drawing surface $surface \ + with width $width height $height space [$quadLib space $displayQuad] + Claim $disp has canvas projection for surface $surface \ + [drawSpaceHomography $pointPairs] +} + +proc drawSpaceWishPrimitive {article shape target surface options} { + set normalized [drawSpaceNormalizeOptions $shape $options] + Wish to draw $article $shape onto [drawSpaceSurfaceTarget $target $surface] \ + with {*}$normalized +} + +When /someone/ wishes to draw a line onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishPrimitive a line $target $surface $options +} +When /someone/ wishes to draw a line onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishPrimitive a line $target $surface $options +} +When /someone/ wishes to draw a line onto /target/ in space /surface/ with /...options/ { + drawSpaceWishPrimitive a line $target $surface $options +} + +proc drawSpaceWishDashedLine {target surface options} { + set normalized [drawSpaceNormalizeOptions dashed-line $options] + Wish to draw a dashed line onto [drawSpaceSurfaceTarget $target $surface] \ + with {*}$normalized +} + +When /someone/ wishes to draw a dashed line onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishDashedLine $target $surface $options +} +When /someone/ wishes to draw a dashed line onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishDashedLine $target $surface $options +} +When /someone/ wishes to draw a dashed line onto /target/ in space /surface/ with /...options/ { + drawSpaceWishDashedLine $target $surface $options +} + +When /someone/ wishes to draw a circle onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishPrimitive a circle $target $surface $options +} +When /someone/ wishes to draw a circle onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishPrimitive a circle $target $surface $options +} +When /someone/ wishes to draw a circle onto /target/ in space /surface/ with /...options/ { + drawSpaceWishPrimitive a circle $target $surface $options +} + +When /someone/ wishes to draw an arc onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishPrimitive an arc $target $surface $options +} +When /someone/ wishes to draw an arc onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishPrimitive an arc $target $surface $options +} +When /someone/ wishes to draw an arc onto /target/ in space /surface/ with /...options/ { + drawSpaceWishPrimitive an arc $target $surface $options +} + +When /someone/ wishes to draw a curve onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishPrimitive a curve $target $surface $options +} +When /someone/ wishes to draw a curve onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishPrimitive a curve $target $surface $options +} +When /someone/ wishes to draw a curve onto /target/ in space /surface/ with /...options/ { + drawSpaceWishPrimitive a curve $target $surface $options +} + +When /someone/ wishes to draw an image onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishPrimitive an image $target $surface $options +} +When /someone/ wishes to draw an image onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishPrimitive an image $target $surface $options +} +When /someone/ wishes to draw an image onto /target/ in space /surface/ with /...options/ { + drawSpaceWishPrimitive an image $target $surface $options +} + +When /someone/ wishes to draw a triangle onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishPrimitive a triangle $target $surface $options +} +When /someone/ wishes to draw a triangle onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishPrimitive a triangle $target $surface $options +} +When /someone/ wishes to draw a triangle onto /target/ in space /surface/ with /...options/ { + drawSpaceWishPrimitive a triangle $target $surface $options +} + +When /someone/ wishes to draw a quad onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishPrimitive a quad $target $surface $options +} +When /someone/ wishes to draw a quad onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishPrimitive a quad $target $surface $options +} +When /someone/ wishes to draw a quad onto /target/ in space /surface/ with /...options/ { + drawSpaceWishPrimitive a quad $target $surface $options +} + +When /someone/ wishes to draw a polygon onto /target/ in surface /surface/ with /...options/ { + drawSpaceWishPrimitive a polygon $target $surface $options +} +When /someone/ wishes to draw a polygon onto /target/ in physical surface /surface/ with /...options/ { + drawSpaceWishPrimitive a polygon $target $surface $options +} +When /someone/ wishes to draw a polygon onto /target/ in space /surface/ with /...options/ { + drawSpaceWishPrimitive a polygon $target $surface $options +} + +When /someone/ wishes to draw text onto /target/ in surface /surface/ with /...options/ { + set normalized [drawSpaceNormalizeOptions text $options] + Wish to draw text onto [drawSpaceSurfaceTarget $target $surface] \ + with {*}$normalized +} + +When /someone/ wishes to draw text onto /target/ in physical surface /surface/ with /...options/ { + set normalized [drawSpaceNormalizeOptions text $options] + Wish to draw text onto [drawSpaceSurfaceTarget $target $surface] \ + with {*}$normalized +} + +When /someone/ wishes to draw text onto /target/ in space /surface/ with /...options/ { + set normalized [drawSpaceNormalizeOptions text $options] + Wish to draw text onto [drawSpaceSurfaceTarget $target $surface] \ + with {*}$normalized +} diff --git a/builtin-programs/mask-tags.folk b/builtin-programs/mask-tags.folk index f3cabc79..ff844ba5 100644 --- a/builtin-programs/mask-tags.folk +++ b/builtin-programs/mask-tags.folk @@ -1,20 +1,18 @@ -When the quad library is /quadLib/ &\ - the pose library is /poseLib/ &\ - the quad changer is /quadChange/ &\ - display /proj/ has width /projWidth/ height /projHeight/ &\ - display /proj/ has intrinsics /projectorIntrinsics/ { - - fn quadChange - +When the quad library is /quadLib/ { When -atomically tag /id/ has quad /q/ { - set scaledQuad [$quadLib scale $q 2.25] + Claim -keep 50ms [list tag-mask $id] has quad [$quadLib scale $q 2.25] + } +} - lassign [lmap v [$quadLib vertices [quadChange $scaledQuad "display $proj"]] { - $poseLib project $projectorIntrinsics $projWidth $projHeight $v - }] p0 p1 p2 p3 +When display /proj/ has width /projWidth/ height /projHeight/ &\ + /mask/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + /proj/ has canvas projection for surface /surface/ /surfaceToClip/ { + if {[lindex $mask 0] ne "tag-mask"} { return } - Wish to draw a quad onto $proj with \ - p0 $p0 p1 $p1 p2 $p2 p3 $p3 \ - color black layer 99 - } -} \ No newline at end of file + Wish to draw a quad onto $proj in surface $surface with \ + p0 [drawSpaceMeterPoint {0 0}] \ + p1 [drawSpaceMeterPoint [list $width 0]] \ + p2 [drawSpaceMeterPoint [list $width $height]] \ + p3 [drawSpaceMeterPoint [list 0 $height]] \ + color black layer 99 +} diff --git a/builtin-programs/points-at.folk b/builtin-programs/points-at.folk index 5de70d0d..4c18bc95 100644 --- a/builtin-programs/points-at.folk +++ b/builtin-programs/points-at.folk @@ -8,6 +8,21 @@ When when /rect/ points /direction/ at /someone/ /lambda/ with environment /e/ { Wish $rect points $direction with length 1 } +proc pointsAtMeterPoint {point} { + lmap value $point { + append value m + } +} + +proc pointsAtDistance {a b} { + set sum 0.0 + foreach av $a bv $b { + set d [expr {$av - $bv}] + set sum [expr {$sum + $d * $d}] + } + expr {sqrt($sum)} +} + When the quad library is /quadLib/ &\ the pose library is /poseLib/ &\ the quad changer is /quadChange/ &\ @@ -15,7 +30,7 @@ When the quad library is /quadLib/ &\ display /disp/ has intrinsics /displayIntrinsics/ &\ /someone/ wishes /rect/ points /direction/ with length /l/ { -When $rect has quad /quad/ { + When $rect has quad /quad/ { package require linalg namespace import \ @@ -28,6 +43,13 @@ When $rect has quad /quad/ { set quad [quadChange $quad "display $disp"] lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + set topWidth [pointsAtDistance $topLeft $topRight] + set bottomWidth [pointsAtDistance $bottomLeft $bottomRight] + set rightHeight [pointsAtDistance $topRight $bottomRight] + set leftHeight [pointsAtDistance $topLeft $bottomLeft] + set width [expr {($topWidth + $bottomWidth) / 2.0}] + set height [expr {($rightHeight + $leftHeight) / 2.0}] + if {$direction eq "up"} { set topCenter [scale 0.5 [add $topLeft $topRight]] set bottomCenter [scale 0.5 [add $bottomLeft $bottomRight]] @@ -36,6 +58,8 @@ When $rect has quad /quad/ { set from $topCenter set to [add $topCenter $up] set color blue + set fromSurface [list [expr {$width / 2.0}] 0] + set toSurface [list [expr {$width / 2.0}] [expr {-$height * $scale}]] } elseif {$direction eq "left"} { set leftCenter [scale 0.5 [add $topLeft $bottomLeft]] @@ -45,6 +69,8 @@ When $rect has quad /quad/ { set from $leftCenter set to [add $leftCenter $left] set color gold + set fromSurface [list 0 [expr {$height / 2.0}]] + set toSurface [list [expr {-$width * $scale}] [expr {$height / 2.0}]] } elseif {$direction eq "right"} { set leftCenter [scale 0.5 [add $topLeft $bottomLeft]] @@ -54,6 +80,8 @@ When $rect has quad /quad/ { set from $rightCenter set to [add $rightCenter $right] set color red + set fromSurface [list $width [expr {$height / 2.0}]] + set toSurface [list [expr {$width * (1.0 + $scale)}] [expr {$height / 2.0}]] } elseif {$direction eq "down"} { set topCenter [scale 0.5 [add $topLeft $topRight]] @@ -63,23 +91,23 @@ When $rect has quad /quad/ { set from $bottomCenter set to [add $bottomCenter $down] set color white + set fromSurface [list [expr {$width / 2.0}] $height] + set toSurface [list [expr {$width / 2.0}] [expr {$height * (1.0 + $scale)}]] } else { error "points-at: Invalid direction $direction" } - # HACK: This implementation is sort of inelegant in that it - # happens entirely in screen-space, because we need to draw right - # to the screen right now, and we don't have a surface-to-clip for - # that. + set surface [list surface of $rect] - # Downproject the whisker to screen-space. - set from [$poseLib project $displayIntrinsics \ - $displayWidth $displayHeight \ - $from] - set to [$poseLib project $displayIntrinsics \ - $displayWidth $displayHeight \ - $to] + # The hit test still happens in display pixels, but drawing now + # stays in the rect's extended physical surface. + set fromPixel [$poseLib project $displayIntrinsics \ + $displayWidth $displayHeight \ + $from] + set toPixel [$poseLib project $displayIntrinsics \ + $displayWidth $displayHeight \ + $to] When /target/ has quad /q2/ { if {$target eq $rect} { return } @@ -89,17 +117,19 @@ When $rect has quad /quad/ { $displayWidth $displayHeight $v }] - if {[::math::geometry::pointInsidePolygon $to $displayVertices]} { + if {[::math::geometry::pointInsidePolygon $toPixel $displayVertices]} { Claim -keep 50ms $rect points $direction at $target Claim -keep 50ms $rect points $direction with length $l at $target set color green Hold! -keep 16ms -key [list $rect pointer] { - Wish to draw a line onto $disp with \ - points [list $from $to] width 4 \ + Wish to draw a line onto $disp in surface $surface with \ + points [list [pointsAtMeterPoint $fromSurface] \ + [pointsAtMeterPoint $toSurface]] width 0.4 \ color $color - Wish to draw a circle onto $disp with \ - center $to radius 10 thickness 5 \ + Wish to draw a circle onto $disp in surface $surface with \ + center [pointsAtMeterPoint $toSurface] \ + radius 1 thickness 0.4 \ color $color filled true } } @@ -107,11 +137,13 @@ When $rect has quad /quad/ { When /nobody/ claims $rect points /anything/ at /anything/ { Hold! -keep 16ms -key [list $rect pointer] { - Wish to draw a line onto $disp with \ - points [list $from $to] width 4 \ + Wish to draw a line onto $disp in surface $surface with \ + points [list [pointsAtMeterPoint $fromSurface] \ + [pointsAtMeterPoint $toSurface]] width 0.4 \ color $color - Wish to draw a circle onto $disp with \ - center $to radius 10 thickness 5 \ + Wish to draw a circle onto $disp in surface $surface with \ + center [pointsAtMeterPoint $toSurface] \ + radius 1 thickness 0.4 \ color $color filled false } } diff --git a/builtin-programs/title.folk b/builtin-programs/title.folk index 223bf6a7..692ca4b4 100644 --- a/builtin-programs/title.folk +++ b/builtin-programs/title.folk @@ -9,14 +9,12 @@ When /thing/ has quad /quad/ { Claim -keep 50ms $thing has a quad } -When the quad library is /quadLib/ &\ - the pose library is /poseLib/ &\ - the quad changer is /quadChange/ &\ - display /disp/ has width /displayWidth/ height /displayHeight/ &\ - display /disp/ has intrinsics /displayIntrinsics/ &\ - /thing/ has a quad { +When display /disp/ has width /displayWidth/ height /displayHeight/ &\ + /thing/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + /disp/ has canvas projection for surface /surface/ /surfaceToClip/ { - fn quadChange + set paddingMeters 0.02 + set textScaleCm 2 foreach {label edge textAnchor} { titled top bottom @@ -28,53 +26,25 @@ When the quad library is /quadLib/ &\ set text [join [lmap result $results {dict get $result text}] "\n"] if {$text eq ""} { return } - When -atomically $thing has quad /q/ { - package require linalg - namespace import \ - ::math::linearalgebra::add \ - ::math::linearalgebra::sub \ - ::math::linearalgebra::scale \ - ::math::linearalgebra::unitLengthVector - - lassign [$quadLib vertices [quadChange $q "display $disp"]] \ - topLeft topRight bottomRight bottomLeft - - switch $edge { - top { - set physicalPos [scale 0.5 [add $topLeft $topRight]] - set physicalDir [sub $topLeft $bottomLeft] - } - bottom { - set physicalPos [scale 0.5 [add $bottomLeft $bottomRight]] - set physicalDir [sub $bottomLeft $topLeft] - } - right { - set physicalPos [scale 0.5 [add $topRight $bottomRight]] - set physicalDir [sub $topRight $topLeft] - } - left { - set physicalPos [scale 0.5 [add $topLeft $bottomLeft]] - set physicalDir [sub $topLeft $topRight] - } + switch $edge { + top { + set position [list [expr {$width / 2.0}] [expr {-$paddingMeters}]] + } + bottom { + set position [list [expr {$width / 2.0}] [expr {$height + $paddingMeters}]] + } + right { + set position [list [expr {$width + $paddingMeters}] [expr {$height / 2.0}]] + } + left { + set position [list [expr {-$paddingMeters}] [expr {$height / 2.0}]] } - - set paddingMeters 0.02 - set offset [scale $paddingMeters [unitLengthVector $physicalDir]] - set physicalPos [add $physicalPos $offset] - - set dispPosition [$poseLib project $displayIntrinsics $displayWidth $displayHeight $physicalPos] - - set dispTopLeft [$poseLib project $displayIntrinsics $displayWidth $displayHeight $topLeft] - set dispTopRight [$poseLib project $displayIntrinsics $displayWidth $displayHeight $topRight] - - set dispTop [vec2 sub $dispTopRight $dispTopLeft] - set dispRadians [expr {-atan2([lindex $dispTop 1], [lindex $dispTop 0])}] - - Wish to draw text onto $disp with \ - position $dispPosition \ - scale 36.0 radians $dispRadians anchor $textAnchor \ - text $text } + + Wish to draw text onto $disp in surface $surface with \ + position [drawSpaceMeterPoint $position] \ + scale $textScaleCm anchor $textAnchor \ + text $text } } -} \ No newline at end of file +} diff --git a/test/draw-spaces.folk b/test/draw-spaces.folk new file mode 100644 index 00000000..87e0ef77 --- /dev/null +++ b/test/draw-spaces.folk @@ -0,0 +1,33 @@ +source builtin-programs/draw/spaces.folk + +set l [drawSpacePhysicalLength 3] +assert {abs($l - 0.03) < 1e-9} + +set l [drawSpacePhysicalLength 4mm] +assert {abs($l - 0.004) < 1e-9} + +set l [drawSpacePhysicalLength 0.5m] +assert {abs($l - 0.5) < 1e-9} + +set point [drawSpacePhysicalPoint {3 -2cm}] +assert {abs([lindex $point 0] - 0.03) < 1e-9} +assert {abs([lindex $point 1] + 0.02) < 1e-9} + +set options [drawSpaceNormalizeOptions circle { + center {3 4cm} + radius 3 + thickness 4mm + color green +}] +set center [dict get $options center] +assert {abs([lindex $center 0] - 0.03) < 1e-9} +assert {abs([lindex $center 1] - 0.04) < 1e-9} +assert {abs([dict get $options radius] - 0.03) < 1e-9} +assert {abs([dict get $options thickness] - 0.004) < 1e-9} + +set H [drawSpaceHomography {{0 0 -1 -1} {1 0 1 -1} {1 1 1 1} {0 1 -1 1}}] +set projected [drawSpaceApplyHomography $H {0.5 0.5}] +assert {abs([lindex $projected 0]) < 1e-9} +assert {abs([lindex $projected 1]) < 1e-9} + +Exit! 0 From 2866c650996428db7dad94b6fdd9ac032ee40865 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 04:59:02 -0400 Subject: [PATCH 04/20] Port connections to draw spaces --- builtin-programs/connections.folk | 69 ------- builtin-programs/draw/connections.folk | 253 +++++++++++++++++++++++++ test/draw-connections.folk | 37 ++++ 3 files changed, 290 insertions(+), 69 deletions(-) delete mode 100644 builtin-programs/connections.folk create mode 100644 builtin-programs/draw/connections.folk create mode 100644 test/draw-connections.folk diff --git a/builtin-programs/connections.folk b/builtin-programs/connections.folk deleted file mode 100644 index 8efa359a..00000000 --- a/builtin-programs/connections.folk +++ /dev/null @@ -1,69 +0,0 @@ -# Connection wish fulfillment -# for wishes of the form: -# "Wish $tag is connected to $tag2" or "Wish $tag is dynamically connected to $tag2" - -When /anyone/ wishes /source/ is connected to /sink/ { - Wish $source is connected to $sink from centroid to centroid -} -When /anyone/ wishes /source/ is dynamically connected to /sink/ { - Wish $source is dynamically connected to $sink from centroid to centroid -} - -When /anyone/ wishes /source/ is connected to /sink/ /...options/ & \ - /source/ has region /source_region/ & \ - /sink/ has region /sink_region/ { - if {$source == $sink} {return} - - set p1 [dict_getdef $options from centroid] - set p2 [dict_getdef $options to centroid] - set source [region $p1 $source_region] - set sink [region $p2 $sink_region] - - set direction [vec2 sub $sink $source] - set color [dict_getdef $options color grey] - set layer [dict_getdef $options layer 0] - - set c [vec2 scale [vec2 add $source $sink] 0.5] - set angle [expr {atan2(-[lindex $direction 1], [lindex $direction 0]) - 3.14159/2}] - - Wish to draw a stroke with points [list $source $sink] width 2 color $color layer $layer - Wish to draw a shape with sides 3 center $c radius 30 radians $angle color $color filled true layer $layer -} - -set speed 75 -set spacing 50 -set maxsize 25 - -When /anyone/ wishes /source/ is dynamically connected to /sink/ /...options/ & \ - /source/ has region /source_region/ & \ - /sink/ has region /sink_region/ { - - if {$source == $sink} {return} - - set p1 [dict_getdef $options from centroid] - set p2 [dict_getdef $options to centroid] - set source [region $p1 $source_region] - set sink [region $p2 $sink_region] - - set direction [vec2 normalize [vec2 sub $sink $source]] - set distance [vec2 distance $sink $source] - set angle [expr {atan2(-[lindex $direction 1], [lindex $direction 0]) - 3.14159/2}] - - set color [dict_getdef $options color white] - set layer [dict_getdef $options layer 0] - - lassign [vec2 scale [vec2 add $source $sink] 0.5] cx cy - - Wish to draw a stroke with points [list $source $sink] width 1 color $color layer $layer - - When the clock time is /t/ { - set offset [expr {round($t*$speed) % $spacing}] - set count [expr {round($distance / $spacing)}] - - for {set p $offset} {$p < $distance} {incr p $spacing} { - set c [vec2 add $source [vec2 scale $direction $p]] - set s [expr {min($maxsize, 0.20*min($p, $distance - $p))}] - Wish to draw a shape with sides 3 center $c radius $s radians $angle color $color filled true layer $layer - } - } -} diff --git a/builtin-programs/draw/connections.folk b/builtin-programs/draw/connections.folk new file mode 100644 index 00000000..9b915633 --- /dev/null +++ b/builtin-programs/draw/connections.folk @@ -0,0 +1,253 @@ +# Connection wish fulfillment for wishes of the form: +# Wish $tag is connected to $tag2 +# Wish $tag is dynamically connected to $tag2 + +proc drawConnectionAdd {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av + $bv}] + } + return $out +} + +proc drawConnectionSub {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av - $bv}] + } + return $out +} + +proc drawConnectionScale {v s} { + lmap x $v { + expr {$x * $s} + } +} + +proc drawConnectionDistance {a b} { + set sum 0.0 + foreach av $a bv $b { + set d [expr {$av - $bv}] + set sum [expr {$sum + $d * $d}] + } + expr {sqrt($sum)} +} + +proc drawConnectionUnit {v} { + set zero [lmap _ $v { expr {0.0} }] + set n [drawConnectionDistance $v $zero] + if {$n == 0.0} { return "" } + drawConnectionScale $v [expr {1.0 / $n}] +} + +proc drawConnectionAverage {points} { + set first [lindex $points 0] + set sum [lmap _ $first { expr {0.0} }] + foreach point $points { + set sum [drawConnectionAdd $sum $point] + } + drawConnectionScale $sum [expr {1.0 / [llength $points]}] +} + +proc drawConnectionMidpoint {a b} { + drawConnectionScale [drawConnectionAdd $a $b] 0.5 +} + +proc drawConnectionQuadPoint {quadLib quad selector} { + lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + + switch -- [string tolower $selector] { + centroid - center { + return [drawConnectionAverage [list $topLeft $topRight $bottomRight $bottomLeft]] + } + top { + return [drawConnectionMidpoint $topLeft $topRight] + } + right { + return [drawConnectionMidpoint $topRight $bottomRight] + } + bottom { + return [drawConnectionMidpoint $bottomLeft $bottomRight] + } + left { + return [drawConnectionMidpoint $topLeft $bottomLeft] + } + topleft - top-left { + return $topLeft + } + topright - top-right { + return $topRight + } + bottomright - bottom-right { + return $bottomRight + } + bottomleft - bottom-left { + return $bottomLeft + } + default { + error "draw/connections: unknown quad point selector $selector" + } + } +} + +proc drawConnectionPerp {from to} { + set dx [expr {[lindex $to 0] - [lindex $from 0]}] + set dy [expr {[lindex $to 1] - [lindex $from 1]}] + set perp [list [expr {-$dy}] $dx] + if {[llength $from] > 2} { + lappend perp 0.0 + } + + set unit [drawConnectionUnit $perp] + if {$unit ne ""} { return $unit } + + set fallback {0.0 1.0} + if {[llength $from] > 2} { + lappend fallback 0.0 + } + return $fallback +} + +proc drawConnectionSurfaceQuad {quadLib space from to height} { + set halfHeight [expr {$height / 2.0}] + set perp [drawConnectionScale [drawConnectionPerp $from $to] $halfHeight] + + set topLeft [drawConnectionSub $from $perp] + set topRight [drawConnectionSub $to $perp] + set bottomRight [drawConnectionAdd $to $perp] + set bottomLeft [drawConnectionAdd $from $perp] + + $quadLib create $space [list $topLeft $topRight $bottomRight $bottomLeft] +} + +proc drawConnectionMeterPoint {point} { + lmap value $point { + append value m + } +} + +proc drawConnectionArrowPoints {x y radius} { + set baseX [expr {$x - $radius}] + set tipX [expr {$x + $radius}] + set spread [expr {$radius * 0.8}] + list [list $tipX $y] \ + [list $baseX [expr {$y - $spread}]] \ + [list $baseX [expr {$y + $spread}]] +} + +proc drawConnectionDrawArrow {disp surface x y radius color layer} { + if {$radius <= 0.0} { return } + lassign [drawConnectionArrowPoints $x $y $radius] p0 p1 p2 + Wish to draw a triangle onto $disp in surface $surface with \ + p0 [drawConnectionMeterPoint $p0] \ + p1 [drawConnectionMeterPoint $p1] \ + p2 [drawConnectionMeterPoint $p2] \ + color $color layer $layer +} + +When /anyone/ wishes /source/ is connected to /sink/ { + Wish $source is connected to $sink with from centroid to centroid +} + +When /anyone/ wishes /source/ is connected to /sink/ from /from/ to /to/ { + Wish $source is connected to $sink with from $from to $to +} + +When /anyone/ wishes /source/ is dynamically connected to /sink/ { + Wish $source is dynamically connected to $sink with from centroid to centroid +} + +When /anyone/ wishes /source/ is dynamically connected to /sink/ from /from/ to /to/ { + Wish $source is dynamically connected to $sink with from $from to $to +} + +When the quad library is /quadLib/ &\ + the quad changer is /quadChange/ &\ + display /disp/ has width /displayWidth/ height /displayHeight/ &\ + /source/ has quad /sourceQuad/ &\ + /sink/ has quad /sinkQuad/ &\ + /anyone/ wishes /source/ is connected to /sink/ with /...options/ { + if {$source eq $sink} { return } + + fn quadChange + set fromSelector [dict getdef $options from centroid] + set toSelector [dict getdef $options to centroid] + set sourceQuad [quadChange $sourceQuad "display $disp"] + set sinkQuad [quadChange $sinkQuad "display $disp"] + + set from [drawConnectionQuadPoint $quadLib $sourceQuad $fromSelector] + set to [drawConnectionQuadPoint $quadLib $sinkQuad $toSelector] + set distance [drawConnectionDistance $from $to] + if {$distance == 0.0} { return } + + set surfaceHeight [drawSpacePhysicalLength [dict getdef $options surfaceHeight 6]] + set connection [list connection $source $sink $fromSelector $toSelector $disp] + Claim -keep 50ms $connection has quad \ + [drawConnectionSurfaceQuad $quadLib "display $disp" $from $to $surfaceHeight] + + When $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + $disp has canvas projection for surface /surface/ /surfaceToClip/ { + set color [dict getdef $options color grey] + set layer [dict getdef $options layer 0] + set lineWidth [dict getdef $options width 0.2] + set arrowRadius [drawSpacePhysicalLength [dict getdef $options arrowRadius 2]] + set y [expr {$height / 2.0}] + set mid [expr {$width / 2.0}] + + Wish to draw a line onto $disp in surface $surface with \ + points [list [drawConnectionMeterPoint [list 0 $y]] \ + [drawConnectionMeterPoint [list $width $y]]] \ + width $lineWidth color $color layer $layer + drawConnectionDrawArrow $disp $surface $mid $y $arrowRadius $color $layer + } +} + +When the quad library is /quadLib/ &\ + the quad changer is /quadChange/ &\ + display /disp/ has width /displayWidth/ height /displayHeight/ &\ + /source/ has quad /sourceQuad/ &\ + /sink/ has quad /sinkQuad/ &\ + /anyone/ wishes /source/ is dynamically connected to /sink/ with /...options/ { + if {$source eq $sink} { return } + + fn quadChange + set fromSelector [dict getdef $options from centroid] + set toSelector [dict getdef $options to centroid] + set sourceQuad [quadChange $sourceQuad "display $disp"] + set sinkQuad [quadChange $sinkQuad "display $disp"] + + set from [drawConnectionQuadPoint $quadLib $sourceQuad $fromSelector] + set to [drawConnectionQuadPoint $quadLib $sinkQuad $toSelector] + set distance [drawConnectionDistance $from $to] + if {$distance == 0.0} { return } + + set surfaceHeight [drawSpacePhysicalLength [dict getdef $options surfaceHeight 6]] + set connection [list dynamic-connection $source $sink $fromSelector $toSelector $disp] + Claim -keep 50ms $connection has quad \ + [drawConnectionSurfaceQuad $quadLib "display $disp" $from $to $surfaceHeight] + + When $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + $disp has canvas projection for surface /surface/ /surfaceToClip/ { + set color [dict getdef $options color white] + set layer [dict getdef $options layer 0] + set lineWidth [dict getdef $options width 0.1] + set speed [drawSpacePhysicalLength [dict getdef $options speed 12]] + set spacing [drawSpacePhysicalLength [dict getdef $options spacing 5]] + set maxSize [drawSpacePhysicalLength [dict getdef $options maxsize 2.5]] + set y [expr {$height / 2.0}] + + Wish to draw a line onto $disp in surface $surface with \ + points [list [drawConnectionMeterPoint [list 0 $y]] \ + [drawConnectionMeterPoint [list $width $y]]] \ + width $lineWidth color $color layer $layer + + When the clock time is /t/ { + set offset [expr {fmod($t * $speed, $spacing)}] + for {set p $offset} {$p < $width} {set p [expr {$p + $spacing}]} { + set edgeDistance [expr {min($p, $width - $p)}] + set radius [expr {min($maxSize, 0.20 * $edgeDistance)}] + drawConnectionDrawArrow $disp $surface $p $y $radius $color $layer + } + } + } +} diff --git a/test/draw-connections.folk b/test/draw-connections.folk new file mode 100644 index 00000000..19b5f25f --- /dev/null +++ b/test/draw-connections.folk @@ -0,0 +1,37 @@ +source builtin-programs/draw/connections.folk + +proc fakeQuadLib {cmd args} { + switch -- $cmd { + vertices { + lindex [lindex $args 0] 1 + } + create { + list [lindex $args 0] [lindex $args 1] + } + default { + error "unknown fakeQuadLib command $cmd" + } + } +} + +set distance [drawConnectionDistance {0 0 0} {3 4 12}] +assert {abs($distance - 13.0) < 1e-9} + +set q [list "display test" {{0 0 0} {4 0 0} {4 2 0} {0 2 0}}] +assert {[drawConnectionQuadPoint fakeQuadLib $q centroid] eq {2.0 1.0 0.0}} +assert {[drawConnectionQuadPoint fakeQuadLib $q top] eq {2.0 0.0 0.0}} +assert {[drawConnectionQuadPoint fakeQuadLib $q bottom-right] eq {4 2 0}} + +set connectionQuad [drawConnectionSurfaceQuad fakeQuadLib "display test" {0 0 0} {4 0 0} 2] +lassign [fakeQuadLib vertices $connectionQuad] topLeft topRight bottomRight bottomLeft +assert {$topLeft eq {0.0 -1.0 0.0}} +assert {$topRight eq {4.0 -1.0 0.0}} +assert {$bottomRight eq {4.0 1.0 0.0}} +assert {$bottomLeft eq {0.0 1.0 0.0}} + +lassign [drawConnectionArrowPoints 5 1 2] tip rearLeft rearRight +assert {$tip eq {7 1}} +assert {$rearLeft eq {3 -0.6}} +assert {$rearRight eq {3 2.6}} + +Exit! 0 From 796fd5978df00fe6e1f8ad565fe7b1836c892ca5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 10:11:57 -0400 Subject: [PATCH 05/20] Move arc primitive into draw --- builtin-programs/{display => draw}/arc.folk | 30 +++++++-------------- test/draw-arc.folk | 22 +++++++++++++++ 2 files changed, 32 insertions(+), 20 deletions(-) rename builtin-programs/{display => draw}/arc.folk (80%) create mode 100644 test/draw-arc.folk diff --git a/builtin-programs/display/arc.folk b/builtin-programs/draw/arc.folk similarity index 80% rename from builtin-programs/display/arc.folk rename to builtin-programs/draw/arc.folk index 81b59144..f41737e4 100644 --- a/builtin-programs/display/arc.folk +++ b/builtin-programs/draw/arc.folk @@ -2,7 +2,7 @@ # When the clock time is /t/ { # # Draw a spinning cyan arc # set spinAngle [expr {fmod($t, 6.28318)}] -# +# # Wish to draw an arc onto $this with \ # center {0.05 0.05} \ # radius 0.04 \ @@ -15,11 +15,8 @@ Wish the GPU compiles pipeline "arc" { {vec2 viewport mat3 surfaceToClip vec2 center float radius float thickness float start float arclen vec4 color} { - - // Pad the bounding box with the thickness so the arc doesn't get clipped float r = radius + thickness; - - // 6 vertices to make 2 triangles (a standard quad) + vec2 vertices[6] = vec2[6]( center - r, vec2(center.x + r, center.y - r), @@ -28,12 +25,10 @@ Wish the GPU compiles pipeline "arc" { center + r, vec2(center.x - r, center.y + r) ); - + vec3 v = surfaceToClip * vec3(vertices[gl_VertexIndex], 1.0); - return vec4(v.xy/v.z, 0.0, 1.0); - + return vec4(v.xy / v.z, 0.0, 1.0); } { - // Map screen coordinates back to tabletop surface coordinates vec2 clipXy = (gl_FragCoord.xy / viewport) * 2.0 - 1.0; vec3 surfaceXy = inverse(surfaceToClip) * vec3(clipXy, 1.0); surfaceXy /= surfaceXy.z; @@ -42,24 +37,19 @@ Wish the GPU compiles pipeline "arc" { float c_start = clamp(start, 0.0, M_TWO_PI); float c_arclen = clamp(arclen, 0.0, M_TWO_PI); - // Use the transformed surfaceXy instead of gl_FragCoord float dist = length(surfaceXy.xy - center) - radius; - - // Y is inverted because Folk/screen-space Y goes down, but atan math expects Y up float angle = atan(-(surfaceXy.y - center.y), surfaceXy.x - center.x); - // Shift angle from [-pi, pi) to [0, 2*pi] angle = (angle < 0.0) ? (angle + M_TWO_PI) : angle; float end = c_start + c_arclen; - // Determine if the pixel falls within the stroked ring AND within the angle slice if (dist < thickness && dist > 0.0) { - if ((end < M_TWO_PI && angle > c_start && angle < end) || + if ((end < M_TWO_PI && angle > c_start && angle < end) || (end >= M_TWO_PI && (angle > c_start || angle < end - M_TWO_PI))) { return color; } } - + return vec4(0.0); } } @@ -71,20 +61,20 @@ When the color map is /colorMap/ &\ set center [dict getdef $options center ""] if {$center eq ""} { set center [list [dict get $options x] [dict get $options y]] } - + set radius [dict get $options radius] set thickness [dict get $options thickness] set start [dict get $options start] set arclen [dict get $options arclen] - + set color [dict get $options color] set color [dict getdef $colorMap $color $color] set layer [dict getdef $options layer 0] set wiResolution [list [dict get $wiOptions width] [dict get $wiOptions height]] - + Wish the GPU draws pipeline "arc" onto canvas $id with arguments \ [list $wiResolution $surfaceToClip \ $center $radius $thickness $start $arclen $color] \ layer $layer -} \ No newline at end of file +} diff --git a/test/draw-arc.folk b/test/draw-arc.folk new file mode 100644 index 00000000..2587530c --- /dev/null +++ b/test/draw-arc.folk @@ -0,0 +1,22 @@ +source builtin-programs/draw/arc.folk +source builtin-programs/draw/spaces.folk + +set options [drawSpaceNormalizeOptions arc { + center {3 4cm} + radius 3 + thickness 4mm + start 0.5 + arclen 1.5 + color cyan +}] + +set center [dict get $options center] +assert {abs([lindex $center 0] - 0.03) < 1e-9} +assert {abs([lindex $center 1] - 0.04) < 1e-9} +assert {abs([dict get $options radius] - 0.03) < 1e-9} +assert {abs([dict get $options thickness] - 0.004) < 1e-9} +assert {[dict get $options start] == 0.5} +assert {[dict get $options arclen] == 1.5} +assert {[dict get $options color] eq "cyan"} + +Exit! 0 From d7159092dc8bc7ec90c4f8c7d1deafe053327f4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 10:25:04 -0400 Subject: [PATCH 06/20] Share drawing space geometry helpers --- builtin-programs/draw/connections.folk | 154 +++---------------------- builtin-programs/draw/spaces.folk | 135 ++++++++++++++++++++-- builtin-programs/points-at.folk | 81 ++++--------- test/draw-connections.folk | 30 +---- test/draw-spaces.folk | 35 ++++++ 5 files changed, 201 insertions(+), 234 deletions(-) diff --git a/builtin-programs/draw/connections.folk b/builtin-programs/draw/connections.folk index 9b915633..5879bbb7 100644 --- a/builtin-programs/draw/connections.folk +++ b/builtin-programs/draw/connections.folk @@ -2,130 +2,6 @@ # Wish $tag is connected to $tag2 # Wish $tag is dynamically connected to $tag2 -proc drawConnectionAdd {a b} { - set out [list] - foreach av $a bv $b { - lappend out [expr {$av + $bv}] - } - return $out -} - -proc drawConnectionSub {a b} { - set out [list] - foreach av $a bv $b { - lappend out [expr {$av - $bv}] - } - return $out -} - -proc drawConnectionScale {v s} { - lmap x $v { - expr {$x * $s} - } -} - -proc drawConnectionDistance {a b} { - set sum 0.0 - foreach av $a bv $b { - set d [expr {$av - $bv}] - set sum [expr {$sum + $d * $d}] - } - expr {sqrt($sum)} -} - -proc drawConnectionUnit {v} { - set zero [lmap _ $v { expr {0.0} }] - set n [drawConnectionDistance $v $zero] - if {$n == 0.0} { return "" } - drawConnectionScale $v [expr {1.0 / $n}] -} - -proc drawConnectionAverage {points} { - set first [lindex $points 0] - set sum [lmap _ $first { expr {0.0} }] - foreach point $points { - set sum [drawConnectionAdd $sum $point] - } - drawConnectionScale $sum [expr {1.0 / [llength $points]}] -} - -proc drawConnectionMidpoint {a b} { - drawConnectionScale [drawConnectionAdd $a $b] 0.5 -} - -proc drawConnectionQuadPoint {quadLib quad selector} { - lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft - - switch -- [string tolower $selector] { - centroid - center { - return [drawConnectionAverage [list $topLeft $topRight $bottomRight $bottomLeft]] - } - top { - return [drawConnectionMidpoint $topLeft $topRight] - } - right { - return [drawConnectionMidpoint $topRight $bottomRight] - } - bottom { - return [drawConnectionMidpoint $bottomLeft $bottomRight] - } - left { - return [drawConnectionMidpoint $topLeft $bottomLeft] - } - topleft - top-left { - return $topLeft - } - topright - top-right { - return $topRight - } - bottomright - bottom-right { - return $bottomRight - } - bottomleft - bottom-left { - return $bottomLeft - } - default { - error "draw/connections: unknown quad point selector $selector" - } - } -} - -proc drawConnectionPerp {from to} { - set dx [expr {[lindex $to 0] - [lindex $from 0]}] - set dy [expr {[lindex $to 1] - [lindex $from 1]}] - set perp [list [expr {-$dy}] $dx] - if {[llength $from] > 2} { - lappend perp 0.0 - } - - set unit [drawConnectionUnit $perp] - if {$unit ne ""} { return $unit } - - set fallback {0.0 1.0} - if {[llength $from] > 2} { - lappend fallback 0.0 - } - return $fallback -} - -proc drawConnectionSurfaceQuad {quadLib space from to height} { - set halfHeight [expr {$height / 2.0}] - set perp [drawConnectionScale [drawConnectionPerp $from $to] $halfHeight] - - set topLeft [drawConnectionSub $from $perp] - set topRight [drawConnectionSub $to $perp] - set bottomRight [drawConnectionAdd $to $perp] - set bottomLeft [drawConnectionAdd $from $perp] - - $quadLib create $space [list $topLeft $topRight $bottomRight $bottomLeft] -} - -proc drawConnectionMeterPoint {point} { - lmap value $point { - append value m - } -} - proc drawConnectionArrowPoints {x y radius} { set baseX [expr {$x - $radius}] set tipX [expr {$x + $radius}] @@ -139,9 +15,9 @@ proc drawConnectionDrawArrow {disp surface x y radius color layer} { if {$radius <= 0.0} { return } lassign [drawConnectionArrowPoints $x $y $radius] p0 p1 p2 Wish to draw a triangle onto $disp in surface $surface with \ - p0 [drawConnectionMeterPoint $p0] \ - p1 [drawConnectionMeterPoint $p1] \ - p2 [drawConnectionMeterPoint $p2] \ + p0 [drawSpaceMeterPoint $p0] \ + p1 [drawSpaceMeterPoint $p1] \ + p2 [drawSpaceMeterPoint $p2] \ color $color layer $layer } @@ -175,15 +51,15 @@ When the quad library is /quadLib/ &\ set sourceQuad [quadChange $sourceQuad "display $disp"] set sinkQuad [quadChange $sinkQuad "display $disp"] - set from [drawConnectionQuadPoint $quadLib $sourceQuad $fromSelector] - set to [drawConnectionQuadPoint $quadLib $sinkQuad $toSelector] - set distance [drawConnectionDistance $from $to] + set from [drawSpaceQuadPoint $quadLib $sourceQuad $fromSelector] + set to [drawSpaceQuadPoint $quadLib $sinkQuad $toSelector] + set distance [drawSpaceVectorDistance $from $to] if {$distance == 0.0} { return } set surfaceHeight [drawSpacePhysicalLength [dict getdef $options surfaceHeight 6]] set connection [list connection $source $sink $fromSelector $toSelector $disp] Claim -keep 50ms $connection has quad \ - [drawConnectionSurfaceQuad $quadLib "display $disp" $from $to $surfaceHeight] + [drawSpaceSurfaceQuadBetween $quadLib "display $disp" $from $to $surfaceHeight] When $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ $disp has canvas projection for surface /surface/ /surfaceToClip/ { @@ -195,8 +71,8 @@ When the quad library is /quadLib/ &\ set mid [expr {$width / 2.0}] Wish to draw a line onto $disp in surface $surface with \ - points [list [drawConnectionMeterPoint [list 0 $y]] \ - [drawConnectionMeterPoint [list $width $y]]] \ + points [list [drawSpaceMeterPoint [list 0 $y]] \ + [drawSpaceMeterPoint [list $width $y]]] \ width $lineWidth color $color layer $layer drawConnectionDrawArrow $disp $surface $mid $y $arrowRadius $color $layer } @@ -216,15 +92,15 @@ When the quad library is /quadLib/ &\ set sourceQuad [quadChange $sourceQuad "display $disp"] set sinkQuad [quadChange $sinkQuad "display $disp"] - set from [drawConnectionQuadPoint $quadLib $sourceQuad $fromSelector] - set to [drawConnectionQuadPoint $quadLib $sinkQuad $toSelector] - set distance [drawConnectionDistance $from $to] + set from [drawSpaceQuadPoint $quadLib $sourceQuad $fromSelector] + set to [drawSpaceQuadPoint $quadLib $sinkQuad $toSelector] + set distance [drawSpaceVectorDistance $from $to] if {$distance == 0.0} { return } set surfaceHeight [drawSpacePhysicalLength [dict getdef $options surfaceHeight 6]] set connection [list dynamic-connection $source $sink $fromSelector $toSelector $disp] Claim -keep 50ms $connection has quad \ - [drawConnectionSurfaceQuad $quadLib "display $disp" $from $to $surfaceHeight] + [drawSpaceSurfaceQuadBetween $quadLib "display $disp" $from $to $surfaceHeight] When $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ $disp has canvas projection for surface /surface/ /surfaceToClip/ { @@ -237,8 +113,8 @@ When the quad library is /quadLib/ &\ set y [expr {$height / 2.0}] Wish to draw a line onto $disp in surface $surface with \ - points [list [drawConnectionMeterPoint [list 0 $y]] \ - [drawConnectionMeterPoint [list $width $y]]] \ + points [list [drawSpaceMeterPoint [list 0 $y]] \ + [drawSpaceMeterPoint [list $width $y]]] \ width $lineWidth color $color layer $layer When the clock time is /t/ { diff --git a/builtin-programs/draw/spaces.folk b/builtin-programs/draw/spaces.folk index 9f2c2299..05b0cc66 100644 --- a/builtin-programs/draw/spaces.folk +++ b/builtin-programs/draw/spaces.folk @@ -132,7 +132,29 @@ proc drawSpaceSurfaceTarget {target surface} { list $target surface $surface } -proc drawSpaceDistance {a b} { +proc drawSpaceVectorAdd {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av + $bv}] + } + return $out +} + +proc drawSpaceVectorSub {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av - $bv}] + } + return $out +} + +proc drawSpaceVectorScale {v s} { + lmap x $v { + expr {$x * $s} + } +} + +proc drawSpaceVectorDistance {a b} { set sum 0.0 foreach av $a bv $b { set d [expr {$av - $bv}] @@ -141,6 +163,109 @@ proc drawSpaceDistance {a b} { expr {sqrt($sum)} } +proc drawSpaceDistance {a b} { + drawSpaceVectorDistance $a $b +} + +proc drawSpaceVectorUnit {v} { + set zero [lmap _ $v { expr {0.0} }] + set n [drawSpaceVectorDistance $v $zero] + if {$n == 0.0} { return "" } + drawSpaceVectorScale $v [expr {1.0 / $n}] +} + +proc drawSpaceVectorAverage {points} { + set first [lindex $points 0] + set sum [lmap _ $first { expr {0.0} }] + foreach point $points { + set sum [drawSpaceVectorAdd $sum $point] + } + drawSpaceVectorScale $sum [expr {1.0 / [llength $points]}] +} + +proc drawSpaceVectorMidpoint {a b} { + drawSpaceVectorScale [drawSpaceVectorAdd $a $b] 0.5 +} + +proc drawSpaceQuadPoint {quadLib quad selector} { + lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + + switch -- [string tolower $selector] { + centroid - center { + return [drawSpaceVectorAverage [list $topLeft $topRight $bottomRight $bottomLeft]] + } + top { + return [drawSpaceVectorMidpoint $topLeft $topRight] + } + right { + return [drawSpaceVectorMidpoint $topRight $bottomRight] + } + bottom { + return [drawSpaceVectorMidpoint $bottomLeft $bottomRight] + } + left { + return [drawSpaceVectorMidpoint $topLeft $bottomLeft] + } + topleft - top-left { + return $topLeft + } + topright - top-right { + return $topRight + } + bottomright - bottom-right { + return $bottomRight + } + bottomleft - bottom-left { + return $bottomLeft + } + default { + error "draw/spaces: unknown quad point selector $selector" + } + } +} + +proc drawSpaceQuadSize {quadLib quad} { + lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + + set topWidth [drawSpaceVectorDistance $topLeft $topRight] + set bottomWidth [drawSpaceVectorDistance $bottomLeft $bottomRight] + set rightHeight [drawSpaceVectorDistance $topRight $bottomRight] + set leftHeight [drawSpaceVectorDistance $topLeft $bottomLeft] + + list [expr {($topWidth + $bottomWidth) / 2.0}] \ + [expr {($rightHeight + $leftHeight) / 2.0}] +} + +proc drawSpacePerpendicularBetween {from to} { + set dx [expr {[lindex $to 0] - [lindex $from 0]}] + set dy [expr {[lindex $to 1] - [lindex $from 1]}] + set perp [list [expr {-$dy}] $dx] + if {[llength $from] > 2} { + lappend perp 0.0 + } + + set unit [drawSpaceVectorUnit $perp] + if {$unit ne ""} { return $unit } + + set fallback {0.0 1.0} + if {[llength $from] > 2} { + lappend fallback 0.0 + } + return $fallback +} + +proc drawSpaceSurfaceQuadBetween {quadLib space from to height} { + set halfHeight [expr {$height / 2.0}] + set perp [drawSpaceVectorScale [drawSpacePerpendicularBetween $from $to] $halfHeight] + + set topLeft [drawSpaceVectorSub $from $perp] + set topRight [drawSpaceVectorSub $to $perp] + set bottomRight [drawSpaceVectorAdd $to $perp] + set bottomLeft [drawSpaceVectorAdd $from $perp] + + $quadLib create $space [list $topLeft $topRight $bottomRight $bottomLeft] +} + proc drawSpaceDisplayPixelToClip {displayWidth displayHeight point} { lassign $point x y list [expr {2.0 * $x / $displayWidth - 1.0}] \ @@ -207,13 +332,7 @@ When the quad library is /quadLib/ &\ set surface [list surface of $thing] set displayQuad [quadChange $quad "display $disp"] lassign [$quadLib vertices $displayQuad] topLeft topRight bottomRight bottomLeft - - set topWidth [drawSpaceDistance $topLeft $topRight] - set bottomWidth [drawSpaceDistance $bottomLeft $bottomRight] - set rightHeight [drawSpaceDistance $topRight $bottomRight] - set leftHeight [drawSpaceDistance $topLeft $bottomLeft] - set width [expr {($topWidth + $bottomWidth) / 2.0}] - set height [expr {($rightHeight + $leftHeight) / 2.0}] + lassign [drawSpaceQuadSize $quadLib $displayQuad] width height set surfacePoints [list \ [list 0 0] \ diff --git a/builtin-programs/points-at.folk b/builtin-programs/points-at.folk index 4c18bc95..6d404b30 100644 --- a/builtin-programs/points-at.folk +++ b/builtin-programs/points-at.folk @@ -8,21 +8,6 @@ When when /rect/ points /direction/ at /someone/ /lambda/ with environment /e/ { Wish $rect points $direction with length 1 } -proc pointsAtMeterPoint {point} { - lmap value $point { - append value m - } -} - -proc pointsAtDistance {a b} { - set sum 0.0 - foreach av $a bv $b { - set d [expr {$av - $bv}] - set sum [expr {$sum + $d * $d}] - } - expr {sqrt($sum)} -} - When the quad library is /quadLib/ &\ the pose library is /poseLib/ &\ the quad changer is /quadChange/ &\ @@ -32,64 +17,44 @@ When the quad library is /quadLib/ &\ When $rect has quad /quad/ { - package require linalg - namespace import \ - ::math::linearalgebra::add \ - ::math::linearalgebra::sub \ - ::math::linearalgebra::scale - fn quadChange set scale $l set quad [quadChange $quad "display $disp"] - lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft - set topWidth [pointsAtDistance $topLeft $topRight] - set bottomWidth [pointsAtDistance $bottomLeft $bottomRight] - set rightHeight [pointsAtDistance $topRight $bottomRight] - set leftHeight [pointsAtDistance $topLeft $bottomLeft] - set width [expr {($topWidth + $bottomWidth) / 2.0}] - set height [expr {($rightHeight + $leftHeight) / 2.0}] + lassign [drawSpaceQuadSize $quadLib $quad] width height if {$direction eq "up"} { - set topCenter [scale 0.5 [add $topLeft $topRight]] - set bottomCenter [scale 0.5 [add $bottomLeft $bottomRight]] - set up [scale $scale [sub $topCenter $bottomCenter]] - - set from $topCenter - set to [add $topCenter $up] + set from [drawSpaceQuadPoint $quadLib $quad top] + set opposite [drawSpaceQuadPoint $quadLib $quad bottom] + set to [drawSpaceVectorAdd $from \ + [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] set color blue set fromSurface [list [expr {$width / 2.0}] 0] set toSurface [list [expr {$width / 2.0}] [expr {-$height * $scale}]] } elseif {$direction eq "left"} { - set leftCenter [scale 0.5 [add $topLeft $bottomLeft]] - set rightCenter [scale 0.5 [add $topRight $bottomRight]] - set left [scale $scale [sub $leftCenter $rightCenter]] - - set from $leftCenter - set to [add $leftCenter $left] + set from [drawSpaceQuadPoint $quadLib $quad left] + set opposite [drawSpaceQuadPoint $quadLib $quad right] + set to [drawSpaceVectorAdd $from \ + [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] set color gold set fromSurface [list 0 [expr {$height / 2.0}]] set toSurface [list [expr {-$width * $scale}] [expr {$height / 2.0}]] } elseif {$direction eq "right"} { - set leftCenter [scale 0.5 [add $topLeft $bottomLeft]] - set rightCenter [scale 0.5 [add $topRight $bottomRight]] - set right [scale $scale [sub $rightCenter $leftCenter]] - - set from $rightCenter - set to [add $rightCenter $right] + set from [drawSpaceQuadPoint $quadLib $quad right] + set opposite [drawSpaceQuadPoint $quadLib $quad left] + set to [drawSpaceVectorAdd $from \ + [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] set color red set fromSurface [list $width [expr {$height / 2.0}]] set toSurface [list [expr {$width * (1.0 + $scale)}] [expr {$height / 2.0}]] } elseif {$direction eq "down"} { - set topCenter [scale 0.5 [add $topLeft $topRight]] - set bottomCenter [scale 0.5 [add $bottomLeft $bottomRight]] - set down [scale $scale [sub $bottomCenter $topCenter]] - - set from $bottomCenter - set to [add $bottomCenter $down] + set from [drawSpaceQuadPoint $quadLib $quad bottom] + set opposite [drawSpaceQuadPoint $quadLib $quad top] + set to [drawSpaceVectorAdd $from \ + [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] set color white set fromSurface [list [expr {$width / 2.0}] $height] set toSurface [list [expr {$width / 2.0}] [expr {$height * (1.0 + $scale)}]] @@ -124,11 +89,11 @@ When the quad library is /quadLib/ &\ set color green Hold! -keep 16ms -key [list $rect pointer] { Wish to draw a line onto $disp in surface $surface with \ - points [list [pointsAtMeterPoint $fromSurface] \ - [pointsAtMeterPoint $toSurface]] width 0.4 \ + points [list [drawSpaceMeterPoint $fromSurface] \ + [drawSpaceMeterPoint $toSurface]] width 0.4 \ color $color Wish to draw a circle onto $disp in surface $surface with \ - center [pointsAtMeterPoint $toSurface] \ + center [drawSpaceMeterPoint $toSurface] \ radius 1 thickness 0.4 \ color $color filled true } @@ -138,11 +103,11 @@ When the quad library is /quadLib/ &\ When /nobody/ claims $rect points /anything/ at /anything/ { Hold! -keep 16ms -key [list $rect pointer] { Wish to draw a line onto $disp in surface $surface with \ - points [list [pointsAtMeterPoint $fromSurface] \ - [pointsAtMeterPoint $toSurface]] width 0.4 \ + points [list [drawSpaceMeterPoint $fromSurface] \ + [drawSpaceMeterPoint $toSurface]] width 0.4 \ color $color Wish to draw a circle onto $disp in surface $surface with \ - center [pointsAtMeterPoint $toSurface] \ + center [drawSpaceMeterPoint $toSurface] \ radius 1 thickness 0.4 \ color $color filled false } diff --git a/test/draw-connections.folk b/test/draw-connections.folk index 19b5f25f..91b6506a 100644 --- a/test/draw-connections.folk +++ b/test/draw-connections.folk @@ -1,34 +1,6 @@ +source builtin-programs/draw/spaces.folk source builtin-programs/draw/connections.folk -proc fakeQuadLib {cmd args} { - switch -- $cmd { - vertices { - lindex [lindex $args 0] 1 - } - create { - list [lindex $args 0] [lindex $args 1] - } - default { - error "unknown fakeQuadLib command $cmd" - } - } -} - -set distance [drawConnectionDistance {0 0 0} {3 4 12}] -assert {abs($distance - 13.0) < 1e-9} - -set q [list "display test" {{0 0 0} {4 0 0} {4 2 0} {0 2 0}}] -assert {[drawConnectionQuadPoint fakeQuadLib $q centroid] eq {2.0 1.0 0.0}} -assert {[drawConnectionQuadPoint fakeQuadLib $q top] eq {2.0 0.0 0.0}} -assert {[drawConnectionQuadPoint fakeQuadLib $q bottom-right] eq {4 2 0}} - -set connectionQuad [drawConnectionSurfaceQuad fakeQuadLib "display test" {0 0 0} {4 0 0} 2] -lassign [fakeQuadLib vertices $connectionQuad] topLeft topRight bottomRight bottomLeft -assert {$topLeft eq {0.0 -1.0 0.0}} -assert {$topRight eq {4.0 -1.0 0.0}} -assert {$bottomRight eq {4.0 1.0 0.0}} -assert {$bottomLeft eq {0.0 1.0 0.0}} - lassign [drawConnectionArrowPoints 5 1 2] tip rearLeft rearRight assert {$tip eq {7 1}} assert {$rearLeft eq {3 -0.6}} diff --git a/test/draw-spaces.folk b/test/draw-spaces.folk index 87e0ef77..26ff6988 100644 --- a/test/draw-spaces.folk +++ b/test/draw-spaces.folk @@ -1,5 +1,19 @@ source builtin-programs/draw/spaces.folk +proc fakeQuadLib {cmd args} { + switch -- $cmd { + vertices { + lindex [lindex $args 0] 1 + } + create { + list [lindex $args 0] [lindex $args 1] + } + default { + error "unknown fakeQuadLib command $cmd" + } + } +} + set l [drawSpacePhysicalLength 3] assert {abs($l - 0.03) < 1e-9} @@ -30,4 +44,25 @@ set projected [drawSpaceApplyHomography $H {0.5 0.5}] assert {abs([lindex $projected 0]) < 1e-9} assert {abs([lindex $projected 1]) < 1e-9} +set distance [drawSpaceVectorDistance {0 0 0} {3 4 12}] +assert {abs($distance - 13.0) < 1e-9} + +set q [list "display test" {{0 0 0} {4 0 0} {4 2 0} {0 2 0}}] +assert {[drawSpaceQuadPoint fakeQuadLib $q centroid] eq {2.0 1.0 0.0}} +assert {[drawSpaceQuadPoint fakeQuadLib $q top] eq {2.0 0.0 0.0}} +assert {[drawSpaceQuadPoint fakeQuadLib $q bottom-right] eq {4 2 0}} + +lassign [drawSpaceQuadSize fakeQuadLib $q] width height +assert {abs($width - 4.0) < 1e-9} +assert {abs($height - 2.0) < 1e-9} + +set surfaceQuad [drawSpaceSurfaceQuadBetween fakeQuadLib "display test" {0 0 0} {4 0 0} 2] +lassign [fakeQuadLib vertices $surfaceQuad] topLeft topRight bottomRight bottomLeft +assert {$topLeft eq {0.0 -1.0 0.0}} +assert {$topRight eq {4.0 -1.0 0.0}} +assert {$bottomRight eq {4.0 1.0 0.0}} +assert {$bottomLeft eq {0.0 1.0 0.0}} + +assert {[drawSpaceMeterPoint {0 1.5}] eq {0m 1.5m}} + Exit! 0 From e70f2754f0173565c475ed45ccad167c2e279b00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 10:45:51 -0400 Subject: [PATCH 07/20] Port decorations and hit targets to surfaces --- builtin-programs/decorations/label.folk | 64 ++++--- builtin-programs/decorations/outline.folk | 43 +++-- builtin-programs/draw/hit-targets.folk | 216 ++++++++++++++++++++++ builtin-programs/draw/spaces.folk | 29 +++ builtin-programs/group.folk | 42 ----- builtin-programs/intersect.folk | 25 --- builtin-programs/regions.folk | 8 - builtin-programs/shapes/region.folk | 92 --------- test/decorations.folk | 18 ++ test/draw-hit-targets.folk | 29 +++ test/draw-spaces.folk | 12 ++ 11 files changed, 373 insertions(+), 205 deletions(-) create mode 100644 builtin-programs/draw/hit-targets.folk delete mode 100644 builtin-programs/group.folk delete mode 100644 builtin-programs/intersect.folk delete mode 100644 builtin-programs/regions.folk delete mode 100644 builtin-programs/shapes/region.folk create mode 100644 test/decorations.folk create mode 100644 test/draw-hit-targets.folk diff --git a/builtin-programs/decorations/label.folk b/builtin-programs/decorations/label.folk index 03341d6d..088b8b71 100644 --- a/builtin-programs/decorations/label.folk +++ b/builtin-programs/decorations/label.folk @@ -1,35 +1,47 @@ -When /thing/ has resolved geometry /geom/ { - When the collected results for [list /someone/ wishes $thing is labelled /text/ with /...options/] are /results/ { - set text [join [lmap result $results {dict get $result text}] "\n"] - if {$text eq ""} { return } +proc drawLabelMeterLength {value} { + append value m +} - # Split text into lines and find the longest line. - set lines [split $text "\n"] - set maxLength 0 - foreach line $lines { - set lineLength [string length $line] - if {$lineLength > $maxLength} { - set maxLength $lineLength - } +proc drawLabelMaxLineLength {text} { + set maxLength 0 + foreach line [split $text "\n"] { + set lineLength [string length $line] + if {$lineLength > $maxLength} { + set maxLength $lineLength } + } + return $maxLength +} + +proc drawLabelDefaultScale {text} { + set maxLength [drawLabelMaxLineLength $text] + if {$maxLength == 0} { return 0.02 } + ::math::min 0.02 [/ 0.45 $maxLength] +} - # Set default scale based on longest line length. - # Scale inversely with length to keep text readable. - set defaultScale [::math::min 0.02 [/ 0.45 $maxLength]] +proc drawLabelDefaultOptions {text width height} { + set scale [drawLabelDefaultScale $text] + dict create \ + position [drawSpaceMeterPoint [list [expr {$width / 2.0}] [expr {$height / 2.0}]]] \ + scale [drawLabelMeterLength $scale] \ + anchor center \ + font "PTSans-Regular" +} - set x [/ $geom(width) 2.0] - try { - set y $($geom(top) + $geom(tagSize) + $geom(bottom)/2.0) - } on error e { - set y [/ $geom(height) 2.0] +When display /disp/ has width /displayWidth/ height /displayHeight/ &\ + /thing/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + /disp/ has canvas projection for surface /surface/ /surfaceToClip/ { + When the collected results for [list /someone/ wishes $thing is labelled /text/ with /...options/] are /results/ { + set text [join [lmap result $results {dict get $result text}] "\n"] + if {$text eq ""} { return } + + set options [drawLabelDefaultOptions $text $width $height] + foreach result $results { + set options [dict merge $options [dict get $result options]] } - set options [dict create x $x y $y scale $defaultScale] - # FIXME: support per-label options; right now, this just - # applies an arbitrary label's options to all of them - # together. - set options [dict merge $options [dict get $result options]] dict set options text $text - Wish to draw text onto $thing with {*}$options + + Wish to draw text onto $disp in surface $surface with {*}$options } } diff --git a/builtin-programs/decorations/outline.folk b/builtin-programs/decorations/outline.folk index c663af26..5b0a6337 100644 --- a/builtin-programs/decorations/outline.folk +++ b/builtin-programs/decorations/outline.folk @@ -1,13 +1,32 @@ -When /someone/ wishes /thing/ is outlined /color/ &\ - /thing/ has resolved geometry /geom/ { - dict with geom { - set points [list [list 0 0] \ - [list $width 0] \ - [list $width $height] \ - [list 0 $height] \ - [list 0 0]] - } - - Wish to draw a line onto $thing with \ - points $points width 0.01 color $color +proc drawOutlineMeterLength {value} { + append value m +} + +proc drawOutlineMeterPoints {width height} { + list [drawSpaceMeterPoint {0 0}] \ + [drawSpaceMeterPoint [list $width 0]] \ + [drawSpaceMeterPoint [list $width $height]] \ + [drawSpaceMeterPoint [list 0 $height]] \ + [drawSpaceMeterPoint {0 0}] +} + +When /someone/ wishes /thing/ is outlined /color/ { + Wish $thing is outlined with color $color +} + +When /someone/ wishes /thing/ is outlined /color/ with /...options/ { + Wish $thing is outlined with color $color {*}$options +} + +When display /disp/ has width /displayWidth/ height /displayHeight/ &\ + /thing/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + /disp/ has canvas projection for surface /surface/ /surfaceToClip/ &\ + /someone/ wishes /thing/ is outlined with /...options/ { + set color [dict getdef $options color white] + set outlineWidth [dict getdef $options width [dict getdef $options thickness [drawOutlineMeterLength 0.01]]] + set layer [dict getdef $options layer 2] + + Wish to draw a line onto $disp in surface $surface with \ + points [drawOutlineMeterPoints $width $height] \ + width $outlineWidth color $color layer $layer } diff --git a/builtin-programs/draw/hit-targets.folk b/builtin-programs/draw/hit-targets.folk new file mode 100644 index 00000000..a2793d4e --- /dev/null +++ b/builtin-programs/draw/hit-targets.folk @@ -0,0 +1,216 @@ +# Child surfaces and hit targets are small physical sub-quads of a parent +# quad. They are real quad-backed objects, so the normal drawing-space and +# pointing APIs can see them. + +proc drawHitTargetTruthy {value} { + expr {$value in {1 true yes on}} +} + +proc drawHitTargetName {options} { + if {[dict exists $options name]} { + return [dict get $options name] + } + if {[dict exists $options index]} { + return [dict get $options index] + } + return 0 +} + +proc drawHitTargetId {parent options} { + if {[dict exists $options id]} { + return [dict get $options id] + } + list hit target of $parent [drawHitTargetName $options] +} + +proc drawHitTargetScalar {value extent} { + if {[string match *% $value]} { + set pct [string range $value 0 end-1] + if {![string is double -strict $pct]} { + error "draw/hit-targets: invalid percentage $value" + } + return [expr {double($pct) / 100.0 * $extent}] + } + drawSpacePhysicalLength $value +} + +proc drawHitTargetPoint {point parentWidth parentHeight} { + if {[llength $point] != 2} { + error "draw/hit-targets: expected a 2D point, got $point" + } + list [drawHitTargetScalar [lindex $point 0] $parentWidth] \ + [drawHitTargetScalar [lindex $point 1] $parentHeight] +} + +proc drawHitTargetOffset {offset parentWidth parentHeight} { + if {$offset eq "" || $offset eq "center"} { + return {0 0} + } + + if {[llength $offset] == 1} { + set token [lindex $offset 0] + switch -- $token { + right { return [list [expr {$parentWidth / 2.0}] 0] } + left { return [list [expr {-$parentWidth / 2.0}] 0] } + down { return [list 0 [expr {$parentHeight / 2.0}]] } + up { return [list 0 [expr {-$parentHeight / 2.0}]] } + default { + return [list [drawHitTargetScalar $token $parentWidth] 0] + } + } + } + + if {[llength $offset] == 2} { + set dir [lindex $offset 0] + set amount [lindex $offset 1] + switch -- $dir { + right { return [list [drawHitTargetScalar $amount $parentWidth] 0] } + left { + set value [drawHitTargetScalar $amount $parentWidth] + return [list [expr {-$value}] 0] + } + down { return [list 0 [drawHitTargetScalar $amount $parentHeight]] } + up { + set value [drawHitTargetScalar $amount $parentHeight] + return [list 0 [expr {-$value}]] + } + default { + return [drawHitTargetPoint $offset $parentWidth $parentHeight] + } + } + } + + error "draw/hit-targets: expected offset like {x y} or {right 50%}, got $offset" +} + +proc drawHitTargetRect {options parentWidth parentHeight} { + set defaultSize [dict getdef $options size 5] + set rectWidth [drawHitTargetScalar [dict getdef $options width $defaultSize] $parentWidth] + set rectHeight [drawHitTargetScalar \ + [dict getdef $options height [dict getdef $options width $defaultSize]] \ + $parentHeight] + + if {[dict exists $options topleft]} { + set topLeft [drawHitTargetPoint [dict get $options topleft] \ + $parentWidth $parentHeight] + lassign $topLeft x y + return [list $x $y $rectWidth $rectHeight] + } + + if {[dict exists $options top-left]} { + set topLeft [drawHitTargetPoint [dict get $options top-left] \ + $parentWidth $parentHeight] + lassign $topLeft x y + return [list $x $y $rectWidth $rectHeight] + } + + if {[dict exists $options center]} { + set center [drawHitTargetPoint [dict get $options center] \ + $parentWidth $parentHeight] + } elseif {[dict exists $options position]} { + set center [drawHitTargetPoint [dict get $options position] \ + $parentWidth $parentHeight] + } elseif {[dict exists $options x] || [dict exists $options y]} { + set center [list \ + [drawHitTargetScalar [dict getdef $options x 50%] $parentWidth] \ + [drawHitTargetScalar [dict getdef $options y 50%] $parentHeight]] + } else { + set center [list [expr {$parentWidth / 2.0}] [expr {$parentHeight / 2.0}]] + } + + if {[dict exists $options offset]} { + set center [drawSpaceVectorAdd $center \ + [drawHitTargetOffset [dict get $options offset] $parentWidth $parentHeight]] + } + + lassign $center cx cy + list [expr {$cx - $rectWidth / 2.0}] \ + [expr {$cy - $rectHeight / 2.0}] \ + $rectWidth $rectHeight +} + +proc drawHitTargetDrawHighlight {disp surface width height options} { + set points [list \ + [drawSpaceMeterPoint {0 0}] \ + [drawSpaceMeterPoint [list $width 0]] \ + [drawSpaceMeterPoint [list $width $height]] \ + [drawSpaceMeterPoint [list 0 $height]] \ + [drawSpaceMeterPoint {0 0}]] + + set color [dict getdef $options highlightColor [dict getdef $options color yellow]] + set thickness [dict getdef $options thickness [dict getdef $options outlineWidth 0.2]] + set layer [dict getdef $options layer 4] + + if {[drawHitTargetTruthy [dict getdef $options dashed false]]} { + set dashlength [dict getdef $options dashlength 1] + set dashoffset [dict getdef $options dashoffset 0] + Wish to draw a dashed line onto $disp in surface $surface with \ + points $points width $thickness color $color \ + dashlength $dashlength dashoffset $dashoffset layer $layer + } else { + Wish to draw a line onto $disp in surface $surface with \ + points $points width $thickness color $color layer $layer + } +} + +proc drawHitTargetClaim {quadLib parent parentQuad options} { + set target [drawHitTargetId $parent $options] + set name [drawHitTargetName $options] + set index [dict getdef $options index $name] + + lassign [drawSpaceQuadSize $quadLib $parentQuad] parentWidth parentHeight + lassign [drawHitTargetRect $options $parentWidth $parentHeight] x y width height + + set targetQuad [drawSpaceQuadSurfaceRect $quadLib $parentQuad $x $y $width $height] + Claim -keep 50ms $target has quad $targetQuad + Claim -keep 50ms $parent has child surface $target \ + with name $name index $index x $x y $y width $width height $height + Claim -keep 50ms $parent has hit target $target \ + with name $name index $index x $x y $y width $width height $height + Claim -keep 50ms $target is child surface of $parent \ + with name $name index $index x $x y $y width $width height $height + Claim -keep 50ms $target is hit target of $parent \ + with name $name index $index x $x y $y width $width height $height + + if {[drawHitTargetTruthy [dict getdef $options highlight false]]} { + When $target has physical drawing surface /surface/ with width /surfaceWidth/ height /surfaceHeight/ space /space/ &\ + /disp/ has canvas projection for surface /surface/ /surfaceToClip/ { + drawHitTargetDrawHighlight $disp $surface $surfaceWidth $surfaceHeight $options + } + } +} + +When the quad library is /quadLib/ &\ + /parent/ has quad /parentQuad/ &\ + /someone/ wishes /parent/ adds child surface with /...options/ { + drawHitTargetClaim $quadLib $parent $parentQuad $options +} + +When the quad library is /quadLib/ &\ + /parent/ has quad /parentQuad/ &\ + /someone/ wishes /parent/ adds hit target with /...options/ { + drawHitTargetClaim $quadLib $parent $parentQuad $options +} + +When /someone/ wishes /parent/ adds child surface /name/ with /...options/ { + Wish $parent adds child surface with name $name {*}$options +} + +When /someone/ wishes /parent/ adds hit target /name/ with /...options/ { + Wish $parent adds hit target with name $name {*}$options +} + +Claim $this has demo { + Wish $this adds hit target with name left-button width 4 height 3 offset {left 25%} \ + highlight true color yellow dashed true + Wish $this adds hit target with name right-button width 4 height 3 offset {right 25%} \ + highlight true color cyan + + When $this has hit target /target/ with name /name/ /...options/ &\ + /target/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + /disp/ has canvas projection for surface /surface/ /surfaceToClip/ { + Wish to draw text onto $disp in surface $surface with \ + position [drawSpaceMeterPoint [list [expr {$width / 2.0}] [expr {$height / 2.0}]]] \ + scale 0.35 anchor center color white text $name + } +} diff --git a/builtin-programs/draw/spaces.folk b/builtin-programs/draw/spaces.folk index 05b0cc66..53d6f524 100644 --- a/builtin-programs/draw/spaces.folk +++ b/builtin-programs/draw/spaces.folk @@ -187,6 +187,11 @@ proc drawSpaceVectorMidpoint {a b} { drawSpaceVectorScale [drawSpaceVectorAdd $a $b] 0.5 } +proc drawSpaceVectorMix {a b t} { + drawSpaceVectorAdd $a \ + [drawSpaceVectorScale [drawSpaceVectorSub $b $a] $t] +} + proc drawSpaceQuadPoint {quadLib quad selector} { lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft @@ -236,6 +241,30 @@ proc drawSpaceQuadSize {quadLib quad} { [expr {($rightHeight + $leftHeight) / 2.0}] } +proc drawSpaceQuadSurfacePoint {quadLib quad point} { + lassign [drawSpaceQuadSize $quadLib $quad] width height + if {$width == 0.0 || $height == 0.0} { + error "draw/spaces: cannot map point through zero-sized quad" + } + + lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + lassign $point x y + set tx [expr {$x / $width}] + set ty [expr {$y / $height}] + + set top [drawSpaceVectorMix $topLeft $topRight $tx] + set bottom [drawSpaceVectorMix $bottomLeft $bottomRight $tx] + drawSpaceVectorMix $top $bottom $ty +} + +proc drawSpaceQuadSurfaceRect {quadLib quad x y width height} { + $quadLib create [$quadLib space $quad] [list \ + [drawSpaceQuadSurfacePoint $quadLib $quad [list $x $y]] \ + [drawSpaceQuadSurfacePoint $quadLib $quad [list [expr {$x + $width}] $y]] \ + [drawSpaceQuadSurfacePoint $quadLib $quad [list [expr {$x + $width}] [expr {$y + $height}]]] \ + [drawSpaceQuadSurfacePoint $quadLib $quad [list $x [expr {$y + $height}]]]] +} + proc drawSpacePerpendicularBetween {from to} { set dx [expr {[lindex $to 0] - [lindex $from 0]}] set dy [expr {[lindex $to 1] - [lindex $from 1]}] diff --git a/builtin-programs/group.folk b/builtin-programs/group.folk deleted file mode 100644 index 72394306..00000000 --- a/builtin-programs/group.folk +++ /dev/null @@ -1,42 +0,0 @@ -return -# FIXME: re-enable group.folk - -# load all programs -When group /group/ contains /...programs/ { - Wish tag $group is stabilized - foreach program $programs { - # HACK: claim 'tag' specifically so it doesn't run twice - Claim tag $program has a program - } -} - -# figure out the text to display below -When group /group/ contains /...programs/ &\ - the collected results for [list /someone/ wishes /program/ is titled /title/] are /results/ { - set programTitles [dict create] - - foreach result $results { - set programId [dict get $result program] - - if {[lsearch $programs $programId] != -1} { - dict set programTitles $programId [dict get $result title] - } - } - - set programTitleText "" - - foreach program $programs { - set title [dict_getdef $programTitles $program "(no title)"] - append programTitleText \n $program ": " $title - } - - Claim group $group has program titles $programTitleText -} - -# display said text -When group /group/ has program titles /programTitles/ &\ - /group/ has region /r/ { - set radians [region angle $r] - set pos [region topleft [region move $r down 40px right 15px]] - Wish to draw text with position $pos text $programTitles scale 0.7 radians $radians anchor topleft -} diff --git a/builtin-programs/intersect.folk b/builtin-programs/intersect.folk deleted file mode 100644 index 18704da5..00000000 --- a/builtin-programs/intersect.folk +++ /dev/null @@ -1,25 +0,0 @@ - -When /someone/ wishes /p/ has neighbors & /p/ has region /r/ & /p2/ has region /r2/ { - if {$p eq $p2} { return } - lassign [regionToBbox $r] bMinX bMinY bMaxX bMaxY - lassign [regionToBbox $r2] b2MinX b2MinY b2MaxX b2MaxY - - set hasIntersections [rectanglesOverlap [list $bMinX $bMinY] \ - [list $bMaxX $bMaxY]\ - [list $b2MinX $b2MinY]\ - [list $b2MaxX $b2MaxY]\ - false ] - #Display::stroke [list [list $bMinX $bMinY] {500 500}] 3 blue - #Display::stroke [list [list $bMaxX $bMaxY] {500 500}] 3 red - - if {$hasIntersections} { - Claim $p has neighbor $p2 - #Display::stroke [list [list $b2MinX $b2MinY] {500 500}] 3 red - #Display::stroke [list [list $b2MaxX $b2MaxY] {500 500}] 3 white - #Display::stroke [list [list $b2MinX $b2MinY] [list $b2MaxX $b2MaxY]] 10 blue - } -} - -When when /p/ has neighbor /n/ /lambda/ with environment /e/ { - Wish $p has neighbors -} diff --git a/builtin-programs/regions.folk b/builtin-programs/regions.folk deleted file mode 100644 index 945fcd20..00000000 --- a/builtin-programs/regions.folk +++ /dev/null @@ -1,8 +0,0 @@ -When when the distance between /p1/ and /p2/ is /distanceVar/ /body/ with environment /e/ & /p1/ has region /r1/ & /p2/ has region /r2/ { - Claim the distance between $p1 and $p2 is [region distance $r1 $r2] -} - -When /someone/ wishes region /r/ is /verbed/ /x/ { - Claim $r has region $r - Wish $r is $verbed $x -} diff --git a/builtin-programs/shapes/region.folk b/builtin-programs/shapes/region.folk deleted file mode 100644 index 492a268d..00000000 --- a/builtin-programs/shapes/region.folk +++ /dev/null @@ -1,92 +0,0 @@ -# Creates an id "${p}:${index}" and assigns region. -# Extra regions can be used to create sensitive areas other pages can collect. -When /someone/ wishes /p/ adds region with /...options/ & /p/ has region /r/ { - lassign [region centroid $r] cx cy - set angle [region angle $r] - - set defaults { - index 0 \ - height 55 \ - width 55 \ - highlight false \ - color red \ - } - - set index [dict get $options index] - set height [dict get $options height] - set width [dict get $options width] - set highlight [dict get $options highlight] - set color [dict get $options color] - - set offset [dict_getdef $options offset {0 0}] - set offset [::process_offset $offset $r] - set center [vec2 add [list $cx $cy] [vec2 rotate $offset $angle]] - - # compute points offset from $p - set hw [expr {$width / 2.0}] - set hh [expr {$height / 2.0}] - - # compute points in table coordinates - set tablePoints [lmap v [list \ - [list [expr {-$hw}] [expr {-$hh}]] \ - [list [expr {$hw}] [expr {-$hh}]] \ - [list [expr {$hw}] [expr {$hh}]] \ - [list [expr {-$hw}] [expr {$hh}]] \ - [list [expr {-$hw}] [expr {-$hh}]] \ - ] { - vec2 add $center [vec2 rotate $v $angle] - }] - - set edges [list] - for {set i 0} {$i < [llength $tablePoints]} {incr i} { - if {$i > 0} { lappend edges [list [expr {$i - 1}] $i] } - } - lappend edges [list [expr {[llength $tablePoints] - 1}] [lindex $tablePoints 0]] - - # Create new region in table points - set indexedRegion [region create $tablePoints $edges $angle] - Claim $p has indexedRegion with index $index region $indexedRegion - Claim "${p}:${index}" has region $indexedRegion - - # debug: display dashed line around the points - if {$highlight} { - Wish region $indexedRegion has highlight $highlight with color $color - } -} - -When /someone/ wishes region /r/ has highlight /highlighted/ with /...options/ { - - set color [dict_getdef $options color white] - set thickness [dict_getdef $options thickness 2] - set layer [dict_getdef $options layer 0] - set dashed [dict_getdef $options dashed false] - set dashlength [dict_getdef $options dashlength 20] - set dashoffset [dict_getdef $options dashoffset 0] - - if {$highlighted} { - set verts [region vertices $r] - set edges [region edges $r] - lappend verts [lindex $verts 0] - Wish to draw a dashed stroke with points $verts color $color width $thickness dashlength $dashlength dashoffset $dashoffset layer $layer - } -} - -Claim $this has demo { - # How to use - # When builtin-programs/shapes/region.folk has demo /code/ & \ - # $this has region /r/ { - # Claim $this has program code $code - # set angle [region angle $r] - # set pos [region bottom $r] - # Wish to draw text with position $pos scale 0.6 text $code radians $angle anchor topright - # } - - When $this has region /r/ { - Wish region $r has highlight true with color yellow thickness 1 dashed true - - Wish $this adds region with index 0 width 50 height 50 offset [list -250 0] highlight true color yellow - Wish $this draws text "Region 0" with offset [list -250 -50] scale 0.6 color yellow - Wish $this adds region with index 1 width 50 height 50 offset [list 250 0] highlight true color yellow - Wish $this draws text "Region 1" with offset [list 250 -50] scale 0.6 color yellow - } -} diff --git a/test/decorations.folk b/test/decorations.folk new file mode 100644 index 00000000..421885ac --- /dev/null +++ b/test/decorations.folk @@ -0,0 +1,18 @@ +source builtin-programs/decorations/label.folk +source builtin-programs/decorations/outline.folk +source builtin-programs/draw/spaces.folk + +assert {[drawOutlineMeterPoints 0.2 0.1] eq {{0m 0m} {0.2m 0m} {0.2m 0.1m} {0m 0.1m} {0m 0m}}} +assert {[drawOutlineMeterLength 0.01] eq "0.01m"} + +assert {[drawLabelMaxLineLength "hi\nthere"] == 5} +assert {abs([drawLabelDefaultScale "hello"] - 0.02) < 1e-9} +assert {abs([drawLabelDefaultScale [string repeat x 100]] - 0.0045) < 1e-9} + +set options [drawLabelDefaultOptions "hello" 0.2 0.1] +assert {[dict get $options position] eq {0.1m 0.05m}} +assert {[dict get $options scale] eq "0.02m"} +assert {[dict get $options anchor] eq "center"} +assert {[dict get $options font] eq "PTSans-Regular"} + +Exit! 0 diff --git a/test/draw-hit-targets.folk b/test/draw-hit-targets.folk new file mode 100644 index 00000000..c7c9f673 --- /dev/null +++ b/test/draw-hit-targets.folk @@ -0,0 +1,29 @@ +source builtin-programs/draw/spaces.folk +source builtin-programs/draw/hit-targets.folk + +set rect [drawHitTargetRect { + width 4 + height 2cm + offset {right 25%} +} 0.2 0.1] +lassign $rect x y width height +assert {abs($x - 0.13) < 1e-9} +assert {abs($y - 0.04) < 1e-9} +assert {abs($width - 0.04) < 1e-9} +assert {abs($height - 0.02) < 1e-9} + +set rect [drawHitTargetRect { + size 10% + top-left {1 2} +} 0.2 0.1] +lassign $rect x y width height +assert {abs($x - 0.01) < 1e-9} +assert {abs($y - 0.02) < 1e-9} +assert {abs($width - 0.02) < 1e-9} +assert {abs($height - 0.01) < 1e-9} + +assert {[drawHitTargetId parent {name button}] eq {hit target of parent button}} +assert {[drawHitTargetName {index 2}] == 2} +assert {[drawHitTargetOffset {left 50%} 0.2 0.1] eq {-0.1 0}} + +Exit! 0 diff --git a/test/draw-spaces.folk b/test/draw-spaces.folk index 26ff6988..25ef3e85 100644 --- a/test/draw-spaces.folk +++ b/test/draw-spaces.folk @@ -5,6 +5,9 @@ proc fakeQuadLib {cmd args} { vertices { lindex [lindex $args 0] 1 } + space { + lindex [lindex $args 0] 0 + } create { list [lindex $args 0] [lindex $args 1] } @@ -63,6 +66,15 @@ assert {$topRight eq {4.0 -1.0 0.0}} assert {$bottomRight eq {4.0 1.0 0.0}} assert {$bottomLeft eq {0.0 1.0 0.0}} +assert {[drawSpaceQuadSurfacePoint fakeQuadLib $q {2 1}] eq {2.0 1.0 0.0}} + +set rectQuad [drawSpaceQuadSurfaceRect fakeQuadLib $q 1 0.5 2 1] +lassign [fakeQuadLib vertices $rectQuad] topLeft topRight bottomRight bottomLeft +assert {$topLeft eq {1.0 0.5 0.0}} +assert {$topRight eq {3.0 0.5 0.0}} +assert {$bottomRight eq {3.0 1.5 0.0}} +assert {$bottomLeft eq {1.0 1.5 0.0}} + assert {[drawSpaceMeterPoint {0 1.5}] eq {0m 1.5m}} Exit! 0 From 28b8a831e460b684badced6ada77521623030bce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 11:05:46 -0400 Subject: [PATCH 08/20] Strengthen decoration surface tests --- builtin-programs/decorations/label.folk | 16 +++++-- builtin-programs/decorations/outline.folk | 20 +++++--- builtin-programs/draw/spaces.folk | 58 +++++++++++------------ test/decorations.folk | 36 ++++++++++++++ 4 files changed, 89 insertions(+), 41 deletions(-) diff --git a/builtin-programs/decorations/label.folk b/builtin-programs/decorations/label.folk index 088b8b71..4aa1343a 100644 --- a/builtin-programs/decorations/label.folk +++ b/builtin-programs/decorations/label.folk @@ -1,8 +1,14 @@ -proc drawLabelMeterLength {value} { +fn drawLabelMeterLength {value} { append value m } -proc drawLabelMaxLineLength {text} { +fn drawLabelMeterPoint {point} { + lmap value $point { + drawLabelMeterLength $value + } +} + +fn drawLabelMaxLineLength {text} { set maxLength 0 foreach line [split $text "\n"] { set lineLength [string length $line] @@ -13,16 +19,16 @@ proc drawLabelMaxLineLength {text} { return $maxLength } -proc drawLabelDefaultScale {text} { +fn drawLabelDefaultScale {text} { set maxLength [drawLabelMaxLineLength $text] if {$maxLength == 0} { return 0.02 } ::math::min 0.02 [/ 0.45 $maxLength] } -proc drawLabelDefaultOptions {text width height} { +fn drawLabelDefaultOptions {text width height} { set scale [drawLabelDefaultScale $text] dict create \ - position [drawSpaceMeterPoint [list [expr {$width / 2.0}] [expr {$height / 2.0}]]] \ + position [drawLabelMeterPoint [list [expr {$width / 2.0}] [expr {$height / 2.0}]]] \ scale [drawLabelMeterLength $scale] \ anchor center \ font "PTSans-Regular" diff --git a/builtin-programs/decorations/outline.folk b/builtin-programs/decorations/outline.folk index 5b0a6337..c538fb9a 100644 --- a/builtin-programs/decorations/outline.folk +++ b/builtin-programs/decorations/outline.folk @@ -1,13 +1,19 @@ -proc drawOutlineMeterLength {value} { +fn drawOutlineMeterLength {value} { append value m } -proc drawOutlineMeterPoints {width height} { - list [drawSpaceMeterPoint {0 0}] \ - [drawSpaceMeterPoint [list $width 0]] \ - [drawSpaceMeterPoint [list $width $height]] \ - [drawSpaceMeterPoint [list 0 $height]] \ - [drawSpaceMeterPoint {0 0}] +fn drawOutlineMeterPoint {point} { + lmap value $point { + drawOutlineMeterLength $value + } +} + +fn drawOutlineMeterPoints {width height} { + list [drawOutlineMeterPoint {0 0}] \ + [drawOutlineMeterPoint [list $width 0]] \ + [drawOutlineMeterPoint [list $width $height]] \ + [drawOutlineMeterPoint [list 0 $height]] \ + [drawOutlineMeterPoint {0 0}] } When /someone/ wishes /thing/ is outlined /color/ { diff --git a/builtin-programs/draw/spaces.folk b/builtin-programs/draw/spaces.folk index 53d6f524..1b6e3e7f 100644 --- a/builtin-programs/draw/spaces.folk +++ b/builtin-programs/draw/spaces.folk @@ -1,4 +1,4 @@ -proc drawSpacePhysicalLength {value} { +fn drawSpacePhysicalLength {value} { if {[llength $value] != 1} { error "draw/spaces: expected a scalar physical length, got $value" } @@ -25,7 +25,7 @@ proc drawSpacePhysicalLength {value} { } } -proc drawSpacePhysicalPoint {point} { +fn drawSpacePhysicalPoint {point} { if {[llength $point] != 2} { error "draw/spaces: expected a 2D physical point, got $point" } @@ -33,20 +33,20 @@ proc drawSpacePhysicalPoint {point} { [drawSpacePhysicalLength [lindex $point 1]] } -proc drawSpacePhysicalPoints {points} { +fn drawSpacePhysicalPoints {points} { lmap point $points { drawSpacePhysicalPoint $point } } -proc drawSpaceSetLength {options key} { +fn drawSpaceSetLength {options key} { if {[dict exists $options $key]} { dict set options $key [drawSpacePhysicalLength [dict get $options $key]] } return $options } -proc drawSpaceSetPoint {options key} { +fn drawSpaceSetPoint {options key} { if {[dict exists $options $key]} { set point [dict get $options $key] if {$point ne ""} { @@ -56,14 +56,14 @@ proc drawSpaceSetPoint {options key} { return $options } -proc drawSpaceSetPoints {options key} { +fn drawSpaceSetPoints {options key} { if {[dict exists $options $key]} { dict set options $key [drawSpacePhysicalPoints [dict get $options $key]] } return $options } -proc drawSpaceNormalizeOptions {shape options} { +fn drawSpaceNormalizeOptions {shape options} { switch -- $shape { line { set options [drawSpaceSetPoints $options points] @@ -128,11 +128,11 @@ proc drawSpaceNormalizeOptions {shape options} { return $options } -proc drawSpaceSurfaceTarget {target surface} { +fn drawSpaceSurfaceTarget {target surface} { list $target surface $surface } -proc drawSpaceVectorAdd {a b} { +fn drawSpaceVectorAdd {a b} { set out [list] foreach av $a bv $b { lappend out [expr {$av + $bv}] @@ -140,7 +140,7 @@ proc drawSpaceVectorAdd {a b} { return $out } -proc drawSpaceVectorSub {a b} { +fn drawSpaceVectorSub {a b} { set out [list] foreach av $a bv $b { lappend out [expr {$av - $bv}] @@ -148,13 +148,13 @@ proc drawSpaceVectorSub {a b} { return $out } -proc drawSpaceVectorScale {v s} { +fn drawSpaceVectorScale {v s} { lmap x $v { expr {$x * $s} } } -proc drawSpaceVectorDistance {a b} { +fn drawSpaceVectorDistance {a b} { set sum 0.0 foreach av $a bv $b { set d [expr {$av - $bv}] @@ -163,18 +163,18 @@ proc drawSpaceVectorDistance {a b} { expr {sqrt($sum)} } -proc drawSpaceDistance {a b} { +fn drawSpaceDistance {a b} { drawSpaceVectorDistance $a $b } -proc drawSpaceVectorUnit {v} { +fn drawSpaceVectorUnit {v} { set zero [lmap _ $v { expr {0.0} }] set n [drawSpaceVectorDistance $v $zero] if {$n == 0.0} { return "" } drawSpaceVectorScale $v [expr {1.0 / $n}] } -proc drawSpaceVectorAverage {points} { +fn drawSpaceVectorAverage {points} { set first [lindex $points 0] set sum [lmap _ $first { expr {0.0} }] foreach point $points { @@ -183,16 +183,16 @@ proc drawSpaceVectorAverage {points} { drawSpaceVectorScale $sum [expr {1.0 / [llength $points]}] } -proc drawSpaceVectorMidpoint {a b} { +fn drawSpaceVectorMidpoint {a b} { drawSpaceVectorScale [drawSpaceVectorAdd $a $b] 0.5 } -proc drawSpaceVectorMix {a b t} { +fn drawSpaceVectorMix {a b t} { drawSpaceVectorAdd $a \ [drawSpaceVectorScale [drawSpaceVectorSub $b $a] $t] } -proc drawSpaceQuadPoint {quadLib quad selector} { +fn drawSpaceQuadPoint {quadLib quad selector} { lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft switch -- [string tolower $selector] { @@ -229,7 +229,7 @@ proc drawSpaceQuadPoint {quadLib quad selector} { } } -proc drawSpaceQuadSize {quadLib quad} { +fn drawSpaceQuadSize {quadLib quad} { lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft set topWidth [drawSpaceVectorDistance $topLeft $topRight] @@ -241,7 +241,7 @@ proc drawSpaceQuadSize {quadLib quad} { [expr {($rightHeight + $leftHeight) / 2.0}] } -proc drawSpaceQuadSurfacePoint {quadLib quad point} { +fn drawSpaceQuadSurfacePoint {quadLib quad point} { lassign [drawSpaceQuadSize $quadLib $quad] width height if {$width == 0.0 || $height == 0.0} { error "draw/spaces: cannot map point through zero-sized quad" @@ -257,7 +257,7 @@ proc drawSpaceQuadSurfacePoint {quadLib quad point} { drawSpaceVectorMix $top $bottom $ty } -proc drawSpaceQuadSurfaceRect {quadLib quad x y width height} { +fn drawSpaceQuadSurfaceRect {quadLib quad x y width height} { $quadLib create [$quadLib space $quad] [list \ [drawSpaceQuadSurfacePoint $quadLib $quad [list $x $y]] \ [drawSpaceQuadSurfacePoint $quadLib $quad [list [expr {$x + $width}] $y]] \ @@ -265,7 +265,7 @@ proc drawSpaceQuadSurfaceRect {quadLib quad x y width height} { [drawSpaceQuadSurfacePoint $quadLib $quad [list $x [expr {$y + $height}]]]] } -proc drawSpacePerpendicularBetween {from to} { +fn drawSpacePerpendicularBetween {from to} { set dx [expr {[lindex $to 0] - [lindex $from 0]}] set dy [expr {[lindex $to 1] - [lindex $from 1]}] set perp [list [expr {-$dy}] $dx] @@ -283,7 +283,7 @@ proc drawSpacePerpendicularBetween {from to} { return $fallback } -proc drawSpaceSurfaceQuadBetween {quadLib space from to height} { +fn drawSpaceSurfaceQuadBetween {quadLib space from to height} { set halfHeight [expr {$height / 2.0}] set perp [drawSpaceVectorScale [drawSpacePerpendicularBetween $from $to] $halfHeight] @@ -295,13 +295,13 @@ proc drawSpaceSurfaceQuadBetween {quadLib space from to height} { $quadLib create $space [list $topLeft $topRight $bottomRight $bottomLeft] } -proc drawSpaceDisplayPixelToClip {displayWidth displayHeight point} { +fn drawSpaceDisplayPixelToClip {displayWidth displayHeight point} { lassign $point x y list [expr {2.0 * $x / $displayWidth - 1.0}] \ [expr {2.0 * $y / $displayHeight - 1.0}] } -proc drawSpaceHomography {pointPairs} { +fn drawSpaceHomography {pointPairs} { package require linalg namespace import ::math::linearalgebra::solvePGauss @@ -321,7 +321,7 @@ proc drawSpaceHomography {pointPairs} { [list [lindex $h 6] [lindex $h 7] 1.0] } -proc drawSpaceApplyHomography {H point} { +fn drawSpaceApplyHomography {H point} { lassign $point x y lassign [lindex $H 0] h00 h01 h02 lassign [lindex $H 1] h10 h11 h12 @@ -332,7 +332,7 @@ proc drawSpaceApplyHomography {H point} { list [expr {$hx / $hw}] [expr {$hy / $hw}] } -proc drawSpaceMeterPoint {point} { +fn drawSpaceMeterPoint {point} { lmap value $point { append value m } @@ -388,7 +388,7 @@ When the quad library is /quadLib/ &\ [drawSpaceHomography $pointPairs] } -proc drawSpaceWishPrimitive {article shape target surface options} { +fn drawSpaceWishPrimitive {article shape target surface options} { set normalized [drawSpaceNormalizeOptions $shape $options] Wish to draw $article $shape onto [drawSpaceSurfaceTarget $target $surface] \ with {*}$normalized @@ -404,7 +404,7 @@ When /someone/ wishes to draw a line onto /target/ in space /surface/ with /...o drawSpaceWishPrimitive a line $target $surface $options } -proc drawSpaceWishDashedLine {target surface options} { +fn drawSpaceWishDashedLine {target surface options} { set normalized [drawSpaceNormalizeOptions dashed-line $options] Wish to draw a dashed line onto [drawSpaceSurfaceTarget $target $surface] \ with {*}$normalized diff --git a/test/decorations.folk b/test/decorations.folk index 421885ac..528efe3b 100644 --- a/test/decorations.folk +++ b/test/decorations.folk @@ -1,9 +1,11 @@ +source builtin-programs/collect.folk source builtin-programs/decorations/label.folk source builtin-programs/decorations/outline.folk source builtin-programs/draw/spaces.folk assert {[drawOutlineMeterPoints 0.2 0.1] eq {{0m 0m} {0.2m 0m} {0.2m 0.1m} {0m 0.1m} {0m 0m}}} assert {[drawOutlineMeterLength 0.01] eq "0.01m"} +assert {[drawOutlineMeterPoint {0.2 0.1}] eq {0.2m 0.1m}} assert {[drawLabelMaxLineLength "hi\nthere"] == 5} assert {abs([drawLabelDefaultScale "hello"] - 0.02) < 1e-9} @@ -15,4 +17,38 @@ assert {[dict get $options scale] eq "0.02m"} assert {[dict get $options anchor] eq "center"} assert {[dict get $options font] eq "PTSans-Regular"} +set thing test-thing +set disp test-display +set surface test-surface +set surfaceTarget [drawSpaceSurfaceTarget $disp $surface] + +Assert! display $disp has width 100 height 100 +Assert! $thing has physical drawing surface $surface with width 0.2 height 0.1 space test-space +Assert! $disp has canvas projection for surface $surface {{1 0 0} {0 1 0} {0 0 1}} + +Wish $thing is labelled "hello" with color cyan +Wish $thing is outlined red with thickness 0.5 layer 7 + +sleep 1 + +set errors [Query! /program/ has error /err/ with info /info/] +assert {[llength $errors] == 0} + +set textDraws [Query! /someone/ wishes to draw text onto $surfaceTarget with /...drawOptions/] +assert {[llength $textDraws] == 1} +set drawOptions [dict get [lindex $textDraws 0] drawOptions] +assert {[dict get $drawOptions text] eq "hello"} +assert {[dict get $drawOptions color] eq "cyan"} +assert {[dict get $drawOptions anchor] eq "center"} +assert {abs([dict get $drawOptions scale] - 0.02) < 1e-9} +assert {[dict get $drawOptions position] eq {0.1 0.05}} + +set lineDraws [Query! /someone/ wishes to draw a line onto $surfaceTarget with /...drawOptions/] +assert {[llength $lineDraws] == 1} +set drawOptions [dict get [lindex $lineDraws 0] drawOptions] +assert {[dict get $drawOptions color] eq "red"} +assert {[dict get $drawOptions layer] == 7} +assert {abs([dict get $drawOptions width] - 0.005) < 1e-9} +assert {[dict get $drawOptions points] eq {{0.0 0.0} {0.2 0.0} {0.2 0.1} {0.0 0.1} {0.0 0.0}}} + Exit! 0 From b4090107660fcb19e4dbb9c1a5cf96874e45346d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 11:14:12 -0400 Subject: [PATCH 09/20] Port terminal to physical surfaces --- builtin-programs/editor.folk | 7 +- builtin-programs/terminal.folk | 221 ++++++++++++++++++++++++++------- lib/terminal.tcl | 46 ++++--- test/terminal.folk | 71 +++++++++++ 4 files changed, 280 insertions(+), 65 deletions(-) create mode 100644 test/terminal.folk diff --git a/builtin-programs/editor.folk b/builtin-programs/editor.folk index 952b6b58..f4462902 100644 --- a/builtin-programs/editor.folk +++ b/builtin-programs/editor.folk @@ -17,12 +17,14 @@ When /k/ is a keyboard with /...opts/ &\ Claim $editor has quad [$quadLib move $q up 105%] } Claim $k has created editor $editor - Claim $k is typing into $editor + When /nobody/ claims $k has focused input target /anything/ { + Claim $k is typing into $editor + } } When /k/ is a keyboard with /...opts/ &\ - /nobody/ claims /k/ has created editor /any/ &\ /k/ points up at /editor/ & /editor/ is an editor with /...opts/ { + Claim $k has focused input target $editor Claim $k is typing into $editor } @@ -73,6 +75,7 @@ set editorLib [library create editorLib {margin defaults} { When /someone/ claims /editor/ is an editor { Claim $editor is an editor with {*}$defaults + Claim $editor accepts keyboard input } When /editor/ is an editor with /...options/ { diff --git a/builtin-programs/terminal.folk b/builtin-programs/terminal.folk index 1fd9c042..ab4944e5 100644 --- a/builtin-programs/terminal.folk +++ b/builtin-programs/terminal.folk @@ -2,64 +2,195 @@ # # Spawn terminals with any command (default "bash"): # Wish $this is a terminal -# Wish $this is a terminal spawning "any command" +# Wish $this is a terminal spawning "vim" +# Wish $this is a terminal spawning "bash" with rows 24 cols 80 # -# Send keyboard events to the terminal: -# Claim $thing has keyboard input -# -# Optionally, draw the terminal on an arbitrary region: -# Claim $thing has terminal region $region -# -# -# Example program: Tie it all together with a simple vim editor... -# -# When $this points up at /target/ & /target/ has program /anything/ { -# Wish $this is a terminal spawning "vim ~/folk-printed-programs/$target.folk" -# When $this has region /r/ { -# Claim $this has terminal region [region move $r right 350px] -# } -# Claim $this has keyboard input +# Terminals draw onto their own physical drawing surface. To attach one to +# another quad, create a child surface and make that child the terminal: +# Wish $this adds child surface terminal with width 16 height 9 offset {right 60%} +# When $this has child surface /term/ with name terminal /...opts/ { +# Wish $term is a terminal spawning "bash" # } # -# - -error "FIXME: terminal.folk not currently working." +# Keyboard input follows the same focus relation as editors: a keyboard that +# points at a terminal types into that terminal. source lib/terminal.tcl -# WIP: Needs to finish being fixed for folk2. +fn terminalDefaultOptions {} { + dict create \ + rows 12 \ + cols 43 \ + padding 0.4 \ + textScale "" \ + font NeomatrixCode \ + foreground green \ + background {0 0 0 0.82} \ + activeColor green \ + layer 0 +} + +fn terminalOptionsWithDefaults {options} { + dict merge [terminalDefaultOptions] $options +} + +fn terminalPhysicalLength {value} { + if {[llength $value] != 1} { + error "terminal: expected a scalar physical length, got $value" + } + + set unit "" + set amount $value + foreach suffix {mm cm m} { + if {[string match *$suffix $value]} { + set unit $suffix + set amount [string range $value 0 end-[string length $suffix]] + break + } + } + + if {![string is double -strict $amount]} { + error "terminal: invalid physical length $value" + } + + switch -- $unit { + "" - cm { return [expr {double($amount) * 0.01}] } + mm { return [expr {double($amount) * 0.001}] } + m { return [expr {double($amount)}] } + default { error "terminal: invalid physical unit $unit" } + } +} + +fn terminalMeterLength {value} { + append value m +} + +fn terminalMeterPoint {point} { + lmap value $point { + terminalMeterLength $value + } +} + +fn terminalTextScale {width height options} { + set explicit [dict getdef $options textScale ""] + if {$explicit ne ""} { + return [terminalPhysicalLength $explicit] + } + + set rows [dict get $options rows] + set cols [dict get $options cols] + set padding [terminalPhysicalLength [dict get $options padding]] + set usableWidth [expr {$width - 2.0 * $padding}] + set usableHeight [expr {$height - 2.0 * $padding}] + if {$usableWidth < 0.001} { set usableWidth 0.001 } + if {$usableHeight < 0.001} { set usableHeight 0.001 } + + if {$rows < 1} { set rows 1 } + if {$cols < 1} { set cols 1 } + set rowScale [expr {$usableHeight / $rows}] + set colScale [expr {$usableWidth / $cols / 0.5859375}] + if {$rowScale < $colScale} { + return $rowScale + } + return $colScale +} + +fn terminalSurfaceCorners {width height} { + list [terminalMeterPoint {0 0}] \ + [terminalMeterPoint [list $width 0]] \ + [terminalMeterPoint [list $width $height]] \ + [terminalMeterPoint [list 0 $height]] +} + +fn terminalDrawSurface {disp surface width height text options isActive} { + set options [terminalOptionsWithDefaults $options] + lassign [terminalSurfaceCorners $width $height] p0 p1 p2 p3 + + set background [dict get $options background] + set layer [dict get $options layer] + Wish to draw a quad onto $disp in surface $surface with \ + p0 $p0 p1 $p1 p2 $p2 p3 $p3 \ + color $background layer [expr {$layer - 10}] + + set padding [terminalPhysicalLength [dict get $options padding]] + set scale [terminalTextScale $width $height $options] + Wish to draw text onto $disp in surface $surface with \ + position [terminalMeterPoint [list $padding $padding]] \ + scale [terminalMeterLength $scale] \ + anchor topleft \ + font [dict get $options font] \ + color [dict get $options foreground] \ + layer $layer \ + text $text + + if {$isActive} { + set points [list $p0 $p1 $p2 $p3 $p0] + Wish to draw a line onto $disp in surface $surface with \ + points $points width 0.2 color [dict get $options activeColor] \ + layer [expr {$layer + 1}] + } +} When /anyone/ wishes /thing/ is a terminal { - Wish $thing is a terminal spawning bash + Wish $thing is a terminal spawning bash } -When /thing/ has terminal region /r/ & /r/ has keyboard input { - Claim $thing has keyboard input +When /anyone/ wishes /thing/ is a terminal with /...options/ { + Wish $thing is a terminal spawning bash with {*}$options } When /anyone/ wishes /thing/ is a terminal spawning /cmd/ { - set term [$terminalLib create 12 43 $cmd] - # Keep for 10 minutes. - Claim -keep [expr {10*60*1000}]ms \ - -destructor [list $terminalLib destroy $term] - $thing has terminal $term spawning $cmd - - When the clock time is /t/ { - set body { - Wish region $region is labelled [$terminalLib read $term] + Wish $thing is a terminal spawning $cmd with {*}[terminalDefaultOptions] +} + +When /anyone/ wishes /thing/ is a terminal spawning /cmd/ with /...options/ { + set options [terminalOptionsWithDefaults $options] + set rows [dict get $options rows] + set cols [dict get $options cols] + if {$rows < 2 || $cols < 2} { + error "terminal: rows and cols must both be at least 2" + } + set term [$terminalLib create $rows $cols $cmd] + if {$term eq ""} { + error "terminal: failed to spawn $cmd" + } + + Claim -keep [expr {10 * 60 * 1000}]ms \ + -destructor [list $terminalLib destroy $term] \ + $thing has terminal $term spawning $cmd with {*}$options + Claim $thing is a terminal with {*}$options + Claim $thing accepts keyboard input +} + +When /keyboard/ is a keyboard with path /kbPath/ /...keyboardOptions/ &\ + /keyboard/ points up at /thing/ &\ + /thing/ is a terminal with /...terminalOptions/ { + Claim $keyboard has focused input target $thing + Claim $keyboard is typing into $thing +} + +When /keyboard/ is a keyboard with path /kbPath/ /...keyboardOptions/ &\ + /keyboard/ is typing into /thing/ &\ + /thing/ has terminal /term/ spawning /cmd/ with /...terminalOptions/ { + Subscribe: keyboard $kbPath claims key /key/ is /keyState/ with /...options/ { + $terminalLib handleEvent $term $key $keyState $options } - When $thing has terminal region /region/ $body - When /nobody/ claims $thing has terminal region /x/ & $thing has region /region/ $body - } - - When /anyone/ claims $thing has keyboard input \ - & keyboard /anyone/ claims key /key/ is /direction/ with /...options/ { - if {$direction != "up"} { - if {[dict exists $options printable]} { - $terminalLib write $term [dict get $options printable] - } else { - $terminalLib handleKey $term $key - } +} + +# Backwards compatibility with the old global-input API. Prefer pointing a +# keyboard at the terminal quad, which uses the focus relation above. +When /anyone/ claims /thing/ has keyboard input &\ + /thing/ has terminal /term/ spawning /cmd/ with /...terminalOptions/ { + Subscribe: keyboard /kbPath/ claims key /key/ is /keyState/ with /...options/ { + $terminalLib handleEvent $term $key $keyState $options } - } +} + +When display /disp/ has width /displayWidth/ height /displayHeight/ &\ + /thing/ has terminal /term/ spawning /cmd/ with /...options/ &\ + /thing/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + /disp/ has canvas projection for surface /surface/ /surfaceToClip/ &\ + the clock time is /t/ { + set isActive [expr {[llength [Query! /someone/ claims /keyboard/ is typing into $thing]] > 0}] + terminalDrawSurface $disp $surface $width $height [$terminalLib read $term] $options $isActive } diff --git a/lib/terminal.tcl b/lib/terminal.tcl index 9c72d103..f0d0d995 100644 --- a/lib/terminal.tcl +++ b/lib/terminal.tcl @@ -10,7 +10,7 @@ $cc endcflags -lutil ./vendor/libtmt/tmt.c $cc include $cc include $cc include -if {$::tcl_platform(os) eq "darwin"} { +if {[string tolower $::tcl_platform(os)] eq "darwin"} { $cc include } else { $cc include @@ -91,16 +91,25 @@ $cc proc termCreate {int rows int cols char* cmd[]} VTerminal* { vt->ncols = cols; vt->display = malloc(sizeof(char[rows][cols + 1])); + memset(vt->display, ' ', sizeof(char[rows][cols + 1])); for (int r = 0; r < rows - 1; r++) { *charAt(vt, r, cols) = '\n'; } *charAt(vt, rows - 1, cols) = '\0'; vt->tmt = tmt_open(rows, cols, tmtEvent, vt, NULL); + if (vt->tmt == NULL) { + free(vt->display); + free(vt); + return NULL; + } struct winsize ws = {.ws_row = rows, .ws_col = cols}; pid_t pid = forkpty(&vt->pty_fd, NULL, NULL, &ws); if (pid < 0){ + tmt_close(vt->tmt); + free(vt->display); + free(vt); return NULL; } else if (pid == 0){ setenv("TERM", "ansi", 1); @@ -118,6 +127,7 @@ $cc proc termCreate {int rows int cols char* cmd[]} VTerminal* { $cc proc termDestroy {VTerminal* vt} void { kill(vt->pid, SIGTERM); close(vt->pty_fd); + tmt_close(vt->tmt); free(vt->display); free(vt); } @@ -166,25 +176,21 @@ set terminalLib [library create terminalLib {impl} { dict append keymap "Control_$char" $charCode } - proc _remap {key} { + proc keyBytes {key {options {}}} { variable keymap - if {[string length $key] == 1} { - # Convert ctrl-A through ctrl-Z and others to terminal control characters - if {$ctrlPressed} { - set charCode [scan [string toupper $key] %c] - if {$charCode >= 64 && $charCode <= 95} { - set charCode [expr {$charCode - 64}] - return [format %c $charCode] - } - } - # All other single char keys can be passed through - return $key + if {[dict exists $options printable]} { + return [dict get $options printable] } if {[dict exists $keymap $key]} { return [dict get $keymap $key] } + + if {[string length $key] == 1} { + return $key + } + return "" } @@ -203,18 +209,22 @@ set terminalLib [library create terminalLib {impl} { $impl termWrite $term $char } - proc handleKey {term key} { + proc handleKey {term key {options {}}} { variable impl - set key [_remap $key] - if {$key ne ""} { - $impl termWrite $term $key + set bytes [keyBytes $key $options] + if {$bytes ne ""} { + $impl termWrite $term $bytes } } + proc handleEvent {term key keyState options} { + if {$keyState eq "up"} { return } + handleKey $term $key $options + } + # Returns a newline separated string of terminal lines proc read {term} { variable impl $impl termRead $term } }] - diff --git a/test/terminal.folk b/test/terminal.folk new file mode 100644 index 00000000..7205ebdb --- /dev/null +++ b/test/terminal.folk @@ -0,0 +1,71 @@ +source builtin-programs/collect.folk +source builtin-programs/terminal.folk +source builtin-programs/draw/spaces.folk +source builtin-programs/editor.folk + +assert {abs([terminalPhysicalLength 3] - 0.03) < 1e-9} +assert {abs([terminalPhysicalLength 4mm] - 0.004) < 1e-9} +assert {[terminalMeterPoint {0.2 0.1}] eq {0.2m 0.1m}} + +set options [terminalOptionsWithDefaults {rows 2 cols 10 padding 0.2 foreground white}] +assert {[dict get $options rows] == 2} +assert {[dict get $options cols] == 10} +assert {[dict get $options foreground] eq "white"} +assert {[dict get $options font] eq "NeomatrixCode"} + +assert {[$terminalLib keyBytes x {printable x}] eq "x"} +assert {[$terminalLib keyBytes Return {}] eq "\r"} +assert {[$terminalLib keyBytes Control_c {}] eq "\x03"} +assert {[$terminalLib keyBytes NotARealKey {}] eq ""} + +set disp test-display +set surface test-surface +set surfaceTarget [drawSpaceSurfaceTarget $disp $surface] + +terminalDrawSurface $disp $surface 0.2 0.1 "hello" $options true +sleep 0.5 + +set textDraws [Query! /someone/ wishes to draw text onto $surfaceTarget with /...drawOptions/] +assert {[llength $textDraws] == 1} +set drawOptions [dict get [lindex $textDraws 0] drawOptions] +assert {[dict get $drawOptions text] eq "hello"} +assert {[dict get $drawOptions color] eq "white"} +assert {[dict get $drawOptions anchor] eq "topleft"} + +set lineDraws [Query! /someone/ wishes to draw a line onto $surfaceTarget with /...drawOptions/] +assert {[llength $lineDraws] == 1} +set drawOptions [dict get [lindex $lineDraws 0] drawOptions] +assert {[dict get $drawOptions color] eq "green"} + +Wish spawned-terminal is a terminal spawning "printf hi" with rows 2 cols 10 +sleep 0.5 + +set spawned [Query! /someone/ claims spawned-terminal has terminal /term/ spawning /cmd/ with /...spawnOptions/] +assert {[llength $spawned] == 1} +set spawnedTerm [dict get [lindex $spawned 0] term] +set output "" +for {set i 0} {$i < 10} {incr i} { + set output [$terminalLib read $spawnedTerm] + if {[string first hi $output] >= 0} { + break + } + sleep 0.1 +} +assert {[string first hi $output] >= 0} + +set keyboard keyboard-page +set terminal terminal-page +set syntheticEditor [list $keyboard editor] + +Assert! $keyboard is a keyboard with path keyboard-path locale us +Assert! $terminal is a terminal with {*}[terminalDefaultOptions] +Assert! $keyboard points up at $terminal + +sleep 1 + +assert {[llength [Query! /someone/ claims $keyboard has focused input target $terminal]] == 1} +assert {[llength [Query! /someone/ claims $keyboard is typing into $terminal]] == 1} +assert {[llength [Query! /someone/ claims $keyboard is typing into $syntheticEditor]] == 0} +assert {[llength [Query! /program/ has error /err/ with info /info/]] == 0} + +Exit! 0 From 2de73b2cab653c3f1563855fb3c24e07ddf741d5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Sun, 3 May 2026 12:57:04 -0400 Subject: [PATCH 10/20] Harden terminal lifecycle and focus fallback --- builtin-programs/terminal.folk | 27 +++++- lib/terminal.tcl | 170 +++++++++++++++++++++++---------- test/terminal.folk | 9 ++ 3 files changed, 154 insertions(+), 52 deletions(-) diff --git a/builtin-programs/terminal.folk b/builtin-programs/terminal.folk index ab4944e5..b7d1b5c8 100644 --- a/builtin-programs/terminal.folk +++ b/builtin-programs/terminal.folk @@ -14,6 +14,8 @@ # # Keyboard input follows the same focus relation as editors: a keyboard that # points at a terminal types into that terminal. +# The old "has keyboard input" API is still accepted as a fallback for keyboards +# that do not currently have a focused input target. source lib/terminal.tcl @@ -34,6 +36,20 @@ fn terminalOptionsWithDefaults {options} { dict merge [terminalDefaultOptions] $options } +fn terminalInstanceKey {thing cmd options} { + list terminal $thing $cmd $options +} + +fn terminalKeyboardPathHasFocusedTarget {kbPath} { + foreach result [Query! /keyboard/ is a keyboard with path $kbPath /...keyboardOptions/] { + set keyboard [dict get $result keyboard] + if {[llength [Query! /someone/ claims $keyboard has focused input target /target/]] > 0} { + return 1 + } + } + return 0 +} + fn terminalPhysicalLength {value} { if {[llength $value] != 1} { error "terminal: expected a scalar physical length, got $value" @@ -150,7 +166,15 @@ When /anyone/ wishes /thing/ is a terminal spawning /cmd/ with /...options/ { if {$rows < 2 || $cols < 2} { error "terminal: rows and cols must both be at least 2" } - set term [$terminalLib create $rows $cols $cmd] + + set existing [Query! /someone/ claims $thing has terminal /term/ spawning $cmd with {*}$options] + if {[llength $existing] > 0} { + Claim $thing is a terminal with {*}$options + Claim $thing accepts keyboard input + return + } + + set term [$terminalLib createForKey [terminalInstanceKey $thing $cmd $options] $rows $cols $cmd] if {$term eq ""} { error "terminal: failed to spawn $cmd" } @@ -182,6 +206,7 @@ When /keyboard/ is a keyboard with path /kbPath/ /...keyboardOptions/ &\ When /anyone/ claims /thing/ has keyboard input &\ /thing/ has terminal /term/ spawning /cmd/ with /...terminalOptions/ { Subscribe: keyboard /kbPath/ claims key /key/ is /keyState/ with /...options/ { + if {[terminalKeyboardPathHasFocusedTarget $kbPath]} { return } $terminalLib handleEvent $term $key $keyState $options } } diff --git a/lib/terminal.tcl b/lib/terminal.tcl index f0d0d995..5c56314d 100644 --- a/lib/terminal.tcl +++ b/lib/terminal.tcl @@ -19,24 +19,31 @@ $cc include $cc include $cc include $cc include +$cc include $cc include "tmt.h" -$cc struct VTerminal { - TMT* tmt; - int pty_fd; - int pid; - - // Note: display has 1 more column than tmt screen to hold newlines between each line - char* display; - int curs_r; - int curs_c; - int ncols; -}; - $cc code { #define PTYBUF 4096 char iobuf[PTYBUF]; + typedef struct VTerminal { + TMT* tmt; + int pty_fd; + int pid; + + // Note: display has 1 more column than tmt screen to hold newlines between each line. + char* display; + int curs_r; + int curs_c; + int ncols; + char* key; + int refCount; + struct VTerminal* next; + } VTerminal; + + pthread_mutex_t terminalRegistryMutex = PTHREAD_MUTEX_INITIALIZER; + VTerminal* terminalRegistry = NULL; + char* charAt(VTerminal *vt, int r, int c) { int i = r * (vt->ncols + 1) + c; return &vt->display[i]; @@ -75,61 +82,117 @@ $cc code { *charAt(vt, vt->curs_r, vt->curs_c) = 0xDB; // block char: â–ˆ } } -} -$cc proc termCreate {int rows int cols char* cmd[]} VTerminal* { - int i = 0; - while (true) { - // execvp requires cmd array to be terminated by null pointer - if (strlen(cmd[i]) == 0) { cmd[i] = NULL; break; } - i++; - } + VTerminal* termCreateRaw(int rows, int cols, char** cmd) { + int i = 0; + while (true) { + // execvp requires cmd array to be terminated by null pointer. + if (strlen(cmd[i]) == 0) { cmd[i] = NULL; break; } + i++; + } - VTerminal *vt = malloc(sizeof(VTerminal)); - vt->curs_r = 0; - vt->curs_c = 0; - vt->ncols = cols; + VTerminal *vt = malloc(sizeof(VTerminal)); + vt->curs_r = 0; + vt->curs_c = 0; + vt->ncols = cols; + vt->key = NULL; + vt->refCount = 1; + vt->next = NULL; + + vt->display = malloc(sizeof(char[rows][cols + 1])); + memset(vt->display, ' ', sizeof(char[rows][cols + 1])); + for (int r = 0; r < rows - 1; r++) { + *charAt(vt, r, cols) = '\n'; + } + *charAt(vt, rows - 1, cols) = '\0'; - vt->display = malloc(sizeof(char[rows][cols + 1])); - memset(vt->display, ' ', sizeof(char[rows][cols + 1])); - for (int r = 0; r < rows - 1; r++) { - *charAt(vt, r, cols) = '\n'; - } - *charAt(vt, rows - 1, cols) = '\0'; + vt->tmt = tmt_open(rows, cols, tmtEvent, vt, NULL); + if (vt->tmt == NULL) { + free(vt->display); + free(vt); + return NULL; + } - vt->tmt = tmt_open(rows, cols, tmtEvent, vt, NULL); - if (vt->tmt == NULL) { - free(vt->display); - free(vt); - return NULL; + struct winsize ws = {.ws_row = rows, .ws_col = cols}; + pid_t pid = forkpty(&vt->pty_fd, NULL, NULL, &ws); + if (pid < 0){ + tmt_close(vt->tmt); + free(vt->display); + free(vt); + return NULL; + } else if (pid == 0){ + setenv("TERM", "ansi", 1); + if (execvp(cmd[0], cmd) == -1) { + fprintf(stderr, "execvp(%s, ...) failed: %m\n", cmd[0]); + } + _exit(127); + } + + vt->pid = pid; + fcntl(vt->pty_fd, F_SETFL, O_NONBLOCK); + return vt; } - struct winsize ws = {.ws_row = rows, .ws_col = cols}; - pid_t pid = forkpty(&vt->pty_fd, NULL, NULL, &ws); - if (pid < 0){ + void termDestroyRaw(VTerminal* vt) { + kill(vt->pid, SIGTERM); + close(vt->pty_fd); tmt_close(vt->tmt); free(vt->display); free(vt); - return NULL; - } else if (pid == 0){ - setenv("TERM", "ansi", 1); - if (execvp(cmd[0], cmd) == -1) { - fprintf(stderr, "execvp(%s, ...) failed: %m\n", cmd[0]); + } +} + +$cc proc termCreate {int rows int cols char* cmd[]} VTerminal* { + return termCreateRaw(rows, cols, cmd); +} + +$cc proc termCreateForKey {char* key int rows int cols char* cmd[]} VTerminal* { + pthread_mutex_lock(&terminalRegistryMutex); + for (VTerminal* vt = terminalRegistry; vt != NULL; vt = vt->next) { + if (strcmp(vt->key, key) == 0) { + vt->refCount++; + pthread_mutex_unlock(&terminalRegistryMutex); + return vt; } - return NULL; } - vt->pid = pid; - fcntl(vt->pty_fd, F_SETFL, O_NONBLOCK); + VTerminal* vt = termCreateRaw(rows, cols, cmd); + if (vt != NULL) { + vt->key = strdup(key); + vt->next = terminalRegistry; + terminalRegistry = vt; + } + pthread_mutex_unlock(&terminalRegistryMutex); return vt; } $cc proc termDestroy {VTerminal* vt} void { - kill(vt->pid, SIGTERM); - close(vt->pty_fd); - tmt_close(vt->tmt); - free(vt->display); - free(vt); + if (vt == NULL) { return; } + + if (vt->key == NULL) { + termDestroyRaw(vt); + return; + } + + pthread_mutex_lock(&terminalRegistryMutex); + vt->refCount--; + if (vt->refCount > 0) { + pthread_mutex_unlock(&terminalRegistryMutex); + return; + } + + VTerminal** cursor = &terminalRegistry; + while (*cursor != NULL) { + if (*cursor == vt) { + *cursor = vt->next; + break; + } + cursor = &(*cursor)->next; + } + pthread_mutex_unlock(&terminalRegistryMutex); + + free(vt->key); + termDestroyRaw(vt); } $cc proc termRead {VTerminal* vt} char* { @@ -199,6 +262,11 @@ set terminalLib [library create terminalLib {impl} { $impl termCreate $rows $cols [list bash -c $cmd ""] } + proc createForKey {key rows cols cmd} { + variable impl + $impl termCreateForKey $key $rows $cols [list bash -c $cmd ""] + } + proc destroy {term} { variable impl $impl termDestroy $term diff --git a/test/terminal.folk b/test/terminal.folk index 7205ebdb..7dfa1360 100644 --- a/test/terminal.folk +++ b/test/terminal.folk @@ -53,6 +53,13 @@ for {set i 0} {$i < 10} {incr i} { } assert {[string first hi $output] >= 0} +Assert! first-wisher wishes shared-terminal is a terminal spawning "printf shared" with rows 2 cols 10 +Assert! second-wisher wishes shared-terminal is a terminal spawning "printf shared" with rows 2 cols 10 +sleep 0.5 + +set shared [Query! /someone/ claims shared-terminal has terminal /term/ spawning /cmd/ with /...sharedOptions/] +assert {[llength $shared] == 1} + set keyboard keyboard-page set terminal terminal-page set syntheticEditor [list $keyboard editor] @@ -66,6 +73,8 @@ sleep 1 assert {[llength [Query! /someone/ claims $keyboard has focused input target $terminal]] == 1} assert {[llength [Query! /someone/ claims $keyboard is typing into $terminal]] == 1} assert {[llength [Query! /someone/ claims $keyboard is typing into $syntheticEditor]] == 0} +assert {[terminalKeyboardPathHasFocusedTarget keyboard-path] == 1} +assert {[terminalKeyboardPathHasFocusedTarget unknown-keyboard-path] == 0} assert {[llength [Query! /program/ has error /err/ with info /info/]] == 0} Exit! 0 From a26ca34c021de7bc5e0ef30e695a825e51558a25 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Tue, 5 May 2026 12:47:32 -0400 Subject: [PATCH 11/20] Clean up drawing surface helper conventions --- builtin-programs/decorations/label.folk | 17 ++++--------- builtin-programs/decorations/outline.folk | 29 +++++++++------------- builtin-programs/draw/spaces.folk | 2 +- builtin-programs/terminal.folk | 30 +++++++++++------------ test/decorations.folk | 5 ++-- test/terminal.folk | 2 +- 6 files changed, 35 insertions(+), 50 deletions(-) diff --git a/builtin-programs/decorations/label.folk b/builtin-programs/decorations/label.folk index 4aa1343a..5d1149f0 100644 --- a/builtin-programs/decorations/label.folk +++ b/builtin-programs/decorations/label.folk @@ -1,13 +1,3 @@ -fn drawLabelMeterLength {value} { - append value m -} - -fn drawLabelMeterPoint {point} { - lmap value $point { - drawLabelMeterLength $value - } -} - fn drawLabelMaxLineLength {text} { set maxLength 0 foreach line [split $text "\n"] { @@ -27,9 +17,12 @@ fn drawLabelDefaultScale {text} { fn drawLabelDefaultOptions {text width height} { set scale [drawLabelDefaultScale $text] + set position [lmap value [list [expr {$width / 2.0}] [expr {$height / 2.0}]] { + format "%sm" $value + }] dict create \ - position [drawLabelMeterPoint [list [expr {$width / 2.0}] [expr {$height / 2.0}]]] \ - scale [drawLabelMeterLength $scale] \ + position $position \ + scale [format "%sm" $scale] \ anchor center \ font "PTSans-Regular" } diff --git a/builtin-programs/decorations/outline.folk b/builtin-programs/decorations/outline.folk index c538fb9a..7708dce7 100644 --- a/builtin-programs/decorations/outline.folk +++ b/builtin-programs/decorations/outline.folk @@ -1,21 +1,16 @@ -fn drawOutlineMeterLength {value} { - append value m -} - -fn drawOutlineMeterPoint {point} { - lmap value $point { - drawOutlineMeterLength $value +fn drawOutlinePoints {width height} { + lmap point [list \ + {0 0} \ + [list $width 0] \ + [list $width $height] \ + [list 0 $height] \ + {0 0}] { + lmap value $point { + format "%sm" $value + } } } -fn drawOutlineMeterPoints {width height} { - list [drawOutlineMeterPoint {0 0}] \ - [drawOutlineMeterPoint [list $width 0]] \ - [drawOutlineMeterPoint [list $width $height]] \ - [drawOutlineMeterPoint [list 0 $height]] \ - [drawOutlineMeterPoint {0 0}] -} - When /someone/ wishes /thing/ is outlined /color/ { Wish $thing is outlined with color $color } @@ -29,10 +24,10 @@ When display /disp/ has width /displayWidth/ height /displayHeight/ &\ /disp/ has canvas projection for surface /surface/ /surfaceToClip/ &\ /someone/ wishes /thing/ is outlined with /...options/ { set color [dict getdef $options color white] - set outlineWidth [dict getdef $options width [dict getdef $options thickness [drawOutlineMeterLength 0.01]]] + set outlineWidth [dict getdef $options width [dict getdef $options thickness [format "%sm" 0.01]]] set layer [dict getdef $options layer 2] Wish to draw a line onto $disp in surface $surface with \ - points [drawOutlineMeterPoints $width $height] \ + points [drawOutlinePoints $width $height] \ width $outlineWidth color $color layer $layer } diff --git a/builtin-programs/draw/spaces.folk b/builtin-programs/draw/spaces.folk index 1b6e3e7f..dfacbde9 100644 --- a/builtin-programs/draw/spaces.folk +++ b/builtin-programs/draw/spaces.folk @@ -334,7 +334,7 @@ fn drawSpaceApplyHomography {H point} { fn drawSpaceMeterPoint {point} { lmap value $point { - append value m + format "%sm" $value } } diff --git a/builtin-programs/terminal.folk b/builtin-programs/terminal.folk index b7d1b5c8..fffb7c79 100644 --- a/builtin-programs/terminal.folk +++ b/builtin-programs/terminal.folk @@ -77,16 +77,6 @@ fn terminalPhysicalLength {value} { } } -fn terminalMeterLength {value} { - append value m -} - -fn terminalMeterPoint {point} { - lmap value $point { - terminalMeterLength $value - } -} - fn terminalTextScale {width height options} { set explicit [dict getdef $options textScale ""] if {$explicit ne ""} { @@ -112,10 +102,15 @@ fn terminalTextScale {width height options} { } fn terminalSurfaceCorners {width height} { - list [terminalMeterPoint {0 0}] \ - [terminalMeterPoint [list $width 0]] \ - [terminalMeterPoint [list $width $height]] \ - [terminalMeterPoint [list 0 $height]] + lmap point [list \ + {0 0} \ + [list $width 0] \ + [list $width $height] \ + [list 0 $height]] { + lmap value $point { + format "%sm" $value + } + } } fn terminalDrawSurface {disp surface width height text options isActive} { @@ -130,9 +125,12 @@ fn terminalDrawSurface {disp surface width height text options isActive} { set padding [terminalPhysicalLength [dict get $options padding]] set scale [terminalTextScale $width $height $options] + set textPosition [lmap value [list $padding $padding] { + format "%sm" $value + }] Wish to draw text onto $disp in surface $surface with \ - position [terminalMeterPoint [list $padding $padding]] \ - scale [terminalMeterLength $scale] \ + position $textPosition \ + scale [format "%sm" $scale] \ anchor topleft \ font [dict get $options font] \ color [dict get $options foreground] \ diff --git a/test/decorations.folk b/test/decorations.folk index 528efe3b..2973588f 100644 --- a/test/decorations.folk +++ b/test/decorations.folk @@ -3,9 +3,8 @@ source builtin-programs/decorations/label.folk source builtin-programs/decorations/outline.folk source builtin-programs/draw/spaces.folk -assert {[drawOutlineMeterPoints 0.2 0.1] eq {{0m 0m} {0.2m 0m} {0.2m 0.1m} {0m 0.1m} {0m 0m}}} -assert {[drawOutlineMeterLength 0.01] eq "0.01m"} -assert {[drawOutlineMeterPoint {0.2 0.1}] eq {0.2m 0.1m}} +assert {[drawOutlinePoints 0.2 0.1] eq {{0m 0m} {0.2m 0m} {0.2m 0.1m} {0m 0.1m} {0m 0m}}} +assert {[drawSpaceMeterPoint {0.2 0.1}] eq {0.2m 0.1m}} assert {[drawLabelMaxLineLength "hi\nthere"] == 5} assert {abs([drawLabelDefaultScale "hello"] - 0.02) < 1e-9} diff --git a/test/terminal.folk b/test/terminal.folk index 7dfa1360..85fcfd49 100644 --- a/test/terminal.folk +++ b/test/terminal.folk @@ -5,7 +5,7 @@ source builtin-programs/editor.folk assert {abs([terminalPhysicalLength 3] - 0.03) < 1e-9} assert {abs([terminalPhysicalLength 4mm] - 0.004) < 1e-9} -assert {[terminalMeterPoint {0.2 0.1}] eq {0.2m 0.1m}} +assert {[drawSpaceMeterPoint {0.2 0.1}] eq {0.2m 0.1m}} set options [terminalOptionsWithDefaults {rows 2 cols 10 padding 0.2 foreground white}] assert {[dict get $options rows] == 2} From 7b7d12633e89652d23c998ff08149205f5bafbaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Wed, 6 May 2026 19:10:48 -0400 Subject: [PATCH 12/20] build: make remote sync work from git worktrees Use git rev-parse --git-path to choose the temporary ignore file for make sync/remote instead of assuming .git is a directory. Worktrees store .git as a file, so writing .git/ignores.tmp breaks remote deployment from branches checked out in a git worktree. --- Makefile | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 68d5a937..fa8c4981 100644 --- a/Makefile +++ b/Makefile @@ -115,16 +115,17 @@ kill-folk: fi FOLK_REMOTE_NODE ?= folk-live +FOLK_SYNC_IGNORES_TMP := $(shell git rev-parse --git-path ignores.tmp 2>/dev/null || echo .git/ignores.tmp) sync: ssh $(FOLK_REMOTE_NODE) -t \ 'cd ~/folk && git init > /dev/null && git ls-files --exclude-standard -oi --directory' \ - > .git/ignores.tmp || true - git ls-files --exclude-standard -oi --directory >> .git/ignores.tmp + > $(FOLK_SYNC_IGNORES_TMP) || true + git ls-files --exclude-standard -oi --directory >> $(FOLK_SYNC_IGNORES_TMP) rsync --timeout=15 -e "ssh -o StrictHostKeyChecking=no" \ --archive --delete --itemize-changes \ --exclude='/.git' \ - --exclude-from='.git/ignores.tmp' \ + --exclude-from='$(FOLK_SYNC_IGNORES_TMP)' \ --exclude='vendor/tracy/public/TracyClient.o' \ --include='vendor/tracy/public/***' \ --exclude='vendor/tracy/*' \ From 374ae6dbf14c836b143dec95f4af51a24b2527b9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Wed, 6 May 2026 19:11:36 -0400 Subject: [PATCH 13/20] draw: move primitives into the draw program space Move the remaining drawing primitive implementations out of the legacy display/root locations and into builtin-programs/draw. This keeps arc, curve, fill, and shape drawing alongside the rest of the new draw APIs.\n\nUpdate fill drawing to target a canvas explicitly, add has-demo-code snippets for the primitive programs, and adjust the README/demo examples to use meter-scale draw-shape values. Add focused draw primitive coverage for the moved APIs. --- README.md | 2 +- builtin-programs/demos.folk | 4 +- builtin-programs/display/arc.folk | 39 --- builtin-programs/display/curve.folk | 135 ---------- builtin-programs/draw/apriltags.folk | 15 ++ builtin-programs/draw/arc.folk | 91 +++++++ builtin-programs/draw/circle.folk | 16 ++ builtin-programs/draw/curve.folk | 92 +++++++ builtin-programs/draw/dashed-line.folk | 13 + builtin-programs/draw/fill.folk | 67 ++++- builtin-programs/draw/image.folk | 14 + builtin-programs/draw/line.folk | 14 + builtin-programs/draw/shapes.folk | 341 +++++++++++++++++++++++ builtin-programs/draw/text.folk | 15 ++ builtin-programs/shapes.folk | 357 ------------------------- test/draw-primitives.folk | 45 ++++ 16 files changed, 713 insertions(+), 547 deletions(-) delete mode 100644 builtin-programs/display/arc.folk delete mode 100644 builtin-programs/display/curve.folk create mode 100644 builtin-programs/draw/arc.folk create mode 100644 builtin-programs/draw/curve.folk create mode 100644 builtin-programs/draw/shapes.folk delete mode 100644 builtin-programs/shapes.folk create mode 100644 test/draw-primitives.folk diff --git a/README.md b/README.md index 4eadf883..002e660c 100644 --- a/README.md +++ b/README.md @@ -514,7 +514,7 @@ Use it in an animation: ``` When the clock time is /t/ { - Wish $this draws a circle with offset [list [expr {sin($t) * 50}] 0] + Wish $this draws a circle with offset [list [expr {sin($t) * 0.05}] 0] radius 0.012 } ``` diff --git a/builtin-programs/demos.folk b/builtin-programs/demos.folk index 192afd23..92d787a3 100644 --- a/builtin-programs/demos.folk +++ b/builtin-programs/demos.folk @@ -10,7 +10,7 @@ Claim 45001 has demo code { Claim 45002 has demo code { When /actor/ is cool { Wish $this is labelled "$actor is pretty cool" - Wish $actor is outlined red + Wish $actor is outlined red } } Claim 45003 has demo code { @@ -24,7 +24,7 @@ Claim 45004 has demo code { } Claim 45005 has demo code { When the clock time is /t/ { - Wish $this draws a circle offset [list expr {sin($t) * 50} 0] + Wish $this draws a circle with offset [list [expr {sin($t) * 0.05}] 0] radius 0.012 } } Claim 45006 has demo code { diff --git a/builtin-programs/display/arc.folk b/builtin-programs/display/arc.folk deleted file mode 100644 index f6a0c678..00000000 --- a/builtin-programs/display/arc.folk +++ /dev/null @@ -1,39 +0,0 @@ -# Example: -# When $this has region /r/ { -# lassign [region centroid $r] x y -# Wish to draw an arc with x $x y $y start 0 arclen 1 thickness 3 radius 100 color green -# } - -Wish the GPU compiles pipeline "arc" {{vec2 center float start float arclen float radius float thickness vec4 color} { - float r = radius + thickness; - vec2 vertices[4] = vec2[4]( - center - r, - vec2(center.x + r, center.y - r), - vec2(center.x - r, center.y + r), - center + r - ); - return vec4(vertices[gl_VertexIndex], 0.0, 1.0); -} { - #define M_TWO_PI 6.283185307179586 - start = clamp(start, 0, M_TWO_PI); - arclen = clamp(arclen, 0, M_TWO_PI); - - float dist = length(gl_FragCoord.xy - center) - radius; - float angle = atan(-(gl_FragCoord.y - center.y), gl_FragCoord.x - center.x); - - // Shift angle from [-pi, pi) to [0, 2*pi] - angle = (angle < 0) ? (angle + M_TWO_PI) : angle; - float end = start + arclen; - - return ((dist < thickness && dist > 0.0) && - ((end < M_TWO_PI && angle > start && angle < end) || - (end >= M_TWO_PI && (angle > start || angle < end-M_TWO_PI)))) ? color : vec4(0, 0, 0, 0); - -}} - -When /someone/ wishes to draw an arc with /...options/ { - dict with options { - Wish the GPU draws pipeline "arc" with arguments \ - [list [list $x $y] $start $arclen $radius $thickness [getColor $color]] - } -} diff --git a/builtin-programs/display/curve.folk b/builtin-programs/display/curve.folk deleted file mode 100644 index 9082d117..00000000 --- a/builtin-programs/display/curve.folk +++ /dev/null @@ -1,135 +0,0 @@ - -# Bezier implementation from https://www.shadertoy.com/view/XdVBWd - -Wish the GPU compiles function "bboxBezier" {{vec2 p0 vec2 p1 vec2 p2 vec2 p3} vec4 { - // Exact BBox to a quadratic bezier - // extremes - vec2 mi = min(p0,p3); - vec2 ma = max(p0,p3); - - vec2 k0 = -1.0*p0 + 1.0*p1; - vec2 k1 = 1.0*p0 - 2.0*p1 + 1.0*p2; - vec2 k2 = -1.0*p0 + 3.0*p1 - 3.0*p2 + 1.0*p3; - - vec2 h = k1*k1 - k0*k2; - - if( h.x>0.0 ) - { - h.x = sqrt(h.x); - //float t = (-k1.x - h.x)/k2.x; - float t = k0.x/(-k1.x-h.x); - if( t>0.0 && t<1.0 ) - { - float s = 1.0-t; - float q = s*s*s*p0.x + 3.0*s*s*t*p1.x + 3.0*s*t*t*p2.x + t*t*t*p3.x; - mi.x = min(mi.x,q); - ma.x = max(ma.x,q); - } - //t = (-k1.x + h.x)/k2.x; - t = k0.x/(-k1.x+h.x); - if( t>0.0 && t<1.0 ) - { - float s = 1.0-t; - float q = s*s*s*p0.x + 3.0*s*s*t*p1.x + 3.0*s*t*t*p2.x + t*t*t*p3.x; - mi.x = min(mi.x,q); - ma.x = max(ma.x,q); - } - } - - if( h.y>0.0) - { - h.y = sqrt(h.y); - //float t = (-k1.y - h.y)/k2.y; - float t = k0.y/(-k1.y-h.y); - if( t>0.0 && t<1.0 ) - { - float s = 1.0-t; - float q = s*s*s*p0.y + 3.0*s*s*t*p1.y + 3.0*s*t*t*p2.y + t*t*t*p3.y; - mi.y = min(mi.y,q); - ma.y = max(ma.y,q); - } - //t = (-k1.y + h.y)/k2.y; - t = k0.y/(-k1.y+h.y); - if( t>0.0 && t<1.0 ) - { - float s = 1.0-t; - float q = s*s*s*p0.y + 3.0*s*s*t*p1.y + 3.0*s*t*t*p2.y + t*t*t*p3.y; - mi.y = min(mi.y,q); - ma.y = max(ma.y,q); - } - } - - return vec4( mi, ma ); -}} - -Wish the GPU compiles function sdSegmentSq {{vec2 p vec2 a vec2 b} float { - vec2 pa = p-a, ba = b-a; - float h = clamp( dot(pa,ba)/dot(ba,ba), 0.0, 1.0 ); - vec2 d = pa - ba*h; - return dot(d, d); -}} - -Wish the GPU compiles function udBezier {{vec2 p0 vec2 p1 vec2 p2 vec2 p3 vec2 pos} vec2 { - const int kNum = 50; - vec2 res = vec2(1e10,0.0); - vec2 a = p0; - for( int i=1; i 0.0) { + if ((end < M_TWO_PI && angle > c_start && angle < end) || + (end >= M_TWO_PI && (angle > c_start || angle < end - M_TWO_PI))) { + return color; + } + } + + return vec4(0.0); + } +} + +When the color map is /colorMap/ &\ + /p/ has canvas /id/ with /...wiOptions/ &\ + /p/ has canvas projection /surfaceToClip/ &\ + /someone/ wishes to draw an arc onto /p/ with /...options/ { + + set center [dict getdef $options center ""] + if {$center eq ""} { set center [list [dict get $options x] [dict get $options y]] } + + set radius [dict get $options radius] + set thickness [dict get $options thickness] + set start [dict get $options start] + set arclen [dict get $options arclen] + + set color [dict get $options color] + set color [dict getdef $colorMap $color $color] + set layer [dict getdef $options layer 0] + + set wiResolution [list [dict get $wiOptions width] [dict get $wiOptions height]] + + Wish the GPU draws pipeline "arc" onto canvas $id with arguments \ + [list $wiResolution $surfaceToClip \ + $center $radius $thickness $start $arclen $color] \ + layer $layer +} + +Claim $this has demo code { + When $this has resolved geometry /geom/ { + set w [dict get $geom width] + set h [dict get $geom height] + Wish to draw an arc onto $this with \ + center [list [expr {$w * 0.50}] [expr {$h * 0.52}]] \ + radius [expr {$h * 0.24}] thickness [expr {$h * 0.018}] \ + start 0.25 arclen 4.7 color hotpink layer 5 + } +} diff --git a/builtin-programs/draw/circle.folk b/builtin-programs/draw/circle.folk index a67b3e4e..97636e27 100644 --- a/builtin-programs/draw/circle.folk +++ b/builtin-programs/draw/circle.folk @@ -45,3 +45,19 @@ When the color map is /colorMap/ &\ [list $wiResolution $surfaceToClip \ $center $radius $thickness $color [expr {$filled eq false ? 0 : 1}]] } + +Claim $this has demo code { + When $this has resolved geometry /geom/ { + set w [dict get $geom width] + set h [dict get $geom height] + set r [expr {$h * 0.16}] + Wish to draw a circle onto $this with \ + center [list [expr {$w * 0.38}] [expr {$h * 0.50}]] \ + radius $r thickness [expr {$h * 0.018}] \ + color cyan filled false layer 4 + Wish to draw a circle onto $this with \ + center [list [expr {$w * 0.62}] [expr {$h * 0.50}]] \ + radius [expr {$r * 0.72}] thickness [expr {$h * 0.010}] \ + color mediumspringgreen filled true layer 5 + } +} diff --git a/builtin-programs/draw/curve.folk b/builtin-programs/draw/curve.folk new file mode 100644 index 00000000..5f1edf9f --- /dev/null +++ b/builtin-programs/draw/curve.folk @@ -0,0 +1,92 @@ +# Bezier implementation adapted from https://www.shadertoy.com/view/XdVBWd + +Wish the GPU compiles function "curveSegmentDistance" {{vec2 p vec2 a vec2 b} float { + vec2 pa = p - a; + vec2 ba = b - a; + float h = clamp(dot(pa, ba) / dot(ba, ba), 0.0, 1.0); + vec2 d = pa - ba * h; + return dot(d, d); +}} + +Wish the GPU compiles function "curveBezierDistance" {{vec2 p0 vec2 p1 vec2 p2 vec2 p3 vec2 pos fn curveSegmentDistance} float { + const int kNumSamples = 50; + float distance = 1e10; + vec2 a = p0; + for (int i = 1; i < kNumSamples; i++) { + float t = float(i) / float(kNumSamples - 1); + float s = 1.0 - t; + vec2 b = p0 * s * s * s + + p1 * 3.0 * s * s * t + + p2 * 3.0 * s * t * t + + p3 * t * t * t; + distance = min(distance, curveSegmentDistance(pos, a, b)); + a = b; + } + return sqrt(distance); +}} + +Wish the GPU compiles pipeline "curve" { + {vec2 viewport mat3 surfaceToClip + vec2 p0 vec2 p1 vec2 p2 vec2 p3 float thickness vec4 color} { + vec2 from = min(min(p0, p1), min(p2, p3)) - thickness; + vec2 to = max(max(p0, p1), max(p2, p3)) + thickness; + + vec2 vertices[6] = vec2[6]( + from, + vec2(to.x, from.y), + vec2(from.x, to.y), + vec2(to.x, from.y), + to, + vec2(from.x, to.y) + ); + + vec3 v = surfaceToClip * vec3(vertices[gl_VertexIndex], 1.0); + return vec4(v.xy / v.z, 0.0, 1.0); + } {fn curveBezierDistance} { + vec2 clipXy = (gl_FragCoord.xy / viewport) * 2.0 - 1.0; + vec3 surfaceXy = inverse(surfaceToClip) * vec3(clipXy, 1.0); + surfaceXy /= surfaceXy.z; + + float distance = curveBezierDistance(p0, p1, p2, p3, surfaceXy.xy); + float edge = max(fwidth(distance), thickness * 0.05); + float alpha = 1.0 - smoothstep(thickness, thickness + edge, distance); + + return (alpha < 0.01) ? vec4(0.0) : vec4(color.rgb, color.a * alpha); + } +} + +When the color map is /colorMap/ &\ + /p/ has canvas /id/ with /...wiOptions/ &\ + /p/ has canvas projection /surfaceToClip/ &\ + /someone/ wishes to draw a curve onto /p/ with /...options/ { + + set p0 [dict get $options p0] + set p1 [dict get $options p1] + set p2 [dict get $options p2] + set p3 [dict get $options p3] + set thickness [dict get $options thickness] + + set color [dict get $options color] + set color [dict getdef $colorMap $color $color] + set layer [dict getdef $options layer 0] + + set wiResolution [list [dict get $wiOptions width] [dict get $wiOptions height]] + + Wish the GPU draws pipeline "curve" onto canvas $id with arguments \ + [list $wiResolution $surfaceToClip \ + $p0 $p1 $p2 $p3 $thickness $color] \ + layer $layer +} + +Claim $this has demo code { + When $this has resolved geometry /geom/ { + set w [dict get $geom width] + set h [dict get $geom height] + Wish to draw a curve onto $this with \ + p0 [list [expr {$w * 0.16}] [expr {$h * 0.72}]] \ + p1 [list [expr {$w * 0.26}] [expr {$h * 0.16}]] \ + p2 [list [expr {$w * 0.74}] [expr {$h * 0.88}]] \ + p3 [list [expr {$w * 0.86}] [expr {$h * 0.30}]] \ + thickness [expr {$h * 0.015}] color lightskyblue layer 5 + } +} diff --git a/builtin-programs/draw/dashed-line.folk b/builtin-programs/draw/dashed-line.folk index c6fd2ad2..b35d25bc 100644 --- a/builtin-programs/draw/dashed-line.folk +++ b/builtin-programs/draw/dashed-line.folk @@ -61,3 +61,16 @@ When the color map is /colorMap/ &\ Wish the GPU draws pipeline "dashed-line" onto canvas $id \ with instances $instances layer $layer } + +Claim $this has demo code { + When $this has resolved geometry /geom/ { + set w [dict get $geom width] + set h [dict get $geom height] + Wish to draw a dashed line onto $this with \ + points [list \ + [list [expr {$w * 0.15}] [expr {$h * 0.32}]] \ + [list [expr {$w * 0.86}] [expr {$h * 0.70}]]] \ + width [expr {$h * 0.012}] color gold \ + dashlength [expr {$w * 0.045}] dashoffset 0 layer 4 + } +} diff --git a/builtin-programs/draw/fill.folk b/builtin-programs/draw/fill.folk index 4e977c1e..a7c0ec60 100644 --- a/builtin-programs/draw/fill.folk +++ b/builtin-programs/draw/fill.folk @@ -10,14 +10,17 @@ Wish the GPU compiles pipeline "fillTriangle" { When the color map is /colorMap/ { -When /someone/ wishes to draw a triangle with /...options/ { +When /someone/ wishes to draw a triangle onto /p/ with /...options/ &\ + /p/ has canvas /id/ with /...wiOptions/ &\ + /p/ has canvas projection /surfaceToClip/ { dict with options { if {![info exists layer]} { set layer 0 } set color [dict getdef $colorMap $color $color] - Wish the GPU draws pipeline "fillTriangle" with arguments \ - [list $p0 $p1 $p2 $color] layer $layer + Wish the GPU draws pipeline "fillTriangle" onto canvas $id with arguments \ + [list $surfaceToClip $p0 $p1 $p2 $color] layer $layer } } + When /someone/ wishes to draw a quad onto /p/ with /...options/ &\ /p/ has canvas /id/ with /...wiOptions/ &\ /p/ has canvas projection /surfaceToClip/ { @@ -30,7 +33,11 @@ When /someone/ wishes to draw a quad onto /p/ with /...options/ &\ [list $surfaceToClip $p0 $p1 $p3 $color] layer $layer } } -When /someone/ wishes to draw a polygon with /...options/ { + +When /someone/ wishes to draw a polygon onto /p/ with /...options/ &\ + /p/ has canvas /id/ with /...wiOptions/ &\ + /p/ has canvas projection /surfaceToClip/ { + set points [dict get $options points] set color [dict get $options color] set layer [dict getdef $options layer 0] @@ -39,31 +46,65 @@ When /someone/ wishes to draw a polygon with /...options/ { if {$num_points < 3} { error "At least 3 points are required to form a polygon." } elseif {$num_points == 3} { - Wish to draw a triangle with \ + Wish to draw a triangle onto $p with \ p0 [lindex $points 0] p1 [lindex $points 1] p2 [lindex $points 2] \ color $color layer $layer } elseif {$num_points == 4} { - Wish to draw a quad with \ + Wish to draw a quad onto $p with \ p0 [lindex $points 0] p1 [lindex $points 1] p2 [lindex $points 2] p3 [lindex $points 3] \ color $color layer $layer } else { # Get the first point in the list as the "base" point of the triangles set p0 [lindex $points 0] - set color [dict getdef $colorMap $color $color] + + # Batch the fanned-out triangles into a single GPU instance list + set instances [list] for {set i 1} {$i < $num_points - 1} {incr i} { set p1 [lindex $points $i] set p2 [lindex $points [expr {$i+1}]] - Wish the GPU draws pipeline "fillTriangle" with arguments \ - [list $p0 $p1 $p2 $color] layer $layer + lappend instances [list $surfaceToClip $p0 $p1 $p2 $color] } + Wish the GPU draws pipeline "fillTriangle" onto canvas $id \ + with instances $instances layer $layer + } +} + +When /someone/ wishes /page/ is filled with /...options/ &\ + /page/ has resolved geometry /geom/ { + dict with geom { + set points [list [list 0 0] \ + [list $width 0] \ + [list $width $height] \ + [list 0 $height]] } + Wish to draw a polygon onto $page with points $points {*}$options } } -When /someone/ wishes /page/ is filled with /...options/ &\ - /page/ has region /region/ { - set points [region vertices $region] - Wish to draw a polygon with points $points {*}$options +Claim $this has demo code { + When $this has resolved geometry /geom/ { + set w [dict get $geom width] + set h [dict get $geom height] + Wish to draw a triangle onto $this with \ + p0 [list [expr {$w * 0.18}] [expr {$h * 0.72}]] \ + p1 [list [expr {$w * 0.32}] [expr {$h * 0.28}]] \ + p2 [list [expr {$w * 0.48}] [expr {$h * 0.72}]] \ + color magenta layer 4 + Wish to draw a quad onto $this with \ + p0 [list [expr {$w * 0.55}] [expr {$h * 0.32}]] \ + p1 [list [expr {$w * 0.84}] [expr {$h * 0.26}]] \ + p2 [list [expr {$w * 0.78}] [expr {$h * 0.70}]] \ + p3 [list [expr {$w * 0.50}] [expr {$h * 0.62}]] \ + color orange layer 4 + Wish to draw a polygon onto $this with \ + points [list \ + [list [expr {$w * 0.22}] [expr {$h * 0.18}]] \ + [list [expr {$w * 0.36}] [expr {$h * 0.12}]] \ + [list [expr {$w * 0.50}] [expr {$h * 0.18}]] \ + [list [expr {$w * 0.45}] [expr {$h * 0.32}]] \ + [list [expr {$w * 0.28}] [expr {$h * 0.32}]]] \ + color greenyellow layer 5 + } } diff --git a/builtin-programs/draw/image.folk b/builtin-programs/draw/image.folk index c159c006..6f932b60 100644 --- a/builtin-programs/draw/image.folk +++ b/builtin-programs/draw/image.folk @@ -183,3 +183,17 @@ When the image library is /imageLib/ &\ When /someone/ wishes /p/ displays image /im/ { Wish $p displays image $im with scale 1.0 } + +Claim $this has demo code { + When the print library is /printLib/ &\ + $this has resolved geometry /geom/ { + set w [dict get $geom width] + set h [dict get $geom height] + Wish to draw an image onto $this with \ + image [$printLib tagImageForId 45009] \ + position [list [expr {$w * 0.50}] [expr {$h * 0.46}]] \ + anchor center \ + width [expr {$h * 0.36}] height [expr {$h * 0.36}] \ + layer 6 + } +} diff --git a/builtin-programs/draw/line.folk b/builtin-programs/draw/line.folk index 96215309..5d190f3e 100644 --- a/builtin-programs/draw/line.folk +++ b/builtin-programs/draw/line.folk @@ -53,3 +53,17 @@ When the color map is /colorMap/ &\ Wish the GPU draws pipeline "line" onto canvas $id \ with instances $instances layer $layer } + +Claim $this has demo code { + When $this has resolved geometry /geom/ { + set w [dict get $geom width] + set h [dict get $geom height] + Wish to draw a line onto $this with \ + points [list \ + [list [expr {$w * 0.16}] [expr {$h * 0.70}]] \ + [list [expr {$w * 0.40}] [expr {$h * 0.35}]] \ + [list [expr {$w * 0.68}] [expr {$h * 0.62}]] \ + [list [expr {$w * 0.86}] [expr {$h * 0.28}]]] \ + width [expr {$h * 0.012}] color deepskyblue layer 4 + } +} diff --git a/builtin-programs/draw/shapes.folk b/builtin-programs/draw/shapes.folk new file mode 100644 index 00000000..17a775aa --- /dev/null +++ b/builtin-programs/draw/shapes.folk @@ -0,0 +1,341 @@ +set drawShapeSides [dict create \ + triangle 3 square 4 pentagon 5 hexagon 6 septagon 7 octagon 8 nonagon 9] + +fn drawShapeTruthy {value} { + expr {$value in {1 true yes on}} +} + +fn drawShapeCanonical {shape options} { + if {[dict exists $options type]} { + set shape [dict get $options type] + } + if {[dict exists $options shape]} { + set shape [dict get $options shape] + } + switch -- $shape { + rectangle - box { return rect } + default { return $shape } + } +} + +fn drawShapeScalar {value extent} { + if {[string match *% $value]} { + set pct [string range $value 0 end-1] + return [expr {double($pct) / 100.0 * $extent}] + } + return $value +} + +fn drawShapePageCenter {geom} { + list [expr {[dict get $geom width] / 2.0}] \ + [expr {[dict get $geom height] / 2.0}] +} + +fn drawShapePoint {point geom} { + if {$point eq "" || $point eq "center"} { + return [drawShapePageCenter $geom] + } + if {[llength $point] != 2} { + error "draw/shapes: expected a 2D point, got $point" + } + list [drawShapeScalar [lindex $point 0] [dict get $geom width]] \ + [drawShapeScalar [lindex $point 1] [dict get $geom height]] +} + +fn drawShapeOffset {offset geom} { + if {$offset eq "" || $offset eq "center"} { + return {0 0} + } + + set width [dict get $geom width] + set height [dict get $geom height] + + if {[llength $offset] == 1} { + set token [lindex $offset 0] + switch -- $token { + right { return [list [expr {$width / 2.0}] 0] } + left { return [list [expr {-$width / 2.0}] 0] } + down { return [list 0 [expr {$height / 2.0}]] } + up { return [list 0 [expr {-$height / 2.0}]] } + default { + return [list [drawShapeScalar $token $width] 0] + } + } + } + + if {[llength $offset] == 2} { + set dir [lindex $offset 0] + set amount [lindex $offset 1] + switch -- $dir { + right { return [list [drawShapeScalar $amount $width] 0] } + left { + set value [drawShapeScalar $amount $width] + return [list [expr {-$value}] 0] + } + down { return [list 0 [drawShapeScalar $amount $height]] } + up { + set value [drawShapeScalar $amount $height] + return [list 0 [expr {-$value}]] + } + default { + return [list [drawShapeScalar $dir $width] \ + [drawShapeScalar $amount $height]] + } + } + } + + error "draw/shapes: expected offset like {x y} or {right 50%}, got $offset" +} + +fn drawShapePosition {options geom} { + if {[dict exists $options position]} { + return [drawShapePoint [dict get $options position] $geom] + } + if {[dict exists $options center]} { + return [drawShapePoint [dict get $options center] $geom] + } + if {[dict exists $options x] || [dict exists $options y]} { + set x [drawShapeScalar [dict getdef $options x 50%] [dict get $geom width]] + set y [drawShapeScalar [dict getdef $options y 50%] [dict get $geom height]] + return [list $x $y] + } + + set pos [drawShapePageCenter $geom] + if {[dict exists $options offset]} { + set pos [vec2 add $pos [drawShapeOffset [dict get $options offset] $geom]] + } + return $pos +} + +fn drawShapeRadians {options} { + dict getdef $options radians [dict getdef $options angle 0] +} + +fn drawShapeRadius {options default} { + if {[dict exists $options diameter]} { + return [expr {[dict get $options diameter] / 2.0}] + } + dict getdef $options radius $default +} + +fn drawShapeRegularPolygon {center radius sides radians} { + lassign $center cx cy + set points [list] + for {set i 0} {$i < $sides} {incr i} { + set theta [expr {$radians + $i * 2.0 * 3.141592653589793 / $sides - 1.5707963267948966}] + lappend points [list [expr {$cx + $radius * cos($theta)}] \ + [expr {$cy + $radius * sin($theta)}]] + } + return $points +} + +fn drawShapeRectPoints {center width height radians} { + set hw [expr {$width / 2.0}] + set hh [expr {$height / 2.0}] + set points [list \ + [list [expr {-$hw}] [expr {-$hh}]] \ + [list $hw [expr {-$hh}]] \ + [list $hw $hh] \ + [list [expr {-$hw}] $hh]] + lmap point $points { + vec2 add $center [vec2 rotate $point $radians] + } +} + +fn drawShapePathPoints {points geom options} { + set radians [drawShapeRadians $options] + set origin [dict getdef $options origin center] + set absolute [expr {$origin in {absolute local topleft top-left}}] + if {$absolute} { + set base {0 0} + } else { + set base [drawShapePosition $options $geom] + } + + set transformed [list] + foreach point $points { + if {$absolute} { + set point [drawShapePoint $point $geom] + } else { + set point [drawShapeOffset $point $geom] + } + lappend transformed [vec2 add $base [vec2 rotate $point $radians]] + } + return $transformed +} + +fn process_offset {offset regionOrGeom} { + if {[catch { + dict create width [dict get $regionOrGeom width] height [dict get $regionOrGeom height] + } geom]} { + set geom [dict create width [region width $regionOrGeom] height [region height $regionOrGeom]] + } + drawShapeOffset $offset $geom +} + +When /someone/ wishes /p/ draws a /shape/ with /...options/ &\ + /p/ has resolved geometry /geom/ { + set shape [drawShapeCanonical $shape $options] + set center [drawShapePosition $options $geom] + set color [dict getdef $options color white] + set filled [drawShapeTruthy [dict getdef $options filled false]] + set thickness [dict getdef $options thickness 0.002] + set layer [dict getdef $options layer 1] + set radians [drawShapeRadians $options] + + if {$shape eq "circle"} { + set radius [drawShapeRadius $options 0.02] + Wish to draw a circle onto $p with \ + center $center radius $radius thickness $thickness \ + color $color filled $filled layer $layer + return + } + + if {$shape eq "rect"} { + set radius [drawShapeRadius $options 0.02] + set size [dict getdef $options size [expr {$radius * 2.0}]] + set rectWidth [dict getdef $options width $size] + set rectHeight [dict getdef $options height [dict getdef $options width $size]] + set points [drawShapeRectPoints $center $rectWidth $rectHeight $radians] + } else { + if {[dict exists $options sides]} { + set sides [dict get $options sides] + } elseif {[dict exists $drawShapeSides $shape]} { + set sides [dict get $drawShapeSides $shape] + } else { + error "draw/shapes: unknown shape $shape" + } + set radius [drawShapeRadius $options 0.02] + set points [drawShapeRegularPolygon $center $radius $sides $radians] + } + + if {$filled} { + Wish to draw a polygon onto $p with points $points color $color layer $layer + } else { + lappend points [lindex $points 0] + Wish to draw a line onto $p with \ + points $points width $thickness color $color layer $layer + } +} + +When /someone/ wishes /p/ draws a /shape/ { + Wish $p draws a $shape with color white filled true +} + +When /someone/ wishes /p/ draws an /shape/ { + Wish $p draws a $shape +} + +When /someone/ wishes /p/ draws an /shape/ with /...options/ { + Wish $p draws a $shape with {*}$options +} + +When /someone/ wishes /p/ draws a rect with width /width/ height /height/ { + Wish $p draws a rect with width $width height $height +} + +When /someone/ wishes /p/ draws a /shape/ with radius /radius/ { + Wish $p draws a $shape with radius $radius +} + +When /someone/ wishes /p/ draws text /text/ with /...options/ &\ + /p/ has resolved geometry /geom/ { + set position [drawShapePosition $options $geom] + set color [dict getdef $options color white] + set scale [dict getdef $options scale 0.01] + set layer [dict getdef $options layer 0] + set anchor [dict getdef $options anchor center] + set font [dict getdef $options font "PTSans-Regular"] + set radians [drawShapeRadians $options] + + Wish to draw text onto $p with \ + position $position scale $scale text $text \ + color $color radians $radians anchor $anchor font $font layer $layer +} + +When /someone/ wishes /p/ draws text /text/ { + Wish $p draws text $text with color white +} + +When /someone/ wishes /p/ draws a polyline /points/ with /...options/ &\ + /p/ has resolved geometry /geom/ { + set points [drawShapePathPoints $points $geom $options] + set color [dict getdef $options color white] + set width [dict getdef $options width [dict getdef $options thickness 0.002]] + set layer [dict getdef $options layer 1] + set dashed [drawShapeTruthy [dict getdef $options dashed false]] + + if {$dashed} { + set dashlength [dict getdef $options dashlength 0.01] + set dashoffset [dict getdef $options dashoffset 0] + Wish to draw a dashed line onto $p with \ + points $points width $width color $color \ + dashlength $dashlength dashoffset $dashoffset layer $layer + } else { + Wish to draw a line onto $p with \ + points $points width $width color $color layer $layer + } +} + +When /someone/ wishes /p/ draws points /points/ with /...options/ &\ + /p/ has resolved geometry /geom/ { + set points [drawShapePathPoints $points $geom $options] + set radius [drawShapeRadius $options 0.003] + set thickness [dict getdef $options thickness 0.001] + set color [dict getdef $options color white] + set filled [drawShapeTruthy [dict getdef $options filled true]] + set layer [dict getdef $options layer 1] + + foreach point $points { + Wish to draw a circle onto $p with \ + center $point radius $radius thickness $thickness \ + color $color filled $filled layer $layer + } +} + +When /someone/ wishes /p/ draws a set of points /points/ with /...options/ { + Wish $p draws points $points with {*}$options +} + +Claim $this has demo code { + Wish $this draws a circle with radius 0.018 color white filled true + + set baseX -0.055 + set baseY -0.035 + set dx 0.037 + set dy 0.03 + + Wish $this draws text "triangle" with color skyblue offset [list $baseX [expr {$baseY - 0.018}]] scale 0.004 + Wish $this draws text "square" with color green offset [list [expr {$baseX + $dx}] [expr {$baseY - 0.018}]] scale 0.004 + Wish $this draws text "pentagon" with color gold offset [list [expr {$baseX + $dx * 2}] [expr {$baseY - 0.018}]] scale 0.004 + Wish $this draws text "rect" with color cyan offset [list [expr {$baseX + $dx * 3}] [expr {$baseY - 0.018}]] scale 0.004 + + Wish $this draws a triangle with color skyblue radius 0.012 thickness 0.001 offset [list $baseX $baseY] + Wish $this draws a square with color green radius 0.012 thickness 0.0015 radians 0.785398 offset [list [expr {$baseX + $dx}] $baseY] + Wish $this draws a pentagon with color gold radius 0.012 filled true offset [list [expr {$baseX + $dx * 2}] $baseY] + Wish $this draws a rect with width 0.026 height 0.014 color cyan radians 0.4 offset [list [expr {$baseX + $dx * 3}] $baseY] + + Wish $this draws a polyline [list {-0.055 0.01} {-0.035 0.025} {-0.015 0.008} {0.005 0.025}] \ + with color magenta width 0.0015 + Wish $this draws a polyline [list {0.02 0.012} {0.04 0.025} {0.06 0.012}] \ + with color orange width 0.001 dashed true dashlength 0.006 + Wish $this draws a set of points [list {-0.052 0.045} {-0.038 0.047} {-0.024 0.043} {-0.010 0.047}] \ + with color palegoldenrod radius 0.0025 + + When $this has resolved geometry /geom/ & the clock time is /t/ { + set x [expr {sin($t) * 0.028}] + set y [expr {cos($t * 1.5) * 0.018}] + Wish $this draws a circle with \ + radius 0.004 color palegoldenrod filled true offset [list $x $y] layer 4 + } + + When $this has resolved geometry /geom/ & the clock time is /t/ { + set filled [expr {round($t * 2) % 2 == 0}] + Wish $this draws a square with \ + radius 0.014 color white filled $filled offset {0.05 0.045} + Wish $this draws text $filled with \ + offset {0.05 0.045} scale 0.005 color red layer 5 + } + + Wish $this is outlined white +} diff --git a/builtin-programs/draw/text.folk b/builtin-programs/draw/text.folk index f9dfcf63..eb1e04f8 100644 --- a/builtin-programs/draw/text.folk +++ b/builtin-programs/draw/text.folk @@ -320,3 +320,18 @@ When the color map is /colorMap/ &\ } } + +Claim $this has demo code { + When $this has resolved geometry /geom/ { + set w [dict get $geom width] + set h [dict get $geom height] + Wish to draw text onto $this with \ + position [list [expr {$w * 0.50}] [expr {$h * 0.44}]] \ + scale [expr {$h * 0.085}] text "draw/text" \ + color white anchor center layer 8 + Wish to draw text onto $this with \ + position [list [expr {$w * 0.50}] [expr {$h * 0.62}]] \ + scale [expr {$h * 0.050}] text "anchor center" \ + color lavender anchor center layer 8 + } +} diff --git a/builtin-programs/shapes.folk b/builtin-programs/shapes.folk deleted file mode 100644 index c67c7e43..00000000 --- a/builtin-programs/shapes.folk +++ /dev/null @@ -1,357 +0,0 @@ -set shapes [dict create triangle 3 square 4 pentagon 5 hexagon 6 septagon 7 octagon 8 nonagon 9] - -proc process_offset {offset region} { - if {![info exists region]} { - return $offset - } - - set w [region width $region] - set h [region height $region] - - if {[llength $offset] == 2 && - ![string match *%* $offset] && - ![string is alpha -strict [lindex $offset 0]]} { - return $offset - } - - # Handle simple percentage string: "50%" - if {[string match *%* $offset] && [llength $offset] == 1} { - set pct [expr {[string map {% ""} $offset] / 100.0}] - return [list [expr {$w * $pct}] 0] # Default to horizontal offset - } - - # Handle directional strings: "right", "left", "up", "down" - if {$offset eq "right"} { - return [list [expr {$w * 0.5}] 0] - } elseif {$offset eq "left"} { - return [list [expr {-$w * 0.5}] 0] - } elseif {$offset eq "up"} { - return [list 0 [expr {-$h * 0.5}]] - } elseif {$offset eq "down"} { - return [list 0 [expr {$h * 0.5}]] - } - - # Handle directional percentage: "right 50%", "left 25%", etc. - if {[llength $offset] == 2 && [string is alpha -strict [lindex $offset 0]]} { - set direction [lindex $offset 0] - set amount [lindex $offset 1] - - if {[string match *%* $amount]} { - set pct [expr {[string map {% ""} $amount] / 100.0}] - - switch $direction { - "right" { return [list [expr {$w * $pct}] 0] } - "left" { return [list [expr {-$w * $pct}] 0] } - "up" { return [list 0 [expr {-$h * $pct}]] } - "down" { return [list 0 [expr {$h * $pct}]] } - default { return [list 0 0] } - } - } - } - - # Handle x y vector where one or both components have percentage notation - if {[llength $offset] == 2} { - lassign $offset ox oy - - if {[string match *%* $ox]} { - set pct [expr {[string map {% ""} $ox] / 100.0}] - set ox [expr {$w * $pct}] - } - - if {[string match *%* $oy]} { - set pct [expr {[string map {% ""} $oy] / 100.0}] - set oy [expr {$h * $pct}] - } - - return [list $ox $oy] - } - - # Default fallback - return $offset -} - -When /someone/ wishes to draw a shape with /...options/ { - set isRect 0 - if {[dict exists $options type] && [dict get $options type] eq "rect"} { - set isRect 1 - } - - set c [dict_getdef $options center {0 0}] - - set color [dict_getdef $options color white] - set filled [dict_getdef $options filled false] - set thickness [dict_getdef $options thickness 1] - set layer [dict_getdef $options layer 0] - set angle [dict_getdef $options angle 0] - - if {$isRect} { - set w [dict_getdef $options width 100] - set h [dict_getdef $options height 100] - - set hw [expr {$w / 2.0}] - set hh [expr {$h / 2.0}] - - set points [lmap v [list \ - [list [expr {-$hw}] [expr {-$hh}]] \ - [list [expr {$hw}] [expr {-$hh}]] \ - [list [expr {$hw}] [expr {$hh}]] \ - [list [expr {-$hw}] [expr {$hh}]] \ - [list [expr {-$hw}] [expr {-$hh}]] \ - ] { - vec2 add [vec2 rotate $v $angle] $c - }] - } else { - set numPoints [dict_getdef $options sides 4] - if {[dict exists $options shape] && [dict exists $shapes [dict get $options shape]]} { - set numPoints [dict get $shapes [dict get $options shape]] - } - set r [dict_getdef $options radius 50] - - set points {{0 0}} - set centerPoint {0 0} - set polyAngle [expr {2 * 3.14159 / $numPoints + 3.14159}] - set angleIncr [expr {2 * 3.14159 / $numPoints}] - - for {set i 0} {$i < $numPoints} {incr i} { - set p [vec2 add [lindex $points end] [vec2 scale [list [expr {cos($polyAngle)}] [expr {sin($polyAngle)}]] $r]] - lappend points $p - set centerPoint [vec2 add $centerPoint $p] - set polyAngle [expr {$polyAngle + $angleIncr}] - } - - set points [lmap v $points { - vec2 add [vec2 rotate [vec2 sub $v [vec2 scale $centerPoint [expr {1.0/$numPoints}]]] $angle] $c - }] - } - - if {$filled} { - Wish to draw a polygon with points $points color $color layer $layer - } else { - Wish to draw a stroke with points $points width $thickness color $color layer $layer - } -} - -When /someone/ wishes /p/ draws a /shape/ { - Wish $p draws a $shape with color white -} - -# Handle "a" vs "an" grammar variations -When /someone/ wishes /p/ draws an /shape/ { - Wish $p draws a $shape -} - -When /someone/ wishes /p/ draws text /text/ with /...options/ & /p/ has region /r/ { - # As shapes.folk but for text. - lassign [region centroid $r] cx cy - set pageAngle [region angle $r] - - # Use the page's angle unless explicitly overwritten - set defaults [dict create \ - color white \ - scale 1.0 \ - layer 0 \ - angle $pageAngle \ - anchor center \ - font "PTSans-Regular" - ] - - set options [dict merge $defaults $options] - - set color [dict get $options color] - set scale [dict get $options scale] - set layer [dict get $options layer] - set angle [dict get $options angle] - set anchor [dict get $options anchor] - set font [dict get $options font] - - set offset [dict_getdef $options offset {0 0}] - set offset [::process_offset $offset $r] - set center [vec2 add [list $cx $cy] [vec2 rotate $offset $pageAngle]] - - Wish to draw text with position $center scale $scale text $text\ - color $color radians $angle anchor $anchor font $font -} - -When /someone/ wishes /p/ draws text /text/ { - Wish $p draws text $text with color white -} - -When /someone/ wishes /p/ draws a /shape/ with /...options/ & /p/ has region /r/ { - lassign [region centroid $r] cx cy - set angle [region angle $r] - - set color [dict_getdef $options color white] - set filled [dict_getdef $options filled false] - set thickness [dict_getdef $options thickness 5] - set layer [dict_getdef $options layer 0] - - set offset [dict_getdef $options offset {0 0}] - set offset [process_offset $offset $r] - - set center [vec2 add [list $cx $cy] [vec2 rotate $offset $angle]] - - if {$shape eq "circle"} { - set radius [dict_getdef $options radius 50] - - Wish to draw a circle with center $center radius $radius thickness $thickness \ - color $color filled $filled layer $layer - - } elseif {$shape eq "rect"} { - set w [dict_getdef $options width [region width $r]] - set h [dict_getdef $options height [region height $r]] - - Wish to draw a shape with type rect center $center width $w height $h angle $angle \ - color $color filled $filled thickness $thickness layer $layer - - } elseif {[dict exists $shapes $shape]} { - set radius [dict_getdef $options radius 50] - - Wish to draw a shape with sides [dict get $shapes $shape] center $center radius $radius \ - angle $angle color $color filled $filled thickness $thickness layer $layer - - } else { - set radius [dict_getdef $options radius 50] - - Wish to draw a shape with sides 4 center $center radius $radius \ - angle $angle color $color filled $filled thickness $thickness layer $layer - } -} - -# Pass through options for "an" version -When /someone/ wishes /p/ draws an /shape/ with /...options/ { - Wish $p draws a $shape with {*}$options -} - -When /someone/ wishes /p/ draws a rect with width /w/ height /h/ { - Wish $p draws a rect with width $w height $h -} - -When /someone/ wishes /p/ draws a /shape/ with radius /rad/ { - Wish $p draws a $shape with radius $rad -} - -When /someone/ wishes /page/ draws a set of points /points/ with /...options/ & /page/ has region /r/ { - set radius [dict_getdef $options radius 5] - set color [dict_getdef $options color white] - set filled [dict_getdef $options filled true] - set thickness [dict_getdef $options thickness 2] - set layer [dict_getdef $options layer 0] - - lassign [region centroid $r] cx cy - set angle [region angle $r] - set center [list $cx $cy] - - if {[dict exists $options offset]} { - set offset [dict get $options offset] - set offset [process_offset $offset $r] - set center [vec2 add $center [vec2 rotate $offset $angle]] - } - - foreach point $points { - set pointPos [vec2 add $center [vec2 rotate $point $angle]] - - Wish to draw a circle with center $pointPos radius $radius thickness $thickness \ - color $color filled $filled layer $layer - } -} - -When /someone/ wishes /page/ draws a polyline /points/ with /...options/ & /page/ has region /r/ { - set color [dict_getdef $options color white] - set thickness [dict_getdef $options thickness 2] - set layer [dict_getdef $options layer 0] - set dashed [dict_getdef $options dashed false] - set dashlength [dict_getdef $options dashlength 20] - set dashoffset [dict_getdef $options dashoffset 0] - - lassign [region centroid $r] cx cy - set angle [region angle $r] - set center [list $cx $cy] - - if {[dict exists $options offset]} { - set offset [dict get $options offset] - set offset [process_offset $offset $r] - set center [vec2 add $center [vec2 rotate $offset $angle]] - } - - set transformedPoints {} - foreach point $points { - lappend transformedPoints [vec2 add $center [vec2 rotate $point $angle]] - } - - if {$dashed} { - Wish to draw a dashed stroke with points $transformedPoints color $color width $thickness \ - dashlength $dashlength dashoffset $dashoffset layer $layer - } else { - Wish to draw a stroke with points $transformedPoints color $color width $thickness layer $layer - } -} - -Claim $this has demo { - # Center circle - Wish $this draws a circle - - # Grid of shapes with varying thickness - set baseX -850 - set baseY -200 - set gridSpacing 130 - - # Row 0: Title - Wish $this draws text "triangle" with color skyblue offset [list $baseX [expr {$baseY - ($gridSpacing / 2.0)}]] scale 0.9 - Wish $this draws text "square" with color green offset [list [expr {$baseX + $gridSpacing}] [expr {$baseY - ($gridSpacing / 2.0)}]] scale 0.9 - Wish $this draws text "pentagon" with color gold offset [list [expr {$baseX + $gridSpacing*2}] [expr {$baseY - ($gridSpacing / 2.0)}]] scale 0.9 - Wish $this draws text "hexagon" with color orange offset [list [expr {$baseX + $gridSpacing*3}] [expr {$baseY - ($gridSpacing / 2.0)}]] scale 0.9 - - # Row 1: Regular polygons with different colors and thickness - Wish $this draws a triangle with color skyblue thickness 2 offset [list $baseX [expr {$baseY}]] - Wish $this draws a square with color green thickness 4 offset [list [expr {$baseX + $gridSpacing}] [expr {$baseY}]] - Wish $this draws a pentagon with color gold thickness 6 offset [list [expr {$baseX + $gridSpacing*2}] [expr {$baseY}]] - Wish $this draws a hexagon with color orange thickness 8 offset [list [expr {$baseX + $gridSpacing*3}] [expr {$baseY}]] - - # Row 2: Filled shapes - Wish $this draws a triangle with color skyblue filled true offset [list $baseX [expr {$baseY + $gridSpacing}]] - Wish $this draws a square with color green filled true offset [list [expr {$baseX + $gridSpacing}] [expr {$baseY + $gridSpacing}]] - Wish $this draws a pentagon with color gold filled true offset [list [expr {$baseX + $gridSpacing*2}] [expr {$baseY + $gridSpacing}]] - Wish $this draws a hexagon with color orange filled true offset [list [expr {$baseX + $gridSpacing*3}] [expr {$baseY + $gridSpacing}]] - - # Row 3: Directional offset examples (replacing shift) - Wish $this draws a triangle with radius 40 offset "right 50%" color skyblue - Wish $this draws a square with radius 40 offset "left 50%" color green - Wish $this draws a pentagon with radius 40 offset "up 50%" color gold - Wish $this draws a hexagon with radius 40 offset "down 50%" color orange - - # Row 4: Rectangles with different properties - Wish $this draws a rect with width 80 height 50 color cyan thickness 3 offset [list $baseX [expr {$baseY + $gridSpacing*3}]] - Wish $this draws a rect with width 80 height 50 color magenta filled true offset [list [expr {$baseX + $gridSpacing}] [expr {$baseY + $gridSpacing*3}]] - Wish $this draws a rect with width 80 height 50 offset "right 50%" - Wish $this draws a rect with width 80 height 50 offset "left 50%" - -# Animated elements - When $this has region /r/ & the clock time is /t/ { - lassign [region angle $r] angle - for {set i 0} {$i < 8} {incr i} { - set offsetVector [list [sin [+ [- $i $t] $angle]] [* 2 [cos [+ [- $i $t] $angle]]]] - set vector [::vec2::scale $offsetVector [+ [* $i $i] 15]] - Wish $this draws a circle with radius $i color palegoldenrod offset $vector - } - } - - When $this has region /r/ & the clock time is /t/ { - lassign [region centroid $r] x y - set fillVal [expr {round(sin($t) * 2)}] - set fill [expr {$fillVal % 2 == 0}] - set y [- $y 150] - Wish to draw a shape with sides 4 center [list [- $x 200] $y] radius 60 color white filled $fill - Wish to draw text with position [list [- $x 200] [+ $y 14]] scale 1.5 text "$fillVal" color red - } - - When $this has region /r/ & the clock time is /t/ { - lassign [region centroid $r] x y - set fillVal [expr {round($t * 2)}] - set fill [expr {$fillVal % 2 == 0}] - set y [- $y 150] - Wish to draw a shape with sides 4 center [list [+ $x 200] $y] radius 60 color white filled $fill - Wish to draw text with position [list [+ $x 200] [+ $y 14]] scale 1.5 text "$fill" color red - } - - Wish $this is outlined white -} diff --git a/test/draw-primitives.folk b/test/draw-primitives.folk new file mode 100644 index 00000000..5d407781 --- /dev/null +++ b/test/draw-primitives.folk @@ -0,0 +1,45 @@ +source builtin-programs/collect.folk +source builtin-programs/draw/color-map.folk +source builtin-programs/draw/fill.folk +source builtin-programs/draw/shapes.folk +source builtin-programs/draw/arc.folk +source builtin-programs/draw/curve.folk + +set geom {width 0.2 height 0.1} + +set pos [drawShapePosition {offset {right 25%}} $geom] +assert {abs([lindex $pos 0] - 0.15) < 1e-9} +assert {abs([lindex $pos 1] - 0.05) < 1e-9} + +set rectPoints [drawShapeRectPoints {0.1 0.05} 0.04 0.02 0] +lassign [lindex $rectPoints 0] x y +assert {abs($x - 0.08) < 1e-9} +assert {abs($y - 0.04) < 1e-9} +lassign [lindex $rectPoints 2] x y +assert {abs($x - 0.12) < 1e-9} +assert {abs($y - 0.06) < 1e-9} + +set shapePage shape-page +Assert! $shapePage has resolved geometry $geom +Wish $shapePage draws a rectangle with width 0.04 height 0.02 color cyan filled true + +set fillPage fill-page +Assert! $fillPage has resolved geometry {width 0.3 height 0.15} +Wish $fillPage is filled with color black layer 7 + +sleep 1 + +set shapeDraws [Query! /someone/ wishes to draw a polygon onto $shapePage with /...drawOptions/] +assert {[llength $shapeDraws] == 1} +set drawOptions [dict get [lindex $shapeDraws 0] drawOptions] +assert {[dict get $drawOptions color] eq "cyan"} +assert {[dict get $drawOptions points] eq $rectPoints} + +set fillDraws [Query! /someone/ wishes to draw a polygon onto $fillPage with /...drawOptions/] +assert {[llength $fillDraws] == 1} +set drawOptions [dict get [lindex $fillDraws 0] drawOptions] +assert {[dict get $drawOptions color] eq "black"} +assert {[dict get $drawOptions layer] == 7} +assert {[dict get $drawOptions points] eq {{0 0} {0.3 0} {0.3 0.15} {0 0.15}}} + +Exit! 0 From 0d02c569c430f59600a92df49dd06ff5db0ce82b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Wed, 6 May 2026 19:12:10 -0400 Subject: [PATCH 14/20] draw: add demo runner and title source margins Add a draw-space library with vector, quad, projection, and display-length helpers for building display-space drawing demos from a page quad. Move the drawing primitives booklet entry into builtin-programs/draw/space.folk and make Wish runs demo code from evaluate that program's has-demo-code claim.\n\nTeach title.folk to pass drawing options through for titled, footnoted, left-margined, and right-margined text. Styled variants can now choose font, color, scale, anchor, and padding, while plain no-options wishes normalize through the same rendering path. Add demo coverage for the composite drawing demo, per-program demo execution, source-code left margins, and styled title/margin examples. --- builtin-programs/draw/space.folk | 316 +++++++++++++++++++++++++++++++ builtin-programs/title.folk | 92 +++++++-- test/drawing-demo.folk | 299 +++++++++++++++++++++++++++++ 3 files changed, 693 insertions(+), 14 deletions(-) create mode 100644 builtin-programs/draw/space.folk create mode 100644 test/drawing-demo.folk diff --git a/builtin-programs/draw/space.folk b/builtin-programs/draw/space.folk new file mode 100644 index 00000000..750762f9 --- /dev/null +++ b/builtin-programs/draw/space.folk @@ -0,0 +1,316 @@ +set drawSpaceLib [library create drawSpaceLib { + proc vectorAdd {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av + $bv}] + } + return $out + } + + proc vectorSub {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av - $bv}] + } + return $out + } + + proc vectorScale {v s} { + lmap x $v { + expr {$x * $s} + } + } + + proc vectorDistance {a b} { + set sum 0.0 + foreach av $a bv $b { + set d [expr {$av - $bv}] + set sum [expr {$sum + $d * $d}] + } + expr {sqrt($sum)} + } + + proc vectorUnit {v} { + set zero [lmap _ $v { expr {0.0} }] + set n [vectorDistance $v $zero] + if {$n == 0.0} { return $zero } + vectorScale $v [expr {1.0 / $n}] + } + + proc vectorAverage {points} { + set first [lindex $points 0] + set sum [lmap _ $first { expr {0.0} }] + foreach point $points { + set sum [vectorAdd $sum $point] + } + vectorScale $sum [expr {1.0 / [llength $points]}] + } + + proc vectorMidpoint {a b} { + vectorScale [vectorAdd $a $b] 0.5 + } + + proc quadBasis {quadLib quad} { + lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + dict create \ + origin [vectorAverage [list $topLeft $topRight $bottomRight $bottomLeft]] \ + xAxis [vectorUnit [vectorSub $topRight $topLeft]] \ + yAxis [vectorUnit [vectorSub $bottomLeft $topLeft]] + } + + proc quadPoint {quadLib quad selector} { + lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + + switch -- [string tolower $selector] { + centroid - center { + return [vectorAverage [list $topLeft $topRight $bottomRight $bottomLeft]] + } + top { + return [vectorMidpoint $topLeft $topRight] + } + right { + return [vectorMidpoint $topRight $bottomRight] + } + bottom { + return [vectorMidpoint $bottomLeft $bottomRight] + } + left { + return [vectorMidpoint $topLeft $bottomLeft] + } + topleft - top-left { + return $topLeft + } + topright - top-right { + return $topRight + } + bottomright - bottom-right { + return $bottomRight + } + bottomleft - bottom-left { + return $bottomLeft + } + default { + error "draw/space: unknown quad point selector $selector" + } + } + } + + proc physicalPoint {origin xAxis yAxis scale x y} { + vectorAdd $origin \ + [vectorAdd \ + [vectorScale $xAxis [expr {$x * $scale}]] \ + [vectorScale $yAxis [expr {$y * $scale}]]] + } + + proc project {poseLib intrinsics width height point} { + $poseLib project $intrinsics $width $height $point + } + + proc projectPoint {poseLib intrinsics width height origin xAxis yAxis scale x y} { + set point [physicalPoint $origin $xAxis $yAxis $scale $x $y] + project $poseLib $intrinsics $width $height $point + } + + proc projectPoints {poseLib intrinsics width height origin xAxis yAxis scale points} { + lmap point $points { + projectPoint $poseLib $intrinsics $width $height \ + $origin $xAxis $yAxis $scale [lindex $point 0] [lindex $point 1] + } + } + + proc displayLength {poseLib intrinsics width height origin xAxis yAxis meters} { + set a [projectPoint $poseLib $intrinsics $width $height \ + $origin $xAxis $yAxis 1.0 0 0] + set b [projectPoint $poseLib $intrinsics $width $height \ + $origin $xAxis $yAxis 1.0 $meters 0] + vectorDistance $a $b + } + + proc regularPolygon {poseLib intrinsics width height origin xAxis yAxis scale cx cy radius sides radians} { + set points [list] + for {set i 0} {$i < $sides} {incr i} { + set theta [expr {$radians + $i * 2.0 * 3.141592653589793 / $sides - 1.5707963267948966}] + lappend points [list [expr {$cx + $radius * cos($theta)}] \ + [expr {$cy + $radius * sin($theta)}]] + } + projectPoints $poseLib $intrinsics $width $height \ + $origin $xAxis $yAxis $scale $points + } +}] + +Claim the draw space library is $drawSpaceLib + +When /someone/ wishes /thing/ runs demo code from /demoSource/ &\ + /demoSource/ has demo code /code/ { + Wish $thing is left-margined [string trim $code] with \ + font CourierPrimeCode \ + anchor {1.0 0.5 0 0.5} \ + scale 18.0 + evaluateBlock $code [list [dict create this $thing]] +} + +When /someone/ wishes /thing/ runs demo code { + Wish $thing runs demo code from $thing +} + +When /someone/ wishes /thing/ shows the drawing primitives demo &\ + the draw space library is /drawSpaceLib/ &\ + the quad library is /quadLib/ &\ + the pose library is /poseLib/ &\ + the quad changer is /quadChange/ &\ + display /disp/ has width /displayWidth/ height /displayHeight/ &\ + display /disp/ has intrinsics /displayIntrinsics/ &\ + /thing/ has quad /quad/ { + fn quadChange + + set basis [$drawSpaceLib quadBasis $quadLib [quadChange $quad "display $disp"]] + set origin [dict get $basis origin] + set xAxis [dict get $basis xAxis] + set yAxis [dict get $basis yAxis] + set scale 1.5 + + set displayScale [expr {$displayHeight / 1080.0}] + set hairline [expr {1.5 * $displayScale}] + set stroke [expr {3.0 * $displayScale}] + set dash [expr {10.0 * $displayScale}] + set textScale [expr {14.0 * $displayScale}] + set tinyTextScale [expr {9.0 * $displayScale}] + + set frame [$drawSpaceLib projectPoints \ + $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale \ + {{-0.10 -0.10} {0.10 -0.10} {0.10 0.10} {-0.10 0.10} {-0.10 -0.10}}] + Wish to draw a polygon onto $disp with \ + points [lrange $frame 0 3] color {0.02 0.025 0.03 0.55} layer 0 + Wish to draw a line onto $disp with \ + points $frame width $hairline color white layer 1 + + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0 -0.087] \ + scale $textScale text "draw/* primitives" color white anchor center layer 8 + + Wish to draw a line onto $disp with \ + points [$drawSpaceLib projectPoints $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale {{-0.086 -0.062} {-0.034 -0.076} {-0.006 -0.054}}] \ + width $stroke color deepskyblue layer 4 + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.046 -0.042] \ + scale $tinyTextScale text "line" color deepskyblue anchor center layer 8 + + Wish to draw a dashed line onto $disp with \ + points [$drawSpaceLib projectPoints $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale {{0.018 -0.072} {0.083 -0.056}}] \ + width $stroke color gold dashlength $dash dashoffset 0 layer 4 + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.052 -0.041] \ + scale $tinyTextScale text "dash" color gold anchor center layer 8 + + Wish to draw a circle onto $disp with \ + center [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.072 -0.012] \ + radius [$drawSpaceLib displayLength $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis [expr {0.013 * $scale}]] \ + thickness $stroke color cyan filled false layer 4 + Wish to draw a circle onto $disp with \ + center [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.045 -0.012] \ + radius [$drawSpaceLib displayLength $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis [expr {0.009 * $scale}]] \ + thickness $hairline color mediumspringgreen filled true layer 5 + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.059 0.015] \ + scale $tinyTextScale text "circle" color cyan anchor center layer 8 + + Wish to draw a triangle onto $disp with \ + p0 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.010 -0.028] \ + p1 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.030 0.010] \ + p2 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.010 0.010] \ + color magenta layer 4 + Wish to draw a quad onto $disp with \ + p0 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.024 -0.030] \ + p1 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.062 -0.020] \ + p2 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.055 0.016] \ + p3 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.018 0.006] \ + color orange layer 4 + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.026 0.022] \ + scale $tinyTextScale text "triangle + quad" color orange anchor center layer 8 + + Wish to draw a polygon onto $disp with \ + points [$drawSpaceLib regularPolygon $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.064 0.044 0.016 6 0.523599] \ + color greenyellow layer 4 + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.058 0.069] \ + scale $tinyTextScale text "polygon" color greenyellow anchor center layer 8 + + Wish to draw an arc onto $disp with \ + center [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.010 0.046] \ + radius [$drawSpaceLib displayLength $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis [expr {0.016 * $scale}]] \ + thickness $stroke start 0.25 arclen 4.7 color hotpink layer 5 + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale -0.010 0.069] \ + scale $tinyTextScale text "arc" color hotpink anchor center layer 8 + + Wish to draw a curve onto $disp with \ + p0 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.026 0.061] \ + p1 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.032 0.020] \ + p2 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.074 0.084] \ + p3 [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.083 0.041] \ + thickness $stroke color lightskyblue layer 5 + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.060 0.019] \ + scale $tinyTextScale text "curve" color lightskyblue anchor center layer 8 + + Wish to draw an AprilTag onto $disp with \ + id 45009 \ + corners [$drawSpaceLib projectPoints $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale {{0.066 -0.004} {0.092 -0.004} {0.092 0.022} {0.066 0.022}}] \ + background {0.96 0.98 1.0 1.0} layer 6 + + When the print library is /printLib/ { + Wish to draw an image onto $disp with \ + image [$printLib tagImageForId 45009] \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.079 0.060] \ + anchor center \ + width [$drawSpaceLib displayLength $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis [expr {0.026 * $scale}]] \ + height [$drawSpaceLib displayLength $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis [expr {0.026 * $scale}]] + } + + Wish to draw text onto $disp with \ + position [$drawSpaceLib projectPoint $poseLib $displayIntrinsics $displayWidth $displayHeight \ + $origin $xAxis $yAxis $scale 0.079 0.083] \ + scale $tinyTextScale text "tag + image" color lavender anchor center layer 8 +} + +Claim $this has demo code { + Wish $this shows the drawing primitives demo +} + +Claim 45009 has demo code { + Wish $this runs demo code from builtin-programs/draw/space.folk +} diff --git a/builtin-programs/title.folk b/builtin-programs/title.folk index 223bf6a7..3e62ad3d 100644 --- a/builtin-programs/title.folk +++ b/builtin-programs/title.folk @@ -4,6 +4,52 @@ # Wish $this is footnoted "This is a footnote" # Wish $this is right-margined "This is right-margined text" # Wish $this is left-margined "This is left-margined text" +# Any of those can also take text drawing options: +# Wish $this is left-margined "code" with font CourierPrimeCode anchor {1.0 0.5 0 0.5} + +Claim $this has demo code { + Wish $this is titled "Title demo\ncenter aligned" with \ + font PTSans-Regular \ + color deepskyblue \ + scale 44.0 \ + anchor {0.5 1.0 0.5 1.0} + + Wish $this is footnoted "Footnote demo\nright aligned" with \ + font VictorMonoRegular \ + color gold \ + scale 22.0 \ + anchor {0.5 0.0 1.0 0.0} + + Wish $this is left-margined "Left margin\nCourier mono\nleft aligned" with \ + font CourierPrimeCode \ + color mediumspringgreen \ + scale 18.0 \ + anchor {1.0 0.15 0.0 0.0} \ + padding 0.01 + + Wish $this is right-margined "Right margin\nNeomatrix\nright aligned" with \ + font NeomatrixCode \ + color hotpink \ + scale 28.0 \ + anchor {0.0 0.85 1.0 1.0} \ + padding 0.01 +} + +When /someone/ wishes /thing/ is titled /text/ { + Wish $thing is titled $text with scale 36.0 +} + +When /someone/ wishes /thing/ is footnoted /text/ { + Wish $thing is footnoted $text with scale 36.0 +} + +When /someone/ wishes /thing/ is right-margined /text/ { + Wish $thing is right-margined $text with scale 36.0 +} + +When /someone/ wishes /thing/ is left-margined /text/ { + Wish $thing is left-margined $text with scale 36.0 +} When /thing/ has quad /quad/ { Claim -keep 50ms $thing has a quad @@ -24,9 +70,18 @@ When the quad library is /quadLib/ &\ right-margined right left left-margined left right } { - When the collected results for [list /someone/ wishes $thing is $label /text/] are /results/ { - set text [join [lmap result $results {dict get $result text}] "\n"] - if {$text eq ""} { return } + When the collected results for [list /someone/ wishes $thing is $label /text/ with /...options/] are /results/ { + set groups [dict create] + foreach result $results { + set resultText [dict get $result text] + if {$resultText eq ""} { continue } + + set resultOptions [dict getdef $result options [dict create]] + set texts [dict getdef $groups $resultOptions [list]] + lappend texts $resultText + dict set groups $resultOptions $texts + } + if {[llength $groups] == 0} { return } When -atomically $thing has quad /q/ { package require linalg @@ -58,23 +113,32 @@ When the quad library is /quadLib/ &\ } } - set paddingMeters 0.02 - set offset [scale $paddingMeters [unitLengthVector $physicalDir]] - set physicalPos [add $physicalPos $offset] - - set dispPosition [$poseLib project $displayIntrinsics $displayWidth $displayHeight $physicalPos] - set dispTopLeft [$poseLib project $displayIntrinsics $displayWidth $displayHeight $topLeft] set dispTopRight [$poseLib project $displayIntrinsics $displayWidth $displayHeight $topRight] set dispTop [vec2 sub $dispTopRight $dispTopLeft] set dispRadians [expr {-atan2([lindex $dispTop 1], [lindex $dispTop 0])}] - Wish to draw text onto $disp with \ - position $dispPosition \ - scale 36.0 radians $dispRadians anchor $textAnchor \ - text $text + dict for {resultOptions texts} $groups { + set text [join $texts "\n"] + set drawOptions [dict create \ + scale 36.0 \ + anchor $textAnchor] + set drawOptions [dict merge $drawOptions $resultOptions] + + set paddingMeters [dict getdef $drawOptions padding 0.02] + set offset [scale $paddingMeters [unitLengthVector $physicalDir]] + set textPhysicalPos [add $physicalPos $offset] + set dispPosition [$poseLib project $displayIntrinsics $displayWidth $displayHeight $textPhysicalPos] + + dict set drawOptions position $dispPosition + dict set drawOptions radians $dispRadians + dict set drawOptions text $text + + Wish to draw text onto $disp with \ + {*}$drawOptions + } } } } -} \ No newline at end of file +} diff --git a/test/drawing-demo.folk b/test/drawing-demo.folk new file mode 100644 index 00000000..abbc0e89 --- /dev/null +++ b/test/drawing-demo.folk @@ -0,0 +1,299 @@ +source builtin-programs/collect.folk + +fn loadProgramForTest {filename} { + set fd [open $filename r] + set code [read $fd] + close $fd + evaluateBlock $code [list [dict create this $filename]] +} + +foreach program { + builtin-programs/draw/space.folk + builtin-programs/title.folk + builtin-programs/draw/line.folk + builtin-programs/draw/dashed-line.folk + builtin-programs/draw/circle.folk + builtin-programs/draw/fill.folk + builtin-programs/draw/arc.folk + builtin-programs/draw/curve.folk + builtin-programs/draw/apriltags.folk + builtin-programs/draw/image.folk + builtin-programs/draw/text.folk + builtin-programs/draw/shapes.folk +} { + loadProgramForTest $program +} + +set fakeQuadLib [library create fakeQuadLib { + proc vertices {quad} { + lindex $quad 1 + } +}] + +set fakePoseLib [library create fakePoseLib { + proc project {intrinsics width height point} { + list [lindex $point 0] [lindex $point 1] + } +}] + +set fakePrintLib [library create fakePrintLib { + proc tagImageForId {id} { + list fake-tag-image $id + } +}] + +fn fakeQuadChange {quad targetSpace} { + list $targetSpace [lindex $quad 1] +} + +fn drawingDemoPointClose {actual expected} { + if {[llength $actual] != [llength $expected]} { return 0 } + foreach av $actual ev $expected { + if {abs($av - $ev) > 1e-9} { return 0 } + } + return 1 +} + +set demo [QueryOne! 45009 has demo code /demoCode/] +evaluateBlock $demo(demoCode) [list [dict create this demo-page]] + +set curveDemo [QueryOne! builtin-programs/draw/curve.folk has demo code /demoCode/] +evaluateBlock $curveDemo(demoCode) [list [dict create this curve-page]] + +evaluateBlock { + Wish $this runs demo code from builtin-programs/title.folk +} [list [dict create this title-page]] + +evaluateBlock { + Wish $this is titled hello + Wish $this is footnoted goodbye + Wish $this is left-margined something + Wish $this is right-margined elsewhere +} [list [dict create this plain-title-page]] + +set disp test-display +Assert! the quad library is $fakeQuadLib +Assert! the pose library is $fakePoseLib +Assert! the quad changer is [fn fakeQuadChange] +Assert! the print library is $fakePrintLib +Assert! display $disp has width 1920 height 1080 +Assert! display $disp has intrinsics test-intrinsics +Assert! demo-page has quad \ + [list page-space {{-0.05 -0.05 0} {0.05 -0.05 0} {0.05 0.05 0} {-0.05 0.05 0}}] +Assert! title-page has quad \ + [list page-space {{-0.05 -0.05 0} {0.05 -0.05 0} {0.05 0.05 0} {-0.05 0.05 0}}] +Assert! plain-title-page has quad \ + [list page-space {{-0.05 -0.05 0} {0.05 -0.05 0} {0.05 0.05 0} {-0.05 0.05 0}}] +Assert! curve-page has resolved geometry {width 0.2 height 0.2} + +sleep 1 + +set errors [Query! /program/ has error /err/ with info /info/] +assert {[llength $errors] == 0} + +set demoWishes [Query! /someone/ wishes demo-page shows the drawing primitives demo] +assert {[llength $demoWishes] == 1} +set demoRunWishes [Query! /someone/ wishes demo-page runs demo code from builtin-programs/draw/space.folk] +assert {[llength $demoRunWishes] == 1} +set titleRunWishes [Query! /someone/ wishes title-page runs demo code from builtin-programs/title.folk] +assert {[llength $titleRunWishes] == 1} +set sourceWishes [Query! /someone/ wishes demo-page is left-margined /text/ with /...options/] +assert {[llength $sourceWishes] == 1} +assert {[dict get [lindex $sourceWishes 0] text] eq {Wish $this shows the drawing primitives demo}} +set sourceOptions [dict get [lindex $sourceWishes 0] options] +assert {[dict get $sourceOptions font] eq "CourierPrimeCode"} +assert {[dict get $sourceOptions anchor] eq {1.0 0.5 0 0.5}} +assert {[dict get $sourceOptions scale] == 18.0} +set titleMarginWishes [Query! /someone/ wishes title-page is left-margined /text/ with /...options/] +assert {[llength $titleMarginWishes] == 2} +foreach {label text} { + titled hello + footnoted goodbye + left-margined something + right-margined elsewhere +} { + set wishes [Query! /someone/ wishes plain-title-page is $label /actualText/ with /...options/] + assert {[llength $wishes] == 1} + assert {[dict get [lindex $wishes 0] actualText] eq $text} + assert {[dict get [lindex $wishes 0] options] eq {scale 36.0}} +} +set curvePageDraws [Query! /someone/ wishes to draw a curve onto curve-page with /...drawOptions/] +assert {[llength $curvePageDraws] >= 1} + +foreach {kind minimum} { + line 2 + dashed 1 + circle 2 + triangle 1 + quad 1 + polygon 2 + arc 1 + curve 1 + text 8 + apriltag 1 + image 1 +} { + switch -- $kind { + line { + set draws [Query! /someone/ wishes to draw a line onto $disp with /...drawOptions/] + } + dashed { + set draws [Query! /someone/ wishes to draw a dashed line onto $disp with /...drawOptions/] + } + circle { + set draws [Query! /someone/ wishes to draw a circle onto $disp with /...drawOptions/] + } + triangle { + set draws [Query! /someone/ wishes to draw a triangle onto $disp with /...drawOptions/] + } + quad { + set draws [Query! /someone/ wishes to draw a quad onto $disp with /...drawOptions/] + } + polygon { + set draws [Query! /someone/ wishes to draw a polygon onto $disp with /...drawOptions/] + } + arc { + set draws [Query! /someone/ wishes to draw an arc onto $disp with /...drawOptions/] + } + curve { + set draws [Query! /someone/ wishes to draw a curve onto $disp with /...drawOptions/] + } + text { + set draws [Query! /someone/ wishes to draw text onto $disp with /...drawOptions/] + } + apriltag { + set draws [Query! /someone/ wishes to draw an AprilTag onto $disp with /...drawOptions/] + } + image { + set draws [Query! /someone/ wishes to draw an image onto $disp with /...drawOptions/] + } + } + assert {[llength $draws] >= $minimum} +} + +set polygonDraws [Query! /someone/ wishes to draw a polygon onto $disp with /...drawOptions/] +set hasThirtyCmFrame 0 +foreach draw $polygonDraws { + set points [dict get [dict get $draw drawOptions] points] + if {[llength $points] == 4 && \ + [drawingDemoPointClose [lindex $points 0] {-0.15 -0.15}] && \ + [drawingDemoPointClose [lindex $points 2] {0.15 0.15}]} { + set hasThirtyCmFrame 1 + } +} +assert {$hasThirtyCmFrame} + +set lineDraws [Query! /someone/ wishes to draw a line onto $disp with /...drawOptions/] +set hasHairline 0 +set hasStroke 0 +foreach draw $lineDraws { + set width [dict get [dict get $draw drawOptions] width] + if {abs($width - 1.5) < 1e-9} { set hasHairline 1 } + if {abs($width - 3.0) < 1e-9} { set hasStroke 1 } +} +assert {$hasHairline} +assert {$hasStroke} + +set dashedDraws [Query! /someone/ wishes to draw a dashed line onto $disp with /...drawOptions/] +set dashedOptions [dict get [lindex $dashedDraws 0] drawOptions] +set dashedWidth [dict get $dashedOptions width] +set dashedLength [dict get $dashedOptions dashlength] +assert {abs($dashedWidth - 3.0) < 1e-9} +assert {abs($dashedLength - 10.0) < 1e-9} + +set textDraws [Query! /someone/ wishes to draw text onto $disp with /...drawOptions/] +set hasTitleScale 0 +set hasTinyScale 0 +set hasSourceMargin 0 +set hasTitleDemoTitle 0 +set hasTitleDemoFootnote 0 +set hasTitleDemoLeftMargin 0 +set hasTitleDemoRightMargin 0 +set hasTitleDemoSourceMargin 0 +set hasPlainTitle 0 +set hasPlainFootnote 0 +set hasPlainLeftMargin 0 +set hasPlainRightMargin 0 +foreach draw $textDraws { + set drawOptions [dict get $draw drawOptions] + set scale [dict get $drawOptions scale] + if {abs($scale - 14.0) < 1e-9} { set hasTitleScale 1 } + if {abs($scale - 9.0) < 1e-9} { set hasTinyScale 1 } + if {[dict getdef $drawOptions text ""] eq {Wish $this shows the drawing primitives demo}} { + assert {[dict get $drawOptions font] eq "CourierPrimeCode"} + assert {[dict get $drawOptions anchor] eq {1.0 0.5 0 0.5}} + assert {abs($scale - 18.0) < 1e-9} + set hasSourceMargin 1 + } + + set text [dict getdef $drawOptions text ""] + if {$text eq "Title demo\ncenter aligned"} { + assert {[dict get $drawOptions font] eq "PTSans-Regular"} + assert {[dict get $drawOptions color] eq "deepskyblue"} + assert {[dict get $drawOptions anchor] eq {0.5 1.0 0.5 1.0}} + assert {[drawingDemoPointClose [dict get $drawOptions position] {0.0 -0.07}]} + assert {abs($scale - 44.0) < 1e-9} + set hasTitleDemoTitle 1 + } elseif {$text eq "Footnote demo\nright aligned"} { + assert {[dict get $drawOptions font] eq "VictorMonoRegular"} + assert {[dict get $drawOptions color] eq "gold"} + assert {[dict get $drawOptions anchor] eq {0.5 0.0 1.0 0.0}} + assert {[drawingDemoPointClose [dict get $drawOptions position] {0.0 0.07}]} + assert {abs($scale - 22.0) < 1e-9} + set hasTitleDemoFootnote 1 + } elseif {$text eq "Left margin\nCourier mono\nleft aligned"} { + assert {[dict get $drawOptions font] eq "CourierPrimeCode"} + assert {[dict get $drawOptions color] eq "mediumspringgreen"} + assert {[dict get $drawOptions anchor] eq {1.0 0.15 0.0 0.0}} + assert {[drawingDemoPointClose [dict get $drawOptions position] {-0.06 0.0}]} + assert {abs($scale - 18.0) < 1e-9} + set hasTitleDemoLeftMargin 1 + } elseif {$text eq "Right margin\nNeomatrix\nright aligned"} { + assert {[dict get $drawOptions font] eq "NeomatrixCode"} + assert {[dict get $drawOptions color] eq "hotpink"} + assert {[dict get $drawOptions anchor] eq {0.0 0.85 1.0 1.0}} + assert {[drawingDemoPointClose [dict get $drawOptions position] {0.06 0.0}]} + assert {abs($scale - 28.0) < 1e-9} + set hasTitleDemoRightMargin 1 + } elseif {[string first {Wish $this is titled} $text] >= 0} { + assert {[dict get $drawOptions font] eq "CourierPrimeCode"} + assert {[dict get $drawOptions anchor] eq {1.0 0.5 0 0.5}} + assert {[drawingDemoPointClose [dict get $drawOptions position] {-0.07 0.0}]} + assert {abs($scale - 18.0) < 1e-9} + set hasTitleDemoSourceMargin 1 + } elseif {$text eq "hello"} { + assert {[dict get $drawOptions anchor] eq "bottom"} + assert {[drawingDemoPointClose [dict get $drawOptions position] {0.0 -0.07}]} + assert {abs($scale - 36.0) < 1e-9} + set hasPlainTitle 1 + } elseif {$text eq "goodbye"} { + assert {[dict get $drawOptions anchor] eq "top"} + assert {[drawingDemoPointClose [dict get $drawOptions position] {0.0 0.07}]} + assert {abs($scale - 36.0) < 1e-9} + set hasPlainFootnote 1 + } elseif {$text eq "something"} { + assert {[dict get $drawOptions anchor] eq "right"} + assert {[drawingDemoPointClose [dict get $drawOptions position] {-0.07 0.0}]} + assert {abs($scale - 36.0) < 1e-9} + set hasPlainLeftMargin 1 + } elseif {$text eq "elsewhere"} { + assert {[dict get $drawOptions anchor] eq "left"} + assert {[drawingDemoPointClose [dict get $drawOptions position] {0.07 0.0}]} + assert {abs($scale - 36.0) < 1e-9} + set hasPlainRightMargin 1 + } +} +assert {$hasTitleScale} +assert {$hasTinyScale} +assert {$hasSourceMargin} +assert {$hasTitleDemoTitle} +assert {$hasTitleDemoFootnote} +assert {$hasTitleDemoLeftMargin} +assert {$hasTitleDemoRightMargin} +assert {$hasTitleDemoSourceMargin} +assert {$hasPlainTitle} +assert {$hasPlainFootnote} +assert {$hasPlainLeftMargin} +assert {$hasPlainRightMargin} + +Exit! 0 From 568eac3f94cae5cb26a1ad08914e8c77ba25c254 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Wed, 6 May 2026 19:12:20 -0400 Subject: [PATCH 15/20] connections: restore quad-based drawing Rewrite connections.folk around quads instead of the old region helpers. Connection endpoints are resolved through quad vertices, projected into the target display, and rendered with the new draw line and fill triangle primitives.\n\nKeep the friendly shorthand wishes for static and dynamic connections while normalizing them into the explicit with from/to option form. Add regression coverage for centroid endpoints, option forwarding, display projection, and dynamic arrowhead placement. --- builtin-programs/connections.folk | 133 ++++++++++++++++++++---------- test/draw-connections.folk | 68 +++++++++++++++ 2 files changed, 159 insertions(+), 42 deletions(-) create mode 100644 test/draw-connections.folk diff --git a/builtin-programs/connections.folk b/builtin-programs/connections.folk index 8efa359a..e8ad439c 100644 --- a/builtin-programs/connections.folk +++ b/builtin-programs/connections.folk @@ -3,67 +3,116 @@ # "Wish $tag is connected to $tag2" or "Wish $tag is dynamically connected to $tag2" When /anyone/ wishes /source/ is connected to /sink/ { - Wish $source is connected to $sink from centroid to centroid + Wish $source is connected to $sink with from centroid to centroid +} +When /anyone/ wishes /source/ is connected to /sink/ from /from/ to /to/ { + Wish $source is connected to $sink with from $from to $to } When /anyone/ wishes /source/ is dynamically connected to /sink/ { - Wish $source is dynamically connected to $sink from centroid to centroid + Wish $source is dynamically connected to $sink with from centroid to centroid +} +When /anyone/ wishes /source/ is dynamically connected to /sink/ from /from/ to /to/ { + Wish $source is dynamically connected to $sink with from $from to $to } -When /anyone/ wishes /source/ is connected to /sink/ /...options/ & \ - /source/ has region /source_region/ & \ - /sink/ has region /sink_region/ { - if {$source == $sink} {return} +fn drawConnectionArrowPoints {center radius radians} { + lassign $center cx cy + set dx [expr {cos($radians)}] + set dy [expr {sin($radians)}] + set spread [expr {$radius * 0.8}] + set baseX [expr {$cx - $dx * $radius}] + set baseY [expr {$cy - $dy * $radius}] + set tip [list [expr {$cx + $dx * $radius}] [expr {$cy + $dy * $radius}]] + set rearLeft [list [expr {$baseX + $dy * $spread}] [expr {$baseY - $dx * $spread}]] + set rearRight [list [expr {$baseX - $dy * $spread}] [expr {$baseY + $dx * $spread}]] + list $tip $rearLeft $rearRight +} - set p1 [dict_getdef $options from centroid] - set p2 [dict_getdef $options to centroid] - set source [region $p1 $source_region] - set sink [region $p2 $sink_region] +fn drawConnectionArrow {disp center radius radians color layer} { + if {$radius <= 0.0} { return } + lassign [drawConnectionArrowPoints $center $radius $radians] p0 p1 p2 + Wish to draw a triangle onto $disp with \ + p0 $p0 p1 $p1 p2 $p2 color $color layer $layer +} - set direction [vec2 sub $sink $source] - set color [dict_getdef $options color grey] - set layer [dict_getdef $options layer 0] +When the draw space library is /drawSpaceLib/ &\ + the quad library is /quadLib/ &\ + the pose library is /poseLib/ &\ + the quad changer is /quadChange/ &\ + display /disp/ has width /displayWidth/ height /displayHeight/ &\ + display /disp/ has intrinsics /displayIntrinsics/ &\ + /anyone/ wishes /source/ is connected to /sink/ with /...options/ &\ + /source/ has quad /sourceQuad/ &\ + /sink/ has quad /sinkQuad/ { + if {$source eq $sink} { return } + fn quadChange - set c [vec2 scale [vec2 add $source $sink] 0.5] - set angle [expr {atan2(-[lindex $direction 1], [lindex $direction 0]) - 3.14159/2}] + set p1 [$drawSpaceLib quadPoint $quadLib \ + [quadChange $sourceQuad "display $disp"] \ + [dict getdef $options from centroid]] + set p2 [$drawSpaceLib quadPoint $quadLib \ + [quadChange $sinkQuad "display $disp"] \ + [dict getdef $options to centroid]] + set from [$drawSpaceLib project $poseLib $displayIntrinsics $displayWidth $displayHeight $p1] + set to [$drawSpaceLib project $poseLib $displayIntrinsics $displayWidth $displayHeight $p2] - Wish to draw a stroke with points [list $source $sink] width 2 color $color layer $layer - Wish to draw a shape with sides 3 center $c radius 30 radians $angle color $color filled true layer $layer + set direction [$drawSpaceLib vectorSub $to $from] + if {[$drawSpaceLib vectorDistance $to $from] == 0.0} { return } + set color [dict getdef $options color grey] + set layer [dict getdef $options layer 0] + + set c [$drawSpaceLib vectorMidpoint $from $to] + set angle [expr {atan2([lindex $direction 1], [lindex $direction 0])}] + + Wish to draw a line onto $disp with \ + points [list $from $to] width 2 color $color layer $layer + drawConnectionArrow $disp $c 30 $angle $color $layer } set speed 75 set spacing 50 set maxsize 25 -When /anyone/ wishes /source/ is dynamically connected to /sink/ /...options/ & \ - /source/ has region /source_region/ & \ - /sink/ has region /sink_region/ { - - if {$source == $sink} {return} +When the draw space library is /drawSpaceLib/ &\ + the quad library is /quadLib/ &\ + the pose library is /poseLib/ &\ + the quad changer is /quadChange/ &\ + display /disp/ has width /displayWidth/ height /displayHeight/ &\ + display /disp/ has intrinsics /displayIntrinsics/ &\ + /anyone/ wishes /source/ is dynamically connected to /sink/ with /...options/ &\ + /source/ has quad /sourceQuad/ &\ + /sink/ has quad /sinkQuad/ { - set p1 [dict_getdef $options from centroid] - set p2 [dict_getdef $options to centroid] - set source [region $p1 $source_region] - set sink [region $p2 $sink_region] + if {$source eq $sink} { return } + fn quadChange - set direction [vec2 normalize [vec2 sub $sink $source]] - set distance [vec2 distance $sink $source] - set angle [expr {atan2(-[lindex $direction 1], [lindex $direction 0]) - 3.14159/2}] + set p1 [$drawSpaceLib quadPoint $quadLib \ + [quadChange $sourceQuad "display $disp"] \ + [dict getdef $options from centroid]] + set p2 [$drawSpaceLib quadPoint $quadLib \ + [quadChange $sinkQuad "display $disp"] \ + [dict getdef $options to centroid]] + set from [$drawSpaceLib project $poseLib $displayIntrinsics $displayWidth $displayHeight $p1] + set to [$drawSpaceLib project $poseLib $displayIntrinsics $displayWidth $displayHeight $p2] - set color [dict_getdef $options color white] - set layer [dict_getdef $options layer 0] + set direction [$drawSpaceLib vectorSub $to $from] + set distance [$drawSpaceLib vectorDistance $to $from] + if {$distance == 0.0} { return } + set direction [$drawSpaceLib vectorScale $direction [expr {1.0 / $distance}]] + set angle [expr {atan2([lindex $direction 1], [lindex $direction 0])}] - lassign [vec2 scale [vec2 add $source $sink] 0.5] cx cy + set color [dict getdef $options color white] + set layer [dict getdef $options layer 0] - Wish to draw a stroke with points [list $source $sink] width 1 color $color layer $layer - - When the clock time is /t/ { - set offset [expr {round($t*$speed) % $spacing}] - set count [expr {round($distance / $spacing)}] + Wish to draw a line onto $disp with \ + points [list $from $to] width 1 color $color layer $layer - for {set p $offset} {$p < $distance} {incr p $spacing} { - set c [vec2 add $source [vec2 scale $direction $p]] - set s [expr {min($maxsize, 0.20*min($p, $distance - $p))}] - Wish to draw a shape with sides 3 center $c radius $s radians $angle color $color filled true layer $layer - } + When the clock time is /t/ { + set offset [expr {round($t*$speed) % $spacing}] + for {set p $offset} {$p < $distance} {incr p $spacing} { + set c [$drawSpaceLib vectorAdd $from [$drawSpaceLib vectorScale $direction $p]] + set s [expr {min($maxsize, 0.20*min($p, $distance - $p))}] + drawConnectionArrow $disp $c $s $angle $color $layer + } } } diff --git a/test/draw-connections.folk b/test/draw-connections.folk new file mode 100644 index 00000000..f39a9265 --- /dev/null +++ b/test/draw-connections.folk @@ -0,0 +1,68 @@ +source builtin-programs/collect.folk +source builtin-programs/draw/space.folk + +set fakeQuadLib [library create fakeQuadLib { + proc vertices {quad} { + lindex $quad 1 + } +}] + +set fakePoseLib [library create fakePoseLib { + proc project {intrinsics width height point} { + list [lindex $point 0] [lindex $point 1] + } +}] + +fn fakeQuadChange {quad targetSpace} { + list $targetSpace [lindex $quad 1] +} + +source builtin-programs/connections.folk + +set points [drawConnectionArrowPoints {5 1} 2 0] +lassign [lindex $points 0] x y +assert {abs($x - 7.0) < 1e-9} +assert {abs($y - 1.0) < 1e-9} +lassign [lindex $points 1] x y +assert {abs($x - 3.0) < 1e-9} +assert {abs($y + 0.6) < 1e-9} + +set disp test-display +set source source-page +set sink sink-page + +Assert! the quad library is $fakeQuadLib +Assert! the pose library is $fakePoseLib +Assert! the quad changer is [fn fakeQuadChange] +Assert! display $disp has width 100 height 100 +Assert! display $disp has intrinsics test-intrinsics +Assert! $source has quad \ + [list source-space {{0 0 0} {2 0 0} {2 2 0} {0 2 0}}] +Assert! $sink has quad \ + [list source-space {{10 0 0} {12 0 0} {12 2 0} {10 2 0}}] +Wish $source is connected to $sink with color cyan layer 4 + +sleep 1 + +set errors [Query! /program/ has error /err/ with info /info/] +assert {[llength $errors] == 0} + +set lineDraws [Query! /someone/ wishes to draw a line onto $disp with /...drawOptions/] +assert {[llength $lineDraws] == 1} +set drawOptions [dict get [lindex $lineDraws 0] drawOptions] +assert {[dict get $drawOptions points] eq {{1.0 1.0} {11.0 1.0}}} +assert {[dict get $drawOptions width] == 2} +assert {[dict get $drawOptions color] eq "cyan"} +assert {[dict get $drawOptions layer] == 4} + +set triangleDraws [Query! /someone/ wishes to draw a triangle onto $disp with /...drawOptions/] +assert {[llength $triangleDraws] == 1} +set drawOptions [dict get [lindex $triangleDraws 0] drawOptions] +assert {[dict get $drawOptions color] eq "cyan"} +assert {[dict get $drawOptions layer] == 4} +foreach key {p0 p1 p2} { + assert {[llength [dict get $drawOptions $key]] == 2} +} +assert {[dict get $drawOptions p0] eq {36.0 1.0}} + +Exit! 0 From ce8c2924c5963c971273f70c2a4946fc178a7170 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Wed, 6 May 2026 19:12:34 -0400 Subject: [PATCH 16/20] draw/text: honor block anchors for aligned lines Fix four-value text anchors so the block anchor places the whole text block and the line anchor only aligns each line inside that block. Previously the X offset subtracted the block offset again, so a left-aligned source-code block anchored on its right edge started at the margin point and spilled into the page.\n\nAdd a glyph-level regression test that draws multi-line Courier text with anchor {1.0 0.5 0.0 0.5} and checks the generated glyph instances stay to the left of the anchor point. --- builtin-programs/draw/text.folk | 6 ++-- test/draw-text-anchor.folk | 63 +++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+), 2 deletions(-) create mode 100644 test/draw-text-anchor.folk diff --git a/builtin-programs/draw/text.folk b/builtin-programs/draw/text.folk index eb1e04f8..71926516 100644 --- a/builtin-programs/draw/text.folk +++ b/builtin-programs/draw/text.folk @@ -113,8 +113,10 @@ $cc proc textShape {Jim_Obj* viewport Jim_Obj* surfaceToClip ch = charOrFallback(font, ch); GlyphInfo* glyphInfo = &font->glyphInfos[ch]; if (ch != ' ') { - // Calculate the absolute glyph position. - float lineOffsetX = -(lineAnchorX * lineWidth) - blockOffsetX; + // Calculate the absolute glyph position. The block anchor places the + // text block relative to the requested position; the line anchor then + // aligns each individual line inside that block. + float lineOffsetX = lineAnchorX * (extent.x - lineWidth); // `lineOffsetY` doesn't exist, since it's already included in the `blockOffsetY` calculation. vec2f rotatedLineOffset = vec2f_rotate((vec2f) { lineOffsetX, 0 }, radians); vec2f combinedOffset = vec2f_add(blockStart, rotatedLineOffset); diff --git a/test/draw-text-anchor.folk b/test/draw-text-anchor.folk new file mode 100644 index 00000000..b53e9d04 --- /dev/null +++ b/test/draw-text-anchor.folk @@ -0,0 +1,63 @@ +source builtin-programs/collect.folk +source builtin-programs/image/image-lib.folk +source builtin-programs/draw/color-map.folk +source builtin-programs/draw/text.folk + +When the image library is /imageLib/ { + fn fakeLoadImage {path} { + $imageLib imageNew 8 8 4 1 + } + Claim the image loader is [fn fakeLoadImage] +} + +When /someone/ wishes the GPU loads image /im/ as texture { + Claim the GPU has loaded image $im as texture 17 +} + +fn drawTextAnchorBounds {instances} { + set minX 1000000.0 + set maxX -1000000.0 + foreach instance $instances { + foreach point [list \ + [lindex $instance 4] \ + [lindex $instance 5] \ + [lindex $instance 6] \ + [lindex $instance 7]] { + set x [lindex $point 0] + if {$x < $minX} { set minX $x } + if {$x > $maxX} { set maxX $x } + } + } + dict create minX $minX maxX $maxX +} + +Assert! text-page has canvas canvas-id with width 400 height 300 +Assert! text-page has canvas projection {1 0 0 0 1 0 0 0 1} + +set fonts [list] +for {set i 0} {$i < 100 && [llength $fonts] == 0} {incr i} { + sleep 0.1 + set fonts [Query! the GPU has font CourierPrimeCode with data /fontData/] +} +assert {[llength $fonts] == 1} + +Wish to draw text onto text-page with \ + position {100 100} \ + scale 10.0 \ + font CourierPrimeCode \ + anchor {1.0 0.5 0.0 0.5} \ + text "A\nAA" \ + color white + +set draws [list] +for {set i 0} {$i < 100 && [llength $draws] == 0} {incr i} { + sleep 0.1 + set draws [Query! /someone/ wishes the GPU draws pipeline "glyph" onto canvas canvas-id with instances /instances/ layer /layer/] +} +assert {[llength $draws] == 1} + +set bounds [drawTextAnchorBounds [dict get [lindex $draws 0] instances]] +assert {[dict get $bounds minX] < 95.0} +assert {[dict get $bounds maxX] < 101.0} + +Exit! 0 From 016c83eaed4afe73497f58ce8d958dbb05b4c8ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Wed, 6 May 2026 20:31:57 -0400 Subject: [PATCH 17/20] draw/image: make Folk logo URL work offline The live Folk machine may not have a public internet route, so fetching https://folk.computer/_media/logo.png can fail even though the URL is valid elsewhere. Bundle the small logo asset and resolve that well-known Folk media URL locally before falling back to curl.\n\nAlso harden URL downloads: preserve a useful extension for loader matching, write through a temporary file, reject empty downloads, and avoid leaving poisoned cache files behind after curl failures. Add a regression test for Wish displays image "https://folk.computer/_media/logo.png". --- assets/logo.png | Bin 0 -> 7111 bytes builtin-programs/draw/image.folk | 47 +++++++++++++++++++++++++++++-- test/draw-image-url.folk | 32 +++++++++++++++++++++ 3 files changed, 76 insertions(+), 3 deletions(-) create mode 100644 assets/logo.png create mode 100644 test/draw-image-url.folk diff --git a/assets/logo.png b/assets/logo.png new file mode 100644 index 0000000000000000000000000000000000000000..a14866a126e31c262e7bdc3e2b8f9f7d4cbcb3c8 GIT binary patch literal 7111 zcmZ{JbySpV*Z0sJiZn=<#LzKxHw+9)2m->;3|%5aN=SqB&>)@CjkF-$(jzS(NS803 z^L*z$-?yIczSni_-@W(#?O6Nz<67&E0Bb1|;8NiN000726$RY~`Da0}F&}n(XRs6i zfZ|~*FAuhtSC)5jaB_t>n_EB?Y~7q4%zeND004WuM_jvl5BN!+cA4%tD4dX%hCf1n zdJ@;u#fI~VBCj4s86+K!(Md-#L;Bqy^^B0 z$hb1Fc_)f+Yc}qp22*mLqq6TN$7}Q!)K9m3_YDrqf|Od-7Uyx{-ru$E|C%^k(GEA% zZ1p5w&^AsPnapGlrBmIlPRmA9lC8x@BsoUntgt-gv*Fk%U27X22%6%_ z7SBquL|i5tOyb&wHmPzIiJ!j3N_h{hs1KfB$)3?q>7&`x88IherFak42}H+O_rINr zk&fYZ)i(q4#G-P2QBZwEQrr7$JlFg&zYDhPUR;ygKAfoHX2{X;h&0vFc@(&~D2FDR znVUHCZP6Q@f(iiJ(-6{A-pf7Ta_zdo;Y~#iJ!1c4zV(^G%hw-&$9MhK0{?dXRr0*PrbliJF7@kB4p!+CLcb$9MC22GT@P4kZCd3YJ6aOvskC0s47K)MP_|Div8Niy2FyE}t` zKrb&Z9xnkNCs%7ApO}~!ke46G&(Hnf!R_V)b2sq~_y77E{?`ou z*8Yp}r&18u)*I?zs9@^|g}MEyi(lxWuK#NJuS|n~F$Kl`&HR_;KTHYWpIQ8CHh&NP zFYUwRrEn#H|C}NzT&@F}hXYBDuc{!c=Z$h;g6B>%<8!~=+?sG37gZCDVi6n>?GQ}Y zw^mmorm6-BXITWH$otgUs^o-(FxQDXGVTcra@1+5>@f?n2=>wB%>v)6W@H7^)5zfp zUos#P(y78xIvu%e>jlK!Zv4CiPweW;mXqodM8oWlMn^~dZZBGY|6culf59NH#6zK0 zPcb=b^(A-c%cX&R+{-#UTfWV7M}pTGQ?<)m-^YpA*4n8+URWI>JL6TICE_XDB>wqG9m+|1~z8I*Mkg)*j7b2WE zOSCpwV(95Mt9%b`d0%zc$A)M|nt}nAQ@P{dpN?&BMv3cZYNq`uqGQ{iq7^-%f-It< z0g=`{J{7oe%plCT0L%kTeN4kEdHQpP#{Nn)-Hjr&fR6#`Ayir67XfH0y3c|%M3l1k zl<2{Tc&tf&%+9n$cZZ(3#4fz~>&$K(%QKRinTyPRZs{1ep+auBFwLAf#))e9&y!7^ zvNCe1-OGsJxia3{sEledV)`mh^@-`%n8jRAq{=t*qrh^4gs$~mJxcizGNj({CW52c zmR~$Z+U+GqfHVCUa_#3cQ}QV82G8Uwhe?qmm0SBctuNT@%9~N+_tmg!R08z}flQAX zVagVTc3gOwsh7(Ov>(lvEXG!E**Uz|-}Q}d^nI)CVK|h>OfdE~jOD-ZtT15Ab;(Yw zmC6B_d5NH>8)F?(KiYXu8YG1)Sgbc$TLQT|%ppMdhWSn;lczB^686=ypS@L)c~)0k zW0^4~$1k2S*VS?5#%8Y8!Xz#X7^#v(d1s|Lv(PX{%RVL8xxqDG7dqj(pO9USxRFJ{ zS%wYbMLGr*FX|(dz-nU1Div$eeN!{mwhNd_oh2D{!*(-RtkSn!Y7-(JZS| zQ92xFq-Z5)=KE@im>!R!;mJkd)%gms|;5#;Up8N77XQxfQnmAP8_ z{gykH6C?PQk@<-I%bXv1&r0i_`l&=xaPxli6!9Ca`Pv!WkxPkWVha1vju$+J5`Z+S zmY?B1yw%*tM6+6uNgzSKIPntp|60j+^aFIrAyKd{(ULg?eo53qqG2|p;mop+QI^@S zd0{4sx1Wb`#u+Ox%&%A{y1JYvdjz-b1GSE}2>309E#%O(x5`>Fjeiu1uHFwJU&Prj zOEb~*FC5qfo5$Pgw-kQaPA{G52?8YnKgPa+Ylls;N#f2hd~S4K&nFGGJZESN zBUaPLE;OB5GkTS>nvmMLdFZN{FL!lTV!D**0~A>$l&mG&&_JdmmVn&uAJHXa-qql< z+D1~hYeVy?3B}}3cam3W?<2&Wkc}4jxV;B{(?n4#BA1W8y{LYaVKOj3KeG#A<5%l+ ze|vl6hy@*L!{PT+d)&j%;>;5@6u^*QJ%MH8u;<5=R2xN)T~)V`k-{7Oeov)V@SyiF zr4mHPQyO-MkBOx-p!+22sNv~{o&kxP^)wDD+b6j~6SYzj8m9NNuQb^ZG<~9pO(BL+ zqe0`|1_!oMVdv244Dw1D*`74q3*4miH5=EB*7ahI2t$%GdF*+bQ?{t25){ksvX2 z@u~DRpY=Bquawx7L!v8nvY)&=dAQ(FbA4*veJTR|O{v87l(B^`+J%rIT#c3Msw$f{ zx%28CzPm$~wrHl-gO2wqE8MxCWpEQCA(2|-cSoD?hJh4jX+eBohdNd?eun<};h0_L zw&@DL3H)YGI|ZgfotA4BFaUgh1bS7}$y#GJoMPdTLf2?&rx+hf^4Z?0gJO1O>=T@b z1>=9rKslCNO=+u#olxgR~J{Q%*hbtiZ3}KE?mW$%Ir8j zunE4KQ8i3Er=8eG9+iTLPl9s}xK4O$W?+LoRZreZ?l7c#TKBVV2uIA`PK|Z;Af?}Jzu*{EqmkJEO?7S}?{8i3+fecbNOP{`S99f@ zDpQ{dh}+Uee*{0gjmhL^#4M{K*(fd0T0>LK+PXnhM9Hu=eF0rUxr1&cOgY5`Th;kE zNO5-@E61RqJtZ9$#Q9_LR2;6;PGQ}pD-n=%jD}yM&@!Y$0S?apoRO_c@KLiVoXyVhLo(%f{elHDh;TA%unnv>7!od7TuQ z4N(tN%{jae!fy=8szSg^$yK@)NT)85{32$j{H?9x1==;`>!u^C-!UIAMyT;}nJxm{ z(0tD8-qL7ymT#oQ?hXwRR4#ScB^cinwQja>?m_Rbko4T+-}*pFlcxr2uU9Kvwk{9O zMEI^793y>MS}v3=56kOrO;#!rP)>BDbwD==3SK&f4Ykpa=a>wy=`bsdX~U zEi-PhlUDaP3{a4_R~Krok3l;kEMoKZ*aqX$VJp0dlCOj9Aio{?=m_7QrnVhv=Y>;*r*F`?r3F&}H!W-}FWDB0*fn`lVlf)|WWABA%lijVFcQ5-glkd}Q;*cdpwa z&GVhpy~6+H`veh?;lK6dC94dnW$v&YMEH&V2S`w)4bW9jx974jpNM*0Pl3iphK7-z zPb8+0r3oYQHFHxnb*SLyxZV~1EHhJO{E4UJAgWh^*=zQ;djw|+)zl6BNywVejdlNnx zz*MthJt*nQf*x$lb%|@gw?=s~)2Bj(Vw<|fQXQuxG~Qp3%F3{%POgy~`LS zhS32HQ*4~a#!N_hrz@n(>DvEaW$g%UW=(+Bb zi_vzX(%)#{&&SloeOzCpj(=6xv~rFQPQ7v!dAY z*(2xdPaC@a?oP2@WD#$r%J(e(xVk;2*=?S`TuI5sLJeQZ5z+?pXedDy>+v86qh%9y zn^tJ0@~E)OqOg}K42uZam4Rppe3cp9Sd>M#+vh`JK4T7_&cufAO$^J-m7)sEY#E5q zJQgRVnsO*#m(uJ}_MuXwK<1T@h)KqEg>~A_;y;_~!YEk2&og;gv&YMe=LW{Q?!n3Sb92#gx%PAAj0+uAG-f+~CoxOiNtc0{n0ciF#E1 z83lpo5;Hza{i@p&yBrLL$JDWT%a6K6TfqGmjxEz_f$8X=7@XoRt7!beL>Tg&P{2J0Mo!C9f<#-eHd_abRMBzgqT0wV63a#v*!p?A zz#f2=kwLvyLbnCPUr3~=Eu@%nVq1MK9ZQ-HJC)@@h{vCvVvg$k%EWBA*d2$D<2dk- z44UvJKKok~jd zLXeX`9S?{(8fLC=eso%$y2o&LBJ#~$I=>S=GT?Gt6%=dLQtQ-0NTy%&jnb07=GGbB zf{5$<*oF|?>}4P@K2fII=DY!Y$JP?<;$v8pV~?$c7or>BIP`p8*rqtdygM)1q+%mr zR>01e|4}8@c!nMtOEhml8cNKKev~o?Ad<<%B<^+FK{C63ui^r!iQgsHCRDlGoxVei0qFlq{&b~UEeC&}P zF*);o^+?}Uk+M1N_4VLvr6w}Tjqw) z03~1N{R6r01GHv0%X-T#;cHovs!b6J)Y7Nja%*2&u3i!bM9zYKf`iH4y!%3E{3+9! zV4<;79cIujzlBKr&E71)l># zak%Ff8lcM-Bk)Vw_9PzbpLx(ry{t!{VbNYybGfhp7YXVmj4Q6?V948=*YZ`A+0wp< z+x=BwLRbS$g0HkRt^E);x9*QzW&Su$vB9P*r1cP1^7Q^PL3}m|jb2*E&}+W3gThbZ zOIMLy(bO!5`Wx4$D35)VTPD33k&UKjlt1@LY{Z3m29gzZ)*@|kZR)m(TGeU{PXw=` z`_A61Gz)0Dg^DpSrZI>VE&1MCg(DTcCcI$jmp-uDOUf#Y6NF^`3-umVhcu+Gmi7k{ z1Fvb#qYPn3B%YCLc9d}Y)<>X1R&PG7lh-e=8q$r#dD>wY@9rz7_K%Ms`QJ>X7|2cU zq)*nNsynK%EIt0*(IARI+@()wvHO|oGWGtSg6a;YQrW!BZ`mG)O5A^7YczSuW)BnB z_j+#`^cw&D`GtM8`0UYX=Qhv0t6P+&)Uuyw?M30?2Q1%5#fKH2bByHY8g`~vv zZ7pXkr^L|@qaP)z=CyFD^M>hN#dGFLGxakvL04&ZVm)pI5eV*DW$d-7Ct10zborV- z2ozq2LHwyols00_&d#N)Xhkhi`Hi&M<%Wvgd?ea~w1h7zLl=aZ)vdt}N}#Wsl$ z1X09VF$%`(Z|Turk5t8OMyRr+F|}wodF7}8%#L5Q#)VuE91tyao9po~n`P3uqKo$} z8{zyJ`CL5-_R-J^+pp0|kqynh$g^8^Z01!Lby}|g5MF~sbWZ|IQ`5OKQ!1vN<_*_$ z$^&lP5B6$$!VnN~ z#nHY~>Q&-y?up)^W-d~W-f_*;>Vm`zmYNDuP!N~VH#%(l`WtY5Z&fN~jus8K4%>Yn zkfY91{*IH&j#|^7#5~6&PcbMdvtnX zmk95i@~pdcCn51~Rkzm>0#h>AT_^-4%faErZJC_2;`O6KyB1ktMKHM90fm`nzgdnA zMA`M`_~y4+kwb@n%t#RKGiUtZuzYgkPA2a`lj>b16aQ(fnJ>^&xX=%w!JGD7pBw=& zHx=!vQCY1?HzrxgoP=JbcJa9IexfHcjD2M~(f`($pd~*S#F)~LQssxZK)%UbP{w(E z+Q!2FdqYLBvdER=F$0_?TdB|2Nq>q-E85Rvu116GrTUI8#{#{Jl*PK*F>CQ99hQ5Z zs9;HVeQ@Fe-6A=xBMaCx5a($@W1C~Y0Qji_3>q3)y2_|J*1ldXO-rrL{UF9>I01I0 z4^rBo)xUh)`_#%3=nzD5;85hhY9_<{73yYb+`aVT#8YUMkbKqXaG-xngYE`vf$}-R z8gUW+YUqP#4YhEsROKVuZti5Mlekj|Vi?(*x+VMEsNQVQ9YsqMGv%XKRnrJ=6jmmc zz0x)MomGoRIYgI)Tu8XGoVQ7*72D^Y@^sx^l;R##c!Kg!O( z=#n!Cl;&SK@|*)z`j8NDXelq*28s{ApmoW5-l0p5ImCPqMhT4+wMS-WS}r>-X2|<< zIc#?)OEc3O+TgSLTYsyv`+VPB56kq6xriCV;fk8zdZh)y~ik z^>e>e@q*EMOQ-T$(i^g$eN+)Y#RV16c0SLj*YzruS;oxxv~u)w*LKKGTI`3J0$noy za50zUi}4k;ZU*~r^`dim0=^W_tSiJj?xifYh+6XHkyL!Bl^S$p&wLFylfKpN6>=8& zCi`)kbqr}5Le9DmMcc5ivHYu11CrN~Tnf%Z*32}rHGnn;oZPHNr2PF$1k1fpPvh&~49{#Mb7kO_;--U$-h zh~0>)CPF~7l*!0BzO<( zPN~?T_Q;soaCacSsj)jpvasvUM01!o-9{-l1ua;KX1bRU=hch*&A6SaFtb$EIA=!V zc>XvF9bO?z3SkFehJPi7zHs0iWdQYaaoGKo;0VEJP_%TUTLhqdWwlB6c!mHlLX4Py zlASX)X*2KZCJ=2<^HT4^QM^BO5SoaNPBF7Xlm7hUZ_uQCNK(bHsFgIWRZ~a-90#VvBS02G(!@N?MAZ? zGthRtj6}YtT=sfiY$NU258P@W03PK^E$#k6Ol4(b6IhsssYB_UK4n7>&g+X%E}Z*~ Z^+`@ACGa@}`sa^}s-l)crJPyN{{Tqi0l5GG literal 0 HcmV?d00001 diff --git a/builtin-programs/draw/image.folk b/builtin-programs/draw/image.folk index 6f932b60..cca71ab2 100644 --- a/builtin-programs/draw/image.folk +++ b/builtin-programs/draw/image.folk @@ -35,6 +35,45 @@ When the gif library is /gifLib/ { When the collected results for {/loader/ is an image loader} are /loaders/ { + fn imageUrlCachePath {url} { + set cleanUrl [regsub {[?#].*$} $url ""] + set ext [file extension $cleanUrl] + set cachePath /tmp/[regsub -all {\W+} $url "_"] + if {$ext ne "" && ![string match "*$ext" $cachePath]} { + append cachePath $ext + } + return $cachePath + } + + fn imageUrlLocalFallback {url} { + if {[regexp {^https?://folk[.]computer/_media/logo[.]png([?#].*)?$} $url]} { + set path [file join [pwd] assets logo.png] + if {[file exists $path]} { return $path } + } + return "" + } + + fn imageDownloadUrl {url} { + set path [imageUrlCachePath $url] + if {[file exists $path] && [file size $path] > 0} { + return $path + } + + file delete -force $path + set tmp "$path.[pid].tmp" + try { + exec curl -fsSL --connect-timeout 10 --retry 2 -o $tmp $url + if {![file exists $tmp] || [file size $tmp] == 0} { + error "Downloaded empty image from $url" + } + file rename -force $tmp $path + } on error {e opts} { + file delete -force $tmp + return -options $opts $e + } + return $path + } + # Pass coerceToImage = 0 if the caller is willing to handle a Gif # object, not just a normal Image. fn loadImage {im {coerceToImage 1}} { @@ -45,9 +84,11 @@ When the collected results for {/loader/ is an image loader} are /loaders/ { set impath $im if {[string match "http*://*" $impath]} { - set im /tmp/[regsub -all {\W+} $impath "_"] - if {![file exists $im]} { - exec curl -s -L -o$im $impath + set fallback [imageUrlLocalFallback $impath] + if {$fallback ne ""} { + set im $fallback + } else { + set im [imageDownloadUrl $impath] } } set path [expr {[string index $im 0] eq "/" ? diff --git a/test/draw-image-url.folk b/test/draw-image-url.folk new file mode 100644 index 00000000..e637dc5e --- /dev/null +++ b/test/draw-image-url.folk @@ -0,0 +1,32 @@ +source builtin-programs/collect.folk +source builtin-programs/image/image-lib.folk +source builtin-programs/image/png-lib.folk +source builtin-programs/draw/color-map.folk +source builtin-programs/draw/image.folk + +When /someone/ wishes the GPU loads image /im/ as texture { + Claim the GPU has loaded image $im as texture 99 +} + +Assert! image-page has resolved geometry {width 0.2 height 0.1 left 0.2} +Assert! image-page has canvas canvas-id with width 400 height 300 +Assert! image-page has canvas projection {1 0 0 0 1 0 0 0 1} + +Wish image-page displays image "https://folk.computer/_media/logo.png" + +sleep 1 + +set errors [Query! /program/ has error /err/ with info /info/] +assert {[llength $errors] == 0} + +set loads [Query! /someone/ wishes the GPU loads image /im/ as texture] +assert {[llength $loads] == 1} + +set draws [Query! /someone/ wishes the GPU draws pipeline "image" onto canvas canvas-id with arguments /arguments/] +assert {[llength $draws] == 1} + +set arguments [dict get [lindex $draws 0] arguments] +assert {[lindex $arguments 2] == 99} +assert {[lindex $arguments 3] eq {0 0}} + +Exit! 0 From d9e7c20b4bdfbf997106c93c856cc9a0fdeebb63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Fri, 8 May 2026 09:42:38 -0400 Subject: [PATCH 18/20] Clean up draw spaces and texture init --- Makefile | 7 +- builtin-programs/decorations/outline.folk | 2 + builtin-programs/draw/connections.folk | 28 ++--- builtin-programs/draw/spaces.folk | 135 +++++++++++++++++++--- builtin-programs/gpu/canvases.folk | 3 +- builtin-programs/gpu/draw.folk | 1 + builtin-programs/gpu/gpu.folk | 10 ++ builtin-programs/gpu/textures.folk | 83 +++++++++---- builtin-programs/gpu/vma.folk | 22 ++++ builtin-programs/points-at.folk | 41 +++---- builtin-programs/web/textures.folk | 10 +- test/decorations.folk | 14 +++ test/draw-spaces.folk | 29 +++++ 13 files changed, 290 insertions(+), 95 deletions(-) diff --git a/Makefile b/Makefile index de3f75ae..63bb3ba4 100644 --- a/Makefile +++ b/Makefile @@ -115,16 +115,17 @@ kill-folk: fi FOLK_REMOTE_NODE ?= folk-live +FOLK_SYNC_IGNORES ?= $(shell git rev-parse --git-path ignores.tmp 2>/dev/null || printf '%s\n' .git/ignores.tmp) sync: ssh $(FOLK_REMOTE_NODE) -t \ 'cd ~/folk && git init > /dev/null && git ls-files --exclude-standard -oi --directory' \ - > .git/ignores.tmp || true - git ls-files --exclude-standard -oi --directory >> .git/ignores.tmp + > '$(FOLK_SYNC_IGNORES)' || true + git ls-files --exclude-standard -oi --directory >> '$(FOLK_SYNC_IGNORES)' rsync --timeout=15 -e "ssh -o StrictHostKeyChecking=no" \ --archive --delete --itemize-changes \ --exclude='/.git' \ - --exclude-from='.git/ignores.tmp' \ + --exclude-from='$(FOLK_SYNC_IGNORES)' \ --exclude='vendor/tracy/public/TracyClient.o' \ --include='vendor/tracy/public/***' \ --exclude='vendor/tracy/*' \ diff --git a/builtin-programs/decorations/outline.folk b/builtin-programs/decorations/outline.folk index 7708dce7..6fd0b0f5 100644 --- a/builtin-programs/decorations/outline.folk +++ b/builtin-programs/decorations/outline.folk @@ -16,6 +16,7 @@ When /someone/ wishes /thing/ is outlined /color/ { } When /someone/ wishes /thing/ is outlined /color/ with /...options/ { + if {![info exists options]} { set options [dict create] } Wish $thing is outlined with color $color {*}$options } @@ -23,6 +24,7 @@ When display /disp/ has width /displayWidth/ height /displayHeight/ &\ /thing/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ /disp/ has canvas projection for surface /surface/ /surfaceToClip/ &\ /someone/ wishes /thing/ is outlined with /...options/ { + if {![info exists options]} { set options [dict create] } set color [dict getdef $options color white] set outlineWidth [dict getdef $options width [dict getdef $options thickness [format "%sm" 0.01]]] set layer [dict getdef $options layer 2] diff --git a/builtin-programs/draw/connections.folk b/builtin-programs/draw/connections.folk index 5879bbb7..ecf79209 100644 --- a/builtin-programs/draw/connections.folk +++ b/builtin-programs/draw/connections.folk @@ -37,29 +37,25 @@ When /anyone/ wishes /source/ is dynamically connected to /sink/ from /from/ to Wish $source is dynamically connected to $sink with from $from to $to } -When the quad library is /quadLib/ &\ - the quad changer is /quadChange/ &\ - display /disp/ has width /displayWidth/ height /displayHeight/ &\ +When the draw space library is /drawSpaceLib/ &\ /source/ has quad /sourceQuad/ &\ /sink/ has quad /sinkQuad/ &\ /anyone/ wishes /source/ is connected to /sink/ with /...options/ { if {$source eq $sink} { return } - fn quadChange set fromSelector [dict getdef $options from centroid] set toSelector [dict getdef $options to centroid] - set sourceQuad [quadChange $sourceQuad "display $disp"] - set sinkQuad [quadChange $sinkQuad "display $disp"] - set from [drawSpaceQuadPoint $quadLib $sourceQuad $fromSelector] - set to [drawSpaceQuadPoint $quadLib $sinkQuad $toSelector] + set from [$drawSpaceLib quadPoint $sourceQuad $fromSelector] + set to [$drawSpaceLib quadPoint $sinkQuad $toSelector] set distance [drawSpaceVectorDistance $from $to] if {$distance == 0.0} { return } set surfaceHeight [drawSpacePhysicalLength [dict getdef $options surfaceHeight 6]] + set disp [$drawSpaceLib display] set connection [list connection $source $sink $fromSelector $toSelector $disp] Claim -keep 50ms $connection has quad \ - [drawSpaceSurfaceQuadBetween $quadLib "display $disp" $from $to $surfaceHeight] + [$drawSpaceLib surfaceQuadBetween $from $to $surfaceHeight] When $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ $disp has canvas projection for surface /surface/ /surfaceToClip/ { @@ -78,29 +74,25 @@ When the quad library is /quadLib/ &\ } } -When the quad library is /quadLib/ &\ - the quad changer is /quadChange/ &\ - display /disp/ has width /displayWidth/ height /displayHeight/ &\ +When the draw space library is /drawSpaceLib/ &\ /source/ has quad /sourceQuad/ &\ /sink/ has quad /sinkQuad/ &\ /anyone/ wishes /source/ is dynamically connected to /sink/ with /...options/ { if {$source eq $sink} { return } - fn quadChange set fromSelector [dict getdef $options from centroid] set toSelector [dict getdef $options to centroid] - set sourceQuad [quadChange $sourceQuad "display $disp"] - set sinkQuad [quadChange $sinkQuad "display $disp"] - set from [drawSpaceQuadPoint $quadLib $sourceQuad $fromSelector] - set to [drawSpaceQuadPoint $quadLib $sinkQuad $toSelector] + set from [$drawSpaceLib quadPoint $sourceQuad $fromSelector] + set to [$drawSpaceLib quadPoint $sinkQuad $toSelector] set distance [drawSpaceVectorDistance $from $to] if {$distance == 0.0} { return } set surfaceHeight [drawSpacePhysicalLength [dict getdef $options surfaceHeight 6]] + set disp [$drawSpaceLib display] set connection [list dynamic-connection $source $sink $fromSelector $toSelector $disp] Claim -keep 50ms $connection has quad \ - [drawSpaceSurfaceQuadBetween $quadLib "display $disp" $from $to $surfaceHeight] + [$drawSpaceLib surfaceQuadBetween $from $to $surfaceHeight] When $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ $disp has canvas projection for surface /surface/ /surfaceToClip/ { diff --git a/builtin-programs/draw/spaces.folk b/builtin-programs/draw/spaces.folk index dfacbde9..84933bfa 100644 --- a/builtin-programs/draw/spaces.folk +++ b/builtin-programs/draw/spaces.folk @@ -332,12 +332,127 @@ fn drawSpaceApplyHomography {H point} { list [expr {$hx / $hw}] [expr {$hy / $hw}] } +fn drawSpacePointInsidePolygon {point polygon} { + if {[llength $polygon] < 3} { return false } + + lassign $point x y + set inside false + set j [expr {[llength $polygon] - 1}] + for {set i 0} {$i < [llength $polygon]} {incr i} { + lassign [lindex $polygon $i] xi yi + lassign [lindex $polygon $j] xj yj + if {(($yi > $y) != ($yj > $y)) && + ($x < (($xj - $xi) * ($y - $yi) / ($yj - $yi)) + $xi)} { + set inside [expr {!$inside}] + } + set j $i + } + return $inside +} + fn drawSpaceMeterPoint {point} { lmap value $point { format "%sm" $value } } +proc drawSpaceMakeLib {quadLib poseLib quadChange disp displayWidth displayHeight displayIntrinsics} { + library create drawSpaceLib { + quadLib poseLib quadChange disp displayWidth displayHeight displayIntrinsics + } { + proc display {} { + variable disp + return $disp + } + + proc displaySpace {} { + variable disp + return "display $disp" + } + + proc displaySize {} { + variable displayWidth + variable displayHeight + list $displayWidth $displayHeight + } + + proc quad {q} { + variable quadChange + fn quadChange + quadChange $q [displaySpace] + } + + proc quadVertices {q} { + variable quadLib + $quadLib vertices [quad $q] + } + + proc quadSpace {q} { + variable quadLib + $quadLib space [quad $q] + } + + proc quadPoint {q selector} { + variable quadLib + drawSpaceQuadPoint $quadLib [quad $q] $selector + } + + proc quadSize {q} { + variable quadLib + drawSpaceQuadSize $quadLib [quad $q] + } + + proc quadSurfacePoint {q point} { + variable quadLib + drawSpaceQuadSurfacePoint $quadLib [quad $q] $point + } + + proc quadSurfaceRect {q x y width height} { + variable quadLib + drawSpaceQuadSurfaceRect $quadLib [quad $q] $x $y $width $height + } + + proc surfaceQuadBetween {from to height} { + variable quadLib + drawSpaceSurfaceQuadBetween $quadLib [displaySpace] $from $to $height + } + + proc project {point} { + variable poseLib + variable displayIntrinsics + variable displayWidth + variable displayHeight + $poseLib project $displayIntrinsics $displayWidth $displayHeight $point + } + + proc clipPoint {point} { + lassign [displaySize] width height + drawSpaceDisplayPixelToClip $width $height [project $point] + } + + proc quadPixelVertices {q} { + lmap vertex [quadVertices $q] { + project $vertex + } + } + + proc containsPixelPoint {q point} { + drawSpacePointInsidePolygon $point [quadPixelVertices $q] + } + } +} + +When the quad library is /quadLib/ &\ + the pose library is /poseLib/ &\ + the quad changer is /quadChange/ &\ + display /disp/ has width /displayWidth/ height /displayHeight/ &\ + display /disp/ has intrinsics /displayIntrinsics/ { + set drawSpaceLib [drawSpaceMakeLib $quadLib $poseLib $quadChange $disp \ + $displayWidth $displayHeight $displayIntrinsics] + Claim the draw space library is $drawSpaceLib + Claim the draw space library for display $disp is $drawSpaceLib +} + When /target/ has canvas /id/ with /...wiOptions/ &\ /target/ has canvas projection for surface /surface/ /surfaceToClip/ { set surfaceTarget [drawSpaceSurfaceTarget $target $surface] @@ -350,18 +465,11 @@ When /target/ has resolved geometry /geom/ &\ Claim $target has canvas projection for surface local $surfaceToClip } -When the quad library is /quadLib/ &\ - the pose library is /poseLib/ &\ - the quad changer is /quadChange/ &\ - display /disp/ has width /displayWidth/ height /displayHeight/ &\ - display /disp/ has intrinsics /displayIntrinsics/ &\ +When the draw space library is /drawSpaceLib/ &\ /thing/ has quad /quad/ { - fn quadChange - set surface [list surface of $thing] - set displayQuad [quadChange $quad "display $disp"] - lassign [$quadLib vertices $displayQuad] topLeft topRight bottomRight bottomLeft - lassign [drawSpaceQuadSize $quadLib $displayQuad] width height + lassign [$drawSpaceLib quadVertices $quad] topLeft topRight bottomRight bottomLeft + lassign [$drawSpaceLib quadSize $quad] width height set surfacePoints [list \ [list 0 0] \ @@ -371,8 +479,7 @@ When the quad library is /quadLib/ &\ set displayVertices [list $topLeft $topRight $bottomRight $bottomLeft] set clipPoints [lmap vertex $displayVertices { - drawSpaceDisplayPixelToClip $displayWidth $displayHeight \ - [$poseLib project $displayIntrinsics $displayWidth $displayHeight $vertex] + $drawSpaceLib clipPoint $vertex }] set pointPairs [list] @@ -383,8 +490,8 @@ When the quad library is /quadLib/ &\ } Claim $thing has physical drawing surface $surface \ - with width $width height $height space [$quadLib space $displayQuad] - Claim $disp has canvas projection for surface $surface \ + with width $width height $height space [$drawSpaceLib quadSpace $quad] + Claim [$drawSpaceLib display] has canvas projection for surface $surface \ [drawSpaceHomography $pointPairs] } diff --git a/builtin-programs/gpu/canvases.folk b/builtin-programs/gpu/canvases.folk index b0f4eba1..4c2908fa 100644 --- a/builtin-programs/gpu/canvases.folk +++ b/builtin-programs/gpu/canvases.folk @@ -1,6 +1,7 @@ When the GPU library is /gpuLib/ & the GPU draw library is /drawLib/ &\ the image library is /imageLib/ &\ - the GPU texture library for /drawLib/ is /gpuTextureLib/ { + the GPU texture library for /drawLib/ is /gpuTextureLib/ &\ + the GPU texture library /gpuTextureLib/ for /drawLib/ has initialized Vulkan state { set gpuc [C] $gpuc include $gpuc cflags -I./vendor diff --git a/builtin-programs/gpu/draw.folk b/builtin-programs/gpu/draw.folk index 15703525..4cf5b70a 100644 --- a/builtin-programs/gpu/draw.folk +++ b/builtin-programs/gpu/draw.folk @@ -1096,6 +1096,7 @@ When the GPU texture library for $drawLib is /gpuTextureLib/ { $gpuTextureLib textureManagerInit + Claim the GPU texture library $gpuTextureLib for $drawLib has initialized Vulkan state Claim display $display has width [$gpu getWidth] height [$gpu getHeight] set kGpu [tracy makeString "gpu"] diff --git a/builtin-programs/gpu/gpu.folk b/builtin-programs/gpu/gpu.folk index 4196b31b..29ecbf49 100644 --- a/builtin-programs/gpu/gpu.folk +++ b/builtin-programs/gpu/gpu.folk @@ -54,6 +54,11 @@ if {$useGlfw} { } set macos [expr {$::tcl_platform(os) eq "darwin"}] +set enableValidation false +if {[info exists ::env(FOLK_VULKAN_VALIDATION)]} { + set validationSetting [string tolower $::env(FOLK_VULKAN_VALIDATION)] + set enableValidation [expr {$validationSetting ni {0 false no off ""}}] +} if {$macos} { $gpuc cflags -I/opt/homebrew/include -L/opt/homebrew/lib } @@ -143,11 +148,16 @@ $gpuc proc init {bool useGlfw} void { VkInstanceCreateInfo createInfo = {0}; createInfo.sType = VK_STRUCTURE_TYPE_INSTANCE_CREATE_INFO; + $[if {$enableValidation} {subst -nocommands { const char* validationLayers[] = { "VK_LAYER_KHRONOS_validation" }; createInfo.enabledLayerCount = sizeof(validationLayers)/sizeof(validationLayers[0]); createInfo.ppEnabledLayerNames = validationLayers; + }} else {subst -nocommands { + createInfo.enabledLayerCount = 0; + createInfo.ppEnabledLayerNames = NULL; + }}] $[if {$macos} {subst -nocommands { const char* enabledExtensions[] = { diff --git a/builtin-programs/gpu/textures.folk b/builtin-programs/gpu/textures.folk index b0629a70..35fe1041 100644 --- a/builtin-programs/gpu/textures.folk +++ b/builtin-programs/gpu/textures.folk @@ -15,12 +15,11 @@ $gpuc code { #include "vk_mem_alloc.h" - void vmaInit(VkInstance instance, VkPhysicalDevice physicalDevice, VkDevice device, - PFN_vkGetInstanceProcAddr vkGetInstanceProcAddr, - PFN_vkGetDeviceProcAddr vkGetDeviceProcAddr, - PFN_vkGetPhysicalDeviceProperties vkGetPhysicalDeviceProperties, - PFN_vkGetPhysicalDeviceMemoryProperties vkGetPhysicalDeviceMemoryProperties); - VmaAllocator vmaGetAllocator(); + VmaAllocator vmaCreateFolkAllocator(VkInstance instance, VkPhysicalDevice physicalDevice, VkDevice device, + PFN_vkGetInstanceProcAddr vkGetInstanceProcAddr, + PFN_vkGetDeviceProcAddr vkGetDeviceProcAddr, + PFN_vkGetPhysicalDeviceProperties vkGetPhysicalDeviceProperties, + PFN_vkGetPhysicalDeviceMemoryProperties vkGetPhysicalDeviceMemoryProperties); } $gpuc include $gpuc include @@ -74,11 +73,27 @@ local proc vktry {call} { string map {\n " "} [csubst {{ # - http://roar11.com/2019/06/vulkan-textures-unbound/ $gpuc code { VkDevice device; + VmaAllocator textureAllocator = VK_NULL_HANDLE; + static PFN_vkCreateFence textureVkCreateFence = NULL; + static PFN_vkResetFences textureVkResetFences = NULL; + + static void loadTextureFenceProcs(void) { + if (vkGetDeviceProcAddr == NULL) { + volkInitialize(); + volkLoadInstanceOnly(*instance_ptr()); + } + FOLK_ENSURE(device != VK_NULL_HANDLE); + + textureVkCreateFence = (PFN_vkCreateFence)vkGetDeviceProcAddr(device, "vkCreateFence"); + textureVkResetFences = (PFN_vkResetFences)vkGetDeviceProcAddr(device, "vkResetFences"); + } + static void initPlaceholderTexture(); } $gpuc typedef int GpuTextureHandle defineVulkanHandleType $gpuc VkImage +defineVulkanHandleType $gpuc VkBuffer defineVulkanHandleType $gpuc VkDeviceMemory defineVulkanHandleType $gpuc VkImageView defineVulkanHandleType $gpuc VkSampler @@ -175,12 +190,12 @@ $gpuc proc textureManagerInit {} void { $[vktry {vkAllocateDescriptorSets(device, &allocInfo, textureDescriptorSet_ptr())}] } - // Initialize VMA allocator - vmaInit(*instance_ptr(), *physicalDevice_ptr(), device, - vkGetInstanceProcAddr, - vkGetDeviceProcAddr, - vkGetPhysicalDeviceProperties, - vkGetPhysicalDeviceMemoryProperties); + // Initialize this texture library's VMA allocator. + textureAllocator = vmaCreateFolkAllocator(*instance_ptr(), *physicalDevice_ptr(), device, + vkGetInstanceProcAddr, + vkGetDeviceProcAddr, + vkGetPhysicalDeviceProperties, + vkGetPhysicalDeviceMemoryProperties); initPlaceholderTexture(); } @@ -221,7 +236,7 @@ $gpuc proc createBuffer {VkDeviceSize size VkBufferUsageFlags usage VkMemoryProp allocInfo.flags = VMA_ALLOCATION_CREATE_HOST_ACCESS_SEQUENTIAL_WRITE_BIT | VMA_ALLOCATION_CREATE_MAPPED_BIT; } - VkResult res = vmaCreateBuffer(vmaGetAllocator(), &bufferInfo, &allocInfo, buffer, allocation, NULL); + VkResult res = vmaCreateBuffer(textureAllocator, &bufferInfo, &allocInfo, buffer, allocation, NULL); if (res != VK_SUCCESS) { fprintf(stderr, "Failed to create buffer with VMA: %d\\n", res); exit(1); @@ -229,11 +244,25 @@ $gpuc proc createBuffer {VkDeviceSize size VkBufferUsageFlags usage VkMemoryProp #ifdef TRACY_ENABLE VmaAllocationInfo vmaInfo; - vmaGetAllocationInfo(vmaGetAllocator(), *allocation, &vmaInfo); + vmaGetAllocationInfo(textureAllocator, *allocation, &vmaInfo); TracyCAlloc(*allocation, vmaInfo.size); #endif } +$gpuc proc copyTextureStagingBufferToImage {VmaAllocation allocation Image im size_t size} void { + void* data; + vmaMapMemory(textureAllocator, allocation, &data); + memcpy(im.data, data, size); + vmaUnmapMemory(textureAllocator, allocation); +} + +$gpuc proc destroyTextureBuffer {VkBuffer buffer VmaAllocation allocation} void { +#ifdef TRACY_ENABLE + TracyCFree(allocation); +#endif + vmaDestroyBuffer(textureAllocator, buffer, allocation); +} + # Texture allocation: $gpuc code [csubst { void createImage(uint32_t width, uint32_t height, @@ -264,7 +293,7 @@ $gpuc code [csubst { allocInfo.flags = VMA_ALLOCATION_CREATE_HOST_ACCESS_SEQUENTIAL_WRITE_BIT; } - VkResult res = vmaCreateImage(vmaGetAllocator(), &imageInfo, &allocInfo, image, allocation, NULL); + VkResult res = vmaCreateImage(textureAllocator, &imageInfo, &allocInfo, image, allocation, NULL); if (res != VK_SUCCESS) { fprintf(stderr, "Failed to create image with VMA: %d\\n", res); exit(1); @@ -272,7 +301,7 @@ $gpuc code [csubst { #ifdef TRACY_ENABLE VmaAllocationInfo vmaInfo; - vmaGetAllocationInfo(vmaGetAllocator(), *allocation, &vmaInfo); + vmaGetAllocationInfo(textureAllocator, *allocation, &vmaInfo); TracyCAlloc(*allocation, vmaInfo.size); #endif } @@ -308,12 +337,18 @@ $gpuc code { static __thread VkFence _fence = VK_NULL_HANDLE; } $gpuc proc getFence {} VkFence { + if (textureVkCreateFence == NULL || textureVkResetFences == NULL) { + loadTextureFenceProcs(); + } + FOLK_ENSURE(textureVkCreateFence != NULL); + FOLK_ENSURE(textureVkResetFences != NULL); + if (_fence == VK_NULL_HANDLE) { VkFenceCreateInfo fenceInfo = {0}; fenceInfo.sType = VK_STRUCTURE_TYPE_FENCE_CREATE_INFO; - $[vktry {vkCreateFence(device, &fenceInfo, NULL, &_fence)}] + $[vktry {textureVkCreateFence(device, &fenceInfo, NULL, &_fence)}] } else { - vkResetFences(device, 1, &_fence); + textureVkResetFences(device, 1, &_fence); } return _fence; } @@ -579,7 +614,7 @@ $gpuc proc copyImageToGpuTexture {Image im} GpuTextureHandle { // Copy im to stagingBuffer: { - void* data; vmaMapMemory(vmaGetAllocator(), stagingBufferAllocation, &data); + void* data; vmaMapMemory(textureAllocator, stagingBufferAllocation, &data); Image stagingIm = (Image) { .width = im.width, .height = im.height, .components = 4, @@ -587,7 +622,7 @@ $gpuc proc copyImageToGpuTexture {Image im} GpuTextureHandle { .data = data }; copyImageToRgba(im, stagingIm); - vmaUnmapMemory(vmaGetAllocator(), stagingBufferAllocation); + vmaUnmapMemory(textureAllocator, stagingBufferAllocation); } // Allocate a texture and texture block: @@ -663,7 +698,7 @@ $gpuc proc copyImageToGpuTexture {Image im} GpuTextureHandle { #ifdef TRACY_ENABLE TracyCFree(stagingBufferAllocation); #endif - vmaDestroyBuffer(vmaGetAllocator(), stagingBuffer, stagingBufferAllocation); + vmaDestroyBuffer(textureAllocator, stagingBuffer, stagingBufferAllocation); return block->handle; } @@ -720,7 +755,7 @@ $gpuc code { #ifdef TRACY_ENABLE TracyCFree(block->textureImageAllocation); #endif - vmaDestroyImage(vmaGetAllocator(), block->textureImage, block->textureImageAllocation); + vmaDestroyImage(textureAllocator, block->textureImage, block->textureImageAllocation); vkDestroySampler(device, block->textureSampler, NULL); vkDestroyImageView(device, block->textureImageView, NULL); @@ -782,8 +817,8 @@ $gpuc proc initPlaceholderTexture {} void { set gpuTextureLib [$gpuc compile] Claim the GPU texture library for $drawLib is $gpuTextureLib -# Wait until the library has been initialized by gpu.folk. -When display /any/ has width /any/ height /any/ { +# Wait until draw.folk has initialized this library's Vulkan state. +When the GPU texture library $gpuTextureLib for $drawLib has initialized Vulkan state { Wish the GPU runs frame prelude handler [list apply {{gpuTextureLib} { $gpuTextureLib processDeferredTextureOps }} $gpuTextureLib] diff --git a/builtin-programs/gpu/vma.folk b/builtin-programs/gpu/vma.folk index f17058a5..6f14b7d9 100644 --- a/builtin-programs/gpu/vma.folk +++ b/builtin-programs/gpu/vma.folk @@ -23,15 +23,35 @@ defineVulkanHandleType $vmac VkPhysicalDevice defineVulkanHandleType $vmac VkDevice $vmac code { extern "C" { +VmaAllocator vmaCreateFolkAllocator(VkInstance instance, VkPhysicalDevice physicalDevice, VkDevice device, + PFN_vkGetInstanceProcAddr vkGetInstanceProcAddr, + PFN_vkGetDeviceProcAddr vkGetDeviceProcAddr, + PFN_vkGetPhysicalDeviceProperties vkGetPhysicalDeviceProperties, + PFN_vkGetPhysicalDeviceMemoryProperties vkGetPhysicalDeviceMemoryProperties); + void vmaInit(VkInstance instance, VkPhysicalDevice physicalDevice, VkDevice device, PFN_vkGetInstanceProcAddr vkGetInstanceProcAddr, PFN_vkGetDeviceProcAddr vkGetDeviceProcAddr, PFN_vkGetPhysicalDeviceProperties vkGetPhysicalDeviceProperties, PFN_vkGetPhysicalDeviceMemoryProperties vkGetPhysicalDeviceMemoryProperties) { + allocator = vmaCreateFolkAllocator(instance, physicalDevice, device, + vkGetInstanceProcAddr, + vkGetDeviceProcAddr, + vkGetPhysicalDeviceProperties, + vkGetPhysicalDeviceMemoryProperties); +} + +VmaAllocator vmaCreateFolkAllocator(VkInstance instance, VkPhysicalDevice physicalDevice, VkDevice device, + PFN_vkGetInstanceProcAddr vkGetInstanceProcAddr, + PFN_vkGetDeviceProcAddr vkGetDeviceProcAddr, + PFN_vkGetPhysicalDeviceProperties vkGetPhysicalDeviceProperties, + PFN_vkGetPhysicalDeviceMemoryProperties vkGetPhysicalDeviceMemoryProperties) { volkInitialize(); volkLoadInstanceOnly(instance); volkLoadDevice(device); + VmaAllocator allocator = VK_NULL_HANDLE; + VmaAllocatorCreateInfo allocatorInfo = {0}; allocatorInfo.physicalDevice = physicalDevice; allocatorInfo.device = device; @@ -59,6 +79,8 @@ void vmaInit(VkInstance instance, VkPhysicalDevice physicalDevice, VkDevice devi fprintf(stderr, "Failed to create VMA allocator: %d\\n", res); exit(1); } + + return allocator; } VmaAllocator vmaGetAllocator() { diff --git a/builtin-programs/points-at.folk b/builtin-programs/points-at.folk index 6d404b30..b5315525 100644 --- a/builtin-programs/points-at.folk +++ b/builtin-programs/points-at.folk @@ -8,24 +8,19 @@ When when /rect/ points /direction/ at /someone/ /lambda/ with environment /e/ { Wish $rect points $direction with length 1 } -When the quad library is /quadLib/ &\ - the pose library is /poseLib/ &\ - the quad changer is /quadChange/ &\ - display /disp/ has width /displayWidth/ height /displayHeight/ &\ - display /disp/ has intrinsics /displayIntrinsics/ &\ +When the draw space library is /drawSpaceLib/ &\ /someone/ wishes /rect/ points /direction/ with length /l/ { When $rect has quad /quad/ { - fn quadChange set scale $l + set disp [$drawSpaceLib display] - set quad [quadChange $quad "display $disp"] - lassign [drawSpaceQuadSize $quadLib $quad] width height + lassign [$drawSpaceLib quadSize $quad] width height if {$direction eq "up"} { - set from [drawSpaceQuadPoint $quadLib $quad top] - set opposite [drawSpaceQuadPoint $quadLib $quad bottom] + set from [$drawSpaceLib quadPoint $quad top] + set opposite [$drawSpaceLib quadPoint $quad bottom] set to [drawSpaceVectorAdd $from \ [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] set color blue @@ -33,8 +28,8 @@ When the quad library is /quadLib/ &\ set toSurface [list [expr {$width / 2.0}] [expr {-$height * $scale}]] } elseif {$direction eq "left"} { - set from [drawSpaceQuadPoint $quadLib $quad left] - set opposite [drawSpaceQuadPoint $quadLib $quad right] + set from [$drawSpaceLib quadPoint $quad left] + set opposite [$drawSpaceLib quadPoint $quad right] set to [drawSpaceVectorAdd $from \ [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] set color gold @@ -42,8 +37,8 @@ When the quad library is /quadLib/ &\ set toSurface [list [expr {-$width * $scale}] [expr {$height / 2.0}]] } elseif {$direction eq "right"} { - set from [drawSpaceQuadPoint $quadLib $quad right] - set opposite [drawSpaceQuadPoint $quadLib $quad left] + set from [$drawSpaceLib quadPoint $quad right] + set opposite [$drawSpaceLib quadPoint $quad left] set to [drawSpaceVectorAdd $from \ [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] set color red @@ -51,8 +46,8 @@ When the quad library is /quadLib/ &\ set toSurface [list [expr {$width * (1.0 + $scale)}] [expr {$height / 2.0}]] } elseif {$direction eq "down"} { - set from [drawSpaceQuadPoint $quadLib $quad bottom] - set opposite [drawSpaceQuadPoint $quadLib $quad top] + set from [$drawSpaceLib quadPoint $quad bottom] + set opposite [$drawSpaceLib quadPoint $quad top] set to [drawSpaceVectorAdd $from \ [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] set color white @@ -67,22 +62,12 @@ When the quad library is /quadLib/ &\ # The hit test still happens in display pixels, but drawing now # stays in the rect's extended physical surface. - set fromPixel [$poseLib project $displayIntrinsics \ - $displayWidth $displayHeight \ - $from] - set toPixel [$poseLib project $displayIntrinsics \ - $displayWidth $displayHeight \ - $to] + set toPixel [$drawSpaceLib project $to] When /target/ has quad /q2/ { if {$target eq $rect} { return } - set displayVertices [lmap v [$quadLib vertices [quadChange $q2 "display $disp"]] { - $poseLib project $displayIntrinsics \ - $displayWidth $displayHeight $v - }] - - if {[::math::geometry::pointInsidePolygon $toPixel $displayVertices]} { + if {[$drawSpaceLib containsPixelPoint $q2 $toPixel]} { Claim -keep 50ms $rect points $direction at $target Claim -keep 50ms $rect points $direction with length $l at $target diff --git a/builtin-programs/web/textures.folk b/builtin-programs/web/textures.folk index 3bdd42bf..f0771f5c 100644 --- a/builtin-programs/web/textures.folk +++ b/builtin-programs/web/textures.folk @@ -2,6 +2,7 @@ When the GPU library is /gpuLib/ & the image library is /imageLib/ &\ the GPU draw library is /drawLib/ &\ the GPU VMA DLL is /vmaDll/ &\ the GPU texture library for /drawLib/ is /gpuTextureLib/ &\ + the GPU texture library /gpuTextureLib/ for /drawLib/ has initialized Vulkan state &\ display /any/ has width /any/ height /any/ { set cc [C] $cc endcflags -lpng @@ -14,8 +15,6 @@ When the GPU library is /gpuLib/ & the image library is /imageLib/ &\ #include "vk_mem_alloc.h" - VmaAllocator vmaGetAllocator(); - VkDevice device; } @@ -135,13 +134,10 @@ When the GPU library is /gpuLib/ & the image library is /imageLib/ &\ vkWaitForFences(device, 1, &fence, VK_TRUE, UINT64_MAX); // Copy staging buffer back to CPU - void* data; - vmaMapMemory(vmaGetAllocator(), stagingBufferAllocation, &data); - memcpy(im.data, data, stagingBufferSize); - vmaUnmapMemory(vmaGetAllocator(), stagingBufferAllocation); + copyTextureStagingBufferToImage(stagingBufferAllocation, im, stagingBufferSize); // Cleanup staging buffer - vmaDestroyBuffer(vmaGetAllocator(), stagingBuffer, stagingBufferAllocation); + destroyTextureBuffer(stagingBuffer, stagingBufferAllocation); return im; } diff --git a/test/decorations.folk b/test/decorations.folk index 2973588f..e0e1353a 100644 --- a/test/decorations.folk +++ b/test/decorations.folk @@ -17,16 +17,22 @@ assert {[dict get $options anchor] eq "center"} assert {[dict get $options font] eq "PTSans-Regular"} set thing test-thing +set plainThing test-plain-outline set disp test-display set surface test-surface +set plainSurface test-plain-surface set surfaceTarget [drawSpaceSurfaceTarget $disp $surface] +set plainSurfaceTarget [drawSpaceSurfaceTarget $disp $plainSurface] Assert! display $disp has width 100 height 100 Assert! $thing has physical drawing surface $surface with width 0.2 height 0.1 space test-space +Assert! $plainThing has physical drawing surface $plainSurface with width 0.3 height 0.2 space test-space Assert! $disp has canvas projection for surface $surface {{1 0 0} {0 1 0} {0 0 1}} +Assert! $disp has canvas projection for surface $plainSurface {{1 0 0} {0 1 0} {0 0 1}} Wish $thing is labelled "hello" with color cyan Wish $thing is outlined red with thickness 0.5 layer 7 +Wish $plainThing is outlined blue sleep 1 @@ -50,4 +56,12 @@ assert {[dict get $drawOptions layer] == 7} assert {abs([dict get $drawOptions width] - 0.005) < 1e-9} assert {[dict get $drawOptions points] eq {{0.0 0.0} {0.2 0.0} {0.2 0.1} {0.0 0.1} {0.0 0.0}}} +set lineDraws [Query! /someone/ wishes to draw a line onto $plainSurfaceTarget with /...drawOptions/] +assert {[llength $lineDraws] == 1} +set drawOptions [dict get [lindex $lineDraws 0] drawOptions] +assert {[dict get $drawOptions color] eq "blue"} +assert {[dict get $drawOptions layer] == 2} +assert {abs([dict get $drawOptions width] - 0.01) < 1e-9} +assert {[dict get $drawOptions points] eq {{0.0 0.0} {0.3 0.0} {0.3 0.2} {0.0 0.2} {0.0 0.0}}} + Exit! 0 diff --git a/test/draw-spaces.folk b/test/draw-spaces.folk index 25ef3e85..20ff5b74 100644 --- a/test/draw-spaces.folk +++ b/test/draw-spaces.folk @@ -17,6 +17,21 @@ proc fakeQuadLib {cmd args} { } } +proc fakePoseLib {cmd intrinsics width height point} { + switch -- $cmd { + project { + list [lindex $point 0] [lindex $point 1] + } + default { + error "unknown fakePoseLib command $cmd" + } + } +} + +proc fakeQuadChange {q targetSpace} { + fakeQuadLib create $targetSpace [fakeQuadLib vertices $q] +} + set l [drawSpacePhysicalLength 3] assert {abs($l - 0.03) < 1e-9} @@ -77,4 +92,18 @@ assert {$bottomLeft eq {1.0 1.5 0.0}} assert {[drawSpaceMeterPoint {0 1.5}] eq {0m 1.5m}} +set drawSpaceLib [drawSpaceMakeLib fakeQuadLib fakePoseLib fakeQuadChange test 100 50 {}] +assert {[$drawSpaceLib display] eq {test}} +assert {[$drawSpaceLib displaySpace] eq {display test}} +assert {[$drawSpaceLib quadPoint $q top] eq {2.0 0.0 0.0}} +lassign [$drawSpaceLib quadSize $q] width height +assert {abs($width - 4.0) < 1e-9} +assert {abs($height - 2.0) < 1e-9} +assert {[$drawSpaceLib project {50 25 0}] eq {50 25}} +set clipPoint [$drawSpaceLib clipPoint {50 25 0}] +assert {abs([lindex $clipPoint 0]) < 1e-9} +assert {abs([lindex $clipPoint 1]) < 1e-9} +assert {[$drawSpaceLib containsPixelPoint $q {2 1}]} +assert {![$drawSpaceLib containsPixelPoint $q {5 1}]} + Exit! 0 From 3e6dae93196cc90204268426c5baa18c661678c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Wed, 13 May 2026 13:24:23 -0400 Subject: [PATCH 19/20] Add shared PI and TAU constants --- builtin-programs/draw/arc.folk | 23 +++++++++++------------ builtin-programs/draw/shapes.folk | 4 ++-- lib/math.tcl | 3 +++ test/draw-arc.folk | 3 +++ test/draw-shapes.folk | 10 ++++++++++ 5 files changed, 29 insertions(+), 14 deletions(-) create mode 100644 test/draw-shapes.folk diff --git a/builtin-programs/draw/arc.folk b/builtin-programs/draw/arc.folk index f41737e4..31df70ef 100644 --- a/builtin-programs/draw/arc.folk +++ b/builtin-programs/draw/arc.folk @@ -1,18 +1,18 @@ # Example # When the clock time is /t/ { # # Draw a spinning cyan arc -# set spinAngle [expr {fmod($t, 6.28318)}] +# set spinAngle [expr {fmod($t, $::TAU)}] # # Wish to draw an arc onto $this with \ # center {0.05 0.05} \ # radius 0.04 \ # thickness 0.005 \ # start $spinAngle \ -# arclen 3.14159 \ +# arclen $::PI \ # color "cyan" # } -Wish the GPU compiles pipeline "arc" { +Wish the GPU compiles pipeline "arc" [list \ {vec2 viewport mat3 surfaceToClip vec2 center float radius float thickness float start float arclen vec4 color} { float r = radius + thickness; @@ -28,31 +28,30 @@ Wish the GPU compiles pipeline "arc" { vec3 v = surfaceToClip * vec3(vertices[gl_VertexIndex], 1.0); return vec4(v.xy / v.z, 0.0, 1.0); - } { + } [subst { vec2 clipXy = (gl_FragCoord.xy / viewport) * 2.0 - 1.0; vec3 surfaceXy = inverse(surfaceToClip) * vec3(clipXy, 1.0); surfaceXy /= surfaceXy.z; - float M_TWO_PI = 6.283185307179586; - float c_start = clamp(start, 0.0, M_TWO_PI); - float c_arclen = clamp(arclen, 0.0, M_TWO_PI); + const float TAU = $::TAU; + float c_start = clamp(start, 0.0, TAU); + float c_arclen = clamp(arclen, 0.0, TAU); float dist = length(surfaceXy.xy - center) - radius; float angle = atan(-(surfaceXy.y - center.y), surfaceXy.x - center.x); - angle = (angle < 0.0) ? (angle + M_TWO_PI) : angle; + angle = (angle < 0.0) ? (angle + TAU) : angle; float end = c_start + c_arclen; if (dist < thickness && dist > 0.0) { - if ((end < M_TWO_PI && angle > c_start && angle < end) || - (end >= M_TWO_PI && (angle > c_start || angle < end - M_TWO_PI))) { + if ((end < TAU && angle > c_start && angle < end) || + (end >= TAU && (angle > c_start || angle < end - TAU))) { return color; } } return vec4(0.0); - } -} + }]] When the color map is /colorMap/ &\ /p/ has canvas /id/ with /...wiOptions/ &\ diff --git a/builtin-programs/draw/shapes.folk b/builtin-programs/draw/shapes.folk index e697f6a4..b1a138ce 100644 --- a/builtin-programs/draw/shapes.folk +++ b/builtin-programs/draw/shapes.folk @@ -122,7 +122,7 @@ proc drawShapeRegularPolygon {center radius sides radians} { lassign $center cx cy set points [list] for {set i 0} {$i < $sides} {incr i} { - set theta [expr {$radians + $i * 2.0 * 3.141592653589793 / $sides - 1.5707963267948966}] + set theta [expr {$radians + $i * $::TAU / $sides - $::PI / 2.0}] lappend points [list [expr {$cx + $radius * cos($theta)}] \ [expr {$cy + $radius * sin($theta)}]] } @@ -311,7 +311,7 @@ Claim $this has demo { Wish $this draws text "rect" with color cyan offset [list [expr {$baseX + $dx * 3}] [expr {$baseY - 0.018}]] scale 0.004 Wish $this draws a triangle with color skyblue radius 0.012 thickness 0.001 offset [list $baseX $baseY] - Wish $this draws a square with color green radius 0.012 thickness 0.0015 radians 0.785398 offset [list [expr {$baseX + $dx}] $baseY] + Wish $this draws a square with color green radius 0.012 thickness 0.0015 radians [expr {$::PI / 4.0}] offset [list [expr {$baseX + $dx}] $baseY] Wish $this draws a pentagon with color gold radius 0.012 filled true offset [list [expr {$baseX + $dx * 2}] $baseY] Wish $this draws a rect with width 0.026 height 0.014 color cyan radians 0.4 offset [list [expr {$baseX + $dx * 3}] $baseY] diff --git a/lib/math.tcl b/lib/math.tcl index a9161a4a..f4bf016a 100644 --- a/lib/math.tcl +++ b/lib/math.tcl @@ -3,6 +3,9 @@ # This file provides global math datatypes and utilities. # +set ::PI 3.14159 +set ::TAU 6.28318 + namespace eval ::vec2 { proc add {a b} { list [+ [lindex $a 0] [lindex $b 0]] [+ [lindex $a 1] [lindex $b 1]] diff --git a/test/draw-arc.folk b/test/draw-arc.folk index 2587530c..75037021 100644 --- a/test/draw-arc.folk +++ b/test/draw-arc.folk @@ -1,6 +1,9 @@ source builtin-programs/draw/arc.folk source builtin-programs/draw/spaces.folk +assert {$::PI == 3.14159} +assert {$::TAU == 6.28318} + set options [drawSpaceNormalizeOptions arc { center {3 4cm} radius 3 diff --git a/test/draw-shapes.folk b/test/draw-shapes.folk new file mode 100644 index 00000000..b8106d71 --- /dev/null +++ b/test/draw-shapes.folk @@ -0,0 +1,10 @@ +source builtin-programs/draw/shapes.folk + +set points [drawShapeRegularPolygon {0 0} 1 4 0] + +assert {abs([lindex $points 0 0]) < 0.00001} +assert {abs([lindex $points 0 1] + 1.0) < 0.00001} +assert {abs([lindex $points 1 0] - 1.0) < 0.00001} +assert {abs([lindex $points 1 1]) < 0.00001} + +Exit! 0 From 3bc7285db5d25e04bd8ee0b5bb0617dad73d1802 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9s=20Cuervo?= Date: Wed, 13 May 2026 17:13:16 -0400 Subject: [PATCH 20/20] Stabilize live draw helper usage --- builtin-programs/draw/connections.folk | 92 ++++++++++++----- builtin-programs/draw/hit-targets.folk | 134 +++++++++++++++++++++---- builtin-programs/draw/shapes.folk | 26 ++--- builtin-programs/draw/spaces.folk | 27 ++++- builtin-programs/mask-tags.folk | 11 +- builtin-programs/points-at.folk | 56 ++++++++--- builtin-programs/title.folk | 4 +- 7 files changed, 272 insertions(+), 78 deletions(-) diff --git a/builtin-programs/draw/connections.folk b/builtin-programs/draw/connections.folk index ecf79209..65c84e53 100644 --- a/builtin-programs/draw/connections.folk +++ b/builtin-programs/draw/connections.folk @@ -2,7 +2,7 @@ # Wish $tag is connected to $tag2 # Wish $tag is dynamically connected to $tag2 -proc drawConnectionArrowPoints {x y radius} { +fn drawConnectionArrowPoints {x y radius} { set baseX [expr {$x - $radius}] set tipX [expr {$x + $radius}] set spread [expr {$radius * 0.8}] @@ -11,13 +11,55 @@ proc drawConnectionArrowPoints {x y radius} { [list $baseX [expr {$y + $spread}]] } -proc drawConnectionDrawArrow {disp surface x y radius color layer} { +fn drawConnectionPhysicalLength {value} { + if {[llength $value] != 1} { + error "draw/connections: expected a scalar physical length, got $value" + } + + set unit "" + set amount $value + foreach suffix {mm cm m} { + if {[string match *$suffix $value]} { + set unit $suffix + set amount [string range $value 0 end-[string length $suffix]] + break + } + } + + if {![string is double -strict $amount]} { + error "draw/connections: invalid physical length $value" + } + + switch -- $unit { + "" - cm { return [expr {double($amount) * 0.01}] } + mm { return [expr {double($amount) * 0.001}] } + m { return [expr {double($amount)}] } + default { error "draw/connections: invalid physical unit $unit" } + } +} + +fn drawConnectionMeterPoint {point} { + lmap value $point { + format "%sm" $value + } +} + +fn drawConnectionVectorDistance {a b} { + set sum 0.0 + foreach av $a bv $b { + set d [expr {$av - $bv}] + set sum [expr {$sum + $d * $d}] + } + expr {sqrt($sum)} +} + +fn drawConnectionDrawArrow {disp surface x y radius color layer} { if {$radius <= 0.0} { return } lassign [drawConnectionArrowPoints $x $y $radius] p0 p1 p2 Wish to draw a triangle onto $disp in surface $surface with \ - p0 [drawSpaceMeterPoint $p0] \ - p1 [drawSpaceMeterPoint $p1] \ - p2 [drawSpaceMeterPoint $p2] \ + p0 [drawConnectionMeterPoint $p0] \ + p1 [drawConnectionMeterPoint $p1] \ + p2 [drawConnectionMeterPoint $p2] \ color $color layer $layer } @@ -37,10 +79,10 @@ When /anyone/ wishes /source/ is dynamically connected to /sink/ from /from/ to Wish $source is dynamically connected to $sink with from $from to $to } -When the draw space library is /drawSpaceLib/ &\ +When -atomically /anyone/ wishes /source/ is connected to /sink/ with /...options/ &\ + the draw space library is /drawSpaceLib/ &\ /source/ has quad /sourceQuad/ &\ - /sink/ has quad /sinkQuad/ &\ - /anyone/ wishes /source/ is connected to /sink/ with /...options/ { + /sink/ has quad /sinkQuad/ { if {$source eq $sink} { return } set fromSelector [dict getdef $options from centroid] @@ -48,36 +90,36 @@ When the draw space library is /drawSpaceLib/ &\ set from [$drawSpaceLib quadPoint $sourceQuad $fromSelector] set to [$drawSpaceLib quadPoint $sinkQuad $toSelector] - set distance [drawSpaceVectorDistance $from $to] + set distance [drawConnectionVectorDistance $from $to] if {$distance == 0.0} { return } - set surfaceHeight [drawSpacePhysicalLength [dict getdef $options surfaceHeight 6]] + set surfaceHeight [drawConnectionPhysicalLength [dict getdef $options surfaceHeight 6]] set disp [$drawSpaceLib display] set connection [list connection $source $sink $fromSelector $toSelector $disp] Claim -keep 50ms $connection has quad \ [$drawSpaceLib surfaceQuadBetween $from $to $surfaceHeight] - When $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + When -atomically $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ $disp has canvas projection for surface /surface/ /surfaceToClip/ { set color [dict getdef $options color grey] set layer [dict getdef $options layer 0] set lineWidth [dict getdef $options width 0.2] - set arrowRadius [drawSpacePhysicalLength [dict getdef $options arrowRadius 2]] + set arrowRadius [drawConnectionPhysicalLength [dict getdef $options arrowRadius 2]] set y [expr {$height / 2.0}] set mid [expr {$width / 2.0}] Wish to draw a line onto $disp in surface $surface with \ - points [list [drawSpaceMeterPoint [list 0 $y]] \ - [drawSpaceMeterPoint [list $width $y]]] \ + points [list [drawConnectionMeterPoint [list 0 $y]] \ + [drawConnectionMeterPoint [list $width $y]]] \ width $lineWidth color $color layer $layer drawConnectionDrawArrow $disp $surface $mid $y $arrowRadius $color $layer } } -When the draw space library is /drawSpaceLib/ &\ +When -atomically /anyone/ wishes /source/ is dynamically connected to /sink/ with /...options/ &\ + the draw space library is /drawSpaceLib/ &\ /source/ has quad /sourceQuad/ &\ - /sink/ has quad /sinkQuad/ &\ - /anyone/ wishes /source/ is dynamically connected to /sink/ with /...options/ { + /sink/ has quad /sinkQuad/ { if {$source eq $sink} { return } set fromSelector [dict getdef $options from centroid] @@ -85,28 +127,28 @@ When the draw space library is /drawSpaceLib/ &\ set from [$drawSpaceLib quadPoint $sourceQuad $fromSelector] set to [$drawSpaceLib quadPoint $sinkQuad $toSelector] - set distance [drawSpaceVectorDistance $from $to] + set distance [drawConnectionVectorDistance $from $to] if {$distance == 0.0} { return } - set surfaceHeight [drawSpacePhysicalLength [dict getdef $options surfaceHeight 6]] + set surfaceHeight [drawConnectionPhysicalLength [dict getdef $options surfaceHeight 6]] set disp [$drawSpaceLib display] set connection [list dynamic-connection $source $sink $fromSelector $toSelector $disp] Claim -keep 50ms $connection has quad \ [$drawSpaceLib surfaceQuadBetween $from $to $surfaceHeight] - When $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + When -atomically $connection has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ $disp has canvas projection for surface /surface/ /surfaceToClip/ { set color [dict getdef $options color white] set layer [dict getdef $options layer 0] set lineWidth [dict getdef $options width 0.1] - set speed [drawSpacePhysicalLength [dict getdef $options speed 12]] - set spacing [drawSpacePhysicalLength [dict getdef $options spacing 5]] - set maxSize [drawSpacePhysicalLength [dict getdef $options maxsize 2.5]] + set speed [drawConnectionPhysicalLength [dict getdef $options speed 12]] + set spacing [drawConnectionPhysicalLength [dict getdef $options spacing 5]] + set maxSize [drawConnectionPhysicalLength [dict getdef $options maxsize 2.5]] set y [expr {$height / 2.0}] Wish to draw a line onto $disp in surface $surface with \ - points [list [drawSpaceMeterPoint [list 0 $y]] \ - [drawSpaceMeterPoint [list $width $y]]] \ + points [list [drawConnectionMeterPoint [list 0 $y]] \ + [drawConnectionMeterPoint [list $width $y]]] \ width $lineWidth color $color layer $layer When the clock time is /t/ { diff --git a/builtin-programs/draw/hit-targets.folk b/builtin-programs/draw/hit-targets.folk index a2793d4e..6d784244 100644 --- a/builtin-programs/draw/hit-targets.folk +++ b/builtin-programs/draw/hit-targets.folk @@ -2,11 +2,11 @@ # quad. They are real quad-backed objects, so the normal drawing-space and # pointing APIs can see them. -proc drawHitTargetTruthy {value} { +fn drawHitTargetTruthy {value} { expr {$value in {1 true yes on}} } -proc drawHitTargetName {options} { +fn drawHitTargetName {options} { if {[dict exists $options name]} { return [dict get $options name] } @@ -16,14 +16,108 @@ proc drawHitTargetName {options} { return 0 } -proc drawHitTargetId {parent options} { +fn drawHitTargetId {parent options} { if {[dict exists $options id]} { return [dict get $options id] } list hit target of $parent [drawHitTargetName $options] } -proc drawHitTargetScalar {value extent} { +fn drawHitTargetPhysicalLength {value} { + if {[llength $value] != 1} { + error "draw/hit-targets: expected a scalar physical length, got $value" + } + + set unit "" + set amount $value + foreach suffix {mm cm m} { + if {[string match *$suffix $value]} { + set unit $suffix + set amount [string range $value 0 end-[string length $suffix]] + break + } + } + + if {![string is double -strict $amount]} { + error "draw/hit-targets: invalid physical length $value" + } + + switch -- $unit { + "" - cm { return [expr {double($amount) * 0.01}] } + mm { return [expr {double($amount) * 0.001}] } + m { return [expr {double($amount)}] } + default { error "draw/hit-targets: invalid physical unit $unit" } + } +} + +fn drawHitTargetMeterPoint {point} { + lmap value $point { + format "%sm" $value + } +} + +fn drawHitTargetVectorAdd {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av + $bv}] + } + return $out +} + +fn drawHitTargetVectorDistance {a b} { + set sum 0.0 + foreach av $a bv $b { + set d [expr {$av - $bv}] + set sum [expr {$sum + $d * $d}] + } + expr {sqrt($sum)} +} + +fn drawHitTargetVectorMix {a b t} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av + ($bv - $av) * $t}] + } + return $out +} + +fn drawHitTargetQuadSize {quadLib quad} { + lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + + set topWidth [drawHitTargetVectorDistance $topLeft $topRight] + set bottomWidth [drawHitTargetVectorDistance $bottomLeft $bottomRight] + set rightHeight [drawHitTargetVectorDistance $topRight $bottomRight] + set leftHeight [drawHitTargetVectorDistance $topLeft $bottomLeft] + + list [expr {($topWidth + $bottomWidth) / 2.0}] \ + [expr {($rightHeight + $leftHeight) / 2.0}] +} + +fn drawHitTargetQuadSurfacePoint {quadLib quad point} { + lassign [drawHitTargetQuadSize $quadLib $quad] width height + if {$width == 0.0 || $height == 0.0} { + error "draw/hit-targets: cannot map point through zero-sized quad" + } + + lassign [$quadLib vertices $quad] topLeft topRight bottomRight bottomLeft + lassign $point x y + set tx [expr {$x / $width}] + set ty [expr {$y / $height}] + + set top [drawHitTargetVectorMix $topLeft $topRight $tx] + set bottom [drawHitTargetVectorMix $bottomLeft $bottomRight $tx] + drawHitTargetVectorMix $top $bottom $ty +} + +fn drawHitTargetQuadSurfaceRect {quadLib quad x y width height} { + $quadLib create [$quadLib space $quad] [list \ + [drawHitTargetQuadSurfacePoint $quadLib $quad [list $x $y]] \ + [drawHitTargetQuadSurfacePoint $quadLib $quad [list [expr {$x + $width}] $y]] \ + [drawHitTargetQuadSurfacePoint $quadLib $quad [list [expr {$x + $width}] [expr {$y + $height}]]] \ + [drawHitTargetQuadSurfacePoint $quadLib $quad [list $x [expr {$y + $height}]]]] +} + +fn drawHitTargetScalar {value extent} { if {[string match *% $value]} { set pct [string range $value 0 end-1] if {![string is double -strict $pct]} { @@ -31,10 +125,10 @@ proc drawHitTargetScalar {value extent} { } return [expr {double($pct) / 100.0 * $extent}] } - drawSpacePhysicalLength $value + drawHitTargetPhysicalLength $value } -proc drawHitTargetPoint {point parentWidth parentHeight} { +fn drawHitTargetPoint {point parentWidth parentHeight} { if {[llength $point] != 2} { error "draw/hit-targets: expected a 2D point, got $point" } @@ -42,7 +136,7 @@ proc drawHitTargetPoint {point parentWidth parentHeight} { [drawHitTargetScalar [lindex $point 1] $parentHeight] } -proc drawHitTargetOffset {offset parentWidth parentHeight} { +fn drawHitTargetOffset {offset parentWidth parentHeight} { if {$offset eq "" || $offset eq "center"} { return {0 0} } @@ -83,7 +177,7 @@ proc drawHitTargetOffset {offset parentWidth parentHeight} { error "draw/hit-targets: expected offset like {x y} or {right 50%}, got $offset" } -proc drawHitTargetRect {options parentWidth parentHeight} { +fn drawHitTargetRect {options parentWidth parentHeight} { set defaultSize [dict getdef $options size 5] set rectWidth [drawHitTargetScalar [dict getdef $options width $defaultSize] $parentWidth] set rectHeight [drawHitTargetScalar \ @@ -119,7 +213,7 @@ proc drawHitTargetRect {options parentWidth parentHeight} { } if {[dict exists $options offset]} { - set center [drawSpaceVectorAdd $center \ + set center [drawHitTargetVectorAdd $center \ [drawHitTargetOffset [dict get $options offset] $parentWidth $parentHeight]] } @@ -129,13 +223,13 @@ proc drawHitTargetRect {options parentWidth parentHeight} { $rectWidth $rectHeight } -proc drawHitTargetDrawHighlight {disp surface width height options} { +fn drawHitTargetDrawHighlight {disp surface width height options} { set points [list \ - [drawSpaceMeterPoint {0 0}] \ - [drawSpaceMeterPoint [list $width 0]] \ - [drawSpaceMeterPoint [list $width $height]] \ - [drawSpaceMeterPoint [list 0 $height]] \ - [drawSpaceMeterPoint {0 0}]] + [drawHitTargetMeterPoint {0 0}] \ + [drawHitTargetMeterPoint [list $width 0]] \ + [drawHitTargetMeterPoint [list $width $height]] \ + [drawHitTargetMeterPoint [list 0 $height]] \ + [drawHitTargetMeterPoint {0 0}]] set color [dict getdef $options highlightColor [dict getdef $options color yellow]] set thickness [dict getdef $options thickness [dict getdef $options outlineWidth 0.2]] @@ -153,15 +247,15 @@ proc drawHitTargetDrawHighlight {disp surface width height options} { } } -proc drawHitTargetClaim {quadLib parent parentQuad options} { +fn drawHitTargetClaim {quadLib parent parentQuad options} { set target [drawHitTargetId $parent $options] set name [drawHitTargetName $options] set index [dict getdef $options index $name] - lassign [drawSpaceQuadSize $quadLib $parentQuad] parentWidth parentHeight + lassign [drawHitTargetQuadSize $quadLib $parentQuad] parentWidth parentHeight lassign [drawHitTargetRect $options $parentWidth $parentHeight] x y width height - set targetQuad [drawSpaceQuadSurfaceRect $quadLib $parentQuad $x $y $width $height] + set targetQuad [drawHitTargetQuadSurfaceRect $quadLib $parentQuad $x $y $width $height] Claim -keep 50ms $target has quad $targetQuad Claim -keep 50ms $parent has child surface $target \ with name $name index $index x $x y $y width $width height $height @@ -207,10 +301,10 @@ Claim $this has demo { highlight true color cyan When $this has hit target /target/ with name /name/ /...options/ &\ - /target/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ + /target/ has physical drawing surface /surface/ with width /width/ height /height/ space /space/ &\ /disp/ has canvas projection for surface /surface/ /surfaceToClip/ { Wish to draw text onto $disp in surface $surface with \ - position [drawSpaceMeterPoint [list [expr {$width / 2.0}] [expr {$height / 2.0}]]] \ + position [drawHitTargetMeterPoint [list [expr {$width / 2.0}] [expr {$height / 2.0}]]] \ scale 0.35 anchor center color white text $name } } diff --git a/builtin-programs/draw/shapes.folk b/builtin-programs/draw/shapes.folk index b1a138ce..7c5a5b41 100644 --- a/builtin-programs/draw/shapes.folk +++ b/builtin-programs/draw/shapes.folk @@ -1,11 +1,11 @@ set drawShapeSides [dict create \ triangle 3 square 4 pentagon 5 hexagon 6 septagon 7 octagon 8 nonagon 9] -proc drawShapeTruthy {value} { +fn drawShapeTruthy {value} { expr {$value in {1 true yes on}} } -proc drawShapeCanonical {shape options} { +fn drawShapeCanonical {shape options} { if {[dict exists $options type]} { set shape [dict get $options type] } @@ -18,7 +18,7 @@ proc drawShapeCanonical {shape options} { } } -proc drawShapeScalar {value extent} { +fn drawShapeScalar {value extent} { if {[string match *% $value]} { set pct [string range $value 0 end-1] return [expr {double($pct) / 100.0 * $extent}] @@ -26,12 +26,12 @@ proc drawShapeScalar {value extent} { return $value } -proc drawShapePageCenter {geom} { +fn drawShapePageCenter {geom} { list [expr {[dict get $geom width] / 2.0}] \ [expr {[dict get $geom height] / 2.0}] } -proc drawShapePoint {point geom} { +fn drawShapePoint {point geom} { if {$point eq "" || $point eq "center"} { return [drawShapePageCenter $geom] } @@ -42,7 +42,7 @@ proc drawShapePoint {point geom} { [drawShapeScalar [lindex $point 1] [dict get $geom height]] } -proc drawShapeOffset {offset geom} { +fn drawShapeOffset {offset geom} { if {$offset eq "" || $offset eq "center"} { return {0 0} } @@ -87,7 +87,7 @@ proc drawShapeOffset {offset geom} { error "draw/shapes: expected offset like {x y} or {right 50%}, got $offset" } -proc drawShapePosition {options geom} { +fn drawShapePosition {options geom} { if {[dict exists $options position]} { return [drawShapePoint [dict get $options position] $geom] } @@ -107,18 +107,18 @@ proc drawShapePosition {options geom} { return $pos } -proc drawShapeRadians {options} { +fn drawShapeRadians {options} { dict getdef $options radians [dict getdef $options angle 0] } -proc drawShapeRadius {options default} { +fn drawShapeRadius {options default} { if {[dict exists $options diameter]} { return [expr {[dict get $options diameter] / 2.0}] } dict getdef $options radius $default } -proc drawShapeRegularPolygon {center radius sides radians} { +fn drawShapeRegularPolygon {center radius sides radians} { lassign $center cx cy set points [list] for {set i 0} {$i < $sides} {incr i} { @@ -129,7 +129,7 @@ proc drawShapeRegularPolygon {center radius sides radians} { return $points } -proc drawShapeRectPoints {center width height radians} { +fn drawShapeRectPoints {center width height radians} { set hw [expr {$width / 2.0}] set hh [expr {$height / 2.0}] set points [list \ @@ -142,7 +142,7 @@ proc drawShapeRectPoints {center width height radians} { } } -proc drawShapePathPoints {points geom options} { +fn drawShapePathPoints {points geom options} { set radians [drawShapeRadians $options] set origin [dict getdef $options origin center] set absolute [expr {$origin in {absolute local topleft top-left}}] @@ -164,7 +164,7 @@ proc drawShapePathPoints {points geom options} { return $transformed } -proc process_offset {offset regionOrGeom} { +fn process_offset {offset regionOrGeom} { if {[catch { dict create width [dict get $regionOrGeom width] height [dict get $regionOrGeom height] } geom]} { diff --git a/builtin-programs/draw/spaces.folk b/builtin-programs/draw/spaces.folk index 84933bfa..6f47a2c2 100644 --- a/builtin-programs/draw/spaces.folk +++ b/builtin-programs/draw/spaces.folk @@ -356,9 +356,20 @@ fn drawSpaceMeterPoint {point} { } } -proc drawSpaceMakeLib {quadLib poseLib quadChange disp displayWidth displayHeight displayIntrinsics} { +fn drawSpaceMakeLib {quadLib poseLib quadChange disp displayWidth displayHeight displayIntrinsics} { + set drawSpaceQuadPoint [fn drawSpaceQuadPoint] + set drawSpaceQuadSize [fn drawSpaceQuadSize] + set drawSpaceQuadSurfacePoint [fn drawSpaceQuadSurfacePoint] + set drawSpaceQuadSurfaceRect [fn drawSpaceQuadSurfaceRect] + set drawSpaceSurfaceQuadBetween [fn drawSpaceSurfaceQuadBetween] + set drawSpaceDisplayPixelToClip [fn drawSpaceDisplayPixelToClip] + set drawSpacePointInsidePolygon [fn drawSpacePointInsidePolygon] + library create drawSpaceLib { quadLib poseLib quadChange disp displayWidth displayHeight displayIntrinsics + drawSpaceQuadPoint drawSpaceQuadSize drawSpaceQuadSurfacePoint + drawSpaceQuadSurfaceRect drawSpaceSurfaceQuadBetween + drawSpaceDisplayPixelToClip drawSpacePointInsidePolygon } { proc display {} { variable disp @@ -394,26 +405,36 @@ proc drawSpaceMakeLib {quadLib poseLib quadChange disp displayWidth displayHeigh proc quadPoint {q selector} { variable quadLib + variable drawSpaceQuadPoint + fn drawSpaceQuadPoint drawSpaceQuadPoint $quadLib [quad $q] $selector } proc quadSize {q} { variable quadLib + variable drawSpaceQuadSize + fn drawSpaceQuadSize drawSpaceQuadSize $quadLib [quad $q] } proc quadSurfacePoint {q point} { variable quadLib + variable drawSpaceQuadSurfacePoint + fn drawSpaceQuadSurfacePoint drawSpaceQuadSurfacePoint $quadLib [quad $q] $point } proc quadSurfaceRect {q x y width height} { variable quadLib + variable drawSpaceQuadSurfaceRect + fn drawSpaceQuadSurfaceRect drawSpaceQuadSurfaceRect $quadLib [quad $q] $x $y $width $height } proc surfaceQuadBetween {from to height} { variable quadLib + variable drawSpaceSurfaceQuadBetween + fn drawSpaceSurfaceQuadBetween drawSpaceSurfaceQuadBetween $quadLib [displaySpace] $from $to $height } @@ -426,6 +447,8 @@ proc drawSpaceMakeLib {quadLib poseLib quadChange disp displayWidth displayHeigh } proc clipPoint {point} { + variable drawSpaceDisplayPixelToClip + fn drawSpaceDisplayPixelToClip lassign [displaySize] width height drawSpaceDisplayPixelToClip $width $height [project $point] } @@ -437,6 +460,8 @@ proc drawSpaceMakeLib {quadLib poseLib quadChange disp displayWidth displayHeigh } proc containsPixelPoint {q point} { + variable drawSpacePointInsidePolygon + fn drawSpacePointInsidePolygon drawSpacePointInsidePolygon $point [quadPixelVertices $q] } } diff --git a/builtin-programs/mask-tags.folk b/builtin-programs/mask-tags.folk index ff844ba5..509b1607 100644 --- a/builtin-programs/mask-tags.folk +++ b/builtin-programs/mask-tags.folk @@ -9,10 +9,13 @@ When display /proj/ has width /projWidth/ height /projHeight/ &\ /proj/ has canvas projection for surface /surface/ /surfaceToClip/ { if {[lindex $mask 0] ne "tag-mask"} { return } + set widthM [format "%sm" $width] + set heightM [format "%sm" $height] + Wish to draw a quad onto $proj in surface $surface with \ - p0 [drawSpaceMeterPoint {0 0}] \ - p1 [drawSpaceMeterPoint [list $width 0]] \ - p2 [drawSpaceMeterPoint [list $width $height]] \ - p3 [drawSpaceMeterPoint [list 0 $height]] \ + p0 {0m 0m} \ + p1 [list $widthM 0m] \ + p2 [list $widthM $heightM] \ + p3 [list 0m $heightM] \ color black layer 99 } diff --git a/builtin-programs/points-at.folk b/builtin-programs/points-at.folk index b5315525..740c92bb 100644 --- a/builtin-programs/points-at.folk +++ b/builtin-programs/points-at.folk @@ -1,3 +1,31 @@ +fn pointsAtMeterPoint {point} { + lmap value $point { + format "%sm" $value + } +} + +fn pointsAtVectorAdd {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av + $bv}] + } + return $out +} + +fn pointsAtVectorSub {a b} { + set out [list] + foreach av $a bv $b { + lappend out [expr {$av - $bv}] + } + return $out +} + +fn pointsAtVectorScale {v s} { + lmap x $v { + expr {$x * $s} + } +} + When when /rect/ points /direction/ with length /l/ at /someone/ /lambda/ with environment /e/ { if {[string match "/*" $rect]} { return } Wish $rect points $direction with length $l @@ -21,8 +49,8 @@ When the draw space library is /drawSpaceLib/ &\ if {$direction eq "up"} { set from [$drawSpaceLib quadPoint $quad top] set opposite [$drawSpaceLib quadPoint $quad bottom] - set to [drawSpaceVectorAdd $from \ - [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] + set to [pointsAtVectorAdd $from \ + [pointsAtVectorScale [pointsAtVectorSub $from $opposite] $scale]] set color blue set fromSurface [list [expr {$width / 2.0}] 0] set toSurface [list [expr {$width / 2.0}] [expr {-$height * $scale}]] @@ -30,8 +58,8 @@ When the draw space library is /drawSpaceLib/ &\ } elseif {$direction eq "left"} { set from [$drawSpaceLib quadPoint $quad left] set opposite [$drawSpaceLib quadPoint $quad right] - set to [drawSpaceVectorAdd $from \ - [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] + set to [pointsAtVectorAdd $from \ + [pointsAtVectorScale [pointsAtVectorSub $from $opposite] $scale]] set color gold set fromSurface [list 0 [expr {$height / 2.0}]] set toSurface [list [expr {-$width * $scale}] [expr {$height / 2.0}]] @@ -39,8 +67,8 @@ When the draw space library is /drawSpaceLib/ &\ } elseif {$direction eq "right"} { set from [$drawSpaceLib quadPoint $quad right] set opposite [$drawSpaceLib quadPoint $quad left] - set to [drawSpaceVectorAdd $from \ - [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] + set to [pointsAtVectorAdd $from \ + [pointsAtVectorScale [pointsAtVectorSub $from $opposite] $scale]] set color red set fromSurface [list $width [expr {$height / 2.0}]] set toSurface [list [expr {$width * (1.0 + $scale)}] [expr {$height / 2.0}]] @@ -48,8 +76,8 @@ When the draw space library is /drawSpaceLib/ &\ } elseif {$direction eq "down"} { set from [$drawSpaceLib quadPoint $quad bottom] set opposite [$drawSpaceLib quadPoint $quad top] - set to [drawSpaceVectorAdd $from \ - [drawSpaceVectorScale [drawSpaceVectorSub $from $opposite] $scale]] + set to [pointsAtVectorAdd $from \ + [pointsAtVectorScale [pointsAtVectorSub $from $opposite] $scale]] set color white set fromSurface [list [expr {$width / 2.0}] $height] set toSurface [list [expr {$width / 2.0}] [expr {$height * (1.0 + $scale)}]] @@ -74,11 +102,11 @@ When the draw space library is /drawSpaceLib/ &\ set color green Hold! -keep 16ms -key [list $rect pointer] { Wish to draw a line onto $disp in surface $surface with \ - points [list [drawSpaceMeterPoint $fromSurface] \ - [drawSpaceMeterPoint $toSurface]] width 0.4 \ + points [list [pointsAtMeterPoint $fromSurface] \ + [pointsAtMeterPoint $toSurface]] width 0.4 \ color $color Wish to draw a circle onto $disp in surface $surface with \ - center [drawSpaceMeterPoint $toSurface] \ + center [pointsAtMeterPoint $toSurface] \ radius 1 thickness 0.4 \ color $color filled true } @@ -88,11 +116,11 @@ When the draw space library is /drawSpaceLib/ &\ When /nobody/ claims $rect points /anything/ at /anything/ { Hold! -keep 16ms -key [list $rect pointer] { Wish to draw a line onto $disp in surface $surface with \ - points [list [drawSpaceMeterPoint $fromSurface] \ - [drawSpaceMeterPoint $toSurface]] width 0.4 \ + points [list [pointsAtMeterPoint $fromSurface] \ + [pointsAtMeterPoint $toSurface]] width 0.4 \ color $color Wish to draw a circle onto $disp in surface $surface with \ - center [drawSpaceMeterPoint $toSurface] \ + center [pointsAtMeterPoint $toSurface] \ radius 1 thickness 0.4 \ color $color filled false } diff --git a/builtin-programs/title.folk b/builtin-programs/title.folk index 692ca4b4..4f623ae4 100644 --- a/builtin-programs/title.folk +++ b/builtin-programs/title.folk @@ -41,8 +41,10 @@ When display /disp/ has width /displayWidth/ height /displayHeight/ &\ } } + set meterPosition [lmap value $position { format "%sm" $value }] + Wish to draw text onto $disp in surface $surface with \ - position [drawSpaceMeterPoint $position] \ + position $meterPosition \ scale $textScaleCm anchor $textAnchor \ text $text }