Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBBS/ECO_ANSI.PAS

Pascal/Delphi Source File | 1993-03-08 | 13.3 KB | 415 lines

unit eco_ansi;
interface
uses
  dos, crt

  ;


var
  ansi                : text;     { ansi is the name of the device }
  wrap                : boolean;  { true if cursor should wrap }
  reportedx,
  reportedy           : word;     { x,y reported }

  { hook for handling control chars i.e. ch < space }
  writehook           : procedure(ch : char);

  { hook for implementing your own device status report procedure }
  replyhook           : procedure(st : string);

  { hook for handling simultaneous writes to comport and screen }
  bbshook       : procedure (ch : char);

function in_ansi    : boolean;    { true if a sequence is pending }
procedure ansiwrite(s: string);

procedure assignansi(var f : text); { use like assigncrt }

implementation

type
  states              = (waiting, bracket, get_args, get_param, eat_semi,
                         get_string, in_param, get_music);
const
  st                  : string = '';
  paramarr            : array[1..10] of word = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
  params              : word = 0; { number of parameters }
  nextstate           : states = waiting; { next state for the parser }
  reverse             : boolean = false; { true if text attributes are reversed }

var
  quote               : char;
  savedx, savedy      : word;

  function in_ansi    : boolean;  { true if a sequence is pending }
  begin
    in_ansi := (nextstate <> waiting) and (nextstate <> bracket);
  end {in_ansi} ;


  function ms(w: word): string;
  var s: string;
  begin
    str(w,s);
    ms := s;
  end;


  {$F+}
  procedure report(st : string);
  {$F-}
  begin
    {stuffstring(st);}
  end;


  {$F+}
  procedure writechar(ch : char);
  {$F-}
  begin
    case ch of
      #7 : begin
        nosound;
        sound(500);
        delay(50);
        nosound;
        delay(50);
      end;
      #8 : if (wherex > 1) then write(#8' '#8);
      #9 : if (wherex < 71) then repeat
        gotoxy(wherex + 1, wherey);
      until (wherex mod 8 = 1);
      else write(ch);
    end { case }
  end; { writechar }

  {$F+}
  procedure dummy(st : string);
    {$F-}
  begin
  end;



  procedure ansiwrite(s: string);
  var
    i  : word;
    j  : byte;
    ch : char;

  label command, ending;

  begin
    for j := 1 to length(s) do begin
      ch := s[j];
      if ch = #27 then begin
        nextstate := bracket;
        goto ending;
      end;
      case nextstate of
        waiting : if (ch > ' ') then write(ch) else writehook(ch);
        bracket : begin
          if ch <> '[' then begin
            nextstate := waiting;
            if (ch > ' ') then write(ch)
            else writehook(ch);
            goto ending;
          end;
          st := '';
          params := 1;
          fillchar(paramarr, 10, 0);
          nextstate := get_args;
        end;
        get_args, get_param, eat_semi : begin
          {$IFNDEF Music}
          if (nextstate = get_args) and ((ch = '=') or (ch = '?')) then begin
            nextstate := get_param;
            goto ending;
          end;
          {$ELSE}
          if (nextstate = get_args) then case ch of
            '=', '?' : begin
              nextstate := get_param;
              goto ending;
            end;
            'M' : begin
              nextstate := get_music;
              goto ending;
            end;
          end; {case}
          {$ENDIF}
          if (nextstate = eat_semi) and (ch = ';') then begin
            if params < 10 then inc(params);
            nextstate := get_param;
            exit;
          end;
          case ch of
            '0'..'9' : begin
              paramarr[params] := ord(ch) - ord('0');
              nextstate := in_param;
            end;
            ';' : begin
              if params < 10 then inc(params);
              nextstate := get_param;
            end;
            '"', '''' : begin
              quote := ch;
              st := st + ch;
              nextstate := get_string;
            end;
            else goto command;
          end {case ch} ;
        end;
        get_string : begin
          st := st + ch;
          if ch <> quote then nextstate := get_string else
            nextstate := eat_semi;
        end;
        in_param : begin                 { last char was a digit }
          { looking for more digits, a semicolon, or a command char }
          case ch of
            '0'..'9' : begin
              paramarr[params] := paramarr[params] * 10 + ord(ch) - ord('0');
              nextstate := in_param;
              goto ending;
            end;
            ';' : begin
              if params < 10 then inc(params);
              nextstate := eat_semi;
              goto ending;
            end;
          end; {case ch}
command:
          nextstate := waiting;
          case ch of
            { note: the order of commands is optimized for execution speed }
            'm' : begin                {sgr}
              for i := 1 to params do begin
                if reverse then textattr := textattr shr 4 + textattr shl 4;
                case paramarr[i] of
                  0 : begin reverse := false; textattr := 7 end;
                  1 : textattr := textattr and $ff or $08;
                  2 : textattr := textattr and $f7 or $00;
                  4 : textattr := textattr and $f8 or $01;
                  5 : textattr := textattr or $80;
                  7 : if not reverse then begin
                    { TextAttr := TextAttr shr 4 + TextAttr shl 4;}
                    reverse := true;
                  end;
                  22 : textattr := textattr and $f7 or $00;
                  24 : textattr := textattr and $f8 or $04;
                  25 : textattr := textattr and $7f or $00;
                  27 : if reverse then begin
                    reverse := false;
                    { TextAttr := TextAttr shr 4 + TextAttr shl 4; }
                  end;
                  30 : textattr := textattr and $f8 or $00;
                  31 : textattr := textattr and $f8 or $04;
                  32 : textattr := textattr and $f8 or $02;
                  33 : textattr := textattr and $f8 or $06;
                  34 : textattr := textattr and $f8 or $01;
                  35 : textattr := textattr and $f8 or $05;
                  36 : textattr := textattr and $f8 or $03;
                  37 : textattr := textattr and $f8 or $07;
                  40 : textattr := textattr and $8f or $00;
                  41 : textattr := textattr and $8f or $40;
                  42 : textattr := textattr and $8f or $20;
                  43 : textattr := textattr and $8f or $60;
                  44 : textattr := textattr and $8f or $10;
                  45 : textattr := textattr and $8f or $50;
                  46 : textattr := textattr and $8f or $30;
                  47 : textattr := textattr and $8f or $70;
                end; { case }
                { fixup for reverse }
                if reverse then textattr := textattr shr 4 + textattr shl 4;
              end;
            end;
            'A' : begin                {cuu}
              if paramarr[1] = 0 then paramarr[1] := 1;
              if (wherey - paramarr[1] >= 1) then gotoxy(
                wherex, wherey - paramarr[1]
              ) else gotoxy(wherex, hi(windmax));
            end;
            'B' : begin                {cud}
              if paramarr[1] = 0 then paramarr[1] := 1;
              if (wherey + paramarr[1] <= hi(windmax)) then gotoxy(
                wherex, wherey + paramarr[1]
              ) else gotoxy(wherex, 1);
            end;
            'C' : begin                {cuf}
              if paramarr[1] = 0 then paramarr[1] := 1;
              if wherex + paramarr[1] <= lo(windmax) then gotoxy(
                wherex + paramarr[1], wherey
              ) else gotoxy(lo(windmax), wherey);
            end;
            'D' : begin                 {cub}
              if paramarr[1] = 0 then paramarr[1] := 1;
              if (wherex - paramarr[1] >= 1) then gotoxy(
                wherex - paramarr[1], wherey
              ) else gotoxy(1, wherey);
            end;
            'H', 'f' : begin           {cup,hvp}
              if paramarr[1] = 0 then paramarr[1] := 1;
              if paramarr[2] = 0 then paramarr[2] := 1;
              gotoxy(paramarr[2], paramarr[1]);
            end;
            'J' : case paramarr[1] of   {eid}
              2 : clrscr;
(*
                0 : begin             {ClrEos}
                  ClrEol;
                  ScrollWindowDown(
                    Lo(WindMin) + 1, Hi(WindMin) + Wherey + 1,
                    Lo(WindMax) + 1, Hi(WindMax) + 1, 0
                  );
                End;
                1 : begin              {Clear from beginning of screen}
                  ScrollWindowDown(
                    Lo(WindMin) + 1, Hi(WindMin) + Wherey,
                    Lo(WindMin) + WhereX, Hi(WindMin) + Wherey, 0
                  );
                  ScrollWindowDown(
                    Lo(WindMin) + 1, Hi(WindMin) + 1,
                    Lo(WindMax) + 1, Hi(WindMin) + Wherey - 1, 0
                  );
                End;
*)
              end; { case }
            'K' : case paramarr[1] of     {eil}
              0 : clreol;
(*
              1 : ScrollWindowDown( { clear from beginning of line to cursor }
                Lo(WindMin) + 1, Hi(WindMin) + Wherey,
                Lo(WindMin) + WhereX - 1, Hi(WindMin) + Wherey, 0
              );
              2 : ScrollWindowDown(              { clear entire line }
                Lo(WindMin) + 1, Hi(WindMin) + Wherey,
                Lo(WindMax) + 1, Hi(WindMin) + Wherey, 0
              );
*)
            end {case paramarr} ;
            'L' : {il } for i := 1 to paramarr[1] do insline; { must not move cursor }
            'M' : {d_l} for i := 1 to paramarr[1] do delline; { must not move cursor }
            'P' : begin                {dc }
            end;
            'R' : begin                {cpr}
              reportedy := paramarr[1];
              reportedx := paramarr[2];
            end;
            '@' : begin                {ic}
              { insert blank chars }
            end;
            'h', 'l' : case paramarr[1] of           {sm/rm}
              0 : textmode(bw40);
              1 : textmode(co40);
              2 : textmode(bw80);
              3 : textmode(co80);
              4 : {graphmode(320x200 col)} ;
              5 : {graphmode(320x200 bw)} ;
              6 : {graphmode(640x200 bw)} ;
              7 : wrap := ch = 'h';
            end {case} ;
            'n' : if (paramarr[1] = 6) then                {dsr}
              replyhook(#27'[' + ms(wherey) + ';' + ms(wherex) + 'R');
            's' : begin                {scp}
              savedx := wherex;
              savedy := wherey;
            end;
            'u' : {rcp} gotoxy(savedx, savedy);
            else begin
              if (ch > ' ') then write(ch)
              else writehook(ch);
              goto ending;
            end;
          end; { case ch }
        end;
        {$IFDEF Music}
        get_music : begin
          if ch <> #3 then st := st + ch else begin           {ctrl-c}
            nextstate := waiting;
          end;
        end;
        {$ENDIF}
      end; { case nextstate }
      ending:
    end;
  end; { ansiwrite }


  {$IFNDEF Small}

  {$F+}                           { All Driver function must be far }

  function nothing(var f : textrec) : integer;
  begin
    nothing := 0;
  end; {nothing}

  procedure null(ch : char);
  begin
    {}
  end; {null}

  function devoutput(var f: textrec): integer;
  var i : integer;
  begin
    with f do begin
      { f.bufpos contains the number of chars in the buffer }
      { f.bufptr^ is your buffer                            }
      { any variable conversion done by writeln is already  }
      { done by now.                                        }
      i := 0;
      while i < bufpos do begin
        ansiwrite(bufptr^[i]);
{$IFDEF BBS}
        bbshook(bufptr^[i]);
{$ENDIF}
        inc(i);
      end;
      bufpos := 0;
    end;
    devoutput := 0;               { return ioresult error codes here }
  end; { devoutput }


  function devopen(var f: textrec): integer;
  begin
    with f do begin
      if mode = fminput then begin
        inoutfunc := @nothing;
        flushfunc := @nothing;
      end else begin
        mode := fmoutput;         { in case it was fminout }
        inoutfunc := @devoutput;
        flushfunc := @devoutput;
      end;
      closefunc := @nothing;
    end;
    devopen := 0;                 { return ioresult error codes here }
  end; { devopen }


  procedure assignansi(var f : text);
  begin
    fillchar(f, sizeof(f), #0);   { init file var }
    with textrec(f) do begin
      handle := $ffff;
      mode := fmclosed;
      bufsize := sizeof(buffer);
      bufptr := @buffer;
      openfunc := @devopen;
      name[0] := #0;
    end;
  end; { assignansi }
  {$ENDIF}


{main}begin
  assignansi(ansi);               { set up the variable }
  rewrite(ansi);                  { open it for output  }
  wrap := true;
  replyhook := report;
  writehook := writechar;
{happy}end.