Posted to tcl by dbohdan at Fri Mar 20 11:43:02 GMT 2015view raw

  1. namespace eval ::decoder {
  2. variable format {
  3. header {
  4. magic 6 a6
  5. len 8 W
  6. version 11 a11
  7. zeros2 21 cu21
  8. tempo 4 f1
  9. }
  10. instrument {
  11. track 1 cu1
  12. zeros 3 cu3
  13. lname 1 cu1
  14. name $lname a${lname}
  15. party 16 cu16
  16. }
  17. }
  18. variable
  19. }
  20.  
  21. proc ::decoder::dump-dict {dictionary} {
  22. puts "{"
  23. foreach {key value} $dictionary {
  24. puts [format { %-8s "%s" %2d %2d} $key $value \
  25. [llength $value] [string length $value]]
  26. }
  27. puts "}\n"
  28. }
  29.  
  30. proc ::decoder::read-record {channel format} {
  31. set result {}
  32. foreach {field length binFormat} $format {
  33. dict with result {
  34. set length [subst $length]
  35. set binFormat [subst $binFormat]
  36. }
  37. set raw [read $channel $length]
  38. if {$raw eq ""} {
  39. # EOF.
  40. return
  41. }
  42. if {[binary scan $raw $binFormat processed]} {
  43. dict set result $field $processed
  44. } else {
  45. error "could not scan value \"$raw\" as \"$binFormat\""
  46. }
  47. #dump-dict $result
  48. }
  49. return $result
  50. }
  51.  
  52.  
  53. proc ::decoder::pretty-print {data} {
  54. dict with data {
  55. dict with header {
  56. puts "[file tail $filename]"
  57. puts "Saved with HW Version: $version"
  58. puts "Tempo: $tempo"
  59. }
  60. foreach instrument $instruments {
  61. if {$instrument eq ""} { continue }
  62. dict with instrument {
  63. set party [string map {0 - 1 x} [join $party ""]]
  64. regsub {(....)(....)(....)(....)} $party {|\1|\2|\3|\4|} party
  65. puts "($track) $name\t$party"
  66. }
  67. }
  68. }
  69. }
  70.  
  71.  
  72. proc ::decoder::decode {filename} {
  73. variable format
  74. set ch [open $filename]
  75. fconfigure $ch -encoding binary -translation binary
  76. set result [list filename $filename]
  77. dict set result header [read-record $ch [dict get $format header]]
  78. dict set result instruments {}
  79. while {![eof $ch]} {
  80. catch {
  81. dict lappend result instruments \
  82. [read-record $ch [dict get $format instrument]]
  83. }
  84. }
  85. close $ch
  86. return $result
  87. }
  88.  
  89. set decoded [::decoder::decode [lindex $argv 0]]
  90. ::decoder::dump-dict $decoded
  91. ::decoder::pretty-print $decoded
  92.