# MIDI::SoundFont.pm
#########################################################################
# This Perl module is Copyright (c) 2002, Peter J Billam #
# c/o P J B Computing, www.pjb.com.au #
# #
# This module is free software; you can redistribute it and/or #
# modify it under the same terms as Perl itself. #
#########################################################################
package MIDI::SoundFont;
no strict;
use bytes;
#my $debug = 1; use Data::Dumper;
$VERSION = '1.08';
$VERSION_DATE = '18may2013';
# 20130518 1.07 Makefile.PL specifies PREREQ_PM, to improve test results :-)
# 20130515 1.06 test.pl skips Gravis.zip test if String::Approx not installed
# 20120809 1.05 added the csound_scoresynth and csound_midisynth examples
# 20120322 1.04 pack a=zeropadded rather than A=spacepadded; introduce
# new_gf(), gravis2file now works, and make_bank5 does gravis too
# 20120320 1.03 new_sf(), and chCorrection is packed as signed
# 20120318 1.02 detect duplicate Preset,Inst,Sample names and uniquely rename
# 20120216 1.01 gravis2file writes .zip files
# 20120215 1.00 first released version
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
@EXPORT = ();
@EXPORT_OK = qw( GeneratorOperators GenAmountType bytes2sf file2sf
sf2bytes sf2file new_sf file2gravis gravis2file new_pat timidity_cfg
);
@EXPORT_CONSTS = qw(GeneratorOperators GenOpname2num GenAmountType
MODES_16BIT MODES_UNSIGNED MODES_LOOPING MODES_PINGPONG
MODES_REVERSE MODES_SUSTAIN MODES_ENVELOPE MODES_CLAMPED);
%EXPORT_TAGS = (ALL => [@EXPORT_OK], CONSTS => [@EXPORT_CONSTS]);
eval 'require File::Format::RIFF';
if ($@) {
die "you need to install the File::Format::RIFF module from www.cpan.org\n";
}
# local $[ = 0; # SoundFont indexes start at zero but setting $[ is deprecated
my %SampleName = (); # to avoid duplicating sample-names...
# ----------------------- exportable constants -----------------------
@GeneratorOperators = qw(
startAddrsOffset endAddrsOffset startloopAddrsOffset endloopAddrsOffset
startAddrsCoarseOffset modLfoToPitch vibLfoToPitch modEnvToPitch
initialFilterFc initialFilterQ modLfoToFilterFc modEnvToFilterFc
endAddrsCoarseOffset modLfoToVolume unused1 chorusEffectsSend
reverbEffectsSend pan unused2 unused3
unused4 delayModLFO freqModLFO delayVibLFO
freqVibLFO delayModEnv attackModEnv holdModEnv
decayModEnv sustainModEnv releaseModEnv keynumToModEnvHold
keynumToModEnvDecay delayVolEnv attackVolEnv holdVolEnv
decayVolEnv sustainVolEnv releaseVolEnv keynumToVolEnvHold
keynumToVolEnvDecay instrument reserved1 keyRange
velRange startloopAddrsCoarseOffset keynum velocity
initialAttenuation reserved2 endloopAddrsCoarseOffset coarseTune
fineTune sampleID sampleModes reserved3
scaleTuning exclusiveClass overridingRootKey unused5
endOper
);
%GenOpname2num = (); {
my $i=0; while ($i <= $#GeneratorOperators) {
$GenOpname2num{$GeneratorOperators[$i]} = $i;
$i += 1;
}
}
@GenAmountType = qw (
S s s s
s s s s
s s s s
s s x s
s s x x
x s s s
s s s s
s s s s
s s s s
s s s s
s S x C2
C2 s S S
S x s s
s S S x
s S s x
x
); # s signed, S unsigned, C2 two bytes, x null; sfspec21 8.1.2 & guesswork
$MODES_16BIT = 1; $MODES_UNSIGNED = 2;
$MODES_LOOPING = 4; $MODES_PINGPONG = 8;
$MODES_REVERSE = 16; $MODES_SUSTAIN = 32;
$MODES_ENVELOPE = 64; $MODES_CLAMPED = 128;
# sf:
# see http://www.pjb.com.au/midi.sfspec21.html#8.1.3
my %OnlyValidInInstr = map { $_, 1 } (0,1,2,3,4,12,45,50,54,57,58);
# gravis:
my $DefaultEnvelopeData = "\x3f\x46\x81\x42\x3f\x3f\xd5\xf2\xf6\x08\x08\x08";
# ----------------------- exportable functions -----------------------
sub file2bytes {
# read bytes from file, or url, or filehandle, or - is stdin
my $bytes;
if ($_[0] eq '-') {
undef $/; binmode STDIN, ':raw';
$bytes = <STDIN>;
} elsif ($_[0] =~ /^[a-z]+:\//) {
eval 'require LWP::Simple'; if ($@) {
die "you'll need to install libwww-perl from www.cpan.org\n";
}
my $bytes = LWP::Simple::get($_[0]);
if (! defined $bytes) { die("can't fetch $_[0]\n"); }
} elsif (ref($_[0]) eq 'GLOB') {
# must open the file ?
undef $/; binmode $_[0], ':raw';
$bytes = <$_[0]>;
close $_[0];
} else {
if (! open(F, '<:raw', $_[0])) {
warn "can't open $_[0]: $!\n"; return '';
}
undef $/; binmode F; $bytes = <F>; close F;
}
return $bytes;
}
sub file2sf {
my $bytes = file2bytes($_[0]);
return bytes2sf($bytes);
}
sub file2dump {
my $bytes = file2bytes($_[0]);
return bytes2dump($bytes);
}
sub bytes2dump { my $bytes = $_[0];
my %sf = ();
if (! open(P, '<', \$bytes)) {
warn "can't open in-memory filehandle: $!\n"; return;
}
undef $/; binmode P;
my $riff = File::Format::RIFF->read(\*P, length($bytes));
close P;
my $info = $riff->at(0); $info->dump;
my $sdta = $riff->at(1); $sdta->dump;
my $smpl = $sdta->shift();
my $smpl_data = $smpl->data();
my $pdta = $riff->at(2); $pdta->dump;
}
sub bytes2sf { my $bytes = $_[0]; # take it apart with RIFF
my %sf = ();
if (! open(P, '<', \$bytes)) {
warn "can't open in-memory filehandle: $!\n"; return;
}
undef $/; binmode P;
my $riff = File::Format::RIFF->read(\*P, length($bytes));
close P;
my $info = $riff->at(0);
my $sdta = $riff->at(1);
my $smpl = $sdta->shift();
my $smpl_data = $smpl->data();
my $pdta = $riff->at(2);
while (1) { # INFO
my $chunk = $info->shift();
if (! defined $chunk) { last; }
my $id = $chunk->id();
my $data = $chunk->data();
if ($id eq 'ifil' or $id eq 'iver') {
my ($wMajor, $wMinor) = unpack('SS', $data);
$sf{$id} = "$wMajor.$wMinor";
} else {
$data =~ s/\0*$//s;
$sf{$id} = $data;
}
}
my %pdta = ();
while (1) { # PDTA
my $chunk = $pdta->shift();
if (! defined $chunk) { last; }
$pdta{$chunk->id()} = $chunk->data();
# warn $chunk->id()." is ".length($pdta{$chunk->id()})." bytes long\n";
}
# http://www.pjb.com.au/midi/sfspec21.html#7.2
if (! $pdta{'phdr'}) { warn "missing phdr sub-chunk\n"; return undef; }
my $len = length $pdta{'phdr'}; if ($len % 38) {
warn "phdr sub-chunk not a multiple of 38 bytes\n"; return undef;
}
my $ind = 0; # $[ must be zero
my @phdr_list = ();
my %preset_names_seen = (); # 1.02
while ($ind < $len) { # sfspec21.txt 7.2
my $phdr_rec = substr $pdta{'phdr'}, $ind, 38;
my ($achPresetName,$wPreset,$wBank,$wPresetBagNdx,$dwLibrary,
$dwGenre,$dwMorphology) = unpack 'A20SSSLLL', $phdr_rec;
$achPresetName =~ s/\0.*$//s;
# 1.02 detect duplicate names and rename as necessary (7.2)
my $orig = $achPresetName;
my $x = 2; while ($preset_names_seen{$achPresetName}) {
$achPresetName = $orig."_$x"; $x += 1;
}
$preset_names_seen{$achPresetName} = 1;
push @phdr_list, {
achPresetName => $achPresetName,
wPreset => $wPreset,
wBank => $wBank,
wPresetBagNdx => $wPresetBagNdx,
# dwLibrary => $dwLibrary,
# dwGenre => $dwGenre,
# dwMorphology => $dwMorphology,
};
$ind += 38;
}
# http://www.pjb.com.au/midi/sfspec21.html#7.3
if (! $pdta{'pbag'}) { warn "missing pbag sub-chunk\n"; return undef; }
$len = length $pdta{'pbag'}; if ($len % 4) {
warn "pbag sub-chunk not a multiple of 4 bytes\n"; return undef;
}
$ind = 0;
my @pbag_list = ();
while ($ind < $len) { # sfspec21.txt 7.3
my $pbag_rec = substr $pdta{'pbag'}, $ind, 4;
my ($wGenNdx,$wModNdx) = unpack 'SS', $pbag_rec;
push @pbag_list, {
wGenNdx => $wGenNdx,
wModNdx => $wModNdx,
};
$ind += 4;
}
# http://www.pjb.com.au/midi/sfspec21.html#7.4
if (! $pdta{'pmod'}) { warn "missing pmod sub-chunk\n"; return undef; }
$len = length $pdta{'pmod'}; if ($len % 10) {
warn "pmod sub-chunk not a multiple of 10 bytes\n"; return undef;
}
$ind = 0;
my @pmod_list = ();
while ($ind < $len) { # sfspec21.txt 7.4
my $pmod_rec = substr $pdta{'pmod'}, $ind, 10;
my ($sfModSrcOper,$sfModDestOper,$modAmount,$sfModAmtSrcOper,
$sfModTransOper) = unpack 'SSSSS', $pmod_rec;
push @pmod_list, {
sfModSrcOper => $sfModSrcOper,
sfModDestOper => $sfModDestOper,
modAmount => $modAmount,
sfModAmtSrcOper => $sfModAmtSrcOper,
sfModTransOper => $sfModTransOper,
};
$ind += 10;
}
# http://www.pjb.com.au/midi/sfspec21.html#7.6
if (! $pdta{'inst'}) { warn "missing inst sub-chunk\n"; return undef; }
$len = length $pdta{'inst'}; if ($len % 22) {
warn "inst sub-chunk not a multiple of 22 bytes\n"; return undef;
}
$ind = 0; # $[ _must_ be zero
my @inst_list = ();
my %inst_names_seen = (); # 1.02
while ($ind < $len) { # sfspec21.html#7.6
my $inst_rec = substr $pdta{'inst'}, $ind, 22;
my ($achInstName,$wInstBagNdx) = unpack 'A20S', $inst_rec;
$achInstName =~ s/\0.*$//s;
# 1.02 detect duplicate names and rename as necessary (7.6)
my $orig = $achInstName;
my $x = 2; while ($inst_names_seen{$achInstName}) {
$achInstName = $orig."_$x"; $x += 1;
}
$inst_names_seen{$achInstName} = 1;
push @inst_list, {
achInstName => $achInstName,
wInstBagNdx => $wInstBagNdx,
};
$ind += 22;
}
# http://www.pjb.com.au/midi/sfspec21.html#7.7
if (! $pdta{'ibag'}) { warn "missing ibag sub-chunk\n"; return undef; }
$len = length $pdta{'ibag'}; if ($len % 4) {
warn "ibag sub-chunk not a multiple of 4 bytes\n"; return undef;
}
$ind = 0;
my @ibag_list = ();
while ($ind < $len) { # sfspec21.txt 7.7
my $ibag_rec = substr $pdta{'ibag'}, $ind, 4;
my ($wInstGenNdx,$wInstModNdx) = unpack 'SS', $ibag_rec;
push @ibag_list, {
wInstGenNdx => $wInstGenNdx,
wInstModNdx => $wInstModNdx,
};
$ind += 4;
}
# now go though @inst_list extracting each preset's lists of bags
$i = 0; while ($i < $#inst_list) {
my $from = $inst_list[$i]{'wInstBagNdx'};
my $to = $inst_list[$i+1]{'wInstBagNdx'};
# should check monotonicity and in-rangeness
my @ibags = (); my $j = $from;
while ($j < $to) { push @ibags, $ibag_list[$j]; $j += 1; }
$inst_list[$i]{'ibags'} = \@ibags;
$i += 1;
}
# http://www.pjb.com.au/midi/sfspec21.html#7.8
if (! $pdta{'imod'}) { warn "missing imod sub-chunk\n"; return undef; }
$len = length $pdta{'imod'}; if ($len % 10) {
warn "imod sub-chunk not a multiple of 10 bytes\n"; return undef;
}
$ind = 0;
my @imod_list = ();
while ($ind < $len) { # sfspec21.txt 7.8
my $imod_rec = substr $pdta{'imod'}, $ind, 10;
my ($sfModSrcOper,$sfModDestOper,$modAmount,$sfModAmtSrcOper,
$sfModTransOper) = unpack 'SSSSS', $imod_rec;
push @imod_list, {
sfModSrcOper => $sfModSrcOper,
sfModDestOper => $sfModDestOper,
modAmount => $modAmount,
sfModAmtSrcOper => $sfModAmtSrcOper,
sfModTransOper => $sfModTransOper,
};
$ind += 10;
}
# http://www.pjb.com.au/midi/sfspec21.html#7.10
if (! $pdta{'shdr'}) { warn "missing shdr sub-chunk\n"; return undef; }
$len = length $pdta{'shdr'}; if ($len % 46) {
warn "shdr sub-chunk not a multiple of 46 bytes\n"; return undef;
}
$ind = 0;
my @shdr_list = ();
my %sample_names_seen = (); # 1.02
while ($ind < $len) { # sfspec21.html#7.10
my $shdr_rec = substr $pdta{'shdr'}, $ind, 46;
my ($achSampleName,$dwStart,$dwEnd,$dwStartloop,$dwEndloop,
$dwSampleRate,$byOriginalKey,$chCorrection,$wSampleLink,$sfSampleType)
= unpack 'A20LLLLLCcSS', $shdr_rec;
$achSampleName =~ s/\0.*$//s;
# 1.02 detect duplicate names and rename as necessary (7.10)
my $orig = $achSampleName;
my $x = 2; while ($sample_names_seen{$achSampleName}) {
$achSampleName = $orig."_$x"; $x += 1;
}
$sample_names_seen{$achSampleName} = 1;
# extract the sample from $smpl_data
my $smpl_length = $dwEnd - $dwStart; # could test
my $this_sample = substr($smpl_data, # 16 bits is 2 bytes
$dwStart+$dwStart, $smpl_length+$smpl_length);
if ($achSampleName ne 'EOS') {
push @shdr_list, {
achSampleName => $achSampleName,
dwStart => 0,
dwEnd => $dwEnd-$dwStart,
dwStartloop => $dwStartloop-$dwStart,
dwEndloop => $dwEndloop-$dwStart,
dwSampleRate => $dwSampleRate,
byOriginalKey => $byOriginalKey,
chCorrection => $chCorrection,
wSampleLink => $wSampleLink,
sfSampleType => $sfSampleType,
sampledata => $this_sample,
};
}
$ind += 46;
}
# http://www.pjb.com.au/midi/sfspec21.html#7.9
# http://www.pjb.com.au/midi/sfspec21.html#8.1.2
# http://www.pjb.com.au/midi/sfspec21.html#8.1.3
if (! $pdta{'igen'}) { warn "missing igen sub-chunk\n"; return undef; }
$len = length $pdta{'igen'}; if ($len % 4) {
warn "igen sub-chunk not a multiple of 4 bytes\n"; return undef;
}
$ind = 0;
my @igen_list = ();
while ($ind < $len) {
my $igen_rec = substr $pdta{'igen'}, $ind, 4;
my ($sfGenOper,$dummy) = unpack 'SS', $igen_rec;
my $type = $GenAmountType[$sfGenOper];
if (! defined $type) {
warn "sfGenOper=$sfGenOper out of range\n"; return;
}
if ($sfGenOper == 41) { # extract the instrument ILLEGAL HERE
warn "instruments are not allowed in instrument zones\n"; return;
my ($dummy,$shAmount) = unpack "SS", $igen_rec;
push @igen_list, {
sfGenOper=>$sfGenOper,
shAmount =>$inst_list[$shAmount]{'achInstName'}
};
} elsif ($sfGenOper == 53) { # extract the sample
my ($dummy,$shAmount) = unpack "SS", $igen_rec;
push @igen_list, {
sfGenOper=>$sfGenOper,
shAmount =>$shdr_list[$shAmount]{'achSampleName'}
};
} elsif ($type eq 'x') {
# unused; ignore
} elsif ($type eq 'C2') {
my ($dummy,$min,$max) = unpack "S$type", $igen_rec;
push @igen_list, { sfGenOper=>$sfGenOper, shAmount=>[$min,$max] };
} else {
my ($dummy,$shAmount) = unpack "S$type", $igen_rec;
push @igen_list, { sfGenOper=>$sfGenOper, shAmount=>$shAmount, };
}
$ind += 4;
}
# http://www.pjb.com.au/midi/sfspec21.html#7.5
# http://www.pjb.com.au/midi/sfspec21.html#8.1.2
# http://www.pjb.com.au/midi/sfspec21.html#8.1.3
if (! $pdta{'pgen'}) { warn "missing pgen sub-chunk\n"; return undef; }
$len = length $pdta{'pgen'}; if ($len % 4) {
warn "pgen sub-chunk not a multiple of 4 bytes\n"; return undef;
}
$ind = 0;
my @pgen_list = ();
while ($ind < $len) {
my $pgen_rec = substr $pdta{'pgen'}, $ind, 4;
my ($sfGenOper,$dummy) = unpack 'SS', $pgen_rec;
my $type = $GenAmountType[$sfGenOper];
if (! defined $type) {
warn "sfGenOper=$sfGenOper out of range\n"; return;
}
if ($OnlyValidInInstr{$sfGenOper}) {
#warn "sfGenOper=$sfGenOper ($GeneratorOperators[$sfGenOper]) "
# . "invalid in presets; ignoring\n";
# invalid in presets; ignore! see sfspec21.html#8.5
} elsif ($sfGenOper == 41) { # extract the instrument
my ($dummy,$shAmount) = unpack "SS", $pgen_rec;
push @pgen_list, {
sfGenOper=>$sfGenOper,
shAmount =>$inst_list[$shAmount]{'achInstName'}
};
} elsif ($type eq 'x') {
warn "sfGenOper=$sfGenOper unused; ignoring\n";
} elsif ($type eq 'C2') {
my ($dummy,$min,$max) = unpack "S$type", $pgen_rec;
push @pgen_list, { sfGenOper=>$sfGenOper, shAmount=>[$min,$max] };
} else {
my ($dummy,$shAmount) = unpack "S$type", $pgen_rec;
push @pgen_list, { sfGenOper=>$sfGenOper, shAmount=>$shAmount, };
}
$ind += 4;
}
# go though @pbag_list extracting each hash of modulators and generators
my $i = 0; while ($i < $#pbag_list) {
my $from = $pbag_list[$i]{'wGenNdx'};
my $to = $pbag_list[$i+1]{'wGenNdx'};
# should check monotonicity and in-rangeness
my %gens = (); my $j = $from;
while ($j < $to) {
if (defined $pgen_list[$j]{'shAmount'}) {
$gens{$GeneratorOperators[$pgen_list[$j]{'sfGenOper'}]}
= $pgen_list[$j]{'shAmount'};
}
$j += 1;
}
$pbag_list[$i]{'generators'} = \%gens;
delete $pbag_list[$i]{'wGenNdx'};
# should check monotonicity and in-rangeness
$from = $pbag_list[$i]{'wModNdx'};
$to = $pbag_list[$i+1]{'wModNdx'};
my @mods = (); $j = $from;
while ($j < $to) { push @mods, $pmod_list[$j]; $j += 1; }
$pbag_list[$i]{'modulators'} = \@mods;
delete $pbag_list[$i]{'wModNdx'};
$i += 1;
}
# now go though @phdr_list extracting each preset's lists of pbags
$i = 0; while ($i < $#phdr_list) {
my $from = $phdr_list[$i]{'wPresetBagNdx'};
my $to = $phdr_list[$i+1]{'wPresetBagNdx'};
# should check monotonicity and in-rangeness
my @pbags = (); my $j = $from;
while ($j < $to) { push @pbags, $pbag_list[$j]; $j += 1; }
$phdr_list[$i]{'pbags'} = \@pbags;
delete $phdr_list[$i]{'wPresetBagNdx'};
$i += 1;
}
# go though @ibag_list extracting each list of modulators and generators
$i = 0; while ($i < $#ibag_list) {
my $from = $ibag_list[$i]{'wInstGenNdx'};
my $to = $ibag_list[$i+1]{'wInstGenNdx'};
my %gens = (); my $j = $from;
while ($j < $to) {
$gens{$GeneratorOperators[$igen_list[$j]{'sfGenOper'}]}
= $igen_list[$j]{'shAmount'};
$j += 1;
}
$ibag_list[$i]{'generators'} = \%gens;
delete $ibag_list[$i]{'wInstGenNdx'};
# should check monotonicity and in-rangeness
$from = $ibag_list[$i]{'wInstModNdx'};
$to = $ibag_list[$i+1]{'wInstModNdx'};
my @mods = (); $j = $from;
while ($j < $to) { push @mods, $imod_list[$j]; $j += 1; }
$ibag_list[$i]{'modulators'} = \@mods;
delete $ibag_list[$i]{'wInstModNdx'};
$i += 1;
}
# now go though @inst_list extracting each preset's lists of bags
$i = 0; while ($i < $#inst_list) {
my $from = $inst_list[$i]{'wInstBagNdx'};
my $to = $inst_list[$i+1]{'wInstBagNdx'};
# should check monotonicity and in-rangeness
my @ibags = (); my $j = $from;
while ($j < $to) { push @ibags, $ibag_list[$j]; $j += 1; }
$inst_list[$i]{'ibags'} = \@ibags;
delete $inst_list[$i]{'wInstBagNdx'};
$i += 1;
}
# pop EOP off the end of @phdr_list
if ($phdr_list[$#phdr_list]{'achPresetName'} eq 'EOP') { pop @phdr_list; }
# pop EOI off the end of @inst_list
if ($inst_list[$#inst_list]{'achInstName'} eq 'EOI') { pop @inst_list; }
# construct %inst_hash and %shdr_hash
my %inst_hash = (); foreach (@inst_list) {
$inst_hash{$_->{'achInstName'}} = $_;
delete $_->{'achInstName'};
}
my %shdr_hash = (); foreach (@shdr_list) {
$shdr_hash{$_->{'achSampleName'}} = $_;
delete $_->{'achSampleName'};
}
# $sf{'pbag'} = \@pbag_list;
$sf{'phdr'} = \@phdr_list;
# $sf{'pmod'} = \@pmod_list;
# $sf{'pgen'} = \@pgen_list;
# $sf{'ibag'} = \@ibag_list;
$sf{'inst'} = \%inst_hash;
# $sf{'imod'} = \@imod_list;
# $sf{'igen'} = \@igen_list;
$sf{'shdr'} = \%shdr_hash;
if ($debug) {
$Data::Dumper::Indent=1; $Data::Dumper::Sortkeys=1; print Dumper(%sf);
}
return %sf;
}
sub new_sf { my $inam = $_[$[] || 'Name of this SoundFont';
my ($name,$passwd,$uid,$gid, $quota,$comment,$gcos,$dir,$shell,$expire)
= getpwuid($>);
$gcos =~ s/,+$//;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
my $y = sprintf ("%4.4d", $year+1900);
my @abbr = qw( January February March April May June
July August September October November December );
my $now = "$abbr[$mon] $mday, $y"; # sfspec21.html#5.6
return (
ICMT => "insert comment here",
ICOP => "Copyright (c) $y $gcos; may be freely copied and modified",
ICRD => $now,
IENG => "$name, $gcos",
INAM => $inam,
IPRD => 'TiMidity',
ISFT => "MIDI-SoundFont $VERSION",
IVER => '',
ifil => '2.1',
inst => {
inst_0 => {
ibags => [
{
generators => {
keyRange => [ 0, 127 ],
pan => -190,
sampleID => 'smpl_0',
sampleModes => 1,
},
modulators => [],
},
],
},
},
phdr => [
{
achPresetName => 'Instrument number 0',
pbags => [
{
generators => {
velRange => [ 0, 127 ],
instrument => 'inst_0',
},
modulators => [],
},
],
wBank => 0,
wPreset => 0,
},
],
shdr => {
inst_0 => {
byOriginalKey => 69,
chCorrection => 0,
dwEnd => 10000,
dwEndloop => 9990,
dwSampleRate => 44100,
dwStart => 0,
dwStartloop => 9890,
sampledata => ' ... ',
sfSampleType => 1,
wSampleLink => 0,
},
},
);
}
sub sf2file { my $file = shift;
# write bytes to file, or filehandle (if GLOB), or - is stdout
if (! $file) { warn "sf2file: missing arguments.\n"; return; }
my $bytes = sf2bytes(@_);
if (ref($file) eq 'GLOB') {
} elsif ($file eq '-') { binmode STDOUT; print STDOUT $bytes;
} else {
if (! open(F, '>', $file)) { warn "can't open $file: $!\n"; return; }
binmode F; print F $bytes;
close F;
}
}
sub sf2bytes{ my %sf = @_; # put it back together with RIFF
# must be careful not to modify %sf ! it's full of references !
# using sf_edit to change the banks, and saving to /tmp/k.sf2
# timidity -idvv -x 'soundfont /tmp/k.sf2' /tmp/t.mid | less
my $info = new File::Format::RIFF::List('INFO');
my $ifil_ck = new File::Format::RIFF::Chunk;
my ($wMajor,$wMinor) = split '\.', $sf{'ifil'};
$ifil_ck->id('ifil');
$ifil_ck->data(pack 'SS', $wMajor,$wMinor);
$info->push($ifil_ck);
my $isng_ck = new File::Format::RIFF::Chunk;
$isng_ck->id('isng');
$isng_ck->data(zero_pad_to_even($sf{'isng'} || 'EMU8000'));
$info->push($isng_ck);
my $INAM_ck = new File::Format::RIFF::Chunk;
$INAM_ck->id('INAM');
$INAM_ck->data(zero_pad_to_even($sf{'INAM'} || 'General MIDI'));
$info->push($INAM_ck);
if ($sf{'irom'}) { # it's optional
my $irom_ck = new File::Format::RIFF::Chunk;
$irom_ck->id('irom');
$irom_ck->data(zero_pad_to_even($sf{'irom'}));
$info->push($irom_ck);
}
if ($sf{'iver'} and $sf{'iver'}=~/^(\d+)\.(\d+)$/) { # it's optional
my $iver_ck = new File::Format::RIFF::Chunk;
$iver_ck->id('iver');
$iver_ck->data(pack 'SS', 0+$1,0+$2);
$info->push($iver_ck);
}
if ($sf{'ICRD'}) { # it's optional
my $ICRD_ck = new File::Format::RIFF::Chunk;
$ICRD_ck->id('ICRD');
$ICRD_ck->data(zero_pad_to_even($sf{'ICRD'}));
$info->push($ICRD_ck);
}
if ($sf{'IENG'}) { # it's optional
my $IENG_ck = new File::Format::RIFF::Chunk;
$IENG_ck->id('IENG');
$IENG_ck->data(zero_pad_to_even($sf{'IENG'}));
$info->push($IENG_ck);
}
if ($sf{'IPRD'}) { # it's optional
my $IPRD_ck = new File::Format::RIFF::Chunk;
$IPRD_ck->id('IPRD');
$IPRD_ck->data(zero_pad_to_even($sf{'IPRD'}));
$info->push($IPRD_ck);
}
if ($sf{'ICOP'}) { # it's optional
my $ICOP_ck = new File::Format::RIFF::Chunk;
$ICOP_ck->id('ICOP');
$ICOP_ck->data(zero_pad_to_even($sf{'ICOP'}));
$info->push($ICOP_ck);
}
if ($sf{'ICMT'}) { # it's optional
my $ICMT_ck = new File::Format::RIFF::Chunk;
$ICMT_ck->id('ICMT');
$ICMT_ck->data(zero_pad_to_even($sf{'ICMT'}));
$info->push($ICMT_ck);
}
my $ISFT_ck = new File::Format::RIFF::Chunk;
my $isft_data = "MIDI-SoundFont $VERSION";
if ($sf{'ISFT'}) { # it's optional, but we create it here anyway
my $s = $sf{'ISFT'};
$s =~ s/:.*$//s; # truncate to 20 less than max (max actually 256)
$isft_data = sprintf('%0.58s:%s', $s,$isft_data);
} else {
$isft_data = "$isft_data:";
}
$ISFT_ck->id('ISFT');
$ISFT_ck->data(zero_pad_to_even($isft_data));
$info->push($ISFT_ck);
# go through @phdr_list, move the pbags out into a @pbag_list, note Ndx's
# http://www.pjb.com.au/midi/sfspec21.html#7.2
my @pbag_list = ();
my @phdr_data = ();
# could sort:
# @phdr_list = sort { (1000*$a->{'wBank'}+$a->{'wPreset'})
# <=> (1000*$b->{'wBank'}+$b->{'wPreset'})} @{$sf{'phdr'}};
foreach my $p_ref (@{$sf{'phdr'}}) {
my $wPresetBagNdx = scalar @pbag_list;
my @these_pbags = @{$p_ref->{'pbags'}};
# check that the instrument-generator is last in @these_pbags #7.3
push @pbag_list, @these_pbags;
push @phdr_data, pack('a20SSSLLL', $p_ref->{'achPresetName'},
$p_ref->{'wPreset'}, $p_ref->{'wBank'}, $wPresetBagNdx, 0,0,0);
}
push @phdr_data, pack('a20SSSLLL', 'EOP',0,0,(scalar @pbag_list),0,0,0);
my $phdr_ck = new File::Format::RIFF::Chunk;
$phdr_ck->id('phdr');
$phdr_ck->data(join('', @phdr_data));
# go through @pbag_list moving the generators and modulators
# out into their own lists, and noting their Ndx's
# "the gen and mod lists are in the same order as the phdr and pbag lists"
# http://www.pjb.com.au/midi/sfspec21.html#7.3
my @pgen_list = (); # #7.3
my @pmod_list = (); # #7.4
my @pbag_data = (); # #7.5
foreach my $b_ref (@pbag_list) {
my $wGenNdx = scalar @pgen_list;
my $wModNdx = scalar @pmod_list;
my @these_pgens = gen_hashref2list($b_ref->{'generators'}, 'p');
my @these_pmods = @{$b_ref->{'modulators'}};
push @pgen_list, @these_pgens;
push @pmod_list, @these_pmods;
push @pbag_data, pack('SS', $wGenNdx, $wModNdx);
}
push @pbag_data, pack('SS', scalar @pgen_list, scalar @pmod_list);
my $pbag_ck = new File::Format::RIFF::Chunk;
$pbag_ck->id('pbag');
$pbag_ck->data(join('', @pbag_data));
# go through pgen_list to put together @inst_list in the required order
# replace the instrument-names in pgen_list with their indexes in inst
my %inst_name2index = ();
my @inst_list = ();
my @pgen_data = ();
foreach my $g_ref (@pgen_list) {
if ($g_ref->[0] == 41) {
my $inst_name = $g_ref->[1];
if (defined $inst_name2index{$inst_name}) {
$g_ref->[1] = $inst_name2index{$inst_name};
} else {
$g_ref->[1] = scalar @inst_list;
$inst_name2index{$inst_name} = $g_ref->[1];
push @inst_list, $inst_name;
}
}
my $type = $GenAmountType[$g_ref->[0]];
push @pgen_data, pack("S$type", @{$g_ref});
}
push @pgen_data, ("\0"x4);
my $pgen_ck = new File::Format::RIFF::Chunk;
$pgen_ck->id('pgen');
$pgen_ck->data(join('', @pgen_data));
# pack the pmod chunk
my @pmod_data = ();
foreach my $m_ref (@pmod_list) { # #7.4
# All modulators within a zone should have a unique set
# of sfModSrcOper, sfModDestOper, and sfModSrcAmtOper.
push @pmod_data, pack( 'SSSSS', $m_ref->{'sfModSrcOper'},
$m_ref->{'sfModDestOper'}, $m_ref->{'modAmount'},
$m_ref->{'sfModAmtSrcOper'}, $m_ref->{'sfModTransOper'},
);
}
push @pmod_data, ("\0"x10);
my $pmod_ck = new File::Format::RIFF::Chunk;
$pmod_ck->id('pmod');
$pmod_ck->data(join('', @pmod_data));
# go through @inst_list, move the ibags out into an @ibag_list, note Ndx's
# http://www.pjb.com.au/midi/sfspec21.html#7.6
my @ibag_list = ();
my @inst_data = ();
foreach my $inst_name (@inst_list) {
my $i_ref = $sf{'inst'}{$inst_name};
my $wInstBagNdx = scalar @ibag_list;
my @these_ibags = @{$i_ref->{'ibags'}};
push @ibag_list, @these_ibags;
push @inst_data, pack('a20S', $inst_name, $wInstBagNdx);
}
push @inst_data, pack('a20S', 'EOI',(scalar @ibag_list));
my $inst_ck = new File::Format::RIFF::Chunk;
$inst_ck->id('inst');
$inst_ck->data(join('', @inst_data));
# go through @ibag_list moving the generators and modulators out into
# their own lists, and noting their Ndx's
# http://www.pjb.com.au/midi/sfspec21.html#7.7
my @igen_list = (); # #7.3
my @imod_list = (); # #7.4
my @ibag_data = (); # #7.5
foreach my $b_ref (@ibag_list) {
my $wGenNdx = scalar @igen_list;
my $wModNdx = scalar @imod_list;
my @these_igens = gen_hashref2list($b_ref->{'generators'}, 'i');
my @these_imods = @{$b_ref->{'modulators'}};
push @igen_list, @these_igens;
push @imod_list, @these_imods;
push @ibag_data, pack('SS', $wGenNdx, $wModNdx);
}
push @ibag_data, pack('SS', scalar @igen_list, scalar @imod_list);
my $ibag_ck = new File::Format::RIFF::Chunk;
$ibag_ck->id('ibag');
$ibag_ck->data(join('', @ibag_data));
# go through igen_list constructing the list of required sample-names,
# and replace the sample-names in igen_list with their index in that list
my @igen_data = ();
my @smpl_list = ();
my %smpl_name2index = ();
foreach my $g_ref (@igen_list) {
if ($g_ref->[0] == 53) {
my $samplename = $g_ref->[1];
if (defined $smpl_name2index{$samplename}) {
$g_ref->[1] = $smpl_name2index{$samplename};
} else {
$g_ref->[1] = scalar @smpl_list;
push @smpl_list, $samplename;
$smpl_name2index{$samplename} = $g_ref->[1];
}
}
my $type = $GenAmountType[$g_ref->[0]];
push @igen_data, pack("S$type", @{$g_ref});
}
push @igen_data, ("\0"x4);
my $igen_ck = new File::Format::RIFF::Chunk;
$igen_ck->id('igen');
$igen_ck->data(join('', @igen_data));
# pack the imod chunk
my @imod_data = ();
foreach my $m_ref (@imod_list) { # #7.4
# All modulators within a zone should have a unique set
# of sfModSrcOper, sfModDestOper, and sfModSrcAmtOper.
push @imod_data, pack( 'SSSSS', $m_ref->{'sfModSrcOper'},
$m_ref->{'sfModDestOper'}, $m_ref->{'modAmount'},
$m_ref->{'sfModAmtSrcOper'}, $m_ref->{'sfModTransOper'},
);
}
push @imod_data, ("\0"x10);
my $imod_ck = new File::Format::RIFF::Chunk;
$imod_ck->id('imod');
$imod_ck->data(join('', @imod_data));
# need to append in order of occurence in Presets and Instruments!!
my %shdr_hash = %{$sf{'shdr'}};
my $samples = ''; # append to $samples to be able to measure its length
my @shdr_data = ();
my $index = 0;
foreach my $samplename (@smpl_list) { # must append in order!!
# adjust dwStart dwEnd dwStartloop dwEndloop
my $shdr = $shdr_hash{$samplename};
my $smpl_length = $shdr->{'dwEnd'} - $shdr->{'dwStart'};
my $to_startloop = $shdr->{'dwStartloop'} - $shdr->{'dwStart'};
my $to_endloop = $shdr->{'dwEndloop'} - $shdr->{'dwStart'};
my $start;
$start = (length $samples)/2;
$samples .= $shdr->{'sampledata'} . "\0"x92;
push @shdr_data, pack 'a20LLLLLCcSS', $samplename,
$start, $start+$smpl_length, $start+$to_startloop,
$start+$to_endloop, $shdr->{'dwSampleRate'},
$shdr->{'byOriginalKey'}, $shdr->{'chCorrection'},
$shdr->{'wSampleLink'}, $shdr->{'sfSampleType'},
$index += 1;
}
push @shdr_data, 'EOS'."\0"x43;
my $shdr_ck = new File::Format::RIFF::Chunk;
$shdr_ck->id('shdr');
$shdr_ck->data(join '', @shdr_data);
my $smpl_ck = new File::Format::RIFF::Chunk;
$smpl_ck->id('smpl');
$smpl_ck->data($samples);
my $sdta = new File::Format::RIFF::List('sdta');
$sdta->push($smpl_ck);
my $pdta = new File::Format::RIFF::List('pdta');
$pdta->push($phdr_ck);
$pdta->push($pbag_ck);
$pdta->push($pmod_ck);
$pdta->push($pgen_ck);
$pdta->push($inst_ck);
$pdta->push($ibag_ck);
$pdta->push($imod_ck);
$pdta->push($igen_ck);
$pdta->push($shdr_ck);
my $riff = new File::Format::RIFF('sfbk'); # section 4.1
$riff->push($info);
$riff->push($sdta);
$riff->push($pdta);
my $bytes;
if (! open(P, '>', \$bytes)) {
warn "can't open in-memory filehandle: $!\n"; return;
}
binmode P;
$riff->write(\*P);
#warn "RIFF:\n"; $riff->dump();
close P;
return $bytes;
}
sub gen_hashref2list { my ($gen_hashref, $is_p_or_i) = @_;
my @gen_list = (); # list of [sfGenOper,genAmount] listrefs, see 7.5 8.1.1
my $last_item;
while (my ($name, $shAmount) = each %{$gen_hashref}) {
my $sfGenOper = $GenOpname2num{$name};
my $type = $GenAmountType[$sfGenOper];
if (! defined $type) {
warn "unrecognised generator=$generator\n"; return;
}
if (($sfGenOper == 41) && ($is_p_or_i eq 'i')) {
warn "instruments are not allowed in instrument zones\n"; return;
}
if (($sfGenOper == 53) && ($is_p_or_i eq 'p')) {
warn "samples are not allowed in preset zones\n"; return;
}
if ($OnlyValidInInstr{$sfGenOper} && ($is_p_or_i eq 'p')) {
warn "sfGenOper=$sfGenOper not valid in preset zones\n"; next;
}
# we leave the instruments and samples referred to by name,
# to be replaced by an index when we know the list.
if ($type eq 'x') {
# unused; ignore
} elsif ($type eq 'C2') {
if ($sfGenOper == 43) { # keyRange MUST be first
unshift @gen_list, [$sfGenOper, @{$shAmount}];
} else {
push @gen_list, [$sfGenOper, @{$shAmount}];
}
} elsif (($sfGenOper == 41) || ($sfGenOper == 53)) { # MUST be last
$last_item = [$sfGenOper, $shAmount,];
} else {
push @gen_list, [$sfGenOper, $shAmount,];
}
}
# could check for global zone
if ($last_item) { push @gen_list, $last_item; }
return @gen_list;
}
sub file2smpl { my ($filename, $original_key, $opt_ref) = @_;
my %opt = %{$opt_ref}; # noloop
# NB: from_key, to_key, from_vel, to_vel go in the ibags, not the shdrs
# we generate $SampleID = $achSampleName from the basename of $filename
# keeping an eye out for duplicates.
# $original_key can be fractional, e.g. 60.4
# looping seems mandatory in sf, so 'noloop' means:
# pushing >32 zero-samples onto the end, and looping them.
# invoke file2raw then raw2shdr
my ($sample_rate, $data) = file2raw($filename);
if (! defined $data) { return; }
use File::Basename;
my $base = basename($filename);
$base =~s/\.\w\w\w\w?$//;
my $sample_name = $base;
if ($SampleName{$sample_name}) {
my $i = 0;
while (1) {
$i += 1;
$sample_name = $base.'_'.$i;
if (! $SampleName{$sample_name}) { last; }
}
}
my %shdr = ();
if ($opt{'noloop'}) {
my $len = length $data; # warn "len = $len\n";
my @zeros = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
@zeros = (@zeros,@zeros,$zeros); # 48 of them
%shdr = raw2shdr($sample_name, $original_key, $sample_rate,
$data . pack('s<*', @zeros));
$shdr{$sample_name}->{'dwStartloop'} = $len+4;
$shdr{$sample_name}->{'dwEndloop'} = $len+44;
} else {
%shdr = raw2shdr($sample_name, $original_key, $sample_rate, $data);
set_looppoints($shdr{$sample_name});
}
return $shdr{$sample_name};
}
sub file2wavsample { my $filename = $_[$[]; # provide a 'noloop' option ?
# need to know sample_name, byOriginalKey
# invoke file2raw then raw2wavsample
}
sub file2raw { my $file = $_[$[];
if (! -e $file) { warn "does not exist: $file\n"; return; }
if (! -f $file) { warn "not a file: $file\n"; return; }
if (! -r $file) { warn "not readable: $file\n"; return; }
# Use soxi $file to ascertain the channels and sample-rate
# (don't use File::Format::RIFF because that only handles .wav files)
# It would be more elegant if there were a CPAN libsox module...
if (! open(P, '-|', "soxi",$file)) {
warn "can't run soxi '$file': $!\n"; return;
}
my $channels = 2; my $sample_rate = 44100;
while (<P>) {
if (/^Channels\s+:\s*(\d+)/) { $channels = 0+$1; next; }
if (/^Sample Rate\s+:\s*(\d+)/) { $sample_rate = 0+$1; next; }
}
close P;
my $tmp; my @data = ();
if ($channels == 1) { # if already mono:
if (! open(P, '-|', "sox '$file' -t raw -c 1 -b 16 -e signed -")) {
warn "can't run sox '$file': $!\n"; return;
}
} else { # stereo to mono:
if (!open(P,"sox '$file' -t raw -c 1 -b 16 -e signed - remix 1,2 |")) {
warn "can't run sox '$file': $!\n"; return;
}
}
while (read P, $tmp, 65536) { push @data, $tmp; }
close P;
return ($sample_rate, join('',@data));
}
sub raw2shdr { my ($achSampleName,$original_key,$dwSampleRate,$sampledata)=@_;
# the 16-bit signed $sampledata might come from a file through file2raw(),
# but might come from a user-supplied wavetable
# Do we invoke set_looppoints($sampledata) from here ? noloop option...
my $byOriginalKey = round($original_key);
my $chCorrection = round(100 * ($original_key-$byOriginalKey));
return ($achSampleName => { # 1.03
byOriginalKey => $byOriginalKey,
chCorrection => $chCorrection,
dwEnd => length $sampledata,
dwEndloop => $dwEndloop,
dwSampleRate => $dwSampleRate,
dwStart => 0,
dwStartloop => $dwStartloop,
sampledata => $sampledata,
sfSampleType => 1,
wSampleLink => 0
});
}
sub raw2wavsample { my ($sample_name,$root_freq,$sample_rate,$data)=@_;
# hopefully you used sox to convert data to .s16 raw signed 16bit mono
# Need to be able to handle non-looped samples...
# invoke raw2looppoints( ... , $data);
return {
balance => 7,
data => $data,
envelope_data => $DefaultEnvelopeData,
high_freq => 10000000,
loop_end => 87800,
loop_start => 87400,
low_freq => 20000,
mode => 101,
root_freq => 440000,
sample_name => $sample_name||'NoName',
sample_rate => 44100,
scale_factor => 1024,
scale_freq => 60,
tremolo_depth => 0,
tremolo_phase => 0,
tremolo_sweep => 0,
tune => 1,
vibrato_ctl => 0,
vibrato_depth => 0,
vibrato_sweep => 0
};
}
sub set_looppoints { my $sr = $_[$[]; # shdr_ref_or_wavsample_ref
# pass it a shdr_ref or a wavsample_ref and it will fill in the
# dwStartloop and dwEndloop, or loop_start and loop_end, and adjust
# the sample values in the loop for smoothest possible looping
my $samples_per_cycle;
if (defined $sr->{'dwStart'}) { # it's a soundfont shdr
# dwStart dwEnd byOriginalKey chCorrection dwSampleRate sampledata
my @data = unpack 's<*', $sr->{'sampledata'};
splice @data, $[, round(0.5 * ($[+$sr->{'dwStart'})); # bytes 2 samples
$sr->{'dwEnd'} -= $sr->{'dwStart'};
$sr->{'dwStart'} = $[;
my $samples_per_cycle = $sr->{'dwSampleRate'}
/ midipitch2freq($sr->{'byOriginalKey'} + 0.01*$sr->{'chCorrection'});
($start, $end) = raw2looppoints($samples_per_cycle, \@data);
$sr->{'dwStartloop'} = 2 * $start; # samples to bytes
$sr->{'dwEndloop'} = 2 * $end; # samples to bytes
$sr->{'sampledata'} = pack 's<*', @data;
return $sr;
} elsif (defined $sr->{'mode'}) { # it's a gravis wavsample
# root_freq sample_rate data
my @data = ();
if ($MODES_UNSIGNED && $sr->{'data'}) { # could test 16BIT ?
@data = unpack 's<*', @{$sr->{'data'}};
} else {
@data = unpack 'S<*', @{$sr->{'data'}};
}
my $samples_per_cycle = $sr->{'sample_rate'}
/ ($sr->{'sample_rate'} + $sr->{'tune'}); # check tune spec...
($start, $end) = raw2looppoints($samples_per_cycle, \@data);
$sr->{'loop_start'} = $start; # samples
$sr->{'loop_end'} = $end; # samples
return $sr;
} else {
warn "set_looppoints: neither dwStart nor mode present\n";
return undef;
}
}
sub raw2looppoints { my ($samples_per_cycle, $data_ref) = @_;
# Find the pair of zero-crossings exactly integer cycles apart for which
# the neighboring samples v[x] are situated in the most similar-in-shape
# curves, weighting nearby samples heavier of course; return indexes
# in _samples_ not bytes. Assume 16-bit signed little-endian.
my @data = @{$data_ref};
my @up_crossings = ();
my @down_crossings = ();
my $i = $[+1; while ($i < $#data) {
if ($data[$i]==0) {
if ($data[$i-1]>0 and $data[$i+1]<0) { push @down_crossings, $i;
} elsif ($data[$i-1]<0 and $data[$i+1]>0) { push @up_crossings, $i;
}
} elsif (($data[$i-1]>0) and ($data[$i]<0)) { push @down_crossings, $i;
} elsif (($data[$i-1]<0) and ($data[$i]>0)) { push @up_crossings, $i;
}
$i += 1;
}
warn "there are ".scalar(@up_crossings)." up_crossings\n";
warn "there are ".scalar(@down_crossings)." down_crossings\n";
my $best_start = $[; my $best_end = $#data; my $best_goodness = 0;
# too slow. must choose a loop_length .1<x<.5 sec closest to a multiple of
# $samples_per_cycle, then look for the several pairs of crossings closest
# to that distance apart, then choose the pair with the best goodness.
foreach my $is (round(0.75*scalar(@up_crossings)) .. ($#up_crossings-1)) {
foreach my $ie (($is+1) .. $#up_crossings) {
my $goodness = goodness_of_fit($is,$ie,$samples_per_cycle,\@data);
if ($goodness > $best_goodness) {
$best_start=$is; $best_end=$ie; $best_goodness=$goodness;
}
}
}
foreach my $is (round(0.75*scalar(@down_crossings))..($#down_crossings-1)){
foreach my $ie (($is+1) .. $#down_crossings) {
my $goodness = goodness_of_fit($is,$ie,$samples_per_cycle,\@data);
if ($goodness > $best_goodness) {
$best_start=$is; $best_end=$ie; $best_goodness=$goodness;
}
}
}
#warn "best_start=$best_start best_end=$best_end goodness=$best_goodness\n";
return ($best_start, $best_end);
}
sub smooth_a_loop { my ($start, $end, $samples_per_cycle, $data_ref) = @_;
# 1) +a*t to line up the end to the curve of the beginning
# then *b*t so that the graph of power/cycle is as horizontal as possible
# 2) then make a graph of the power (x*x)/cycle
# then *b*t so that the graph of power/cycle is as horizontal as possible
}
sub goodness_of_fit { my ($start, $end, $samples_per_cycle, $data_ref) = @_;
my @data = @{$data_ref};
# how close is $end-$start to a multiple of the cycle ?
my $cycles = ($end-$start) / $samples_per_cycle;
my $cycle_badness = 2.0 * abs($cycles - round($cycles)); # or square?
#warn "cycle_badness=$cycle_badness\n"; # 0..1
# how close are $end and $start to .8 and .95 of the data ?
my $size = scalar @data;
my $space_badness = abs(0.625*($start-(0.8*$size))/$size)
+ abs(0.475*($end-(0.95*$size))/$size);
#warn "space_badness=$space_badness\n"; # 0..1
# how well do the +/-1/4 of a cycle data points match ?
my $match_badness = 0;
my $quarter_cycle = round(0.25 * $samples_per_cycle);
foreach my $i (0 .. $quarter_cycle) {
my $weight = (1+$quarter_cycle-$i) / $quarter_cycle;
$match_badness += $weight * abs($data[$end+$i] - $data[$start+$i]);
$match_badness += $weight * abs($data[$end-$i] - $data[$start-$i]);
}
$match_badness = $match_badness / ($quarter_cycle*32000);
#warn "match_badness=$match_badness\n"; # 0..1
my $goodness = 1.0 - 0.15*$cycle_badness
- 0.15*$space_badness - 0.7*$match_badness;
#warn "goodness=$goodness\n"; # 0..1
}
sub midipitch2freq { my $pitch = $_[$[];
return 440 * (1.0594630943348**($pitch-69));
}
sub round { my $x = $_[$[];
if ($x > 0.0) { return int ($x + 0.5); }
if ($x < 0.0) { return int ($x - 0.5); }
return 0;
}
# --------------------------- gravis routines -----------------------
sub file2gravis { my $file = $_[0];
my $file_type = filetype($file);
if ($file_type eq 'pat') {
my %pat = bytes2pat(file2bytes($file));
$pat{'filename'} = $file;
eval 'require File::Basename'; if ($@) {
die "you'll need to install File::Basename from www.cpan.org\n";
}
my ($name,$path,$suffix) = File::Basename::fileparse($file,'.pat');
return "$name$suffix", \%pat; # kv, will be assigned into a hash
} elsif ($file_type eq 'zip') {
eval 'require Archive::Zip'; if ($@) {
die "you'll need to install Archive::Zip from www.cpan.org\n";
}
# take it apart with Archive::Zip
my $zip = Archive::Zip->new();
# if ($zip->read($file) != Archive::Zip::AZ_OK) {
if ($zip->read($file) != 0) {
warn "can't read zipfile $file: read error\n"; return undef;
}
my @memberNames = $zip->memberNames();
my @gr; # key/value/key/value...
foreach my $memberName ($zip->memberNames()) {
if ($memberName !~ /\.pat$/) { next; }
my $bytes = $zip->contents($memberName);
my %pat = bytes2pat($bytes);
push @gr, $memberName;
push @gr, \%pat;
}
return @gr; # kvkv, will be assigned into a hash
}
}
sub bytes2gravis { my $bytes = $_[0];
# Archive::Zip only does files, not even filehandles;
# might have to use /tmp in order to handle urls etc.
eval 'require File::Temp'; if ($@) {
die "you'll need to install File::Temp from www.cpan.org\n";
}
my ($fh, $filename) = File::Temp::tempfile(SUFFIX => '.zip');
return file2gravis($filename);
}
sub bytes2pat { my $bytes = $_[0];
my $index = 0;
my $header = substr $bytes, $index, 129; $index += 129;
my ($ID,$manufacturer,$description, $num_instrs,$num_voices,$num_channels,
$num_waveforms,$master_vol,$data_length, $reserved)
= unpack ('A12 A10 A60 C C C S S L C36', $header);
my %pat = ();
# $pat{'manufacturer'} = $manufacturer; ID#000002 is mandatory for timidity
$description =~ s/\0.*$//s;
$description =~ tr /\cZ//d;
$pat{'description'} = $description;
$pat{'num_voices'} = $num_voices;
$pat{'num_channels'} = $num_channels;
# $pat{'num_instrs'} = $num_instrs;
$pat{'instruments'} = [];
foreach (1 .. $num_instrs) {
my %instr = ();
my $instr_header = substr $bytes, $index, 63; $index += 63;
my ($instr_num, $instr_name, $instr_size, $num_layers, $reserved)
= unpack('S A16 L C A40', $instr_header);
$instr{'instr_num'} = $instr_num;
$instr_name =~ s/\0.*$//s;
$instr_name =~ tr /\cZ//d;
$instr{'instr_name'} = $instr_name;
# $instr{'instr_size'} = $instr_size; # 1.04
# $instr{'num_layers'} = $num_layers;
my @layers = ();
foreach (1 .. $num_layers) {
my $layer_header = substr $bytes, $index, 47; $index += 47;
my ($previous, $id, $size, $num_wavsamples, $reserved)
= unpack('C C L C A40', $layer_header);
my @wavsamples = ();
foreach (1 .. $num_wavsamples) {
my $wav_header = substr $bytes, $index, 96; $index += 96;
# tremolo: sweep 46, phase 43, depth 32
# vibrato: sweep 1443, ctl 818, depth 32
my ($sample_name, $fractions, $data_size, $loop_start,
$loop_end, $sample_rate, $low_freq, $high_freq, $root_freq,
$tune, $balance, $envelope_data,
$tremolo_sweep, $tremolo_phase, $tremolo_depth,
$vibrato_sweep, $vibrato_ctl, $vibrato_depth,
$mode, $scale_freq, $scale_factor) =
unpack('a7 C L L L S L L L S C a12 C6 C S S',$wav_header);
# see doc/headers.c doc/gravis.c doc/timidity/instrum.c
# 6 bytes envelope_velf and 6 bytes envelope_keyf, ?
# (or Filter envelope rate and Filter envelope offset ?)
# perhaps bytes: attack_vol attack_time decay_vol decay_time
# release_vol final_vol; then attack_freq attack_time
# decay_freq decay_time release_freq final_freq ?
# See convert_envelope_rate() and convert_envelope_offset()
$sample_name =~ s/\0.*$//s;
my $data=substr $bytes,$index,$data_size; $index+=$data_size;
push @wavsamples, {
sample_name => $sample_name,
loop_start => $loop_start,
loop_end => $loop_end,
sample_rate => $sample_rate,
low_freq => $low_freq,
high_freq => $high_freq,
root_freq => $root_freq,
tune => $tune,
balance => $balance,
envelope_data => $envelope_data,
tremolo_sweep => $tremolo_sweep,
tremolo_phase => $tremolo_phase,
tremolo_depth => $tremolo_depth,
vibrato_sweep => $vibrato_sweep,
vibrato_ctl => $vibrato_ctl,
vibrato_depth => $vibrato_depth,
mode => $mode,
scale_freq => $scale_freq,
scale_factor => $scale_factor,
# data_size => $data_size ,
data => $data,
};
}
push @layers, {
previous => $previous, id => $id,
# num_wavsamples => $num_wavsamples,
wavsamples => \@wavsamples,
};
}
$instr{'layers'} = \@layers;
push @{$pat{'instruments'}}, \%instr;
}
return %pat;
}
sub pat2bytes { my %pat = @_;
use bytes;
my @pat_data = ();
my @instruments = @{$pat{'instruments'}};
my $instr_num = 0;
my $num_waveforms = 0;
foreach my $instref (@instruments) {
my @inst_data = ();
my @layers = @{$instref->{'layers'}};
my $previous = 0; my $id = 0;
my @all_layer_data = ();
foreach my $layerref (@layers) {
my @this_layer_data = ();
my @wavsamples = @{$layerref->{'wavsamples'}};
foreach my $wref (@wavsamples) {
my $wave_size = length($wref->{'data'}); # bytes? samples?
# XXX to relate to timidity -idvv I should extract:
# tremolo: sweep 46, phase 43, depth 32
# vibrato: sweep 1443, ctl 818, depth 32
# mode: 0x65
# ? what's this ? volume comp: 1.024000
push @this_layer_data,
pack('a7 C L L L S L L L S C a12 C6 C S S C36',
$wref->{'sample_name'}, 0, $wave_size,
$wref->{'loop_start'}, $wref->{'loop_end'},
$wref->{'sample_rate'}, $wref->{'low_freq'},
$wref->{'high_freq'}, $wref->{'root_freq'}, $wref->{'tune'},
$wref->{'balance'}, $wref->{'envelope_data'},
$wref->{'tremolo_sweep'}, $wref->{'tremolo_phase'},
$wref->{'tremolo_depth'},
$wref->{'vibrato_sweep'}, $wref->{'vibrato_ctl'},
$wref->{'vibrato_depth'},
$wref->{'mode'},
$wref->{'scale_freq'}, $wref->{'scale_factor'}, 0
);
push @this_layer_data, $wref->{'data'};
$num_waveforms += 1;
}
unshift @this_layer_data, pack('C C L C A40', $previous, $id,
length(join '',@this_layer_data), scalar @wavsamples, '');
push @all_layer_data, @this_layer_data;
$previous = $id; $id += 1;
}
my $instr_size = length(join '',@all_layer_data);
my $num_layers = scalar @layers;
push @inst_data, pack('S a16 L C A40', $instr_num,
$instref->{'instr_name'}, $instr_size, $num_layers, '');
push @inst_data, @all_layer_data;
push @pat_data, @inst_data;
$instr_num += 1;
}
unshift @pat_data, pack ('a12 a10 a60 C C C S S L C36', 'GF1PATCH110',
'ID#000002', # manufacturer=ID#000002 is mandatory for timidity
$pat{'description'}, (scalar @instruments),
14, 1, $num_waveforms, 100, length(join '',@pat_data), 0);
return join '', @pat_data;
}
sub gravis2file { my $file = shift;
if (! $file) { warn "gravis2file: missing arguments.\n"; return 0; }
my %gravis = @_;
if (! %gravis) { warn "gravis2file: missing 2nd argument.\n"; return 0; }
# write bytes to file, or filehandle (if GLOB), or - is stdout
eval 'require Archive::Zip'; if ($@) {
die "you'll need to install Archive::Zip from www.cpan.org\n";
}
my @pat_names = sort keys %gravis;
my $n_pat_names = scalar @pat_names;
if (($n_pat_names != 1) && ($file =~ /\.pat/)) {
warn "can't store $n_pat_names patches in one .pat file\n"; return 0;
}
if ($file =~ /\.pat/) {
my $bytes = pat2bytes(%{$gravis{$pat_names[0]}});
if (! $bytes) { return 0; } # pat2bytes has already warned
if (! open(F, '>', $file)) { warn "can't open $file:$!\n"; return 0; }
print F $bytes; close F;
} elsif ($file =~ /\.zip/) { # 1.01
eval 'require Archive::Zip'; if ($@) {
die "you'll need to install Archive::Zip from www.cpan.org\n";
}
my $zip = Archive::Zip->new();
foreach my $pat_name (@pat_names) {
my $bytes = pat2bytes(%{$gravis{$pat_name}});
if (0 == length $bytes) { warn "gravis{$pat_name} was empty\n"; }
if ($bytes) { my $member = $zip->addString($bytes,$pat_name); }
}
if ($zip->overwriteAs($file) != 0) {
warn "can't write zipfile $file: write error\n"; return 0;
}
} else {
warn "it has to be either a .pat or a .zip file\n"; return 0;
}
return 1;
}
sub new_pat {
# See doc/timidity/instrum.[ch]
# MODES_16BIT 1 MODES_UNSIGNED 2 MODES_LOOPING 4 MODES_PINGPONG 8
# MODES_REVERSE 16 MODES_SUSTAIN 32 MODES_ENVELOPE 64 MODES_CLAMPED 128
return (
description => 'description of patch',
filename => 'filename of patch',
num_channels => 0,
num_voices => 14,
instruments => [
{
instr_name => 'instrument name',
instr_num => 'instrument number',
layers => [
{
id => 0,
previous => 0,
wavsamples => [
{
balance => 7,
data => ' ... ',
envelope_data => $DefaultEnvelopeData,
high_freq => 10000000,
loop_end => 266282,
loop_start => 149902,
low_freq => 20000,
mode => 1+4+32+64,
root_freq => 261625,
sample_name => 'name of sample',
sample_rate => 44100,
scale_factor => 1024,
scale_freq => 69,
tremolo_depth => 0,
tremolo_phase => 0,
tremolo_sweep => 0,
vibrato_depth => 0,
vibrato_ctl => 0,
vibrato_sweep => 0,
tune => 1,
}
]
},
],
},
],
);
}
sub timidity_cfg { my $file = shift; my %sf_or_gr = @_;
eval 'require File::Basename'; if ($@) {
die "you'll need to install File::Basename from www.cpan.org\n";
}
my @cfg = ('# See man timidity.cfg ...'); # array of lines
if ($sf_or_gr{'ifil'}) { # it's a sf
my ($name,$path,$suffix) = File::Basename::fileparse($file,'.sf2');
my $current_bank = -1;
push @cfg, "dir $path";
my @phdr_list = sort { (1000*$a->{'wBank'}+$a->{'wPreset'})
<=> (1000*$b->{'wBank'}+$b->{'wPreset'})} @{$sf_or_gr{'phdr'}};
foreach my $a (@phdr_list) {
my $patch = $a->{'wPreset'};
my $bank = $a->{'wBank'};
my $pname = $a->{'achPresetName'};
if ($bank != $current_bank) {
push @cfg, "bank $bank # $bank,0 cc0=$bank cc32=0";
$current_bank = $bank;
}
push @cfg, "$patch %font $name.sf2 $bank $patch # $pname";
}
} else { # it's a gr
my @patnames = sort keys %sf_or_gr;
my $bank = 0;
if (1 == scalar @patnames) {
push @cfg, "bank $bank # $bank,0 cc0=$bank cc32=0";
push @cfg, "0 /home/gravis/$patnames[0]";
} else {
push @cfg, "dir $file#";
push @cfg, "bank $bank # $bank,0 cc0=$bank cc32=0";
my @barenames = @patnames;
foreach (@barenames) { s/\.pat$//; }
my %unpaired_barename = map {$_,1} (@barenames);
eval 'require String::Approx'; if ($@) {
warn "for more appropriate patch numbers "
. "you need the String::Approx module\n";
} else {
eval 'require MIDI'; if ($@) {
warn "you need to install the MIDI-Perl module\n";
} else {
push @cfg, '# the bank 0 patches have been assigned by '
. 'approximate string matching';
push @cfg, '# to the general-midi patches; '
. "you'll probably want to edit them...";
# for each patname note the distance to each gmname
# then as long as their are patnames which are the closest
# of more than one gmname, the patname chooses the closest
# and the other(s) forget their first pref, and next;
# when there are no further contested patchnames every
# remaining first choice is fulfilled.
# any remaining patchnames are presented alphabetically.
my @suitors = ();
# $suitors[$gm_pnum] = [$barename=>$distance, ...]
my %gm_pn2barename = ();
foreach my $gm_pnum (0..127) {
my $gm_patch = $MIDI::number2patch{$gm_pnum};
my %dh; @dh{@barenames}= map { abs }
String::Approx::adistr($gm_patch, @barenames);
my @da = sort { $dh{$a} <=> $dh{$b} } @barenames;
my @da2dist = (); foreach (@da) {
push @da2dist, $_, $dh{$_};
}
$suitors[$gm_pnum] = \@da2dist;
}
# then patchnums first-pick-of-more-than-one-suitor, choose
# closest until remaining first choices can be fulfilled
my %unpaired_gm_pnum = map {$_,1} (0..127);
while (1) {
# go through the unpaired_gm_pnums seeking 1st
# .pat, and note the .pat which occurs most often
my %pat2gmtarget = (); # hash of [gm_pn,distance, ..]
my $pat_with_most_gmtargets = undef;
my $most_targets = 0;
my @unpaired_gm_pnums
= sort {0+$a<=>0+$b} keys %unpaired_gm_pnum;
if (! @unpaired_gm_pnums) { last; }
my @unpaired_barenames = sort keys %unpaired_barename;
if (! @unpaired_barenames) { last; }
foreach my $gm_pnum (@unpaired_gm_pnums) {
if ($gm_pn2barename{$gm_pnum}) { next; }
my @suitrs = @{$suitors[$gm_pnum]};
$pat2gmtarget{$suitrs[0]} += 1;
if ($pat2gmtarget{$suitrs[0]} > $most_targets) {
$pat_with_most_gmtargets = $suitrs[0];
$most_targets = $pat2gmtarget{$suitrs[0]};
}
}
if ($most_targets == 0) { last; }
if ($most_targets > 1.5) { # barename's choice!
my $closest_gm_pnum = undef;
my $closest_gm_dist = 10**30;
foreach my $gm_pnum (@unpaired_gm_pnums) {
my @suitrs = @{$suitors[$gm_pnum]};
if ($suitrs[0] eq $pat_with_most_gmtargets) {
if ($suitrs[1] < $closest_gm_dist) {
$closest_gm_pnum = $gm_pnum;
$closest_gm_dist = $suitrs[1];
}
}
}
# if (! defined $closest_gm_pnum) { last; }
$gm_pn2barename{$closest_gm_pnum}
= $pat_with_most_gmtargets;
delete $unpaired_gm_pnum{$closest_gm_pnum};
delete $unpaired_barename{$pat_with_most_gmtargets};
# chop $suitrs[0,1] off the lists of the losers
foreach my $gm_pnum (@unpaired_gm_pnums) {
while (@{$suitors[$gm_pnum]}) {
my @suitrs = @{$suitors[$gm_pnum]};
if ($unpaired_barename{$suitrs[0]}) {last;}
shift @{$suitors[$gm_pnum]};
shift @{$suitors[$gm_pnum]};
}
}
next;
}
# none left: fulfill all remaining first choices
foreach my $gm_pnum (@unpaired_gm_pnums) {
my @suitrs = @{$suitors[$gm_pnum]};
$gm_pn2barename{$gm_pnum} = $suitrs[0];
delete $unpaired_barename{$suitrs[0]};
delete $unpaired_gm_pnum{$gm_pnum};
}
}
foreach my $k (sort {$a<=>$b} keys %gm_pn2barename) {
push @cfg, "$k $gm_pn2barename{$k}.pat";
}
if (%unpaired_barename) {
$bank = 1;
push @cfg, "bank $bank # $bank,0 cc0=$bank cc32=0";
}
}
}
my $patch = 0;
foreach my $bn (sort keys %unpaired_barename) {
if ($patch >= 127) {
$bank += 1;
push @cfg, "bank $bank # $bank,0 cc0=$bank cc32=0";
$patch = 0;
}
push @cfg, "$patch $bn.pat";
$patch += 1;
}
}
}
return join("\n",@cfg,"\n"); # could detect wantarray ...
}
# ----------------------- infrastructure -----------------------------
sub zero_pad_to_even { my $str = $_[$[];
if (length($str) % 2) { return "$str\0" } else { return "$str\0\0"; }
}
sub filetype { my $f = $_[$[];
if (! open(F, $f)) { warn "can't open $f: $!\n"; return undef; }
read F, my $s, 12;
close F;
if ($s =~ /^RIFF....sfbk/) { return 'sf2'; }
if ($s =~ /^PK/) { return 'zip'; }
if ($s =~ /^GF1PATCH/) { return 'pat'; }
if ($f =~ /.sf2$/) { return 'sf2'; }
if ($f =~ /.zip$/) { return 'zip'; }
if ($f =~ /.pat$/) { return 'pat'; }
return '';
}
1;
__END__
=pod
=head1 NAME
MIDI::SoundFont - Handles .sf2 SoundFont and .pat and .zip Gravis files
=head1 SYNOPSIS
use MIDI::SoundFont();
use Data::Dumper(Dumper);
$Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1;
my %sf = MIDI::SoundFont::file2sf('doc/Jeux14.sf2');
open (P, '|-', 'less'); print P Dumper(\%sf); close P;
MIDI::SoundFont::sf2file('/tmp/Jeux15.sf2', %sf);
my %gus = MIDI::SoundFont::file2gravis('gravis/Gravis.zip');
open (P, '|-', 'less'); print P Dumper(\%gus); close P;
MIDI::SoundFont::gravis2file('/tmp/Gravis2.zip', %gus);
print MIDI::SoundFont::timidity_cfg('/home/me/Gr.zip',%gus);
print MIDI::SoundFont::timidity_cfg('/home/me/Sf.sf2',%sf);
=head1 DESCRIPTION
This module offers a Perl interface to ease the manipulation of
I<SoundFont> and I<Gravis> files.
This module loads these files into a Perl associative array
whose structure is documented in the section
IN-MEMORY SOUNDFONT FORMAT
or
IN-MEMORY GRAVIS FORMAT
below.
Nothing is exported by default,
but all the documented functions can be exported, e.g.:
use MIDI::SoundFont(file2sf, sf2file);
No functions are provided to manipulate the I<.pat>
members in a Gravis I<.zip> archive; to do this work
you should use I<Archive::Zip> directly.
Future versions should offer translation between I<Gravis> and
I<SoundFont> formats, and should also allow importing a B<.wav> snippet
into a patch by automatically detecting the optimal I<StartLoop>
and I<EndLoop> points. These features are currently unimplemented.
=head1 IN-MEMORY SOUNDFONT FORMAT
See:
perl examples/sf_list doc/Jeux14.sf2 | less
perl examples/sf_list -b 0 -p 17 -l doc/Jeux14.sf2 | less
I<file2sf($filename)> returns a hash with keys:
I<ifil>,
I<isng>,
I<INAM>,
I<irom>,
I<iver>,
I<ICRD>,
I<IENG>,
I<IPRD>,
I<ICOP>,
I<ICMT> and
I<ISFT>
which have scalar values
(see http://www.pjb.com.au/midi/sfspec21.html#i5
), and the keys:
I<phdr>
whose value is an arrayref, and
I<inst> and
I<shdr>
whose values are hashrefs.
Each item of the I<phdr> array is a B<Preset>
("Preset" is a SoundFont term which means
substantially the same as the MIDI "Patch"),
which is a hashref with the following keys:
I<achPresetName> is the Patch-name,
I<wBank> is the MIDI Bank-number,
I<wPreset> is the MIDI Patch-number
( see http://www.pjb.com.au/midi/sfspec21.html#7.2 ),
plus I<pbags> which is an arrayref.
Each I<pbag> is a hashref with the following keys:
I<modulators> which is an arrayref
( see http://www.pjb.com.au/midi/sfspec21.html#7.4 ) and
I<generators> which is a hashref
( see http://www.pjb.com.au/midi/sfspec21.html#7.5 ).
The I<generators> is where most of the action is
( see http://www.pjb.com.au/midi/sfspec21.html#8.1.3 ),
and particularly crucial is I<instrument>
which tells the Patch (i.e. Preset) which Instrument it will be using.
Each key of the I<inst> hash is an Instrument-name,
( see http://www.pjb.com.au/midi/sfspec21.html#7.6 ),
and each value is an B<Instrument>
( see http://www.pjb.com.au/midi/sfspec21.html#8.5 ),
which is a hashref with just one key:
I<ibags> whose value is an arrayref.
Each I<ibag> is a hashref with the following keys:
I<modulators> which is an arrayref
( see http://www.pjb.com.au/midi/sfspec21.html#7.8 ) and
I<generators> which is a hashref
( see http://www.pjb.com.au/midi/sfspec21.html#7.9 ).
The I<generators> is where most of the action is
( see http://www.pjb.com.au/midi/sfspec21.html#8.1.3 ),
and particularly crucial is I<sampleID>
which (at last!) tells the Instrument and hence the Preset
which B<Sample> it will be using :-)
Each item of the I<shdr> array is a B<Sample>
which is a hashref with the following keys, which all have scalar values:
I<achSampleName>,
I<dwStart>,
I<dwEnd>,
I<dwStartloop>,
I<dwEndloop>,
I<dwSampleRate>,
I<byOriginalKey>,
I<chCorrection>,
I<wSampleLink> and
I<sfSampleType>
( see http://www.pjb.com.au/midi/sfspec21.html#7.10 ),
plus I<sampledata>,
which (at last!!) contains the (16-bit signed little-endian) audio data.
The Patch-names ( I<achPresetName> ) must be unique,
the Instrument-names ( I<achInstName> ) must be unique, and
the Sample-names ( I<achSampleName> ) must be unique.
=head1 IN-MEMORY GRAVIS FORMAT
See:
perl examples/sf_list gravis/fiddle.pat | less
I<file2gravis($filename)> returns a hash with keys:
I<description>,
I<filename>,
I<num_channels>, and
I<num_voices>,
which have scalar values, and
I<instruments> whose value is an arrayref (although in practice
I've never met a patch-file with more than one instrument).
The I<instrument> is a hash with keys:
I<instr_name> and
I<instr_num>,
which have scalar values, and
I<layers> whose value is an arrayref.
Each I<layer> has keys:
I<id> and
I<previous>,
which have scalar values (apparently unused), and
I<wavsamples> whose value is an arrayref.
Each I<wavsample> is a hash with keys:
I<balance>,
I<data>,
I<envelope_data>,
I<high_freq>,
I<loop_end>,
I<loop_start>,
I<low_freq>,
I<mode>,
I<root_freq>,
I<sample_name>,
I<sample_rate>,
I<scale_factor>,
I<scale_freq>,
I<tremolo_depth>,
I<tremolo_phase>,
I<tremolo_sweep>,
I<vibrato_depth>,
I<vibrato_ctl>,
I<vibrato_sweep> and
I<tune>,
which have scalar values.
Unlike the SoundFont format,
the frequencies I<low_freq>, I<high_freq> and I<root_freq>
are in thousandths of a Hz,
and the I<loop_start> and I<loop_end> are in bytes, not samples.
The I<mode> bits describes the format of the I<data>,
and the following package variables can be imported with
I<use MIDI::SoundFont(':CONSTS');>
MODES_16BIT=1 MODES_UNSIGNED=2 MODES_LOOPING=4 MODES_PINGPONG=8
MODES_REVERSE=16 MODES_SUSTAIN=32 MODES_ENVELOPE=64 MODES_CLAMPED=128
See:
I<doc/gravis.txt>
I<doc/headers.c>
I<doc/timidity/instrum.c>
I<doc/timidity/instrum.h>
I<doc/timidity/playmidi.c>
I<doc/wav2pat.c> and
I<ftp://ftp.gravis.com/Public/Sdk/>
for more details of what the values mean.
The tremolo and vibrato data displayed by
B<timidity -idvv -x 'bank 0\n0 ./gravis/fiddle.pat'>
are different from the values of the tremolo and vibrato variables above,
because the I<timidity> variables have been multiplied by corresponding
control ratios: see I<doc/timidity/instrum.c>
See:
I<test.pl>,
I<examples/make_bank5> and
I<examples/sf_list> for examples manipulating this data-structure.
=head1 SOUNDFONT FILE-FORMAT
Fortunately, there exists authoritative and clear documentation
of the SoundFont file format:
http://connect.creativelabs.com/developer/SoundFont/sfspec21.pdf
Unfortunately, it's a fairly hard format to work with...
A SoundFont-2 compatible RIFF file comprises three chunks:
an INFO-list chunk containing a number of required and optional sub-chunks
describing the file, its history, and its intended use, see
http://www.pjb.com.au/midi/sfspec21.html#i5
an SDTA-list chunk comprising a single sub-chunk containing any
referenced digital audio samples, see
http://www.pjb.com.au/midi/sfspec21.html#i6
and a PDTA-list chunk containing nine sub-chunks which define
the articulation of the digital audio data, see
http://www.pjb.com.au/midi/sfspec21.html#i7
=head1 GRAVIS FILE-FORMAT
The files I<doc/gravis.txt>, I<doc/headers.c> and I<doc/wav2pat.c>
disagree somewhat about the file format.
Most authoritative is the TiMidity source in I<doc/timidity/>,
but it's also somewhat hard to interpret.
The format adopted here seems to work with all patches in I<gravis/Gravis.zip>
Several of the parameters seem obscure: for example,
I<num_channels> is often zero, when it should be either 1 or 2,
and I<instr_num> is either zero or, in non-Gravis patches, usually random.
In the I<wavsample> section, I<low_freq> and I<high_freq> seem large
(perhaps in thousandths of Hz? See:
I<ftp://ftp.gravis.com/Public/Sdk/PATCHKIT.ZIP>).
These are the parameters that must correspond to the SoundFont I<key range>,
allowing different wavsamples to be used for different tessituras.
See:
perl examples/sf_list gravis/fiddle.pat | less
=head1 FUNCTIONS
=over 3
=item %sf = file2sf($filename)
Reads the file, which should be a SoundFont file, and converts it
to the data-structure documented above in the
IN-MEMORY SOUNDFONT FORMAT
section.
The I<filename> can also be a URL, or B<-> meaning I<STDIN>
=item sf2file($filename, %soundfont)
Converts a data-structure as documented above in the
IN-MEMORY SOUNDFONT FORMAT
section into a file as documented in the
SOUNDFONT FILE-FORMAT
section.
=item %sf = new_sf($inam)
Returns a minimal empty soundfont data-structure as documented above in the
IN-MEMORY SOUNDFONT FORMAT section.
The optional argument I<$inam> sets the 'INAM' value.
You can then change I<$sf{'INAM'}> and I<$sf{'phdr'}[0]{'wPreset'}>
or push onto I<@{$sf{'phdr'}}> and so on.
See I<examples/make_bank5> in the I<examples/> directory.
=item %gr = file2gravis($filename)
Reads the file, which should be either a Gravis B<.pat> patch-file,
or a B<.zip> archive of patch-files, and converts it to the
data-structure documented above in the IN-MEMORY GRAVIS FORMAT section.
The I<filename> can also be a URL, or B<-> meaning I<STDIN>
=item gravis2file($filename, %gravis)
Converts a data-structure as documented above in the
IN-MEMORY GRAVIS FORMAT
section either into a B<.pat> patch-file as documented in the
GRAVIS FILE-FORMAT section,
or into a B<.zip> archive of patch-files.
=item %sf = new_pat()
Returns a minimal empty I<patch> data-structure;
the reference to this is a I<value> in the gravis data-structure
documented above in the IN-MEMORY GRAVIS FORMAT section,
the I<key> being the filename it will get when given a home in a I<.zip> file.
See I<examples/make_bank5> in the I<examples/> directory.
=item timidity_cfg($filename, %sf_or_gravis)
This returns a suggested I<timidity.cfg> paragraph to
allow you to use your soundfont, or gravis patch or zip, in I<timidity>.
The B<filename> is the I<.sf2> or I<.pat> or I<.zip> file
in which it resides, or will reside.
You should insert the resulting string into your I<timidity.cfg> by hand,
using your favourite text editor,
because there are bound to be things you'll want to change.
For Gravis I<.zip> archives, the I<String::Approx> module
is used to guess some General-Midi-conformant patch-numbers.
=back
=head1 EXAMPLES
Five simple examples in the I<examples/> subdirectory
are already useful applications:
=over 3
=item sf_list
I<sf_list> displays, in a readable format, a list of
the Patches available in a .sf2 SoundFont file, or in a Gravis .zip archive,
or the contents of a Gravis .pat patch-file.
It displays the Patches in a readable format, e.g.:
bank 8 patch 17 # Detuned Organ 2
It also has options B<-l> for long, detailed output,
and B<-b> and B<-p> to restrict the choice to particular Banks and Patches,
and a B<-c> option to suggest a paragraph for your I<timidity.cfg>
=item sf_edit
I<sf_edit> is a I<Term::Clui> application which allows certain simple
operations such as moving Banks, deleting Patches.
=item make_bank5
I<make_bank5> puts together a I<SoundFont> file from scratch, using some
simple waveforms, and then puts together some substantially identical
I<Gravis> patches.
These files can be used successfully both by I<timidity> and by I<csound>,
which is a reasonable test of
MIDI::SoundFont's conformance to the file-formats.
See:
http://www.pjb.com.au/midi/free/Bank5.sf2
http://www.pjb.com.au/midi/free/SawtoothToTriangle.pat
and
http://www.pjb.com.au/midi/free/SquareToSine.pat
=item csound_scoresynth.csd
I<csound_scoresynth.csd> evolves from the script
explained on page 148 of the book I<Csound Power> by Jim Aikin.
It shows how to load a SoundFont into I<csound> and play its notes
directly from the I<Score> section of the I<.csd> file.
It assumes you have run I<make_bank5>,
so that the SoundFont I</tmp/Bank5.sf2> already exists.
=item csound_midisynth.csd
I<csound_midisynth.csd> evolves from the script I<fluidcomplex.csd>
by Istvan Varga, as included in the I<csound> documentation.
It shows how to load a SoundFont into I<csound>
and play its notes using a midi keyboard,
which you will have to connect by hand
using some command such as I<aconnect ProKeys 14:0>
It assumes you have run I<make_bank5>,
so that the SoundFont I</tmp/Bank5.sf2> already exists.
=back
=head1 DOWNLOAD
This module is available from CPAN at
http://search.cpan.org/perldoc?MIDI::SoundFont
=head1 AUTHOR
Peter J Billam, http://www.pjb.com.au/comp/contact.html
=head1 SEE ALSO
http://search.cpan.org/perldoc?MIDI::SoundFont
http://search.cpan.org/perldoc?File::Format::RIFF
http://search.cpan.org/perldoc?File::Format::RIFF::Container
http://search.cpan.org/perldoc?Archive::Zip
http://search.cpan.org/perldoc?File::Temp
http://search.cpan.org/perldoc?String::Approx
http://connect.creativelabs.com/developer/SoundFont/sfspec21.pdf
http://www.pjb.com.au/midi/sfspec21.html
http://www.onicos.com/staff/iz/timidity/dist/tools-1.1.0/wav2pat.c
http://timidity.sourceforge.net
ftp://ftp.gravis.com/Public/Sdk/
http://www.csounds.com/manual/html/fluidEngine.html
http://www.csounds.com/manual/html/fluidNote.html
http://www.csounds.com/manual/html/fluidLoad.html
"Csound Power" by Jim Aikin, Course Technology, Cengage Learning, 2013,
ISBN-13 978-1-4354-6004-1
ISBN-10 1-4354-6004-9
man timidity - (1) MIDI-to-WAVE converter and player
man timidity.cfg - (5) configure file of TiMidity++
=cut