DP Tool Club 17/CD_ASCQ_17_101194.iso/dos/prg/geutsrce/geuterpe.pas

Pascal/Delphi Source File | 1994-08-22 | 18.5 KB | 790 lines

{$R-} {$V-} {$G+}
PROGRAM GEUTERPE;


USES
 DOS,Digital,Y360x480,MyGUI;


TYPE
 String4 =String[4];
 String20=String[20];


CONST
 MaxDevices   =5;
 DeviceCommand:ARRAY[1..MaxDevices] OF String4 =
                    ('-L1','-L2','-S','-A','-SB');
 DeviceName   :ARRAY[1..MaxDevices] OF String20=
                    ('DAC on LPT1',
                     'DAC on LPT2',
                     'PC Speaker',
                     'AdLib FM',
                     'SoundBlaster DAC');


VAR
 i            :BYTE;
 j            :WORD;
 Tval         :WORD;
 OutDevice    :DeviceType;
 AdLib_OK,
 SB_OK,
 Mixer_OK     :BOOLEAN;
 Volume       :BYTE;
 SampleRate   :WORD;
 SizeOfDigit  :LongInt;
 SampleName   :STRING;
 Future       :TypePolice;
 LCD          :TypePolice;
 ThinScrp     :TypePolice;
 BThin        :TypePolice;
 Counter1     :WORD;
 palette,
 palette2     :ARRAY[0..767] OF BYTE;
 old_int_truc,
 int_truc     :Pointer;
 GetName      :STRING;
 FT           :FILE;


PROCEDURE DelayT(Duration:BYTE);
VAR
 Count:WORD;
BEGIN
  FOR Count:=0 TO Duration*6 DO
  BEGIN
    YAttenteSynchro;
  END;
END;


FUNCTION UpString(StringIn:STRING):STRING;
VAR
 TempString:STRING;
 Counter   :BYTE;
BEGIN
  TempString:='';
  FOR Counter:=1 TO Length(StringIn) DO
    TempString:=TempString+UpCase(StringIn[Counter]);
  UpString:=TempString;
END;


PROCEDURE CadrePDStatus;
BEGIN
  PoliceActive:=Future;
  Cadre(10,30,349,130,BeigeMoyen);
  PanneauCcv(13,36,346,56,BeigeClair);
  TexteCreux(65,39,BeigeMoyen,3,' AUTHOR  INFORMATION ');
  PoliceActive:=ThinScrp;
  ParametresPolice(90,0,True);
  TexteNormal(14,57 ,0,'Coder..:Patrick Ruelle');
  TexteNormal(14,70 ,0,'Address:43 av. de Grande Bretagne');
  TexteNormal(14,83 ,0,'        98000 Monaco');
  TexteNormal(14,96 ,0,'        Principality of MONACO');
  TexteGras  (14,109,1,'FREEWARE,  CONTRIBUTIONS ARE WELCOME!');
END;


PROCEDURE CadreHardwareStatus;
BEGIN
  PoliceActive:=Future;
  Cadre(10,156,349,249,BeigeMoyen);
  PanneauCcv(13,162,346,182,BeigeClair);
  TexteCreux(98,165,BeigeMoyen,3,'HARDWARE STATUS');
  PoliceActive:=LCD;
  ParametresPolice(90,0,True);
  TexteNormal(14,184,0,'AdLib FM Chipset:');
  TexteNormal(14,199,0,'SB DAC Chipset..:');
  TexteNormal(14,214,0,'SB Mixer Chipset:');
  TexteNormal(14,229,0,'Card detected...:');
END;


PROCEDURE CadreOutputStatus;
BEGIN
  PoliceActive:=Future;
  Cadre(10,254,349,407,BeigeMoyen);
  PanneauCcv(13,260,346,280,BeigeClair);
  TexteCreux(109,263,BeigeMoyen,3,'OUTPUT STATUS');
  PoliceActive:=LCD;
  ParametresPolice(90,0,True);
  TexteNormal(14,282,0,'File name.......:');
  TexteNormal(14,297,0,'File size.......:');
  TexteNormal(14,312,0,'Output device...:');
  TexteNormal(14,327,0,'Sample rate.....:');
  TexteNormal(14,342,0,'Buffer size.....:');
  TexteNormal(14,357,0,'Header size.....:');
  TexteNormal(14,372,0,'Bass filter.....:');
  TexteNormal(14,387,0,'Volume..........:');
