[Back to ANSI SWAG index] [Back to Main SWAG index] [Original]

    (*
      A unit to implement FULL ANSI output.  Useful for a BBS or DOOR program
      where you would want to send string out over the modem.  Simply call
      your modem routine to :

                 SENDSTRING(port,ANSIGoToXY(1,1))

      Would reposition the cursor on the remote terminal.  Get the idea ??

      The thing will EVEN play ANSI music !!

      Gayle Davis 1/24/94

    1) Added allowance for "esc[M " as a valid music prefix.  It is used
       occasionally.

    2) Changed the effect of "esc[0m" from "NormVideo" to "textattr:=7",
       which is what "esc[0m" literally means.  NormVideo just restores
       startup colors, which could be anything.

    3) Added "HighVideo" line to take effect *immediately* when "esc[1m"
       ("Bold") is encountered.  Otherwise, "esc[1m" by itself would not
       activate "Bold".

    4) Changed "{blink on}" from "5 : textattr := textattr +  blink;"
    .                            "5 : textattr := textattr or blink;"
    .                                                      ^^
       The "blink ON" was turning blink OFF when blink was turned ON
       with blink already ON.

    5) Added "textattr and blink" to preserve blink status in the
       "{general foregrounds}" subroutine.

    6) Changed default tempo assignment from "Min1:=120" to "Min1:=120/4"
       in order to be consistent with the way the unit deals with tempo.

    7) Added an initialization line of "TextAttr:=7;" to allow for the
       fact that some ANSI artists assume that the screen is normal white
       on black to start with.  (My screen is NOT that color!)

    DAVID DANIEL ANDERSON
    09/08/94

    *)

    UNIT AnsiIO;

    INTERFACE

       USES
          CRT,
          Graph3;  { GRAPH3.TPU is included in the BORLAND distribution diskettes }

       FUNCTION ANSIClrScr : string;
       FUNCTION ANSIClrEol : string;
       FUNCTION ANSIGotoXY(X, Y : word) : string;
       FUNCTION ANSIUp(Lines : word) : string;
       FUNCTION ANSIDown(Lines : word) : string;
       FUNCTION ANSIRight(Cols : word) : string;
       FUNCTION ANSILeft(Cols : word) : string;
       FUNCTION ANSIColor(Fg, Bg : integer) : string;
       FUNCTION ANSIMusic(s : string) : string;
       PROCEDURE ANSIWrite(s : string);
       PROCEDURE ANSIWriteLn(s : string);

    IMPLEMENTATION

       CONST
          ColorArray : array[0..7] of integer = (0,4,2,6,1,5,3,7);

       VAR
          Bold, TruncateLines : boolean;
          Vari, Octave, Numb : integer;
          Test, Dly, Intern, DlyKeep : longInt;
          Flager, ChartoPlay : char;
          Typom, Min1, Adder : real;

    {****************************************************************************}
    {***                                                                      ***}
    {***       Function that returns the ANSI code for a Clear Screen.        ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSIClrScr : string;
          BEGIN
             ANSIClrScr := #27+'[2J';
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***    Function that returns the ANSI code for a Clear to End of Line.   ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSIClrEol : string;
          BEGIN
             ANSIClrEol := #27+'[K';
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***   Function that returns the ANSI code to move the cursor to (X,Y).   ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSIGotoXY(X, Y : word) : string;
          VAR
             XStr, YStr : string;

          BEGIN
             str(X,XStr);
             str(Y,YStr);
             ANSIGotoXY := #27+'['+YStr+';'+XStr+'H';
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***  Function that returns the ANSI code to move the cursor up "Lines"   ***}
    {***                         number of lines.                             ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSIUp(Lines : word) : string;
          VAR
             LinesStr : string;

          BEGIN
             str(Lines,LinesStr);
             ANSIUp := #27+'['+LinesStr+'A';
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***  Function that returns the ANSI code to move the cursor down "Lines" ***}
    {***                        number of lines.                              ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSIDown(Lines : word) : string;
          VAR
             LinesStr : string;

          BEGIN
             str(Lines,LinesStr);
             ANSIDown := #27+'['+LinesStr+'B';
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***     Function that returns the ANSI code to move the cursor "Cols"    ***}
    {***                         positions forward.                           ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSIRight(Cols : word) : string;
          VAR
             ColsStr : string;

          BEGIN
             str(Cols,ColsStr);
             ANSIRight := #27+'['+ColsStr+'C';
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***     Function that returns the ANSI code to move the cursor "Cols"    ***}
    {***                        positions backward.                           ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSILeft(Cols : word) : string;
          VAR
             ColsStr : string;

          BEGIN
             str(Cols,ColsStr);
             ANSILeft := #27+'['+ColsStr+'D';
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***    Function that returns the ANSI code to change the screen color    ***}
    {***             to an "Fg" foreground and a "Bg" background.             ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSIColor(Fg, Bg : integer) : string;
          VAR
             FgStr, BgStr, Temp : string;

          BEGIN
             str(ColorArray[Fg mod 8] + 30, FgStr);
             str(ColorArray[Bg mod 8] + 40, BgStr);
             Temp := #27+'[';
             if Bg > 7 then
                Temp := Temp+'5;'
             else
                Temp := Temp+'0;';
             if Fg > 7 then
                Temp := Temp+'1;'
             else
                Temp := Temp+'2;';
             ANSIColor := Temp+FgStr+';'+BgStr+'m';
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {*** Function that returns an ANSI code representing a music string ("s") ***}
    {***                                                                      ***}
    {****************************************************************************}
       FUNCTION ANSIMusic(s : string) : string;

          BEGIN
             ANSIMusic := #27+'[MF'+s+#14;
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***  Procedure that simulates BASIC's "PLAY" procedure.  Will also work  ***}
    {***      with ANSI codes.  Taken from PC Magazine Volume 9 Number 3      ***}
    {***                                                                      ***}
    {****************************************************************************}
       PROCEDURE Play(SoundC : string);
          FUNCTION IsNumber(ch : char) : boolean;
             BEGIN
                IsNumber := (CH >= '0') AND (CH <= '9');
             END;

       {Converts a string to an integer}
          FUNCTION value(s : string) : integer;
             VAR
                ss, sss : integer;
             BEGIN
                Val(s, ss, sss);
                value := ss;
             END;

       {Plays the selected note}
          PROCEDURE sounder(key : char; flag : char);
             VAR
                old, New, new2 : Real;
             BEGIN
                adder := 1;
                old := dly;
                New := dly;
                intern := Pos(key, 'C D E F G A B')-1;
                IF (flag = '+') AND (key <> 'E') AND (key <> 'B') {See if note}
                   THEN Inc(intern);                              {is sharped }
                IF (flag = '-') AND (key <> 'F') AND (key <> 'C')
                   THEN Dec(intern);                              {or a flat. }
                WHILE SoundC[vari+1] = '.' DO
                   BEGIN
                      Inc(vari);
                      adder := adder/2;
                      New := New+(old*adder);
                   END;
                new2 := (New/typom)*(1-typom);
                sound(Round(Exp((octave+intern/12)*Ln(2)))); {Play the note}
                Delay(Trunc(New));
                Nosound;
                Delay(Trunc(new2));
             END;

       {Calculate delay for a specified note length}
          FUNCTION delayer1 : integer;
             BEGIN
                numb := value(SoundC[vari+1]);
                delayer1 := Trunc((60000/(numb*min1))*typom);
             END;

       {Used as above, except reads a number >10}

          FUNCTION delayer2 : Integer;
             BEGIN
                numb := value(SoundC[vari+1]+SoundC[vari+2]);
                delayer2 := Trunc((60000/(numb*min1))*typom);
             END;

          BEGIN                           {Play}
             SoundC := SoundC+' ';
             FOR vari := 1 TO Length(SoundC) DO
                BEGIN                     {Go through entire string}
                   SoundC[vari] := Upcase(SoundC[vari]);
                   CASE SoundC[vari] OF
    {Check to see}    'C','D','E',
    {if char is a}    'F','G','A',
    {note}            'B' : BEGIN
                               flager := ' ';
                               dlykeep := dly;
                               chartoplay := SoundC[vari];
                               IF (SoundC[vari+1] = '-') OR
                                  (SoundC[vari+1] = '+') THEN
    {Check for flats & sharps}    BEGIN
                                     flager := SoundC[vari+1];
                                     Inc(vari);
                                  END;
                               IF IsNumber(SoundC[vari+1]) THEN
                                  BEGIN
                                     IF IsNumber(SoundC[vari+2]) THEN
                                        BEGIN
                                           test := delayer2;
    {Make sure # is legal}                 IF numb < 65 THEN
                                              dly := test;
                                           Inc(vari, 2);
                                        END
                                     ELSE
                                        BEGIN
                                           test := delayer1;
    {Make sure # is legal}                 IF numb > 0 THEN
                                              dly := test;
                                           Inc(vari);
                                        END;
                                  END;
                               sounder(chartoplay, flager);
                               dly := dlykeep;
                            END;
    {Check for}       'O' : BEGIN
    {octave change}            Inc(vari);
                               CASE SoundC[vari] OF
                                  '-' : IF octave > 1 THEN Dec(octave);
                                  '+' : IF octave < 7 THEN Inc(octave);
                                  '1','2','3',
                                  '4','5','6',
                                  '7' : octave := value(SoundC[vari])+4;
                               ELSE Dec(vari);
                               END;
                            END;
    {Check for a}     'L' : IF IsNumber(SoundC[vari+1]) THEN
    {change in length}         BEGIN
    {for notes}                   IF IsNumber(SoundC[vari+2]) THEN
                                     BEGIN
                                        test := delayer2;
                                        IF numb < 65 THEN
    {Make sure # is legal}                 dly := test;
                                        Inc(vari, 2);
                                     END
                                  ELSE
                                     BEGIN
                                        test := delayer1;
                                        IF numb > 0 THEN
    {Make sure # is legal}                 dly := test;
                                        Inc(vari);
                                     END;
                               END;
    {Check for pause} 'P' : IF IsNumber(SoundC[vari+1]) THEN
    {and it's length}          BEGIN
                                  IF IsNumber(SoundC[vari+2]) THEN
                                     BEGIN
                                        test := delayer2;
                                        IF numb < 65 THEN
    {Make sure # is legal}                 Delay(test);
                                        Inc(vari, 2);
                                     END
                                  ELSE
                                     BEGIN
                                        test := delayer1;
                                        IF numb > 0 THEN
    {Make sure # is legal}                 Delay(test);
                                        Inc(vari);
                                     END;
                               END;
    {Check for}       'T' : IF IsNumber(SoundC[vari+1]) AND
    {tempo change}             IsNumber(SoundC[vari+2]) THEN
                               BEGIN
                                  IF IsNumber(SoundC[vari+3]) THEN
                                     BEGIN
                                        min1 := value(SoundC[vari+1]+
                                                SoundC[vari+2]+SoundC[vari+3]);
                                        Inc(vari, 3);
                                        IF min1 > 255 THEN
    {Make sure # isn't too big}            min1 := 255;
                                     END
                                  ELSE
                                     BEGIN
                                        min1 := value(SoundC[vari+1]+
                                                SoundC[vari+2]);
                                        IF min1 < 32 THEN
    {Make sure # isn't too small}          min1 := 32;
                                     END;
                                  min1 := min1/4;
                               END;
    {Check for music} 'M' : BEGIN
    {type}                     Inc(vari);
                               CASE Upcase(SoundC[vari]) OF
    {Normal}                      'N' : typom := 7/8;
    {Legato}                      'L' : typom := 1;
    {Staccato}                    'S' : typom := 3/4;
                               END;
                            END;
                   END;
                END;
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***    Procedure to process string "s" and write its contents to the     ***}
    {***          screen, interpreting ANSI codes as it goes along.           ***}
    {***                                                                      ***}
    {****************************************************************************}
       PROCEDURE ANSIWrite(s : string);
          VAR
             SaveX, SaveY : byte;
             MusicStr : string;
             MusicPos : integer;

       {*** Procedure to process the actual ANSI sequence ***}
          PROCEDURE ProcessEsc;
             VAR
                DeleteNum : integer;
                ts : string[5];
                Num : array[0..10] of shortint;
                Color : integer;

             LABEL
                loop;

          {*** Procedure to extract a parameter from the ANSI sequence and ***}
          {*** place it in "Num" ***}
             PROCEDURE GetNum(cx : byte);
                VAR
                   code : integer;
                BEGIN
                   ts := '';
                   WHILE (s[1] in ['0'..'9']) and (length(s) > 0) DO
                      BEGIN
                         ts := ts + s[1];
                         Delete(s,1,1);
                      END;
                   val(ts,Num[cx],code)
                END;

             BEGIN
                IF s[2] <> '[' THEN exit;
                Delete(s,1,2);
                IF (UpCase(s[1]) = 'M') and (UpCase(s[2]) in ['F','B',#32]) THEN
    {| Added allowance for "esc[M " as a valid music prefix in line above. DDA|}

    {play music}   BEGIN
                      Delete(s,1,2);
                      MusicPos := pos(#14,s);
                      Play(copy(s,1,MusicPos-1));
                      DeleteNum := MusicPos;
                      Goto Loop;
                   END;
                fillchar(Num,sizeof(Num),#0);
                GetNum(0);
                DeleteNum := 1;
                WHILE (s[1] = ';') and (DeleteNum < 11) DO
                   BEGIN
                      Delete(s,1,1);
                      GetNum(DeleteNum);
                      DeleteNum  := DeleteNum + 1;
                   END;
                CASE UpCase(s[1]) of
    {move up}      'A' : BEGIN
                            if Num[0] = 0 THEN
                               Num[0] := 1;
                            WHILE Num[0] > 0 DO
                               BEGIN
                                  GotoXY(wherex,wherey - 1);
                                  Num[0] := Num[0] - 1;
                               END;
                            DeleteNum := 1;
                         END;
    {move down}    'B' : BEGIN
                            if Num[0] = 0 THEN
                               Num[0] := 1;
                            WHILE Num[0] > 0 DO
                               BEGIN
                                  GotoXY(wherex,wherey + 1);
                                  Num[0] := Num[0] - 1;
                               END;
                            DeleteNum := 1;
                         END;
    {move right}   'C' : BEGIN
                            if Num[0] = 0 THEN
                               Num[0] := 1;
                            WHILE Num[0] > 0 DO
                               BEGIN
                                  GotoXY(wherex + 1,wherey);
                                  Num[0] := Num[0] - 1;
                               END;
                            DeleteNum := 1;
                         END;
    {move left}    'D' : BEGIN
                            if Num[0] = 0 THEN
                               Num[0] := 1;
                            WHILE Num[0] > 0 DO
                               BEGIN
                                  GotoXY(wherex - 1,wherey);
                                  Num[0] := Num[0] - 1;
                               END;
                            DeleteNum := 1;
                         END;
    {goto x,y}     'H',
                   'F' : BEGIN
                            if (Num[0] = 0) THEN
                               Num[0] := 1;
                            if (Num[1] = 0) THEN
                               Num[1] := 1;
                            GotoXY(Num[1],Num[0]);
                            DeleteNum := 1;
                         END;
    {save current} 'S' : BEGIN
    {position}              SaveX := wherex;
                            SaveY := wherey;
                            DeleteNum := 1;
                         END;
    {restore}      'U' : BEGIN
    {saved position}        GotoXY(SaveX,SaveY);
                            DeleteNum := 1;
                         END;
    {clear screen} 'J' : BEGIN
                            if Num[0] = 2 THEN
                               ClrScr;
                            DeleteNum := 1;
                         END;
    {clear from}   'K' : BEGIN
    {cursor position}       ClrEOL;
    {to end of line}        DeleteNum := 1;
                         END;
    {change}       'M' : BEGIN
    {colors and}            DeleteNum := 0;
    {attributes}            WHILE (Num[DeleteNum] <> 0) or (DeleteNum = 0) DO
                               BEGIN
                                  CASE Num[DeleteNum] of
    {all attributes off}             0 : BEGIN
    {ie. normal white on black}             textattr:=7;
    {| Changed above line from "NormVideo", which only resets attributes to
       whatever the cursor attribute at startup was.  Changed to textattr:=7
       since "esc[0..m" actually equals "textattr:=7". DDA|}

                                            Bold := false;
                                         END;
    {bold on}                        1 : BEGIN
                                            Bold := true;
                                            HighVideo;
    {| Added "HighVideo" line, since "esc[1m" by itself would not otherwise
       activate "Bold". DDA|}

                                         END;
    {blink on}                       5 : textattr := textattr or blink;
    {| Changed from "textattr+blink", which would turn blink off if it was
       already on. DDA|}

    {reverse on}                     7 : textattr := ((textattr and $07) shl 4) +
                                         ((textattr and $70) shr 4);
    {invisible on}                   8 : textattr := 0;
    {general foregrounds}            30..
                                     37 : BEGIN
                                             color := ColorArray[Num[DeleteNum]
                                                      - 30];
                                             IF Bold THEN
                                                color := color + 8;
                                             textcolor((textattr and blink)+color);
    {| Added "textattr and blink" to preserve blink status. DDA|}

                                          END;
    {general backgrounds}            40..
                                     47 : textbackground(
                                          ColorArray[Num[DeleteNum] - 40]);
                                  END;
                                  DeleteNum := DeleteNum + 1;
                               END;
                            DeleteNum := 1;
                         END;
    {change text}  '=',
    {modes}        '?' : BEGIN
                            Delete(s,1,1);
                            GetNum(0);
                            if UpCase(s[1]) = 'H' THEN
                               BEGIN
                                  CASE Num[0] of
                                     0 : TextMode(bw40);
                                     1 : TextMode(co40);
                                     2 : TextMode(bw80);
                                     3 : TextMode(co80);
                                     4 : GraphColorMode;
                                     5 : GraphMode;
                                     6 : HiRes;
                                     7 : TruncateLines := false;
                                  END;
                               END;
                            if UpCase(s[1]) = 'L' THEN
                               if Num[0] = 7 THEN
                                  TruncateLines := true;
                            DeleteNum := 1;
                         END;
                END;
    loop:       Delete(s,1,DeleteNum);
             END;

          BEGIN
             WHILE length(s) > 0 DO
                BEGIN
                   if s[1] = #27 THEN
                      ProcessEsc
                   else
                      BEGIN
                         Write(s[1]);
                         Delete(s,1,1);
                      END;
                END;
          END;

    {****************************************************************************}
    {***                                                                      ***}
    {***         Procedure that calls ANSIWrite, then line feeds.             ***}
    {***                                                                      ***}
    {****************************************************************************}
       PROCEDURE ANSIWriteLn(s : string);
          BEGIN
             ANSIWrite(s);
             WriteLn;
          END;

       BEGIN
          Octave := 4;
          ChartoPlay := 'N';
          Typom := 7/8;
          Min1 := 120/4;
    {| Added "/4" to be consistent with the part of the "Play" procedure
       that reads and sets the tempo. DDA|}

          TruncateLines := false;
          TextAttr:=7;
    {| Added above line to account for the fact that some ANSI artists just
       assume that the screen is normal white on black to start with.  DDA|}

       END.

[Back to ANSI SWAG index] [Back to Main SWAG index] [Original]