[[seoane]]

Vuelvo a la carga con mi código inútil

Este que os traigo hoy, se puede considerar como uno de los mayores derroches de CPU de la historia. Se trata de ponerle fondo musical a nuestros programas utilizando el altavoz interno del PC. Solo hay que añadir la siguiente unit a un proyecto, y ella solita se encarga de reproducir la musica en un thread en segundo plano.

Código Delphi [-]
// **********************************************************
// Este código esta basado, y MUCHO, en este otro
// http : / / perso.wanadoo.es/plcl/speaker/playspkr.html
// En la misma pagina podéis encontrar otra canciones.
// **********************************************************
unit Beeper;

interface

uses Windows, SysUtils, Classes;

type
  // Esta la clase del thread que reproduce la cancion
  TBeeper = class(TThread)
  private
    procedure PlayString(Str: String);
    procedure PlayTone(Pitch, Value, Sustain: Integer) ;
  protected
    procedure Execute; override;
  public
    constructor Create; 
    destructor Destroy; override;
  end;

implementation

// Las siguinetes constantes y variables tienen que ver con "cosas" musicales,
// y como de musica no tengo ni idea, pues no se para que sirven.
var
  Octave: Integer;
  Whole: Integer;
  Value: Integer;
  Fill: Integer;
  Octtrack: Boolean;
  Octprefix: Boolean;

const
  HZ = 1000;

  SECS_PER_MIN = 60;
  WHOLE_NOTE = 4;
  MIN_VALUE  = 64;
  DFLT_VALUE = 4;
  FILLTIME = 8;
  STACCATO = 6;
  NORMAL = 7;
  LEGATO = 8;
  DFLT_OCTAVE  = 4;
  MIN_TEMPO  = 32;
  DFLT_TEMPO = 120;
  MAX_TEMPO  = 255;
  NUM_MULT  = 3;
  DENOM_MULT  = 2;
  Notetab: array ['A'..'G'] of Integer = (9, 11, 0, 2, 4, 5, 7);

  OCTAVE_NOTES = 12;
  Pitchtab: array[0..83] of Integer =
