home *** CD-ROM | disk | FTP | other *** search
/ Current Shareware 1994 January / SHAR194.ISO / sounds / sam2far2.zip / SAM2FAR.PAS < prev   
Pascal/Delphi Source File  |  1993-09-02  |  4KB  |  215 lines
  1. Program sam2far;
  2.  
  3. uses crt;
  4.  
  5. type
  6.  memblk=array [1..64000] of byte;
  7.  fsm=record
  8.       magic:array[1..4] of byte;
  9.       name:array[1..32] of char;
  10.       nums:array[1..3] of byte;
  11.       len:longint;
  12.       finetune:byte;
  13.       volume:byte;
  14.       RepeatStart:longint;
  15.       RepeatEnd:longint;
  16.       SampleType:byte;
  17.       loopingmode:byte;
  18.      end;
  19.  
  20. var
  21.  header:fsm;
  22.  fin,fout:file;
  23.  i,i2:integer;
  24.  b:byte;
  25.  s1,s2,str:string;
  26.  work:string[32];
  27.  cnt,finish:longint;
  28.  me:^memblk;
  29.  
  30.  
  31. procedure stext(c,b:integer);
  32.  begin
  33.   textcolor(c);
  34.   textbackground(b);
  35.  end;
  36.  
  37. function fileexists(fname:string):boolean;
  38. var
  39.  f:file of byte;
  40.  
  41.  begin
  42.    assign(f,fname);
  43.    {$I-}
  44.    reset(f);
  45.    {$I+}
  46.    if ioresult=0 then
  47.     begin
  48.      close(f);
  49.      fileexists:=true;
  50.     end
  51.    else
  52.     fileexists:=false;
  53.  end;
  54.  
  55. function itos (num:longint):string;
  56. var i:longint;
  57.     s:string;
  58. begin
  59.    s:='';
  60.    if num=0 then
  61.      s:='0'
  62.    else
  63.      while num<>0 do
  64.        begin
  65.         i:=num mod 10;
  66.         i:=i+48;
  67.         num:=num div 10;
  68.         s:=concat(chr(i),s);
  69.        end;
  70.    itos:=s;
  71. end;
  72.  
  73.  
  74. procedure initheader;
  75. var
  76.  i:integer;
  77.  begin
  78.   with header do
  79.     begin
  80.      work:='FSM■';
  81.      move(work[1],magic,4);
  82.      for i:=1 to 32 do
  83.       name[i]:=' ';
  84.      nums[1]:=10;
  85.      nums[2]:=13;
  86.      nums[3]:=26;
  87.      len:=finish-1;
  88.      finetune:=0;
  89.      volume:=0;
  90.      repeatstart:=0;
  91.      repeatend:=finish-1;
  92.      sampletype:=0;
  93.      loopingmode:=1;
  94.     end;
  95.  end;
  96.  
  97. function filesiz(str:string):longint;
  98. var
  99.  f:file of byte;
  100.  l:longint;
  101.  
  102.  begin
  103.   assign(f,str);
  104.   {$I-}
  105.   reset(f);
  106.   {$I+}
  107.   if ioresult=0 then
  108.    begin
  109.     l:=filesize(f);
  110.     close(f);
  111.    end
  112.   else
  113.    l:=0;
  114.   filesiz:=l;
  115.  end;
  116.  
  117.  begin
  118.   new(me);
  119.   if paramcount=2 then
  120.    begin
  121.     s1:=paramstr(1);
  122.     s2:=paramstr(2);
  123.     for i:=1 to length(s1) do
  124.      s1[i]:=upcase(s1[i]);
  125.     for i:=1 to length(s2) do
  126.      s2[i]:=upcase(s2[i]);
  127.    end;
  128.   if (paramcount=2) and fileexists(s1) then
  129.    begin
  130.     cnt:=1;
  131.     finish:=filesiz(s1);
  132.     initheader;
  133.     assign(fin,s1);
  134.     reset(fin,1);
  135.     blockread(fin,me^[1],finish);
  136.     close(fin);
  137.     writeln;
  138.     stext(14,0);
  139.     writeln('SAM to USM Sample Converter');
  140.     writeln('  For Farandole Composer');
  141.     writeln;
  142.     stext(1,0);
  143.     Write(' ORIGINAL FILE: ');
  144.     stext(15,0);
  145.     writeln(s1);
  146.     stext(1,0);
  147.     WRITE('CONVERTED FILE: ');
  148.     stext(15,0);
  149.     write(s2);
  150.     stext(7,0);
  151.     writeln;
  152.     writeln;
  153.     stext(1,0);
  154.     write('   Filesize: ');
  155.     stext(15,0);
  156.     write(finish);
  157.     stext(1,0);
  158.     writeln(' Bytes');
  159.     stext(1,0);
  160.     write('   Complete:       Bytes');
  161.     for i:=1 to 5 do
  162.      write(chr(8));
  163.     while (cnt<=finish) do
  164.       begin
  165.         me^[cnt]:=(me^[cnt]+128) mod 256;
  166.         cnt:=cnt+1;
  167.         str:=itos(cnt);
  168.         if ((cnt mod 100)=0) then
  169.          begin
  170.            while length(str)<6 do
  171.              str:=str+' ';
  172.            for i:=1 to 6 do
  173.              write(chr(8));
  174.            stext(15,0);
  175.            write(str);
  176.            stext(0,0);
  177.          end;
  178.       end;
  179.     str:=itos(cnt-1);
  180.     while length(str)<6 do
  181.       str:=str+' ';
  182.     for i:=1 to 6 do
  183.       write(chr(8));
  184.     stext(15,0);
  185.     write(str);
  186.     stext(7,0);
  187.     writeln;
  188.     writeln;
  189.  {   write('Internal File Desc: ');
  190.     stext(15,1);
  191.     for i:=1 to 32 do
  192.      write(' ');
  193.     for i:=1 to 32 do
  194.      write(chr(8));
  195.     readln(work);
  196.     stext(7,0);
  197.     for i:=1 to length(work) do
  198.      header.name[i]:=work[i];}
  199.     assign(fout,s2);
  200.     rewrite(fout,1);
  201. {    blockwrite(fout,header,55);}
  202.     blockwrite(fout,me^[1],finish);
  203.     close(fout);
  204.     writeln;
  205.     writeln;
  206.     dispose(me);
  207.    end
  208.   else
  209.    begin
  210.     if not(fileexists(s1)) then
  211.       write('Could Not Open Input File')
  212.     else
  213.      write('FORMAT: sam2far <infilename> <outfilename>');
  214.    end;
  215.  end.