END;


PROCEDURE CadreOscilloStatus;
BEGIN
  PoliceActive:=Future;
  Cadre(10,411,349,704,BeigeMoyen);
  PanneauCcv(13,417,346,437,BeigeClair);
  TexteCreux(87,420,BeigeMoyen,3,'SPECTRUM ANALYZER');
  PanneauCcv(13,439,346,697,230);
END;


PROCEDURE MontreSplit;
BEGIN
  FOR counter1:=480 DOWNTO 459 DO
  BEGIN
    YAttenteSynchro;
    YSplit(counter1);
  END;
  DelayT(18);
END;


PROCEDURE EnleveSplit;
BEGIN
  FOR counter1:=459 TO 480 DO
  BEGIN
    YAttenteSynchro;
    YSplit(counter1);
  END;
END;


PROCEDURE SplitError(texte:STRING);
BEGIN
  PoliceActive:=BThin;
  EnleveSplit;
  PanneauCcv(0,0,359,19,BeigeClair);
  TexteOmbre(6,3,90,0,texte);
  MontreSplit;
END;



PROCEDURE SplitDeFin;
BEGIN
  FOR j:=Counter DIV ScrollSpeed TO 247 DO
  BEGIN
    YAttenteSynchro;
    YScroll(j);
  END;
  PoliceActive:=BThin;
  EnleveSplit;
  PanneauCcv(0,0,359,97,BeigeClair);
  TexteOmbre(6,6,90,0,'  THIS IS A NICE FREEWARE HIGH QUALITY TP');
  TexteOmbre(6,24,90,0,'   AND BASM SOUND ORIENTED PGM INCLUDING ');
  TexteOmbre(3,42,90,0,'THE COMPLETE SOURCE CODE FROM PATRICK RUELLE');
  TexteOmbre(10,60,15,0,'  So a contribution will be appreciated!');
  TexteOmbre(2,78,15,0,'     What about  FF50 or DM15 or US$10?');
  For j:=480 DownTo 381 DO
  BEGIN
    YAttenteSynchro;
    YSplit(j);
  END;
  DelayT(90);
  For j:=381 To 480 DO
  BEGIN
    YAttenteSynchro;
    YSplit(j);
  END;
END;


PROCEDURE Info;
VAR
  StringG,
  String2 :STRING;
BEGIN
  ParametresPolice(90,0,True);
  PoliceActive:=LCD;
  TexteGras(150,282,1,SampleName);
  Str(SizeOfDigit DIV 1024,StringG);
  TexteGras(150,297,1,StringG+'Kb');
  TexteGras(150,312,1,DeviceName[Ord(OutDevice)+1]);
  Str(SampleRate,StringG);
  TexteGras(150,327,1,StringG+'Hz');
  Str(BufSize Div 1000,StringG);
  TexteGras(150,342,1,StringG+'Kb');
  Str(HeaSize,StringG);
  IF HeaSize<>1
    THEN TexteGras(150,357,1,StringG+' bytes')
  ELSE
    TexteGras(150,357,1,StringG+' byte');
  IF Mixer_OK THEN
  BEGIN
    IF NOT(NoFilter) THEN
      TexteGras(150,372,1,'OFF')
    ELSE
      TexteGras(150,372,1,'ON');
    Str(Volume,StringG);
    Str(VolMax,String2);
    TexteGras(150,387,1,StringG+'/'+String2);
  END
  ELSE
  BEGIN
    TexteGras(150,372,1,'Not available');
    TexteGras(150,387,1,'Not available');
  END;
END;


PROCEDURE LitPalette;
BEGIN
  FOR i:=0 TO 255 DO
  BEGIN
    YLitCouleur(i);
    palette[i*3]  :=r;
    palette[i*3+1]:=v;
    palette[i*3+2]:=b;
  END;
END;


PROCEDURE EcranNoir;
BEGIN
  FOR j:=0 TO 767 DO
    palette2[j]:=0;
  YAttenteSynchro;
  YEcritPalette(palette2[0],0,128);
  YAttenteSynchro;
  YEcritPalette(palette2[384],128,128);
END;


