diff --git a/lib/folk.js b/lib/folk.js index b64e4f46..d55d8941 100644 --- a/lib/folk.js +++ b/lib/folk.js @@ -24,8 +24,8 @@ const eatBrace = (str) => { if (bc === 0) { return [ - str.slice(0, i+1), - str.slice(i+1), + str.slice(0, i + 1), + str.slice(i + 1), ]; } } @@ -118,8 +118,8 @@ const loadDict = (str) => { if (list.length % 2 !== 0) throw new Error('uneven element count in dict'); const obj = {}; - for (let i = 0; i < list.length; i+= 2) - obj[list[i]] = list[i+1]; + for (let i = 0; i < list.length; i += 2) + obj[list[i]] = list[i + 1]; return obj; }; @@ -141,7 +141,7 @@ const dump = (val) => { return dumpString(val.toString()); } else if (typeof val == 'object') { const core = Object.entries(val) - .map(([k, v]) => dump(k) + ' ' + dump(v)); + .map(([k, v]) => dump(k) + ' ' + dump(v)); return '{' + core.join(' ') + '}'; } @@ -170,18 +170,21 @@ class FolkWSChannel { this.prefix = prefix; this.callback = callback; this.ws.channels[prefix] = this; + this.retractKey = null; } stop() { + this.ws.ws.send(`Retract ${this.retractKey}`); if (this.ws.channels[this.prefix] !== this) return; delete this.ws.channels[this.prefix]; } } class FolkWS { - constructor(statusEl=null, url=null) { + constructor(statusEl = null, url = null) { this.channels = {}; this.i = 0; + this.assertSeq = 0; this._connect(statusEl, url); } @@ -247,7 +250,12 @@ class FolkWS { } // Evaluates inside a match context dependent on the WS connection: async send(message) { - await this.evaluate(tcl`Assert when websocket $chan is connected [list {this __seq} ${message}] with environment [list $chan [incr ::__seq]]`); + const seqNumber = this.assertSeq++; + const assertBody = tcl`when websocket $chan is connected [list {this __seq} ${message}] with environment [list $chan ${seqNumber}]`; + await this.evaluate(`Assert ${assertBody}`); + + const retractKey = assertBody; + return retractKey; } // Evaluates inside a persistent match context that replaces any // previous hold with same key: @@ -270,36 +278,67 @@ class FolkWS { async watch(statement, callbacks) { const channel = this.createChannel((message) => { - const [ action, match, matchId ] = loadList(message); + const [action, match, matchId] = loadList(message); const callback = callbacks[action]; callback && callback(loadDict(match), matchId); }); - await this.send(tcl` - set varNamesWillBeBound [list] - foreach word ${statement} { - if {[set varName [trie scanVariable $word]] != "false"} { + const retractKey = await this.send(tcl` + # for the top level Say + set outerVarNames [list] + # for inner When's + set innerVarNames [list] + set statement ${statement} + set body { + set matches [dict create] + foreach varName $names { + set val [set $varName] + dict append matches $varName $val + } + emit ${channel.prefix} [list add $matches $::matchId] + On unmatch { + emit ${channel.prefix} [list remove $matches $::matchId] + } + } + for {set i 0} {$i < [llength $statement]} {incr i} { + set word [lindex $statement $i] + if {$word eq "&"} { + # Desugar this join into nested Whens. + set remainingStatement [lrange $statement $i+1 end] + set statement [lrange $statement 0 $i-1] + for {set j 0} {$j < [llength $remainingStatement]} {incr j} { + set remainingWord [lindex $remainingStatement $j] + if {[set varName [trie scanVariable $remainingWord]] != "false"} { + if {$varName ni $statement::blanks && $varName ni $statement::negations} { + if {[string range $varName 0 2] eq "..."} { + set varName [string range $varName 3 end] + } + lappend innerVarNames $varName + } + } + if {[regexp {^/([^/ ]+)/$} $remainingWord -> remainingVarName] && + $remainingVarName in $outerVarNames} { + lset remainingStatement $j \\$$remainingVarName + } + } + set body [list When {*}$remainingStatement $body] + break + } elseif {[set varName [trie scanVariable $word]] != "false"} { if {$varName ni $statement::blanks && $varName ni $statement::negations} { if {[string range $varName 0 2] eq "..."} { set varName [string range $varName 3 end] } - lappend varNamesWillBeBound $varName + lappend outerVarNames $varName } } } - Say when {*}${statement} {{this names args} { - set matches [dict create] - foreach varName $names val $args { - dict append matches $varName $val - } - - emit ${channel.prefix} [list add $matches $::matchId] - On unmatch { - emit ${channel.prefix} [list remove $matches $::matchId] - } - }} with environment [list $this $varNamesWillBeBound] + # join both variable names to be sent along the websocket in the innermost When + set combinedVarNames [concat $outerVarNames $innerVarNames] + Say when {*}$statement [list [list this names {*}$outerVarNames] $body] with environment [list $this $combinedVarNames] `); + channel.retractKey = retractKey; + return channel; } } diff --git a/setup.folk.default b/setup.folk.default index b43adab4..1ef1dfb1 100644 --- a/setup.folk.default +++ b/setup.folk.default @@ -1,6 +1,6 @@ # Copy this file to ~/folk-live/setup.folk and edit it to make # changes. -Assert $this wishes $::thisNode uses camera "/dev/video0" with width 1280 height 720 bufferCount 4 +Assert $this wishes $::thisNode uses camera "/dev/video0" with width 1280 height 720 -Assert $this wishes $::thisNode uses display 0 with swapchainPadding 1 +Assert $this wishes $::thisNode uses display 0 diff --git a/vendor/blobdetect/blobdetect.tcl b/vendor/blobdetect/blobdetect.tcl index c4f1c3ce..e59e05a4 100644 --- a/vendor/blobdetect/blobdetect.tcl +++ b/vendor/blobdetect/blobdetect.tcl @@ -1,10 +1,10 @@ namespace eval ::BlobDetect { - rename [c create] apc - apc cflags -I$::env(HOME)/apriltag $::env(HOME)/folk/vendor/blobdetect/hk.c - apc include - apc include - apc include - apc code { + set cc [c create] + $cc cflags -I$::env(HOME)/apriltag $::env(HOME)/folk/vendor/blobdetect/hk.c + $cc include + $cc include + $cc include + $cc code { int hoshen_kopelman(int **matrix, int m, int n); typedef struct { @@ -36,6 +36,7 @@ namespace eval ::BlobDetect { // for(int i = 0; i < rows; i++) // memset(matrix[i], 0, cols * sizeof(int)); + // filter the raster into on or off for (int y = 0; y < im_orig->height; y++) { for (int x = 0; x < im_orig->width; x++) { int i = y * im_orig->stride + x; @@ -54,6 +55,7 @@ namespace eval ::BlobDetect { int clusters = hoshen_kopelman(matrix,m,n); // printf("clusters: %d\n", clusters); + // initialize a structure for (int i=0; iid = i; @@ -120,9 +122,9 @@ namespace eval ::BlobDetect { zarray_destroy(detections); } } - defineImageType apc + defineImageType $cc - apc proc detect {image_t gray int threshold} Tcl_Obj* { + $cc proc detect {image_t gray int threshold} Tcl_Obj* { assert(gray.components == 1); image_u8_t im = (image_u8_t) { .width = gray.width, .height = gray.height, .stride = gray.bytesPerRow, .buf = gray.data }; @@ -134,7 +136,7 @@ namespace eval ::BlobDetect { detected_blob_t *det; zarray_get(detections, i, &det); - // printf("detection %3d: id %-4d\n cx %f cy %f size %d\n", i, det->id, det->c[0], det->c[1], det->size); + printf("detection %3d: id %-4d\n cx %f cy %f size %d\n", i, det->id, det->c[0], det->c[1], det->size); // int size = sqrt((det->p[0][0] - det->p[1][0])*(det->p[0][0] - det->p[1][0]) + (det->p[0][1] - det->p[1][1])*(det->p[0][1] - det->p[1][1])); int size = det->size; @@ -154,5 +156,5 @@ namespace eval ::BlobDetect { return result; } - apc compile + $cc compile } diff --git a/virtual-programs/calibrate/calibrate.folk b/virtual-programs/calibrate/calibrate.folk index c78aa531..ecedb267 100644 --- a/virtual-programs/calibrate/calibrate.folk +++ b/virtual-programs/calibrate/calibrate.folk @@ -384,6 +384,9 @@ Wish the web server handles route "/calibrate$" with handler [list apply {{UNIT_ [list /someone/ claims the default program geometry is /defaultGeom/]] 0] defaultGeom] fn defaultGeomGet {key} { return [string map {mm ""} [dict get $defaultGeom $key]] } + set camera [dict get [lindex [Statements::findMatches \ + [list /someone/ claims camera /camera/ has width /cameraWidth/ height /cameraHeight/]] 0] camera] + upvar ^html ^html html [csubst { @@ -464,15 +467,15 @@ Wish the web server handles route "/calibrate$" with handler [list apply {{UNIT_ }); -

Once you start calibration, you'll see some AprilTags get automatically projected on your table. Move your board to the projected tags so that at least one projected tag sits inside the gap between printed AprilTags, wait a second for the projected tags to refit into the grid, +

Once you start calibration, you'll see some AprilTags get automatically projected on your table. Move your board to the projected tags so that at least one projected tag sits inside the gap between printed AprilTags, wait a second for the projected tags to refit into the grid, then hold the board still for a few seconds until the pose is recorded.

-

Example video of Andrés calibration the Folk0 system (playing at 2x speed).

+

Example video of Andrés calibrating the folk0 system (2x speed)

-

Are the projected tags too big to fit in the gaps between printed tags? Adjust this slider to reset & adjust the default projected tag size: +

Are the projected tags too big to fit in the gaps between printed tags? Adjust this slider to reset & adjust the default projected tag size:

+ +

Use this camera preview to debug why printed and/or projected tags aren't being recognized (maybe overexposure, maybe your camera isn't in a good position): +


+ + -

Use this camera preview to debug why printed and/or projected tags aren't being recognized (maybe overexposure, maybe your camera isn't in a good position):


