Turbo Toolbox/Turbo_Toolbox.iso/1989/10/titel/mcga.pas

Pascal/Delphi Source File | 1989-09-06 | 7.3 KB | 347 lines

(*           (C) 1989 TOOLBOX & Jan Laitenberger            *)
(*      Diese Unit liefert die Grundlage für die Pro-       *)
(*      grammierung des Modus 13h (MCGA) der VGA-Karte      *)
(*               Turbo Pascal 4.0/5.x Unit                  *)
unit MCGA;

interface

uses crt,dos;

TYPE ColorRegBuffer = ARRAY[0..255] OF RECORD
                                        r,g,b : BYTE;
                                      END;

var  i: integer;
    c: char;

procedure plot (x,y,color: integer);
function getdotcolor (x,y: integer): integer;
procedure initgraphic;
procedure exitgraphic;
procedure print (line: string; color: integer);
procedure setcursor (x,y:integer);
function cursorx: integer;
function cursory: integer;
procedure clearscreen (color: integer);
procedure colorbox (x1,y1,x2,y2,color: integer);
procedure mcgasave (filename: string);
procedure mcgaload (filename: string);
procedure line(x1,y1,x2,y2,color: integer);
PROCEDURE box (x1,y1,x2,y2, color: INTEGER);
PROCEDURE setcolor(nr,red,green,blue : INTEGER);
PROCEDURE readcolor(nr : INTEGER;
                   VAR red,green,blue : INTEGER);
PROCEDURE setcolorblock(startnr : INTEGER;
                       buf : ColorRegBuffer;
                       nr : INTEGER         );
PROCEDURE readcolorblock(startnr : INTEGER;
                        VAR buf : ColorRegBuffer;
                        nr : INTEGER         );


implementation

(* Setzt einen Punkt mit der Farbe  color *)
procedure plot(x,y,color: integer);
begin
 mem[$A000:word(y)*320+word(x)] := color;
end;

(* Ermittelt die Farbe des Punktes auf x,y *)
function getdotcolor (x,y: integer): integer;
begin
 getdotcolor := mem[$A000:word(y)*320+word(x)];
end;

(* Setzt den MCGA-Modus mit 320*200 Punkten x 256 Farben *)
procedure initgraphic;

VAR regs : Registers;

begin
 with regs do begin
   ah := 0;
   al := $13
 end;
 intr ($10, regs)
end;


(* Zurück in den Textmodus *)
procedure exitgraphic;

VAR regs : Registers;

begin
 with regs do begin
   ah := 0;
   al := $3;
 end;
 intr ($10,regs)
end;

(* Schreibt einen String an die Cursorposition *)
procedure print (line: string; color: integer);

var i : integer;
   regs : Registers;

begin
 for i := 1 to length (line) do
   with regs do begin
     ah := 14;
     al := ord (line [i]);
     bl := color;
     intr ($10,regs)
   end
end;

(* Setzt den Cursor auf x,y *)
procedure setcursor (x,y: integer);

VAR regs : Registers;

begin
  with regs do begin
    ah := 2;  bh := 0;
    dh := y;  dl := x
  end;
  intr ($10, regs)
  end;

(* Liest x-Position des Cursors *)
function cursorx: integer;

VAR regs : Registers;

begin
  with regs do begin
    ah := 3;  bh := 0
  end;
  Intr ($10, regs);
  cursorx := regs.dl
end;

(* Liest y-Position des Cursors *)
function cursory: integer;

VAR regs : Registers;

begin
  with regs do begin
    ah := 3;  bh := 0
  end;
  intr ($10, regs);
  cursory := regs.dh
end;

(* Löscht Bildschirm in der Farbe "color" *)
procedure clearscreen (color: integer);
begin
  fillchar (mem[$A000:0000],64000,chr (color));
end;

(* Zeichnet gefüllte Box in der Farbe "color" *)
procedure colorbox (x1,y1,x2,y2,color: integer);

var i, d: integer;

begin
  d := x2-x1;
  for i := y1 to y2 do
    fillchar (mem[$A000:word(i)*320+word(x1)],d,chr (color));
end;

(* Sichert den Bildschirm in der Datei "filename" *)
procedure mcgasave (filename: string);

var f: file;

begin
  assign (f, filename);
  rewrite (f,1);
  blockwrite (f,mem[$a000:0000], 64000);
  close (f)
end;


(* Lädt einen gesicherten Bildschirm *)
procedure mcgaload (filename: string);

var f: file;

