Turbo Toolbox/Turbo_Toolbox.iso/1991/01/tricks/screens.pas

Pascal/Delphi Source File | 1990-10-22 | 9.6 KB | 346 lines

(* ------------------------------------------------------ *)
(*                      SCREENS.PAS                       *)
(*   Verwaltung und Animation von Bildschirmseiten der    *)
(*         CGA/EGA/VGA Karten im 80x25-Textmodus          *)
(*                  Turbo Pascal 5.5                      *)
(*             (c) 1990 H. Zenz & TOOLBOX                 *)
(* ------------------------------------------------------ *)
UNIT Screens;

INTERFACE

PROCEDURE SetPage(Page: BYTE);           { zeigt Bildseite }
PROCEDURE SetCursor(Page, x, y: BYTE);      { setzt Cursor }
FUNCTION  CursorX(Page: BYTE) : BYTE;      { ermittelt die }
FUNCTION  CursorY(Page: BYTE) : BYTE;     { Cursorposition }
PROCEDURE Cls(Page, Farbe: BYTE);         { Screen löschen }
PROCEDURE WriteStrXY(x, y, Page: BYTE; stg : STRING);
                                 { gibt String an x, y aus }
PROCEDURE WriteIntXY(x, y, Page: BYTE;
                     i: INTEGER; len: BYTE);
                                { gibt Integer an x, y aus }
PROCEDURE WriteRealXY(x, y, Page: BYTE;
                      r: REAL; len, dezi: BYTE);
                                { gibt Integer an x, y aus }
PROCEDURE CopyScreen(Source, Dest: BYTE; Wait, Art: WORD);
                      { animiertes Kopieren von Bildseiten }

IMPLEMENTATION

USES Dos, Crt;

CONST ScreenSegment    = $B800;{ Bildschirmspeichersegment }
      PageLen          = 4096 DIV 16;
                              { Seitenlänge in Paragraphen }
VAR   Wait             : WORD;
      ScrSeg1, ScrSeg2 : WORD; { Startsegmente von Quell-  }
                               { und Zielseite             }

PROCEDURE SetPage(Page: BYTE);
VAR R: Registers;
BEGIN
  R.ah := 5;
  R.al := Page;
  Intr($10, R);
END;

PROCEDURE SetCursor(Page, x, y: BYTE);
VAR R: Registers;
BEGIN
  R.ah := 2;
  R.bh := Page;
  R.dh := y;
  R.dl := x;
  Intr($10, R);
END;

FUNCTION CursorX(Page: BYTE): BYTE;
VAR r: Registers;
BEGIN
  R.ah := 3;
  R.bh := Page;
  Intr($10, R);
  CursorX := R.dl;
END;

FUNCTION CursorY(Page: BYTE): BYTE;
VAR R: Registers;
BEGIN
  R.ah := 3;
  R.bh := Page;
  Intr($10, R);
  CursorY := R.dh;
END;

PROCEDURE Cls(Page, Farbe: BYTE);
VAR Feld          : RECORD CASE BOOLEAN OF
                      TRUE : (h, l: BYTE);
                      FALSE: (w:    WORD);
                    END;
    ScrOfs, ScrSeg: WORD;
    i             : INTEGER;
    Fill          : WORD;
BEGIN
  ScrSeg := Page * PageLen + ScreenSegment;
  ScrOfs := 0;
  Feld.h := 32;                              { Leerzeichen }
  Feld.l := Farbe * 16;
  FOR i := 0 TO 2000 DO BEGIN
    Move(Feld.w, Mem[ScrSeg:ScrOfs], 2);
    Inc(ScrOfs, 2);
  END;
  SetCursor(Page, 0, 0);
END;

PROCEDURE WriteStrXY(x, y, Page: BYTE; stg: STRING);
VAR ScrSeg, ScrOfs: WORD;
    i             : BYTE;
BEGIN
  ScrSeg := Page * PageLen + ScreenSegment;
  ScrOfs := x * 2 + y * 160;
  FOR i := 1 TO Ord(stg[0]) DO BEGIN
    Move(stg[i], Mem[ScrSeg:ScrOfs], 1);
    Inc(ScrOfs);
    Move(TextAttr, Mem[ScrSeg:ScrOfs], 1);
    Inc(ScrOfs);
  END;
  SetCursor(Page, x + Ord(stg[0]), y);
END;