-

Once you've recorded the first pose, slowly drag the board around your space, going slow enough for the projected AprilTags to catch up with the printed AprilTags and fit into the gaps on your board. When you've moved the board at least a full board-length away from the first pose, try to slant it 45 degrees or so off the table and hold it still again to capture another pose.

+

Is the projection too bright and washing out the camera? +
+ Adjust camera exposure: + + μs +

+ + + +

Once you've recorded the first pose, slowly drag the board around your space, going slow enough for the projected AprilTags to catch up with the printed AprilTags and fit into the gaps on your board. When you've moved the board at least a full board-length away from the first pose, try to slant it 45 degrees or so off the table and hold it still again to capture another pose.

Repeat this process of dragging the board around and capturing a new pose. You'll need to record 10 different @@ -498,7 +559,7 @@ Wish the web server handles route "/calibrate$" with handler [list apply {{UNIT_

Troubleshooting

Look at ~/folk-calibration-poses to see images of the captured poses (maybe tags are distorted or washed out?).

-

You can try manually adjusting webcam settings if your poses are bad. (They should be immediately reflected in the camera preview once you refresh.) Folk tries to turn off autofocus by default, but you might also want to turn off autoexposure and set a manual exposure time. For example:

+

You can try manually adjusting webcam settings if your poses are bad. (They should be immediately reflected in the camera preview once you refresh.) Folk tries to turn off autofocus by default, and you might also want to check that your camera actually has an exposure setting and focus setting. For example:

 \$ v4l2-ctl --device=/dev/video0 --list-ctrls
 