begin
  assign (f, filename);
  reset (f,1);
  blockread (f, mem[$A000:0000], 64000);
  close (f)
end;

(* Zeichnet eine Linie in der Farbe color *)
PROCEDURE line(x1,y1,x2,y2,color: INTEGER);

VAR deltax,deltay,abweichung,
    zaehler,x,y,temp        : INTEGER;

BEGIN
  abweichung := 0;
  deltax := x2-x1;
  deltay := y2-y1;
  IF deltay <0 THEN BEGIN
    temp := x1; x1 := x2 ; x2 := temp;
    temp := y1; y1 := y2 ; y2 := temp;
    deltax := -deltax;
    deltay := -deltay;
  END;
  plot(x1,y1,color);
  x := x1;
  y := y1;
  IF deltax >= 0 THEN BEGIN
    IF deltax < deltay THEN BEGIN
      FOR zaehler := 1 TO deltay-1 DO BEGIN
        IF abweichung <0 THEN BEGIN
          x := x+1;
          y := y+1;
          plot(x,y,color);
          abweichung := abweichung+deltay-deltax;
        END
        ELSE BEGIN
          y := y+1;
          plot(x,y,color);
          abweichung := abweichung+deltay-deltax;
        END;
      END;
    END ELSE BEGIN
      FOR zaehler := 1 TO deltax-1 DO BEGIN
        IF abweichung <=0 THEN BEGIN
          x := x+1;
          plot(x,y,color);
          abweichung := abweichung+deltay;
        END ELSE BEGIN
          x := x+1;
          y := y+1;
          plot(x,y,color);
          abweichung := abweichung+deltay-deltax;
        END;
      END;
    END;
  END ELSE BEGIN
    IF ABS(deltax) >= deltay THEN BEGIN
      FOR zaehler := 1 TO ABS(deltax)-1 DO BEGIN
        IF abweichung <= 0 THEN BEGIN
          x :=x-1;
          plot(x,y,color);
          abweichung := abweichung+deltay;
        END ELSE BEGIN
          x := x-1;
          y := y+1;
          plot(x,y,color);
          abweichung := abweichung+deltax+deltay;
        END;
      END;
    END ELSE BEGIN
      FOR zaehler := 1 TO deltay-1 DO BEGIN
        IF abweichung <0 THEN BEGIN
          x := x-1;
          y := y+1;
          plot(x,y,color);
          abweichung := abweichung+deltax+deltay;
        END ELSE BEGIN
          y := y+1;
          plot(x,y,color);
          abweichung := abweichung+deltax;
        END;
      END;
    END;
  END;
  plot(x2,y2,color);
END;

(* Zeichnet eine Box in der Farbe color *)
PROCEDURE box (x1,y1,x2,y2, color: INTEGER);

BEGIN
  line(x1,y1,x2,y1,color);
  line(x1,y2,x2,y2,color);
  line(x1,y1,x1,y2,color);
  line(x2,y1,x2,y2,color);
END;


(* Setzt ein Farbregister *)
PROCEDURE setcolor(nr,red,green,blue : INTEGER);

VAR r : Registers;

BEGIN
  WITH R DO BEGIN
    AH := $10;
    AL := $10;
    BX := nr;
    DH := red;
    CH := green;
    CL := blue;
  END;
  INTR($10,R);
END;

(* Liest ein Farbregister *)
PROCEDURE readcolor(nr : INTEGER;
                    VAR red,green,blue : INTEGER);

VAR R : Registers;

BEGIN
  WITH R DO BEGIN
    AH := $10;
    AL := $15;
    BX := nr;
    Intr($10,R);
    red := DH;
    green := CH;
    blue := CL;
  END;
END;


(* Setzt einen Block von Farbregistern *)
PROCEDURE setcolorblock(startnr : INTEGER;
                        buf : ColorRegBuffer;
                        nr : INTEGER         );

VAR R : Registers;

BEGIN
  WITH R DO BEGIN
    AH := $10;
    AL := $12;
    BX := startnr;
    ES := Seg(buf);
    DX := Ofs(buf);
    CX := nr;
  END;
  Intr($10,R);
END;

(* Liest eine Block von Farbregistern *)
PROCEDURE readcolorblock(startnr : INTEGER;
                         VAR buf : ColorRegBuffer;
                         nr : INTEGER         );

VAR R : Registers;

BEGIN
  WITH R DO BEGIN
    AH := $10;
    AL := $17;
    BX := startnr;
    ES := Seg(buf);
    DX := Ofs(buf);
    CX := nr;
  END;
  Intr($10,R);
END;

END.