diff --git a/rtl/morphos/video.pp b/rtl/morphos/video.pp index 7a2273edda..9cce21e857 100644 --- a/rtl/morphos/video.pp +++ b/rtl/morphos/video.pp @@ -22,9 +22,16 @@ uses {$i videoh.inc} + +{ Amiga specific calls, to help interaction between Keyboard, Mouse and + Video units, and Free Vision } +procedure GotCloseWindow; +function HasCloseWindow: boolean; + var videoWindow : pWindow; + implementation uses @@ -45,57 +52,36 @@ var videoPens : array[0..15] of longint; oldCursorX, oldCursorY: longint; - visibleCursor: boolean; - oldvisibleCursor: boolean; + cursorType: word; + oldcursorType: word; + + gotCloseWindowMsg: boolean; procedure SysInitVideo; var counter: longint; begin -// writeln('sysinitvideo'); InitGraphicsLibrary; InitIntuitionLibrary; -{ - ScreenColor:=true; - GetConsoleScreenBufferInfo(TextRec(Output).Handle, OrigConsoleInfo); - GetConsoleCursorInfo(TextRec(Output).Handle, OrigConsoleCursorInfo); - OrigCP := GetConsoleCP; - ConsoleInfo:=OrigConsoleInfo; - ConsoleCursorInfo:=OrigConsoleCursorInfo; - { - About the ConsoleCursorInfo record: There are 3 possible - structures in it that can be regarded as the 'screen': - - dwsize : contains the cols & row in current screen buffer. - - srwindow : Coordinates (relative to buffer) of upper left - & lower right corners of visible console. - - dmMaximumWindowSize : Maximal size of Screen buffer. - The first implementation of video used srWindow. After some - bug-reports, this was switched to dwMaximumWindowSize. - } - with ConsoleInfo.dwMaximumWindowSize do - begin - ScreenWidth:=X; - ScreenHeight:=Y; - end; - { TDrawBuffer only has FVMaxWidth elements - larger values lead to crashes } - if ScreenWidth> FVMaxWidth then - ScreenWidth:=FVMaxWidth; - CursorX:=ConsoleInfo.dwCursorPosition.x; - CursorY:=ConsoleInfo.dwCursorPosition.y; - if not ConsoleCursorInfo.bvisible then - CursorLines:=0 - else - CursorLines:=ConsoleCursorInfo.dwSize; -} + + // 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_MOUSEBUTTONS Or IDCMP_RAWKEYS, - WA_IDCMP,IDCMP_VANILLAKEY Or IDCMP_RAWKEY, + WA_IDCMP,IDCMP_VANILLAKEY Or IDCMP_RAWKEY Or + IDCMP_CLOSEWINDOW, 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) + WA_Flags,(WFLG_GIMMEZEROZERO Or WFLG_SMART_REFRESH Or WFLG_NOCAREREFRESH Or + WFLG_ACTIVATE Or WFLG_DRAGBAR Or WFLG_DEPTHGADGET Or +// WFLG_SIZEGADGET Or WFLG_SIZEBBOTTOM Or + WFLG_CLOSEGADGET) ]); ScreenWidth := 80; @@ -115,8 +101,10 @@ begin CursorY:=0; oldCursorX:=0; oldCursorY:=0; - visibleCursor:=true; - oldvisibleCursor:=true; + cursorType:=crHidden; + oldcursorType:=crHidden; + + gotCloseWindowMsg:=false; end; @@ -125,101 +113,18 @@ var counter: longint; begin if videoWindow<>nil then CloseWindow(videoWindow); for counter:=0 to 15 do ReleasePen(videoColorMap,videoPens[counter]); - -{ - SetConsoleScreenBufferSize (TextRec (Output).Handle, OrigConsoleInfo.dwSize); - SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, OrigConsoleInfo.srWindow); - SetConsoleCursorInfo(TextRec(Output).Handle, OrigConsoleCursorInfo); - SetConsoleCP(OrigCP); -} end; -function SysVideoModeSelector (const VideoMode: TVideoMode): boolean; +function SysSetVideoMode (Const Mode : TVideoMode) : Boolean; -{ -var MI: Console_Screen_Buffer_Info; - C: Coord; - SR: Small_Rect; -} -begin -{ - if not (GetConsoleScreenBufferInfo (TextRec (Output).Handle, MI)) then - SysVideoModeSelector := false - else - begin - with MI do - begin - C.X := VideoMode.Col; - C.Y := VideoMode.Row; - end; - with SR do - begin - Top := 0; - Left := 0; - { First, we need to make sure we reach the minimum window size - to always fit in the new buffer after changing buffer size. } - Right := MI.srWindow.Right - MI.srWindow.Left; - if VideoMode.Col <= Right then - Right := Pred (VideoMode.Col); - Bottom := MI.srWindow.Bottom - MI.srWindow.Top; - if VideoMode.Row <= Bottom then - Bottom := Pred (VideoMode.Row); - end; - if SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, SR) then - if SetConsoleScreenBufferSize (TextRec (Output).Handle, C) then - begin - with SR do - begin - { Now, we can resize the window to the final size. } - Right := Pred (VideoMode.Col); - Bottom := Pred (VideoMode.Row); - end; - if SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, SR) then - begin - SysVideoModeSelector := true; - SetCursorType (LastCursorType); - ClearScreen; - end - else - begin - SysVideoModeSelector := false; - SetConsoleScreenBufferSize (TextRec (Output).Handle, MI.dwSize); - SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, MI.srWindow); - SetCursorType (LastCursorType); - end - end - else - begin - SysVideoModeSelector := false; - SetConsoleWindowInfo (cardinal (TextRec (Output).Handle), true, MI.srWindow); - SetCursorType (LastCursorType); - end - else - SysVideoModeSelector := false; - end; -} -end; - -Const - SysVideoModeCount = 6; - SysVMD : Array[0..SysVideoModeCount-1] of TVideoMode = ( - (Col: 40; Row: 25; Color: True), - (Col: 80; Row: 25; Color: True), - (Col: 80; Row: 30; Color: True), - (Col: 80; Row: 43; Color: True), - (Col: 80; Row: 50; Color: True), - (Col: 80; Row: 25; Color: True) // Reserved for TargetEntry - ); - - -Function SysSetVideoMode (Const Mode : TVideoMode) : Boolean; - -Var +var I : Integer; begin + +{ I:=SysVideoModeCount-1; SysSetVideoMode:=False; While (I>=0) and Not SysSetVideoMode do @@ -238,21 +143,9 @@ begin ScreenColor:=SysVMD[I].Color; end else SysSetVideoMode := false; end; +} end; -Function SysGetVideoModeData (Index : Word; Var Data : TVideoMode) : boolean; - -begin - SysGetVideoModeData:=(Index<=high(SysVMD)); - If SysGetVideoModeData then - Data:=SysVMD[Index]; -end; - -Function SysGetVideoModeCount : Word; - -begin - SysGetVideoModeCount:=SysVideoModeCount; -end; procedure SysClearScreen; begin @@ -260,7 +153,7 @@ begin end; -procedure DrawChar(x,y: longint; bitmap: pBitmap; drawCursor: boolean); +procedure DrawChar(x,y: longint; crType: word); var tmpCharData: word; tmpChar : byte; tmpFGColor : byte; @@ -273,17 +166,24 @@ begin tmpChar :=tmpCharData and $0ff; tmpFGColor :=(tmpCharData shr 8) and %00001111; tmpBGColor :=(tmpCharData shr 12) and %00000111; - + sX:=x*8; sY:=y*16; - - SetAPen(videoWindow^.Rport,videoPens[tmpFGColor]); - SetBPen(videoWindow^.RPort,videoPens[tmpBGColor]); + + 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 drawCursor then begin - 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); + + 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; @@ -292,11 +192,12 @@ procedure SysUpdateScreen(force: boolean); var BufCounter : Longint; smallforce : boolean; - + cursormoved : boolean; counter, counterX, counterY: longint; -var - tmpBitmap : tBitmap; begin + smallforce:=false; + cursormoved:=false; + if force then smallforce:=true else begin @@ -312,21 +213,23 @@ begin for counterY:=0 to ScreenHeight-1 do begin for counterX:=0 to ScreenWidth-1 do begin if VideoBuf^[BufCounter]<>OldVideoBuf^[BufCounter] then - DrawChar(counterX,counterY,@tmpBitmap,false); + DrawChar(counterX,counterY,crHidden); Inc(BufCounter); end; end; move(VideoBuf^,OldVideoBuf^,VideoBufSize); end; - if (oldvisibleCursor<>visibleCursor) or (CursorX<>oldCursorX) or (CursorY<>oldCursorY) then begin - writeln('kurzor:',cursorx,' ',cursory); - DrawChar(oldCursorY,oldCursorX,@tmpBitmap,false); - DrawChar(CursorY,CursorX,@tmpBitmap,visibleCursor); + 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; - oldVisibleCursor:=visibleCursor; + oldcursorType:=cursorType; end; + end; @@ -344,54 +247,33 @@ end; function SysGetCursorType: Word; begin - if not visibleCursor then SysGetCursorType:=crHidden - else SysGetCursorType:=crUnderline; - -{ - GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo); - if not ConsoleCursorInfo.bvisible then - SysGetCursorType:=crHidden - else - case ConsoleCursorInfo.dwSize of - 1..30: - SysGetCursorType:=crUnderline; - 31..70: - SysGetCursorType:=crHalfBlock; - 71..100: - SysGetCursorType:=crBlock; - end; -} + SysGetCursorType:=cursorType; end; procedure SysSetCursorType(NewType: Word); begin - if newType=crHidden then visibleCursor:=false - else visibleCursor:=true; + cursorType:=newType; + { FIXME: halfBlock cursors are not supported for now + by the rendering code } + if cursorType = crHalfBlock then cursorType:=crBlock; + SysUpdateScreen(false); -{ - GetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo); - if newType=crHidden then - ConsoleCursorInfo.bvisible:=false - else - begin - ConsoleCursorInfo.bvisible:=true; - case NewType of - crUnderline: - ConsoleCursorInfo.dwSize:=10; - - crHalfBlock: - ConsoleCursorInfo.dwSize:=50; - - crBlock: - ConsoleCursorInfo.dwSize:=99; - end - end; - SetConsoleCursorInfo(TextRec(Output).Handle,ConsoleCursorInfo); -} end; +// Amiga specific calls +procedure GotCloseWindow; +begin + gotCloseWindowMsg:=true; +end; + +function HasCloseWindow: boolean; +begin + HasCloseWindow:=gotCloseWindowMsg; + gotCloseWindowMsg:=false; +end; + const SysVideoDriver : TVideoDriver = ( @@ -400,13 +282,12 @@ const UpdateScreen : @SysUpdateScreen; ClearScreen : @SysClearScreen; SetVideoMode : @SysSetVideoMode; - GetVideoModeCount : @SysGetVideoModeCount; - GetVideoModeData : @SysGetVideoModeData; + GetVideoModeCount : nil; + GetVideoModeData : nil; SetCursorPos : @SysSetCursorPos; GetCursorType : @SysGetCursorType; SetCursorType : @SysSetCursorType; GetCapabilities : @SysGetCapabilities - );