{
  System independent low-level video interface for tp7

  $Id: video.inc,v 1.1.2.2 2000/10/04 11:44:33 pierre Exp $
}

{ use a buffer, just like linux,go32v2 }
{$define use_buf}

uses dos,{$ifdef TP}winapi{$endif}{$ifdef go32v2}go32{$endif};


procedure TargetEntry;
begin
end;

procedure TargetExit;
begin
end;

var
  VideoSeg    : word;
  OldVideoBuf : PVideoBuf;

{ internal function, which is by default available under FPC }
procedure fillword(var buf;len,w:word);assembler;
asm
        les     di,buf
        mov     cx,len
        mov     ax,w
        rep     stosw
end;


{$IFDEF DPMI}
const
    DPMI_INTR      = $31;

type
    TDPMIRegisters = record     { DPMI call structure }
      EDI     : LongInt;
      ESI     : LongInt;
      EBP     : LongInt;
      Reserved: LongInt;
      EBX     : LongInt;
      EDX     : LongInt;
      ECX     : LongInt;
      EAX     : LongInt;
      Flags   : Word;
      ES      : Word;
      DS      : Word;
      FS      : Word;
      GS      : Word;
      IP      : Word;
      CS      : Word;
      SP      : Word;
      SS      : Word;
    end;

  MemPtr = record
    Selector: Word;  {Protected mode}
    Segment : Word;  {Real mode}
  end;

  Function GetDosMem(var Mem : MemPtr; Size : Word): Boolean;
    begin
      if (Size > 0) then
      begin
        LongInt(Mem) := GlobalDOSAlloc(Size);
        GetDosMem := (LongInt(Mem) <> 0);
      end

      else
      begin
        LongInt(Mem) := 0;
        GetDosMem := True;
      end;
    end;

  Procedure FreeDosMem(Mem : MemPtr; Size : Word);
    begin
      if (Size > 0) then
        GlobalDOSFree(Mem.Selector);
    end;

  Function MakePtr(Mem : MemPtr): Pointer;
    begin
      MakePtr := Ptr(Mem.Selector, 0);
    end;

  var
    DPMIRegs: TDPMIRegisters;

  procedure realintr(IntNo: byte; var r: registers);
  var Regs: Registers;
  begin
    FillChar(DPMIRegs, SizeOf(TDPMIRegisters), 0);
    DPMIRegs.EAX := r.ax;
    DPMIRegs.EBX := r.bx;
    DPMIRegs.ECX := r.cx;
    DPMIRegs.EDX := r.dx;
    DPMIRegs.EDI := r.di;
    DPMIRegs.ESI := r.si;
    DPMIRegs.EBP := r.bp;
    DPMIRegs.DS := r.ds;
    DPMIRegs.ES := r.es;
    DPMIRegs.Flags := r.flags;
    Regs.AX := $0300;
    Regs.BL := IntNo;
    Regs.BH := 0;
    Regs.CX := 0;
    Regs.ES := Seg(DPMIRegs);
    Regs.DI := Ofs(DPMIRegs);
    dos.Intr(DPMI_INTR, Regs);
    r.ax := DPMIRegs.EAX;
    r.bx := DPMIRegs.EBX;
    r.cx := DPMIRegs.ECX;
    r.dx := DPMIRegs.EDX;
    r.di := DPMIRegs.EDI;
    r.si := DPMIRegs.ESI;
    r.bp := DPMIRegs.EBP;
    r.ds := DPMIRegs.DS;
    r.es := DPMIRegs.ES;
    r.Flags := DPMIRegs.Flags;
  end;
{$ENDIF}

function BIOSGetScreenMode(var Cols,Rows: word; var Color: boolean): boolean;
var r: registers;
    M: MemPtr;
    B: array[0..63] of byte;
type TWord = word; PWord = ^TWord;
var Size: word;
    OK: boolean;
begin
  GetDosMem(M,64);
  r.ah:=$1b; r.bx:=0;
  r.es:=M.Segment; r.di:=0;
  realintr($10,r);
  OK:=(r.al=$1b);
  if OK then
  begin
    Move(Ptr(M.Selector,0)^,B,sizeof(B));
    Cols:=PWord(@B[5])^; Rows:=B[$22];
    Color:=PWord(@B[$27])^<>0;
  end;
  FreeDosMem(M,64);
  BIOSGetScreenMode:=OK;
end;

procedure InitVideo;
var SX,SY: integer;
begin
  asm
        mov     ah,0fh
        int     10h
        mov     [ScreenColor],1
        test    al,1            { even modes are colored }
        jne     @ColorOn
        mov     [ScreenColor],0
@ColorOn:
        cmp     al,7            { 7 mono mode }
        mov     dx,SegB800
        jne     @@1
        mov     [ScreenColor],0
        mov     dx,SegB000
