fpc/rtl/morphos/video.pp

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 2006 by Karoly Balogh
    member of the Free Pascal development team

    Video unit for Amiga and MorphOS

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
unit Video;

interface

uses
  intuition;

{$i videoh.inc}


{ Amiga specific calls, to help interaction between Keyboard, Mouse and
  Video units, and Free Vision }
procedure GotCloseWindow;
function HasCloseWindow: boolean;
procedure GotResizeWindow;
function HasResizeWindow(var winw:longint; var winh: longint): boolean;

var
   videoWindow   : pWindow;


implementation

uses
   exec, graphics;

{$i video.inc}

{$i videodata.inc}

const
    LastCursorType: word = crUnderline;
    OrigScreen: PVideoBuf = nil;
    OrigScreenSize: cardinal = 0;

var
   videoColorMap : pColorMap;
   videoPens     : array[0..15] of longint;

   oldCursorX, oldCursorY: longint;
   cursorType: word;
   oldcursorType: word;

   gotCloseWindowMsg: boolean;
   gotResizeWindowMsg: boolean;

procedure SysInitVideo;
var counter: longint;
begin
   InitGraphicsLibrary;
   InitIntuitionLibrary;

   // fill videobuf and oldvideobuf with different bytes, to allow proper first draw
   FillDword(VideoBuf^,VideoBufSize Div 4,$1234D3AD);
   FillDword(OldVideoBuf^,VideoBufSize Div 4,$4321BEEF);

   videoWindow:=OpenWindowTags(Nil, [
      WA_Left,50,
      WA_Top,50,
      WA_InnerWidth,80*8,
      WA_InnerHeight,25*16,
      WA_MaxWidth,32768,
      WA_MaxHeight,32768,
      WA_IDCMP,IDCMP_VANILLAKEY Or IDCMP_RAWKEY Or
               IDCMP_MOUSEMOVE Or IDCMP_MOUSEBUTTONS Or
               IDCMP_CLOSEWINDOW Or IDCMP_CHANGEWINDOW,
      WA_Title,DWord(PChar('Free Pascal Video Output')),
      WA_Flags,(WFLG_GIMMEZEROZERO Or WFLG_SMART_REFRESH Or WFLG_NOCAREREFRESH Or
                WFLG_ACTIVATE Or WFLG_DRAGBAR Or WFLG_DEPTHGADGET Or WFLG_REPORTMOUSE Or
                WFLG_SIZEGADGET Or WFLG_SIZEBBOTTOM Or WFLG_RMBTRAP Or
                WFLG_CLOSEGADGET)
   ]);

   ScreenWidth := 80;
   ScreenHeight := 25;
   ScreenColor := true;

   videoColorMap := pScreen(videoWindow^.WScreen)^.ViewPort.ColorMap;
   for counter:=0 to 15 do begin
     videoPens[counter]:=ObtainPen(videoColorMap,-1,
         vgacolors[counter,0] shl 24,vgacolors[counter,1] shl 24,vgacolors[counter,2] shl 24,
         PEN_EXCLUSIVE);
//     writeln(videoPens[counter]);
     // XXX: do checks for -1 colors (KB)
   end;

   CursorX:=0;
   CursorY:=0;
   oldCursorX:=0;
   oldCursorY:=0;
   cursorType:=crHidden;
   oldcursorType:=crHidden;

   gotCloseWindowMsg:=false;
   gotResizeWindowMsg:=false;
end;


procedure SysDoneVideo;
var counter: longint;
begin
   if videoWindow<>nil then CloseWindow(videoWindow);
   for counter:=0 to 15 do ReleasePen(videoColorMap,videoPens[counter]);
end;



function SysSetVideoMode (Const Mode : TVideoMode) : Boolean;

var
  I : Integer;
  dx : integer;
  dy : integer;
begin
  dx := (Mode.col * 8) - videoWindow^.GZZWidth;
  dy := (Mode.row * 16) - videoWindow^.GZZHeight;
  SizeWindow(videoWindow,dx,dy);

  ScreenWidth:=Mode.col;
  ScreenHeight:=Mode.row;
  ScreenColor:=Mode.color;
  SysSetVideoMode:=true;
end;

var
  oldSH, oldSW : longint;

procedure SysClearScreen;
begin
  oldSH := -1;
  oldSW := -1;
  UpdateScreen(true);
end;


procedure DrawChar(x,y: longint; crType: word);
var tmpCharData: word;
    tmpChar    : byte;
    tmpFGColor : byte;
    tmpBGColor : byte;
var
    counterX, counterY:longint;
    sX,sY: longint;
