transpun.txt

Subiect: transpun.txt 14th Decembrie 2010, 1:02 pm

aici e un inceput de program de transpus cantece.
nu e gata.
e in pascal
si e tare.

Cod:: program transpune;
var a:array[1..24] of string[2];
n,m:string[2];
n1,n2:1..24;
f,g:text;
s:string;
c:integer;

function intchord(n:string):byte; {de la 1 la 12
al catelea semiton de la C=1}
var i:integer;
begin
for i:=1 to 24 do
if a[i]=n then begin
intchord:=(i+i mod 2)div 2;
break
end;
end;

function chordint(acord:integer;poz:byte):char;
{a poz-a litera din acord. Db, Eb, F#, Ab, Bb se folosesc}

begin
if poz=1 then
case acord of
1:chordint:='C';
2..3:chordint:='D';
4..5:chordint:='E';
6..7:chordint:='F';
8:chordint:='G';
9..10:chordint:='A';
11..12:chordint:='B';
end;
if poz=2 then
case acord of
1:;
2:chordint:='b';
3:;
4:chordint:='b';
5:;
6:;
7:chordint:='#';
8:;
9:chordint:='b';
10:;
11:chordint:='b';
12:;
end;
end;

procedure init;
begin
{2k-1, 2k sunt al k-lea semiton}
{init vectorul a cu acorduri de la C la B}
a[1]:='B#';a[2]:='C';a[3]:='C#';a[4]:='Db';a[5]:='D';a[6]:='D';
a[7]:='D#';a[8]:='Eb';a[9]:='E';a[10]:='Fb';a[11]:='E#';a[12]:='F';
a[13]:='F#';a[14]:='Gb';a[15]:='G';a[16]:='G';a[17]:='G#';a[18]:='Ab';
a[19]:='A';a[20]:='A';a[21]:='A#';a[22]:='Bb';a[23]:='B';a[24]:='Cb';
end;

procedure transp(var s:string);
var acord,acordleninit,p,ult:integer;
gasit:boolean;
acordstr:string[2];
i:integer;
begin
ult:=1;
writeln('stringul nostru este...');
writeln(s);
repeat
{primul acord din rand apoi urm pana la ultimul}
for i:=length(s) downto ult do
if(s[i]<>' ')and(s[i]<>'/')and(s[i]<>'|')and(s[i]<>'') then
begin
p:=i;
end;
{p este poz ultimului caracter nenul gasit}
gasit:=false;

for i:=1 to 24 do
if copy(s,p,2)=a[i] then begin
acord:=intchord(copy(s,p,2));
gasit:=true;

end;
if not gasit then
for i:=1 to 24 do
if copy(s,p,1)=a[i] then begin
acord:=intchord(copy(s,p,1));
gasit:=true;

end;
{acord e acordul gasit}
{e acordul absolut. acum cautam sa il facem relativ}
if gasit then begin
acordleninit:=1;
if (chordint(acord,2)='b') or(chordint(acord,2)='#') then
inc(acordleninit);
writeln('acordleninit e ',acordleninit);
acord:=acord+(n2-n1);
writeln('acord e ',acord);
if acord>12 then acord:=acord-12;
if acord<1 then acord:=acord+12;
writeln('acord e ',acord);
if (chordint(acord,2)='b') or (chordint(acord,2)='#') then
acordstr:=chordint(acord,1)+chordint(acord,2)
else acordstr:=chordint(acord,1);
s:=copy(s,1,p-1)+acordstr+copy(s,p+acordleninit,length(s));
writeln('s e ',s);
ult:=p+acordleninit;
writeln('ult e ',ult);
end
else ult:=ult+1;
until ult>=length(s);
writeln('am iesit din procedura transpun');
end;

begin
init;
readln(n);
readln(m);
n1:=intchord(n);
n2:=intchord(m);
assign(f,'transpun.txt');
assign(g,'tout.txt');
rewrite(g);
reset(f);
writeln('am inceput sa cautam in f');

c:=0;
for c:=1 to 1 do begin
readln(f,s);
writeln('am intrat de ',c,' ori in for');
transp(s);
writeln(g,s);
writeln(s);
end;
close(f);
close(g);
readln;
end.

inca nu merge foarte bine, am schimbat sa incerce doar o linie, si nu merge pentru E# sau Fb sau din ce imi inchipui si pentru B# sau Cb

scratch

Vizitator

iata varianta finala in cod pascal
as vrea sa includ si un fisier exe dar nu stiu unde sa il uploadez

Cod:: program transpune;
{autor HHH}
var a:array[1..24] of string[2];
n,m:string[2];
n1,n2:1..24;
f,g:text;
s:string;
verscuacorduri:boolean;

function intchord(n:string):byte; {de la 1 la 12
al catelea semiton de la C=1}
var i:integer;
begin
for i:=1 to 24 do
if a[i]=n then begin
intchord:=(i+i mod 2)div 2;
break
end;
end;

function chordint(acord:integer;poz:byte):char;
{a poz-a litera din acord. Db, Eb, F#, Ab, Bb se folosesc}

begin
if poz=1 then
case acord of
1:chordint:='C';
2..3:chordint:='D';
4..5:chordint:='E';
6..7:chordint:='F';
8:chordint:='G';
9..10:chordint:='A';
11..12:chordint:='B';
end;
if poz=2 then
case acord of
1:;
2:chordint:='b';
3:;
4:chordint:='b';
5:;
6:;
7:chordint:='#';
8:;
9:chordint:='b';
10:;
11:chordint:='b';
12:;
end;
end;

procedure init;
begin
{2k-1, 2k sunt al k-lea semiton}
{init vectorul a cu acorduri de la C la B}
a[1]:='B#';a[2]:='C';a[3]:='C#';a[4]:='Db';a[5]:='D';a[6]:='D';
a[7]:='D#';a[8]:='Eb';a[9]:='Fb';a[10]:='E';a[11]:='F';a[12]:='E#';
a[13]:='F#';a[14]:='Gb';a[15]:='G';a[16]:='G';a[17]:='G#';a[18]:='Ab';
a[19]:='A';a[20]:='A';a[21]:='A#';a[22]:='Bb';a[23]:='B';a[24]:='Cb';
end;

procedure transp(var s:string);
var acord,acordleninit,p,ult:integer;
gasit:boolean;
acordstr:string[2];
i:integer;
begin
ult:=1;
repeat
{primul acord din rand apoi urm pana la ultimul}
for i:=length(s) downto ult do
if(s[i]<>' ')and(s[i]<>'/')and(s[i]<>'|')and(s[i]<>'')and(s[i]<>'(')
and(s[i]<>')')and (s[i-2]<>'N')then
begin
p:=i;
end;
{p este poz ultimului caracter nenul gasit}
gasit:=false;

for i:=1 to 24 do
if copy(s,p,2)=a[i] then begin
acord:=intchord(copy(s,p,2));
gasit:=true;

end;
if not gasit then
for i:=1 to 24 do
if copy(s,p,1)=a[i] then begin
acord:=intchord(copy(s,p,1));
gasit:=true;

end;
{acord e acordul gasit}
{e acordul absolut. acum cautam sa il facem relativ}
if gasit then begin
acordleninit:=1;
if (chordint(acord,2)='b') or(chordint(acord,2)='#') then
inc(acordleninit);
acord:=acord+(n2-n1);
if acord>12 then acord:=acord-12;
if acord<1 then{autor HHH} acord:=acord+12;
if (chordint(acord,2)='b') or (chordint(acord,2)='#') then
acordstr:=chordint(acord,1)+chordint(acord,2)
else acordstr:=chordint(acord,1);
s:=copy(s,1,p-1)+acordstr+copy(s,p+acordleninit,length(s));
ult:=p+acordleninit;
end
else ult:=ult+1;
until ult>=length(s);
end;

begin
init;
readln(n);
readln(m);
n1:=intchord(n);
n2:=intchord(m);
assign(f,'transpun.txt');
assign(g,'tout.txt');
rewrite(g);
reset(f);

verscuacorduri:=false;
while not eof(f) do begin
readln(f,s);
if s<>'' then begin
if verscuacorduri then transp(s);
verscuacorduri:=not verscuacorduri;
end;
writeln(g,s);
writeln(s);
end;
close(f);
close(g);
readln;
end.

succes la muzica oameni!

Subiect: Re: transpun.txt 20th Ianuarie 2011, 10:45 am

http://www.fileshare.ro/14491424646.1

Subiect: Re: transpun.txt 24th Ianuarie 2011, 7:32 am

varianta 2 ce va fi upgradata din timp in timp
(varianta 1 are un mic bug la care nu i-am gasit sensul dar pe care l-am reparat, din cate se pare.

Cod:: program transpune2;
{varianta asta calculeaza care ar fi gama cea mai usoara pentru cantare
da primele 3 rezultate in ordinea dificultatii de la usor la greu
punctele fiecarui acord se afla in fisierul text 'transp2.ini'}
{autor HHH}
var a:array[1..24] of string[2];
n,m:string[2];
n1,n2:1..24;
f,g:text;
s:string;
verscuacorduri:boolean;

function intchord(n:string):byte; {de la 1 la 12
al catelea semiton de la C=1}
var i:integer;
begin
for i:=1 to 24 do
if a[i]=n then begin
intchord:=(i+i mod 2)div 2;
break
end;
end;

function chordint(acord:integer;poz:byte):char;
{a poz-a litera din acord. Db, Eb, F#, Ab, Bb se folosesc}

begin
if poz=1 then
case acord of
1:chordint:='C';
2..3:chordint:='D';
4..5:chordint:='E';
6..7:chordint:='F';
8:chordint:='G';
9..10:chordint:='A';
11..12:chordint:='B';
end;
if poz=2 then
case acord of
1:;
2:chordint:='b';
3:;
4:chordint:='b';
5:;
6:;
7:chordint:='#';
8:;
9:chordint:='b';
10:;
11:chordint:='b';
12:;
end;
end;

procedure init;
begin
{2k-1, 2k sunt al k-lea semiton}
{init vectorul a cu acorduri de la C la B}
a[1]:='B#';a[2]:='C';a[3]:='C#';a[4]:='Db';a[5]:='D';a[6]:='D';
a[7]:='D#';a[8]:='Eb';a[9]:='Fb';a[10]:='E';a[11]:='F';a[12]:='E#';
a[13]:='F#';a[14]:='Gb';a[15]:='G';a[16]:='G';a[17]:='G#';a[18]:='Ab';
a[19]:='A';a[20]:='A';a[21]:='A#';a[22]:='Bb';a[23]:='B';a[24]:='Cb';
end;

procedure transp(var s:string);
var acord,acordleninit,p,ult:integer;
gasit:boolean;
acordstr:string[2];
i:integer;
begin
ult:=1;
repeat
p:=length(s);
{primul acord din rand apoi urm pana la ultimul}
for i:=length(s) downto ult do begin
if(s[i]<>' ')and(s[i]<>'/')and(s[i]<>'|')and(s[i]<>'')and(s[i]<>'(')
and(s[i]<>')')and(s[i-2]<>'N')then
begin
p:=i;
end;
end;
ult:=p;
{p este poz ultimului caracter nenul gasit}
gasit:=false;

for i:=1 to 24 do
if copy(s,p,2)=a[i] then begin
acord:=intchord(copy(s,p,2));
gasit:=true;
end;
if not gasit then
for i:=1 to 24 do
if copy(s,p,1)=a[i] then begin
acord:=intchord(copy(s,p,1));
gasit:=true;
end;
{acord e acordul gasit}
{e acordul absolut. acum cautam sa il facem relativ}
if gasit then begin
acordleninit:=1;
if (chordint(acord,2)='b') or(chordint(acord,2)='#') then
inc(acordleninit);
acord:=acord+(n2-n1);
if acord>12 then acord:=acord-12;
if acord<1 then{autor HHH} acord:=acord+12;
if (chordint(acord,2)='b') or (chordint(acord,2)='#') then
acordstr:=chordint(acord,1)+chordint(acord,2)
else acordstr:=chordint(acord,1);
s:=copy(s,1,p-1)+acordstr+copy(s,p+acordleninit,length(s));
ult:=ult+acordleninit;
end
else ult:=ult+1;
until ult>=length(s);
end;

begin
init;
readln(n);
readln(m);
n1:=intchord(n);
n2:=intchord(m);
assign(f,'transpun.txt');
assign(g,'tout.txt');
rewrite(g);
reset(f);

verscuacorduri:=false;
while not eof(f) do begin
readln(f,s);
if s<>'' then begin
if verscuacorduri then transp(s);
verscuacorduri:=not verscuacorduri;
end;
writeln(g,s);
writeln(s);
end;
close(f);
close(g);
readln;
end.