home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / TP / UTL3 / VT100.PZS / VT100.PAS
Pascal/Delphi Source File  |  2000-06-30  |  6KB  |  321 lines
  1. { vt100.pas -- simple vt100 terminal emulator }
  2. {$l-}
  3. const
  4.  
  5.     ESC    = '<27>';
  6.     CR    = '<13>';
  7.  
  8. var
  9.     c    : char;
  10.  
  11.     { send state }
  12.     rstate  : integer;
  13.     fkey    : char;
  14.     cmove,
  15.     dodump,
  16.     done    : boolean;
  17.  
  18.     { receive state }
  19.     top,bottom : integer;
  20.     row,col : integer;
  21.     ac : char;
  22.     mstate  : integer;
  23.     icnt : integer;
  24.     ichars : array [1..20] of char;
  25.  
  26. function mdmst : boolean; external;
  27. function ttyst : boolean; external;
  28. function mdmin : char; external;
  29. function ttyin : char; external;
  30. procedure mdmout( c : char); external;
  31. procedure ttyout( c : char); external;
  32.  
  33. { doconsole -- handle a character typed at the keyboard }
  34. procedure doconsole(c:char);
  35. begin
  36.     case rstate of
  37. 0:    begin
  38.         case ord(c) of
  39.     %05:    begin
  40.             done := true;
  41.         end;
  42.     %0B:    begin    { cursor up }
  43.             mdmout(ESC); mdmout('['); mdmout('A');
  44.         end;
  45.     %16:    begin    { cursor down }
  46.             mdmout(ESC); mdmout('['); mdmout('B');
  47.         end;
  48.     %0C:    begin    { cursor right }
  49.             mdmout(ESC); mdmout('['); mdmout('C');
  50.         end;
  51.     %08:    begin    { cursor left }
  52.             mdmout(ESC); mdmout('['); mdmout('D');
  53.         end;
  54.     %01:    begin    { control-A (function key) }
  55.             rstate := 1;
  56.         end;
  57.     else
  58.         mdmout(c);
  59.         end;
  60.     end;
  61. 1:    begin
  62.         fkey := c;
  63.         rstate := 2;
  64.     end;
  65. 2:    begin
  66.         rstate := 0;
  67.         if (fkey='D') then
  68.             rstate := 3
  69.         else if fkey='H' then { ctrl/k }
  70.             mdmout(chr(11))
  71.         else if fkey='I' then { backspace }
  72.             mdmout(chr(8))
  73.         else if (fkey>='@') and (fkey<='C') then begin
  74.             mdmout(ESC); mdmout('O');
  75.             mdmout(chr(ord(fkey)-ord('@')+ord('P')));
  76.         end;
  77.     end;
  78. 3:    begin
  79.         rstate := 0;
  80.         mdmout(ESC); mdmout('O');
  81.         if (c>='0') and (c<='9') then
  82.             mdmout(chr(ord(c)-ord('0')+ord('p')))
  83.         else if c='-' then
  84.             mdmout('m')
  85.         else if c=',' then
  86.             mdmout('l')
  87.         else if c='.' then
  88.             mdmout('n')
  89.         else
  90.             mdmout('M');
  91.     end;
  92.     end;    { of case }
  93. end;
  94.  
  95. procedure domodem(c : char);
  96. var    parm : array [1..4] of integer;
  97.     parms : integer;
  98.     i : integer;
  99.  
  100.     procedure dumpit;
  101.     var i : integer;
  102.     begin
  103.     if dodump then begin
  104.         write('<ESC>[');
  105.         for i := 1 to icnt do write(ichars[i]);
  106.         writeln(c);
  107.     end;
  108.     end;
  109.  
  110.     procedure getnumeric;
  111.     var i,j : integer;
  112.  
  113.         procedure ival(var v : integer);
  114.     var c : char;
  115.         begin
  116.         v := 0;
  117.         c := ichars[i];
  118.         while (i<=icnt) and (c>='0') and (c<='9') do begin
  119.             v := v*10+ord(c)-ord('0');
  120.             i := succ(i);
  121.             c := ichars[i];
  122.         end;
  123.     end;
  124.     begin
  125.     for j := 1 to 4 do
  126.         parm[j] := 0;
  127.     i := 1;
  128.     j := 1;
  129.     while (i<=icnt) and (j<=4) do begin
  130.         ival(parm[j]);
  131.         i := succ(i);    { skip ; }
  132.         j := succ(j);    { get next parm }
  133.     end;
  134.     parms := pred(j);
  135.     end;
  136.  
  137.     procedure setattr;
  138.     var i : integer;
  139.     begin
  140.     getnumeric;
  141.     if parms < 1 then
  142.         ac := '0';
  143.     for i := 1 to parms do
  144.     case parm[i] of
  145.     0:    ac := '0';
  146.     1:    ;
  147.     4:    ac := chr(ord(ac) or 8);
  148.     5:    ac := chr(ord(ac) or 2);
  149.     7:    ac := chr(ord(ac) or 4);
  150.     else    ;
  151.     end;
  152.     ttyout(ESC); ttyout('G'); ttyout(ac);
  153.     end;
  154.  
  155.     procedure setrow(n:integer);
  156.     begin
  157.     ttyout(ESC);
  158.     ttyout('[');
  159.     ttyout(chr(%20+n-1));
  160.     end;
  161.  
  162.     procedure domargin;
  163.     begin
  164.     getnumeric;
  165.     top := parm[1];
  166.     if top < 1 then top := 1;
  167.     bottom := parm[2];
  168.     if bottom >24 then bottom := 24;
  169.     end;
  170.  
  171.     procedure docursor;
  172.     begin
  173.     getnumeric;
  174.     ttyout(esc);
  175.     ttyout('=');
  176.     if parm[1]=0 then parm[1] := 1;
  177.     if parm[2]=0 then parm[2] := 1;
  178.     row := parm[1];
  179.     col := parm[2];
  180.     ttyout(chr(%20+parm[1]-1));
  181.     ttyout(chr(%20+parm[2]-1));
  182.     cmove := true;
  183.     end;
  184.  
  185. begin
  186.     case mstate of
  187. 0:    begin
  188.         if c='<13>' then begin
  189.             ttyout(c);
  190.             col := 1;
  191.         end
  192.         else if c='<10>' then begin
  193.             if (row=bottom) and (bottom<24) then begin
  194.             setrow(top);
  195.             ttyout(ESC); ttyout('R'); { delete line }
  196.             setrow(bottom);
  197.             ttyout(ESC); ttyout('E');
  198.             end
  199.             else begin
  200.             row := row + 1;
  201.             ttyout(c);
  202.             end;
  203.         end
  204.         else if c=ESC then begin
  205.             icnt := 0;
  206.             if dodump then
  207.                 write('<Esc>')
  208.             else
  209.                 mstate := 1;
  210.         end
  211.         else begin
  212.             col := succ(col);
  213.             ttyout(c);
  214.             while col>=80 do begin
  215.                 col := pred(col);
  216.                 ttyout('<8>');
  217.             end;
  218.         end;
  219.         cmove := false;
  220.     end;
  221. 1:    begin    { escape seen, collect ansi intermediate chars }
  222.         if ( ord(c)>=%20 ) and ( ord(c)<=%2F ) then begin
  223.             if icnt<=10 then begin
  224.                 icnt := succ(icnt);
  225.                 ichars[icnt] := c;
  226.             end;
  227.         end
  228.         else if c='[' then begin    { csi }
  229.             mstate := 2;
  230.             icnt := 0;
  231.         end
  232.         else if c='M' then begin    { ri }
  233.             mstate := 0;
  234.             if row=top then begin    { scroll up }
  235.                 setrow(bottom);
  236.                 ttyout(ESC); ttyout('R'); { delete line }
  237.                 setrow(top);
  238.                 ttyout(ESC); ttyout('E'); { insert line }
  239.             end
  240.             else begin
  241.                 row := row - 1;
  242.                 ttyout(ESC); ttyout('j');
  243.             end;
  244.         end
  245.         else begin    { assume terminating char }
  246.             mstate := 0;
  247.             dumpit;
  248.         end;
  249.     end;
  250. 2:    begin    { csi seen, collect intermediate parameters }
  251.         if (c<'@') then begin
  252.             if icnt<=10 then begin
  253.                 icnt := succ(icnt);
  254.                 ichars[icnt] := c;
  255.             end;
  256.         end
  257.         else begin    { terminator }
  258.             ichars[icnt+1] := ' ';
  259.             mstate := 0;
  260.             if (c='J') and (ichars[1]='2') then begin
  261.                 ttyout(chr(26));    { clear page }
  262.             end
  263.             else if (c='K') then begin { erase to end of line }
  264.                 ttyout(ESC); ttyout('T');
  265.             end
  266.             else if (c='J') and ((ichars[1]='0') or (icnt=0)) then
  267.                 begin
  268.                 ttyout(ESC); ttyout('Y'); { clear eop }
  269.             end
  270.             else if c='c' then begin    { identify }
  271.                 mdmout(ESC);
  272.                 mdmout('[');
  273.                 mdmout('?');
  274.                 mdmout('1');
  275.                 mdmout(';');
  276.                 mdmout('0');
  277.                 mdmout('c');
  278.             end
  279.             else if (c='f') or (c='H') then
  280.                 docursor
  281.             else if (c='r') then
  282.                 domargin
  283.             else if (c='m') then
  284.                 setattr
  285.             else if (c='h') or (c='l') then
  286.                 { ignore }
  287.             else    dumpit;
  288.         end;
  289.     end;    { state 2 }
  290.     end;    { of case }
  291. end;
  292.  
  293. begin
  294.     writeln('Vt100 emulator -- use CTRL/E to exit');
  295.     if eoln then readln;
  296.     dodump := false;
  297. #if false
  298.     repeat
  299.         write('Display controls ? ');
  300.         readln(c);
  301.         if (c>='a') then c := chr(ord(c)-ord('a')+ord('A'));
  302.         dodump := (c='Y');
  303.     until (c='Y') or (c='N');
  304. #endif
  305.     ac := '0';
  306.     done := false;
  307.     cmove := false;
  308.     top := 1; bottom := 24;
  309.     mstate := 0;
  310.     rstate := 0;
  311.  
  312.     repeat
  313.         if ttyst then
  314.         doconsol(ttyin)
  315.         else if mdmst then
  316.         domodem(mdmin);
  317.     until done;
  318. end.
  319.  
  320.     
  321.