begin
  tmpCharData:=VideoBuf^[y*ScreenWidth+x];
  tmpChar    :=tmpCharData and $0ff;
  tmpFGColor :=(tmpCharData shr 8) and %00001111;
  tmpBGColor :=(tmpCharData shr 12) and %00000111;

  sX:=x*8;
  sY:=y*16;

  if crType <> crBlock then begin
    SetABPenDrMd(videoWindow^.RPort,videoPens[tmpFGColor],videoPens[tmpBGColor],JAM2);
  end else begin
    { in case of block cursor, swap fg/bg colors
      and BltTemplate() below will take care of everything }
    SetABPenDrMd(videoWindow^.RPort,videoPens[tmpBGColor],videoPens[tmpFGColor],JAM2);
  end;

  BltTemplate(@vgafont[tmpChar,0],0,1,videoWindow^.RPort,sX,sY,8,16);

  if crType = crUnderLine then begin
    { draw two lines at the bottom of the char, in case of underline cursor }
    gfxMove(videoWindow^.RPort,sX,sY+14); Draw(videoWindow^.RPort,sX+7,sY+14);
    gfxMove(videoWindow^.RPort,sX,sY+15); Draw(videoWindow^.RPort,sX+7,sY+15);
  end;
end;


procedure SysUpdateScreen(force: boolean);
var
   BufCounter  : Longint;
   smallforce  : boolean;
   cursormoved : boolean;
   counter, counterX, counterY: longint;
begin
  smallforce:=false;
  cursormoved:=false;

  // override forced update when screen dimensions haven't changed
  if force then begin
    if (oldSH = ScreenHeight) and
       (oldSW = ScreenWidth) then
      force:=false
    else begin
      oldSH := ScreenHeight;
      oldSW := ScreenWidth;
    end;
  end;

  if force then begin
    smallforce:=true;
  end else begin
    counter:=0;
    while not smallforce and (counter<(VideoBufSize div 4)-1) do begin
      smallforce:=(PDWord(VideoBuf)[counter] <> PDWord(OldVideoBuf)[counter]);
      inc(counter);
    end;
  end;

  BufCounter:=0;
  if smallforce then begin
    for counterY:=0 to ScreenHeight-1 do begin
      for counterX:=0 to ScreenWidth-1 do begin
        if (VideoBuf^[BufCounter]<>OldVideoBuf^[BufCounter]) or force then
          DrawChar(counterX,counterY,crHidden);
        Inc(BufCounter);
      end;
    end;
    move(VideoBuf^,OldVideoBuf^,VideoBufSize);
  end;

  if (cursorType<>oldcursorType) or
     (CursorX<>oldCursorX) or (CursorY<>oldCursorY) or
     smallforce then begin
    DrawChar(oldCursorY,oldCursorX,crHidden);
    DrawChar(CursorY,CursorX,cursorType);
    oldCursorX:=CursorX;
    oldCursorY:=CursorY;
    oldcursorType:=cursorType;
  end;

end;


procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
begin
  CursorX:=NewCursorY;
  CursorY:=NewCursorX;
  SysUpdateScreen(false);
end;

function SysGetCapabilities: Word;
begin
  SysGetCapabilities:=cpColor or cpChangeCursor;
end;

function SysGetCursorType: Word;
begin
  SysGetCursorType:=cursorType;
end;


procedure SysSetCursorType(NewType: Word);
begin
  cursorType:=newType;
  { FIXME: halfBlock cursors are not supported for now
           by the rendering code }
  if cursorType = crHalfBlock then cursorType:=crBlock;

  SysUpdateScreen(false);
end;


// Amiga specific calls
procedure GotCloseWindow;
begin
  gotCloseWindowMsg:=true;
end;

function HasCloseWindow: boolean;
begin
  HasCloseWindow:=gotCloseWindowMsg;
  gotCloseWindowMsg:=false;
end;

procedure GotResizeWindow;
begin
  gotResizeWindowMsg:=true;
end;

function HasResizeWindow(var winw:longint; var winh: longint): boolean;
begin
  HasResizeWindow:=gotResizeWindowMsg;
  winw:=videoWindow^.GZZWidth div 8;
  winh:=videoWindow^.GZZHeight div 16;
  gotResizeWindowMsg:=false;
end;


const
  SysVideoDriver : TVideoDriver = (
    InitDriver : @SysInitVideo;
    DoneDriver : @SysDoneVideo;
    UpdateScreen : @SysUpdateScreen;
    ClearScreen : @SysClearScreen;
    SetVideoMode : @SysSetVideoMode;
    GetVideoModeCount : nil;
    GetVideoModeData : nil;
    SetCursorPos : @SysSetCursorPos;
    GetCursorType : @SysGetCursorType;
    SetCursorType : @SysSetCursorType;
    GetCapabilities : @SysGetCapabilities
  );


initialization
  SetVideoDriver(SysVideoDriver);
end.