Forum of Horatiu Roman - Enjoy
 
AcasaAcasa  CalendarCalendar  FAQFAQ  CautareCautare  InregistrareInregistrare  MembriMembri  GrupuriGrupuri  Harta vizitatorilorHarta vizitatorilor  Conectare  
Conectare
Utilizator:
Parola:
Conectare automata: 
:: Mi-am uitat parola
Cautare
 
 

Rezultate pe:
 
Rechercher Cautare avansata
Ultimele subiecte
» pacat ca acest forum nu mai este activ
Scris de crr_ro 12th Septembrie 2016, 3:42 pm

» CULOAREA VIETII
Scris de EUGEN 19th Iunie 2012, 3:43 pm

» Povestea lui Iov
Scris de Genesis 7th Aprilie 2011, 8:50 am

» transpun.txt
Scris de Horace 24th Ianuarie 2011, 7:32 am

» MAZEGAME
Scris de Horace 2nd Iunie 2010, 1:31 pm

» nebunie
Scris de Vizitator 24th Februarie 2010, 8:50 am

Cine este conectat?
In total este 1 utilizator conectat: 0 Inregistrati, 0 Invizibil si 1 Vizitator

Nici unul

Recordul de utilizatori conectati a fost de 13, 5th Iunie 2009, 12:33 am
Statistici
Avem 57 membri inregistrati
Cel mai nou utilizator inregistrat este: alinatim

Membrii nostri au postat un numar de 1064 mesaje în 108 subiecte

Distribuiți | 
 

 transpun.txt

Vezi subiectul anterior Vezi subiectul urmator In jos 
AutorMesaj
Horace
Admin
Admin
avatar

masculin Numarul mesajelor : 298
Varsta : 24
Muzica : psihedelica
Reputatie : 10
Data de inscriere : 12/05/2007

MesajSubiect: 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 Suspect cyclops Twisted Evil geek afro

_________________
de obicei nu am dreptate. dovedeste!
Sus In jos
Vezi profilul utilizatorului http://horacehomepage.great-forum.com
tot io-s
Vizitator



MesajSubiect: Am terminat programul!   20th Ianuarie 2011, 10:31 am

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!
Sus In jos
Horace
Admin
Admin
avatar

masculin Numarul mesajelor : 298
Varsta : 24
Muzica : psihedelica
Reputatie : 10
Data de inscriere : 12/05/2007

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


_________________
de obicei nu am dreptate. dovedeste!
Sus In jos
Vezi profilul utilizatorului http://horacehomepage.great-forum.com
Horace
Admin
Admin
avatar

masculin Numarul mesajelor : 298
Varsta : 24
Muzica : psihedelica
Reputatie : 10
Data de inscriere : 12/05/2007

MesajSubiect: 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.


_________________
de obicei nu am dreptate. dovedeste!


Ultima editare efectuata de catre Horace in 25th Ianuarie 2011, 5:21 pm, editata de 1 ori (Motiv : update)
Sus In jos
Vezi profilul utilizatorului http://horacehomepage.great-forum.com
Continut sponsorizat




MesajSubiect: Re: transpun.txt   

Sus In jos
 
transpun.txt
Vezi subiectul anterior Vezi subiectul urmator Sus 
Pagina 1 din 1

Permisiunile acestui forum:Nu puteti raspunde la subiectele acestui forum
Forum || Horace Homepage :: Discutii :: Informatica si calculatoare-
Mergi direct la: