Posted to tcl by patthoyts at Mon Aug 18 13:34:19 GMT 2008view raw

  1. # An example of a coroutine based RLE decoder
  2. # Reads data a character at a time. If the input is \xff then the next byte
  3. # is the number of repetitions of the following byte.
  4. # Each call to the coroutine will return 1 byte.
  5.  
  6. load /opt/tcl/site-lib/Memchan2.2.2/memchan222.dll
  7. package require Memchan
  8.  
  9. namespace path ::tcl::unsupported
  10. variable uid 0
  11.  
  12. # A factory procedure that returns a lambda-based coroutine to decode
  13. # our RLE encoded channel. When the lambda exits, it will clean
  14. # up the decoder procedure automatically.
  15. # The proc returns the name of the created decoder, each call to this
  16. # new command will return one character from the data stream or -1 when
  17. # the stream has been emptied.
  18. proc make-decompressor {channel} {
  19. variable uid
  20. set lambda [list {chan} {
  21. yield
  22. while {1} {
  23. set c [read $chan 1]
  24. if {[eof $chan]} {
  25. return -1
  26. }
  27. if {[scan $c %c] == 0xff} {
  28. set len [scan [read $chan 1] %c]
  29. set c [read $chan 1]
  30. while {$len} {
  31. incr len -1
  32. yield $c
  33. }
  34. } else {
  35. yield $c
  36. }
  37. }
  38. }]
  39. set name rle[incr uid]
  40. coroutine $name ::apply $lambda $channel
  41. return $name
  42. }
  43.  
  44. # Create a channel with some sample RLE encoded data.
  45. set mem [memchan]
  46. puts -nonewline $mem "\x31\x32\x33\xff\x06\x34\x35"
  47. seek $mem 0
  48.  
  49. # Create a coroutine reader that will return one char per call from the
  50. # compressed channel data.
  51. set getchar [make-decompressor $mem]
  52.  
  53. # Prove that the decoder exists as a command
  54. puts "$getchar exists? [llength [info commands $getchar]]"
  55.  
  56. # Nice simple reader code...
  57. set n 0
  58. while {[set c [$getchar]] != -1} {
  59. puts "$n '$c'"
  60. incr n
  61. }
  62.  
  63. close $mem
  64.  
  65. # Prove the decoder was automatically garbage collected.
  66. puts "$getchar exists? [llength [info commands $getchar]]"

Comments

Posted by miguel at Mon Aug 18 13:40:29 GMT 2008 [text] [code]

Nice! If the lambda were defined as a literal instead of using [list], decompressors for all channels would use the same lambda and bytecodes, the compilation would be done just once.