CP/M/CPM_CDROM.iso/mbug/mbug117.arc/TURBO.LBR/LORES.LZB/LORES.LIB

Text File | 1979-12-31 | 12KB | 471 lines

{ GENERALITY          : CP/M
  APPLICATION AREA    : TURBO utility
  PROGRAM DESCRIPTION : Lores Graphics from TURBO
  PROGRAM NAME        : LOGCOUNT.PAS
  NECESSARY MODULES   : None
  SOURCE LANGUAGE     : Borland turbo pascal (ver 3)
  WRITTEN             : G. Irlam 1985
  LAST MODIFIED       : G. Irlam 1985
  COMMENTS            : See LORES.DOC }

{$R+}
  CONST
    max_reg = 15;
    rom_read_latch = $0B;
    latch_on = 1;
    latch_off = 0;
    address_port = $0C;
    register_port = $0D;
    max_pcg_height = $0F;
    max_pcg_height_plus_one = $10;
    first_pcg_code = $80;
    max_pcg = $7F;
    max_pcg_used = $3F;

  TYPE
    register = 0 .. max_reg;
    screen_reg = ARRAY [register] OF byte;
    char_number = 0 .. $7FF;
    character_code = byte;
    pcg_line_no = 0 .. max_pcg_height;
    char_range = 0 .. max_pcg;
    bit_value = 1 .. $20;
    pt = RECORD
      x, y : byte
    END;
    address = RECORD
      ch_no : char_number;
      value : bit_value
    END;
    mode = (draw, rub_out, invert);
    fill_mode = draw .. rub_out;
    state = (on, off, ascii_character, out_of_range);

  CONST
    s80_24 : screen_reg = ($6B, $50, $58, $37, $1B, $05, $18, $1A, $48, $0A, $2A, $0A, $20, $00, $00, $00);
    s64_16 : screen_reg = ($6B, $40, $51, $37, $12, $09, $10, $12, $48, $0F, $2F, $0F, $00, $00, $00, $00);
    s75_23 : screen_reg = ($6B, 75, 87, $37, 25, 1, 23, $18, $48, 11, $2B, $2B, $20, $00, $00, $00);

  VAR
    screen : RECORD
      char_wide : 0 .. $7F;
      char_high : 0 .. $7F;
      pcg_height : 0 .. $3F;
      cols : 0 .. $FF;
      rows : 0 .. $17F
    END;
    vdu_ram : ARRAY [char_number] OF character_code ABSOLUTE $F000;
    char_rom : ARRAY [char_range, pcg_line_no] OF byte ABSOLUTE $F000;
    pcg_ram : ARRAY [char_range, pcg_line_no] OF byte ABSOLUTE $F800;
    max_col, max_row : byte;
    error : boolean;
    char_addr : address;
    ch_code : character_code;

  PROCEDURE set_screen (new_screen : screen_reg);

    VAR
      reg : register;

    BEGIN
      FOR reg := 0 TO max_reg DO
        BEGIN
          port [address_port] := reg;
          port [register_port] := new_screen [reg]
        END;
      WITH screen DO
        BEGIN
          char_wide := new_screen [1];
          char_high := new_screen [6];
          pcg_height := new_screen [9] + 1;
          cols := char_wide * 2;
          rows := char_high * 3;
          max_col := cols - 1;
          max_row := rows - 1
        END
    END;

  PROCEDURE init_pcg;

    VAR
      pcg : 0 .. max_pcg_used;
      block : 1 .. 3;
      first : pcg_line_no;
      last : 0 .. max_pcg_height_plus_one;
      bit_value : 1 .. 8;

    PROCEDURE set_row (right, left : byte);

      VAR
        line_value : byte;
        line : pcg_line_no;

      BEGIN
        line_value := 0;
        IF right <> 0 THEN
          line_value := line_value OR $F0;
        IF left <> 0 THEN
          line_value := line_value OR $0F;
        FOR line := first TO last - 1 DO
          pcg_ram [pcg, line] := line_value
      END;

    BEGIN
      last := screen . pcg_height;
      bit_value := 1;
      FOR block := 3 DOWNTO 1 DO
        BEGIN
          first := last - last DIV block;
          FOR pcg := 0 TO max_pcg_used DO
            set_row (pcg AND bit_value, pcg AND (8 * bit_value));
          bit_value := 2 * bit_value;
          last := first
        END
    END;

  PROCEDURE inverse_init;

    VAR
      ch : char_range;
      line : pcg_line_no;

    BEGIN
      port [rom_read_latch] := latch_on;
      FOR ch := 0 TO max_pcg DO
        FOR line := 0 TO max_pcg_height DO
{$R-}
          pcg_ram [ch, line] := NOT char_rom [ch, line];
{$R+}
      port [rom_read_latch] := latch_off
    END;

  FUNCTION range_check (p : pt) : boolean;
{ range_check := (p . x >= 0) AND (p . x <= max_col) AND (p . y >= 0) AND (p . y <= max_row) }

    VAR
      result : boolean;

    BEGIN
      INLINE ($21/ p/
              $3A/ max_col/
              $BE/
              $DA/ * + 15/
              $23/
              $3A/ max_row/
              $BE/
              $DA/ * + 7/
              $3E/ $01/
              $C3/ * + 3/
              $AF/
              $32/ result);
      range_check := result
    END;

  PROCEDURE location (p : pt; VAR address : address);

    VAR
      ch_up, ch_right : byte;
      value : byte;

    BEGIN
      WITH p DO
        BEGIN
          ch_right := x SHR 1;
          ch_up := y DIV 3;
          address . ch_no := (screen . char_high - ch_up - 1) * screen . char_wide + ch_right;
          value := y - (ch_up + (ch_up SHL 1));
          IF value = 0 THEN
            value := 1
          ELSE
            value := value SHL 1;
          IF odd (x) THEN
            value := value SHL 3;
          address . value := value
        END
    END;

  FUNCTION status (p : pt) : state;

    BEGIN
      IF range_check (p) THEN
        WITH char_addr DO
          BEGIN
            location (p, char_addr);
            ch_code := vdu_ram [ch_no];
            IF ch_code < first_pcg_code THEN
              status := ascii_character
            ELSE
              IF ch_code AND value = 0 THEN
                status := off
              ELSE
                status := on
          END
      ELSE
        status := out_of_range
    END;

  PROCEDURE point (p : pt; mode : mode);

    VAR
      ch_code : character_code;
      char_addr : address;

    BEGIN
      IF range_check (p) THEN
        WITH char_addr DO
          BEGIN
            location (p, char_addr);
            ch_code := vdu_ram [ch_no];
            IF ch_code < first_pcg_code THEN
              ch_code := first_pcg_code;
            CASE mode OF
              draw :
                ch_code := ch_code OR value;
              rub_out :
                ch_code := ch_code AND NOT value;
              invert :
                ch_code := ch_code XOR value
            END;
            vdu_ram [ch_no] := ch_code;
            error := false
          END
      ELSE
        error := true
    END;

  PROCEDURE line (p0, p1 : pt; mode : mode);

    VAR
      x_inc, y_inc : - 1 .. 1;
      x_step, y_step : byte;
      remainder : integer;

    BEGIN
      IF range_check (p0) AND range_check (p1) THEN
        WITH p0 DO
          BEGIN
            x_step := abs (p1 . x - x);
            y_step := abs (p1 . y - y);
            IF p1 . x > x THEN
              x_inc := 1
            ELSE
              IF p1 . x < x THEN
                x_inc := - 1
              ELSE
                x_inc := 0;
            IF p1 . y > y THEN
              y_inc := 1
            ELSE
              IF p1 . y < y THEN
                y_inc := - 1
              ELSE
                y_inc := 0;
            remainder := 0;
            point (p0, mode);
            IF y_step <= x_step THEN
              WHILE x <> p1 . x DO
                BEGIN
                  x := x + x_inc;
                  remainder := remainder + y_step;
                  IF remainder SHL 1 >= x_step THEN
                    BEGIN
                      y := y + y_inc;
                      remainder := remainder - x_step
                    END;
                  point (p0, mode)
                END
            ELSE
              WHILE y <> p1 . y DO
                BEGIN
                  y := y + y_inc;
                  remainder := remainder + x_step;
                  IF remainder SHL 1 >= y_step THEN
                    BEGIN
                      x := x + x_inc;
                      remainder := remainder - y_step
                    END;
                  point (p0, mode)
                END;
            error := false
          END
      ELSE
        error := true
    END;

  PROCEDURE ellipse (p : pt; x_radius, y_radius : byte; mode : mode);

    VAR
      x_sin, x_cos, y_sin, y_cos, step : real;
      max_radius, count : integer;
      q, r, s : pt;

    BEGIN
{$R-}
      q . x := p . x + x_radius;
      q . y := p . y + y_radius;
      r . x := p . x - x_radius;
      r . y := p . y - y_radius;
{$R+}
      IF range_check (q) AND range_check (r) THEN
        BEGIN
          IF y_radius > x_radius THEN
            max_radius := y_radius
          ELSE
            max_radius := x_radius;
          step := 0.9 / max_radius;
          x_sin := 0;
          x_cos := x_radius;
          y_sin := 0;
          y_cos := y_radius;
          s . x := p . x + round (x_cos);
          s . y := p . y + round (y_sin);
          point (s, mode);
          q := s;
          FOR count := 0 TO trunc (2 * PI / step - 1) DO
            BEGIN
              x_sin := x_sin + x_cos * step;
              x_cos := x_cos - x_sin * step;
              y_sin := y_sin + y_cos * step;
              y_cos := y_cos - y_sin * step;
              r . x := p . x + round (x_cos);
              r . y := p . y + round (y_sin);
              IF (r . x <> q . x) OR (r . y <> q . y) THEN
                BEGIN
                  IF (r . x <> s . x) OR (r . y <> s . y) THEN
                    point (r, mode);
                  q := r
                END
            END;
          error := false
        END
      ELSE
        error := true
    END;

  PROCEDURE fill (p : pt; mode : fill_mode);

    VAR
      st : state;

  FUNCTION can_go (p : pt; x, y : integer; mode : fill_mode) : boolean;

    VAR
      st : state;

    BEGIN
{$R-}
      p . x := p . x + x;
      p . y := p . y + y;
{$R+}
      st := status (p);
      IF st = ascii_character THEN
        st := off;
      can_go := NOT ((st = out_of_range) OR (st = state (mode)))
    END;

  PROCEDURE quick_point;

    BEGIN
      IF ch_code < first_pcg_code THEN
        ch_code := first_pcg_code;
      CASE mode OF
        draw :
          ch_code := ch_code OR char_addr . value;
        rub_out :
          ch_code := ch_code AND NOT char_addr . value;
      END;
      vdu_ram [char_addr . ch_no] := ch_code
    END;
{$A-}

  PROCEDURE v_line (p : pt);

    forward;

  PROCEDURE h_line (p : pt);

    VAR
      q, r : pt;
      a : integer;

    BEGIN
      q := p;
      WHILE can_go (q, 1, 0, mode) DO
        BEGIN
          quick_point;
{$R-}
          q.x := q.x + 1
{$R+}
        END;
      r := p;
      WHILE can_go (r, -1, 0, mode) DO
        BEGIN
          quick_point;
{$R-}
          r.x := r.x - 1
{$R+}
        END;
      FOR a := r.x TO p.x - 1 DO
       BEGIN
        p.x := a;
        v_line (p)
       END;
      FOR a := p.x + 1 TO q.x DO
       BEGIN
        p.x := a;
        v_line (p)
       END
    END;

  PROCEDURE v_line;

    VAR
      q, r : pt;
      a : integer;

    BEGIN
      q := p;
      WHILE can_go (q, 0, 1, mode) DO
        BEGIN
          quick_point;
{$R-}
          q.y := q.y + 1
{$R+}
        END;
      r := p;
      WHILE can_go (r, 0, -1, mode) DO
        BEGIN
          quick_point;
{$R-}
          r.y := r.y - 1
{$R+}
        END;
      FOR a := r.y TO p.y - 1 DO
       BEGIN
        p.y := a;
        h_line (p)
       END;
      FOR a := p.y + 1 TO q.y DO
       BEGIN
        p.y := a;
        h_line (p)
       END
    END;
{$A+}

    BEGIN
      st := status (p);
      IF st = ascii_character THEN
        st := off;
      IF NOT ((st = out_of_range) OR (st = state (mode))) THEN
        BEGIN
          quick_point;
          h_line (p);
          v_line (p);
          error := false
        END
      ELSE
        error := true
    END;
{$R-}