home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / ada_1 / Examples_demos_ada_screenio < prev    next >
Encoding:
Text File  |  1994-10-15  |  3.4 KB  |  137 lines
  1.  
  2. ----------------------------------------------------------------------
  3. --
  4. --              Screen Input Output Package
  5. --
  6. --                      written by
  7. --
  8. --                   Edmond Schonberg
  9. --                    David Shields
  10. --
  11. --                      Ada Project
  12. --                   Courant Institute
  13. --                  New York University
  14. --                   251 Mercer Street
  15. --                New York, New York  10012
  16. --
  17. -----------------------------------------------------------------------
  18.  
  19. with text_io;         use text_io;
  20. with semaphore;       use semaphore;
  21.  
  22. package screen_io is
  23.  
  24. -- These screen input output primitives assume that the terminal can
  25. -- function as a VT100 or, for the IBM PC, has ANSI.SYS installed
  26. -- as a screen driver.
  27.  
  28.     subtype row is integer range 1..25;
  29.     subtype column is integer range 1..80;
  30.  
  31.     procedure clear ;
  32.     procedure PUTS(s: string; r: row; c: column);
  33.     procedure PUTSN(s: string; n: integer; r: row; c: column);
  34.     procedure PUTC(ch: character; r: row; c: column);
  35.     procedure PUTCB(ch: character; r: row; c: column);
  36.     procedure fill_screen(c: character) ;
  37.  
  38. end screen_io;
  39.  
  40. with integer_text_io; use integer_text_io;
  41. package body screen_io is
  42.  
  43.     protect: ACCESS_BINARY_SEMAPHORE := new BINARY_SEMAPHORE;
  44.     Invert : constant string := ASCII.ETB & ASCII.DC1 & ASCII.ENQ &
  45.                        ASCII.NUL & ASCII.NUL & ASCII.NUL & ASCII.NUL &
  46.                        ASCII.NUL & ASCII.NUL & ASCII.NUL;
  47.  
  48.     procedure Ada_WriteI ( Char : in Integer );
  49.     pragma INTERFACE(C, Ada_WriteI);
  50.     
  51.     procedure VDU ( Char : in Character ) is
  52.     begin
  53.        Ada_WriteI ( Character'Pos(Char) );
  54.     end VDU;
  55.  
  56.     procedure VDU ( Vdu_Seq : in String ) is
  57.     begin
  58.        for I in Vdu_Seq'Range loop
  59.           Ada_WriteI ( Character'Pos(Vdu_Seq(I)) );
  60.        end loop;
  61.     end VDU;
  62.  
  63.     procedure clear is
  64.     begin
  65.         VDU ( ASCII.SUB & ASCII.FF );
  66.     end ;
  67.  
  68.     procedure PUT_INT(R: integer) is
  69.     digs: constant string := "0123456789";
  70.     d : integer := R;
  71.     begin
  72.     if d>=100 then
  73.         put(digs(d/100 + 1));
  74.             d := d mod 100;
  75.     end if;                
  76.     -- always write at least two digits (if setting screen position).
  77.     put(digs(d/10 + 1));
  78.     put(digs(d mod 10 + 1));
  79.     end;
  80.  
  81.     procedure SET_CURSOR(R: row := 1; C:column := 1) is
  82.       -- uses escape sequence ESC [ row ; column H
  83.     begin
  84.         VDU ( ASCII.US & Character'Val(C-1) & Character'Val(R-1) );
  85.     end SET_CURSOR;
  86.  
  87.     procedure PUTS(S: string; R: row; C: column) is
  88.         index: integer;
  89.     begin
  90.         PROTECT.P;
  91.         SET_CURSOR(R, C); put_line(S);
  92.         PROTECT.V;
  93.     end;
  94.  
  95.     procedure PUTSN(S: string; N: integer; R: row; C: column) is
  96.         index: integer;
  97.     -- put string and integer values
  98.     begin
  99.         PROTECT.P;
  100.         SET_CURSOR(R, C); put(S);
  101.     put_int(N);
  102.         put_line("   ");
  103.         PROTECT.V;
  104.     end;
  105.  
  106.     procedure PUTCB(CH: character ; R: row; C: column) is
  107.     -- put "emphasized" character 
  108.         index: integer;
  109.     begin
  110.         PROTECT.P;
  111.         SET_CURSOR(R, C); 
  112.     VDU( Invert );
  113.     put(CH);
  114.     VDU( Invert );
  115.         PROTECT.V;
  116.     end;
  117.  
  118.    procedure PUTC(Ch: character; R: row; C: column) is
  119.    begin
  120.       PROTECT.P;
  121.       SET_CURSOR(R, C); 
  122.       put(Ch); 
  123.       new_line;
  124.       PROTECT.V;
  125.    end PUTC; 
  126.  
  127.    procedure fill_screen(c: character) is
  128.        line : string(1..80) := (1..80 => c) ;
  129.    begin
  130.        for i in 2..23 loop
  131.           SET_CURSOR(i, 1); put_line(line) ;
  132.        end loop;
  133.    end fill_screen;
  134.  end screen_io;
  135.     
  136.  
  137.