Posted to tcl by aspect at Thu Nov 19 04:16:19 GMT 2015view raw

  1. proc fixpoint {varName script} {
  2. upvar 1 $varName arg
  3. while {[set res [uplevel 1 $script]] ne $arg} {
  4. set arg $res
  5. }
  6. return $res
  7. }
  8.  
  9. proc dfs {cmdPrefix seed} {
  10. set stack [list $seed]
  11. set result {}
  12. while {[llength $stack]} {
  13. set stack [lassign $stack seed]
  14. lappend result $seed
  15. set stack [linsert $stack 0 {*}[uplevel 1 $cmdPrefix [list $seed]]]
  16. }
  17. return $result
  18. }
  19.  
  20. # ^^ -- not used in this example, but relevant variations on [bfs] -- ^^
  21.  
  22. proc bfs {varName script} {
  23. upvar 1 $varName seed
  24. set queue [list $seed]
  25. set result {}
  26. while {[llength $queue]} {
  27. set queue [lassign $queue seed]
  28. lappend result $seed
  29. lappend queue {*}[uplevel 1 $script]
  30. }
  31. }
  32.  
  33. set arclist {
  34. a b
  35. a p
  36. b m
  37. b c
  38. c d
  39. d e
  40. e f
  41. f q
  42. f g
  43. }
  44. foreach {from to} $arclist {
  45. dict lappend arcs $from $to
  46. }
  47.  
  48. proc findpath {arcs from to} {
  49. set path [list $from]
  50. set good {}
  51. bfs {path} {
  52. set node [lindex $path end]
  53. if {[dict exists $arcs $node]} {
  54. lmap next [dict get $arcs $node] {
  55. if {$next in $to} {
  56. lappend good [list {*}$path $next]
  57. }
  58. list {*}$path $next
  59. }
  60. }
  61. }
  62. return $good
  63. }
  64.  
  65. puts [findpath $arcs a {k l g}]
  66.