Posted to tcl by GPS at Tue Oct 09 02:54:57 GMT 2007view raw

  1. #This is my solution using memoize from the Wiki...
  2.  
  3. if {0} {
  4.  
  5. memoize
  6.  
  7. A package that can be used to cache, load and save the values of expensive pure function calls.
  8.  
  9. HISTORY
  10.  
  11. DDG 2004-06-03: A fix to memoize::save for handling strings with spaces
  12.  
  13. DDG 2004-06-04: Adding memoize::unload to unset the Memo array or parts of it instead of directly manipulating it via array unset memoize::Memo
  14.  
  15. SEE ALSO
  16.  
  17. memoizing, Perl Memoize Package [1]
  18.  
  19. }
  20.  
  21. ##############################################################################
  22. # AUTHOR: Dr. Detlef Groth
  23. # Copyright (c) Get it, use it, share it, improve it, but don't blame me.
  24. package provide memoize 0.1
  25. namespace eval ::memoize {
  26. variable Memo
  27. }
  28.  
  29. proc ::memoize::memoize {} {
  30. variable Memo
  31. set cmd [info level -1]
  32. if {[info level] > 2 && [lindex [info level -2] 0] eq "memoize::memoize"} return
  33. if { ! [info exists Memo($cmd)]} {set Memo($cmd) [eval $cmd]}
  34. return -code return $Memo($cmd)
  35. }
  36. proc ::memoize::save {file {cmd ""}} {
  37. variable Memo
  38. set names [array names Memo -glob $cmd*]
  39. if [catch { set out [open $file w 0600] }] {
  40. error "Could not open $file!"
  41. } else {
  42. foreach name $names {
  43. puts $out "set {memoize::Memo($name)} {$Memo($name)}"
  44. }
  45. }
  46. close $out
  47. }
  48.  
  49. proc ::memoize::load {file} {
  50. variable Memo
  51. if {[file readable $file]} {
  52. source $file
  53. }
  54. }
  55. proc ::memoize::unload {{cmd ""}} {
  56. variable Memo
  57. array unset Memo "$cmd*"
  58. }
  59. # testing actually longer than the code itself
  60. if {0} {
  61. # RS example
  62. proc memoize {} {
  63. global memo
  64. set cmd [info level -1]
  65. if {[info level] > 2 && [lindex [info level -2] 0] eq "memoize"} return
  66. if { ! [info exists memo($cmd)]} {set memo($cmd) [eval $cmd]}
  67. return -code return $memo($cmd)
  68. }
  69.  
  70. proc fib x {expr {$x <=1? 1 : [fib [expr {$x-1}]] + [fib [expr {$x-2}]]}}
  71. proc fibm x {memoize; expr {$x <=1? 1 : [fibm [expr {$x-1}]] + [fibm [expr {$x-2}]]}}
  72. proc fibmp x {memoize::memoize; expr {$x <=1? 1 : [fibm [expr {$x-1}]] + [fibm [expr {$x-2}]]}}
  73.  
  74. fib 20 ;#= 10946
  75. fibm 20 ;#= 10946
  76. fibmp 20 ;#= 10946
  77. time {fib 32} ;#= 7757279 microseconds per iteration
  78. time {fib 32} ;#= 7763364 microseconds per iteration
  79. time {fib 32} ;#= 7927045 microseconds per iteration
  80. array unset memo
  81. time {fibm 32} ;#= 1365 microseconds per iteration
  82. time {fibm 32} ;#= 27 microseconds per iteration
  83. time {fibm 32} ;#= 28 microseconds per iteration
  84. memoize::unload
  85. time {fibmp 32} ;#= 97 microseconds per iteration
  86. time {fibmp 32} ;#= 29 microseconds per iteration
  87. time {fibmp 32} ;#= 28 microseconds per iteration
  88. memoize::save test.tmf
  89. memoize::unload
  90. memoize::load test.tmf
  91. time {fibmp 32} ;#= 33 microseconds per iteration
  92. time {fibmp 32} ;#= 29 microseconds per iteration
  93. time {fibmp 32} ;#= 28 microseconds per iteration
  94. }
  95. set key "012345678912345678"
  96. set subject "DUKE NUKEM FOREVER"
  97. set iterations 1000000
  98.  
  99. proc xor {subject key} {
  100. binary scan $subject c[string length $subject] subject
  101. binary scan $key c[string length $key] key
  102. set destbuffer [list]
  103. foreach s $subject k $key {
  104. lappend destbuffer [expr {$s^$k}]
  105. }
  106. return [binary format c* $destbuffer]
  107. }
  108. puts BASE:[time {xor $subject $key}]
  109.  
  110. proc xor2 {subject key} {
  111. memoize::memoize
  112. set result {}
  113. foreach s [split $subject ""] k [split $key ""] {
  114. append result [format %c [expr {[scan $s %c] ^ [scan $k %c]}]]
  115. }
  116. return $result
  117. }
  118.  
  119. puts ONCE:[time {xor2 $subject $key}]
  120. puts TWICE:[time {xor2 $subject $key}]
  121. puts THRICE:[time {xor2 $subject $key}]
  122.  
  123. set iterations [expr $iterations*2]
  124. for {set i 0} {$i < $iterations} {incr i} {
  125. set subject [xor2 $subject $key]
  126. #puts $subject
  127. }
  128. puts "after: $subject"
  129.