Browse Source
Assisted-by: harness=opencode; primary-model=openrouter/moonshotai/kimi-k3; api-location=openrouter.aimaster
4 changed files with 655 additions and 2 deletions
@ -0,0 +1,637 @@
|
||||
#!/usr/bin/env tclsh |
||||
# goals_xref.tcl - cross-reference and scope-overlap analysis for the two-tier |
||||
# goals documentation (root GOALS.md / GOALS-archive.md + goals/ detail files) |
||||
# |
||||
# Companion to goals_lint.tcl. goals_lint validates structure; this tool answers |
||||
# relationship questions: |
||||
# - which proposed/active goals overlap in scope but never reference each other |
||||
# (the drafting-time cross-reference gap) |
||||
# - which goals intersect a given set of repo paths (the "read intersecting |
||||
# goals before editing" step in GOALS.md, and the drafting overlap survey) |
||||
# - which goals are most related to one given goal |
||||
# - which G-id references dangle (mention a goal in neither index) |
||||
# |
||||
# Overlap scoring combines two evidence tiers: |
||||
# paths - scope entries normalised to repo paths with subpath containment, |
||||
# namespace<->path bridging (punk::args == src/modules/punk/args-*.tm) |
||||
# and version-insensitive module keys (libunknown-0.2.1.tm == libunknown) |
||||
# terms - shared distinctive words from title/Goal/Acceptance (IDF-weighted) |
||||
# Evidence is weighted by inverse document frequency across the live goal set so |
||||
# ubiquitous anchors (src/make.tcl, src/tests/) count for little. |
||||
# A pair is UNLINKED when neither goal's detail file or index entry mentions the |
||||
# other's id anywhere (the house convention is dependency-direction linking - one |
||||
# direction suffices to count as linked). Pairs linked in exactly one direction |
||||
# are listed separately as back-pointer candidates. |
||||
# |
||||
# Plain tclsh (8.6+ or 9), no package dependencies. Advisory only: always exit 0 |
||||
# (exit 2 on usage/repo errors). Run from anywhere: |
||||
# tclsh scriptlib/developer/goals_xref.tcl ?mode? ?args? ?-root dir? |
||||
# Modes: |
||||
# report ?--top N? ?--min S? ?--linked? unlinked + one-directional overlap pairs (default) |
||||
# paths <p1> ?<p2>... goals whose scope intersects the given paths |
||||
# score <G-id|id> all overlap pairs for one goal, classified |
||||
# refs dangling G-id references (in neither index) |
||||
|
||||
# ---------------------------------------------------------------- arguments -- |
||||
set root "" |
||||
set mode report |
||||
set top 30 |
||||
set minscore 0.0 |
||||
set show_linked 0 |
||||
set positional {} |
||||
set expect "" |
||||
foreach arg $argv { |
||||
if {$expect eq "root"} { set root $arg; set expect ""; continue } |
||||
if {$arg eq "-root"} { set expect root; continue } |
||||
if {$arg eq "--linked"} { set show_linked 1; continue } |
||||
if {[string match "--top=*" $arg]} { set top [string range $arg 6 end]; continue } |
||||
if {[string match "--min=*" $arg]} { set minscore [string range $arg 6 end]; continue } |
||||
lappend positional $arg |
||||
} |
||||
if {$expect ne ""} { puts stderr "goals_xref: -root needs a value"; exit 2 } |
||||
if {$root eq ""} { |
||||
set root [file dirname [file dirname [file dirname [file normalize [info script]]]]] |
||||
} |
||||
if {![file isfile [file join $root GOALS.md]] || ![file isdir [file join $root goals]]} { |
||||
puts stderr "goals_xref: '$root' does not look like the punkshell repo root (need GOALS.md and goals/)" |
||||
exit 2 |
||||
} |
||||
if {[llength $positional] >= 1} { set mode [lindex $positional 0] } |
||||
set modeargs [lrange $positional 1 end] |
||||
|
||||
# ------------------------------------------------------------------ parsing -- |
||||
proc read_lines {path} { |
||||
set f [open $path r] |
||||
fconfigure $f -encoding utf-8 |
||||
set lines [split [read $f] \n] |
||||
close $f |
||||
return $lines |
||||
} |
||||
|
||||
# index file -> dict: id -> {status <s> title <t> scope <s>} |
||||
proc parse_index {path} { |
||||
set entries [dict create] |
||||
set curid "" |
||||
foreach line [read_lines $path] { |
||||
if {[regexp {^### G-(\d+) \[([^\]]*)\] (.*)$} $line -> id status title]} { |
||||
set curid $id |
||||
dict set entries $id [dict create status $status title $title scope ""] |
||||
} elseif {[regexp {^### } $line]} { |
||||
set curid "" |
||||
} elseif {$curid ne "" && [regexp {^Scope: (.*)$} $line -> scope]} { |
||||
dict set entries $curid scope $scope |
||||
} |
||||
} |
||||
return $entries |
||||
} |
||||
|
||||
proc goal_refs {text} { |
||||
set refs {} |
||||
foreach {full id} [regexp -all -inline {G-(\d+)} $text] { |
||||
if {[lsearch -exact $refs $id] < 0} { lappend refs $id } |
||||
} |
||||
return $refs |
||||
} |
||||
|
||||
# live detail files -> dict: id -> goal record (universe: proposed + active) |
||||
proc parse_goals {root index} { |
||||
set goals [dict create] |
||||
foreach path [lsort [glob -nocomplain -directory [file join $root goals] G-*.md]] { |
||||
set fname [file tail $path] |
||||
if {![regexp {^G-(\d+)-[a-z0-9-]+\.md$} $fname -> id]} continue |
||||
set lines [read_lines $path] |
||||
set fields [dict create] |
||||
for {set i 2} {$i < [llength $lines]} {incr i} { |
||||
set line [lindex $lines $i] |
||||
if {[regexp {^## } $line]} break |
||||
if {[regexp {^(Status|Scope|Goal|Acceptance): ?(.*)$} $line -> field value]} { |
||||
dict set fields $field $value |
||||
} |
||||
} |
||||
set status [expr {[dict exists $fields Status] ? [dict get $fields Status] : ""}] |
||||
if {$status ne "proposed" && $status ne "active"} continue |
||||
set title "" |
||||
set scope "" |
||||
if {[dict exists $index $id]} { |
||||
set title [dict get $index $id title] |
||||
set scope [dict get $index $id scope] |
||||
} |
||||
set goal [expr {[dict exists $fields Goal] ? [dict get $fields Goal] : ""}] |
||||
set acceptance [expr {[dict exists $fields Acceptance] ? [dict get $fields Acceptance] : ""}] |
||||
set refs [goal_refs "[join $lines \n]\n$scope\n$title"] |
||||
set refs [lsearch -all -inline -not -exact $refs $id] |
||||
dict set goals $id [dict create \ |
||||
status $status title $title scope $scope goal $goal \ |
||||
acceptance $acceptance refs $refs relpath goals/$fname] |
||||
} |
||||
return $goals |
||||
} |
||||
|
||||
# ------------------------------------------------------- scope normalisation -- |
||||
# A scope line yields: |
||||
# paths - normalised repo paths (lowercase, forward slashes, no trailing /). |
||||
# Containment is positional: a shorter entry contains anything beneath |
||||
# it, and namespace-derived entries (punk::mix -> punk/mix) also match |
||||
# as path suffixes (src/modules/punk/mix/...). |
||||
# keys - version-insensitive module keys harvested from path segments of the |
||||
# forms name-<ver>.tm / #name-<ver> / name-*.tm, the tails of |
||||
# namespace tokens, and bare module-name tokens (modpod, tomlish) |
||||
# admitted only when they exist in the corpus key vocabulary - this |
||||
# keeps prose words (machinery, tooling, consent) out of the keyspace. |
||||
proc is_file_token {t} { |
||||
return [regexp {\.(tcl|tm|md|test|toml|config|cfg|zig|zon|ico|ps1|bash|cmd|vfs|txt|json|yaml|yml|fossil|c|h)$} $t] |
||||
} |
||||
|
||||
proc version_key {seg} { |
||||
set core $seg |
||||
if {[string index $core 0] eq "#"} { set core [string range $core 1 end] } |
||||
if {[regexp {^([a-z][a-z0-9_]+)-[0-9][0-9a-z.]*\.tm$} $core -> k]} { return $k } |
||||
if {[regexp {^([a-z][a-z0-9_]+)-\*\.tm$} $core -> k]} { return $k } |
||||
if {[regexp {^([a-z][a-z0-9_]+)-[0-9][0-9a-z.]*$} $core -> k]} { return $k } |
||||
return "" |
||||
} |
||||
|
||||
# pass 1: collect anchors; bare tokens land in barecands for vocab filtering |
||||
# Path-shaped tokens (containing /) must be repo-rooted - otherwise prose |
||||
# fragments like "layout/naming decision" or "entry/exit hooks" become anchors. |
||||
set ::path_roots {} |
||||
foreach r {src bin goals tools scriptlib callbacks modules lib \ |
||||
modules_tcl8 modules_tcl9 lib_tcl8 lib_tcl9 temp_reference \ |
||||
punkbin .fossil-settings} { |
||||
dict set ::path_roots $r 1 |
||||
} |
||||
proc scope_anchors_pass1 {scope pathsKv keysKv bareKv} { |
||||
upvar $pathsKv paths $keysKv keys $bareKv bare |
||||
set s [string map {( " " ) " " , " " ; " " "\\" "/" "\"" " " "'" " " \[ " " \] " "} $scope] |
||||
foreach tok [split $s " "] { |
||||
if {$tok eq ""} continue |
||||
set t [string tolower [string trim $tok ".:"]] |
||||
if {$t eq ""} continue |
||||
if {[string first "::" $t] >= 0} { |
||||
set p [string map {:: /} $t] |
||||
lappend paths $p |
||||
lappend keys [file tail $p] |
||||
continue |
||||
} |
||||
if {[string first "/" $t] >= 0} { |
||||
set p $t |
||||
while {$p ne "" && ([string index $p 0] eq "." || [string index $p 0] eq "/")} { |
||||
set p [string range $p 1 end] |
||||
} |
||||
while {[string length $p] > 1 && [string index $p end] eq "/"} { |
||||
set p [string range $p 0 end-1] |
||||
} |
||||
if {$p eq ""} continue |
||||
set top [lindex [split $p /] 0] |
||||
if {![dict exists $::path_roots $top] && ![regexp {^[a-z]:$} $top]} continue |
||||
lappend paths $p |
||||
foreach seg [split $p /] { |
||||
set k [version_key $seg] |
||||
if {$k ne ""} { lappend keys $k } |
||||
} |
||||
continue |
||||
} |
||||
if {[is_file_token $t]} { |
||||
lappend paths $t |
||||
set k [version_key $t] |
||||
if {$k ne ""} { lappend keys $k } |
||||
continue |
||||
} |
||||
set k [version_key $t] |
||||
if {$k ne ""} { lappend keys $k; continue } |
||||
# bare candidate: plain word possibly naming a module |
||||
if {[regexp {^#?[a-z][a-z0-9_]{2,}(-[a-z0-9_]+)*$} $t]} { lappend bare $t } |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------ path relation -- |
||||
# Returns {anchor broader} when two normalised paths are related, else "": |
||||
# equal, a contains b, b contains a, or namespace-suffix match (punk/mix vs |
||||
# src/modules/punk/mix[/...]). Single-segment bare filenames (agents.md, |
||||
# mapvfs.config) match by equality only - otherwise one goal scoping root |
||||
# AGENTS.md would "relate" to every AGENTS.md in the tree. |
||||
proc path_anchor {a b} { |
||||
if {$a eq $b} { return [list $a $a] } |
||||
if {[string first "/" $a] < 0 || [string first "/" $b] < 0} { return "" } |
||||
set la [string length $a] |
||||
set lb [string length $b] |
||||
if {$la < $lb} { |
||||
if {[string first "$a/" $b] == 0} { return [list $b $a] } |
||||
if {[string first "/$a/" $b] >= 0} { return [list $b $a] } |
||||
if {$lb > $la + 1 && [string range $b [expr {$lb - $la - 1}] end] eq "/$a"} { return [list $b $a] } |
||||
} else { |
||||
if {[string first "$b/" $a] == 0} { return [list $a $b] } |
||||
if {[string first "/$b/" $a] >= 0} { return [list $a $b] } |
||||
if {$la > $lb + 1 && [string range $a [expr {$la - $lb - 1}] end] eq "/$b"} { return [list $a $b] } |
||||
} |
||||
return "" |
||||
} |
||||
|
||||
# sibling files: same parent dir, both basenames carrying an extension |
||||
proc sibling_anchor {a b} { |
||||
if {$a eq $b} { return "" } |
||||
set da [file dirname $a] |
||||
set db [file dirname $b] |
||||
if {$da ne $db || $da eq "."} { return "" } |
||||
if {![regexp {\.} [file tail $a]] || ![regexp {\.} [file tail $b]]} { return "" } |
||||
return $da |
||||
} |
||||
|
||||
# ------------------------------------------------------------------- terms -- |
||||
set ::stopwords {} |
||||
foreach w {the a an and or to of in for on at as by is are was were be been being \ |
||||
it its this that these those with without within not no nor so if \ |
||||
then than when where which who whom whose what how why all any each \ |
||||
every both neither either only own same other another such more most \ |
||||
less least much many few several first second last one two three new \ |
||||
now out up down over under again still already always never ever once \ |
||||
here there into onto from via per vs etc eg ie \ |
||||
do does did done make makes made take takes taken give gives given get \ |
||||
gets got keep keeps kept use uses used using run runs ran running set \ |
||||
sets setting put puts see seen say says said want wants wanted need \ |
||||
needs needed like likely just even also well way ways thing things \ |
||||
part parts side sides end ends top bottom left right full empty open \ |
||||
can could will would shall should may might must has have had having \ |
||||
we you they he she me him her us them our your their mine ours theirs \ |
||||
itself themselves ourselves \ |
||||
goal goals acceptance scope status detail recorded record records \ |
||||
decision decisions decided user users work works worked working note \ |
||||
notes section sections file files line lines value values name names \ |
||||
named current currently existing exists exist future present today \ |
||||
punk punkshell tcl tclsh tk} { |
||||
dict set ::stopwords $w 1 |
||||
} |
||||
|
||||
proc stem {w} { |
||||
if {[string length $w] <= 4} { return $w } |
||||
if {[string match *ies $w]} { return "[string range $w 0 end-3]y" } |
||||
set last [string index $w end] |
||||
set prev [string index $w end-1] |
||||
if {$last eq "s" && $prev ne "s" && $prev ne "u"} { |
||||
return [string range $w 0 end-1] |
||||
} |
||||
return $w |
||||
} |
||||
|
||||
proc term_set {text} { |
||||
set terms {} |
||||
set t [string tolower $text] |
||||
set candidates {} |
||||
foreach tok [regexp -all -inline {[a-z][a-z0-9]+} $t] { |
||||
lappend candidates $tok |
||||
} |
||||
# hyphenated words also contribute their joined form (pre-built ~ prebuilt) |
||||
foreach tok [regexp -all -inline {[a-z][a-z0-9]+(?:-[a-z0-9]+)+} $t] { |
||||
lappend candidates [string map {- ""} $tok] |
||||
} |
||||
foreach tok $candidates { |
||||
if {[string length $tok] < 4} continue |
||||
if {[dict exists $::stopwords $tok]} continue |
||||
set st [stem $tok] |
||||
if {[dict exists $::stopwords $st]} continue |
||||
if {[lsearch -exact $terms $st] < 0} { lappend terms $st } |
||||
} |
||||
return $terms |
||||
} |
||||
|
||||
# ------------------------------------------------------------------- model -- |
||||
set active_index [parse_index [file join $root GOALS.md]] |
||||
set archive_index [parse_index [file join $root GOALS-archive.md]] |
||||
set goals [parse_goals $root $active_index] |
||||
proc idcmp {a b} { |
||||
scan $a %d ai |
||||
scan $b %d bi |
||||
return [expr {$ai < $bi ? -1 : ($ai > $bi ? 1 : 0)}] |
||||
} |
||||
set ids [lsort -command idcmp [dict keys $goals]] |
||||
|
||||
# pass 1: anchors + key vocabulary |
||||
set keyvocab [dict create] |
||||
dict for {id g} $goals { |
||||
set paths {}; set keys {}; set bare {} |
||||
scope_anchors_pass1 [dict get $g scope] paths keys bare |
||||
dict set g paths [lsort -unique $paths] |
||||
dict set g keys [lsort -unique $keys] |
||||
dict set g bare [lsort -unique $bare] |
||||
dict set goals $id $g |
||||
foreach k $keys { dict set keyvocab $k 1 } |
||||
} |
||||
# pass 2: admit bare tokens present in the vocabulary (or a real module dir/file) |
||||
dict for {id g} $goals { |
||||
set keys [dict get $g keys] |
||||
foreach b [dict get $g bare] { |
||||
set bb $b |
||||
if {[string index $bb 0] eq "#"} { set bb [string range $bb 1 end] } |
||||
if {[string length $bb] >= 4 \ |
||||
&& ([dict exists $keyvocab $bb] \ |
||||
|| [file isdir [file join $root src modules $bb]] \ |
||||
|| [file isdir [file join $root src vendormodules $bb]] \ |
||||
|| [llength [glob -nocomplain -directory [file join $root src modules] -types f "${bb}-*.tm"]] > 0 \ |
||||
|| [llength [glob -nocomplain -directory [file join $root src vendormodules] -types f "${bb}-*.tm"]] > 0)} { |
||||
if {[lsearch -exact $keys $bb] < 0} { lappend keys $bb } |
||||
} |
||||
} |
||||
dict set g keys $keys |
||||
dict set g terms [term_set "[dict get $g title] [dict get $g goal] [dict get $g acceptance]"] |
||||
dict set goals $id $g |
||||
} |
||||
|
||||
set ngoals [dict size $goals] |
||||
|
||||
# document frequencies |
||||
set keydf [dict create] |
||||
set termdf [dict create] |
||||
dict for {id g} $goals { |
||||
foreach k [dict get $g keys] { dict incr keydf $k } |
||||
foreach t [dict get $g terms] { dict incr termdf $t } |
||||
} |
||||
|
||||
set ::df_cache [dict create] |
||||
proc path_df {anchor} { |
||||
global goals |
||||
if {[dict exists $::df_cache $anchor]} { return [dict get $::df_cache $anchor] } |
||||
set df 0 |
||||
dict for {id g} $goals { |
||||
foreach p [dict get $g paths] { |
||||
if {[path_anchor $anchor $p] ne ""} { incr df; break } |
||||
} |
||||
} |
||||
dict set ::df_cache $anchor $df |
||||
return $df |
||||
} |
||||
|
||||
# weight for a path-tier evidence anchor: 1/df of the BROADER entry (so a goal |
||||
# scoping a whole tree only weakly overlaps everything beneath it), with a |
||||
# heavy damp for co-location in reference containers (temp_reference). |
||||
proc anchor_weight {anchor broader} { |
||||
set df [path_df $broader] |
||||
if {$df <= 0 || $df > 20} { return 0.0 } |
||||
set w [expr {1.0 / $df}] |
||||
set top [lindex [split $anchor /] 0] |
||||
if {$top eq "temp_reference"} { set w [expr {$w * 0.2}] } |
||||
return [list $w $df] |
||||
} |
||||
|
||||
# shared evidence between two goal dicts -> {pathscore anchors termscore terms} |
||||
proc pair_evidence {ga gb} { |
||||
global keydf termdf |
||||
set anchors {} |
||||
set pathscore 0.0 |
||||
set seen {} |
||||
foreach pa [dict get $ga paths] { |
||||
foreach pb [dict get $gb paths] { |
||||
set rel [path_anchor $pa $pb] |
||||
if {$rel ne ""} { |
||||
lassign $rel a broader |
||||
if {[lsearch -exact $seen $a] < 0} { |
||||
lappend seen $a |
||||
lassign [anchor_weight $a $broader] w df |
||||
if {$w > 0} { |
||||
set pathscore [expr {$pathscore + $w}] |
||||
lappend anchors "$a (df$df)" |
||||
} |
||||
} |
||||
} |
||||
set sib [sibling_anchor $pa $pb] |
||||
if {$sib ne "" && [lsearch -exact $seen "sib:$sib"] < 0} { |
||||
lappend seen "sib:$sib" |
||||
lassign [anchor_weight $sib $sib] w df |
||||
if {$w > 0} { |
||||
set pathscore [expr {$pathscore + $w}] |
||||
lappend anchors "$sib/ (sibling files, df$df)" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
foreach ka [dict get $ga keys] { |
||||
if {[string length $ka] < 3} continue |
||||
if {[lsearch -exact [dict get $gb keys] $ka] < 0} continue |
||||
set df [dict get $keydf $ka] |
||||
if {$df > 20} continue |
||||
set pathscore [expr {$pathscore + 1.0 / $df}] |
||||
lappend anchors "key:$ka (df$df)" |
||||
} |
||||
set terms {} |
||||
set termscore 0.0 |
||||
set tb [dict get $gb terms] |
||||
foreach ta [dict get $ga terms] { |
||||
if {[lsearch -exact $tb $ta] < 0} continue |
||||
set df [dict get $termdf $ta] |
||||
if {$df <= 12} { |
||||
set w [expr {1.0 / $df}] |
||||
} elseif {$df <= 28} { |
||||
set w [expr {0.6 / $df}] |
||||
} else { |
||||
set w 0.0 |
||||
} |
||||
if {$w > 0} { |
||||
set termscore [expr {$termscore + $w}] |
||||
lappend terms "$ta (df$df)" |
||||
} |
||||
} |
||||
return [list $pathscore $anchors $termscore $terms] |
||||
} |
||||
|
||||
set ::term_factor 0.35 |
||||
|
||||
proc pair_class {ga gb a b} { |
||||
set ab [expr {[lsearch -exact [dict get $ga refs] $b] >= 0}] |
||||
set ba [expr {[lsearch -exact [dict get $gb refs] $a] >= 0}] |
||||
if {$ab && $ba} { return linked } |
||||
if {$ab} { return "a-only" } |
||||
if {$ba} { return "b-only" } |
||||
return unlinked |
||||
} |
||||
|
||||
proc shared_archived {ga gb} { |
||||
global archive_index |
||||
set shared {} |
||||
foreach r [dict get $ga refs] { |
||||
if {![dict exists $archive_index $r]} continue |
||||
if {[lsearch -exact [dict get $gb refs] $r] >= 0} { lappend shared G-$r } |
||||
} |
||||
return $shared |
||||
} |
||||
|
||||
proc compute_pairs {} { |
||||
global goals ids |
||||
set pairs {} |
||||
set n [llength $ids] |
||||
for {set i 0} {$i < $n} {incr i} { |
||||
set a [lindex $ids $i] |
||||
set ga [dict get $goals $a] |
||||
for {set j [expr {$i + 1}]} {$j < $n} {incr j} { |
||||
set b [lindex $ids $j] |
||||
set gb [dict get $goals $b] |
||||
lassign [pair_evidence $ga $gb] ps anchors ts terms |
||||
if {$ps <= 0.0 && $ts <= 0.0} continue |
||||
set score [expr {$ps + $::term_factor * $ts}] |
||||
lappend pairs [list $score $ps $ts $a $b [pair_class $ga $gb $a $b] \ |
||||
$anchors $terms [shared_archived $ga $gb]] |
||||
} |
||||
} |
||||
return [lsort -decreasing -real -index 0 $pairs] |
||||
} |
||||
|
||||
proc fmt_id {id} { |
||||
scan $id %d n |
||||
return G-[format %03d $n] |
||||
} |
||||
|
||||
proc pair_text {p direction} { |
||||
lassign $p score ps ts a b class anchors terms shared |
||||
if {$direction eq "pair"} { |
||||
set head [format " %5.2f %s <-> %s (paths %.2f, terms %.2f)" \ |
||||
$score [fmt_id $a] [fmt_id $b] $ps $ts] |
||||
} elseif {$direction eq "a2b"} { |
||||
set head [format " %5.2f %s -> %s (paths %.2f, terms %.2f) back-pointer candidate: %s" \ |
||||
$score [fmt_id $a] [fmt_id $b] $ps $ts [fmt_id $b]] |
||||
} else { |
||||
set head [format " %5.2f %s -> %s (paths %.2f, terms %.2f) back-pointer candidate: %s" \ |
||||
$score [fmt_id $b] [fmt_id $a] $ps $ts [fmt_id $a]] |
||||
} |
||||
set lines [list $head] |
||||
if {[llength $anchors]} { lappend lines " paths: [join $anchors {, }]" } |
||||
if {[llength $terms]} { lappend lines " terms: [join $terms {, }]" } |
||||
if {[llength $shared]} { lappend lines " shared archived refs: [join $shared {, }]" } |
||||
return [join $lines \n] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------- modes -- |
||||
proc mode_report {top minscore show_linked} { |
||||
global goals ngoals |
||||
set pairs [compute_pairs] |
||||
set nprop 0; set nact 0 |
||||
dict for {id g} $goals { |
||||
if {[dict get $g status] eq "active"} { incr nact } else { incr nprop } |
||||
} |
||||
puts "goals_xref report: $ngoals live goals ($nprop proposed, $nact active)" |
||||
foreach sect {unlinked onedir linked} { |
||||
if {$sect eq "linked" && !$show_linked} continue |
||||
set lines {} |
||||
set shown 0 |
||||
foreach p $pairs { |
||||
if {$shown >= $top} break |
||||
set class [lindex $p 5] |
||||
if {[lindex $p 0] < $minscore} break |
||||
if {$sect eq "unlinked"} { |
||||
if {$class ne "unlinked"} continue |
||||
lappend lines [pair_text $p pair] |
||||
} elseif {$sect eq "onedir"} { |
||||
if {$class eq "a-only"} { |
||||
lappend lines [pair_text $p a2b] |
||||
} elseif {$class eq "b-only"} { |
||||
lappend lines [pair_text $p b2a] |
||||
} else { |
||||
continue |
||||
} |
||||
} else { |
||||
if {$class ne "linked"} continue |
||||
lappend lines [pair_text $p pair] |
||||
} |
||||
incr shown |
||||
} |
||||
switch $sect { |
||||
unlinked { set hdr "UNLINKED overlap pairs (no reference in either direction)" } |
||||
onedir { set hdr "ONE-DIRECTIONAL pairs (link exists one way only)" } |
||||
linked { set hdr "LINKED pairs (--linked)" } |
||||
} |
||||
puts "" |
||||
puts "$hdr - top $top:" |
||||
if {$shown == 0} { puts " (none)" } else { puts [join $lines \n] } |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
proc mode_paths {qpaths} { |
||||
global goals |
||||
if {![llength $qpaths]} { |
||||
puts stderr "goals_xref paths: give at least one path" |
||||
return 2 |
||||
} |
||||
foreach q $qpaths { |
||||
set qp {}; set qk {}; set qb {} |
||||
scope_anchors_pass1 $q qp qk qb |
||||
set qp [lsort -unique $qp]; set qk [lsort -unique $qk] |
||||
puts "query: $q" |
||||
puts " anchors: paths=[join $qp {, }] keys=[join $qk {, }]" |
||||
set scored {} |
||||
dict for {id g} $goals { |
||||
lassign [pair_evidence [dict create paths $qp keys $qk terms {}] $g] ps anchors ts terms |
||||
if {$ps <= 0.0} continue |
||||
lappend scored [list $ps $id $anchors] |
||||
} |
||||
foreach row [lsort -decreasing -real -index 0 $scored] { |
||||
lassign $row ps id anchors |
||||
puts [format " %5.2f %s %s" $ps [fmt_id $id] [dict get $goals $id title]] |
||||
puts " [join $anchors {, }]" |
||||
} |
||||
if {![llength $scored]} { puts " (no live goals intersect)" } |
||||
puts "" |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
proc mode_score {qarg} { |
||||
global goals |
||||
if {![regexp -nocase {^(?:g-?)?0*([1-9][0-9]*)$} $qarg -> qnum]} { |
||||
puts stderr "goals_xref score: bad goal id '$qarg'" |
||||
return 2 |
||||
} |
||||
set qid [format %03d $qnum] |
||||
if {![dict exists $goals $qid]} { |
||||
puts stderr "goals_xref score: no such live goal G-$qid" |
||||
return 2 |
||||
} |
||||
set g [dict get $goals $qid] |
||||
puts "[fmt_id $qid] [dict get $g title] ([dict get $g status])" |
||||
set outrefs {} |
||||
foreach r [dict get $g refs] { lappend outrefs [fmt_id $r] } |
||||
puts " refs out: [join $outrefs {, }]" |
||||
puts "" |
||||
set pairs [compute_pairs] |
||||
set shown 0 |
||||
foreach p $pairs { |
||||
lassign $p score ps ts a b class anchors terms shared |
||||
if {$a ne $qid && $b ne $qid} continue |
||||
incr shown |
||||
if {$a eq $qid} { set other $b } else { set other $a } |
||||
switch $class { |
||||
linked { set rel "<-> linked" } |
||||
a-only { if {$a eq $qid} { set rel "-> (they lack a back-pointer)" } else { set rel "<- (this goal lacks the back-pointer)" } } |
||||
b-only { if {$b eq $qid} { set rel "-> (they lack a back-pointer)" } else { set rel "<- (this goal lacks the back-pointer)" } } |
||||
default { set rel "-- unlinked" } |
||||
} |
||||
puts [format " %5.2f vs %s %s (paths %.2f, terms %.2f)" $score [fmt_id $other] $rel $ps $ts] |
||||
if {[llength $anchors]} { puts " paths: [join $anchors {, }]" } |
||||
if {[llength $terms]} { puts " terms: [join $terms {, }]" } |
||||
} |
||||
if {!$shown} { puts " (no overlap pairs)" } |
||||
return 0 |
||||
} |
||||
|
||||
proc mode_refs {} { |
||||
global goals active_index archive_index |
||||
set bad 0 |
||||
dict for {id g} $goals { |
||||
foreach r [dict get $g refs] { |
||||
if {![dict exists $active_index $r] && ![dict exists $archive_index $r]} { |
||||
puts "[dict get $g relpath]: references [fmt_id $r] - no such goal in GOALS.md or GOALS-archive.md" |
||||
incr bad |
||||
} |
||||
} |
||||
} |
||||
if {!$bad} { puts "goals_xref refs: no dangling references" } |
||||
return 0 |
||||
} |
||||
|
||||
switch $mode { |
||||
report { exit [mode_report $top $minscore $show_linked] } |
||||
paths { exit [mode_paths $modeargs] } |
||||
score { exit [mode_score [lindex $modeargs 0]] } |
||||
refs { exit [mode_refs] } |
||||
default { |
||||
puts stderr "goals_xref: unknown mode '$mode' (want report|paths|score|refs)" |
||||
exit 2 |
||||
} |
||||
} |
||||
Loading…
Reference in new issue