Power-Programmierung/CD1.mdf/pascal/library/dos/sound/midipeek/midipeek.pas

Pascal/Delphi Source File | 1988-09-04 | 9.2 KB | 367 lines

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I-}    {I/O checking OFF}
{$N-}    {No numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}

{ Copyright (c) 1986, 1987, 1988 Carter Scholz }

{ You may copy and distribute this program freely for NON-COMMERCIAL use
  only.  If you have received this program for free, and find it useful
  or educational, a $15 donation is suggested. }

{ works fine EXCEPT that running from EXE after the first time
  exits w/o waiting for a "quit"
  Revise so that "filtering" is an option rather than a forced
  query?
}


uses Crt, Mpu;

const
  MaxBuf=$7FFF;     {limits buffer to 32K}
  version='2.0';

var
  ch:char;
  i, LastByte : integer;
  Midijunk: byte;
  j, MidiCh, BytesLeft, statbytes, laststat : integer;
  buffer: array [0 .. MaxBuf] of byte;
  PrintFlag, answer: char;
  ActiveIgnore : Boolean;
  SysEx, NoteOn, Quit, done, stattocome, comingback : Boolean;
  FileName: string;
  MidiFile: file of byte;
  AFilter,BFilter,CFilter,DFilter,EFilter,FFilter,NFilter: boolean;

function Exist (filename:string) : Boolean;
  var
    testfile: file;
  begin
    assign (testfile,filename);
    reset (testfile);
    if (IOresult=0) then
      begin
        exist := true;
        close(testfile);
      end
      else
      exist := false;
  end;


function HexString(b:integer):string;
  const
    hex : array [0..15] of char = '0123456789ABCDEF';
  begin
    HexString := hex [b shr 4] + hex [b and 15];
  end;

procedure Hello;
  var ch:char;
  begin
    clrscr;
    writeln;
    writeln;
    writeln;
    writeln;
    HighVideo;
    writeln('    PEEK');
    writeln;
    writeln('    version ',version);
    LowVideo;
    writeln;
    writeln;
    writeln;
    writeln('              a MIDI monitor program for MPU-401 interface');
    writeln;
    writeln;
    writeln('              copyright 1986-88 Carter Scholz');
    writeln;
    writeln;
    writeln;
    writeln;
    writeln('    Carter Scholz, 2665 Virginia St., Berkeley CA 94709.');
    writeln;
    writeln;
    writeln('    Press any key to continue.');
    ch:=readkey;
    clrscr;
  end;

procedure InitFilters;
  begin
     Afilter:=false;
     Bfilter:=false;
     Cfilter:=false;
     Dfilter:=false;
     EFilter:=false;
     Ffilter:=false;
     Nfilter:=false;
  end;

procedure ShowFilters;
  begin
      window(1,25,80,25);
      clrscr;
      write ('Filtering:  ');
      if AFilter then write ('Poly-after ');
      if BFilter then write ('Cont-ctrl ');
      if CFilter then write ('Prgm-chng ');
      if DFilter then write ('Aftertch ');
      if EFilter then write ('Pitchbnd ');
      if Ffilter then write ('System ');
      if Nfilter then write ('Notes ');
   end;

procedure FilterSetup;
  var
    choice: char;
  begin
    window(1,1,80,24);
    clrscr;
      writeln('Filter these types of messages: ');
      writeln;
      writeln('A) polyphonic key pressure     D) aftertouch');
      writeln('B) continuous controllers      E) pitch bend');
      writeln('C) program change              F) system messages');
      writeln('N) notes');
      writeln;
      writeln('R) reset');
      writeln;
      writeln('Return to accept settings.');
      writeln;
   repeat
      choice:=upcase(readkey);
      case choice of
        'A': Afilter:=true;
        'B': BFilter:=true;
        'C': Cfilter:=true;
        'D': Dfilter:=true;
        'E': Efilter:=true;
        'F': Ffilter:=true;
        'N': Nfilter:=true;
        'R': InitFilters;
      end;
      ShowFilters;
    until choice=#13;

    gotoxy(1,24); write ('Press any key to stop. ');
    window(1,1,80,22);
    clrscr;
  end;

procedure PrintHex;
  begin
    write ( HexString(buffer[i]),'  ');
  end;

procedure PrintDec;
  begin
    write ( buffer[i]:4 );
  end;

procedure PrintLine;
  begin
    stattocome:=false;
    BytesLeft:=2;
    midich:=(buffer[i] and $0F)+1;
    case buffer[i] of
      $80..$8F: write ('Note Off   ');
      $90..$9F: write ('Note On    ');
      $A0..$AF: write ('Poly after ');
      $B0..$BF: write ('Controller ');
      $C0..$CF: begin write ('Program    '); dec(Bytesleft); end;
      $D0..$DF: begin write ('Aftertouch '); dec(Bytesleft); end;
      $E0..$EF: write ('Pitch Wheel');
      $F0: begin  writeln ('System exclusive:  '); sysex:=true; end;
      $F2:      write ('Song Pointer');
      $F3: begin  write ('Song Select'); dec(BytesLeft); end;
      $F6:      writeln ('Tune Request ');
      $F7: begin writeln;writeln('End of sys-ex '); sysex:=false; end;
      $F8:      writeln ('Clock  ');
      $FA:      writeln ('Play ');
      $FB:      writeln ('Continue ');
      $FC:      writeln ('Stop ');
      $FE:      writeln ('Active sensing ');
      $FF:      writeln ('System reset  ');
    end;
    if buffer[i] in [$F6..$FF] then BytesLeft:=0;
    statbytes:=bytesleft;
  end;