@@ -524,9 +585,10 @@ Camera Controls
                  focus_absolute 0x009a090a (int)    : min=0 max=250 step=5 default=0 value=30
      focus_automatic_continuous 0x009a090c (bool)   : default=1 value=0
                   zoom_absolute 0x009a090d (int)    : min=100 max=500 step=1 default=100 value=100
-\$ v4l2-ctl --device=/dev/video0 --set-ctrl=auto_exposure=1
+\$ v4l2-ctl --device=/dev/video0 --set-ctrl=auto_exposure=1 # to set them manually from terminal
 \$ v4l2-ctl --device=/dev/video0 --set-ctrl=exposure_time_absolute=25
+

Camera needs to have auto_exposure and exposure_time_absolute settings listed for Folk to be able to set them.

@@ -671,10 +733,6 @@ When camera /camera/ has width /cameraWidth/ height /cameraHeight/ &\ # TODO: restore old camera resolution later } - # HACK: hard-coded for now; assumes dark room. Won't work on USB - # webcams yet, either (just Pi). - Wish camera $camera uses exposure time 16000 us - set tagSideLength 1.0 set tagOuterLength [expr {$tagSideLength * 10/6}] set pad $tagSideLength @@ -793,7 +851,12 @@ When camera /camera/ has width /cameraWidth/ height /cameraHeight/ &\ model /anything/ version /anything/ timestamp /anything/ { HoldDefaultModel 1.0 } - On unmatch { Hold H_modelToDisplay {} } + On unmatch { + Hold H_modelToDisplay {} + Hold exposure { + Wish camera $camera uses exposure time auto us + } + } When main-detector detects tags /tags/ on $camera at /timestamp/ in time /something/ & \ the calibration model-to-display homography is /H_modelToDisplay/ with \ diff --git a/virtual-programs/camera-usb.folk b/virtual-programs/camera-usb.folk index a17f3ce3..e1a83d94 100644 --- a/virtual-programs/camera-usb.folk +++ b/virtual-programs/camera-usb.folk @@ -261,6 +261,24 @@ set makeCamera { folkHeapFree(image.data); } + camc proc setExposure {camera_t* camera int value} void { + struct v4l2_control c; + + c.id = V4L2_CID_EXPOSURE_AUTO; + c.value = V4L2_EXPOSURE_MANUAL; + FOLK_ENSURE(xioctl(camera->fd, VIDIOC_S_CTRL, &c) == 0); + + c.id = V4L2_CID_EXPOSURE_ABSOLUTE; + c.value = value; + FOLK_ENSURE(xioctl(camera->fd, VIDIOC_S_CTRL, &c) == 0); + } + camc proc setExposureAuto {camera_t* camera} void { + struct v4l2_control c; + c.id = V4L2_CID_EXPOSURE_AUTO; + c.value = V4L2_EXPOSURE_APERTURE_PRIORITY; + FOLK_ENSURE(xioctl(camera->fd, VIDIOC_S_CTRL, &c) == 0); + } + if {$::tcl_platform(os) eq "Darwin"} { c loadlib "/opt/homebrew/lib/libjpeg.dylib" } else { @@ -301,7 +319,7 @@ When /someone/ wishes $::thisNode uses camera /cameraPath/ with /...options/ { set width [dict get $options width] set height [dict get $options height] - set bufferCount [dict_getdef $options bufferCount 4] + set bufferCount [dict_getdef $options bufferCount 2] if {[dict exists $options crop]} { set crop [dict get $options crop] @@ -324,6 +342,8 @@ When /someone/ wishes $::thisNode uses camera /cameraPath/ with /...options/ { Wish $::thisProcess shares statements like \ [list /someone/ claims camera $cameraPath /...anything/] + Wish $::thisProcess receives statements like \ + [list /someone/ wishes camera $cameraPath uses exposure time /exposureTimeUs/ us] namespace eval Camera $makeCamera set camera [Camera::new $cameraPath $width $height $bufferCount] @@ -333,6 +353,14 @@ When /someone/ wishes $::thisNode uses camera /cameraPath/ with /...options/ { puts "camera-usb: $cameraPath ($options) (tid [getTid]) booted at [clock milliseconds]" + When /someone/ wishes camera $cameraPath uses exposure time /exposureTimeUs/ us { + if {$exposureTimeUs eq "auto"} { + Camera::setExposureAuto $camera + } else { + Camera::setExposure $camera [expr {int($exposureTimeUs / 100)}] + } + } + set ::oldFrames [list] When $::thisProcess has step count /c/ { set frame [Camera::grayFrame $camera] diff --git a/virtual-programs/display.folk b/virtual-programs/display.folk index 5e6bdebb..0f1f0747 100644 --- a/virtual-programs/display.folk +++ b/virtual-programs/display.folk @@ -1640,9 +1640,9 @@ Start-display-process { Wish $::thisProcess shares statements like \ [list /someone/ has error /err/ with info /errorInfo/] - # for backwards compatibility + # If swapchain padding isn't indicated, default to this When /someone/ wishes $::thisNode uses display /displayIdx/ { - Wish $::thisNode uses display $displayIdx with swapchainPadding 1 + Wish $::thisNode uses display $displayIdx with swapchainPadding 0 } When /someone/ wishes $::thisNode uses display /displayIdx/ with /...options/ { diff --git a/virtual-programs/editor-control.folk b/virtual-programs/editor-control.folk new file mode 100644 index 00000000..cb27992c --- /dev/null +++ b/virtual-programs/editor-control.folk @@ -0,0 +1,170 @@ +When /page/ has editor code /editorCode/ & /page/ has program code /programCode/ { + Claim $page has base64 editor code [binary encode base64 $editorCode] \ + program code [binary encode base64 $programCode] +} + +Wish the web server handles route "/editor-control" with handler { + html { + + + + + Editor copy/paste + + + + Status +

