Code Library
Home Submit Free Hosting Link To Us Contacts

Pascal Screen

 Pascal Screen Pascal Pascal Screen Download (.zip)



unit Screen; {$IfNDef Os2}{$G+,F+}{$EndIf}
{ ######################################################################### }
                                  interface
{ ######################################################################### }

type  String8  = String[8];  { for Window: 'Íͺº»¼ÉÈ','Äij³¿ÙÚÀ','ÜßÛÛÜßÜß' }
var VideoMem : Pointer;                                    { video memory   }

{ Text output }
procedure WriteSt(x,y,Attr:Byte; Stro:String);   { output string to (x,y)  +}
procedure WriteCh(x,y,Attr:Byte; What:Char);     { write a char to (x,y)   +}
procedure WriteVr(x,y,Attr,Rep:Byte; What:Char); { repeat REP chars (verti)+}
procedure WriteHr(x,y,Attr,Rep:Byte; What:Char); { repeat REP chars (horis)+}
{ Special funcs }
procedure WriteMenu(X,Y:Byte; Stroka:String);    { writest(), '&'-selector +}
procedure WriteSelected( X,Y,Size:Byte);         { select the block        +}
{ Windows and Screens }
procedure ClrScrn(What:Char;Attr:Byte);          { clear the screen        +}
procedure Window(x1,y1,x2,y2,Attr:Byte);         { create a window         +}
procedure WinBor(x1,y1,x2,y2,Attr:Byte;Mask:String8); { window + border    =}
procedure PushScreen;                            { save the state          =}
procedure PopScreen;                             { restore the state       =}
{ Video Modes and Settings }
procedure Set80x25;                              { set 80x25x16 text mode  +}
procedure Set80x30;                              { set 80x30x16 text mode  +}{$Ifndef Os2}
procedure Set80x30PrintScreen;                   { enables PrScreen30 linesD}{$EndIf}
procedure SwitchMonitor(OnOff:Boolean);          { on/off the monitor      +}
procedure SetBlink(OnOff:Boolean);               { enable/disable blinking +}
procedure SetCursor(OnOff:Boolean);              { enable/disable cursor   +}
procedure EditCursor(StLine,EnLine:Byte);        { changes the cursor view +}
{ Cursor }
procedure GotoXY(x,y:Byte);                      { moves the cursor to(x,y)+}
function  WhereX:Byte;                           { gets cursor pos(x)      +}
function  WhereY:Byte;                           { gets cursor pos(y)      +}
{ Misc }
procedure Move(var Source,Dest; Count:Word);     { copy bytes (dos: faster)+}
procedure UpdateScreen;                          { updates the screen      O}
procedure WaitRetrace;                           { waits the retrace       +}

{ ######################################################################### }
                                implementation
{ ######################################################################### }

{$IfDef Os2}
{ ######################################################################### }
{ ##                                OS / 2                               ## }
{ ######################################################################### }
Uses Os2Base;

procedure WriteSt;                                                { WriteSt }
  var b      : Byte;
      VidMem : LongInt;
  begin
    VidMem:=LongInt(VideoMem)+((y*5)shl 5)-162+(x shl 1);
    b:=1;
    while b<Length(Stro)*2 do begin
      inc(b);
      Mem[VidMem+b-2]:=Byte(Stro[b div 2]);
      inc(b);
      Mem[VidMem+b-2]:=Attr;
    end;
  end; { WriteSt }

procedure WriteCh;                                                { WriteCh }
  begin
    WriteSt(x,y,Attr,What);
  end; { WriteCh }

procedure WriteVr;                                                { WriteVr }
  var b : Byte;
  begin
    for b:=1 to Rep do WriteSt(x,b+y-1,Attr,What);
  end; { WriteVr }

procedure WriteHr;                                                { WriteHr }
  var b : Byte;
      s : String;
  begin
    s:='';
    for b:=1 to Rep do s:=s+What;
    WriteSt(x,y,Attr,s);
  end; { WriteHr }

procedure WriteMenu;
  var i : Byte;
      di: shortint;
  begin
    if Pos('&',Stroka)=0 then WriteSt(x,y,$70,Stroka)
    else begin
      di:=-1;
      i:=1;
      while i<=Length(Stroka) do begin
        if Stroka[i]<>'&' then WriteCh(x+di+i,y,$70,Stroka[i])
        else begin
          dec(di);
          inc(i);
          WriteCh(x+di+i,y,$71,Stroka[i]);
        end;
        inc(i);
      end;
    end;
  end; { WriteMenu }

procedure WriteSelected;
  var b      : Byte;
      VidMem : LongInt;
  begin
    VidMem:=LongInt(VideoMem)+((y*5)shl 5)-162+(x shl 1);
    b:=1;
    while b<Size*2 do begin
      inc(b);
      inc(b);
      if (Mem[VidMem+b] and $0F)=1 then Mem[VidMem+b]:=$8E
      else Mem[VidMem+b]:=$8F;
    end;
  end; { WriteSelected }

procedure ClrScrn;                                                { ClrScrn }
  var b : Byte;
      s : String;
  begin
    s:='';
    for b:=1 to 80 do s:=s+What;
    for b:=1 to 50 do WriteSt(1,b,Attr,s);
  end; { ClrScrn }

procedure Window;                                                  { Window }
  var b : Byte;
      s : String;
  begin
    s:='';
    for b:=1 to x2-x1+1 do s:=s+' ';
    for b:=y1 to y2 do WriteSt(x1,b,Attr,s);
  end; { Window }

procedure Set80x25;                                              { Set80x25 }
  var Mode : VioModeInfo;
  begin
    Mode.cb:=8;
    Mode.fbType:=5;
    Mode.Color:=8;
    Mode.Col:=80;
    Mode.Row:=25;
    VioSetMode(Mode,0);
    SetBlink(False);
  end; { Set80x25 }

procedure Set80x30;                                              { Set80x30 }
  var Mode : VioModeInfo;
  begin
    Mode.cb:=8;
    Mode.fbType:=5;
    Mode.Color:=8;
    Mode.Col:=80;
    Mode.Row:=30;
    VioSetMode(Mode,0);
    SetBlink(False);
  end; { Set80x30 }

procedure SetBlink;                                              { SetBlink }
  var State : VioPalState;
  begin
    State.cb:=6;
    State.rType:=2;
    State.iFirst:=Ord(not OnOff);
    VioSetState(State,0);
  end; { SetBlink }

procedure SetCursor;                                            { SetCursor }
  var CurData : VioCursorInfo;
  begin
    VioGetCurType(CurData,0);
    CurData.Attr:=Ord(OnOff)-1;
    VioSetCurType(CurData,0);
  end; { SetCursor }

procedure EditCursor;                                          { EditCursor }
  var CurData : VioCursorInfo;
  begin
    CurData.yStart:=stLine;
    CurData.cEnd:=enLine;
    CurData.cx:=1;
    CurData.Attr:=0;
    VioSetCurType(CurData,0);
  end; { EditCursor }

procedure GotoXY;                                                  { GotoXy }
  begin
    VioSetCurPos(y-1,x-1,0);
  end; { GotoXY }

function WhereX;                                                   { WhereX }
  var a,b : SmallWord;
  begin
    VioGetCurPos(a,b,0);
    WhereX:=b+1;
  end; { WhereX }

function WhereY;                                                   { WhereX }
  var a,b : SmallWord;
  begin
    VioGetCurPos(a,b,0);
    WhereY:=a+1;
  end; { WhereY }

procedure SwitchMonitor;                                    { SwitchMonitor }
  begin
    Port[$3C4]:=1;
    if OnOff then Port[$3C5]:=0
    else Port[$3C5]:=Port[$3C5] or $20;
  end; { SwitchMonitor }

procedure Move;                                                      { Move }
  begin
    System.Move(Source,Dest,Count);
  end; { Move }

procedure CountB800;                                            { CountB800 }
  var BufSize : SmallWord;
      Address : Pointer;
  begin
    VioGetBuf(Address,BufSize,0);
    SelToFlat(Address);
    VideoMem:=Address;
  end; { CountB800 }

{$Else}
{ ######################################################################### }
{ ##                                  DOS                                ## }
{ ######################################################################### }

procedure WriteSt; assembler; asm                                 { WriteSt }
    push  ds
    les   di,VideoMem
    mov   al,byte ptr [y]
    dec   al
    mov   cl,160
    mul   cl
    dec   [x]
    shl   [x],1
    add   al,[x]
    adc   ah,0
    add   di,ax
    lds   si,[Stro]
    mov   cl,[ds:si]
    cmp   cl,0
    je    @@e
    xor   ch,ch
    inc   si
    mov   ah,[Attr]
@@a:lodsb
    stosw
    loop  @@a
@@e:pop   ds
  end; { WriteSt }

procedure WriteCh; assembler; asm                                 { WriteCh }
    les   di,VideoMem
    mov   al,byte ptr [y]
    dec   al
    mov   cl,160
    mul   cl
    dec   [x]
    shl   [x],1
    add   al,[x]
    adc   ah,0
    add   di,ax
    mov   ah,[Attr]
    mov   al,[What]
    stosw
  end; { WriteCh }

procedure WriteVr; assembler; asm                                 { WriteVr }
    les   di,VideoMem
    mov   al,byte ptr [y]
    dec   al
    mov   cl,160
    mul   cl
    dec   [x]
    shl   [x],1
    add   al,[x]
    adc   ah,0
    add   di,ax
    mov   ah,[Attr]
    mov   al,[What]
    mov   cl,[Rep]
    xor   ch,ch
@@a:stosw
    add   di,158
    loop  @@a
  end; { WriteVr }

procedure WriteHr; assembler; asm                                 { WriteHr }
    les   di,VideoMem
    mov   al,byte ptr [y]
    dec   al
    mov   cl,160
    mul   cl
    dec   [x]
    shl   [x],1
    add   al,[x]
    adc   ah,0
    add   di,ax
    mov   ah,[Attr]
    mov   al,[What]
    mov   cl,[Rep]
    xor   ch,ch
    rep   stosw
  end; { WriteHr }

procedure WriteMenu; assembler; asm                             { WriteMenu }
    push   ds
    les    di,VideoMem
    mov    al,byte ptr [y]
    dec    al
    mov    cl,160
    mul    cl
    shl    byte ptr [x],1
    add    al,byte ptr [x]
    adc    ah,0
    add    di,ax
    lds    si,[Stroka]
    lodsb
    mov    cl,al
    xor    ch,ch
@@l:mov    ah,70h
    lodsb
    cmp    al,"&"
    jnz    @@s
    inc    ah
    lodsb
    dec    cx
@@s:stosw
    loop   @@l
    pop    ds
  end; { WriteMenu }

procedure WriteSelected; assembler; asm                     { WriteSelected }
    push   ds
    les    di,VideoMem
    mov    al,byte ptr [y]
    dec    al
    mov    cl,160
    mul    cl
    shl    byte ptr [x],1
    add    al,byte ptr [x]
    adc    ah,0
    mov    cl,Size
    lds    si,VideoMem
    add    di,ax
    add    si,ax
    xor    ch,ch
@@a:lodsw
    and    ah,0Fh
    cmp    ah,1
    mov    ah,8Eh
    je     @@s
    inc    ah
@@s:stosw
    loop   @@a
    pop    ds
  end; { WriteSelected }

procedure ClrScrn; assembler; asm                                 { ClrScrn }
    les   di,VideoMem
    mov   ah,[Attr]
    mov   al,[What]
    mov   cx,4000
    rep   stosw
  end; { ClrScrn }

procedure Window; assembler; asm                                   { Window }
    les   di,VideoMem
    mov   al,byte ptr [y1]   { count offset }
    dec   al
    mov   cl,160
    mul   cl
    xor   ch,ch              { get repeat rate }
    mov   cl,[x2]
    sub   cl,[x1]
    inc   cl
    mov   bh,cl              { bh:swap: <-x-> count }
    mov   cl,[y2]            { bl:swap: _/y/^ count }
    sub   cl,[y1]
    inc   cl
    dec   [x1]               { continue with offset }
    shl   [x1],1
    add   al,[x1]
    adc   ah,0
    add   di,ax               { ok, caught it }
    mov   dx,di
    mov   ah,[Attr]
    mov   al,' '
@@a:mov   bl,cl
    mov   cl,bh
    rep   stosw
    mov   cl,bl
    add   dx,160
    mov   di,dx
    loop  @@a
  end; { Window }

procedure Set80x25; assembler; asm                               { Set80x25 }
    mov   ax,0003h
    int   10h
    mov   ax,1003h  { no_blink }
    xor   bl,bl
    int   10h
  end; { Set80x25 }

procedure Set80x30; assembler; asm                               { Set80x30 }
    cli
    mov   ax,40h
    mov   es,ax
    mov   ax,8192d
    mov   [es:4Ch],ax
    mov   al,29d
    mov   [es:84h],al
    mov   dx,[es:$63]
    mov   es,ax
    mov   ax,$0C11
    out   dx,ax           { 0C11 }
    mov   ax,$0D06
    out   dx,ax           { 0D06 }
    mov   ax,$3E07
    out   dx,ax           { 3E07 }
    mov   ax,$EA10
    out   dx,ax           { EA10 }
    mov   ax,$8C11
    out   dx,ax           { 8C11 }
    mov   ax,$DF12
    out   dx,ax           { DF12 }
    mov   ax,$E715
    out   dx,ax           { E715 }
    mov   ax,$0616
    out   dx,ax           { 0616 }
    mov   dx,3CCh
    in    al,dx
    and   al,33h
    or    al,0C4h
    mov   dx,3C2h
    out   dx,al
    sti
  end; { Set80x30 }

procedure Set80x30PrintScreen; assembler; asm         { Set80x30PrintScreen }
    mov   ah,12h
    mov   bl,20h
    int   10h
  end; { Set80x30PrintScreen }

procedure SwitchMonitor; assembler; asm                     { SwitchMonitor }
    mov   dx,3C4h
    mov   al,1
    out   dx,al
    inc   dx
    mov   al,0
    out   dx,al
    cmp   [OnOff],False
    jne   @@F
    in    al,dx
    or    al,20h
    out   dx,al
@@F:
  end; { SwitchMonitor }

procedure SetBlink; assembler; asm                               { SetBlink }
    mov   ax,1003h
    mov   bl,[OnOff]
    int   10h
  end; { SetBlink }

procedure SetCursor; assembler; asm                             { SetCursor }
    mov   ah,01h
    cmp   [OnOff],False
    je    @@a
    mov   cx,1312h
    jmp   @@b
@@a:mov   cx,2020h
@@b:int   10h
  end; { SetCursor }

procedure EditCursor; assembler; asm                           { EditCursor }
    mov   ah,01h
    mov   ch,[StLine]
    mov   cl,[EnLine]
    int   10h
  end; { EditCursor }

procedure GotoXY; assembler; asm                                   { GotoXy }
    mov   ah,02h
    xor   bh,bh
    mov   dh,[y]
    mov   dl,[x]
    dec   dh
    dec   dl
    int   10h
  end; { GotoXY }

function WhereX; assembler; asm                                    { WhereX }
    mov   ah,03h
    xor   bh,bh
    int   10h
    mov   al,dl
    inc   al
  end; { WhereX }

function WhereY; assembler; asm                                    { WhereX }
    mov   ah,03h
    xor   bh,bh
    int   10h
    mov   al,dh
    inc   al
  end; { WhereY }

procedure Move; assembler; asm                                       { Move }
    push  ds
    lds   si,Source
    les   di,Dest
    mov   ax,[Count]
    mov   cx,ax
    shr   cx,1
    rep   movsw
    test  ax,1
    jz    @@e
    movsb
@@e:pop   ds
  end; { Move }

{$EndIf}
{ ######################################################################### }
{ ##                                ANY OS                               ## }
{ ######################################################################### }

procedure WinBor;                                                  { WinBor }
  begin
    Window(X1,Y1,X2,Y2,Attr);
    WriteHr(x1+1,y1,Attr,x2-x1-1,Mask[1]);
    WriteHr(x1+1,y2,Attr,x2-x1-1,Mask[2]);
    WriteVr(x1,y1+1,Attr,y2-y1-1,Mask[3]);
    WriteVr(x2,y1+1,Attr,y2-y1-1,Mask[4]);
    WriteCh(x2,y1,Attr,Mask[5]);
    WriteCh(x2,y2,Attr,Mask[6]);
    WriteCh(x1,y1,Attr,Mask[7]);
    WriteCh(x1,y2,Attr,Mask[8]);
  end; { WinBor }

var Saved : array[1..4000] of Word;              { saved screen: max 80x50  }

procedure PushScreen;                                          { PushScreen }
  begin
    Move(VideoMem^,Saved,8000);
  end; { PushScreen }

procedure PopScreen;                                            { PopScreen }
  begin
    Move(Saved,VideoMem^,8000);
  end; { PopScreen }

procedure WaitRetrace;                                        { WaitRetrace }
  {$IfDef Os2} begin
{    while Port[$3DA]<>8 do;}
  {$Else} assembler; asm
    mov   dx,$3DA
@V1:in    al,dx
    test  al,08h
    jz    @v1
  {$EndIf}
  end; { WaitRetrace }

procedure UpdateScreen;                                      { UpdateScreen }
  begin
    {$IfDef OS2}
    VioShowBuf(0,4000,0);
    {$EndIf}
  end; { UpdateScreen }

begin
  asm cld end;
  {$IfDef Os2} CountB800;
  {$Else}      VideoMem:=Ptr($B800,0); {$EndIf}
end.




  • PascalScreen


Tatet

Home | Bookmark Us | Terms of Use | Link to us | Contact Us

Copyright 2012 Code Library, All rights reserved.