gwbleep.pas

絮语2007视频聊天软件源程序.仅供参考

Unit GWBleep; { Bleeper / BleepInt / GWBleep Version 5.5 }

{ Copyright 1999, 2001 Andy Preston - Apollo Developments, Swindon U.K. http://www.apollod.omnia.co.uk/aa/

  HACKERS OF THE WORLD UNITE!    HACKERS OF THE WORLD UNITE!    HACKERS OF THE WORLD UNITE!    HACKERS OF THE WORLD UNITE!

  Play tunes on the PC speaker using syntax like GWBasic's Play statement, using the bleeper unit, see bleepint.htm for details

  This unit is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public
  License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version.

  This unit is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public License for more details.

  You should have received a copy of the GNU Library General Public License along with this unit; if not, write to the
  Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
}

Interface

procedure playstop;
Procedure PlayBleep(str:string);

Implementation

Uses
  SysUtils, Bleeper;

Type
  TOctave = 1..7;
  TNoteLength = 1..64;
  TNote = (NoteC, NoteCs, NoteD, NoteDs, NoteE, NoteF, NoteFs, NoteG, NoteGs, NoteA, NoteAs, NoteB, NoteBad);
  TPlayable = NoteC..NoteB;

  { Approximate frequencies based on table in 'Electronic Music And Musique Concret? }
  { By F. C. Judd A.Inst.E. Neville Spearman, London, 1961                            }

Const
  Freq : Array [TPlayable, TOctave] Of Word = (
     ({16,} 33, 65, 131, 262, 523, 1047, 2093 {, 4168, 8372}),
     ({17,} 35, 69, 139, 277, 554, 1109, 2217 {, 4435, 8870}),
     ({18,} 37, 73, 147, 294, 587, 1174, 2344 {, 4699, 9397}),
     ({19,} 39, 78, 156, 311, 622, 1245, 2489 {, 4978, 9956}),
     ({21,} 41, 82, 165, 330, 659, 1319, 2637 {, 5274, 10548}),
     ({22,} 44, 87, 175, 349, 698, 1397, 2794 {, 5588, 11175}),
     ({23,} 46, 92, 185, 370, 740, 1480, 2960 {, 5920, 11840}),
     ({24,} 49, 98, 196, 392, 784, 1568, 3136 {, 6271, 12542}),
     ({26,} 52, 104, 208, 415, 831, 1661, 3322 {, 6645, 13290}),
     ({28,} 55, 110, 220, 440, 880, 1760, 3520 {, 7040, 14080}),
     ({29,} 59, 117, 233, 466, 932, 1865, 3729 {, 7459, 14917}),
     ({31,} 62, 123, 247, 494, 988, 1976, 3951 {, 7902, 15804})
    );

  Natural : Array ['A'..'G'] Of TNote = (NoteA, NoteB, NoteC, NoteD, NoteE, NoteF, NoteG);
  Sharp : Array ['A'..'G'] Of TNote = (NoteAs, NoteBad, NoteCs, NoteDs, NoteBad, NoteFs, NoteGs);
  Flat : Array ['A'..'G'] Of TNote = (NoteGs, NoteAs, NoteBad, NoteCs, NoteDs, NoteBad, NoteFs);

  WholeNoteDur : Integer = 1024; { Makes it easy if it's a multiple of 64 }

Var
  ResetOctave, Octave : TOctave;
  ResetNoteLength, NoteLength : TNoteLength;
  Duration : LongInt;
  stop:boolean=false;

procedure playstop;
begin
stop:=true;
end;

Function GetANumber (Str : String; Var Position : Integer) : Integer;
Var
  P : Integer;
Begin
  P := Position + 1;
  While (P <= Length (Str)) And (Str [P] In ['0'..'9']) Do Inc (P);
  If Not (Str [P] In ['0'..'9']) Then Dec (P);
  If P <= Position Then Result := -1
  Else Begin
    Result := StrToInt (Copy (Str, Position + 1, (P - Position)));
    Position := P;
  End;
End;

Procedure SetNoteLength (NewLen : TNoteLength);
Begin
  NoteLength := NewLen;
  Duration := WholeNoteDur Div NoteLength;
End;

{ GWBasic, PLAY Commands not yet implemented }
{ MF, MB }
{ N      }
{ T      }
{ .      }

Procedure PlayBleep (str:string);
Var
  ANumber, C : Integer;

  Procedure TryNoteLength;
  Var
    ANumber : Integer;
  Begin
    ANumber := GetANumber (Str, C);
    If ANumber > -1 Then SetNoteLength (TNoteLength (ANumber));
  End;

Var
  Note : TPlayable;
  Command : Char;
  LegatoStaccatoRatio, LegatoStaccatoPause : Integer;
Begin
  LegatoStaccatoRatio := 8;
  C := 1;
  stop:=false;
  While C <= Length (Str) Do
    try
    Command := Str [C];
    Case Command Of
      '>' : If Octave < High (TOctave) Then Begin
          ResetOctave := Octave;
          Octave := Succ (Octave);
        End;
      '<' : If Octave > Low (TOctave) Then Begin
          ResetOctave := Octave;
          Octave := Pred (Octave);
        End;
      'A'..'G' : Begin
          If C = Length (Str) Then Note := Natural [Command]
          Else Begin
            If Str [C + 1] In ['#', '+'] Then Begin
              Note := Sharp [Command];
              C := C + 1;
            End
            Else If Str [C + 1] = '-' Then Begin
              Note := Flat [Command];
              C := C + 1;
            End
            Else Note := Natural [Command];
          End;
          TryNoteLength;
          If Note = NoteBad Then Raise Exception.Create ('不能识别的音符编码.');
          If LegatoStaccatoRatio = 0 Then LegatoStaccatoPause := 0
          Else LegatoStaccatoPause := Duration Div LegatoStaccatoRatio;
          DoBleep (Freq [Note, Octave], Duration - LegatoStaccatoPause);
          BleepPause (LegatoStaccatoPause);
          Octave := ResetOctave;
          SetNoteLength (ResetNoteLength);
        End;
      'L' : Begin
          TryNoteLength;
          ResetNoteLength := NoteLength;
        End;
      'M' : Begin
          C := C + 1;
          Case Str [C] Of
            'B' : Raise Exception.Create ('不支持 MB 这一模式.');
            'F' : Raise Exception.Create ('不支持 MF 这一模式');
            'L' : LegatoStaccatoRatio := 0;
            'N' : LegatoStaccatoRatio := 8;
            'S' : LegatoStaccatoRatio := 4;
          Else Raise Exception.Create ('不能识别的模式.M*');
          End;
        End;
      'O' : Begin
          ANumber := GetANumber (Str, C);
          If ANumber > -1 Then Begin
            Octave := TOctave (ANumber);
            ResetOctave := Octave;
          End;
        End;
      'P' : Begin
          TryNoteLength;
          BleepPause (Duration);
          SetNoteLength (ResetNoteLength);
        End;
      End;
    C := C + 1;
    if stop then c:=Length (Str)+1;
    except
    exit;
    end;
End;

Initialization
  SetNoteLength (1);
  ResetNoteLength := NoteLength;
  Octave := 4;
  ResetOctave := Octave;

End.