+ Select a keyboard: +

+ + + + + } +} diff --git a/virtual-programs/esc-pos.folk b/virtual-programs/esc-pos.folk index cc9f9bed..c832978d 100644 --- a/virtual-programs/esc-pos.folk +++ b/virtual-programs/esc-pos.folk @@ -49,7 +49,7 @@ namespace eval escpos { if {![dict exists $matchDict geometry]} { return } set geometry [dict get $matchDict geometry] set metaFile [open "$::env(HOME)/folk-printed-programs/$id.meta.folk" w] - puts $metaFile [subst -novariables {Claim tag $this has geometry {[read $fd]}}] + puts $metaFile [subst {Claim tag \$this has geometry {$geometry}}] close $metaFile } @@ -84,7 +84,8 @@ namespace eval escpos { return $tagBits } - proc tag {id {scale 20}} { + # scale must be divisible by 4 so width will be divisible by 8 + proc tag {id {scale 12}} { set tagImage [::tagImageForId $id] set tagBits [scaledAprilTag $id $scale] diff --git a/virtual-programs/group.folk b/virtual-programs/group.folk new file mode 100644 index 00000000..b470fa1e --- /dev/null +++ b/virtual-programs/group.folk @@ -0,0 +1,39 @@ +# 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 matches for [list /someone/ wishes /program/ is titled /title/] are /matches/ { + set programTitles [dict create] + + foreach match $matches { + set programId [dict get $match program] + + if {[lsearch $programs $programId] != -1} { + dict set programTitles $programId [dict get $match 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 +} \ No newline at end of file diff --git a/virtual-programs/laser.folk b/virtual-programs/laser.folk index 712312cd..8d69d1cb 100644 --- a/virtual-programs/laser.folk +++ b/virtual-programs/laser.folk @@ -1,8 +1,7 @@ -return - source vendor/blobdetect/blobdetect.tcl -When camera /any/ has frame /grayFrame/ at timestamp /timestamp/ { +When /someone/ wishes to detect laser blobs &\ + camera /any/ has frame /grayFrame/ at timestamp /timestamp/ { set blobTime [time { set threshold 250 set blobs [::BlobDetect::detect $grayFrame $threshold] diff --git a/virtual-programs/shapes.folk b/virtual-programs/shapes.folk index 2245336a..7cd932cb 100644 --- a/virtual-programs/shapes.folk +++ b/virtual-programs/shapes.folk @@ -1,111 +1,353 @@ -# sides 2 => line -# sides 3 => triangle -# sides 4 => square +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 numPoints [dict get $options sides] - set c [dict get $options center] - set r [dict get $options radius] - set radians [dict_getdef $options radians 0] + 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 p [list 0 0] - set center $p - set points [list $p] - - set incr [expr {2 * 3.14159 / $numPoints}] - set a [expr {$incr + 3.14159}] - for {set i 0} {$i < $numPoints} {incr i} { - set p [vec2 add $p [vec2 scale [list [expr {cos($a)}] [expr {sin($a)}]] $r]] - lappend points $p - # Accumulate center - set center [vec2 add $center $p] - set a [expr {$a + $incr}] + 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 + }] } - set center [vec2 scale $center [expr {1.0/$numPoints}]] - - set points [lmap v $points { - set v [vec2 sub $v $center] - set v [vec2 rotate $v $radians] - set v [vec2 add $v $c] - set v - }] - + if {$filled} { Wish to draw a polygon with points $points color $color layer $layer } else { - Wish to draw a stroke with points $points width 1 color $color layer $layer + Wish to draw a stroke with points $points width $thickness color $color layer $layer } } -set shapes [dict create triangle 3 square 4 pentagon 5 hexagon 6 \ - septagon 7 octagon 8 nonagon 9] When /someone/ wishes /p/ draws a /shape/ { - # TODO: This is a hack because rest pattern doesn't match empty - # sequence at end. Wish $p draws a $shape with color white } -When /someone/ wishes /p/ draws an /shape/ { Wish $p draws a $shape } + +# 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 a /shape/ with /...options/ & /p/ has region /r/ { - lassign [region centroid $r] x y - set width [region width $r] - set height [region height $r] - lassign [dict_getdef $options offset {0 0}] offsetX offsetY - set radius [dict_getdef $options radius 50] + 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] - - if {$offsetX != 0} { - set x [expr {$x + $offsetX}] - } - if {$offsetY != 0} { - set y [expr {$y + $offsetY}] - } - - set angle [region angle $r] - set p [list $x $y] - + + 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"} { - Wish to draw a circle with \ - center $p radius $radius thickness $thickness \ - color $color filled $filled layer $layer + 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]} { - Wish to draw a shape with sides [dict get $shapes $shape] \ - center $p radius $radius radians $angle \ - color $color filled $filled layer $layer + 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 { - Wish to draw a shape with sides 2 \ - center $p radius $radius radians $angle \ - color $color filled $filled layer $layer + 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 - Wish $this draws a triangle with color skyblue - Wish $this draws a triangle with color green offset {280 0} - Wish $this draws a pentagon with color gold offset {200 0} - Wish $this draws an octagon with color red offset {250 80} + + # Grid of shapes with varying thickness + set baseX -850 + set baseY -200 + set gridSpacing 130 - When the clock time is /t/ { - set offsetVector [list [sin $t] [cos $t]] - set offsetVector [::vec2::scale $offsetVector 105] - Wish $this draws a circle with color palegoldenrod offset $offsetVector - } + # 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}]] - # This toggles a square between filled and unfilled + # 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 fill [expr {round(sin($t) * 2) % 2 == 0}] + 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 100] $y] radius 60 color white filled $fill + 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/virtual-programs/shapes/region.folk b/virtual-programs/shapes/region.folk new file mode 100644 index 00000000..47b4c367 --- /dev/null +++ b/virtual-programs/shapes/region.folk @@ -0,0 +1,92 @@ +# 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 virtual-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/virtual-programs/web/web-keyboards.folk b/virtual-programs/web/web-keyboards.folk index 3c4867fb..08c5355b 100644 --- a/virtual-programs/web/web-keyboards.folk +++ b/virtual-programs/web/web-keyboards.folk @@ -3,15 +3,37 @@ When the keyboards are /keyboards/ { upvar ^html ^html html [subst { + + + Status
[join [lmap kb $keyboards { subst { -
$kb
-
-
- -
+
+
$kb
+
+ Keys typed: +
+
+ +
+
} }] "\n"]