Turbo Toolbox/Turbo_Toolbox.iso/1989/04/extra/grinout.pas

Pascal/Delphi Source File | 1989-01-25 | 7.8 KB | 340 lines

(* ---------------------------------------------*)
(*               GRINOUT.PAS                    *)
(* Unit zur Verwendung der Standardein- und     *)
(* Ausgabe prozeduren auf dem Graphikschirm     *)
(* unter Turbo Pascal 4.0/5.0                   *)
(*      (C) 1989 F. Prattes & TOOLBOX           *)
(* -------------------------------------------- *)

UNIT GrInOut;
INTERFACE
USES
  Graph, Dos, Crt;

VAR
  graphmode,
  graphdriver,
  errorcode   : INTEGER;

PROCEDURE InitGraphic;
(* Initialisiert Graphiksystem *)
(* und Textgeräte-Treiber      *)

PROCEDURE EnterGraphic;
(* Wiedereintritt in das Graphiksystem nach dem *)
(* Ausstieg mit LeaveGraphic                    *)

PROCEDURE AssignGr(VAR f:TEXT);
(* Zuweisen der Textgeräte-Treiberroutinen an   *)
(* die Dateivariable f                          *)

PROCEDURE LeaveGraphic;
(* Ausstieg aus dem Graphiksystem, aktiviert    *)
(* wieder die Standardein- und ausgabeprozeduren*)
(*  der Unit Crt                               *)

FUNCTION GetMaxPosX : INTEGER;
(* Liefert die maximale Zeichenanzahl in einer  *)
(* Zeile beim gegenwärtig gesetzten Zeichensatz *)

FUNCTION GetMaxPosY : INTEGER;
(* Liefert die maximale Anzahl von Zeilen beim  *)
(* gegenwärtig gesetzten Zeichensatz            *)

PROCEDURE ClrEol;
(* Löschen bis zum Ende der Zeile               *)

PROCEDURE GotoXY(x,y:INTEGER);
(* Setzen der Zeichenausgabeposition auf X, Y   *)

FUNCTION WhereX : INTEGER;
(* Liefert den gegenwärtigen X-Wert *)
(* bei der Textausgabe              *)

FUNCTION WhereY : INTEGER;
(* Liefert den gegenwärtigen Y-Wert *)
(* bei der Textausgabe              *)


IMPLEMENTATION

VAR
  ingraphmode :BOOLEAN;
  posxtext,
  posytext,
  maxposx,
  maxposy     : INTEGER;
  oldexitproc : POINTER;

FUNCTION GetMaxPosX : INTEGER;
BEGIN
  IF ingraphmode THEN
    GetMaxPosX := GetMaxX DIV TextWidth('m')
  ELSE GetMaxPosX := 80
END; (* GetMaxPosX *)

FUNCTION GetMaxPosY : INTEGER;
BEGIN
  IF ingraphmode THEN
    (*das ist die Höhe e. Zeichens + Unterlänge*)
    GetMaxPosY := GetMaxY DIV (TextHeight('M') +
                  TextHeight('M') DIV 4)
  ELSE GetMaxPosY := 25
END; (* GetMaxPosY *)

PROCEDURE DrawChar(c : CHAR);
(* Ausgeben des Zeichens c an der *)
(* aktuellen Textposition         *)
VAR
  maxposx, maxposy,
  th, tw, offsx    :INTEGER;

  PROCEDURE DrawSpace;
  VAR
    i, xbegin, ybegin : INTEGER;
    tmpcolor          : WORD;

  BEGIN (* SPACE 'zeichnen' *)
   tmpcolor := GetColor;
   SetColor(GetBkColor);
   xbegin := (posxtext-1)*tw;
   ybegin := (posytext-1)*th
              + TextHeight('M') DIV 4;
   FOR i:=0 TO TextWidth('m') - 1 DO
     Line(xbegin+i,ybegin,xbegin+i,
          ybegin + th + 1);
   SetColor(tmpcolor)
  END; (* DrawSpace *)

BEGIN (* DrawChar *)
  maxposx := GetMaxPosX; tw := TextWidth('m');
  maxposy := GetMaxPosY; th := TextHeight('M');
  th := th + th DIV 4;
  (* Das Zeichen wird zentriert ausgegeben, *)
  (* deshalb die Berechnung des Offsets     *)
  offsx := tw DIV 2 - TextWidth(c) DIV 2;
  CASE c OF
  (* BS *)
    #8 : IF posxtext > 1 THEN
           Dec(posxtext)
         ELSE IF posytext > 1 THEN
          BEGIN
           Dec(posytext);
           posxtext := GetMaxPosX
          END;
   (* LF *)
    #10: IF posytext < maxposy THEN Inc(posytext);
   (* CR *)
    #13: posxtext := 1;
    ELSE
     BEGIN
      IF c=#32 THEN DrawSpace
      ELSE
        OutTextXY((posxtext-1)*tw + offsx,
                       (posytext-1)*th + 1, c);
      IF posxtext < maxposx THEN Inc(posxtext)
      ELSE
       BEGIN posxtext := 1;
        IF posytext < maxposy THEN Inc(posytext)
       END
     END
  END (* CASE *)
END; (* DrawChar *)

(*$F+*)
(* -------- Textgeräte-Treiberroutinen -------- *)

FUNCTION GrInput(VAR f:TextRec):INTEGER;
(* Eingaberoutine, füllt den Puffer bufptr^ mit *)
(* den eingegebenen Zeichen                     *)
VAR
  p     :INTEGER;
  empty :BOOLEAN;
  ch    :CHAR;

