diff --git a/Makefile b/Makefile index 30882ab8..17b5f9dd 100644 --- a/Makefile +++ b/Makefile @@ -86,7 +86,7 @@ debug: folk if [ "$$(uname)" = "Darwin" ]; then \ lldb -o "process handle -p true -s false SIGUSR1" -- ./folk; \ else \ - gdb -ex "handle SIGUSR1 nostop" -ex "handle SIGPIPE nostop" ./folk; \ + DEBUGINFOD_URLS="" gdb -ex "handle SIGUSR1 nostop" -ex "handle SIGPIPE nostop" ./folk; \ fi clean: @@ -124,10 +124,10 @@ sync: rsync --timeout=15 -e "ssh -o StrictHostKeyChecking=no" \ --archive --delete --itemize-changes \ --exclude='/.git' \ - --exclude-from='.git/ignores.tmp' \ --exclude='vendor/tracy/public/TracyClient.o' \ --include='vendor/tracy/public/***' \ --exclude='vendor/tracy/*' \ + --exclude-from='.git/ignores.tmp' \ ./ $(FOLK_REMOTE_NODE):~/folk/ remote-setup: diff --git a/builtin-programs/apriltags.folk b/builtin-programs/apriltags.folk index 606fa28f..0405a058 100644 --- a/builtin-programs/apriltags.folk +++ b/builtin-programs/apriltags.folk @@ -120,8 +120,7 @@ set entireFrameDetector [makeAprilTagDetector $tagFamily 2.0 1] set incrementalDetector [makeAprilTagDetector $tagFamily 1.5 1] # Entire-frame tag detector: -When /nobody/ wishes to calibrate camera /any/ to display /any/ &\ - /nobody/ wishes to interactively refine calibration from camera /any/ to display /any/ &\ +When /nobody/ wishes to calibrate camera /any/ to display /any/ /...etc/ &\ -serially camera /camera/ has gray frame /frame/ at timestamp /frameTs/ { tracy zoneBegin @@ -141,8 +140,7 @@ When /nobody/ wishes to calibrate camera /any/ to display /any/ &\ # Incremental tag detector (looks at regions where there were tags # seen recently): -When /nobody/ wishes to calibrate camera /any/ to display /any/ &\ - /nobody/ wishes to interactively refine calibration from camera /any/ to display /any/ &\ +When /nobody/ wishes to calibrate camera /any/ to display /any/ /...etc/ &\ the image library is /imageLib/ &\ -serially camera /camera/ has gray frame /frame/ at timestamp /frameTs/ { tracy zoneBegin diff --git a/builtin-programs/calibrate/calibrate-page.folk b/builtin-programs/calibrate/calibrate-page.folk index 7ec0e299..c5da4154 100644 --- a/builtin-programs/calibrate/calibrate-page.folk +++ b/builtin-programs/calibrate/calibrate-page.folk @@ -1,150 +1,10 @@ -When the print library is /printLib/ &\ - the programToPs is /programToPs/ &\ - the calibration matrix library is /matLib/ &\ - the calibration model library is /modelLib/ { - -fn programToPs - -fn makeCalibrationBoardPdf {model tagSideLengthPs} { - package require linalg - namespace import ::math::linearalgebra::add - - set marginTop 72; set marginLeft 36 - set PageWidth 612; set PageHeight 792 - - set innerToOuter 0.333333 - - set tagOuterLengthPs [expr {$tagSideLengthPs * 10/6}] - - set H_modelToPs [$matLib estimateHomography [subst { - {1 1 $tagSideLengthPs $tagSideLengthPs} - {1 0 $tagSideLengthPs 0} - {0 1 0 $tagSideLengthPs} - {0 0 0 0} - }]] - - set ps [subst { - %!PS - << /PageSize \[$PageWidth $PageHeight\] >> setpagedevice - - % (0, 0) is bottom-left of portrait page right now. - 90 rotate 1 -1 scale - % Now (0, 0) is top-left of landscape page. - - gsave - $marginLeft [- $marginTop 18] translate - 1 -1 scale - 0 setgray /Helvetica findfont 14 scalefont setfont - newpath 0 0 moveto (Folk calibration board) show - grestore - - $marginLeft $marginTop translate - - [set tagIdx -1] - [join [lmap {id modelTag} $model { - if {![$modelLib isPrintedTag $id]} { continue } - incr tagIdx - - set modelInnerTopLeft [lindex [dict get $modelTag p] 3] - set modelOuterTopLeft [add $modelInnerTopLeft [list -$innerToOuter -$innerToOuter]] - lassign [$matLib applyHomography $H_modelToPs $modelOuterTopLeft] psX psY - subst { - gsave - $psX [+ $psY $tagOuterLengthPs] translate - $tagOuterLengthPs -$tagOuterLengthPs scale - [$printLib tagPsForId $id] - grestore - - % Label the inner side length: - [if {$tagIdx == 1} { subst { - gsave - [expr {$psX + ($tagOuterLengthPs - $tagSideLengthPs)/2}] - [expr {$psY - 15}] translate - 1 -1 scale - 0.1 0.67 0.1 setrgbcolor - newpath 0 0 moveto $tagSideLengthPs 0 lineto stroke - newpath 0 0 moveto 0 -5 lineto stroke - newpath $tagSideLengthPs 0 moveto $tagSideLengthPs -5 lineto stroke - /Helvetica findfont 7 scalefont setfont - newpath 0 5 moveto (inner side length) show - grestore - } }] - } - }] "\n"] - }] - - set fp [open [list |ps2pdf - - <<$ps] rb] - set pdf [read $fp]; close $fp - return $pdf -} +When the codeToPostScript is /codeToPostScript/ { -fn makeExampleProgramPng {} { - # HACK: we hard-code letter, since this is just for documentation - # purposes, and we want to cut the bottom half off so we need - # known dimensions. - set format letter - set ps [{*}$programToPs 0 {# This image is for illustration purposes; don't -# print it. You should print a program normally -# through the Folk editor and measure that.} $format {{ - - [set left [expr {$PageWidth-$tagwidth-$margin}]] - [set bottom [expr {$PageHeight-$tagheight-$margin}]] - [set outerToInner [expr {($tagwidth / 10.0) * 2}]] - - % These take in x1 y1 x2 y2 on stack. - /markXDistance { - newpath moveto - 0 -15 rlineto 0 30 rmoveto 0 -15 rlineto - lineto - 0 -15 rlineto 0 30 rmoveto 0 -15 rlineto - 6 setlinewidth stroke - } def - /markYDistance { - newpath moveto - -15 0 rlineto 30 0 rmoveto -15 0 rlineto - lineto - -15 0 rlineto 30 0 rmoveto -15 0 rlineto - 6 setlinewidth stroke - } def - - % Left - [+ $left $outerToInner] [expr {$bottom + $tagheight/2.0}] - 0 [expr {$bottom + $tagheight/2.0}] - 1 0 0 setrgbcolor markXDistance - - % Right - [expr {$left + $tagwidth - $outerToInner}] [expr {$bottom + $tagheight/2.0}] - $PageWidth [expr {$bottom + $tagheight/2.0}] - 1 0 0 setrgbcolor markXDistance - - % Top - [expr {$left + $tagwidth/2.0}] [expr {$bottom + $tagheight - $outerToInner}] - [expr {$left + $tagwidth/2.0}] $PageHeight - 0 0.5 1 setrgbcolor markYDistance - - % Bottom - [expr {$left + $tagwidth/2.0}] [expr {$bottom + $outerToInner}] - [expr {$left + $tagwidth/2.0}] [expr {$PageHeight/2.0}] - 0 0.5 1 setrgbcolor markYDistance - - % Tag inner - [+ $left $outerToInner] [+ $bottom $outerToInner 5] - [expr {$left + $tagwidth - $outerToInner}] [+ $bottom $outerToInner 5] - 0 1 0 setrgbcolor markXDistance - }}] - - set fp [open [list |gs -sDEVICE=png16m -q -dBATCH -r300 -sOutputFile=- - <<$ps] rb] - set png [read $fp]; close $fp - return $png -} +fn codeToPostScript Wish the web server handles route "/calibrate" with hidden true handler { package require base64 - set calibrationBoardPdf [makeCalibrationBoardPdf [$modelLib unitModel] 70] - - set exampleProgramPng [makeExampleProgramPng] - set defaultGeom [dict get [lindex [Query! /someone/ claims the default program geometry is /defaultGeom/] 0] defaultGeom] fn defaultGeomGet {key} { return [string map {mm ""} [dict get $defaultGeom $key]] } @@ -251,67 +111,67 @@ Wish the web server handles route "/calibrate" with hidden true handler {

  • Print the calibration board.

    -

    Print this calibration board and glue/tape it to +

    We're going to print this calibration board and glue/tape it to something solid and flat (hardcover book, solid cardboard, etc):

    - -

    You can download the PDF and print it yourself, or print through Folk if your printer is set up:

    + +

    Make sure your printer is set up for Folk to print.

    +

    Print the calibration board through Folk: (print through Folk so that we can calibrate the way you will actually print)

    Try to keep the board from bending or warping. Printing on cardstock can help.

    -

    (During calibration, Folk will want to project AprilTags in the gaps on the grid of tags on the board. Instead of printing, you can - try just maximizing the board on your computer/tablet - screen, but you'll need to cover each gap with sticky note or something else that Folk can project - tags on.)

  • Measure your calibration board.

    -

    On your calibration board, measure the inner side length (indicated on calibration PDF) of a tag in millimeters and enter it here: mm

    - -

    Try to be as accurate as possible, like to within half a millimeter or better -- the more accurate, the better your calibration will be.

    +

    On your calibration board, measure each indicator in millimeters and enter it here. + (Try to be as accurate as possible, like to within half a millimeter or better -- + the more accurate, the better your calibration will be.)

    +

  • Run the calibration process.

    -

    Start calibration:

    +

    Start calibration:

    -

    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.

    - -

    You should be lifting your board above the table plane and tilting it in the air. Don't just keep it flat on the table!

    - - - -

    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: @@ -338,6 +198,16 @@ Claim the calibration poses max is \${calibrationPosesMax} }); +

    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.

    + +

    You should be lifting your board above the table plane and tilting it in the air. Don't just keep it flat on the table!

    + + + +

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

    +

    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 @@ -404,99 +274,6 @@ Camera Controls calibrating again.

    • - - -
  • -

    Measure program geometry.

    - -

    Now we need to tell Folk the exact geometry of an - average program page: what is the physical size of the - AprilTag on the page? how far is the tag from the edges - of the page?

    - -

    Print a program that outlines itself, - if you don't have one already.

    - -

    Fold the program in half if you want half-height programs. Measure the tag inner side length in millimeters, along with the distances in millimeters from the tag inner perimeter to each edge of the paper. Enter them below.

    - - - - -

    - - -
    - How to manually override the geometry of a specific program - -

    If you've, for example, printed out program 30 at a - different size, or you manually cut and pasted the tag - 30 somewhere and want to create a specially sized region - around that, you can set tag 30's geometry manually by making a - 30.meta.folk text file in ~/folk-printed-programs, with content like this:

    - - 
    Claim tag \$this has geometry {tagSize 30mm top 28mm right 28mm left 157mm bottom 80mm}
    -
    -
    • -

  • Test calibration.

    diff --git a/builtin-programs/calibrate/calibrate.folk b/builtin-programs/calibrate/calibrate.folk index 1427a052..b8293ddc 100644 --- a/builtin-programs/calibrate/calibrate.folk +++ b/builtin-programs/calibrate/calibrate.folk @@ -29,8 +29,8 @@ When camera /camera/ has width /cameraWidth/ height /cameraHeight/ &\ the jpeg library is /jpegLib/ &\ the calibration model library is /modelLib/ &\ the calibration matrix library is /matLib/ &\ - the printed calibration tag size is /printedSideLengthMm/ mm &\ - /someone/ wishes to calibrate camera /camera/ to display /display/ { + /someone/ wishes to calibrate camera /camera/ to display /display/ \ + using tag size /printedSideLengthMm/ mm { fn makeAprilTagDetector set calibrationTagDetector [makeAprilTagDetector "tagStandard52h13" 2.0 3] @@ -538,7 +538,7 @@ fn setCameraToProjectorExtrinsics {modelLib calibrationVar calibrationPoses} { # to find the rotation and translation from 3D camera-space to 3D # projector-space. - upvar $calibrationVar calibration + upvar $calibrationVar cal # Let's take all the points for which we have a corresponding # camera frame point and projector frame point. @@ -547,12 +547,12 @@ fn setCameraToProjectorExtrinsics {modelLib calibrationVar calibrationPoses} { for {set i 0} {$i < [llength $calibrationPoses]} {incr i} { set calibrationPose [lindex $calibrationPoses $i] - - set Rc [dict get [lindex [dict get $calibration camera extrinsics] $i] R] - set tc [dict get [lindex [dict get $calibration camera extrinsics] $i] t] - set Rp [dict get [lindex [dict get $calibration projector extrinsics] $i] R] - set tp [dict get [lindex [dict get $calibration projector extrinsics] $i] t] + set Rc [dict get [lindex [dict get $cal camera extrinsics] $i] R] + set tc [dict get [lindex [dict get $cal camera extrinsics] $i] t] + + set Rp [dict get [lindex [dict get $cal projector extrinsics] $i] R] + set tp [dict get [lindex [dict get $cal projector extrinsics] $i] t] # TODO: Try using pose estimation instead? dict for {id tag} [dict get $calibrationPose model] { @@ -594,8 +594,8 @@ fn setCameraToProjectorExtrinsics {modelLib calibrationVar calibrationPoses} { set t [sub $projectorFramePointsCentroid \ [matmul $R $cameraFramePointsCentroid]] - dict set calibration R_cameraToProjector $R - dict set calibration t_cameraToProjector $t + dict set cal R_cameraToProjector $R + dict set cal t_cameraToProjector $t } # End-to-end calibrates a camera-projector pair. calibrationPoses is @@ -701,6 +701,7 @@ When the calibration model library is /modelLib/ &\ set calibration [{*}$refineCalibration \ $modelLib $matLib \ + [fn setCameraToProjectorExtrinsics] \ $calibrationPoses $calibration] puts "======== Refined calibration intrinsics =========" diff --git a/builtin-programs/calibrate/calibration-board.folk b/builtin-programs/calibrate/calibration-board.folk new file mode 100644 index 00000000..5294480f --- /dev/null +++ b/builtin-programs/calibrate/calibration-board.folk @@ -0,0 +1,243 @@ +# Goal of the calibration board is to have the user do four +# measurements: +# +# - paper edge to top margin +# +# - paper edge to bottom margin +# +# - paper edge to left margin +# +# - tag inner width, to account for scaling. (We also want this tag +# inner width to be exactly the same as the tag inner width that we +# use on every printed program, so that if the user measures the tag +# wrong, it still looks OK on the average program.) +# +# Then we can correct for these factors in all future prints, so we +# can print mm-accurate. + +# These values are all in points (1/72 of an inch). +set marginTop 48; set marginLeft 48 + +set measureTop [/ $marginTop 2]; set measureLeft [/ $marginLeft 2] +set tagInnerSideLength 70 + +When the calibration measurements are /measurements/ { + set m_tag [expr {double([string trimright [dict get $measurements tagSideLength] mm])}] + set m_left [expr {double([string trimright [dict get $measurements left] mm])}] + set m_bottom [expr {double([string trimright [dict get $measurements bottom] mm])}] + + # Derive a PostScript CTM that maps calibrated space (origin at + # paper bottom-left, 1 unit = 1 physical point = 25.4/72 mm) to + # the printer's raw PS coordinate space. + # + # The calibration board was printed unmediated, so its PS coords + # are the printer's raw coords. The measurement lines were drawn + # at PS positions measureLeft and measureTop; the tag inner side + # was tagInnerSideLength PS points. From the physical measurements + # (in mm) we can recover the printer's scale and origin offset. + set scale [expr {25.4 * $tagInnerSideLength / (72.0 * $m_tag)}] + set tx [expr {$measureLeft - $m_left * $tagInnerSideLength / $m_tag}] + set ty [expr {$measureTop - $m_bottom * $tagInnerSideLength / $m_tag}] + + Claim the calibrated print preamble is "\[$scale 0 0 $scale $tx $ty\] concat" + Claim the calibrated print scale is $scale +} + +When the print library is /printLib/ &\ + the calibration model library is /modelLib/ &\ + the calibration matrix library is /matLib/ { + +fn makeCalibrationBoardPs {} { + set model [$modelLib unitModel] + + package require linalg + namespace import ::math::linearalgebra::add + + set PageWidth 612; set PageHeight 792 + + set innerToOuter 0.333333 + + set tagOuterLengthPs [expr {$tagInnerSideLength * 10/6}] + + set H_modelToPs [$matLib estimateHomography [subst { + {1 1 $tagInnerSideLength $tagInnerSideLength} + {1 0 $tagInnerSideLength 0} + {0 1 0 $tagInnerSideLength} + {0 0 0 0} + }]] + + set ps [subst { + %!PS + << /PageSize \[$PageWidth $PageHeight\] >> setpagedevice + + gsave + $marginLeft [- $PageHeight [/ $marginTop 2]] translate + 0 setgray /Helvetica findfont 14 scalefont setfont + newpath 0 0 moveto (Folk calibration board) show + grestore + + /Helvetica findfont 7 scalefont setfont + 1 setlinecap + 2 setlinewidth 0.67 0.1 0.1 setrgbcolor + + % Short red segment at top measure, with arrow up to top edge. + 2 setlinewidth + newpath + [expr {$PageWidth/2 - 20}] [- $PageHeight $measureTop] moveto + [expr {$PageWidth/2 + 20}] [- $PageHeight $measureTop] lineto + stroke + 1 setlinewidth + newpath + [/ $PageWidth 2] [- $PageHeight $measureTop] moveto + [/ $PageWidth 2] [expr {$PageHeight - 2}] lineto + stroke + newpath + [/ $PageWidth 2] [expr {$PageHeight - 2}] moveto + [expr {$PageWidth/2 - 4}] [expr {$PageHeight - 8}] lineto + stroke + newpath + [/ $PageWidth 2] [expr {$PageHeight - 2}] moveto + [expr {$PageWidth/2 + 4}] [expr {$PageHeight - 8}] lineto + stroke + newpath [expr {$PageWidth/2 + 12}] [expr {$PageHeight - $measureTop/2 - 3}] moveto + (Measure to top edge of paper) show + + % Short red segment at bottom measure, with arrow down to bottom edge. + 2 setlinewidth + newpath + [expr {$PageWidth/2 - 20}] $measureTop moveto + [expr {$PageWidth/2 + 20}] $measureTop lineto + stroke + 1 setlinewidth + newpath + [/ $PageWidth 2] $measureTop moveto + [/ $PageWidth 2] 2 lineto + stroke + newpath + [/ $PageWidth 2] 2 moveto + [expr {$PageWidth/2 - 4}] 8 lineto + stroke + newpath + [/ $PageWidth 2] 2 moveto + [expr {$PageWidth/2 + 4}] 8 lineto + stroke + newpath [expr {$PageWidth/2 + 12}] [expr {$measureTop/2- 3}] moveto + (Measure to bottom edge of paper) show + + 0.1 0.1 0.67 setrgbcolor + + % Short blue segment at left measure, with arrow left to left edge. + 2 setlinewidth + newpath + $measureLeft [expr {$PageHeight/2 - 20}] moveto + $measureLeft [expr {$PageHeight/2 + 20}] lineto + stroke + 1 setlinewidth + newpath + $measureLeft [/ $PageHeight 2] moveto + 2 [/ $PageHeight 2] lineto + stroke + newpath + 2 [/ $PageHeight 2] moveto + 8 [expr {$PageHeight/2 - 4}] lineto + stroke + newpath + 2 [/ $PageHeight 2] moveto + 8 [expr {$PageHeight/2 + 4}] lineto + stroke + newpath [/ $measureLeft 4] [expr {$PageHeight/2 - 30}] moveto + (Measure to) show + [/ $measureLeft 4] [expr {$PageHeight/2 - 37}] moveto + (left edge of paper) show + + % We should flip the coordinate system to match the model coordinate system, + % so (0, 0) is top-left. + 1 -1 scale + $marginLeft [- $marginTop $PageHeight] translate + + [set tagIdx -1] + [join [lmap {id modelTag} $model { + if {![$modelLib isPrintedTag $id]} { continue } + incr tagIdx + + set modelInnerTopLeft [lindex [dict get $modelTag p] 3] + set modelOuterTopLeft [add $modelInnerTopLeft [list -$innerToOuter -$innerToOuter]] + lassign [$matLib applyHomography $H_modelToPs $modelOuterTopLeft] psX psY + subst { + gsave + $psX [+ $psY $tagOuterLengthPs] translate + $tagOuterLengthPs -$tagOuterLengthPs scale + [$printLib tagPsForId $id] + grestore + + % gsave + % 0 setgray /Helvetica findfont 14 scalefont setfont + % 1 0 0 setrgbcolor + % newpath $psX $psY moveto 1 -1 scale ($tagIdx) show + % grestore + + % Label the inner side length: + [if {$tagIdx == 1} { subst { + gsave + [expr {$psX + ($tagOuterLengthPs - $tagInnerSideLength)/2}] + [expr {$psY - 15}] translate + 1 -1 scale + 0.1 0.67 0.1 setrgbcolor 2 setlinewidth + newpath 0 0 moveto $tagInnerSideLength 0 lineto stroke + newpath 0 0 moveto 0 -5 lineto stroke + newpath $tagInnerSideLength 0 moveto $tagInnerSideLength -5 lineto stroke + /Helvetica findfont 7 scalefont setfont + newpath 0 5 moveto (inner side length) show + grestore + } }] + } + }] "\n"] + + showpage + }] + + return $ps +} +Claim the makeCalibrationBoardPs is [fn makeCalibrationBoardPs] + +fn makeCalibrationBoardPdf {} { + set ps [makeCalibrationBoardPs] + set fp [open [list |ps2pdf - - <<$ps] rb] + set pdf [read $fp]; close $fp + return $pdf +} +Claim the makeCalibrationBoardPdf is [fn makeCalibrationBoardPdf] + +fn makeCalibrationBoardPng {} { + set ps [makeCalibrationBoardPs] + set psFile [file tempfile].ps + set fp [open $psFile w]; puts $fp $ps; close $fp + set pngFile [file tempfile].png + exec gs -dNOPAUSE -dBATCH -sFONTPATH=vendor/fonts \ + -sDEVICE=png16m -r144 \ + -sOutputFile=$pngFile $psFile + set fp [open $pngFile rb] + set png [read $fp]; close $fp + return $png +} +Claim the makeCalibrationBoardPng is [fn makeCalibrationBoardPng] + +Wish the web server handles route {/calibrate/board.pdf} with hidden true handler { + dict create statusAndHeaders "HTTP/1.1 200 OK +Connection: close +Content-Type: application/pdf + +" \ + body [makeCalibrationBoardPdf] +} + +Wish the web server handles route {/calibrate/board.png} with hidden true handler { + dict create statusAndHeaders "HTTP/1.1 200 OK +Connection: close +Content-Type: image/png + +" \ + body [makeCalibrationBoardPng] +} + +} diff --git a/builtin-programs/calibrate/interactively-refine.folk b/builtin-programs/calibrate/interactively-refine.folk deleted file mode 100644 index 1b73d35d..00000000 --- a/builtin-programs/calibrate/interactively-refine.folk +++ /dev/null @@ -1,716 +0,0 @@ -# interactively-refine.folk -- -# -# Implements table-oriented projector-camera end-to-end -# calibration step. -# - -When the pose library is /poseLib/ { - -set cc [C] -$cc extend $poseLib - -$cc cflags -I./vendor/apriltag -$cc endcflags ./vendor/apriltag/build/libapriltag.so - -$cc include -$cc include -$cc include - -# From https://courses.cs.duke.edu/cps274/fall13/notes/rodrigues.pdf: -fn rotationMatrixToRotationVector {R} { - set A [scale 0.5 [sub $R [transpose $R]]] - set rho [list [getelem $A 2 1] \ - [getelem $A 0 2] \ - [getelem $A 1 0]] - set s [norm $rho] - set c [expr {([getelem $R 0 0] + [getelem $R 1 1] + [getelem $R 2 2] - 1) / 2}] - - # If s = 0 and c = 1: - if {abs($s) < 0.0001 && abs($c - 1) < 0.0001} { - return {0 0 0} - } - # If s = 0 and c = -1: - if {abs($s) < 0.0001 && abs($c - (-1)) < 0.0001} { - # let v = a nonzero column of R + I - set v [getcol [add $R [mkIdentity 3]] 0] - set u [scale [/ 1.0 [norm $v]] $v] - set r [scale 3.14159 $u] - if {abs([norm $r] - 3.14159) < 0.0001 && - ((abs([getelem $r 0]) < 0.0001 && - abs([getelem $r 1]) < 0.0001 && - [getelem $r 2] < 0) || - (abs([getelem $r 0]) < 0.0001 && - [getelem $r 1] < 0) || - ([getelem $r 0] < 0))} { - return [scale -1 $r] - } else { - return $r - } - } - - set u [scale [/ 1.0 $s] $rho] - set theta $(atan2($s, $c)) - return [scale $theta $u] -} - -fn rotationVectorToRotationMatrix {r} { - set theta [norm $r] - if {abs($theta) < 0.0001} { - return [mkIdentity 3] - } - set u [scale [/ 1.0 $theta] $r] - set ux [list [list 0 [* -1.0 [getelem $u 2]] [getelem $u 1]] \ - [list [getelem $u 2] 0 [* -1.0 [getelem $u 0]]] \ - [list [* -1.0 [getelem $u 1]] [getelem $u 0] 0]] - return [add [scale $(cos($theta)) [mkIdentity 3]] \ - [add [scale [expr {1.0 - cos($theta)}] \ - [matmul $u [transpose $u]]] \ - [scale $(sin($theta)) $ux]]] -} - -# Used to generate the initial guess in estimateBoardPose. Kind of -# misuses the AprilTag pose estimation code to do an entire-board -# estimate (which includes multiple tags). -$cc proc baseEstimateBoardPose {Intrinsics cameraIntrinsics - double cameraWidth double cameraHeight - double[][2] modelTagCorners double[][2] detectedTagCorners - int cornersCount} TagPose { - // We'll fill this in with a .H that represents all the corners. - apriltag_detection_t det; - - // The normal tag .H homography goes from (+/-1, +/-1) to the - // camera-detected tag corners. We will instead create a - // board-wide homography from board meters position to the - // camera-detected tag corners. - float correspondences[cornersCount][4]; - for (int i = 0; i < cornersCount; i++) { - correspondences[i][0] = modelTagCorners[i][0]; - correspondences[i][1] = modelTagCorners[i][1]; - - double undistortedDetectedTagCorners[2]; - rescaleAndUndistort(cameraIntrinsics, cameraWidth, cameraHeight, - detectedTagCorners[i], - undistortedDetectedTagCorners); - correspondences[i][2] = undistortedDetectedTagCorners[0]; - correspondences[i][3] = undistortedDetectedTagCorners[1]; - } - zarray_t correspondencesArr = { - .el_sz = sizeof(float[4]), .size = cornersCount, .alloc = cornersCount, - .data = (char*) correspondences - }; - det.H = homography_compute(&correspondencesArr, - HOMOGRAPHY_COMPUTE_FLAG_SVD); - apriltag_detection_info_t info = { - .det = &det, - .tagsize = 2.0, // scale factor = 1.0 - .fx = cameraIntrinsics.fx, .fy = cameraIntrinsics.fy, - .cx = cameraIntrinsics.cx, .cy = cameraIntrinsics.cy - }; - apriltag_pose_t pose; - estimate_pose_for_tag_homography(&info, &pose); - - matd_destroy(det.H); - - TagPose ret; - memcpy(ret.R, pose.R->data, sizeof(ret.R)); - memcpy(ret.t, pose.t->data, sizeof(ret.t)); - - matd_destroy(pose.R); - matd_destroy(pose.t); - return ret; -} -$cc proc estimateBoardPose {Intrinsics cameraIntrinsics - double cameraWidth double cameraHeight - double[][2] modelTagCorners double[][2] detectedTagCorners - int cornersCount} TagPose { - TagPose baseBoardPose = - baseEstimateBoardPose(cameraIntrinsics, cameraWidth, cameraHeight, - modelTagCorners, detectedTagCorners, cornersCount); - - double wX[cornersCount][3]; - double x[cornersCount][2]; - for (int i = 0; i < cornersCount; i++) { - rescaleAndUndistort(cameraIntrinsics, cameraWidth, cameraHeight, - detectedTagCorners[i], - x[i]); - // Apply intrinsics to go from pixel coordinates to normalized - // image-plane coordinates: - x[i][0] = (x[i][0] - cameraIntrinsics.cx) / cameraIntrinsics.fx; - x[i][1] = (x[i][1] - cameraIntrinsics.cy) / cameraIntrinsics.fy; - - wX[i][0] = modelTagCorners[i][0]; - wX[i][1] = modelTagCorners[i][1]; - wX[i][2] = 0; - } - - matd_t* cRw = matd_create_data(3, 3, (double*) baseBoardPose.R); - matd_t* ctw = matd_create_data(3, 1, (double*) baseBoardPose.t); - - poseGaussNewton(wX, x, cornersCount, &cRw, &ctw, 200); - - TagPose ret; - memcpy(ret.R, cRw->data, sizeof(ret.R)); - memcpy(ret.t, ctw->data, sizeof(ret.t)); - - matd_destroy(cRw); - matd_destroy(ctw); - return ret; -} - -$cc cflags -I./vendor/cmpfit -$cc include "mpfit.h" -$cc include "mpfit.c" -$cc proc funct {int m int n double* x - double* fvec double** dvec - void* userdata} int { - Jim_Obj* jimFunct = (Jim_Obj*) userdata; - - // Build xList from x[0..n-1]. - Jim_Obj* xList = Jim_NewListObj(interp, NULL, 0); - for (int i = 0; i < n; i++) { - Jim_ListAppendElement(interp, xList, Jim_NewDoubleObj(interp, x[i])); - } - - // Expand jimFunct (already an arg list) and append xList, then eval. - int prefixLen = Jim_ListLength(interp, jimFunct); - Jim_Obj* objv[prefixLen + 1]; - for (int i = 0; i < prefixLen; i++) { - __ENSURE_OK(Jim_ListIndex(interp, jimFunct, i, &objv[i], JIM_NONE)); - } - objv[prefixLen] = xList; - __ENSURE_OK(Jim_EvalObjVector(interp, prefixLen + 1, objv)); - - // Unpack result list into fvec[0..m-1]. - Jim_Obj* result = Jim_GetResult(interp); - FOLK_ENSURE(Jim_ListLength(interp, result) == m); - for (int i = 0; i < m; i++) { - Jim_Obj* elem; - __ENSURE_OK(Jim_ListIndex(interp, result, i, &elem, JIM_NONE)); - __ENSURE_OK(Jim_GetDouble(interp, elem, &fvec[i])); - } - return 0; -} -$cc proc fit {int m int n double[] x Jim_Obj* jimFunct} Jim_Obj* { - mp_result result = {0}; - - mp_par pars[18]; // One for each parameter - memset(pars, 0, sizeof(pars)); - // Set larger relative step sizes - for (int i = 0; i < 18; i++) { - pars[i].relstep = 1e-3; // Default is ~1e-7, try 1e-3 to 1e-2 - } - - mpfit(funct, - m, // Number of residuals. - n, x, // Parameters to optimize. - pars, NULL, (void*) jimFunct, &result); - fprintf(stderr, "next niter=%d, nfev=%d, status=%d, pid=%d ;\n orignorm=%f, bestnorm=%f\n", result.niter, result.nfev, result.status, gettid(), - result.orignorm, result.bestnorm); - - Jim_Obj* xList = Jim_NewListObj(interp, NULL, 0); - for (int i = 0; i < n; i++) { - Jim_ListAppendElement(interp, xList, Jim_NewDoubleObj(interp, x[i])); - } - return xList; -} - -set boardLib [$cc compile] - -When the AprilTag detector maker is /makeAprilTagDetector/ &\ - the calibration model library is /modelLib/ &\ - the calibration matrix library is /matLib/ &\ - the printed calibration tag size is /printedSideLengthMm/ mm &\ - camera /camera/ has width /cameraWidth/ height /cameraHeight/ &\ - display /display/ has width /displayWidth/ height /displayHeight/ &\ - /someone/ wishes to interactively refine calibration from camera /camera/ to display /display/ { - - When /someone/ wishes to draw refining model /model/ onto detected tags /tags/ \ - using calibration /calibration/ &\ - the collected results for [list /someone/ wishes to draw refining label /label/] \ - are /labels/ { - package require linalg - namespace import ::math::linearalgebra::matmul \ - ::math::linearalgebra::add - - set cameraIntrinsics [dict get $calibration camera intrinsics] - set displayIntrinsics [dict get $calibration projector intrinsics] - - set modelPrintedTagCorners [list] - set detectedPrintedTagCorners [list] - dict for {id tag} $tags { - if {![$modelLib isPrintedTag $id]} { continue } - - lappend modelPrintedTagCorners {*}[dict get $model $id p] - lappend detectedPrintedTagCorners {*}[dict get $tag p] - } - if {[llength $detectedPrintedTagCorners] < 4} { return } - - # Do a single board-wide pose estimate. - set pose [$boardLib estimateBoardPose $cameraIntrinsics \ - $cameraWidth $cameraHeight \ - $modelPrintedTagCorners $detectedPrintedTagCorners \ - [llength $detectedPrintedTagCorners]] - set R_boardToCamera [dict get $pose R] - set t_boardToCamera [dict get $pose t] - - set R_cameraToDisplay [dict get $calibration R_cameraToProjector] - set t_cameraToDisplay [dict get $calibration t_cameraToProjector] - - # Compute model-to-display homography from pose via correspondences - # of the detected printed tag corners: - set correspondences [lmap mc $modelPrintedTagCorners { - set v [list {*}$mc 0] - set camPt [add [matmul $R_boardToCamera $v] $t_boardToCamera] - set dispPt [add [matmul $R_cameraToDisplay $camPt] $t_cameraToDisplay] - set dp [$poseLib project $displayIntrinsics \ - $displayWidth $displayHeight $dispPt] - list {*}$mc {*}$dp - }] - set H_modelToDisplay [$matLib estimateHomography $correspondences] - - Wish to draw calibration model $model \ - using model-to-display homography $H_modelToDisplay \ - with message [join [lmap r $labels {dict get $r label}] " "] - } - - fn AwaitNextCameraFrame! {frameStmtVar} { - upvar $frameStmtVar frameStmt - if {$frameStmt ne {}} { - StatementRelease! [dict get $frameStmt __ref] - set prevFrameTimestamp $frameStmt(frameTimestamp) - } else { - set prevFrameTimestamp 0 - } - while true { - after 8 - - set frames [Query! camera $camera has gray frame /frame/ at timestamp /frameTimestamp/] - if {[llength $frames] < 1} { continue } - set frameResult [lindex $frames end] - - if {$frameResult(frameTimestamp) <= $prevFrameTimestamp} { continue } - - try { - StatementAcquire! [dict get $frameResult __ref] - } on error e { continue } - - break - } - set frameStmt $frameResult - return $frameResult - } - - set intrNames {fx cx fy cy k1 k2} - # Calibration -> flat list of 18 parameters `x`. - fn unravel {calibration} { - list \ - {*}[lmap n $intrNames { dict get $calibration camera intrinsics $n }] \ - {*}[lmap n $intrNames { dict get $calibration projector intrinsics $n }] \ - {*}[rotationMatrixToRotationVector [dict get $calibration R_cameraToProjector]] \ - {*}[dict get $calibration t_cameraToProjector] - } - # Flat list of 18 parameters `x` -> update calibration. - fn ravelInto {calibrationVar x} { - upvar $calibrationVar calibration - foreach n $intrNames v [lrange $x 0 5] { - dict set calibration camera intrinsics $n $v - } - foreach n $intrNames v [lrange $x 6 11] { - dict set calibration projector intrinsics $n $v - } - dict set calibration R_cameraToProjector \ - [rotationVectorToRotationMatrix [lrange $x 12 14]] - dict set calibration t_cameraToProjector [lrange $x 15 17] - } - - fn makeAprilTagDetector - set tagDetector [makeAprilTagDetector "tagStandard52h13" 1.0 3] - - package require linalg - namespace import ::math::linearalgebra::scale \ - ::math::linearalgebra::sub ::math::linearalgebra::add \ - ::math::linearalgebra::transpose ::math::linearalgebra::getelem \ - ::math::linearalgebra::norm ::math::linearalgebra::getcol \ - ::math::linearalgebra::mkIdentity ::math::linearalgebra::matmul - - set printedSideLengthM [/ $printedSideLengthMm 1000.0] - set model0 [$modelLib scaleModel [$modelLib unitModel] \ - $printedSideLengthM] - - set calibration [dict get [QueryOne! a calibration from camera $camera to display $display is /calibration/] calibration] - set calibrationPoses [dict get [QueryOne! the calibration poses from camera $camera to display $display are /calibrationPoses/] calibrationPoses] - - # The actual refinement process. We will have the user hold up the - # board in a sequence of whatever poses they want. When the board - # is stable for a couple seconds, we say that's a pose, and we - # start refinement with respect to that pose. - # - # Once the calibration is refined with respect to the pose, the - # user can move the board to a different pose. They can stop - # whenever they want. - - set poses [list] - - set frameStmt {} - while true { - AwaitNextCameraFrame! frameStmt - set frame $frameStmt(frame) - set frameTimestamp $frameStmt(frameTimestamp) - - set detectedTags0 [dict create] - foreach tag [$tagDetector detect $frame] { - dict set detectedTags0 $tag(id) $tag - } - if {[dict size $detectedTags0] < 8} { - # puts stderr "Not enough tags: [dict size $detectedTags0]" - continue - } - - # Do our best (given current calibration) to draw projected - # tags on the board to match the printed tags. We wouldn't - # really need this, I guess, except this is also what'll - # display the label (set next). - Hold! -key refining-model -keep 32ms Wish to draw refining model $model0 \ - onto detected tags $detectedTags0 \ - using calibration $calibration - - # We don't want to start a new pose right on top of a pose we - # just recorded. The user should have to move the board a bit. - if {[llength $poses] > 0} { - # Are the seen $tags far enough from previous pose's - # $tags? - set lastPose [lindex $poses end] - if {[$modelLib meanTagsDifference $detectedTags0 $lastPose(detectedTags0)] < 50} { - # Not far enough from previous pose. - Hold! -key label Wish to draw refining label "Move board farther!" - continue - } - } - - # We want the user to keep the board still, so don't start - # refining over a pose until it's been stable for a few - # seconds. - if {![info exists prevDetectedTags0] || - [set diff [$modelLib meanTagsDifference $detectedTags0 $prevDetectedTags0]] > 5} { - # Not close enough to previous frame for us to trust - # that the board is held still. Reset. - set prevDetectedTags0 $detectedTags0 - set prevDetectedTags0Timestamp $frameTimestamp - - set diffLabel "" - if {[info exists diff]} { set diffLabel "(moved $diff pixels)" } - Hold! -key label Wish to draw refining label \ - "Keep still! $diffLabel" - continue - } elseif {$frameTimestamp - $prevDetectedTags0Timestamp < 4} { - set timeSincePrevDetectedTags0 $($frameTimestamp - $prevDetectedTags0Timestamp) - Hold! -key label Wish to draw refining label \ - "Keep still for $(round((4.0 - $timeSincePrevDetectedTags0))) sec" - continue - } - Hold! -key label Wish to draw refining label \ - "Keep still. Refining..." - - set idealCameraCorners [apply {{} { - upvar modelLib modelLib; upvar matLib matLib - upvar model0 model0 - upvar detectedTags0 detectedTags0 - - # Collect correspondences: list of {x0 y0 x1 y1}, pairs of - # detected model corner & camera corner for all printed - # tags seen this frame. - set printedCorrespondences [list] - dict for {id tag} $detectedTags0 { - if {![$modelLib isPrintedTag $id]} { continue } - foreach modelCorner [dict get $model0 $id p] \ - camCorner [dict get $tag p] { - lappend printedCorrespondences \ - [list {*}$modelCorner {*}$camCorner] - } - } - if {[llength $printedCorrespondences] < 4} { continue } - - # H_mc: homography from model xy to camera xy. - # Used to find ideal camera positions for projected tags. - set H_mc [$matLib estimateHomography $printedCorrespondences] - - # idealCameraCorners: tag id -> list of 4 {x y}. - set idealCameraCorners [dict create] - dict for {id modelTag} $model0 { - if {![$modelLib isProjectedTag $id]} { continue } - dict set idealCameraCorners $id \ - [lmap modelCorner $modelTag(p) { - $matLib applyHomography $H_mc $modelCorner - }] - } - return $idealCameraCorners - }}] - - set pose [dict create detectedTags0 $detectedTags0 \ - idealCameraCorners $idealCameraCorners] - - # 2 residuals (dx, dy) per projected tag corner. - set projectedTagsCount [$modelLib countProjectedTags $model0] - set oldPoseResidualCount 0 - foreach oldPose $poses { - set nPrinted 0 - dict for {id tag} [dict get $oldPose finalDetectedTags] { - if {[$modelLib isPrintedTag $id]} { incr nPrinted [llength [dict get $tag p]] } - } - if {$nPrinted < 4} { continue } - dict for {id tag} [dict get $oldPose finalDetectedTags] { - if {[$modelLib isProjectedTag $id]} { - incr oldPoseResidualCount [expr {[llength [dict get $tag p]] * 2}] - } - } - } - set m [expr {$projectedTagsCount * 4 * 2 + $oldPoseResidualCount}] - - # Each saved calibrationPose contributes 2 residuals per - # projected tag corner, comparing H_modelToDisplay * model_corner - # (the target projector pixel) against the same model corner - # reprojected through the current draft calibration. - foreach calPose $calibrationPoses { - dict for {id modelTag} [dict get $calPose model] { - if {![$modelLib isProjectedTag $id]} continue - incr m [expr {[llength [dict get $modelTag p]] * 2}] - } - } - - # Refine the parameters with respect to this pose. This will - # block for a while and run the interior function a lot (10 - # times? 100 times?). - set version 0 - set x0 [unravel $calibration] - # puts stderr "x0=($x0)" - # Track the last calibration that produced a render the - # camera could actually detect. If the optimizer steers the - # parameters somewhere that breaks the detect loop, we'll - # revert to this so the projector goes back to a visible - # state. - set lastGoodCalibration $calibration - set detectedTags {} - set x [$boardLib fit $m [llength $x0] $x0 [fn funct {x} { - # This block gets run on each iteration of the - # Levenberg-Marquardt optimization loop. - - # puts stderr "ITER ------" - # puts stderr "Test x=($x)" - - ravelInto calibration $x - incr version - set model [$modelLib updateModelVersion $model0 $version] - - # This will cause the new model version to be rendered by - # the other process. Note that this assumes that the user - # hasn't moved the calibration board from the pose $tags0. - Hold! -key refining-model Wish to draw refining model $model \ - onto detected tags $detectedTags0 \ - using calibration $calibration - - # Loop until we see the version we just wished to draw. - set expectedVersion [expr {$version % 4}] - set detectedVersion {} - set missedFrames 0 - while {$detectedVersion != $expectedVersion} { - incr missedFrames - if {$missedFrames > 120} { - # The current draft x has rendered tags so badly - # the camera can't find them. Revert the projector - # render to the last known good calibration and - # return penalty residuals to push mpfit away. - puts stderr "Failure: reverting to last known good calibration" - set calibration $lastGoodCalibration - incr version - set model [$modelLib updateModelVersion $model0 $version] - Hold! -key refining-model Wish to draw refining model $model \ - onto detected tags $detectedTags0 \ - using calibration $calibration - return [lrepeat $m 1e3] - } - - AwaitNextCameraFrame! frameStmt - set frame $frameStmt(frame) - set frameTimestamp $frameStmt(frameTimestamp) - - set detectedTags [$tagDetector detect $frame] - # Report the detections for on-page preview: - Hold! -key detected-tags \ - Claim $this detects calibration tags $detectedTags on camera $camera - - set detectedProjectedTagsCount [llength [$modelLib filterProjectedTagsInDetectedTags $detectedTags]] - if {$detectedProjectedTagsCount < 1} { - # puts stderr "Failure: Only seeing $detectedProjectedTagsCount of $projectedTagsCount projected tags" - continue - } else { - # puts stderr "Success: Seeing $detectedProjectedTagsCount of $projectedTagsCount projected tags" - } - set detectedVersion [$modelLib detectVersionFromDetectedTags $detectedTags] - } - # The render was visible to the camera, so this calibration - # is safe to revert to if a later iteration breaks things. - set lastGoodCalibration $calibration - - # Compute residuals: detected position - ideal position for - # each projected tag corner. - - # H_mp: model xy -> projector xy. - # Used to infill projected tags that we didn't detect this frame. - set projCorrespondences [list] - foreach tag $detectedTags { - if {![$modelLib isProjectedTag $tag(id)]} { continue } - foreach modelCorner [dict get $model $tag(id) p] \ - projCorner [dict get $tag p] { - lappend projCorrespondences \ - [list {*}$modelCorner {*}$projCorner] - } - } - set H_mp [$matLib estimateHomography $projCorrespondences] - - set detectedCornersById [dict create] - foreach tag $detectedTags { - dict set detectedById $tag(id) $tag(p) - } - - set residuals [list] - dict for {id modelTag} $model { - if {![$modelLib isProjectedTag $id]} { continue } - set nCorners [llength [dict get $modelTag p]] - for {set i 0} {$i < $nCorners} {incr i} { - set idealIdx [expr {[$modelLib isVersionTag $id] ? ($i + $version) % 4 : $i}] - set ideal [lindex [dict get $idealCameraCorners $id] $idealIdx] - if {[dict exists $detectedCornersById $id]} { - set det [lindex $detectedCornersById($id) $i] - } else { - set det [$matLib applyHomography $H_mp \ - [lindex [dict get $modelTag p] $i]] - } - lappend residuals \ - [- [lindex $det 0] [lindex $ideal 0]] \ - [- [lindex $det 1] [lindex $ideal 1]] - } - } - # puts stderr "Residuals: ($residuals)" - - # Old-pose residuals: for each prior pose, estimate the board - # position using the current draft calibration, compute where - # projected tags would land in display space (H_mD) and use - # the stored printed-tag camera detections to map back to - # camera space (H_dC), then compare to stored projected detections. - set curCamIntr [dict get $calibration camera intrinsics] - set curDispIntr [dict get $calibration projector intrinsics] - set curR_cDP [dict get $calibration R_cameraToProjector] - set curT_cDP [dict get $calibration t_cameraToProjector] - - foreach oldPose $poses { - set oldDet [dict get $oldPose finalDetectedTags] - - set oldModelPrCorners [list] - set oldDetPrCorners [list] - dict for {id tag} $oldDet { - if {![$modelLib isPrintedTag $id]} { continue } - lappend oldModelPrCorners {*}[dict get $model0 $id p] - lappend oldDetPrCorners {*}[dict get $tag p] - } - if {[llength $oldModelPrCorners] < 4} { continue } - - set oldBP [$boardLib estimateBoardPose $curCamIntr \ - $cameraWidth $cameraHeight \ - $oldModelPrCorners $oldDetPrCorners \ - [llength $oldModelPrCorners]] - set R_old [dict get $oldBP R] - set t_old [dict get $oldBP t] - - # H_mD: model -> display (from current calibration + pose) - # H_dC: display -> stored camera detections (from printed tags) - set oldMDCorrs [list] - set oldDCCorrs [list] - foreach mc $oldModelPrCorners detC $oldDetPrCorners { - set camPt [add [matmul $R_old [list {*}$mc 0.0]] $t_old] - set dispPt [add [matmul $curR_cDP $camPt] $curT_cDP] - set dp [$poseLib project $curDispIntr $displayWidth $displayHeight $dispPt] - lappend oldMDCorrs [list {*}$mc {*}$dp] - lappend oldDCCorrs [list {*}$dp {*}$detC] - } - set H_mD [$matLib estimateHomography $oldMDCorrs] - set H_dC [$matLib estimateHomography $oldDCCorrs] - - dict for {id tag} $oldDet { - if {![$modelLib isProjectedTag $id]} { continue } - foreach detCorner [dict get $tag p] \ - mc [dict get $model0 $id p] { - set dispPos [$matLib applyHomography $H_mD $mc] - set ideal [$matLib applyHomography $H_dC $dispPos] - lappend residuals \ - [- [lindex $detCorner 0] [lindex $ideal 0]] \ - [- [lindex $detCorner 1] [lindex $ideal 1]] - } - } - } - - # CalibrationPose residuals: for each saved calibration pose, - # pose-estimate the board using current draft camera intrinsics - # and the saved tag detections, then compare where the current - # draft calibration would project each projected tag corner in - # display space against where H_modelToDisplay says it should be. - foreach calPose $calibrationPoses { - set calModel [dict get $calPose model] - set calTags [dict get $calPose tags] - set calH_mD [dict get $calPose H_modelToDisplay] - set calCamWidth [dict get $calPose cameraWidth] - set calCamHeight [dict get $calPose cameraHeight] - - set calModelPrCorners [list] - set calDetPrCorners [list] - dict for {id tag} $calTags { - if {![$modelLib isPrintedTag $id]} { continue } - if {![dict exists $calModel $id]} { continue } - lappend calModelPrCorners {*}[dict get $calModel $id p] - lappend calDetPrCorners {*}[dict get $tag p] - } - if {[llength $calModelPrCorners] < 4} { continue } - - set calBP [$boardLib estimateBoardPose $curCamIntr \ - $calCamWidth $calCamHeight \ - $calModelPrCorners $calDetPrCorners \ - [llength $calModelPrCorners]] - set R_cal [dict get $calBP R] - set t_cal [dict get $calBP t] - - dict for {id modelTag} $calModel { - if {![$modelLib isProjectedTag $id]} { continue } - foreach mc [dict get $modelTag p] { - set target [$matLib applyHomography $calH_mD $mc] - set camPt [add [matmul $R_cal [list {*}$mc 0.0]] $t_cal] - set dispPt [add [matmul $curR_cDP $camPt] $curT_cDP] - set current [$poseLib project $curDispIntr \ - $displayWidth $displayHeight $dispPt] - lappend residuals \ - [- [lindex $target 0] [lindex $current 0]] \ - [- [lindex $target 1] [lindex $current 1]] - } - } - } - - return $residuals - }]] - # puts stderr "Old x: ($x0)" - # puts stderr "New x: ($x)" - ravelInto calibration $x - - Hold! -save -on calibration -key calibration \ - Claim a calibration from camera $camera to display $display is $calibration - - dict set pose finalDetectedTags $detectedTags - lappend poses $pose - - puts stderr "Saved calibration. Now have [llength $poses] poses." - unset prevDetectedTags0 prevDetectedTags0Timestamp - } - On unmatch { - Hold! -key label {} - Hold! -key refining-model {} - } -} - -} diff --git a/builtin-programs/calibrate/model.folk b/builtin-programs/calibrate/model.folk index e684defe..e69004df 100644 --- a/builtin-programs/calibrate/model.folk +++ b/builtin-programs/calibrate/model.folk @@ -7,8 +7,8 @@ Claim the calibration model library is [library create modelLib { namespace import ::math::linearalgebra::scale \ ::math::linearalgebra::add - variable ROWS 3 - variable COLS 5 + variable ROWS 5 + variable COLS 4 proc rows {} { variable ROWS; return $ROWS } proc cols {} { variable COLS; return $COLS } # A model is a dictionary whose keys are tag IDs and where each @@ -20,7 +20,7 @@ Claim the calibration model library is [library create modelLib { set tagSideLength 1.0 set tagOuterLength [expr {$tagSideLength * 10/6}] - set pad [expr {$tagSideLength / 2}] + set pad [expr {$tagSideLength / 3}] for {set row 0} {$row < $ROWS} {incr row} { for {set col 0} {$col < $COLS} {incr col} { set id [expr {48600 + $row*$COLS + $col}] @@ -57,9 +57,14 @@ Claim the calibration model library is [library create modelLib { return $($id >= 48600 && $id < 48600 + $ROWS*$COLS) } proc isPrintedTag {id} { + variable COLS if {![isCalibrationTag $id]} { return false } set idx [- $id 48600] - return [expr {$idx % 2 == 0}] ;# for checkerboard + set row [expr {int($idx / $COLS)}] + set col [expr {$idx % $COLS}] + return [expr {$row % 2 == 0 ? + ($col % 2 == 1) : + ($col % 2 == 0)}] ;# for checkerboard } proc isProjectedTag {id} { if {![isCalibrationTag $id]} { return false } diff --git a/builtin-programs/calibrate/refine.folk b/builtin-programs/calibrate/refine.folk index 46d91d8e..8b9442b6 100644 --- a/builtin-programs/calibrate/refine.folk +++ b/builtin-programs/calibrate/refine.folk @@ -561,8 +561,9 @@ fn refineMonoCalibration {calibration} { return $calibration } -fn refineCalibration {modelLib matLib +fn refineCalibration {modelLib matLib setCameraToProjectorExtrinsics calibrationPoses calibration} { + fn setCameraToProjectorExtrinsics # We start by individually refining the mono calibration of # the camera and the mono calibration of the projector. @@ -641,8 +642,7 @@ fn refineCalibration {modelLib matLib }] # Reconstruct camera->projector extrinsics after refinement. - setCameraToProjectorExtrinsics $modelLib \ - calibration $calibrationPoses + setCameraToProjectorExtrinsics $modelLib calibration $calibrationPoses # Now we do stereo refinement of the reprojection error # of the entire system, including all intrinsics and diff --git a/builtin-programs/editor/draw-editor.folk b/builtin-programs/editor/draw-editor.folk new file mode 100644 index 00000000..2cf7cb3b --- /dev/null +++ b/builtin-programs/editor/draw-editor.folk @@ -0,0 +1,92 @@ +When the editor utils library is /utils/ { + +# Draw text and cursor +When /editor/ is an editor with /...anything/ &\ + editor /editor/ has margin /margin/ &\ + editor /editor/ has viewport position /vpPos/ &\ + editor /editor/ has viewport size /vpSize/ &\ + editor /editor/ has font options with /...fontOptions/ { + lassign $vpPos vpX vpY + lassign $vpSize vpWidth vpHeight + + set textScale [dict get $fontOptions scale] + set advance [$utils getAdvance $textScale] + + When editor $editor has selected program /program/ &\ + editor buffer for /program/ is /code/ &\ + editor $editor has cursor /cursor/ &\ + editor $editor has cursor position /cursorPos/ &\ + editor $editor has selection anchor /selAnchor/ { + set lineCount [min [- [llength [split $code "\n"]] $vpY] $vpHeight] + set lineNumbers [$utils lineNumberView $vpY $lineCount] + + set marginLeft [lindex $margin 3] + set lineNumbersRight $($marginLeft + $advance*1.5) + Wish to draw text onto $editor with \ + position [list $lineNumbersRight [lindex $margin 0]] \ + text $lineNumbers \ + scale $textScale anchor topright font NeomatrixCode + + set text [$utils applyTextViewport $code $vpX $vpY $vpWidth $vpHeight] + set pos [list [+ $lineNumbersRight $advance] [lindex $margin 0]] + Wish to draw text onto $editor with \ + position $pos text $text \ + scale $textScale anchor topleft font NeomatrixCode + + # Draw selection highlight + if {$selAnchor ne ""} { + set rawStart [min $selAnchor $cursor] + set rawEnd [max $selAnchor $cursor] + lassign [$utils cursorToXy $code $rawStart] selStartX selStartY + lassign [$utils cursorToXy $code $rawEnd] selEndX selEndY + + set lines [split $code "\n"] + for {set ly $selStartY} {$ly <= $selEndY} {incr ly} { + if {$ly < $vpY || $ly >= $vpY + $vpHeight} continue + + set lineLen [string length [lindex $lines $ly]] + + # Absolute column range for selection on this line + if {$ly == $selStartY} { + set absStart $selStartX + } else { + set absStart 0 + } + if {$ly == $selEndY} { + set absEnd $selEndX + } else { + set absEnd $lineLen + } + + # Clip to viewport + set absStart [max $absStart $vpX] + set absEnd [min $absEnd [+ $vpX $vpWidth]] + + if {$absStart >= $absEnd} continue + + # Convert to display coordinates + set dispStart [- $absStart $vpX] + set dispEnd [- $absEnd $vpX] + set dispRow [- $ly $vpY] + + set x0 $([lindex $pos 0] + $dispStart * $advance) + set x1 $([lindex $pos 0] + $dispEnd * $advance) + set y0 $([lindex $pos 1] + $dispRow * $textScale) + set y1 $($y0 + $textScale) + + Wish to draw a quad onto $editor with \ + p0 [list $x0 $y0] p1 [list $x1 $y0] \ + p2 [list $x1 $y1] p3 [list $x0 $y1] \ + color {0.2 0.4 0.8 0.7} layer -1 + } + } + + set p1 [vec2 add $cursorPos $pos] + set p2 [vec2 add $p1 [list 0 [* $textScale 1.2]]] + set s [/ $textScale 6] + Wish to draw a circle onto $editor with center $p1 radius $s thickness 0 color green filled true + Wish to draw a line onto $editor with points [list $p1 $p2] width $s color green + } +} + +} diff --git a/builtin-programs/editor-utils.folk b/builtin-programs/editor/editor-utils.folk similarity index 83% rename from builtin-programs/editor-utils.folk rename to builtin-programs/editor/editor-utils.folk index a27e1ba5..7b1aa5c7 100644 --- a/builtin-programs/editor-utils.folk +++ b/builtin-programs/editor/editor-utils.folk @@ -1,4 +1,4 @@ -set editorUtilsLib [library create editorUtilsLib { +Claim the editor utils library is [library create editorUtilsLib { proc applyTextViewport {originalText x y width height} { set lines [split $originalText \n] set lines [lrange $lines $y [expr {($height - 1) + $y}]] @@ -191,6 +191,40 @@ set editorUtilsLib [library create editorUtilsLib { } join $numbers "\n" } -}] -Claim the editor utils library is $editorUtilsLib + # For rendering: + + proc getAdvance {em} { + # From NeomatrixCode.csv + return $(0.5859375 * $em) + } + + proc widthAndHeight {resolvedGeom} { + set tagSize [dict get $resolvedGeom tagSize] + set left [dict get $resolvedGeom left] + set right [dict get $resolvedGeom right] + set top [dict get $resolvedGeom top] + set bottom [dict get $resolvedGeom bottom] + + set width $($left + $tagSize + $right) + set height $($top + $tagSize + $bottom) + + return [list $width $height] + } + + # given program and the editor options, figure out how many characters can + # fit in this editor + proc editorSizeInCharacters {margin resolvedGeom options} { + set textScale [dict get $options scale] + set advance [getAdvance $textScale] + + lassign [widthAndHeight $resolvedGeom] width height + set width $($width - [lindex $margin 3] - $advance*2.5 - [lindex $margin 1]) + set height $($height - [lindex $margin 0] - [lindex $margin 2]) + + set widthInCharacters $(int($width / $advance)) + set heightInCharacters $(int($height / $textScale)) + + return [list $widthInCharacters $heightInCharacters] + } +}] diff --git a/builtin-programs/editor.folk b/builtin-programs/editor/editor.folk similarity index 71% rename from builtin-programs/editor.folk rename to builtin-programs/editor/editor.folk index 952b6b58..ccdfb9aa 100644 --- a/builtin-programs/editor.folk +++ b/builtin-programs/editor/editor.folk @@ -1,76 +1,36 @@ -# This makes all keyboards into editors automatically, so a keyboard -# doesn't need to point at a real editor. May choose to change later, or -# exclude keyboards that opt out. -When /k/ is a keyboard with /...opts/ &\ - /nobody/ wishes /k/ does not create an editor { +# Old editor data is incompatible. +file delete $::env(HOME)/folk-data/hold/editor.folk +# This makes all keyboards create editors automatically. May choose to +# change later, or exclude keyboards that opt out. +When /k/ is a keyboard with /...opts/ { Wish tag $k is stabilized - # Create a synthetic editor above the keyboard page. - set editor [list $k editor] - Claim $editor is an editor - Wish $editor has a canvas - When $k has resolved geometry /geom/ { - Claim $editor has resolved geometry $geom - } - When the quad library is /quadLib/ & $k has quad /q/ { - Claim $editor has quad [$quadLib move $q up 105%] - } - Claim $k has created editor $editor - 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/ { + When $k points up with length 0.3 at /program/ &\ + /nobody/ claims /program/ is an editor { + + Wish tag $program is stabilized - Claim $k is typing into $editor + # Create a synthetic editor on top of the program being edited,. + set editor [list $k editor] + Claim $editor is an editor + Claim editor $editor has selected program $program + Wish $editor has a canvas with layer 98 + + When $program has resolved geometry /geom/ { + Claim $editor has resolved geometry $geom + } + When $program has quad /q/ { Claim $editor has quad $q } + Claim $k has created editor $editor + Claim $k is typing into $editor + } } When the program save directory is /programDir/ &\ the editor utils library is /utils/ { # TODO: also don't hardcode this? -set margin [list 0.01 0.005 0.005 0.01] ;# CSS order (top, right, bottom, left) set defaults { textScale 0.01 } - -set editorLib [library create editorLib {margin defaults} { - proc getAdvance {em} { - # From NeomatrixCode.csv - return $(0.5859375 * $em) - } - - proc widthAndHeight {resolvedGeom} { - set tagSize [dict get $resolvedGeom tagSize] - set left [dict get $resolvedGeom left] - set right [dict get $resolvedGeom right] - set top [dict get $resolvedGeom top] - set bottom [dict get $resolvedGeom bottom] - - set width $($left + $tagSize + $right) - set height $($top + $tagSize + $bottom) - - return [list $width $height] - } - - # given program and the editor options, figure out how many characters can - # fit in this editor - proc editorSizeInCharacters {resolvedGeom options} { - variable margin - - set textScale [dict get $options scale] - set advance [getAdvance $textScale] - - lassign [widthAndHeight $resolvedGeom] width height - set width $($width - [lindex $margin 3] - $advance*2.5 - [lindex $margin 1]) - set height $($height - [lindex $margin 0] - [lindex $margin 2]) - - set widthInCharacters $(int($width / $advance)) - set heightInCharacters $(int($height / $textScale)) - - return [list $widthInCharacters $heightInCharacters] - } -}] - When /someone/ claims /editor/ is an editor { Claim $editor is an editor with {*}$defaults } @@ -80,13 +40,7 @@ When /editor/ is an editor with /...options/ { if {![info exists options]} { return } set options [dict merge $defaults $options] - - Wish tag $editor is stabilized - - # Select which program the editor is viewing - When $editor points up with length 0.3 at /program/ { - Claim editor $editor has selected program $program - } + Claim editor $editor has margin [list 0.01 0.005 0.005 0.01] ;# CSS order (top, right, bottom, left) # Initial setup # Load initial text settings if not set @@ -103,8 +57,9 @@ When /editor/ is an editor with /...options/ { # We then use its size to figure out how many characters we can fit in it, # width-wise and height-wise. When $editor has resolved geometry /geom/ &\ + editor $editor has margin /margin/ &\ editor $editor has font options with /...options/ { - Claim editor $editor has viewport size [$editorLib editorSizeInCharacters $geom $options] + Claim editor $editor has viewport size [$utils editorSizeInCharacters $margin $geom $options] } # Load in defaults for the editor if it hasn't been initialized @@ -153,8 +108,21 @@ When /keyboard/ is a keyboard with path /kbPath/ /...anything/ &\ /keyboard/ is typing into /editor/ &\ /editor/ is an editor with /...anything/ &\ editor /editor/ has selected program /program/ { + Wish $editor is outlined green + When $editor has canvas /editorCanvas/ with /...wiOpts/ { + set bgColor [list 0 0 0 0.8] + Wish the GPU draws pipeline "fillTriangle" onto canvas $editorCanvas \ + with arguments [list {{1 0 0} {0 1 0} {0 0 1}} \ + [list -1 -1] [list 1 -1] [list 1 1] $bgColor] \ + layer -2 + Wish the GPU draws pipeline "fillTriangle" onto canvas $editorCanvas \ + with arguments [list {{1 0 0} {0 1 0} {0 0 1}} \ + [list -1 -1] [list 1 1] [list -1 1] $bgColor] \ + layer -2 + } + Subscribe: keyboard $kbPath claims key /key/ is /keyState/ with /...options/ { ForEach! editor $editor has viewport position /vpPos/ &\ editor $editor has viewport size /vpSize/ &\ @@ -277,7 +245,7 @@ When /keyboard/ is a keyboard with path /kbPath/ /...anything/ &\ Notify: save code on editor $editor } Control_p { - Notify: print code $code + Notify: print program from editor $editor # Give the user some feedback Hold! -key printing-alert:$editor \ @@ -416,7 +384,7 @@ When /editor/ is an editor with /...anything/ &\ lassign [$utils cursorToXy $code $cursor] cursorX cursorY set textScale [dict get $textOptions scale] - set advance [$editorLib getAdvance $textScale] + set advance [$utils getAdvance $textScale] set offsetX $(($cursorX - $vpX) * $advance) set offsetY $(($cursorY - $vpY) * $textScale) @@ -424,94 +392,4 @@ When /editor/ is an editor with /...anything/ &\ Claim editor $editor has cursor position [list $offsetX $offsetY] } -# Draw text and cursor -When /editor/ is an editor with /...anything/ &\ - editor /editor/ has viewport position /vpPos/ &\ - editor /editor/ has viewport size /vpSize/ &\ - editor /editor/ has font options with /...fontOptions/ { - lassign $vpPos vpX vpY - lassign $vpSize vpWidth vpHeight - - set textScale [dict get $fontOptions scale] - set advance [$editorLib getAdvance $textScale] - - When editor $editor has selected program /program/ &\ - editor buffer for /program/ is /code/ &\ - editor $editor has cursor /cursor/ &\ - editor $editor has cursor position /cursorPos/ &\ - editor $editor has selection anchor /selAnchor/ { - set lineCount [min [- [llength [split $code "\n"]] $vpY] $vpHeight] - set lineNumbers [$utils lineNumberView $vpY $lineCount] - - set marginLeft [lindex $margin 3] - set lineNumbersRight $($marginLeft + $advance*1.5) - Wish to draw text onto $editor with \ - position [list $lineNumbersRight [lindex $margin 0]] \ - text $lineNumbers \ - scale $textScale anchor topright font NeomatrixCode - - set text [$utils applyTextViewport $code $vpX $vpY $vpWidth $vpHeight] - set pos [list [+ $lineNumbersRight $advance] [lindex $margin 0]] - Wish to draw text onto $editor with \ - position $pos text $text \ - scale $textScale anchor topleft font NeomatrixCode - - # Draw selection highlight - if {$selAnchor ne ""} { - set rawStart [min $selAnchor $cursor] - set rawEnd [max $selAnchor $cursor] - lassign [$utils cursorToXy $code $rawStart] selStartX selStartY - lassign [$utils cursorToXy $code $rawEnd] selEndX selEndY - - set lines [split $code "\n"] - for {set ly $selStartY} {$ly <= $selEndY} {incr ly} { - if {$ly < $vpY || $ly >= $vpY + $vpHeight} continue - - set lineLen [string length [lindex $lines $ly]] - - # Absolute column range for selection on this line - if {$ly == $selStartY} { - set absStart $selStartX - } else { - set absStart 0 - } - if {$ly == $selEndY} { - set absEnd $selEndX - } else { - set absEnd $lineLen - } - - # Clip to viewport - set absStart [max $absStart $vpX] - set absEnd [min $absEnd [+ $vpX $vpWidth]] - - if {$absStart >= $absEnd} continue - - # Convert to display coordinates - set dispStart [- $absStart $vpX] - set dispEnd [- $absEnd $vpX] - set dispRow [- $ly $vpY] - - set x0 $([lindex $pos 0] + $dispStart * $advance) - set x1 $([lindex $pos 0] + $dispEnd * $advance) - set y0 $([lindex $pos 1] + $dispRow * $textScale) - set y1 $($y0 + $textScale) - - Wish to draw a quad onto $editor with \ - p0 [list $x0 $y0] p1 [list $x1 $y0] \ - p2 [list $x1 $y1] p3 [list $x0 $y1] \ - color {0.2 0.4 0.8 0.7} layer -1 - } - } - - set p1 [vec2 add $cursorPos $pos] - set p2 [vec2 add $p1 [list 0 [* $textScale 1.2]]] - set s [/ $textScale 6] - Wish to draw a circle onto $editor with center $p1 radius $s thickness 0 color green filled true - Wish to draw a line onto $editor with points [list $p1 $p2] width $s color green - } -} - - -# end of library code } diff --git a/builtin-programs/editor/print-editor.folk b/builtin-programs/editor/print-editor.folk new file mode 100644 index 00000000..65e4f725 --- /dev/null +++ b/builtin-programs/editor/print-editor.folk @@ -0,0 +1,81 @@ +set formats [subst { + letter { + tagInnerSideLength 70 + pageSize {612 792} + } + a4 { + tagInnerSideLength 70 + pageSize {595 842} + } + indexcard { + tagInnerSideLength 70 + pageSize {612 792} + } +}] +# indexcard (really receipt) assumes fake letter/A4 size: +# https://github.com/NaitLee/Cat-Printer/discussions/8#discussioncomment-2557843 + +fn editorToPrintOptions {editor} { + set program [dict get [QueryOne! editor $editor has selected program /program/] program] + set code [dict get [QueryOne! editor buffer for $program is /code/] code] + + set fontOptions [dict get [QueryOne! editor $editor has font options with /...opts/] opts] + set textScale $fontOptions(scale) + set margin [dict get [QueryOne! editor $editor has margin /margin/] margin] + + # TODO: support other formats (it should be set in the editor so + # the user gets an accurate preview.) + # if {![dict exists $options format]} { + # set defaultFormatMatches [Query! paper format /format/ is the default paper format] + # if {[llength $defaultFormatMatches] > 0} { + # dict set options format [dict get [lindex $defaultFormatMatches 0] format] + # } + # } + set fmt $formats(letter) + set mToPt 2834.646 + return [dict merge $fmt \ + [dict create \ + code $code \ + lineHeight [* $textScale $mToPt] \ + advance [* 0.5859375 $textScale $mToPt] \ + margin [lmap x $margin {* $x $mToPt}]]] +} + +Subscribe: print program from editor /editor/ { + set options [editorToPrintOptions $editor] + Notify: print a new program with {*}$options +} + +# Print preview: +When the codeToPostScript is /codeToPostScript/ &\ + /someone/ wishes editor /editor/ has a print preview &\ + editor /editor/ has selected program /program/ { + + set preview [list $editor preview] + Wish $preview has a canvas + set fmt $formats(letter) + set mToPt 2834.646 + set previewGeom [list width [/ [lindex $fmt(pageSize) 0] $mToPt] \ + height [/ [lindex $fmt(pageSize) 1] $mToPt]] + Claim $preview has resolved geometry $previewGeom + When the quad library is /quadLib/ & $editor has quad /q/ { + Claim $preview has quad [$quadLib alignGeometry \ + [$quadLib move $q right 100%] \ + $previewGeom] + } + Wish $preview is outlined white + + fn codeToPostScript + When editor buffer for $program is /code/ { + set ps [codeToPostScript 48700 $code [editorToPrintOptions $editor]] + + set psFile [file tempfile].ps + set fp [open $psFile w]; puts $fp $ps; close $fp + set pngFile [file tempfile].png + set result [exec gs -dNOPAUSE -dBATCH -sFONTPATH=vendor/fonts \ + -sDEVICE=png16m -r300 \ + -sOutputFile=$pngFile $psFile] + puts stderr "gs to render preview: $result" + Wish $preview displays image $pngFile with width $previewGeom(width) + } +} diff --git a/builtin-programs/gpu/canvases.folk b/builtin-programs/gpu/canvases.folk index 6ffb5667..c170b2a5 100644 --- a/builtin-programs/gpu/canvases.folk +++ b/builtin-programs/gpu/canvases.folk @@ -268,14 +268,14 @@ When the GPU library is /gpuLib/ &\ When /someone/ wishes the GPU creates canvas /id/ with /...options/ { puts "Create canvas: $id" - set width [dict get $options width] - set height [dict get $options height] - set settle [dict getdef $options settle 3ms] + dict set options width [dict getdef $options width 1024] + dict set options height [dict getdef $options height 1024] + dict set options settle [dict getdef $options settle 3ms] - set wi [$gpuCanvasLib create $width $height] + set wi [$gpuCanvasLib create $options(width) $options(height)] Claim the GPU has created canvas $id with \ - width $width height $height \ + {*}$options \ texture [$gpuCanvasLib gpuTexture $wi] \ writableInfo $wi \ -destructor [list $gpuCanvasLib destroy $wi] @@ -283,10 +283,10 @@ When the GPU library is /gpuLib/ &\ Wish to collect results for \ [list /wisher/ wishes the GPU draws pipeline /name/ \ onto canvas $id with /...options/] \ - with settle $settle + with settle $options(settle) } - Wish the GPU runs frame prelude handler [list apply {{gpuCanvasLib} { + Wish the GPU runs frame prelude handler [list apply {{gpuCanvasLib gpuTextureLib} { upvar missingPipelines missingPipelines upvar mostRecentDrawListsByTexture mostRecentDrawListsByTexture if {![info exists missingCanvases]} { @@ -400,6 +400,11 @@ When the GPU library is /gpuLib/ &\ } } } + # Image texture wishes can publish draw commands while their + # descriptor writes are still queued. Drain before recording + # canvas command buffers so those handles are drawable. + $gpuTextureLib drainDeferredTextureOps + dict for {id drawLists} $drawListsByTexture { if {[dict exists $mostRecentDrawListsByTexture $id] && ($drawLists eq $mostRecentDrawListsByTexture($id))} { @@ -424,7 +429,7 @@ When the GPU library is /gpuLib/ &\ foreach ref $acquiredRefs { StatementRelease! $ref } - }} $gpuCanvasLib] + }} $gpuCanvasLib $gpuTextureLib] When /someone/ wishes /p/ has a canvas { Wish $p has a canvas with width 1024 height 1024 settle 3ms @@ -483,7 +488,7 @@ When the GPU library is /gpuLib/ &\ # can draw onto it using the canvas-oriented interface. set dispCanvas [list $disp canvas] Wish the GPU creates canvas $dispCanvas with \ - width $dispWidth height $dispHeight settle 0ms + width $dispWidth height $dispHeight settle 0ms layer 100 When the GPU has created canvas $dispCanvas with /...canvOpts/ { Claim $disp has canvas $dispCanvas with {*}$canvOpts @@ -510,7 +515,8 @@ When the GPU library is /gpuLib/ &\ Wish the GPU draws pipeline "composite-canvas" with arguments \ [list [list $dispWidth $dispHeight] \ $surfaceToClip \ - [dict get $canvOpts texture] $a $b $c $d] + [dict get $canvOpts texture] $a $b $c $d] \ + layer [dict getdef $canvOpts layer 99] } } } diff --git a/builtin-programs/gpu/draw.folk b/builtin-programs/gpu/draw.folk index d48291a4..c59db073 100644 --- a/builtin-programs/gpu/draw.folk +++ b/builtin-programs/gpu/draw.folk @@ -12,6 +12,7 @@ if {[info exists this] && $::tcl_platform(os) eq "darwin"} { When the GPU library is /gpuLib/ &\ the GPU Vulkan handle type definer is /defineVulkanHandleType/ &\ + the GPU texture library is /gpuTextureLib/ &\ the GPU pipeline library is /pipelineLib/ { fn defineVulkanHandleType @@ -59,7 +60,7 @@ $cc code [subst { uint32_t imageIndex; VkSemaphore imageAvailableSemaphore; - VkSemaphore renderFinishedSemaphore; + VkSemaphore* renderFinishedSemaphores; VkFence inFlightFence; [expr { $useGlfw ? "GLFWwindow* window;" : "" }] } DisplayState; @@ -343,7 +344,10 @@ $cc proc initDisplay {char* display uint32_t width uint32_t height uint32_t refr fenceInfo.flags = VK_FENCE_CREATE_SIGNALED_BIT; $[vktry {vkCreateSemaphore(device, &semaphoreInfo, NULL, &ds->imageAvailableSemaphore)}] - $[vktry {vkCreateSemaphore(device, &semaphoreInfo, NULL, &ds->renderFinishedSemaphore)}] + ds->renderFinishedSemaphores = calloc(ds->swapchainImageCount, sizeof(VkSemaphore)); + for (uint32_t i = 0; i < ds->swapchainImageCount; i++) { + $[vktry {vkCreateSemaphore(device, &semaphoreInfo, NULL, &ds->renderFinishedSemaphores[i])}] + } $[vktry {vkCreateFence(device, &fenceInfo, NULL, &ds->inFlightFence)}] } @@ -358,7 +362,13 @@ $cc proc drawStart {DisplayState* ds} void { vkResetFences(device, 1, &ds->inFlightFence); - vkAcquireNextImageKHR(device, ds->swapchain, UINT64_MAX, ds->imageAvailableSemaphore, VK_NULL_HANDLE, &ds->imageIndex); + VkResult acquireResult = vkAcquireNextImageKHR(device, ds->swapchain, UINT64_MAX, + ds->imageAvailableSemaphore, VK_NULL_HANDLE, + &ds->imageIndex); + if (acquireResult != VK_SUCCESS && acquireResult != VK_SUBOPTIMAL_KHR) { + FOLK_ERROR("Failed vkAcquireNextImageKHR: %s (%d)\n", + VkResultToString(acquireResult), acquireResult); + } vkResetCommandBuffer(commandBuffer, 0); @@ -445,7 +455,7 @@ $cc proc drawEnd {} void { vkCmdEndRenderPass(commandBuffer); $[vktry {vkEndCommandBuffer(commandBuffer)}] - VkSemaphore signalSemaphores[] = {ds->renderFinishedSemaphore}; + VkSemaphore signalSemaphores[] = {ds->renderFinishedSemaphores[ds->imageIndex]}; { VkSubmitInfo submitInfo = {0}; submitInfo.sType = VK_STRUCTURE_TYPE_SUBMIT_INFO; @@ -466,6 +476,7 @@ $cc proc drawEnd {} void { $[vktry {vkQueueSubmit(*graphicsQueue_ptr(), 1, &submitInfo, ds->inFlightFence)}] pthread_mutex_unlock(graphicsQueueMutex_ptr()); } + { VkPresentInfoKHR presentInfo = {0}; presentInfo.sType = VK_STRUCTURE_TYPE_PRESENT_INFO_KHR; @@ -479,8 +490,12 @@ $cc proc drawEnd {} void { presentInfo.pResults = NULL; pthread_mutex_lock(graphicsQueueMutex_ptr()); - vkQueuePresentKHR(*presentQueue_ptr(), &presentInfo); + VkResult presentResult = vkQueuePresentKHR(*presentQueue_ptr(), &presentInfo); pthread_mutex_unlock(graphicsQueueMutex_ptr()); + if (presentResult != VK_SUCCESS && presentResult != VK_SUBOPTIMAL_KHR) { + FOLK_ERROR("Failed vkQueuePresentKHR: %s (%d)\n", + VkResultToString(presentResult), presentResult); + } } // Wait for this display's submission to complete before we @@ -937,7 +952,8 @@ When /wisher/ wishes the GPU compiles pipeline /name/ /source/ { set missingPipelines [dict create] while true { - # Run prelude handlers once per frame (textures, canvases). + # Advance texture retirement once per frame, then run canvas redraw work. + $gpuTextureLib beginTextureFrame ForEach! /someone/ wishes the GPU runs frame prelude handler /hd/ { {*}$hd } @@ -1004,6 +1020,10 @@ while true { } } + # Make textures published while building the display list drawable + # before we record display command buffers. + $gpuTextureLib drainDeferredTextureOps + # Draw to each active display. dict for {displayName ds} $displays { if {$ds eq "missing"} { continue } diff --git a/builtin-programs/gpu/textures.folk b/builtin-programs/gpu/textures.folk index e74e4074..0cf2cebe 100644 --- a/builtin-programs/gpu/textures.folk +++ b/builtin-programs/gpu/textures.folk @@ -22,6 +22,8 @@ $gpuc code { VmaAllocator vmaGetAllocator(); } $gpuc include +$gpuc include +$gpuc include $gpuc include $gpuc extend $gpuLib @@ -87,9 +89,11 @@ defineVulkanHandleType $gpuc VkImageView defineVulkanHandleType $gpuc VkSampler $gpuc struct GpuTextureBlock { bool _Atomic alive; + bool _Atomic retiring; int width; int height; + int retireAfterFrame; GpuTextureHandle handle; @@ -118,6 +122,9 @@ $gpuc code { struct DeferredTextureEntry deferredQueue[DEFERRED_QUEUE_CAP]; int _Atomic deferredQueueCount = 0; pthread_mutex_t deferredQueueMutex = PTHREAD_MUTEX_INITIALIZER; + + #define TEXTURE_RETIRE_GRACE_FRAMES 2 + int textureFrameEpoch = 0; } $gpuc proc textureManagerInit {} void { $[vktry volkInitialize()] @@ -432,18 +439,21 @@ $gpuc proc copyImageToRgba {Image im Image ret} void { $gpuc code [csubst { GpuTextureHandle allocateGpuTextureHandle() { - for (int i = 0; i < getMaxTextures(); i++) { - bool notAlive = false; - if (atomic_compare_exchange_weak(&gpuTextures[i].alive, ¬Alive, true)) { - gpuTextures[i].handle = i; - return i; + for (;;) { + for (int i = 0; i < getMaxTextures(); i++) { + bool notAlive = false; + if (atomic_compare_exchange_weak(&gpuTextures[i].alive, ¬Alive, true)) { + gpuTextures[i].handle = i; + return i; + } } + fprintf(stderr, "gpu/textures: Exceeded GPU max textures (%d):\n", getMaxTextures()); + for (int i = 0; i < getMaxTextures(); i++) { + fprintf(stderr, " %d: %s\n", i, gpuTextures[i].alive ? gpuTextures[i].description : ""); + } + struct timespec ts = {0, 5000000}; + nanosleep(&ts, NULL); } - fprintf(stderr, "gpu/textures: Exceeded GPU max textures (%d):\n", getMaxTextures()); - for (int i = 0; i < getMaxTextures(); i++) { - fprintf(stderr, " %d: %s\n", i, gpuTextures[i].alive ? gpuTextures[i].description : ""); - } - exit(1); } }] @@ -520,6 +530,8 @@ $gpuc proc createGpuTexture {int width int height int format} GpuTextureBlock* { block->width = width; block->height = height; + block->retiring = false; + block->retireAfterFrame = 0; createImage(width, height, (VkFormat) format, VK_IMAGE_TILING_OPTIMAL, @@ -568,13 +580,8 @@ $gpuc proc createGpuTexture {int width int height int format} GpuTextureBlock* { return block; } -# In-flight texture upload ring, per worker thread. Lets -# copyImageToGpuTexture submit a staging-buffer->image copy without -# waiting for it to complete; the staging buffer is reclaimed lazily -# on a later call once the GPU is done with it. We only block when -# the ring fills up (i.e. we've pipelined enough uploads that the -# oldest one still isn't done), which is the natural backpressure -# point for a single worker. +# Per-worker reusable texture upload slots. Staging buffers stay alive +# until their slot is reused and the previous upload fence has signaled. $gpuc code { #define INFLIGHT_UPLOADS 8 struct InflightUpload { @@ -605,6 +612,8 @@ $gpuc code { #endif vmaDestroyBuffer(vmaGetAllocator(), slot->stagingBuffer, slot->stagingBufferAllocation); + slot->stagingBuffer = VK_NULL_HANDLE; + slot->stagingBufferAllocation = NULL; slot->inUse = false; } if (slot->fence == VK_NULL_HANDLE) { @@ -621,6 +630,8 @@ $gpuc code { allocInfo.level = VK_COMMAND_BUFFER_LEVEL_PRIMARY; allocInfo.commandBufferCount = 1; vkAllocateCommandBuffers(device, &allocInfo, &slot->cmdBuffer); + } else { + vkResetCommandBuffer(slot->cmdBuffer, 0); } return slot; } @@ -757,8 +768,17 @@ $gpuc proc freeGpuTexture {GpuTextureHandle gim} void { # Actually destroy a texture's GPU resources. Must only be called # on the GPU thread between frames when the GPU is idle. $gpuc code { + static void retireGpuTexture(GpuTextureHandle gim) { + GpuTextureBlock* block = &gpuTextures[gim]; + if (gim == 0 || !block->alive || block->retiring) return; + + block->retiring = true; + block->retireAfterFrame = textureFrameEpoch + TEXTURE_RETIRE_GRACE_FRAMES; + } + static void destroyGpuTextureResources(GpuTextureHandle gim) { GpuTextureBlock* block = &gpuTextures[gim]; + if (gim == 0 || !block->alive) return; // Point this descriptor slot at the placeholder texture (slot 0) // so later frames don't reference a destroyed image. @@ -783,18 +803,34 @@ $gpuc code { #ifdef TRACY_ENABLE TracyCFree(block->textureImageAllocation); #endif - vmaDestroyImage(vmaGetAllocator(), block->textureImage, block->textureImageAllocation); vkDestroySampler(device, block->textureSampler, NULL); vkDestroyImageView(device, block->textureImageView, NULL); + vmaDestroyImage(vmaGetAllocator(), block->textureImage, block->textureImageAllocation); free(block->description); + block->description = NULL; + block->textureImage = VK_NULL_HANDLE; + block->textureImageAllocation = NULL; + block->textureImageView = VK_NULL_HANDLE; + block->textureSampler = VK_NULL_HANDLE; + block->retiring = false; + block->retireAfterFrame = 0; block->alive = false; } + + static void destroyRetiredGpuTextures() { + for (GpuTextureHandle gim = 1; gim < getMaxTextures(); gim++) { + GpuTextureBlock* block = &gpuTextures[gim]; + if (block->alive && block->retiring && + block->retireAfterFrame <= textureFrameEpoch) { + destroyGpuTextureResources(gim); + } + } + } } -# Called on the GPU thread between frames, after the previous -# frame's fence has been waited on (GPU is idle). -$gpuc proc processDeferredTextureOps {} void { +# Called on the GPU thread before recording work that may sample textures. +$gpuc proc drainDeferredTextureOps {} void { pthread_mutex_lock(&deferredQueueMutex); int count = deferredQueueCount; struct DeferredTextureEntry localQueue[DEFERRED_QUEUE_CAP]; @@ -808,10 +844,19 @@ $gpuc proc processDeferredTextureOps {} void { writeTextureDescriptor(localQueue[i].handle); break; case DEFERRED_FREE: - destroyGpuTextureResources(localQueue[i].handle); + retireGpuTexture(localQueue[i].handle); break; } } + + destroyRetiredGpuTextures(); +} + +# Called once per GPU frame so retired textures age exactly once, +# even though descriptor work may be drained multiple times. +$gpuc proc beginTextureFrame {} void { + textureFrameEpoch++; + drainDeferredTextureOps(); } $gpuc proc initPlaceholderTexture {} void { @@ -829,7 +874,7 @@ $gpuc proc initPlaceholderTexture {} void { debugIm.data[i+0] = 255; debugIm.data[i+1] = 0; debugIm.data[i+2] = 255; - debugIm.data[i+3] = 0; + debugIm.data[i+3] = 255; } } GpuTextureHandle han = copyImageToGpuTexture(debugIm); @@ -839,7 +884,7 @@ $gpuc proc initPlaceholderTexture {} void { // drain the queued DEFERRED_ADD for slot 0 (which is now redundant // but harmless). initializeDescriptorSet(han); - processDeferredTextureOps(); + drainDeferredTextureOps(); } set gpuTextureLib [$gpuc compile] @@ -848,10 +893,6 @@ $gpuTextureLib textureManagerInit Claim the GPU texture library is $gpuTextureLib -Wish the GPU runs frame prelude handler [list apply {{gpuTextureLib} { - $gpuTextureLib processDeferredTextureOps -}} $gpuTextureLib] - When /someone/ wishes the GPU loads image /im/ as texture { set gtex [$gpuTextureLib copyImageToGpuTexture $im] Claim the GPU has loaded image $im as texture $gtex \ diff --git a/builtin-programs/mask-tags.folk b/builtin-programs/mask-tags.folk index f3cabc79..291f7f46 100644 --- a/builtin-programs/mask-tags.folk +++ b/builtin-programs/mask-tags.folk @@ -15,6 +15,6 @@ When the quad library is /quadLib/ &\ Wish to draw a quad onto $proj with \ p0 $p0 p1 $p1 p2 $p2 p3 $p3 \ - color black layer 99 + color black layer 100 } -} \ No newline at end of file +} diff --git a/builtin-programs/print.folk b/builtin-programs/print.folk deleted file mode 100644 index e8a04e16..00000000 --- a/builtin-programs/print.folk +++ /dev/null @@ -1,339 +0,0 @@ -# Configuring printers -# -# Start by adding a printer to CUPS. You can do this from the Web UI, or declare it using Folk: -# -# Assert $::thisNode claims printer "printer-name" is a cups printer with url "http://url/ipp/print" driver "everywhere" -# -# Whether the printer was added via Folk or not, you need to let Folk know which formats your printer supports: -# -# Claim printer my-printer can print double-sided a4 paper -# Claim printer alt-printer can print single-sided indexcard paper -# -# Use "double-sided" if the printer supports printing on both sides of the paper in a single printing operation. -# -# Lastly, you need to declare a default printer and default paper format: -# (make sure that the default printer supports the default paper format) -# -# Claim printer my-printer is the default printer -# Claim paper format a4 is the default paper format - -When libapriltag has been built with config /configCcWithLibapriltag/ &\ - the image library is /imageLib/ &\ - the program save directory is /saveDir/ { -fn configCcWithLibapriltag - -set cc [C] -$cc extend $imageLib -$cc cflags -Wall -Werror -configCcWithLibapriltag $cc - -$cc code { - #include - #include - apriltag_family_t *tf = NULL; -} - -# HACK (osnr): This is used when someone wants to draw an AprilTag -# (often for calibration/cnc preview purposes); I put it here because -# we already have a whole AprilTag family and C compiler object setup -# here. The returned image_t's data needs to be freed by the caller. -$cc proc tagImageForId {int id} Image { - if (tf == NULL) tf = tagStandard52h13_create(); - - image_u8_t* image = apriltag_to_image(tf, id); - Image ret = { - .width = image->width, .height = image->height, - .components = 1, .bytesPerRow = image->stride, - .data = image->buf - }; - free(image); // doesn't free data - return ret; -} - -$cc proc tagPsForId {int id} char* { - if (tf == NULL) tf = tagStandard52h13_create(); - - image_u8_t* image = apriltag_to_image(tf, id); - - char* ret = malloc(10000); -#define emit(...) i += sprintf(&ret[i], __VA_ARGS__) - int i = 0; - emit("gsave\n"); - emit("0 1 translate\n"); - emit("%f %f scale\n", 1.0/image->width, -1.0/image->height); - for (int row = 0; row < image->height; row++) { - for (int col = 0; col < image->width; col++) { - uint8_t pixel = image->buf[(row * image->stride) + col]; - emit("%d setgray ", pixel != 0); - emit("newpath "); - emit("%d %d moveto ", col, row); // bottom-left - emit("%d %d lineto ", col + 1, row); // bottom-right - emit("%d %d lineto ", col + 1, row + 1); // top-right - emit("%d %d lineto ", col, row + 1); // top-left - emit("closepath fill "); - } - emit("\n"); - } - emit("grestore\n"); -#undef emit - ret[i++] = '\0'; - image_u8_destroy(image); - return ret; -} -set printLib [$cc compile] -Claim the print library is $printLib - -fn paginate {text maxlines linelen {linelenOverrides {}}} { - set lines [split $text "\n"] - - for {set i 0} {$i < [llength $lines]} {incr i} { - # tag each line with its 1-indexed line number - lset lines $i [list [expr {$i+1}] [lindex $lines $i]] - } - - set safeline 0 - set firstline 0 - set pages "" - for {set i 0} {$i < [llength $lines]} {incr i} { # hard-wrap lines - if {$i - $firstline > $maxlines - 1} { - set pagelines [lrange $lines $firstline $safeline-1] - lappend pagelines [list "..." ""] - lappend pages $pagelines - set firstline $safeline - } - - lassign [lindex $lines $i] linenum line - set max [dict getdef $linelenOverrides $i $linelen] - if {$max == 0} { - lset lines $i [list "" ""] - set lines [linsert $lines $i+1 [list $linenum $line]] - - } elseif {[string length $line] > $max} { - lset lines $i 1 [string range $line 0 $max] - set lines [linsert $lines $i+1 [list "" [string range $line $max+1 end]]] - - } elseif {$linenum ne ""} { - set safeline $i - } - } - - lappend pages [lrange $lines $firstline end] - - return $pages -} - -fn rangeDict {from to val} { - set res "" - for {set i $from} {$i < $to} {incr i} { - lappend res $i $val - } - return $res -} - -fn programToPs {id text {format "letter"} {mixins {}}} { - set defaults { - margin 36 - fontsize 12 - tagsize {150 150} - maxcharsOverride {} - } - set formats [subst { - letter { - pagesize {612 792} - maxlines 40 - maxchars 72 - maxcharsOverride {[rangeDict 0 8 49]} - } - a4 { - pagesize {595 842} - maxlines 43 - maxchars 68 - maxcharsOverride {[rangeDict 0 8 46]} - } - indexcard { - fontsize 24 - tagsize {300 300} - pagesize {612 792} - maxlines 22 - maxchars 34 - maxcharsOverride {[rangeDict 0 9 0]} - } - }] - # indexcard (really receipt) assumes fake letter/A4 size: - # https://github.com/NaitLee/Cat-Printer/discussions/8#discussioncomment-2557843 - - set params [dict merge $defaults [dict get $formats $format]] - dict with params { - lassign $pagesize PageWidth PageHeight - lassign $tagsize tagwidth tagheight - set lineheight [expr $fontsize*1.5] - - set image [$printLib tagPsForId $id] - - set pages [paginate $text $maxlines $maxchars $maxcharsOverride] - - set out "" - set pageidx 0 - foreach lines $pages { - set lineidx 0 - append out [subst { - %!PS - << /PageSize \[$PageWidth $PageHeight\] >> setpagedevice - - /settextcolor {0 setgray} def - - /Courier findfont - $fontsize scalefont - setfont - newpath - [join [lmap lineinfo $lines { - lassign $lineinfo linenum line - set line [string map {"\\" "\\\\" ")" "\\)" "(" "\\("} $line] - incr lineidx - subst { - $margin [expr $PageHeight-$margin-$lineidx*$lineheight] moveto - 0.4 setgray ([format "%- 3s" $linenum]) show settextcolor ($line) show - } - }] "\n"] - - [expr {$pageidx ? {} : [subst { - gsave - [expr $PageWidth-$tagwidth-$margin] [expr $PageHeight-$tagheight-$margin] translate - $tagwidth $tagheight scale - $image - grestore - - /Helvetica-Narrow findfont - [- $fontsize 2] scalefont - setfont - newpath - [expr $PageWidth-$tagwidth-$margin] [expr $PageHeight-$tagheight-16-$margin] moveto - ($id ([clock format [clock seconds] -format "%a, %d %b %Y, %r"])) show - - [join [lmap mixin $mixins { - # We run mixins only on page 1 for now. They - # get access to everything in scope. Kind of - # hacky, but OK for now. - - subst $mixin - }] "\n"] - }] }] - showpage - }] - incr pageidx - } - } - - return $out -} -Claim the programToPs is [fn programToPs] -fn nextId {} { - set idResults [Query! the next program id is /id/] - if {[llength $idResults] == 0} { - set id 0 - } else { - set id [dict get [lindex $idResults 0] id] - } - - while {[file exists "$saveDir/$id.folk"]} { - incr id - } - - Hold! -save -key next-id the next program id is $id - - set id -} -When $::thisNode claims printer /name/ is a cups printer with /...options/ { - set command [list /usr/sbin/lpadmin -p $name -E] - if {[dict exists $options url]} { - lappend command -v [dict get $options url] - } - - if {[dict exists $options driver]} { - lappend command -m [dict get $options driver] - } - - if {[dict exists $options extra-args]} { - lappend command {*}[dict get $options extra-args] - } - - exec {*}$command -} - -Subscribe: print code /code/ with /...options/ { - if {$::thisNode eq "folk-beads" || $::thisNode eq "folk-convivial"} { - # HACK: Forward the print request to folk-hex. - exec curl -X POST "http://folk-hex.local:4273/" \ - -H "Content-Type: text/plain" \ - -d [list Notify: print code $code with printer Canon_TR150_series]; - return - } - - set id [nextId] - if {![info exists options]} { set options [dict create]} - Notify: print program $id with code $code {*}$options -} -Subscribe: print program /id/ with /...options/ { - set code [dict get $options code] - - ForEach! printer /printer/ is a receipt printer &\ - printer /printer/ is the default printer { - Notify: print program $id on receipt printer $printer with code $code - return - } - - if {![dict exists $options printer]} { - set defaultPrinterMatches [Query! printer /printer/ is the default printer] - if {[llength $defaultPrinterMatches] > 0} { - dict set options printer [dict get [lindex $defaultPrinterMatches 0] printer] - } - } - - if {![dict exists $options format]} { - set defaultFormatMatches [Query! paper format /format/ is the default paper format] - if {[llength $defaultFormatMatches] > 0} { - dict set options format [dict get [lindex $defaultFormatMatches 0] format] - } - } - - set printer [dict getdef $options printer /printer/] - set format [dict getdef $options format /format/] - # TODO: we don't use /sided/ for anything right now. - set results [Query! printer $printer can print /sided/ $format paper] - if {[llength $results] > 0} { - set result [lindex $results 0] - dict with result { - set args [list -P $printer -o media=$format] - } - } else { - puts stderr "print.folk: Couldn't find a matching configured printer; using bare lpr command" - set args [list] - set format letter - } - - # HACK: added for folk2 launch party printing - if {[dict exists $options printer]} { - set args [list -P [dict get $options printer]] - } - - set ps [programToPs $id $code $format] - - # save code and ps to disk - if {[file exists "$saveDir/$id.folk"]} { - error "Program $id already exists on disk. Aborting print." - } - set fp [open "$saveDir/$id.folk" w] - puts $fp $code - close $fp - - set fp [open "$saveDir/$id.ps" w] - puts $fp $ps - close $fp - - exec ps2pdf $saveDir/$id.ps $saveDir/$id.pdf - - puts "Printing program $id on $::thisNode" - exec lpr {*}$args $saveDir/$id.pdf -} - -} diff --git a/builtin-programs/print/print.folk b/builtin-programs/print/print.folk new file mode 100644 index 00000000..a6cbb0a8 --- /dev/null +++ b/builtin-programs/print/print.folk @@ -0,0 +1,333 @@ +# Configuring printers +# +# Start by adding a printer to CUPS. You can do this from the Web UI, or declare it using Folk: +# +# Assert $::thisNode claims printer "printer-name" is a cups printer with url "http://url/ipp/print" driver "everywhere" +# +# Whether the printer was added via Folk or not, you need to let Folk know which formats your printer supports: +# +# Claim printer my-printer can print double-sided a4 paper +# Claim printer alt-printer can print single-sided indexcard paper +# +# Use "double-sided" if the printer supports printing on both sides of the paper in a single printing operation. +# +# Lastly, you need to declare a default printer and default paper format: +# (make sure that the default printer supports the default paper format) +# +# Claim printer my-printer is the default printer +# Claim paper format a4 is the default paper format + +When libapriltag has been built with config /configCcWithLibapriltag/ &\ + the image library is /imageLib/ &\ + the program save directory is /saveDir/ { +fn configCcWithLibapriltag + +set cc [C] +$cc extend $imageLib +$cc cflags -Wall -Werror +configCcWithLibapriltag $cc + +$cc code { + #include + #include + apriltag_family_t *tf = NULL; +} + +# HACK (osnr): This is used when someone wants to draw an AprilTag +# (often for calibration/cnc preview purposes); I put it here because +# we already have a whole AprilTag family and C compiler object setup +# here. The returned image_t's data needs to be freed by the caller. +$cc proc tagImageForId {int id} Image { + if (tf == NULL) tf = tagStandard52h13_create(); + + image_u8_t* image = apriltag_to_image(tf, id); + Image ret = { + .width = image->width, .height = image->height, + .components = 1, .bytesPerRow = image->stride, + .data = image->buf + }; + free(image); // doesn't free data + return ret; +} + +$cc proc tagPsForId {int id} char* { + if (tf == NULL) tf = tagStandard52h13_create(); + + image_u8_t* image = apriltag_to_image(tf, id); + + char* ret = malloc(10000); +#define emit(...) i += sprintf(&ret[i], __VA_ARGS__) + int i = 0; + emit("gsave\n"); + emit("0 1 translate\n"); + emit("%f %f scale\n", 1.0/image->width, -1.0/image->height); + for (int row = 0; row < image->height; row++) { + for (int col = 0; col < image->width; col++) { + uint8_t pixel = image->buf[(row * image->stride) + col]; + emit("%d setgray ", pixel != 0); + emit("newpath "); + emit("%d %d moveto ", col, row); // bottom-left + emit("%d %d lineto ", col + 1, row); // bottom-right + emit("%d %d lineto ", col + 1, row + 1); // top-right + emit("%d %d lineto ", col, row + 1); // top-left + emit("closepath fill "); + } + emit("\n"); + } + emit("grestore\n"); +#undef emit + ret[i++] = '\0'; + image_u8_destroy(image); + return ret; +} +set printLib [$cc compile] +Claim the print library is $printLib + +fn codeToPostScript {id code opts {mixins {}}} { + # All opts should be passed in as points (1/2834.65 of a meter). + lassign $opts(pageSize) PageWidth PageHeight + set tagInnerSideLength $opts(tagInnerSideLength) + set tagWidth [expr {$tagInnerSideLength * 10.0 / 6}] + set tagHeight $tagWidth + lassign $opts(margin) marginTop marginRight marginBottom marginLeft + set tagInset $opts(tagInset) + set lineHeight $opts(lineHeight) + set maxLines $(int(($PageHeight - $marginTop - $marginBottom) / $lineHeight)) + + set lineNumbersRight $($marginLeft + $opts(advance)*1.5) + + set lines [split $code "\n"] + + set image [$printLib tagPsForId $id] + + set outPages [list] + set lineIdx 0 + while {[llength $lines] > 0} { + set pageLines [lrange $lines 0 $maxLines] + set lines [lreplace $lines 0 $maxLines] + + # The typesetting here is meant to exactly duplicate the + # layout in the editor. + lappend outPages [subst { + %!PS + << /PageSize \[$PageWidth $PageHeight\] >> setpagedevice + + [dict getdef $opts calibrationPreamble {}] + + /settextcolor {0 setgray} def + + /NeomatrixCode findfont + $lineHeight scalefont + setfont + + newpath + [join [lmap line $pageLines { + set line [string map {"\\" "\\\\" ")" "\\)" "(" "\\("} $line] + incr lineIdx + subst { + $lineNumbersRight [expr {$PageHeight-$marginTop-$lineIdx*$lineHeight}] moveto + 0.4 setgray ([format "% 3s" $lineIdx]) + dup stringwidth pop neg 0 rmoveto + show + + [+ $lineNumbersRight $opts(advance)] [expr {$PageHeight-$marginTop-$lineIdx*$lineHeight}] moveto + settextcolor ($line) show + } + }] "\n"] + + [expr {[llength $outPages] > 0 ? {} : [subst { + gsave + [expr {$PageWidth-$tagWidth-$marginRight-$tagInset}] [expr {$PageHeight-$tagHeight-$marginTop-$tagInset}] translate + $tagWidth $tagHeight scale + $image + grestore + + /Helvetica-Narrow findfont + 8 scalefont + setfont + newpath + [expr {$PageWidth-$tagWidth-$marginRight-$tagInset}] [expr {$PageHeight-$tagHeight-14-$marginTop-$tagInset}] moveto + ($id ([clock format [clock seconds] -format "%a, %d %b %Y, %r"])) show + + [join [lmap mixin $mixins { + # We run mixins only on page 1 for now. They + # get access to everything in scope. Kind of + # hacky, but OK for now. + + subst $mixin + }] "\n"] + }] }] + + showpage + }] + } + return [join $outPages "\n"] +} +Claim the codeToPostScript is [fn codeToPostScript] + +fn nextId {} { + set idResults [Query! the next program id is /id/] + if {[llength $idResults] == 0} { + set id 0 + } else { + set id [dict get [lindex $idResults 0] id] + } + + while {[file exists "$saveDir/$id.folk"]} { + incr id + } + + # HACK: using old path for backward compatibility. + Hold! -save -on builtin-programs/print.folk -key next-id \ + the next program id is $id + + set id +} +When $::thisNode claims printer /name/ is a cups printer with /...options/ { + set command [list /usr/sbin/lpadmin -p $name -E] + if {[dict exists $options url]} { + lappend command -v [dict get $options url] + } + + if {[dict exists $options driver]} { + lappend command -m [dict get $options driver] + } + + if {[dict exists $options extra-args]} { + lappend command {*}[dict get $options extra-args] + } + + exec {*}$command +} + +Subscribe: print a new program with /...options/ { + if {$::thisNode eq "folk-beads" || $::thisNode eq "folk-convivial"} { + # HACK: Forward the print request to folk-hex. + exec curl -X POST "http://folk-hex.local:4273/" \ + -H "Content-Type: text/plain" \ + -d [list Notify: print a new program with {*}$options]; + return + } + + set id [nextId] + Notify: print program $id with {*}$options +} +Subscribe: print program /id/ with /...options/ { + set code [dict get $options code] + + ForEach! printer /printer/ is a receipt printer &\ + printer /printer/ is the default printer { + Notify: print program $id on receipt printer $printer with code $code + return + } + + set calibPreambleResults [Query! the calibrated print preamble is /preamble/] + if {[llength $calibPreambleResults] > 0} { + dict set options calibrationPreamble [dict get [lindex $calibPreambleResults 0] preamble] + } + + set calibScaleResults [Query! the calibrated print scale is /scale/] + if {[llength $calibScaleResults] > 0} { + set calibScale [dict get [lindex $calibScaleResults 0] scale] + dict set options tagInnerSideLength [expr {70.0 / $calibScale}] + } + + dict set options tagInset 16 + + set ps [codeToPostScript $id $code $options] + + # save code and ps to disk + if {[file exists "$saveDir/$id.folk"]} { + error "Program $id already exists on disk. Aborting print." + } + set fp [open "$saveDir/$id.folk" w]; puts $fp $code; close $fp + + set fp [open "$saveDir/$id.ps" w]; puts $fp $ps; close $fp + exec ps2pdf -dPDFSETTINGS=/prepress -sFONTPATH=vendor/fonts \ + $saveDir/$id.ps $saveDir/$id.pdf + + # Write geometry to meta.folk so the camera system can interpret + # this program's quad and map (line, col) -> physical position. + # All opts are in calibrated points; 1 calibrated pt = 25.4/72 mm. + set ptmm [expr {25.4 / 72.0}] + lassign [dict get $options pageSize] PageWidth PageHeight + set tagInn [dict get $options tagInnerSideLength] + set tagOut [expr {$tagInn * 10.0 / 6}] + lassign [dict get $options margin] marginTop marginRight marginBottom marginLeft + set lh [dict get $options lineHeight] + set adv [dict get $options advance] + + set tagInset [dict get $options tagInset] + set border [expr {($tagOut - $tagInn) / 2.0}] + set gLeft [expr {($PageWidth - $tagOut - $marginRight - $tagInset + $border) * $ptmm}] + set gRight [expr {($marginRight + $tagInset + $border) * $ptmm}] + set gTop [expr {($marginTop + $tagInset + $border) * $ptmm}] + set gBottom [expr {($PageHeight - $tagOut - $marginTop - $tagInset + $border) * $ptmm}] + + # If the first page is sparse enough, assume the user will fold the + # page in half vertically and shrink the reported bottom geometry. + set numLines [llength [split $code "\n"]] + set maxLines [expr {int(($PageHeight - $marginTop - $marginBottom) / $lh)}] + set firstPageLines [expr {$numLines < $maxLines ? $numLines : $maxLines}] + if {$firstPageLines < $maxLines / 2.0} { + set tagSize [expr {$tagInn * $ptmm}] + set pageHeightMm [expr {$tagSize + $gTop + $gBottom}] + set gBottom [expr {$gBottom - $pageHeightMm / 2.0}] + } + + set geomStr [format \ + {tagSize %.4gmm left %.4gmm right %.4gmm top %.4gmm bottom %.4gmm lineHeight %.4gmm advance %.4gmm codeLeft %.4gmm codeTop %.4gmm} \ + [expr {$tagInn * $ptmm}] $gLeft $gRight $gTop $gBottom \ + [expr {$lh * $ptmm}] [expr {$adv * $ptmm}] \ + [expr {($marginLeft + $adv * 2.5) * $ptmm}] \ + [expr {$marginTop * $ptmm}]] + + set fp [open "$saveDir/$id.meta.folk" w] + puts $fp "Claim tag \$this has geometry \{$geomStr\}" + close $fp + + puts "Printing program $id on $::thisNode" + Notify: print pdf $saveDir/$id.pdf with {*}$options +} + +} + +Subscribe: print pdf /pdfPath/ with /...options/ { + if {![info exists options]} { set options {} } + + if {![dict exists $options printer]} { + set defaultPrinterMatches [Query! printer /printer/ is the default printer] + if {[llength $defaultPrinterMatches] > 0} { + dict set options printer [dict get [lindex $defaultPrinterMatches 0] printer] + } + } + + if {![dict exists $options format]} { + set defaultFormatMatches [Query! paper format /format/ is the default paper format] + if {[llength $defaultFormatMatches] > 0} { + dict set options format [dict get [lindex $defaultFormatMatches 0] format] + } + } + + set printer [dict getdef $options printer /printer/] + set format [dict getdef $options format /format/] + # TODO: we don't use /sided/ for anything right now. + set results [Query! printer $printer can print /sided/ $format paper] + if {[llength $results] > 0} { + set result [lindex $results 0] + dict with result { + set args [list -P $printer -o media=$format] + } + } else { + puts stderr "print.folk: Couldn't find a matching configured printer; using bare lpr command" + set args [list] + set format letter + } + + # HACK: added for folk2 launch party printing + if {[dict exists $options printer]} { + set args [list -P [dict get $options printer]] + } + + exec lpr -o print-scaling=none {*}$args $pdfPath +} diff --git a/builtin-programs/tags-to-quads.folk b/builtin-programs/tags-to-quads.folk index 4cc651aa..6248ee52 100644 --- a/builtin-programs/tags-to-quads.folk +++ b/builtin-programs/tags-to-quads.folk @@ -615,6 +615,19 @@ set quadLib [library create quadLib {} { } return [create [space $q] [list $topLeft $topRight $bottomRight $bottomLeft]] } + + # Move an existing geometry geom (object with width and height + # keys) to align onto the plane & the top edge & left edge of the + # existing quad q. + proc alignGeometry {q geom} { + lassign [vertices $q] topLeft topRight bottomRight bottomLeft + set topDisp [scaleVector $geom(width) [unitLengthVector [sub $topRight $topLeft]]] + set leftDisp [scaleVector $geom(height) [unitLengthVector [sub $bottomLeft $topLeft]]] + set topRight [add $topLeft $topDisp] + set bottomRight [add $topRight $leftDisp] + set bottomLeft [add $topLeft $leftDisp] + return [create [space $q] [list $topLeft $topRight $bottomRight $bottomLeft]] + } }] Claim the quad library is $quadLib @@ -759,17 +772,12 @@ When the quad changer is /quadChange/ &\ $displayWidth $displayHeight $v }] a b c d - Hold! -keep 2ms -key [list $tag image] \ - Wish the GPU draws pipeline "image" with arguments \ + Wish the GPU draws pipeline "image" with arguments \ [list [list $displayWidth $displayHeight] \ $displayToClip \ - [dict get $wiOptions texture] $a $b $c $d] - } - - On unmatch { - Hold! -key [list $tag image] {} + [dict get $wiOptions texture] $a $b $c $d] \ + layer [dict getdef $wiOptions layer 0] } - # TODO: How to prevent a race if the tag returns? } } diff --git a/builtin-programs/web/db-lib.folk b/builtin-programs/web/db-lib.folk index 2b5b875a..ba1d7b5d 100644 --- a/builtin-programs/web/db-lib.folk +++ b/builtin-programs/web/db-lib.folk @@ -108,12 +108,17 @@ Claim the db library is [apply {{} { matchRelease(db, match); return alive; } + $cc code { + #define CHILD_STATEMENTS_REMOVING ((ListOfEdgeTo*)1) + } $cc proc childStatements {Db* db MatchRef matchRef} Jim_Obj* { Match* match = matchAcquire(db, matchRef); if (match == NULL) { return Jim_NewStringObj(interp, "", -1); } pthread_mutex_lock(&match->childStatementsMutex); - if (match->childStatements == NULL) { + if (match->childStatements == NULL || + match->childStatements == CHILD_STATEMENTS_REMOVING) { + pthread_mutex_unlock(&match->childStatementsMutex); matchRelease(db, match); return Jim_NewEmptyStringObj(interp); diff --git a/builtin-programs/web/setup.folk b/builtin-programs/web/setup.folk index ac75208d..2c2911c0 100644 --- a/builtin-programs/web/setup.folk +++ b/builtin-programs/web/setup.folk @@ -515,7 +515,7 @@ folk.watchCollected(`/someone/ wishes the web server handles route "/setup" with

    Projector-camera calibration

    -

    Select one display and one or more cameras to calibrate:

    +

    Select one display and one or more cameras to calibrate:

    Display (projector) @@ -582,6 +582,12 @@ folk.watchCollected(`/someone/ wishes the web server handles route "/setup" with window.location.href = `/calibrate?\${params.toString()}`; } + + const firstDisplay = document.querySelector('input\[name="calibration-display"]'); + if (firstDisplay) firstDisplay.checked = true; + const firstCamera = document.querySelector('input\[name="calibration-camera"]'); + if (firstCamera) firstCamera.checked = true; + calibrationSelectionChange();
    diff --git a/db.c b/db.c index 368af7ad..d61b983c 100644 --- a/db.c +++ b/db.c @@ -248,10 +248,18 @@ typedef struct Match { pthread_mutex_t destructorSetMutex; // ListOfEdgeTo StatementRef. Used for removal. - ListOfEdgeTo* childStatements; + // NULL means the slot is fully destroyed and ready for reuse (matchNew + // checks this). CHILD_STATEMENTS_REMOVING means matchRemoveSelf has + // claimed removal but matchDestroy hasn't finished yet. + ListOfEdgeTo* _Atomic childStatements; pthread_mutex_t childStatementsMutex; } Match; +// Sentinel: matchRemoveSelf sets childStatements to this to prevent new +// children from being added. matchDestroy then sets it to NULL (release) +// as its final step, which is what matchNew waits for. +#define CHILD_STATEMENTS_REMOVING ((ListOfEdgeTo*)1) + // Database datatypes: typedef struct Hold { @@ -750,7 +758,8 @@ static MatchRef matchNew(Db* db, match = &db->matchPool[idx]; GenRc oldGenRc = match->genRc; - if (oldGenRc.rc == 0 && !oldGenRc.alive && match->childStatements == NULL) { + if (oldGenRc.rc == 0 && !oldGenRc.alive && + atomic_load_explicit(&match->childStatements, memory_order_acquire) == NULL) { GenRc newGenRc = oldGenRc; newGenRc.alive = true; @@ -763,7 +772,7 @@ static MatchRef matchNew(Db* db, // We should have exclusive access to match right now. - match->childStatements = listOfEdgeToNew(8); + atomic_store_explicit(&match->childStatements, listOfEdgeToNew(8), memory_order_relaxed); match->parentWasRemoved = false; pthread_mutexattr_t mta; @@ -783,12 +792,17 @@ static MatchRef matchNew(Db* db, } static void matchDestroy(Match* match) { - assert(match->childStatements == NULL); + assert(atomic_load_explicit(&match->childStatements, memory_order_relaxed) + == CHILD_STATEMENTS_REMOVING); // Fire any destructors. pthread_mutex_lock(&match->destructorSetMutex); destructorSetReleaseAll(&match->destructorSet); pthread_mutex_unlock(&match->destructorSetMutex); + + // Release store: synchronizes with matchNew's acquire load so that + // all writes above are visible before the slot is reused. + atomic_store_explicit(&match->childStatements, NULL, memory_order_release); } AtomicallyVersion* matchAtomicallyVersion(Match* m) { @@ -803,8 +817,9 @@ static bool statementChecker(void* db, uint64_t ref) { } // You must call this with the childStatementsMutex held. static void matchAddChildStatement(Db* db, Match* match, StatementRef child) { - listOfEdgeToAdd(statementChecker, db, - &match->childStatements, child.val); + ListOfEdgeTo* list = atomic_load_explicit(&match->childStatements, memory_order_relaxed); + listOfEdgeToAdd(statementChecker, db, &list, child.val); + atomic_store_explicit(&match->childStatements, list, memory_order_relaxed); } void matchAddDestructor(Match* m, Destructor* d) { pthread_mutex_lock(&m->destructorSetMutex); @@ -838,8 +853,8 @@ void matchRemoveSelf(Db* db, Match* match) { // Walk through each child statement and remove this match as a // parent of that statement. pthread_mutex_lock(&match->childStatementsMutex); - ListOfEdgeTo* childStatements = match->childStatements; - if (childStatements == NULL) { + ListOfEdgeTo* childStatements = atomic_load_explicit(&match->childStatements, memory_order_relaxed); + if (childStatements == NULL || childStatements == CHILD_STATEMENTS_REMOVING) { // Someone else has done / is doing removal. Abort. pthread_mutex_unlock(&match->childStatementsMutex); return; @@ -847,7 +862,7 @@ void matchRemoveSelf(Db* db, Match* match) { // This blocks further child statements from being added to this // match (if they were added, then we wouldn't be able to remove // them). - match->childStatements = NULL; + atomic_store_explicit(&match->childStatements, CHILD_STATEMENTS_REMOVING, memory_order_relaxed); genRcMarkAsDead(&match->genRc); pthread_mutex_unlock(&match->childStatementsMutex); @@ -866,7 +881,11 @@ void matchRemoveSelf(Db* db, Match* match) { // execution. ThreadControlBlock *workerThread = &threads[match->workerThreadIndex]; if (timestamp_get(workerThread->clockid) - workerThread->currentItemStartTimestamp > 100000000) { - char buf[10000]; traceItem(buf, sizeof(buf), workerThread->currentItem); + mutexLock(&workerThread->currentItemMutex); + WorkQueueItem item = workerThread->currentItem; + mutexUnlock(&workerThread->currentItemMutex); + + char buf[10000]; traceItem(buf, sizeof(buf), item); fprintf(stderr, "KILL (%.150s)\n", buf); kill(workerThread->tid, SIGUSR1); } @@ -1187,7 +1206,8 @@ Statement* dbInsertOrReuseStatement(Db* db, Clause* clause, } pthread_mutex_lock(&parentMatch->childStatementsMutex); - if (parentMatch->childStatements == NULL) { + ListOfEdgeTo* cs = atomic_load_explicit(&parentMatch->childStatements, memory_order_relaxed); + if (cs == NULL || cs == CHILD_STATEMENTS_REMOVING) { pthread_mutex_unlock(&parentMatch->childStatementsMutex); matchRelease(db, parentMatch); diff --git a/prelude.tcl b/prelude.tcl index 37b4238a..a4bd660f 100644 --- a/prelude.tcl +++ b/prelude.tcl @@ -46,7 +46,9 @@ proc unknown {cmdName args} { # environment (probably passed through a statement) # and can just be applied to args. set fnObj [lindex $fn 0] - proc $cmdName args {fnObj} { tailcall {*}$fnObj {*}$args } + uplevel [list local proc $cmdName \ + args [list [list fnObj $fnObj]] \ + { tailcall {*}$fnObj {*}$args }] tailcall $cmdName {*}$args } @@ -75,9 +77,11 @@ proc unknown {cmdName args} { set env [dict merge {*}[lrange $envStack 0 $i]] dict set env __envStack $envStack dict set env __env $env - dict with env { - proc $cmdName $argNames [dict keys $env] $body - } + + set envPairs [list] + dict for {k v} $env { lappend envPairs [list $k $v] } + uplevel [list local proc $cmdName \ + $argNames $envPairs $body] tailcall $cmdName {*}$args } @@ -779,7 +783,9 @@ if {[__isTracyEnabled]} { TracyCSetThreadName(strdup(name)); } $tracyCpp code { - __thread TracyCZoneCtx __zoneCtx; + #define __ZONE_CTX_MAX 16 + __thread TracyCZoneCtx __zoneCtxs[__ZONE_CTX_MAX]; + __thread int __zoneCtxIdx; } $tracyCpp proc zoneBegin {} void { Jim_Obj* scriptObj = interp->evalFrame->scriptObj; @@ -801,13 +807,23 @@ if {[__isTracyEnabled]} { fnName != NULL ? fnName : "", fnName != NULL ? strlen(fnName) : strlen(""), 0); - __zoneCtx = ___tracy_emit_zone_begin_alloc(loc, 1); + if (__zoneCtxIdx >= __ZONE_CTX_MAX) { + fprintf(stderr, "tracy: zone stack overflow (max %d)\n", __ZONE_CTX_MAX); + exit(1); + } + __zoneCtxs[__zoneCtxIdx++] = ___tracy_emit_zone_begin_alloc(loc, 1); } $tracyCpp proc zoneName {char* name} void { - ___tracy_emit_zone_name(__zoneCtx, name, strlen(name)); + if (__zoneCtxIdx > 0) { + ___tracy_emit_zone_name(__zoneCtxs[__zoneCtxIdx - 1], name, strlen(name)); + } } $tracyCpp proc zoneEnd {} void { - ___tracy_emit_zone_end(__zoneCtx); + if (__zoneCtxIdx <= 0) { + fprintf(stderr, "tracy: zone stack underflow\n"); + exit(1); + } + ___tracy_emit_zone_end(__zoneCtxs[--__zoneCtxIdx]); } return [$tracyCpp compile $tracyCid] } diff --git a/vendor/fonts/NeomatrixCode.ttf b/vendor/fonts/NeomatrixCode.ttf new file mode 100644 index 00000000..c7465bd1 Binary files /dev/null and b/vendor/fonts/NeomatrixCode.ttf differ diff --git a/vendor/jimtcl/jim-json.c b/vendor/jimtcl/jim-json.c index 6d4cdfa7..2964d7a0 100644 --- a/vendor/jimtcl/jim-json.c +++ b/vendor/jimtcl/jim-json.c @@ -240,7 +240,7 @@ json_decode_dump_value(Jim_Interp *interp, struct json_state *state, Jim_Obj *li } if (set_source) { /* Note we need to subtract 1 because both are 1-based values */ - Jim_SetSourceInfo(interp, elem, state->fileNameObj, state->line + t->line - 1); + Jim_SetSourceInfo(interp, elem, state->fileNameObj, state->line + t->line - 1, 0); } Jim_ListAppendElement(interp, list, elem); @@ -378,7 +378,7 @@ json_decode(Jim_Interp *interp, int argc, Jim_Obj *const argv[]) } /* Save any source information from the original string */ - state.fileNameObj = Jim_GetSourceInfo(interp, argv[argc - 1], &state.line); + state.fileNameObj = Jim_GetSourceInfo(interp, argv[argc - 1], &state.line, NULL); if ((tokens = json_decode_tokenize(interp, state.json, len)) == NULL) { goto done; diff --git a/vendor/jimtcl/jim.c b/vendor/jimtcl/jim.c index 7ddfc378..5f9aabe5 100644 --- a/vendor/jimtcl/jim.c +++ b/vendor/jimtcl/jim.c @@ -1272,9 +1272,11 @@ struct JimParserCtx const char *p; /* Pointer to the point of the program we are parsing */ int len; /* Remaining length */ int linenr; /* Current line number */ + const char *line_start; /* Pointer to the start of the current line */ const char *tstart; const char *tend; /* Returned token is at tstart-tend in 'prg'. */ int tline; /* Line number of the returned token */ + int tcol; /* Column number of the returned token (0-based) */ int tt; /* Token type */ int eof; /* Non zero if EOF condition is true. */ int inquote; /* Parsing a quoted string */ @@ -1299,17 +1301,20 @@ static Jim_Obj *JimParserGetTokenObj(Jim_Interp *interp, struct JimParserCtx *pc /* Initialize a parser context. * 'prg' is a pointer to the program text, linenr is the line * number of the first line contained in the program. */ -static void JimParserInit(struct JimParserCtx *pc, const char *prg, int len, int linenr) +static void JimParserInit(struct JimParserCtx *pc, const char *prg, int len, int linenr, int col) { pc->p = prg; pc->len = len; pc->tstart = NULL; pc->tend = NULL; pc->tline = 0; + pc->tcol = 0; pc->tt = JIM_TT_NONE; pc->eof = 0; pc->inquote = 0; pc->linenr = linenr; + /* Offset line_start so that tcol values are file-relative */ + pc->line_start = prg - col; pc->comment = 1; pc->missing.ch = ' '; pc->missing.line = linenr; @@ -1322,6 +1327,7 @@ static int JimParseScript(struct JimParserCtx *pc) pc->tstart = pc->p; pc->tend = pc->p - 1; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; pc->tt = JIM_TT_EOL; if (pc->inquote) { pc->missing.ch = '"'; @@ -1358,6 +1364,7 @@ static int JimParseScript(struct JimParserCtx *pc) if (JimParseVar(pc) == JIM_ERR) { /* An orphan $. Create as a separate token */ pc->tstart = pc->tend = pc->p++; + pc->tcol = pc->tstart - pc->line_start; pc->len--; pc->tt = JIM_TT_ESC; } @@ -1380,6 +1387,7 @@ static int JimParseSep(struct JimParserCtx *pc) { pc->tstart = pc->p; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; while (isspace(UCHAR(*pc->p)) || (*pc->p == '\\' && *(pc->p + 1) == '\n')) { if (*pc->p == '\n') { break; @@ -1388,6 +1396,7 @@ static int JimParseSep(struct JimParserCtx *pc) pc->p++; pc->len--; pc->linenr++; + pc->line_start = pc->p + 1; } pc->p++; pc->len--; @@ -1401,9 +1410,12 @@ static int JimParseEol(struct JimParserCtx *pc) { pc->tstart = pc->p; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; while (isspace(UCHAR(*pc->p)) || *pc->p == ';') { - if (*pc->p == '\n') + if (*pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; + } pc->p++; pc->len--; } @@ -1453,6 +1465,7 @@ static void JimParseSubBrace(struct JimParserCtx *pc) if (pc->len > 1) { if (*++pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; } pc->len--; } @@ -1473,6 +1486,7 @@ static void JimParseSubBrace(struct JimParserCtx *pc) case '\n': pc->linenr++; + pc->line_start = pc->p + 1; break; } pc->p++; @@ -1507,6 +1521,7 @@ static int JimParseSubQuote(struct JimParserCtx *pc) if (pc->len > 1) { if (*++pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; } pc->len--; tt = JIM_TT_ESC; @@ -1526,6 +1541,7 @@ static int JimParseSubQuote(struct JimParserCtx *pc) case '\n': pc->linenr++; + pc->line_start = pc->p + 1; break; case '$': @@ -1562,6 +1578,7 @@ static void JimParseSubCmd(struct JimParserCtx *pc) if (pc->len > 1) { if (*++pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; } pc->len--; } @@ -1597,6 +1614,7 @@ static void JimParseSubCmd(struct JimParserCtx *pc) case '\n': pc->linenr++; + pc->line_start = pc->p + 1; break; } startofword = isspace(UCHAR(*pc->p)); @@ -1612,6 +1630,7 @@ static int JimParseBrace(struct JimParserCtx *pc) { pc->tstart = pc->p + 1; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; pc->tt = JIM_TT_STR; JimParseSubBrace(pc); return JIM_OK; @@ -1621,6 +1640,7 @@ static int JimParseCmd(struct JimParserCtx *pc) { pc->tstart = pc->p + 1; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; pc->tt = JIM_TT_CMD; JimParseSubCmd(pc); return JIM_OK; @@ -1630,6 +1650,7 @@ static int JimParseQuote(struct JimParserCtx *pc) { pc->tstart = pc->p + 1; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; pc->tt = JimParseSubQuote(pc); return JIM_OK; } @@ -1652,14 +1673,17 @@ static int JimParseVar(struct JimParserCtx *pc) pc->tstart = pc->p; pc->tt = JIM_TT_VAR; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; if (*pc->p == '{') { pc->tstart = ++pc->p; + pc->tcol = pc->tstart - pc->line_start; pc->len--; while (pc->len && *pc->p != '}') { if (*pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; } pc->p++; pc->len--; @@ -1760,6 +1784,7 @@ static int JimParseStr(struct JimParserCtx *pc) } pc->tstart = pc->p; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; while (1) { if (pc->len == 0) { if (pc->inquote) { @@ -1779,6 +1804,7 @@ static int JimParseStr(struct JimParserCtx *pc) if (pc->len >= 2) { if (*(pc->p + 1) == '\n') { pc->linenr++; + pc->line_start = pc->p + 2; } pc->p++; pc->len--; @@ -1826,6 +1852,7 @@ static int JimParseStr(struct JimParserCtx *pc) } else if (*pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; } break; case '"': @@ -1857,12 +1884,14 @@ static int JimParseComment(struct JimParserCtx *pc) } if (*pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; } } else if (*pc->p == '\n') { pc->p++; pc->len--; pc->linenr++; + pc->line_start = pc->p; break; } pc->p++; @@ -2130,6 +2159,7 @@ static int JimParseList(struct JimParserCtx *pc) pc->tstart = pc->tend = pc->p; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; pc->tt = JIM_TT_EOL; pc->eof = 1; return JIM_OK; @@ -2139,9 +2169,11 @@ static int JimParseListSep(struct JimParserCtx *pc) { pc->tstart = pc->p; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; while (isspace(UCHAR(*pc->p))) { if (*pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; } pc->p++; pc->len--; @@ -2158,6 +2190,7 @@ static int JimParseListQuote(struct JimParserCtx *pc) pc->tstart = pc->p; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; pc->tt = JIM_TT_STR; while (pc->len) { @@ -2173,6 +2206,7 @@ static int JimParseListQuote(struct JimParserCtx *pc) break; case '\n': pc->linenr++; + pc->line_start = pc->p + 1; break; case '"': pc->tend = pc->p - 1; @@ -2192,6 +2226,7 @@ static int JimParseListStr(struct JimParserCtx *pc) { pc->tstart = pc->p; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; pc->tt = JIM_TT_STR; while (pc->len) { @@ -3214,13 +3249,13 @@ static const Jim_ObjType scriptLineObjType = { JIM_NONE, }; -static Jim_Obj *JimNewScriptLineObj(Jim_Interp *interp, int argc, int line) +static Jim_Obj *JimNewScriptLineObj(Jim_Interp *interp, int argc, int line, int col) { Jim_Obj *objPtr; #ifdef DEBUG_SHOW_SCRIPT char buf[100]; - snprintf(buf, sizeof(buf), "line=%d, argc=%d", line, argc); + snprintf(buf, sizeof(buf), "line=%d, col=%d, argc=%d", line, col, argc); objPtr = Jim_NewStringObj(interp, buf, -1); #else objPtr = Jim_NewEmptyStringObj(interp); @@ -3228,6 +3263,7 @@ static Jim_Obj *JimNewScriptLineObj(Jim_Interp *interp, int argc, int line) objPtr->typePtr = &scriptLineObjType; objPtr->internalRep.scriptLineValue.argc = argc; objPtr->internalRep.scriptLineValue.line = line; + objPtr->internalRep.scriptLineValue.col = col; return objPtr; } @@ -3339,6 +3375,7 @@ typedef struct ScriptObj shimmering of the currently evaluated object. */ int firstline; /* Line number of the first line */ int linenr; /* Error line number, if any */ + int colnr; /* Error column number, if any */ int missing; /* Missing char if script failed to parse, (or space or backslash if OK) */ } ScriptObj; @@ -3382,6 +3419,7 @@ typedef struct int len; /* Length of this token */ int type; /* Token type */ int line; /* Line number */ + int column; /* Column number (0-based) */ } ParseToken; /* A list of parsed tokens representing a script. @@ -3417,7 +3455,7 @@ static void ScriptTokenListFree(ParseTokenList *tokenlist) * The token list is resized as necessary. */ static void ScriptAddToken(ParseTokenList *tokenlist, const char *token, int len, int type, - int line) + int line, int column) { ParseToken *t; @@ -3440,6 +3478,7 @@ static void ScriptAddToken(ParseTokenList *tokenlist, const char *token, int len t->len = len; t->type = type; t->line = line; + t->column = column; } /* Counts the number of adjoining non-separator tokens. @@ -3465,6 +3504,7 @@ static int JimCountWordTokens(struct ScriptObj *script, ParseToken *t) /* This is a "extra characters after close-brace" error. Report the first error */ script->missing = '}'; script->linenr = t[1].line; + script->colnr = t[1].column; } } } @@ -3521,6 +3561,7 @@ static void ScriptObjAddTokens(Jim_Interp *interp, struct ScriptObj *script, ScriptToken *linefirst; int count; int linenr; + int colnr; #ifdef DEBUG_SHOW_SCRIPT_TOKENS printf("==== Tokens ====\n"); @@ -3538,6 +3579,7 @@ static void ScriptObjAddTokens(Jim_Interp *interp, struct ScriptObj *script, } } linenr = script->firstline = tokenlist->list[0].line; + colnr = tokenlist->list[0].column; token = script->token = Jim_Alloc(sizeof(ScriptToken) * count); @@ -3559,7 +3601,7 @@ static void ScriptObjAddTokens(Jim_Interp *interp, struct ScriptObj *script, /* None, so at end of line */ if (lineargs) { linefirst->type = JIM_TT_LINE; - linefirst->objPtr = JimNewScriptLineObj(interp, lineargs, linenr); + linefirst->objPtr = JimNewScriptLineObj(interp, lineargs, linenr, colnr); Jim_IncrRefCount(linefirst->objPtr); /* Reset for new line */ @@ -3584,8 +3626,9 @@ static void ScriptObjAddTokens(Jim_Interp *interp, struct ScriptObj *script, } if (lineargs == 0) { - /* First real token on the line, so record the line number */ + /* First real token on the line, so record the line and column number */ linenr = tokenlist->list[i].line; + colnr = tokenlist->list[i].column; } lineargs++; @@ -3600,7 +3643,7 @@ static void ScriptObjAddTokens(Jim_Interp *interp, struct ScriptObj *script, /* Every object is initially a string of type 'source', but the * internal type may be specialized during execution of the * script. */ - Jim_SetSourceInfo(interp, token->objPtr, script->fileNameObj, t->line); + Jim_SetSourceInfo(interp, token->objPtr, script->fileNameObj, t->line, t->column); token++; } } @@ -3683,14 +3726,16 @@ static int JimParseCheckMissing(Jim_Interp *interp, int ch) return JIM_ERR; } -Jim_Obj *Jim_GetSourceInfo(Jim_Interp *interp, Jim_Obj *objPtr, int *lineptr) +Jim_Obj *Jim_GetSourceInfo(Jim_Interp *interp, Jim_Obj *objPtr, int *lineptr, int *colptr) { int line; + int col = 0; Jim_Obj *fileNameObj; if (objPtr->typePtr == &sourceObjType) { fileNameObj = objPtr->internalRep.sourceValue.fileNameObj; line = objPtr->internalRep.sourceValue.lineNumber; + col = objPtr->internalRep.sourceValue.columnNumber; } else if (objPtr->typePtr == &scriptObjType) { ScriptObj *script = JimGetScript(interp, objPtr); @@ -3702,17 +3747,19 @@ Jim_Obj *Jim_GetSourceInfo(Jim_Interp *interp, Jim_Obj *objPtr, int *lineptr) line = 1; } *lineptr = line; + if (colptr) *colptr = col; return fileNameObj; } void Jim_SetSourceInfo(Jim_Interp *interp, Jim_Obj *objPtr, - Jim_Obj *fileNameObj, int lineNumber) + Jim_Obj *fileNameObj, int lineNumber, int columnNumber) { JimPanic((Jim_IsShared(objPtr), "Jim_SetSourceInfo called with shared object")); Jim_FreeIntRep(interp, objPtr); Jim_IncrRefCount(fileNameObj); objPtr->internalRep.sourceValue.fileNameObj = fileNameObj; objPtr->internalRep.sourceValue.lineNumber = lineNumber; + objPtr->internalRep.sourceValue.columnNumber = columnNumber; objPtr->typePtr = &sourceObjType; } @@ -3756,22 +3803,23 @@ static void JimSetScriptFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) ParseTokenList tokenlist; Jim_Obj *fileNameObj; int line; + int col; /* Try to get information about filename / line number */ - fileNameObj = Jim_GetSourceInfo(interp, objPtr, &line); + fileNameObj = Jim_GetSourceInfo(interp, objPtr, &line, &col); /* Initially parse the script into tokens (in tokenlist) */ ScriptTokenListInit(&tokenlist); - JimParserInit(&parser, scriptText, scriptTextLen, line); + JimParserInit(&parser, scriptText, scriptTextLen, line, col); while (!parser.eof) { JimParseScript(&parser); ScriptAddToken(&tokenlist, parser.tstart, parser.tend - parser.tstart + 1, parser.tt, - parser.tline); + parser.tline, parser.tcol); } /* Add a final EOF token */ - ScriptAddToken(&tokenlist, scriptText + scriptTextLen, 0, JIM_TT_EOF, 0); + ScriptAddToken(&tokenlist, scriptText + scriptTextLen, 0, JIM_TT_EOF, 0, 0); /* Create the "real" script tokens from the parsed tokens */ script = Jim_Alloc(sizeof(*script)); @@ -6061,6 +6109,16 @@ static Jim_Obj *JimProcForEvalFrame(Jim_Interp *interp, Jim_EvalFrame *frame) return NULL; } +static Jim_Obj *JimLineColObj(Jim_Interp *interp, int line, int col) +{ + if (col > 0) { + char buf[32]; + snprintf(buf, sizeof(buf), "%d:%d", line, col); + return Jim_NewStringObj(interp, buf, -1); + } + return Jim_NewIntObj(interp, line); +} + /** * Append stack trace info (proc, file, line, cmd) from the eval frame * to listObj @@ -6070,16 +6128,18 @@ static void JimAddStackFrame(Jim_Interp *interp, Jim_EvalFrame *frame, Jim_Obj * Jim_Obj *procNameObj = JimProcForEvalFrame(interp, frame); Jim_Obj *fileNameObj = interp->emptyObj; int linenr = 1; + int colnr = 0; if (frame->scriptObj) { ScriptObj *script = JimGetScript(interp, frame->scriptObj); fileNameObj = script->fileNameObj; linenr = script->linenr; + colnr = script->colnr; } Jim_ListAppendElement(interp, listObj, procNameObj ? procNameObj : interp->emptyObj); Jim_ListAppendElement(interp, listObj, fileNameObj); - Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, linenr)); + Jim_ListAppendElement(interp, listObj, JimLineColObj(interp, linenr, colnr)); Jim_ListAppendElement(interp, listObj, Jim_NewListObj(interp, frame->argv, frame->argc)); } @@ -6104,7 +6164,7 @@ static void JimSetErrorStack(Jim_Interp *interp, ScriptObj *script) */ Jim_ListAppendElement(interp, stackTrace, interp->emptyObj); Jim_ListAppendElement(interp, stackTrace, script->fileNameObj); - Jim_ListAppendElement(interp, stackTrace, Jim_NewIntObj(interp, script->linenr)); + Jim_ListAppendElement(interp, stackTrace, JimLineColObj(interp, script->linenr, script->colnr)); Jim_ListAppendElement(interp, stackTrace, interp->emptyObj); } else { @@ -6853,7 +6913,7 @@ static int SetListFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) } /* Try to preserve information about filename / line number */ - fileNameObj = Jim_GetSourceInfo(interp, objPtr, &linenr); + fileNameObj = Jim_GetSourceInfo(interp, objPtr, &linenr, NULL); Jim_IncrRefCount(fileNameObj); /* Get the string representation */ @@ -6869,7 +6929,7 @@ static int SetListFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) /* Convert into a list */ if (strLen) { - JimParserInit(&parser, str, strLen, linenr); + JimParserInit(&parser, str, strLen, linenr, 0); while (!parser.eof) { Jim_Obj *elementPtr; @@ -6877,7 +6937,7 @@ static int SetListFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) if (parser.tt != JIM_TT_STR && parser.tt != JIM_TT_ESC) continue; elementPtr = JimParserGetTokenObj(interp, &parser); - Jim_SetSourceInfo(interp, elementPtr, fileNameObj, parser.tline); + Jim_SetSourceInfo(interp, elementPtr, fileNameObj, parser.tline, 0); ListAppendElement(objPtr, elementPtr); } } @@ -9169,6 +9229,7 @@ static int JimParseExpression(struct JimParserCtx *pc) while (isspace(UCHAR(*pc->p)) || (*(pc->p) == '\\' && *(pc->p + 1) == '\n')) { if (*pc->p == '\n') { pc->linenr++; + pc->line_start = pc->p + 1; } pc->p++; pc->len--; @@ -9185,6 +9246,7 @@ static int JimParseExpression(struct JimParserCtx *pc) /* Common case */ pc->tline = pc->linenr; pc->tstart = pc->p; + pc->tcol = pc->tstart - pc->line_start; if (pc->len == 0) { pc->tend = pc->p; @@ -9726,7 +9788,7 @@ static int ExprTreeBuildTree(Jim_Interp *interp, struct ExprBuilder *builder, in objPtr = Jim_NewStringObj(interp, t->token, t->len); if (t->type == JIM_TT_CMD) { /* Only commands need source info */ - Jim_SetSourceInfo(interp, objPtr, builder->fileNameObj, t->line); + Jim_SetSourceInfo(interp, objPtr, builder->fileNameObj, t->line, 0); } } @@ -9826,7 +9888,7 @@ static int SetExprFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) int rc = JIM_ERR; /* Try to get information about filename / line number */ - fileNameObj = Jim_GetSourceInfo(interp, objPtr, &line); + fileNameObj = Jim_GetSourceInfo(interp, objPtr, &line, NULL); Jim_IncrRefCount(fileNameObj); exprText = Jim_GetString(objPtr, &exprTextLen); @@ -9834,7 +9896,7 @@ static int SetExprFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) /* Initially tokenise the expression into tokenlist */ ScriptTokenListInit(&tokenlist); - JimParserInit(&parser, exprText, exprTextLen, line); + JimParserInit(&parser, exprText, exprTextLen, line, 0); while (!parser.eof) { if (JimParseExpression(&parser) != JIM_OK) { ScriptTokenListFree(&tokenlist); @@ -9847,7 +9909,7 @@ static int SetExprFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr) } ScriptAddToken(&tokenlist, parser.tstart, parser.tend - parser.tstart + 1, parser.tt, - parser.tline); + parser.tline, parser.tcol); } #ifdef DEBUG_SHOW_EXPR_TOKENS @@ -11186,8 +11248,8 @@ static Jim_Obj *JimInterpolateTokens(Jim_Interp *interp, const ScriptToken * tok else if (tokens && intv[0] && intv[0]->typePtr == &sourceObjType) { /* The first interpolated token is source, so preserve the source info */ int line; - Jim_Obj *fileNameObj = Jim_GetSourceInfo(interp, intv[0], &line); - Jim_SetSourceInfo(interp, objPtr, fileNameObj, line); + Jim_Obj *fileNameObj = Jim_GetSourceInfo(interp, intv[0], &line, NULL); + Jim_SetSourceInfo(interp, objPtr, fileNameObj, line, 0); } @@ -11326,6 +11388,7 @@ int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr) /* First token of the line is always JIM_TT_LINE */ argc = token[i].objPtr->internalRep.scriptLineValue.argc; script->linenr = token[i].objPtr->internalRep.scriptLineValue.line; + script->colnr = token[i].objPtr->internalRep.scriptLineValue.col; /* Allocate the arguments vector if required */ if (argc > JIM_EVAL_SARGV_LEN) @@ -11708,7 +11771,7 @@ int Jim_EvalSource(Jim_Interp *interp, const char *filename, int lineno, const c scriptObjPtr = Jim_NewStringObj(interp, script, -1); Jim_IncrRefCount(scriptObjPtr); if (filename) { - Jim_SetSourceInfo(interp, scriptObjPtr, Jim_NewStringObj(interp, filename, -1), lineno); + Jim_SetSourceInfo(interp, scriptObjPtr, Jim_NewStringObj(interp, filename, -1), lineno, 0); } retval = Jim_EvalObj(interp, scriptObjPtr); Jim_DecrRefCount(interp, scriptObjPtr); @@ -11795,7 +11858,7 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename) } filenameObj = Jim_NewStringObj(interp, filename, -1); - Jim_SetSourceInfo(interp, scriptObjPtr, filenameObj, 1); + Jim_SetSourceInfo(interp, scriptObjPtr, filenameObj, 1, 0); oldFilenameObj = JimPushInterpObj(interp->currentFilenameObj, filenameObj); @@ -11822,6 +11885,7 @@ static void JimParseSubst(struct JimParserCtx *pc, int flags) { pc->tstart = pc->p; pc->tline = pc->linenr; + pc->tcol = pc->tstart - pc->line_start; if (pc->len == 0) { pc->tend = pc->p; @@ -11839,6 +11903,7 @@ static void JimParseSubst(struct JimParserCtx *pc, int flags) } /* Not a var, so treat as a string */ pc->tstart = pc->p; + pc->tcol = pc->tstart - pc->line_start; /* Skip this $ */ pc->p++; pc->len--; @@ -11881,7 +11946,7 @@ static int SetSubstFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr, int flags /* Initially parse the subst into tokens (in tokenlist) */ ScriptTokenListInit(&tokenlist); - JimParserInit(&parser, scriptText, scriptTextLen, 1); + JimParserInit(&parser, scriptText, scriptTextLen, 1, 0); while (1) { JimParseSubst(&parser, flags); if (parser.eof) { @@ -11889,7 +11954,7 @@ static int SetSubstFromAny(Jim_Interp *interp, struct Jim_Obj *objPtr, int flags break; } ScriptAddToken(&tokenlist, parser.tstart, parser.tend - parser.tstart + 1, parser.tt, - parser.tline); + parser.tline, parser.tcol); } /* Create the "real" subst/script tokens from the initial token list */ @@ -12135,6 +12200,8 @@ static int JimInfoFrame(Jim_Interp *interp, Jim_Obj *levelObjPtr, Jim_Obj **objP ScriptObj *script = JimGetScript(interp, frame->scriptObj); Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "line", -1)); Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, script->linenr)); + Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "col", -1)); + Jim_ListAppendElement(interp, listObj, Jim_NewIntObj(interp, script->colnr)); Jim_ListAppendElement(interp, listObj, Jim_NewStringObj(interp, "file", -1)); Jim_ListAppendElement(interp, listObj, script->fileNameObj); } @@ -15844,11 +15911,11 @@ static int Jim_InfoCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *arg return JIM_ERR; } resObjPtr = Jim_NewStringObj(interp, Jim_String(argv[2]), Jim_Length(argv[2])); - Jim_SetSourceInfo(interp, resObjPtr, argv[3], line); + Jim_SetSourceInfo(interp, resObjPtr, argv[3], line, 0); } else { int line; - fileNameObj = Jim_GetSourceInfo(interp, argv[2], &line); + fileNameObj = Jim_GetSourceInfo(interp, argv[2], &line, NULL); resObjPtr = Jim_NewListObj(interp, NULL, 0); Jim_ListAppendElement(interp, resObjPtr, fileNameObj); Jim_ListAppendElement(interp, resObjPtr, Jim_NewIntObj(interp, line)); diff --git a/vendor/jimtcl/jim.h b/vendor/jimtcl/jim.h index df6c0b17..f64dc9cf 100644 --- a/vendor/jimtcl/jim.h +++ b/vendor/jimtcl/jim.h @@ -340,6 +340,7 @@ typedef struct Jim_Obj { struct { struct Jim_Obj *fileNameObj; int lineNumber; + int columnNumber; } sourceValue; /* Dict substitution type */ struct { @@ -348,6 +349,7 @@ typedef struct Jim_Obj { } dictSubstValue; struct { int line; + int col; int argc; } scriptLineValue; } internalRep; @@ -701,10 +703,10 @@ JIM_EXPORT int Jim_SubstObj (Jim_Interp *interp, Jim_Obj *substObjPtr, /* source information */ JIM_EXPORT Jim_Obj *Jim_GetSourceInfo(Jim_Interp *interp, Jim_Obj *objPtr, - int *lineptr); + int *lineptr, int *colptr); /* may only be called on an unshared object */ JIM_EXPORT void Jim_SetSourceInfo(Jim_Interp *interp, Jim_Obj *objPtr, - Jim_Obj *fileNameObj, int lineNumber); + Jim_Obj *fileNameObj, int lineNumber, int columnNumber); /* stack */