home *** CD-ROM | disk | FTP | other *** search
/ AMIGA PD 1 / AMIGA-PD-1.iso / Programme_zum_Heft / Programmieren / Kurztests / PascalPCQ / Examples / Play8.p < prev    next >
Text File  |  1990-07-20  |  7KB  |  267 lines
  1. Program Play8;
  2.  
  3. {
  4.     Play8.p
  5.  
  6.     Play a one-shot 8SVX IFF sound file.  The command line is simply
  7.     Play8 filename, where the filename is any path and must be
  8.     present.  This code was derived from Eric Jacobsen's spIFF.c.
  9.     The differences between this and spIFF.c:
  10.        a) This was translated from C to Pascal
  11.        b) Several sound files in my collection had odd-length
  12.         name or annotation fields.  That is, the field lengths
  13.         in the file were odd, but the actual data was padded
  14.         with an extra 0 byte.  So this program handles that.
  15.        c) I added decompression routines taken from an old IFF
  16.         documentation disk.  I couldn't find any properly
  17.         formatted compressed sound files, however, so I'm not
  18.         sure if the decompression is accurate.  The program
  19.         will certainly try to decompress files, but mine came
  20.         out garbage.  Based on the samples I've accumulated,
  21.         it seems that few of them are compressed anyway.
  22.  
  23.     In my distribution, I included a sample sample, as it were,
  24.     called UseTheForce.8SVX, which obviously came from Star Wars.
  25. }
  26.  
  27. {$I "Include:Devices/Audio.i"}
  28. {$I "Include:Exec/IO.i"}
  29. {$I "Include:Utils/IOUtils.i"}
  30. {$I "Include:Libraries/DOS.i"}
  31. {$I "Include:Utils/StringLib.i"}
  32. {$I "Include:Utils/Parameters.i"}
  33. {$I "Include:Exec/Memory.i"}
  34. {$I "Include:Exec/Devices.i"}
  35.  
  36. type
  37.     Voice8Header = record
  38.     oneShotHiSamples,
  39.     repeatHiSamples,
  40.     samplesPreHiCycle : Integer;
  41.     samplesPerSec : Short;
  42.     ctOctave    : Byte;
  43.     sCompression    : Byte;
  44.     volume : Integer;
  45.     end;
  46.  
  47. type
  48.     FibTable = Array [0..15] of Byte;
  49.  
  50. const
  51.     ckname    : String = Nil;
  52.     NoMem    : String = "\nNot enough memory.\n";
  53.     reps    : Integer = 1;
  54.     wrt_flg    : Boolean = True;
  55.     ioa        : IOAudioPtr = Nil;
  56.     dbuf    : Address = Nil;
  57.     FP        : FileHandle = Nil;
  58.     codeToDelta    : FibTable = (-34, -21, -13, -8, -5, -3, -2, -1, 0,
  59.                 1, 2, 3, 5, 8, 13, 21);
  60.  
  61. var
  62.     VHeader    : Voice8Header;
  63.     chan    : Char;
  64.     s, ps    : String;
  65.     dlen, oerr,
  66.     i        : Integer;
  67.     chnk    : ^Integer;
  68.     ckbuffer    : Array [0..2] of Short;
  69.     t        : Address;
  70.  
  71. Function D1Unpack(source : String; n : Integer; dest : String; x : Byte) : Byte;
  72. var
  73.     d : Byte;
  74.     i, lim : Integer;
  75. begin
  76.     lim := n shl 1;
  77.     for i := 0 to lim - 1 do begin
  78.     d := Ord(Source[i shr 1]);
  79.     if Odd(i) then
  80.         d := d and 15
  81.     else
  82.         d := d shr 4;
  83.     x := x + codeToDelta[d];
  84.     dest[i] := Chr(x);
  85.     end;
  86.     D1Unpack := x;
  87. end;
  88.  
  89. Procedure DUnpack(source : String; n : Integer; dest : Address);
  90. var
  91.     x : Byte;
  92. begin
  93.     x := D1Unpack(Adr(source[1]), n - 2, dest, Ord(source[0]));
  94. end;
  95.  
  96. Procedure OpenFile;
  97. var
  98.     NameBuffer : Array [0..127] of char;
  99.     Name : String;
  100. begin
  101.     Name := Adr(NameBuffer);
  102.     GetParam(1, Name);
  103.     if strlen(Name) = 0 then begin
  104.     Writeln('Usage: Play8 filename');
  105.     Exit(10);
  106.     end;
  107.     FP := DOSOpen(Name, MODE_OLDFILE);
  108.     if FP = Nil then begin
  109.     Writeln('Could not open ', Name);
  110.     Exit(10);
  111.     end;
  112. end;
  113.  
  114. procedure CleanUp;
  115. begin
  116.     if ioa <> Nil then begin
  117.     with ioa^.ioa_Request.io_Message do begin
  118.         if mn_ReplyPort <> Nil then
  119.         DeletePort(mn_ReplyPort);
  120.     end;
  121.     FreeMem(ioa, SizeOf(IOAudio));
  122.     end;
  123.     if dbuf <> Nil then
  124.     FreeMem(dbuf, dlen);
  125.     if FP <> nil then
  126.     DOSClose(FP);
  127. end;
  128.  
  129.  
  130. Procedure pExit(Msg : String);
  131. begin
  132.     Writeln(Msg);
  133.     CleanUp;
  134.     Exit(20);
  135. end;
  136.  
  137. Procedure DoRead(Buffer : Address; Length : Integer);
  138. var
  139.     ReadResult : Integer;
  140. begin
  141.     ReadResult := DOSRead(FP, Buffer, Length);
  142.     if ReadResult <> Length then
  143.     pExit("Read error");
  144. end;
  145.  
  146. Procedure WriteData(len : Integer);
  147. var
  148.     MBuffer : Array [0..127] of Char;
  149.     MString : String;
  150. begin
  151.     MString := Adr(MBuffer);
  152.     if Odd(len) then
  153.     len := Succ(len);
  154.     MBuffer[127] := '\0';
  155.     while len > 127 do begin
  156.     DoRead(MString, 127);
  157.     if wrt_flg then
  158.         Write(MString);
  159.     len := len - 127;
  160.     end;
  161.     if len > 0 then begin
  162.     DoRead(MString, len);
  163.     MString[len] := '\0';
  164.     if wrt_flg then
  165.         Writeln(MString);
  166.     end;
  167.     wrt_flg := True;
  168. end;
  169.  
  170. begin
  171.     ckname := Adr(ckbuffer);
  172.     ckname[4] := '\0';
  173.     chan := Chr(15);
  174.     OpenFile;
  175.     DoRead(ckname, 4);
  176.     if streq(ckname, "FORM") then begin
  177.     DoRead(ckname,4);    { Get size out of the way. }
  178.     DoRead(ckname,4);
  179.     if streq(ckname,"8SVX") then begin
  180.         DoRead(ckname,4);
  181.         while not streq(ckname,"BODY") do begin
  182.         DoRead(Adr(dlen), 4);
  183.         if streq(ckname,"VHDR") then
  184.             DoRead(Adr(VHeader), SizeOf(Voice8Header))
  185.         else begin
  186.             chnk := Address(ckname);
  187.             case chnk^ of
  188.               $4e414d45: Write("\nName of sample: ");
  189.               $41555448: Write("\nAuthor: ");
  190.               $28432920,
  191.               $28632920,
  192.               $2843294a,
  193.               $2863294a: Write("\n(c) notice: ");
  194.               $414e4e4f: WriteLn("\nAnnotation field:");
  195.             else
  196.               wrt_flg := True;
  197.             end;
  198.             WriteData(dlen);
  199.         end;
  200.         DoRead(ckname, 4);
  201.         end;
  202.         DoRead(Adr(dlen), 4);
  203.         Writeln(dlen, ' bytes at ', VHeader.samplesPerSec, 'Hz');
  204.     end else
  205.         pExit("Not an 8SVX sound file.")
  206.     end else
  207.     pExit("Not an IFF file.");
  208.     ioa := AllocMem(SizeOf(IOAudio), MEMF_PUBLIC);
  209.     if ioa = Nil then
  210.     pExit(NoMem);
  211.     with ioa^.ioa_Request.io_Message do begin
  212.     mn_ReplyPort := CreatePort(Nil, 0);
  213.     if mn_ReplyPort = nil then
  214.         pExit("Unable to allocate port");
  215.     end;
  216.  
  217.     dbuf := AllocMem(dlen, MEMF_PUBLIC + MEMF_CHIP);
  218.     if dbuf = Nil then
  219.     pExit(NoMem);
  220.  
  221.     with ioa^ do begin
  222.     ioa_Request.io_Message.mn_Node.ln_Pri := 10;
  223.     ioa_Data := Adr(chan);
  224.     ioa_Length := 1;
  225.     ioa_AllocKey := 0;
  226.     end;
  227.  
  228.     oerr := OpenDevice(AUDIONAME, 0, IORequestPtr(ioa), 0);
  229.     if oerr <> 0 then
  230.     pExit("Can't open audio device");
  231.  
  232.     if dlen > 131000 then begin  { Supposed hardware limitation. }
  233.     dlen := 131000;
  234.     end else if Odd(dlen) then
  235.     dlen := Pred(dlen);
  236.     DoRead(dbuf, dlen);
  237.  
  238.     if VHeader.sCompression = 1 then begin
  239.     t := AllocMem(dlen shl 1, MEMF_CHIP + MEMF_PUBLIC);
  240.     if t = Nil then
  241.         pExit("Not enough memory for decompression");
  242.     DUnpack(dbuf, dlen, t);
  243.     FreeMem(dbuf, dlen);
  244.     dbuf := t;
  245.     dlen := dlen shl 1;
  246.     end else if VHeader.sCompression > 1 then
  247.     pExit("Unknown compression type");
  248.  
  249.     with ioa^ do begin
  250.     ioa_Request.io_Command := CMD_WRITE;
  251.     ioa_Request.io_Flags := ADIOF_PERVOL;
  252.     ioa_Data := dbuf;
  253.     ioa_Cycles := 1;        { 1 or from command line. }
  254.     ioa_Length := dlen;
  255.     ioa_Period := 3579546 div VHeader.samplesPerSec;
  256.     ioa_Volume := 64;         { Always use maximum volume. }
  257.     end;
  258.  
  259.     BeginIO(IORequestPtr(ioa));
  260.     oerr := WaitIO(IORequestPtr(ioa));
  261.  
  262.     if oerr <> 0 then
  263.     Writeln('Error ', oerr, ' playing sample');
  264.     CloseDevice(IORequestPtr(ioa));
  265.     CleanUp;
  266. end.
  267.