Turbo Toolbox/Turbo_Toolbox.iso/1990/09/tricks/mcga.pas

Pascal/Delphi Source File | 1990-08-03 | 8.5 KB | 376 lines

(* -------------------------------------------------------- *)
(*                        MCGA.PAS                          *)
(*           Unit zur Absteuerung des MCGA-Modus            *)
(*                (c) 1989, 1990 TOOLBOX                    *)
(*      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);
PROCEDURE Circle(xmitte, ymitte, radius, farbe: 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;

(* Schneller Kreisalgorithmus ohne Sinus und Cosinus *)
(* Diese Prozedur: (c) 1990 Philipps & TOOLBOX       *)
PROCEDURE Circle(xmitte, ymitte, radius, farbe: INTEGER);
VAR
  x, y, md,
  od, sd   : INTEGER;

BEGIN
  y := 0; x := radius; md := 0;
  REPEAT
     Plot(xmitte + x, ymitte + y, farbe);
     Plot(xmitte - x, ymitte + y, farbe);
     Plot(xmitte - x, ymitte - y, farbe);
     Plot(xmitte + x, ymitte - y, farbe);
     Plot(xmitte + y, ymitte + x, farbe);
     Plot(xmitte - y, ymitte + x, farbe);
     Plot(xmitte - y, ymitte - x, farbe);
     Plot(xmitte + y, ymitte - x, farbe);
  od := md + y + y + 1;  {  Distanz bei Schritt nach oben  }
  sd := od - x - x + 1;      {  Distanz bei Schrägschritt  }
  y := y + 1; md := od;
  IF Abs(sd) < Abs(od) THEN
  BEGIN
    Dec(x);
    md := sd;
  END
  UNTIL x < y;
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.