Re: Clear Screen

[mfb@mbunix.mitre.org (Michael F Brenner)]

  >  bunch of us should band together to create a good DOS screen
  > manipulation package.  Ada needs a larger body of common tools for the
  > common programmer.  Graphics and screen manipulation, as well as file
  > handling, are several things that come to mind.  If these packages
  > (not bindings, but bona fide Ada packages) already exist, it would be
  > very nice to know where we can find them.  :)

Ole! Yes, we need to get a large body of Free code available, bug-free,
and with fast performance. DOS system level code is needed.  

The following excerpts of my Free source code give an outline of the memory
locations needed to do machine dependent DOS text screen manipulation. This
should always be done directly to the hardware like this, because this 
always runs faster than any windowing system can light up characters. Some
Ada programmers are very much into quality, style, and machine independence.
But these attributes of a program are just methods of delivering Performance
to the user, and have no intrinsic value outside of this performance. In
drawing characters on the screen, speed is a very important component of performance. 

This method works on the raw hardware and under the DOS operating system. 
Windows NT 4.0 prevents access to these memory locations unless you are
using the game developers kit. 

  function key_bios return unsign.unsigned_8 is
    register: dosutils.registers_16;
    BIOS_keyboard_interrupt: constant := 16#16#;
    BIOS_keyboard_read:      constant := 16#1000#;
    use DOSutils;
    use unsign;
  begin
    register.ax := BIOS_keyboard_read;
    dosutils.interrupt_16 (BIOS_keyboard_interrupt, register);
    return unsign.unsigned_8 (register.ax mod 256);
    -- al is the ascii char (00 or e0); ah is the extended scan code
  end key_bios;

  function key_os return unsign.unsigned_8 is
    register: dosutils.registers_16;
    DOS_keyboard_interrupt:   constant := 16#21#;
    DOS_keyboard_read_noecho: constant := 16#0800#;
    use DOSutils;
    use unsign;
  begin
    register.ax := DOS_keyboard_read_noecho;
    dosutils.interrupt_16 (DOS_keyboard_interrupt, register);
    return unsign.unsigned_8 (register.ax mod 256);
  end key_os;

  function slitet return signals is
  begin
    return signals ((unsigned_8'(memory.get (lighter)) and 16#F0#) / 16);
  end slitet;

  procedure slitet (signal: signals) is
    surrounding_tissue: unsigned_8 := memory.get (lighter) and 15;
  begin
    memory.put (lighter, surrounding_tissue or (unsigned_8(signal) * 16));
    os.low_level_display(string'(1=>ascii.nul)); -- Forces DOS to read 417.
  end slitet;
 speakerSolenoid: constant := 16#61#;
 seed: rand.seeds;

 procedure nosound is
   maskSpeakerOff: constant unsigned_8 := 16#fc#;
 begin
   ioport.put (speakerSolenoid,
               ioport.get (speakerSolenoid) and maskSpeakerOff);
     --disk drive status is saved, and auto-interrupt sound is turned off
 end nosound;

procedure sound (frequency: frequencies) is
   timerInterrupt: constant unsigned_8:= 3;
   magicNumber: constant frequencies := 1193180; -- not a frequency
   timerPort: constant             := 16#42#;
   timerRate: frequencies;
   clipped_frequency: frequencies := frequency;
 begin
   if soundEffectsEnabled then
     if frequency < 19 then
       clipped_frequency := 19; -- prevent overflow
     end if;
     timerRate := magicNumber / clipped_frequency;
     ioport.put (timerPort, unsigned_8 (timerRate mod 256));
     ioport.put (timerPort, unsigned_8 (timerRate / 256));
     ioport.put (speakerSolenoid,
                 ioport.get (speakerSolenoid) or timerInterrupt);
     --speaker output is enabled
   end if;
 end sound;

with memory; -- pure
with unsign; -- pure
package body text_surface is
  use memory;

  procedure assert (condition: boolean) is
    text_surface_not_initialized: exception;
  begin
    if not condition then
      raise text_surface_not_initialized;
    end if;
  end assert;

  procedure clear (text_surface: text_surfaces) is
  begin
    assert (text_surface.initialized);
    blanks (text_surface, 0, 0,
            natural (text_surface.current_last_row + 1) *
            natural (text_surface.current_last_column + 1));
  end clear;

  procedure initialize (text_surface: in out text_surfaces) is
    t: text_surfaces renames text_surface;
  begin
    t.initialized := True;
    set_Foreground (t, white);
    set_background (t, blue);
    t.current_last_row := last_row (t);
    t.current_last_column := last_column (t);
  end initialize;

  procedure finalize (text_surface: in out text_surfaces) is
  begin
    assert (text_surface.initialized);
    text_surface.initialized := False;
  end finalize;

  function address (text_surface: text_surfaces;
                    column: columns;
                    row: rows) return addresses is

    text_address:        constant addresses := 16#b8000#;
    row_contribution:    constant addresses :=
      addresses (row) * addresses (text_surface.current_last_column+1);
    column_contribution: constant addresses := addresses (column);
  begin
    assert (text_surface.initialized);
    return text_address + 2 * (column_contribution + row_contribution);
  end address;

  procedure blanks (text_surface: text_surfaces;
                    column: columns;
                    row: rows;
                    count: natural) is
    a:    constant addresses := address (text_surface, column, row);
    use unsign;
    pair: constant unsigned_16 :=
      shift_left (unsigned_16 (text_surface.current_color), 8) +
      character'pos (' ');
  begin
    assert (text_surface.initialized);
    for i in 1..addresses(count) loop -- faster as buffer instead of loop?
      put (a - 2 + 2*i, pair);
    end loop;
  end blanks;
^  procedure colors_only (text_surface: text_surfaces;
                         column: columns;
                         row: rows;
                         count: natural) is
    a:    constant addresses := address (text_surface, column, row);
    byte: constant unsign.unsigned_8 :=
                   unsign.unsigned_8 (text_surface.current_color);
  begin
    assert (text_surface.initialized);
    for i in 1..addresses(count) loop
      put (a - 1 + 2*i, byte);
    end loop;
  end colors_only;

  function last_row (text_surface: text_surfaces)
                     return rows is
  begin
    assert (text_surface.initialized);
    return text_surface.current_last_row;
  end last_row;

  function last_column (text_surface: text_surfaces)
                        return columns is
  begin
    assert (text_surface.initialized);
    return text_surface.current_last_column;
  end last_column;

  function last_row return rows is
    byte: constant unsign.unsigned_8 := get (16#484#);
  begin
    return rows (byte);
  end last_row;

  function last_column return columns is
    byte: constant unsign.unsigned_8 := get (16#44a#);
  begin
    return columns (byte) - 1;
  end last_column;
  procedure message (text_surface: text_surfaces;
                     column: columns;
                     row: rows;
                     message: string) is
    a:    constant addresses := address (text_surface, column, row);
  begin
    assert (text_surface.initialized);
    for i in 1..message'length loop
      declare
        use unsign;
        pair: constant unsigned_16 :=
          shift_left (unsigned_16 (text_surface.current_color), 8) +
          character'pos (message (i));
      begin
        put (a - 2 + 2*addresses(i), pair);
      end;
    end loop;
  end message;
  procedure recompute_color (t: in out text_surfaces) is
    b_contribution: constant hues := colors'pos (t.current_background);
    f_contribution: constant hues := colors'pos (t.current_foreground);
    shift_left_4:   constant := 2**4;
    hue: constant hues := f_contribution + b_contribution * shift_left_4;
  begin
    assert (t.initialized);
    t.current_color := hue;
  end recompute_color;

  procedure set_foreground (text_surface: in out text_surfaces;
                            color: colors) is
  begin
    assert (text_surface.initialized);
    text_surface.current_foreground := color;
    recompute_color (text_surface);
  end set_foreground;
  procedure set_background (text_surface: in out text_surfaces;
                            color: colors) is
  begin
    assert (text_surface.initialized);
    text_surface.current_background := color;
    recompute_color (text_surface);
  end set_background;

end text_surface;
package communication_control