PROCEDURE NoFadeIn;
BEGIN
  YAttenteSynchro;
  YEcritPalette(palette[0],0,128);
  YAttenteSynchro;
  YEcritPalette(palette[384],128,128);
END;


PROCEDURE FadeOut;
BEGIN
  FOR i:=0 TO 63 DO
  BEGIN
    FOR j:=0 TO 767 DO
      IF palette[j]>0
        THEN Dec(palette[j]);
    YAttenteSynchro;
    YEcritPalette(palette[0],0,128);
    YAttenteSynchro;
    YEcritPalette(palette[384],128,128);
  END;
END;


FUNCTION FileExists(FileName:STRING):BOOLEAN;
VAR F:FILE;
BEGIN
  SizeOfDigit:=0;
  {$I-}
  Assign(F,FileName);
  Reset(F,1);
  SizeOfDigit:=FileSize(F);
  Close(F);
  {$I+}
  FileExists:=(IOResult=0) AND (FileName<>'');
END;


PROCEDURE WaitKey;ASSEMBLER;
ASM
  xor   ah, ah
  int   16h
END;


FUNCTION FindOutPutDevice:DeviceType;
VAR
 Counter      :BYTE;
 DeviceCounter:BYTE;
 Found        :BOOLEAN;
 Device       :DeviceType;
BEGIN
  Counter:=1;
  Found  :=False;
  Device :=PcSpeaker;
  WHILE (Counter<=ParamCount) AND NOT(Found) DO
  BEGIN
    FOR DeviceCounter:=1 TO MaxDevices DO
      IF UpString(ParamStr(Counter))=DeviceCommand[DeviceCounter] THEN
      BEGIN
        Device:=DeviceType(DeviceCounter-1);
        Found :=True;
      END;
    Inc(Counter);
  END;
  FindOutPutDevice:=Device;
END;


FUNCTION FindRawFileName:STRING;
VAR
 FileNameFound:STRING;
 TempName     :STRING;
 Found        :BOOLEAN;
 Counter      :BYTE;
BEGIN
  FileNameFound:='';
  Counter      :=1;
  Found        :=False;
  WHILE (Counter<=ParamCount) AND NOT(Found) DO
  BEGIN
    TempName:=UpString(ParamStr(Counter));
    IF TempName[1]<>'-' THEN
    BEGIN
      FileNameFound:=TempName;
      Found        :=True;
    END;
    Inc(Counter);
  END;
  FindRawFileName:=FileNameFound;
END;


FUNCTION FindPlayBackRate:WORD;
VAR
 RateString:STRING;
 Rate      :WORD;
 Found     :BOOLEAN;
 Counter   :BYTE;
 ErrorCode :INTEGER;
BEGIN
  Rate   :=11000;
  Counter:=1;
  Found  :=False;
  WHILE (Counter<=ParamCount) AND NOT(Found) DO
  BEGIN
    RateString:=UpString(ParamStr(Counter));
    IF Copy(RateString,1,2)='-F' THEN
    BEGIN
      RateString:=Copy(RateString,3,Length(RateString)-2);
      Val(RateString,Rate,ErrorCode);
      IF ErrorCode<>0 THEN
      BEGIN
        Rate:=11000;
        SplitError(' Frequency error, using default');
      END;
      Found:=True;
    END;
    Inc(Counter);
  END;
  IF Rate<4000 THEN
    Rate:=4000
  ELSE
    IF Rate>22000 THEN
      Rate:=22000;
  FindPlayBackRate:=Rate;
END;


FUNCTION FindBufferSize:WORD;
VAR
 BufferString:STRING;
 Buffer      :WORD;
 Found       :BOOLEAN;
 Counter     :BYTE;
 ErrorCode   :INTEGER;
BEGIN
  Buffer :=16;
  Counter:=1;
  Found  :=False;
  WHILE (Counter<=ParamCount) AND NOT(Found) DO
  BEGIN
    BufferString:=UpString(ParamStr(Counter));
    IF Copy(BufferString,1,3)<>'-BF' THEN
    BEGIN
      IF Copy(BufferString,1,2)='-B' THEN
      BEGIN
        BufferString:=Copy(BufferString,3,Length(BufferString)-2);
        Val(BufferString,Buffer,ErrorCode);
        IF ErrorCode<>0 THEN
        BEGIN
          Buffer:=16;
          SplitError(' Buffer size error, using default');
        END;
        Found:=True;
      END;
    END;
    Inc(Counter);
  END;
  IF Buffer<8 THEN
    Buffer:=8
  ELSE
    IF Buffer>64 THEN
      Buffer:=64;
  FindBufferSize:=Buffer*1000;
