## www.lawebdelprogramador.com ##
## Respuesta a la pregunta 43822 - Pascal/TurboPascal ##


{***********************************************************************}
{                                                                       }
{   Üßß  ÛßßÜ ÜßßÜ ÛßßÜ ÜßßÜ Üßß  ÜßßÜ ÛÜ Û                             }
{   Û ßÛ ÛßÛ  ÛßßÛ ÛßßÜ ÛßßÛ  ßßÜ Û  Û Û ßÛ                             }
{    ßß  ß  ß ß  ß ßßß  ß  ß ßßß   ßß  ß  ß                             }
{   Programa que emula el funcionamiento de un ¢rgano electr¢nico,      }
{   almacena los sonidos en una tabla y luego los reproduce.            }
{                                                                       }
{   ÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÛ                                  }
{   Û (c) Manuel Carnero Ripalda     Û                                  }
{   Û S bado, 7 de Agosto de 1999    Û                                  }
{   Û Peralta de Navarra (Espa€a)    Û                                  }
{   ÛÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÛ                                  }
{***********************************************************************}

PROGRAM Organo;
USES    Crt, Dos, Graph;
CONST   nota : array [0..12] of string[4] =
('-s-','Do','Do#','Re','Re#','Mi','Fa','Fa#','Sol','Sol#','La','La#','Si');
        tono : array [0..12] of integer =
      (0,1000,1062,1125,1187,1250,1330,1415,1500,1583,1666,1763,1860);
{         1    2    3    4    5    6    7    8    9    10   11   12  }
{         Do   (W)  Re   (E)  Mi   Fa   (T)  Sol  (Y)  La   (U)  Si  }
{         (A)  Do#  (S)  Re#  (D)  (F)  Fa#  (G)  Sol# (H)  La#  (J) }
        max  =  2000;
TYPE    TpGrab  =  word;
VAR     i            :integer;
        t,j          :TpGrab;
        k            :char;
        bufp         :array[0..max] of byte;
        buft         :array[0..max] of TpGrab;
        a,n,p,p60    :byte;
        w,x,y,z      :byte;
        Oir,Grabar   :boolean;


FUNCTION Inkey :char;
BEGIN
  IF KeyPressed THEN Inkey:=ReadKey ELSE Inkey:=#255;
END;

PROCEDURE Rec;
VAR       x,y  : integer;
BEGIN
  IF a=p THEN Inc(t)
  ELSE BEGIN
    IF j&ltmax THEN BEGIN
      inc(j);
      bufp[j]:=a;
      buft[j]:=t;
      buft[0]:=j;
      a:=p; t:=0;
    END;
  END;
END;

PROCEDURE Play;
VAR       x,y  : integer;
BEGIN
  IF Oir THEN BEGIN
    IF t=0 THEN BEGIN
      IF j&ltbuft[0] THEN BEGIN
        Inc(j);
        t:=buft[j];
        p60:=bufp[j];
      END
      ELSE Oir:=False;
    END
    ELSE BEGIN
      Dec(t);
    END;
  END;
END;

BEGIN
  TextColor(White); TextBackground(Blue);
  ClrScr;

  TextColor(Blue); TextBackground(Cyan);
  GotoXY(1,24);
  FOR n:=1 TO 20 DO Write('    ');
  GotoXY(2,24);
  Write('F1 - Stop ³ F2 - Rec ³ F3 - Play ³');

  TextColor(Black); TextBackground(White);
  FOR n:=0 TO 3 DO BEGIN
    GotoXY(14*n+10,12);Write(' Û Û ³ Û Û Û ³');
    GotoXY(14*n+10,13);Write(' Û Û ³ Û Û Û ³');
    GotoXY(14*n+10,14);Write(' ³ ³ ³ ³ ³ ³ ³');
  END;
  TextColor(White); TextBackground(Blue);
  GotoXY(2,2);Write('Oct   Nota  ');
  Oir:=FALSE; Grabar:=False; t:=0; a:=Port[$60]; x:=3;z:=0;n:=0; j:=0;i:=120;
  REPEAT
    k:=Inkey;
    IF k=#0 THEN BEGIN
      k:=Inkey;
      CASE k OF
       #59  : BEGIN
                Oir:=FALSE; Grabar:=FALSE;
              END;
       #60  : BEGIN
                Oir:=FALSE; Grabar:=TRUE;
                a:=n; j:=0; t:=0;
                a:=Port[$60];
                REPEAT
                  p:=Port[$60];
                UNTIL a<&gtp;
              END;
       #61  : BEGIN
                Oir:=TRUE; Grabar:=FALSE;
                a:=n; j:=0; t:=0;
              END;
      END;
    END;
    IF Oir THEN Play;
    IF Grabar THEN Rec;
    IF Oir THEN p:=p60 ELSE p:=Port[$60];
    IF (p AND 128)=0 THEN BEGIN
      i:=500;
      CASE p OF
        16  : n:=$11; {Do  }     { PRIMERA OCTAVA = "Q" a "U" }
         03 : n:=$12; {Do# }
        17  : n:=$13; {Re  }
         04 : n:=$14; {Re# }
        18  : n:=$15; {Mi  }
        19  : n:=$16; {Fa  }
         06 : n:=$17; {Fa# }
        20  : n:=$18; {Sol }
         07 : n:=$19; {Sol#}
        21  : n:=$1A; {La  }
         08 : n:=$1B; {La# }
        22  : n:=$1C; {Si  }
        23  : n:=$21; {Do  }     { SEGUNDA OCTAVA = "I" a "P" }
         10 : n:=$22; {Do# }
        24  : n:=$23; {Re  }
         11 : n:=$24; {Re# }
        25  : n:=$25; {Mi  }

        44  : n:=$18; {Sol }     { PRIMERA OCTAVA = "Z" a "C" }
         31 : n:=$19; {Sol#}
        45  : n:=$1A; {La  }
         32 : n:=$1B; {La# }
        46  : n:=$1C; {Si  }
        47  : n:=$21; {Do  }     { SEGUNDA OCTAVA = "V" a "-" }
         34 : n:=$22; {Do# }
        48  : n:=$23; {Re  }
         35 : n:=$24; {Re# }
        49  : n:=$25; {Mi  }
        50  : n:=$26; {Fa  }
         37 : n:=$27; {Fa# }
        51  : n:=$28; {Sol }
         38 : n:=$29; {Sol#}
        52  : n:=$2A; {La  }
         39 : n:=$2B; {La# }
        53  : n:=$2C; {Si  }
        ELSE BEGIN
          IF NOT(Grabar) THEN BEGIN
            n:=0;
            NoSound;
          END;
        END;
      END;
    END
    ELSE BEGIN
      Dec(i);
      IF i=0 THEN BEGIN
        n:=0;
        NoSound;
      END;
    END;
    Sound((n DIV 16)*tono[n MOD 16]); { Sound(nota[n]+2000);Delay(i); Sound(nota[n]+1000);Delay(i);}
    GotoXY(1,1); Write(n DIV 16:3,'  ',nota[n MOD 16]:5,'  ');
    IF Oir THEN Write('Play ',j:4)
    ELSE IF Grabar THEN Write('Rec  ',j:4) ELSE Write('Stop     ');
    IF (n=z) THEN BEGIN
      w:=(n MOD 16)-1; IF w&gt4 THEN Inc(w);
      TextColor(Red);
      x:=14*(n DIV 16)+10+w;
      w:=(n MOD 16); IF w&gt5 THEN Dec(w);
      IF (w MOD 2)=0 THEN y:=Black ELSE y:=LightGray;
      GotoXY(x,13);IF (x&gt10) THEN Write('Û');
    END
    ELSE BEGIN
      TextColor(y);
      GotoXY(x,13);IF (x&gt10) THEN Write('Û');
      z:=n;
    END;
  UNTIL k=#27;
  NoSound;
END.

## Manolo Carnero ##
## mcarnero@terra.es ##