procedure PrintLineData;
  begin
    if stattocome then begin
      write('           ');
      bytesleft:=statbytes;
      stattocome:=false;
    end;
    write(buffer[i]:8);
    dec(BytesLeft);
    if BytesLeft=0 then begin
      gotoxy(40,whereY);
      writeln ('channel ',midich:2);
      stattocome:=true;
    end;
  end;

procedure FileSave(N: integer);
  var
    j: integer; ch: char;
  begin
    LowVideo;
    while keypressed do ch:=readkey;
    writeln;
    repeat
      write ('Save data to filename (Return only for no save) : ');
      readln (FileName);
        if FileName = '' then exit;
      if exist(Filename) then begin
        writeln ('File exists! Overwrite? (y/n)');
        ch:=upcase(readkey);
      end;
    until (exist(filename)=false) or (ch='Y');
    assign (MidiFile, FileName);
    rewrite (MidiFile);
    for j:=0 to N-1 do
      write (MidiFile, byte(buffer[j]));
    close (MidiFile);
  end;

procedure DataSend (N: integer);
  begin
    i:=0;
    window(1,1,80,22);
    repeat
      write (HexString(buffer[i]),'  ');
      PutData (buffer[i]);
      inc(i);
    until i = N;
  end;

procedure Send;
  var j:byte;
  begin
    LowVideo;
    writeln;
    repeat
      write ('Send data from filename (Return only for no send) : ');
      readln (FileName);
        if FileName = '' then exit;
      assign (MidiFile, FileName);
      if IOResult<>0 then writeln ('Disk error!');
    until IOResult=0;
    reset (MidiFile);
    i:=0;
    repeat
      read (MidiFile, j);
      buffer[i]:=integer(j);
      inc(i);
    until eof (MidiFile) = true;
    LastByte := i;
    writeln (LastByte,' bytes to send');
    close (MidiFile);
    write('Press any key to send'); ch:=readkey;
    DataSend (LastByte);
  end;

procedure DisplayData;
  begin
    LowVideo;
    case PrintFlag of
      'H': PrintHex;
      'D': PrintDec;
      'L': if sysex=false then PrintLineData else printhex;
    end;
    inc(i);
  end;

procedure DisplayStatus;
  begin
      HighVideo;
      case PrintFlag of
        'H': PrintHex;
        'D': PrintDec;
        'L': PrintLine;
      end;
    inc(i);
  end;

procedure Skip;
  begin
    laststat:=buffer[i];
    repeat
      getdata(buffer[i]);
    until (buffer[i]>$7F) and (buffer[i]<>laststat);
    laststat:=buffer[i];
    comingback:=true;
  end;

procedure Receive;
  begin
    done:=false;   comingback:=false;
    window(1,23,80,24);
    clrscr;
    LowVideo;
    writeln ('Display data in H)ex, D)ecimal, or L)ine format? ');
    PrintFlag := upcase(readkey);
    write ('Press any key to quit');
    ShowFilters;
    window(1,1,80,23);
    clrscr;
    sysex:=false;
    i:=0;
    repeat
      if comingback=false then getdata(buffer[i]);
      if comingback then comingback:=false;
      case buffer[i] of
        $00..$7F: DisplayData;
        $80..$9F: if Nfilter then Skip else DisplayStatus;
        $A0..$AF: if Afilter then Skip else DisplayStatus;
        $B0..$BF: if Bfilter then Skip else DisplayStatus;
        $C0..$CF: if Cfilter then Skip else DisplayStatus;
        $D0..$DF: if Dfilter then Skip else DisplayStatus;
        $E0..$EF: if Efilter then Skip else DisplayStatus;
        $F0: if Ffilter then Skip else DisplayStatus;
        $F2: if Ffilter then Skip else DisplayStatus;
        $F3: if Ffilter then Skip else DisplayStatus;
        $F4..$FF: if Ffilter=false then DisplayStatus;
      end;
    until keypressed;                            { End loop.   }

    window(1,23,80,25);
    FileSave(i);
    window(1,1,80,25); clrscr;
  end;

{ **** MAIN PROGRAM **** }

begin
  Hello;
  quit:=false;
  resetMPU;
  putcmd($3f);
    getdata(midijunk);  {empty ACK}
  InitFilters;
  repeat
    ShowFilters;
    window(1,23,80,24);
    clrscr; LowVideo;
    writeln ('R)eceive MIDI data         S)end data from a file');
    write   ('F)ilters                   Q)uit ');
    answer := upcase(readkey);
    if answer = 'R' then Receive;
    if answer = 'Q' then Quit := true;
    if answer = 'F' then FilterSetup;
    if answer = 'S' then Send;
  until Quit=true;
  clrscr;
  resetMPU;
  writeln ('So long!');
  NormVideo;
end.