END;


FUNCTION FindXMS:BOOLEAN;
VAR
 XMSString :STRING;
 Found     :BOOLEAN;
 Counter   :BYTE;
BEGIN
  IF NoXMS
    THEN UseXMS:=False;
  Counter:=1;
  Found  :=False;
  WHILE (Counter<=ParamCount) AND NOT(Found) DO
  BEGIN
    XMSString:=UpString(ParamStr(Counter));
    IF Copy(XMSString,1,2)='-X' THEN
      Found:=True;
    Inc(Counter);
  END;
  FindXMS:=Found;
END;


FUNCTION FindHeaderSize:WORD;
VAR
 HeaderString:STRING;
 Header      :WORD;
 Found       :BOOLEAN;
 Counter     :BYTE;
 ErrorCode   :INTEGER;
BEGIN
  Header :=0;
  Counter:=1;
  Found  :=False;
  WHILE (Counter<=ParamCount) AND NOT(Found) DO
  BEGIN
    HeaderString:=UpString(ParamStr(Counter));
    IF Copy(HeaderString,1,2)='-H' THEN
    BEGIN
      HeaderString:=Copy(HeaderString,3,Length(HeaderString)-2);
      Val(HeaderString,Header,ErrorCode);
      IF ErrorCode<>0 THEN
      BEGIN
        Header:=0;
        SplitError(' Header size error, using default');
      END;
      Found:=True;
    END;
    Inc(Counter);
  END;
  IF Header<0 THEN
    Header:=0
  ELSE
    IF Header>255 THEN
      Header:=255;
  FindHeaderSize:=Header;
END;


FUNCTION FindFilter:BOOLEAN;
VAR
 FilterString:STRING;
 Found       :BOOLEAN;
 Counter     :BYTE;
BEGIN
  Counter:=1;
  Found  :=False;
  WHILE (Counter<=ParamCount) AND NOT(Found) DO
  BEGIN
    FilterString:=UpString(ParamStr(Counter));
    IF Copy(FilterString,1,3)='-BF' THEN
      Found:=True;
    Inc(Counter);
  END;
  FindFilter:=Found;
END;


FUNCTION FindVolume:WORD;
VAR
 VolumeString:STRING;
 Vol         :WORD;
 Found       :BOOLEAN;
 Counter     :BYTE;
 ErrorCode   :INTEGER;
BEGIN
  Vol    :=9;
  Counter:=1;
  Found  :=False;
  WHILE (Counter<=ParamCount) AND NOT(Found) DO
  BEGIN
    VolumeString:=UpString(ParamStr(Counter));
    IF Copy(VolumeString,1,2)='-V' THEN
    BEGIN
      VolumeString:=Copy(VolumeString,3,Length(VolumeString)-2);
      Val(VolumeString,Vol,ErrorCode);
      IF ErrorCode<>0 THEN
      BEGIN
        Vol:=9;
        SplitError(' Volume error, using default');
      END;
      Found:=True;
    END;
    Inc(Counter);
  END;
  IF Vol<1 THEN
    Vol:=1
  ELSE
    IF Vol>VolMax THEN
      Vol:=VolMax;
  FindVolume:=Vol;
END;


PROCEDURE Buffer_Test;
VAR
 MemSize:LongInt;
 OneBuf :WORD;
BEGIN
  MemSize:=MaxAvail;
  IF MemSize<(2*BufSize) THEN
  BEGIN
    OneBuf:=((MemSize DIV 1000)*1000) DIV 2;
    IF OneBuf<8000 THEN
    BEGIN
        SplitError(' Not enough memory');
        DelayT(19);
        YModeTexte;
        Halt;
    END
    ELSE BufSize:=OneBuf;
  END;
END;


PROCEDURE Adlister_Test;
VAR
  Hexa:STRING[3];