BEGIN
  WITH f DO
   BEGIN
    p := 0; empty := FALSE;
    WHILE NOT empty DO
     BEGIN
      ch := ReadKey;
      IF ch = #8 THEN
       BEGIN
        IF p > 0 THEN
         BEGIN
          DrawChar(#8); DrawChar(#32);
          DrawChar(#8);
          Dec(p)
         END
       END
      ELSE
       BEGIN
        empty := (ch = #13);
        IF NOT empty AND (p < BufSize - 1) THEN
         BEGIN
           BufPtr^[p] := ch;
           Inc(p);
           DrawChar(ch)
         END;
       END
     END; (* WHILE *)
    BufPtr^[p] := #13; Inc(p);
    BufPtr^[p] := #10; Inc(p);
    DrawChar(#13); DrawChar(#10);
    BufPos := 0; BufEnd := p
   END;
  GrInput := 0
END; (* GrInput *)

FUNCTION GrOutput(VAR f:TextRec):INTEGER;
(* Ausgaberoutine, schreibt die Zeichen im      *)
(* Puffer an der aktuellen Textposition auf den *)
(* Bildschirm                                   *)
VAR p:INTEGER;
BEGIN
  WITH f DO
   BEGIN
    FOR p:=0 TO BufPos-1 DO DrawChar(BufPtr^[p]);
    BufPos := 0
   END; (* WITH *)
  GrOutput := 0
END; (* GrOutput *)

FUNCTION GrIgnore(VAR f:TextRec):INTEGER;
(* Dummy-Routine, dient nur zum Zuweisen von    *)
(* nicht benötigten Funktionen                  *)
BEGIN
  GrIgnore := 0
END; (* GrIgnore *)

FUNCTION GrOpen(VAR f:TextRec):INTEGER;
(* Zuweisen der Ein- ausgabefunktion, *)
(* je nach mode                       *)
BEGIN
  WITH f DO
   BEGIN
    IF mode = fminput THEN
     BEGIN
      InOutFunc := @GrInput;
      FlushFunc := @GrIgnore
     END
    ELSE
     BEGIN
      InOutFunc := @GrOutput;
      FlushFunc := @GrOutput
     END;
    CloseFunc := @GrIgnore
   END;
  GrOpen := 0
END; (* GrOpen *)

(*$F-*)

PROCEDURE AssignGr(VAR f:TEXT);
BEGIN
  WITH TextRec(f) DO
   BEGIN
    mode := fmClosed;
    BufSize := SizeOf(Buffer);
    BufPtr  := @Buffer;
    OpenFunc:= @GrOpen;
    InOutFunc := @GrOutput;
    name[0] := #0
  END
END; (* AssignGr *)

PROCEDURE GotoXY(x,y : INTEGER);
BEGIN
  IF NOT ingraphmode THEN Crt.GotoXY(x,y);
  posxtext:=x;
  posytext:=y
END; (* GotoXY *)

FUNCTION WhereX;
BEGIN
  IF NOT ingraphmode THEN WhereX := Crt.WhereX
  ELSE  WhereX := posxtext
END; (* WhereX *)

FUNCTION WhereY;
BEGIN
  IF NOT ingraphmode THEN WhereY := Crt.WhereY
  ELSE WhereY := posytext
END; (* WhereY *)

PROCEDURE ClrEol;
VAR
  maxposx, tw, th,
  tmpx, tmpy, tmp : INTEGER;
  tmpcolor        : WORD;
  vp : ViewPortType;
BEGIN
  IF NOT ingraphmode THEN Crt.ClrEol
  ELSE
   BEGIN
    GetViewSettings(vp);
    tw := TextWidth('m'); th := TextHeight('M');
    tmpx := (posxtext-1) * tw;
    tmpy := (posytext-1) * th;

    SetViewPort(
      tmpx,tmpy,GetMaxX,tmpy+th+th DIV 4,FALSE);
    ClearViewPort;
    SetViewPort(vp.x1,vp.y1,vp.x2,vp.y2,vp.Clip)
   END
END; (* ClrEol *)

PROCEDURE LeaveGraphic;
BEGIN
  IF ingraphmode THEN
   BEGIN
    RestoreCrtMode;
    AssignCrt(Input); ReSet(Input);
    AssignCrt(Output); ReWrite(Output)
   END;
  ingraphmode := FALSE
END; (* LeaveGraphic *)

{$F+}
PROCEDURE MyExitProc;
BEGIN
  ExitProc := oldexitproc;
  CloseGraph
END; (* MyExitProc *)
{$F-}

PROCEDURE EnterGraphic;
BEGIN
  SetGraphMode(graphmode);
(*  GraphDefaults; *)
  AssignGr(Input);  ReSet(Input);
  AssignGr(Output); ReWrite(Output);
(*  ClearDevice; *)
  ingraphmode := TRUE
END; (* EnterGraphic *)

PROCEDURE InitGraphic;
VAR
  errorcode : INTEGER;
BEGIN
  ingraphmode := FALSE;
  GotoXY(1,1);
  graphdriver := Detect;
  InitGraph(graphdriver,graphmode,'');
  errorcode := GraphResult;
  IF errorcode <> GrOk THEN BEGIN
    WriteLn('Graphik-Fehler: ',
            GraphErrorMsg(errorcode));
    ReadLn;
    Halt(1)
  END;
  oldexitproc := ExitProc;
  ExitProc := @MyExitProc;
  EnterGraphic
END; (* InitGraphic *)

BEGIN
  ingraphmode := FALSE
END.