Power-Programmierung/CD1.mdf/pascal/library/dos/mouse/mouse0/video.pas

Pascal/Delphi Source File | 1994-04-30 | 5.9 KB | 350 lines

Unit VIDEO;

Interface

Uses Dos,Crt;

Type
    ScreenChars = Record
      ch : Char;
      at : Byte;
    End;

    screens = Record
      Position : Array[1..25, 1..80] of ScreenChars;
      x,y :Byte;
    end;

    Screentype = (Mono, Color);

var
   Stype : Screentype;
   VidSeg : Word;
   xx : Integer;

Procedure ShowScreen (Var Source, Video; Length: Word);

Procedure Getscreen (Var Video, Source; Length: Word);

Procedure XYstring(x, y: Byte;
                   s: String;
                   fg,
                   bg: Byte);

Procedure ReadScr(Var S);

Procedure WriteScr(Var S);

Procedure HorStr(X, Y, Len : Byte;
                 fg, bg: Byte;
                 Ch : Char);

Procedure VerStr(X, Y, Len : Byte;
                 fg, bg: Byte;
                 Ch : Char);

Procedure Box(x1, y1, x2, y2 : Byte;
              fg, bg : Byte);

Procedure Center(y : Byte;
                 st : String;
                 fg,
                 bg : Byte);

Procedure BoxString(y : Byte;
                    st :  String;
                    fg,
                    bg : Byte);

Procedure FillScreen(Var sc : Screens;
                     s : String;
                     x, y : Byte;
                     fg, bg : Byte);

Procedure CursorOff;

Procedure CursorSmall;

Procedure CursorBig;


Implementation

Var
   Regs : Registers;
   Vid : Pointer;


Procedure ShowScreen(Var Source, Video;
                            Length: Word);
Begin
If Stype = Color Then
   Inline($90/$90/$90/
          $1E/$55/$BA/$DA/$03/$C5/$B6/ Source /$C4/$BE/ Video /
          $8B/$8E/ Length /$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/
          $72/$FB/$FA/$EC/$20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/
          $EA/$5D/$1F)

Else
    Begin
    Length := Length * 2;
    Move(Source, Video, Length);
    end;
End;


Procedure GetScreen(Var Video , Source;
                        Length: Word);

Begin
If Stype = Color Then
   Inline($1E/$55/$BA/$DA/$03/$C5/$B6/ Video /$C4/$BE/ Source /
          $8B/$8E/Length /$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/
          $D8/$73/$FB/$AD/$FB/$AB/$E2/$F0/$5D/$1F)

Else
    begin
    length := length * 2;
    Move(Video, Source, Length);
    end;
End;


Procedure XYstring(x, y: Byte;
                   s: String;
                   fg, bg: Byte);

Var
   SA : Array[1..255] of Record
      ch : Char;
      at : byte;
      End;

   b, i : Byte;
   offset : Word;

Begin
If (Length(s) = 0) Or
   (x > 80) Or
   (x < 1) Or
   (y > 25) Or
   (y < 1) Then Exit;

b := (Ord(bg) Shl 4) Or Ord(fg);

FillChar(SA, SizeOf(SA), b);
For i := 1 to Length(s) Do
    Sa[i].ch := s[i];

offset := (((y-1) *80) + (x-1))*2;

Vid := Ptr (Vidseg,offset);

Showscreen(SA, Vid^, Length(s));
End;


Procedure ReadScr(Var S);

Begin
Vid := Ptr(Vidseg, 0);
Showscreen(S, Vid^, 2000);
End;


Procedure WriteScr(Var S);

Begin
Vid := Ptr(Vidseg,0);
Showscreen(S, Vid^, 2000);
End;


Procedure HorStr(x, y, Len : Byte;
                 fg, bg: Byte;
                 ch : Char);

Var
   i : Byte;
Begin
For i := 1 To Len Do
    Begin
    XYString(x,y,ch,fg,bg);
    x := x + 1;
    End;
End;



Procedure VerStr(x, y, Len : Byte;
                 fg,bg: Byte;
                 ch : Char);

Var
   i : Byte;
Begin
For i := 1 To Len Do
    Begin
    XYString(x,y,ch,fg,bg);
    y := y + 1;
    End;
End;



Procedure Box(x1, y1, x2, y2 : Byte;
              fg, bg : Byte);

Begin
If (x1 < 1) Or
   (x2 > 80) Or
   (y1 < 1) Or
   (y2 > 25) Or
   ((x2-x1) < 2) Or
   ((y2-y1) < 2) Then Exit;

HorStr(x1, y1, 1, fg, bg, #201);
HorStr(x2, y1, 1, fg, bg, #187);
HorStr(x1, y2, 1, fg, bg, #200);
HorStr(x2, y2, 1, fg, bg, #188);
VerStr(x1, y1+1, y2-y1-1, fg, bg, #186);
For xx:=x1+1 to x2-1 do
Begin
     VerStr(xx, y1+1, y2-y1-1, fg, bg, ' ');
End;
VerStr(x2, y1+1, y2-y1-1, fg, bg, #186);
HorStr(x1+1, y1, x2-x1-1, fg, bg, #205);
HorStr(x1+1, y2, x2-x1-1, fg, bg, #205);
End;



Procedure Center(y : Byte;
                 st : String;
                 fg,
                 bg : Byte);

Var
   x : Byte;

Begin
x := (40-(Length(st) Div 2));
XYString(x, y, st, fg, bg);
End;



Procedure BoxString(y : Byte;
                    st : String;
                    fg, bg : Byte);

Var
   x1, y1, x2, y2 : Byte;

Begin
Center(y, st, fg, bg);
x1 := 40-(Length(st) Div 2) -2;
x2 := x1+Length(st)+3;
y1 := y-1;
y2 := y+1;
Box(x1, y1, x2, y2, fg, bg);
End;


Procedure FillScreen(Var sc : screens;
                      s : String;
                      x, y : Byte;
                      fg,bg : Byte);

Var
   i, atx : Byte;
Begin
atx := fg Or (bg Shl 4);

For i := 1 To Length(s) Do
    Begin
    sc.position[y,x].ch := s[i];
    sc.position[y,x].at := atx;
    x := x+1;
    If x > 80 Then
       Begin
       x := 1;
       y := y+1;
       If y>25 Then
          Exit;
       End;
    End;
End;



Procedure CursorOff;
Begin
FillChar(Regs, sizeof(Regs),0);

With Regs Do
     Begin
     AH := $01;
     CH := $20;
     CL := $20;
     End;

Intr($10, Regs);
End;



Procedure CursorSmall;
Begin
FillChar(Regs,sizeof(Regs),0);
regs. AH := $01;

      Case stype of
      Mono :
           Begin
           With Regs Do
                begin
                CH := 12;
                CL := 13;
                End;
           End;
      End;

Intr($10, Regs);
End;



Procedure CursorBig;
Begin
FillChar(Regs, sizeof(Regs),0);
regs.AH := 1;
regs.CH := 0;

    Case stype of
    Mono : regs.CL :=13;
    Color : regs.CL :=7;
    End;

Intr($10, Regs);
End;


Begin
FillChar(regs,sizeof(regs),0);
Regs.AH := $0F;

Intr($10,Regs);
If Regs.AL = 7 Then
   Begin
   Stype := Mono;
   Vidseg := $b000;
   End
Else
    Begin
    Stype := Color;
    Vidseg := $B800;
    End;
End.