BEGIN
  ParametresPolice(90,1,True);
  PoliceActive:=LCD;
  IF AdLib_OK THEN
    TexteGras(150,184,1,'AVAILABLE [388h]')
  ELSE
    TexteGras(150,184,1,'NOT AVAILABLE');
  IF SB_OK THEN
  BEGIN
    Str(Hexa_Addr(SBPort),Hexa);
    TexteGras(150,199,1,'AVAILABLE ['+Hexa+'h]');
  END
  ELSE TexteGras(150,199,1,'NOT AVAILABLE');
  IF Mixer_OK THEN TexteGras(150,214,1,'AVAILABLE')
  ELSE TexteGras(150,214,1,'NOT AVAILABLE');
  CASE CardType OF
    Speaker:TexteGras(150,229,1,'NONE (PC SPEAKER)');
    AdLibFM:TexteGras(150,229,1,'ADLIB');
    SB_Norm:TexteGras(150,229,1,'SOUNDBLASTER');
    SB_Pro :TexteGras(150,229,1,'SOUNDBLASTER PRO');
    SB_16  :TexteGras(150,229,1,'SOUNDBLASTER 16');
  END;
END;


PROCEDURE Device_Selection;
BEGIN
  ScrollSpeed:=50;
  CASE OutDevice OF
   SoundBlaster:BEGIN
                  ScrollSpeed:=(26-(SampleRate DIV 1000))*3;
                  IF SB_OK=False THEN
                  BEGIN
                    ScrollSpeed:=50;
                    IF AdLib_OK=False THEN
                      OutDevice:=PCSpeaker
                    ELSE OutDevice:=AdLib;
                  END;
                END;
   AdLib       :BEGIN
                  IF AdLib_OK=False THEN
                    OutDevice:=PCSpeaker;
                END;
  END;
  Counter:=20*ScrollSpeed;
END;


PROCEDURE Init_Device;
BEGIN
  CASE OutDevice OF
   PCSpeaker   :BEGIN
                  Tval:=(1193180 DIV SampleRate) SHR 1;
                  FOR i:=0 TO 255 DO
                    SpkrTable[i]:=(WORD((SpkrBaseTable[i]-1)*Tval) DIV $39)+1;
                  Init_Speaker;
                END;
   AdLib       :BEGIN
                  InitializeAdLib;
                END;
   SoundBlaster:BEGIN
                  Spk_On;
                END;
  END;
END;


PROCEDURE Deinit_Device;
BEGIN
  CASE OutDevice OF
   PCSpeaker   :End_Speaker;
   SoundBlaster:Spk_Off;
  END;
END;


PROCEDURE EUTERPETitle;
BEGIN
  PoliceActive:=Future;
  PanneauCcv(0,0,359,19,BeigeClair);
  TexteRelief(2,2,BeigeXClair,3,'G-EUTERPE 1.0ß');
  TexteRelief(334,3,BeigeXClair,0,Chr(30));
  TexteRelief(348,3,BeigeXClair,0,Chr(31));
END;


PROCEDURE Rien;Interrupt;
BEGIN
END;