(
(*        C     C#    D     D#    E     F     F#    G     G#    A     A#    B*)
(* 0 *)   65,   69,   73,   78,   82,   87,   93,   98,  103,  110,  117,  123,
(* 1 *)  131,  139,  147,  156,  165,  175,  185,  196,  208,  220,  233,  247,
(* 2 *)  262,  277,  294,  311,  330,  349,  370,  392,  415,  440,  466,  494,
(* 3 *)  523,  554,  587,  622,  659,  698,  740,  784,  831,  880,  932,  988,
(* 4 *) 1047, 1109, 1175, 1245, 1319, 1397, 1480, 1568, 1661, 1760, 1865, 1975,
(* 5 *) 2093, 2217, 2349, 2489, 2637, 2794, 2960, 3136, 3322, 3520, 3729, 3951,
(* 6 *) 4186, 4435, 4698, 4978, 5274, 5588, 5920, 6272, 6644, 7040, 7459, 7902
);

  
  // Wish you a Merry Christmas
  Cancion = 'T160' +
            'd gL8gagf# L4ece' +
            'aL8abag L4f#df# bL8b>c< ba' +
            'L4ged8d8 eaf#g2d ggg' +
            'f#2f# gf#e d2a bL8aagg' +
            'L4>d< dd8d8 L4eaf#g1';

{ TBeeper }

// Creamos el trhead y inicializamos las variables
constructor TBeeper.Create;
begin
  inherited Create(FALSE);
  Octave:= DFLT_OCTAVE;
  Whole:= (HZ * SECS_PER_MIN * WHOLE_NOTE) div DFLT_TEMPO;
  Fill:= NORMAL;
  Value:= DFLT_VALUE;
  Octtrack:= FALSE;
  Octprefix:= TRUE;
end;

destructor TBeeper.Destroy;
begin
  inherited;
end;

// Reproducimos la cancion en un bucle hasta que el thread termina
procedure TBeeper.Execute;
begin
  inherited;
  while not Terminated do
  begin
     // Reproducir cancion
     PlayString(Cancion);
     // Hacer una pequeña pausa
     Sleep(200); // Pausa
  end;
end;

// Esta función devuelve el valor de un numero dentro de una cadena de texto.
// La variable i termina apuntando a la ultima cifra del numero.
function GetNum(Str: String; var i: Integer): Integer;
var
  j: Integer;
begin
  // Inicializamos el resultado
  Result:= 0;  
  while TryStrToInt(Copy(Str,i+1,1),j) do
  begin
    Result:= (Result * 10) + j;
    inc(i);
  end;
end;

// Esto reproduce la canción. Básicamente analiza la cadena y la convierte
// en tonos que se envían al altavoz. Otra vez "cosas" musicales, jeje
procedure TBeeper.PlayString(Str: String);
var
  Pitch, OldFill, LastPitch, i: Integer;
  Sustain, Timeval, Tempo: Integer;
begin
  LastPitch:= OCTAVE_NOTES * DFLT_OCTAVE;
  Str:= Uppercase(Str);
  i:= 1;
  while i <= Length(Str) do
  begin
    case Str[i] of
      'A'..'G': begin
        Pitch:= Notetab[Str[i]] + Octave * OCTAVE_NOTES;
        if (Copy(Str,i+1,1) = '#') or  (Copy(Str,i+1,1) = '+') then
        begin
          inc(Pitch);
          inc(i);
        end else if Copy(Str,i+1,1) = '-' then
        begin
          dec(Pitch);
          inc(i);
        end;
        if Octtrack and not Octprefix then
        begin
          if abs(Pitch-Lastpitch) > abs(Pitch+OCTAVE_NOTES-LastPitch) then
          begin
              inc(Octave);
              inc(Pitch,OCTAVE_NOTES);
          end;
          if abs(Pitch-Lastpitch) > abs((Pitch-OCTAVE_NOTES)-LastPitch) then
          begin
              dec(Octave);
              dec(Pitch,OCTAVE_NOTES);
          end;
        end;
        Octprefix:= FALSE;
        LastPitch:= Pitch;
        Timeval:= GetNum(Str,i);
        if (Timeval <= 0) or (Timeval > MIN_VALUE) then
          Timeval:= Value;
        Sustain:= 0;
        while Copy(Str,i+1,1) = '.' do
        begin
          inc(Sustain);
          inc(i);
        end;
        Oldfill:= Fill;
        if Copy(Str,i+1,1) = '_' then
        begin
          Fill:= LEGATO;
          inc(i);
        end;
        Playtone(Pitch, Timeval, Sustain);
        Fill:= OldFill;
      end;
      'O': begin
        if Copy(Str,i+1,1) = 'N' then
        begin
          Octprefix:= FALSE;
          Octtrack:= FALSE;
          inc(i);
        end else if Copy(Str,i+1,1) = 'L' then
        begin
          Octtrack:= TRUE;
          inc(i);
        end else
        begin
          Octave:= GetNum(Str,i);
          if Octave >= (High(Pitchtab) div OCTAVE_NOTES) then
            Octave:= DFLT_OCTAVE;
          Octprefix:= TRUE;
        end;
      end;
      '>': begin
        if (Octave < (High(Pitchtab) div OCTAVE_NOTES) - 1) then
          inc(Octave);
          Octprefix:= TRUE;
        end;
      '<': begin
          if (Octave > 0) then
            dec(Octave);
          Octprefix:= TRUE;
      end;
      'N': begin
        Pitch:= GetNum(Str,i);
        Sustain:= 0;
        while Copy(Str,i+1,1) = '.' do
        begin
          inc(i);
          inc(Sustain);
        end;
        Oldfill:= Fill;
        if Copy(Str,i+1,1) = '_' then
        begin
          Fill:= LEGATO;
          inc(i);
        end;
        Playtone(Pitch - 1, Value, Sustain);
        Fill:= OldFill;
      end;
      'L': begin
        Value:= GetNum(Str,i);
        if (Value <= 0) or (Value > MIN_VALUE) then
          Value:= DFLT_VALUE;
      end;
      'P','~': begin
        Timeval:= Getnum(Str,i);
        if (Timeval <= 0) or (Timeval > MIN_VALUE) then
          Timeval:= Value;
        Sustain:= 0;
        while Copy(Str,i+1,1) = '.' do
        begin
          inc(i);
          inc(Sustain);
        end;
        PlayTone(-1, Timeval, Sustain);
      end;
      'T': begin
        Tempo:= GetNum(Str,i);
        if (Tempo < MIN_TEMPO) or (Tempo > MAX_TEMPO) then
          Tempo:= DFLT_TEMPO;
        Whole:= (HZ * SECS_PER_MIN * WHOLE_NOTE) div tempo;
      end;
      'M': begin
         if Copy(Str,i+1,1) = 'N' then
          begin
            Fill:= NORMAL;
            inc(i);
          end else if Copy(Str,i+1,1) = 'L' then
          begin
            Fill:= LEGATO;
            inc(i);
          end else if Copy(Str,i+1,1) = 'S' then
          begin
            Fill:= STACCATO;
            inc(i);
          end;
      end;
    end;
    inc(i);
  end;
end;

// Esta funcion envia un tono al altavoz
procedure TBeeper.PlayTone(Pitch, Value, Sustain: Integer);
var
  Sound, Silence, Snum, Sdenom: Integer;
begin
  Snum:= 1;
  Sdenom:= 1;
  while Sustain > 0 do
  begin
    Snum:= Snum * NUM_MULT;
    Sdenom:= Sdenom * DENOM_MULT;
    dec(Sustain);
  end;
  if Pitch = -1 then
    Sleep(Whole * Snum div (Value * Sdenom))
  else begin
    Sound:= (Whole * Snum) div (Value * Sdenom)
          - (Whole * (FILLTIME - Fill)) div (Value * FILLTIME);
    Silence:= Whole * (FILLTIME - Fill) * Snum div (FILLTIME * Value * Sdenom);
  Windows.Beep(Pitchtab[Pitch],Sound);
  if Fill <> LEGATO then
    Sleep(Silence);
  end;
end;

// Aqui creamos el thread al cargarse la unidad
initialization
  with TBeeper.Create do
    // Le indicamos que se destruya al terminarr
    FreeOnTerminate:= TRUE;
finalization

end.

El código es una adaptación a Delphi del encontrado aquí:
http://perso.wanadoo.es/plcl/speaker/playspkr.html