@@1:
{$ifdef use_buf}
        mov     videoseg,dx
{$else}
        mov     [word ptr VideoBuf+0], 0
        mov     [word ptr VideoBuf+2], dx
{$endif}
        xchg    al,ah
        xor     ah,ah
        mov     [ScreenWidth],ax
        mov     bx,40h
        mov     cx,ax                   { cx:=ax, pipeline ok }
        mov     es,bx
        shl     cx,1
        mov     ax,[word ptr es:04ch] { Size of videobuf }
        xor     dx,dx
        div     cx
        mov     [ScreenHeight],ax
        mov     ah,03h
        xor     bh,bh
        int     10h
        mov     [CursorLines], cl
        xor     ax,ax
        mov     al,dl
        mov     [CursorX],ax
        mov     al,dh
        mov     [CursorY],ax
  end;
  BIOSGetScreenMode(ScreenWidth,ScreenHeight,ScreenColor);
{$ifdef use_buf}
  VideoBufSize:=ScreenWidth*ScreenHeight*2;
  GetMem(VideoBuf,VideoBufSize);
  GetMem(OldVideoBuf,VideoBufSize);
{$endif}
  ClearScreen;
end;


procedure DoneVideo;
begin
  ClearScreen;
  SetCursorType(crUnderLine);
  SetCursorPos(0,0);
{$ifdef use_buf}
  FreeMem(VideoBuf,VideoBufSize);
  FreeMem(OldVideoBuf,VideoBufSize);
  VideoBufSize:=0;
{$endif}
end;


function GetCapabilities: Word;
begin
  GetCapabilities := $3F;
end;


procedure SetCursorPos(NewCursorX, NewCursorY: Word); assembler;
asm
        mov     ah,02h
        xor     bh,bh
        mov     dh,[byte ptr NewCursorY]
        mov     dl,[byte ptr NewCursorX]
        int     10h
        mov     [byte ptr CursorY],dh
        mov     [byte ptr CursorX],dl
end;


function GetCursorType: Word; assembler;
asm
        mov     ah,03h
        xor     bh,bh
        int     10h
        mov     ax,crHidden
        cmp     cx,2000h
        je      @@1
        mov     ax,crBlock
        cmp     ch,00h
        je      @@1
        mov     ax,crHalfBlock
        mov     bl,[CursorLines]
        shr     bl,1
        cmp     ch,bl
        jbe     @@1
        mov     ax,crUnderline
@@1:
end;


procedure SetCursorType(NewType: Word); assembler;
asm
        mov     ah,01h
        mov     bx,[NewType]
        mov     cx,2000h
        cmp     bx,crHidden
        je      @@1
        mov     ch,[CursorLines]
        mov     cl,ch
        shr     ch,1
        cmp     bx,crHalfBlock
        je      @@1
        mov     ch,0
        cmp     bx,crBlock
        je      @@1
        mov     cl,[CursorLines]
        mov     ch,cl
        dec     ch
@@1:
        int     10h
end;


procedure ClearScreen;
begin
  FillWord(VideoBuf^,VideoBufSize shr 1,$0720);
{$ifdef use_buf}
  UpdateScreen(true);
{$endif}
end;


procedure UpdateScreen(Force: Boolean);
{$ifdef use_buf}
var
  SwapPtr : PVideoBuf;
{$endif}
begin
  if LockUpdateScreen<>0 then
   exit;
{$ifdef use_buf}
  if not force then
   begin
     asm
        mov     cx,word ptr VideoBufSize
        shr     cx,1
        les     di,OldVideoBuf
        push    ds
        lds     si,VideoBuf
        repe    cmpsw
        pop     ds
        or      cx,cx
        jz      @@10
        mov     force,1
@@10:
     end;
   end;
  if force then
   begin
     move(videobuf^,ptr(videoseg,0)^,VideoBufSize);
     move(videobuf^,oldvideobuf^,VideoBufSize);
   end;
{$endif}
end;


function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean; assembler;
asm
        mov     ax,[word ptr Params+0]
        mov     bx,[word ptr Params+2]
        push    bp
        int     10h
        pop     bp
        mov     al,1
end;


procedure RegisterVideoModes;
begin
  RegisterVideoMode(40, 25, False, DefaultVideoModeSelector, $00000000);
  RegisterVideoMode(40, 25, True, DefaultVideoModeSelector, $00000001);
  RegisterVideoMode(80, 25, False, DefaultVideoModeSelector, $00000002);
  RegisterVideoMode(80, 25, True, DefaultVideoModeSelector, $00000003);
end;

{
  $Log: video.inc,v $
  Revision 1.1.2.2  2000/10/04 11:44:33  pierre
   add TargetEntry and TargetExit procedures (needed for linux)

  Revision 1.1.2.1  2000/07/18 05:56:01  michael
  + Changes from Gabor

  Revision 1.1  2000/07/18 05:54:00  michael
  + File from Gabor

  Revision 1.1  2000/01/06 01:20:31  peter
    * moved out of packages/ back to topdir

  Revision 1.1  1999/11/24 23:36:38  peter
    * moved to packages dir

  Revision 1.3  1998/12/15 17:17:18  peter
    + cursor at 1,1 at the end

  Revision 1.2  1998/12/15 10:25:16  peter
    * Use Segb800 instead of $b800

  Revision 1.1  1998/12/04 12:48:57  peter
    * moved some dirs

  Revision 1.4  1998/11/01 20:29:13  peter
    + lockupdatescreen counter to not let updatescreen() update

  Revision 1.3  1998/10/28 21:18:28  peter
    * more fixes

  Revision 1.2  1998/10/28 00:02:09  peter
    + mouse
    + video.clearscreen, video.videobufsize

  Revision 1.1  1998/10/26 11:31:49  peter
    + inital include files

}