BEGIN
  IF ParamCount<>0 THEN
  BEGIN
    InLine($FA);      {CLI}
    GetIntVec($1B,old_int_truc);
    int_truc:=Ptr(Seg(Rien),Ofs(Rien));
    SetIntVec($1B,int_truc);
    InLine($FB);      {STI}
    NoFilter  :=True;
    Volume    :=9;
    YMode360x480;
    YRemplitEcran(0);
    InitialisationsCouleurs;
    YEcritCouleur(90,63,54,45);{chair}
    YEcritCouleur(230,0,18,0); {vert fonce}
    YEcritCouleur(231,33,44,0);{vert clair}
    LitPalette;
    EcranNoir;
    YRemplitEcran(BeigeXFonce);
    YScroll(20);
    YSplit(459);
    IF ChargePolice(Future  ,'future')=0 THEN;
    IF ChargePolice(LCD     ,'lcd')=0 THEN;
    IF ChargePolice(ThinScrp,'thinscrp')=0 THEN;
    IF ChargePolice(BThin   ,'bthin')=0 THEN;
    CadrePDStatus;
    CadreHardwareStatus;
    CadreOutputStatus;
    CadreOscilloStatus;
    EUTERPETitle;
    NoFadeIn;
    XMSChoice :=FindXMS;
    SampleRate:=FindPlayBackRate;
    BufSize   :=FindBufferSize;
    HeaSize   :=FindHeaderSize;
    NoFilter  :=FindFilter;
    SampleName:=FindRawFileName;
    OutDevice :=FindOutPutDevice;
    AdLib_OK  :=AdLib_Test;
    SB_OK     :=SB_Test;
    Mixer_OK  :=Mixer_Test;
    Volume    :=FindVolume;
    Buffer_Test;
    Adlister_Test;
    Device_Selection;
    IF SampleName<>'' THEN
    BEGIN
      IF FileExists(SampleName) THEN
      BEGIN
        IF SizeOfDigit>999 THEN
        BEGIN
          Info;
          Init_Device;
          SetOutputDevice(OutDevice);
          IF Mixer_OK THEN
          BEGIN
            IF NOT(NoFilter) THEN
              SbProSetFilter(True)
            ELSE
              SbProSetFilter(False);
            VoiceMixerVol(Volume);
          END;
          IF UseXMS THEN
          BEGIN
            IF XMSChoice THEN
            BEGIN
             LoadPlayXMS(SampleName,SampleRate);
             IF XMSError<>0 THEN
             BEGIN
               SplitError(Stringn);
               EUTERPETitle;
               PlayRAWSoundFile(SampleName,SampleRate);
             END;
            END
            ELSE
            BEGIN
              EUTERPETitle;
              PlayRAWSoundFile(SampleName,SampleRate);
            END;
          END
          ELSE
          BEGIN
            IF XMSChoice THEN
            BEGIN
              SplitError(' XMS manager not detected.');
            END;
            EUTERPETitle;
            PlayRAWSoundFile(SampleName,SampleRate);
          END;
          IF Mixer_OK THEN
            VoiceMixerVol(9);
          Deinit_Device;
        END
        ELSE
        BEGIN
          SplitError(' Sound file too small.');
        END;
      END
      ELSE
      BEGIN
        SplitError(' Sound file not found.');
      END;
    END
    ELSE
    BEGIN
      SplitError(' Filename not specified');
    END;
    CleanUp;
    SplitDeFin;
    FadeOut;
    IF DechargePolice(Future)=0 THEN;
    IF DechargePolice(LCD)=0 THEN;
    IF DechargePolice(ThinScrp)=0 THEN;
    IF DechargePolice(BThin)=0 THEN;
    YModeTexte;
    InLine($FA);      {CLI}
    SetIntVec($1B,old_int_truc);
    InLine($FB);      {STI}
  END
  ELSE
  BEGIN
    WriteLn(' ╔════════════════════════════════════════════════════════════════════════════╗');
    WriteLn(' ║ USAGE...: GEUTERPE [SWITCHES] <RAW SOUND FILE>     Patrick Ruelle (C) 1994 ║');
    WriteLn(' ╟────────────────────────────────────────────────────────────────────────────╢');
    WriteLn(' ║        ■PC_Speaker - ■AdLib - ■LPT1 - ■LPT2 - ■SB - ■SB_PRO - ■SB_16       ║');
    WriteLn(' ╟────────────────────────────────────────────────────────────────────────────╢');
    WriteLn(' ║ SWITCHES: [REGISTERED VERSION]                                             ║');
    WriteLn(' ║  -S       PC Speaker (default)          -Fxxxxx  from 4000 upto 22000      ║');
    WriteLn(' ║  -L1      DAC on LPT1                   -Bxx     from 8Kb upto 64Kb        ║');
    WriteLn(' ║  -L2      DAC on LPT2                   -Hxxx    from 0 upto 255 bytes     ║');
    WriteLn(' ║  -A       AdLib FM                      -Vxx     from 1 upto [15 or 31]    ║');
    WriteLn(' ║  -SB      SoundBlaster DAC              -BF      Bass Filter               ║');
    WriteLn(' ║  -X       use XMS (otherwise disk)                                         ║');
    WriteLn(' ╟────────────────────────────────────────────────────────────────────────────╢');
    WriteLn(' ║  -F  Frequency (default=11000Hz)        -B  Buffer size (default=16Kb)     ║');
    WriteLn(' ║  -H  Header size to skip (default=0)    -V  output Volume (default=9)      ║');
    WriteLn(' ╚════════════════════════════════════════════════════════════════════════════╝');
  END;
END.