PROCEDURE WriteIntXY(x, y, Page: BYTE;
                     i: INTEGER; len: BYTE);
VAR stg: STRING;
BEGIN
  Str(i:len, stg);
  WriteStrXY(x, y, Page, stg);
END;

PROCEDURE WriteRealXY(x, y, Page: BYTE;
                      r: REAL; len, dezi: BYTE);
VAR stg: STRING;
BEGIN
  Str(r:len:dezi, stg);
  WriteStrXY(x, y, Page, stg);
END;

PROCEDURE CopyScreen(Source, Dest: BYTE; Wait, Art: WORD);
VAR
  ScrSeg1, ScrSeg2: WORD;       { StArtsegmente von Quell- }
                                { und Zielseite            }

  PROCEDURE Art0;                    { auf einmal anzeigen }
  BEGIN
    Move(Mem[ScrSeg1:0], Mem[ScrSeg2:0], 4096);
  END;

  PROCEDURE Art1;                  { spiralförmig anzeigen }
  VAR ScrOfs : WORD;
      i, Step: BYTE;
  BEGIN
    ScrOfs := 1996;
    Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 6);
    Delay(Wait);
    Step := 2;
    REPEAT
      Dec(ScrOfs, 160);
      Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 6);
      Delay(Wait*2 DIV Step);
      FOR i := 1 TO Step - 1 DO BEGIN
        Inc(ScrOfs, 6);
        Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 6);
        Delay(Wait*2 DIV Step);
      END;
      FOR i := 1 TO Step DO BEGIN
        Inc(ScrOfs, 160);
        Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 6);
        Delay(Wait*2 DIV Step);
      END;
      FOR i := 1 TO Step DO BEGIN
        Dec(ScrOfs, 6);
        Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 6);
        Delay(Wait*2 DIV Step);
      END;
      FOR i := 1 TO Step DO BEGIN
        Dec(ScrOfs, 160);
        Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 6);
        Delay(Wait*2 DIV Step);
      END;
      Inc(Step, 2);
    UNTIL Step > 24;
    ScrOfs := 3840;
    FOR i := 0 TO 24 DO BEGIN
      Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 4);
      Delay(Wait*2 DIV Step);
      Dec(ScrOfs, 160);
    END;
    ScrOfs := 154;
    FOR i := 0 TO 24 DO BEGIN
      Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 6);
      Delay(Wait*2 DIV Step);
      Inc(ScrOfs, 160);
    END;
  END;

  PROCEDURE Art2;                        { fallende Balken }
  VAR ScrOfs, StArtOfs: WORD;
      Buffer, Old     : ARRAY [0..79] OF WORD;
      y               : BYTE;
  BEGIN
    FOR y := 24 DOWNTO 0 DO BEGIN
      ScrOfs := y * 160;
      Move(Mem[ScrSeg1:ScrOfs], buffer, 160);
      stArtofs := 0;
      Move(Mem[ScrSeg2:stArtofs], old, 160);
      Move(buffer, Mem[ScrSeg2:stArtofs], 160);
      Delay(Wait*16 DIV (y+1));
      WHILE stArtofs < ScrOfs DO BEGIN
        Move(old, Mem[ScrSeg2:stArtofs], 160);
        Inc(stArtofs, 160);
        Move(Mem[ScrSeg2:stArtofs], old, 160);
        Move(buffer, Mem[ScrSeg2:stArtofs], 160);
        Delay(Wait*16 DIV (y+1));
      END;
    END;
  END;

  PROCEDURE Art3;                         { runterschieben }
  VAR y: BYTE;
  BEGIN
    FOR y := 24 DOWNTO 0 DO BEGIN
      Move(Mem[ScrSeg1:y*160], Mem[ScrSeg2:0], (25-y)*160);
      Delay(Wait*4);
    END;
  END;

  PROCEDURE Art4;                        { schräg aufbauen }
  VAR y, x, Step: BYTE;
      ScrOfs    : WORD;
  BEGIN
    FOR x := 0 TO 79 DO BEGIN
      IF x < 24 THEN Step := x
      ELSE Step := 24;
      FOR y := 0 TO Step DO BEGIN
        ScrOfs := (x - y) * 2 + y * 160;
        Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 2);
      END;
      Delay(Wait);
    END;
    FOR y := 1 TO 24 DO BEGIN
      FOR x := y TO 24 DO BEGIN
        ScrOfs := x * 160 + (79 - x + y) * 2;
        Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 2);
      END;
      Delay(Wait);
    END;
  END;

  PROCEDURE Art5;                                { Vorhang }
  VAR y, x, Step      : BYTE;
      ScrOfs1, ScrOfs2: WORD;
  BEGIN
    FOR x := 0 TO 39 DO BEGIN
      ScrOfs1 := (39 - x) * 2;
      ScrOfs2 := 80;
      FOR y := 0 TO 24 DO BEGIN
        Move(Mem[ScrSeg1:ScrOfs1+y*160],
             Mem[ScrSeg2:y*160], (x+1)*2);
        Move(Mem[ScrSeg1:ScrOfs2+y*160],
             Mem[ScrSeg2:158-x*2+y*160], (x+1)*2);
      END;
      Delay(Wait*2);
    END;
  END;

  PROCEDURE Art6;                           { Querstreifen }
  VAR y, x, Step      : WORD;
      ScrOfs1, ScrOfs2: WORD;
  BEGIN
    FOR y := 0 TO 24 DO BEGIN
      FOR x := 0 TO 79 DO BEGIN
       ScrOfs1 := x*2+((x+y) MOD 25) * 160;
       Move(Mem[ScrSeg1:ScrOfs1], Mem[ScrSeg2:ScrOfs1], 2);
      END;
      Delay(Wait*4);
    END;
  END;

  PROCEDURE Art7;                                 { Zufall }
  VAR y, x, t: BYTE;
      ScrOfs : WORD;
      tst    : ARRAY [0..79] OF SET OF BYTE;
  BEGIN
    FOR y := 0 TO 24 DO BEGIN
      t := 0;
      FOR x := 0 TO 79 DO BEGIN
        IF y = 0 THEN
          tst[x] := [];
        REPEAT
          t := Random(25);
        UNTIL NOT (t IN tst[x]);
        tst[x] := tst[x] + [t];
        ScrOfs := x*2 + t*160;
        Move(Mem[ScrSeg1:ScrOfs], Mem[ScrSeg2:ScrOfs], 2);
      END;
      Delay(Wait*2);
    END;
  END;

  PROCEDURE Art8;                          { schräg ziehen }
  VAR y, x            : BYTE;
      ScrOfs1, ScrOfs2: WORD;
  BEGIN
    FOR y := 24 DOWNTO 0 DO BEGIN
      ScrOfs2 := (80-(25-y)*3)*2;
      ScrOfs1 := 0;
      FOR x := y TO 24 DO BEGIN
        Move(Mem[ScrSeg1:ScrOfs1],
             Mem[ScrSeg2:ScrOfs2+(x*160)], (25-y)*6);
        Inc(ScrOfs1, 160);
      END;
      Delay(Wait*4);
    END;
    Move(Mem[ScrSeg1:0], Mem[ScrSeg2:0], 4096);
  END;

  PROCEDURE Art9;                      { Gitter horizontal }
  VAR y, x  : BYTE;
      Buffer: ARRAY[0..79] OF WORD;
  BEGIN
    FOR x := 0 TO 79 DO BEGIN
      FOR y := 0 TO 24 DO BEGIN
        IF Odd(y) THEN BEGIN
          Move(Mem[ScrSeg2:y*160],
               Mem[ScrSeg2:y*160+2], 158);
          Move(Mem[ScrSeg1:y*160+158-2*x],
               Mem[ScrSeg2:y*160], 2);
        END ELSE BEGIN
          Move(Mem[ScrSeg2:y*160+2],
               Mem[ScrSeg2:y*160], 158);
          Move(Mem[ScrSeg1:y*160+2*x],
               Mem[ScrSeg2:y*160+158], 2);
        END;
      END;
      Delay(Wait DIV 2);
    END;
  END;

BEGIN                                         { CopyScreen }
  ScrSeg1 := Source * PageLen + ScreenSegment;  { Quellseg }
  ScrSeg2 := Dest * PageLen + ScreenSegment;     { Zielseg }
  CASE Art OF
    0: Art0;
    1: Art1;
    2: Art2;
    3: Art3;
    4: Art4;
    5: Art5;
    6: Art6;
    7: Art7;
    8: Art8;
    9: Art9;
  END;
END;
END.
(* ------------------------------------------------------ *)
(*                   Ende von SCREENS.PAS                 *)