badpork/kolibrios
1
0
Fork 0
forked from KolibriOS/kolibrios
Code Pull Requests Activity

[FP] changes in RTL, gfx example

Browse Source 
git-svn-id: svn://kolibrios.org@666 a494cfbc-eb01-0410-851d-a64ba20cac60
This commit is contained in:
bw 2007-10-27 16:38:51 +00:00
parent c1f806239d
commit bafb2d78f4
11 changed files with 425 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
programs/develop/fp/examples/_build.bat
View File

@ -2,7 +2,7 @@
set NAME=%1
set NAMEEXE=%NAME%.exe
set NAMEKOS=%NAME%
set NAMEKEX=%NAME%.kex
set BUILD=-FUbuild
set UNTS=-Fu..\units
@ -10,8 +10,9 @@ set UNTS=-Fu..\units
fpc %NAME%.pp -n -Twin32 -Se5 -XXs -Sg -O3pPENTIUM3 -CfSSE -WB0 %BUILD% %UNTS%
if errorlevel 1 goto error
..\exe2kos\exe2kos.exe %NAMEEXE% %NAMEKOS%.kex
..\exe2kos\exe2kos.exe %NAMEEXE% %NAMEKEX%
del %NAMEEXE%
move %NAMEKEX% bin
goto end
:error

1
programs/develop/fp/examples/ray.bat Normal file
View File

@ -0,0 +1 @@
@call _build.bat ray

256
programs/develop/fp/examples/ray.pp Normal file
View File

@ -0,0 +1,256 @@
{ ‚ FreePascal 2.2.0 ª®¤¨à®¢ª  cp866 ­¥ ॠ«¨§®¢ ­ . }
{-$codepage cp866}
{$mode objfpc}
{$apptype gui}
{$r-}
program Ray;
const
MSG_PRESSKEY = '<27> ¦¬¨ ­  ª­®¯ªã...';
MSG_USAGE = '„«ï ¯¥à¥¬¥è¥­¨ï ¨ ¢à è¥­¨ï ¨á¯®«ì§ã© áâ५ª¨';
WIDTH = 320;
HEIGHT = 200;
COLORS = 128;
FlatPalette: array[1..COLORS * 3] of Byte = (
0,10,20,48,48,48,1,0,43,1,3,43,2,5,44,2,7,44,3,9,45,4,11,46,5,13,47,6,15,48,
7,17,49,8,19,50,9,21,51,10,22,52,11,24,52,12,26,54,13,28,54,14,30,56,15,32,
56,16,34,58,17,34,58,17,36,58,18,38,60,19,40,60,20,42,62,21,44,62,10,31,0,
11,31,0,11,31,1,11,32,1,12,32,1,12,32,2,12,33,2,13,33,2,14,33,3,15,33,3,15,
34,3,15,34,4,15,35,4,16,35,4,16,35,5,16,36,5,17,36,5,17,36,6,18,37,6,18,38,
7,19,38,8,20,39,8,20,40,9,21,40,10,22,41,10,22,42,11,23,42,12,24,43,12,24,
44,13,25,44,14,25,45,14,26,46,15,27,46,16,27,47,17,28,47,18,28,48,19,29,49,
19,30,49,20,30,50,21,31,51,21,32,51,22,32,52,23,33,53,23,34,53,24,34,54,25,
35,55,25,36,55,26,36,56,27,37,57,27,38,57,27,39,57,27,41,57,27,42,57,27,43,
57,27,44,57,27,45,57,27,46,57,27,47,57,27,49,57,27,50,57,27,51,57,27,52,57,
27,53,57,27,55,57,27,56,57,27,57,57,27,58,57,27,58,57,26,58,57,25,58,57,24,
58,56,23,58,55,22,58,54,20,58,53,19,58,51,18,58,50,17,58,50,16,58,49,15,58,
48,14,58,47,13,58,46,12,58,45,11,58,44,11,58,44,10,58,43,10,58,42,9,57,41,
8,57,40,8,56,39,7,56,38,6,55,37,5,55,35,4,54,33,4,54,31,2,32,32,32,63,63,63,
63,63,63,63,63,63,63,63,63,48,48,48,63,63,63,63,63,63);
type
TRGBColor = packed record
R, G, B: Byte;
end;
PRGBPalette = ^TRGBPalette;
TRGBPalette = array[0..COLORS - 1] of TRGBColor;
PRGBBuffer = ^TRGBBuffer;
TRGBBuffer = array[0..HEIGHT - 1, 0..WIDTH - 1] of TRGBColor;
lrgarr = array[Word] of Byte;
sq = array[0..254, 0..255] of Byte;
var
mp: ^lrgarr;
rng: array[0..320] of Byte;
fcos, fsin: array[0..359] of Integer;
RGBBuffer : PRGBBuffer;
RGBPalette: TRGBPalette absolute FlatPalette;
Message: String = '';
function NCol(mc, n, dvd: Longint): Byte;
var
loc: Byte;
begin
loc := Byte((mc + n - Random(2 * n)) div dvd);
if loc > 100 then Result := 100 else
if loc < 5 then Result := 5 else
Result := loc;
end;
procedure Plasma(x1, y1, x2, y2: Word);
var
xn, yn, dxy : Word;
p1, p2, p3, p4: Word;
begin
if (x2 - x1 > 1) or (y2 - y1 > 1) then
begin
p1 := mp^[Word(y1 shl 8 + x1)];
p2 := mp^[Word(y2 shl 8 + x1)];
p3 := mp^[Word(y1 shl 8 + x2)];
p4 := mp^[Word(y2 shl 8 + x2)];
xn := (x2 + x1) shr 1;
yn := (y2 + y1) shr 1;
dxy:= 5 * (x2 - x1 + y2 - y1) div 3;
if mp^[y1 shl 8 + xn] = 0 then mp^[Word(y1 shl 8 + xn)] := NCol(p1 + p3, dxy, 2);
if mp^[yn shl 8 + x1] = 0 then mp^[Word(yn shl 8 + x1)] := NCol(p1 + p2, dxy, 2);
if mp^[yn shl 8 + x2] = 0 then mp^[Word(yn shl 8 + x2)] := NCol(p3 + p4, dxy, 2);
if mp^[y2 shl 8 + xn] = 0 then mp^[Word(y2 shl 8 + xn)] := NCol(p2 + p4, dxy, 2);
mp^[Word(yn shl 8 + xn)] := NCol(p1 + p2 + p3 + p4, dxy, 4);
Plasma(x1, y1, xn, yn);
Plasma(xn, y1, x2, yn);
Plasma(x1, yn, xn, y2);
Plasma(xn, yn, x2, y2);
end;
end;
procedure Draw(xp, yp, dir: Integer);
var
z, zobs : Integer;
ix, iy, iy1, iyp, ixp : Integer;
x, y : Integer;
s, csf, snf, mpc, i, j: Integer;
begin
while dir < 0 do Inc(dir, SizeOf(fcos));
while dir >= SizeOf(fcos) do Dec(dir, SizeOf(fcos));
FillChar(rng, SizeOf(rng), 200);
FillChar(RGBBuffer^, SizeOf(RGBBuffer^), 0);
zobs := 300 + mp^[Word(yp shl 8 + xp)];
csf := fcos[dir];
snf := fsin[dir];
for iy := yp to yp+150 do
begin
iy1 := 1 + 2 * (iy - yp);
s := 4 + 300 div iy1;
for ix := xp + yp - iy to xp - yp + iy do
begin
ixp := xp + ((ix - xp) * csf + (iy - yp) * snf) shr 8;
iyp := yp + ((iy - yp) * csf - (ix - xp) * snf) shr 8;
x := 160 + 360 * (ix - xp) div iy1;
if (x >= 0) and (x + s < 319) then
begin
z := mp^[Word(iyp shl 8 + ixp)];
mpc := z shr 1;
if z < 40 then z := 40;
y := 100 + (zobs - z) * 30 div iy1;
if (y < 200) and (y >= 0) then
for j := x to x + s do
if y < rng[j] then
begin
for i := y to rng[j] do
RGBBuffer^[i - 1, j] := RGBPalette[mpc];
rng[j] := y;
end;
end;
end;
end;
end;
procedure Paint;
begin
kos_begindraw();
kos_definewindow(100, 100, WIDTH - 1, HEIGHT - 1, $01000000);
kos_drawimage24(0, 0, WIDTH, HEIGHT, RGBBuffer);
if Message <> '' then
kos_drawtext(12, HEIGHT - 12 - 9, Message, $00FF00, $FF000000);
kos_enddraw();
end;
function ReadKey: Char;
var
Event: Word;
begin
kos_maskevents(ME_PAINT or ME_KEYBOARD);
repeat
Event := kos_getevent();
if Event = SE_PAINT then Paint;
until Event = SE_KEYBOARD;
Result := Chr(kos_getkey() shr 8);
end;
procedure Pause;
begin
kos_maskevents(ME_PAINT or ME_KEYBOARD);
Message := MSG_PRESSKEY;
Paint;
ReadKey;
end;
var
dir, i, j, x, y: Longint;
C: Char;
B: Byte;
Terminate: Boolean;
begin
{ â ¡«¨æë §­ ç¥­¨© ᨭãá  ¨ ª®á¨­ãá  }
for i := 0 to 359 do
begin
fcos[i] := Trunc(256 * Cos(i / 180 * Pi));
fsin[i] := Trunc(256 * Sin(i / 180 * Pi));
end;
{ ᮧ¤ ¥¬ ¡ãä¥à á íä䥪⮬ "¯« §¬ " }
New(mp);
FillChar(mp^, SizeOf(mp^), 0);
mp^[$0000] := 128;
Plasma(0, 0, 256, 256);
{ ᮧ¤ ¥¬ "¯ãá⮩" ¡ãä¥à ª ¤à  }
New(RGBBuffer);
FillChar(RGBBuffer^, SizeOf(RGBBuffer^), 0);
{ ¯à¥®¡à §®¢ ­¨¥ ¯ «¨âàë ¨§ 63 ¢ 255 }
for i := 0 to COLORS - 1 do
begin
B := Round(RGBPalette[i].R / 63 * 255);
RGBPalette[i].R := Round(RGBPalette[i].B / 63 * 255);
RGBPalette[i].G := Round(RGBPalette[i].G / 63 * 255);
RGBPalette[i].B := B;
end;
for j := 0 to 199 do
for i := 0 to 255 do
RGBBuffer^[j, i + (WIDTH - 256) shr 1] := RGBPalette[sq(Pointer(mp)^)[j, i]];
Pause;
x := 0;
y := 0;
dir := 0;
Message := MSG_USAGE;
Terminate := False;
while not Terminate do
begin
dir := dir mod 360;
if dir < 0 then dir := 360 + dir;
Draw(x, y, dir);
Paint;
C := ReadKey;
if C = #$B0 then Dec(dir, 13) else
if C = #$B3 then Inc(dir, 13) else
if C = #$B2 then
begin
y := y + fcos[dir] shr 6;
x := x + fsin[dir] shr 6;
end else
if C = #$B1 then
begin
y := y - fcos[dir] shr 6;
x := x - fsin[dir] shr 6;
end;
if C = #27 then Terminate := True;
end;
end.

2
programs/develop/fp/examples/readme-ru.txt
View File

@ -1,3 +1 @@
Codepage: cp866
„«ï ­ ç «  ­¥®¡å®¦¨¬® ᮡà âì RTL ¨ ã⨫¨âã exe2kos.

1
programs/develop/fp/readme-ru.txt
View File

@ -1,4 +1,3 @@
Codepage: cp866
’¥ªã騩 ª®¤  ¤ ¯â¨à®¢ ­ ¨ ¯à®¢¥àï«áï ⮫쪮 ­  FreePascal 2.2.0 ¯à¨ ª®¬¯¨«ï樨
¨§ Windows.

1
programs/develop/fp/rtl/_defines.inc
View File

@ -1,6 +1,5 @@
{$undef mswindows}
{$undef windows}
{$undef Windows}
{$undef win32}
{$undef os2}
{$undef linux}

3
programs/develop/fp/rtl/build.bat
View File

@ -3,7 +3,8 @@
set FPRTL={FreePascal RTL source code, example c:\fp\src\rtl}
set INCS=-Fi%FPRTL%\inc;%FPRTL%\i386;%FPRTL%\objpas;%FPRTL%\objpas\sysutils;%FPRTL%\objpas\classes
set UNTS=-Fu%FPRTL%\inc;%FPRTL%\i386;%FPRTL%\objpas
set FPCARGS=-Twin32 -Se5 -Sg -n -O3pPENTIUM3 -CfSSE -di386 -FU..\units %INCS% %UNTS%
set BUILDPATH=..\units
set FPCARGS=-n -Twin32 -Sge5 -O3pPENTIUM3 -CfSSE -di386 -FU%BUILDPATH% %INCS% %UNTS%
fpc system.pp -Us %FPCARGS%
if errorlevel 1 goto error

11
programs/develop/fp/rtl/kos.inc
View File

@ -388,6 +388,17 @@ asm
popl %eax
end;
{ Work with system - Get system parameters }
function kos_timecounter(): DWord; assembler; register;
asm
pushl %ebx
movl $26, %eax
movl $9, %ebx
int $0x40
popl %ebx
end;
{ Work with system - Internal system services }
procedure kos_switchthread(); assembler; register;

112
programs/develop/fp/rtl/kos_stdio.inc
View File

@ -2,6 +2,7 @@
procedure OpenStdout(var f: TextRec); forward;
procedure WriteStdout(var f: TextRec); forward;
procedure FlushStdout(var f: TextRec); forward;
procedure CloseStdout(var f: TextRec); forward;
procedure OpenStdin(var f: TextRec); forward;
@ -20,7 +21,7 @@ end;
procedure OpenStdout(var f: TextRec);
begin
TextRec(f).InOutFunc := @WriteStdout;
TextRec(f).FlushFunc := @WriteStdout;
TextRec(f).FlushFunc := @FlushStdout;
TextRec(f).CloseFunc := @CloseStdout;
end;
@ -34,6 +35,12 @@ begin
Konsole.Write(msg);
end;
procedure FlushStdout(var f: TextRec);
begin
WriteStdout(f);
Konsole.Flush;
end;
procedure CloseStdout(var f: TextRec);
begin
end;
@ -114,12 +121,14 @@ begin
while not Console^.FTerminate do
begin
Event := kos_getevent();
Console^.FOnAir := True;
if not Console^.FTerminate then
case Event of
SE_PAINT: Console^.Paint();
SE_KEYBOARD: Console^.ProcessKeyboard(kos_getkey());
SE_IPC: while Console^.ReceiveMessage(Message) do Console^.ProcessMessage(Message);
end;
Console^.FOnAir := False;
end;
Console^.FOpened := False;
end;
@ -143,6 +152,7 @@ begin
FMaxLines := 150;
FTerminate := False;
FOpened := False;
FOnAir := False;
FIPCBufferSize := SizeOf(TKosIPC) + IPC_SIZE;
FIPCBuffer := GetMem(FIPCBufferSize);
FIPCBuffer^.Lock := False;
@ -151,7 +161,6 @@ begin
FThreadID := BeginThread(TThreadFunc(@KonsoleThreadMain), @Self);
if FThreadID <> 0 then
{XXX: ¬®¦¥â § ¢¨á­ãâì}
{‚®, â ª ¨ ¥áâì ¢ 2.2.0.}
while not FOpened do ThreadSwitch;
end;
@ -164,10 +173,11 @@ begin
if FOpened then
begin
FOpened := False;
FOnAir := False;
KillThread(FThreadID);
end;
FreeMem(FIPCBuffer);
SetLength(FLines, 0);
{FreeMem(FIPCBuffer);
SetLength(FLines, 0);}
end;
function TKonsole.ReceiveMessage(var Message: ShortString): Boolean;
@ -176,9 +186,10 @@ var
PMsg: PKosMessage;
Size: Longword;
begin
FIPCBuffer^.Lock := True;
if FIPCBuffer^.Size > 0 then
begin
FIPCBuffer^.Lock := True;
PMsg := Pointer(Longword(FIPCBuffer) + SizeOf(TKosIPC));
{TODO: ¯à®¢¥àª  PMsg^.SenderID}
{Size := PMsg^.Size;
@ -210,38 +221,25 @@ end;
procedure TKonsole.ProcessMessage(Message: ShortString);
{ ‚뢥á⨠ᮮ¡é¥­¨¥ ­  ª®­á®«ì }
var
S: String;
LinesCount: Word;
CR, LF, W: Word;
BottomRow: Boolean = True;
begin
if Length(Message) < 1 then Exit;
OnlyBottomLine: Boolean = True;
repeat
CR := Pos(#13, Message);
LF := Pos(#10, Message);
if (CR > 0) and ((CR < LF) or (LF <= 0)) then
W := CR else
if LF > 0 then
W := LF else
W := Length(Message) + 1;
if W > 0 then
procedure PutChar(C: Char);
var
LinesCount: Longint;
PLine: PShortString;
I: Longint;
begin
if W > 1 then
begin
S := Copy(Message, 1, W - 1);
Delete(FLines[FCursor.Y], FCursor.X, Length(FLines[FCursor.Y]) - FCursor.X);
Insert(S, FLines[FCursor.Y], FCursor.X);
Inc(FCursor.X, Length(S));
end;
Delete(Message, 1, W);
if W = CR then
{¯¥à¥¢®¤ ª®à¥âª¨ ¢ ­ ç «® áâப¨}
FCursor.X := 1 else
if W = LF then
{ ¯¥à¥¢®¤ ª®à¥âª¨ ­  ¯®§¨æ¨î ¢«¥¢® }
if C = #8 then
begin
if FCursor.X > 1 then
Dec(FCursor.X);
end else
{ ¯¥à¥¢®¤ ª®à¥âª¨ ­  á«¥¤ãîéãî áâபã }
BottomRow := False;
if C = #10 then
begin
OnlyBottomLine := False;
Inc(FCursor.Y);
LinesCount := Length(FLines);
while FCursor.Y >= FMaxLines do Dec(FCursor.Y, FMaxLines);
@ -252,11 +250,46 @@ begin
FLines[LinesCount] := '';
Inc(LinesCount);
end;
end;
end;
until Length(Message) <= 0;
end else
Paint(BottomRow);
{ ¯¥à¥¢®¤ ª®à¥âª¨ ¢ ­ ç «® áâப¨ }
if C = #13 then
FCursor.X := 1 else
{ ¯®¬¥é¥­¨¥ ᨬ¢®«  ¢ áâபã }
begin
if FCursor.X > 200 then
begin
PutChar(#13);
PutChar(#10);
end;
{ FIXME: …᫨ ¢ PascalMain ⮫쪮 ®¤¨­ Write/Ln, â® § ¢¨á®­.
á¬. FPC_DO_EXIT, InternalExit }
PLine := @FLines[FCursor.Y];
I := Length(PLine^);
if FCursor.X > I then
begin
SetLength(PLine^, FCursor.X);
Inc(I);
while I < FCursor.X do
begin
PLine^[I] := ' ';
Inc(I);
end;
end;
FLines[FCursor.Y][FCursor.X] := C;
Inc(FCursor.X);
end;
end;
var
I: Longint;
begin
for I := 1 to Length(Message) do
PutChar(Message[I]);
Paint(OnlyBottomLine);
end;
procedure TKonsole.ProcessKeyboard(Key: Word);
@ -351,3 +384,8 @@ begin
end;
end;
end;
procedure TKonsole.Flush();
begin
while FOnAir do ThreadSwitch;
end;

71
programs/develop/fp/rtl/kosh.inc
View File

@ -1,4 +1,4 @@
{}
{-$codepage cp866}
type
TKosPoint = packed record
@ -46,6 +46,9 @@ function kos_getthreadslot(tid: TThreadID): TThreadSlot;
{ Work with system - Set system parameters }
procedure kos_enablepci();
{ Work with system - Get system parameters }
function kos_timecounter(): DWord;
{ Work with system - Internal system services }
procedure kos_switchthread();
function kos_initheap(): DWord;
@ -67,7 +70,9 @@ type
MemoryUsage: DWord;
ThreadID: TThreadID;
WindowRect: TKosRect;
Unknown0: array[1..1066] of Byte;
Reserved3: DWord;
ClientRect: TKosRect;
Reserved4: array[1..1046] of Byte;
end;
{<EFBFBD>ãä¥à IPC}
@ -179,7 +184,7 @@ type
TKonsole = object
private
FCaption: String;
FLines: array of String;
FLines: array of ShortString;
FCursor: TKosPoint;
FMaxLines: Word;
FThreadID: TThreadID;
@ -188,6 +193,7 @@ type
FIPCBufferSize: DWord;
FTerminate: Boolean;
FOpened: Boolean;
FOnAir : Boolean;
FKeyPressed: Word;
function ReceiveMessage(var Message: ShortString): Boolean;
procedure ProcessMessage(Message: ShortString);
@ -195,6 +201,7 @@ type
function GetRect(): TKosRect;
function GetKeyPressed(): Word;
procedure Paint(BottomRow: Boolean = False);
procedure Flush();
public
constructor Init(ACaption: String = '');
destructor Done();
@ -205,7 +212,59 @@ type
property ThreadSlot: TThreadSlot read FThreadSlot; {JustForFun, must be hidden, do not use}
end;
IStreamIO = interface
function Read(Size: DWord = 0): AnsiString;
procedure Write(Str: AnsiString; Error: Boolean = False);
(*<EFBFBD> §à ¡®âª  â¥à¬¨­ «  ¢ à ¬ª å RTL ¯à¥ªà é¥­ . ’¥à¬¨­ « ¡ã¤¥â ¢ë¤¥«¥­ ¨§ ª®¤ 
ª®­á®«ì­®£® ¯à¨«®¦¥­¨ï ¨ ¤®«¦¥­ ¡ëâì ॠ«¨§®¢ ­ ª ª ®â¤¥«ì­ë© á¥à¢¨á á
¤¨­ ¬¨ç¥áª¨¬ ¯®¤ª«î祭¨¥¬, «¨¡® ª ª ®â¤¥«ì­ë© ¬®¤ã«ì FreePascal á® áâ â¨ç¥áª¨¬
¨«¨ ¤¨­ ¬¨ç¥áª¨¬ ¯®¤ª«î祭¨¥¬ â¥à¬¨­ «ì­®£® ä㭪樮­ « .
PTermKursor = ^TTermKursor;
TTermKursor = object
private
FVisible: Boolean;
procedure SetVisbile(Value: Boolean);
public
constructor Init;
procedure Repaint;
property Visible: Boolean read FVisible write SetVisbile;
end;
PTermKIO = ^TTermKIO;
TTermKIO = object
private
FBuffer: Pointer;
FBufferScreen: Pointer;
FBufferSize : Longword;
FBufferWidth: Longword;
FBufferLines: Longword;
FIPCBuffer: PKosIPC;
FIPCBufferSize: Longword;
FCursor: TTermKursor;
FCaption: String;
FThreadID: TThreadID;
FThreadSlot: TThreadSlot;
FTerminate: Boolean;
FOpened: Boolean;
FWindowBounds: TKosRect;
FWindowStyle : Longword;
FClientBounds: TKosRect;
FMaxWidth : Longword;
FFirstLine: Longword;
FDefaultChar: Word;
FPalette: array[0..15] of Longword;
procedure MainLoop;
procedure ReallocBuffer(Size: Longword);
procedure ResizeBuffer(NewWidth, NewLines: Longword);
procedure FillDefaultChar(var X; Count: Longword);
function GetLine(Index: Longint): Pointer;
function PrevLine(Line: Pointer): Pointer;
{function ReceiveMessage(var Message: ShortString): Boolean;
procedure ProcessMessage(Message: ShortString);}
procedure ProcessKeyboard(Key: Word);
procedure DoPaint(const Bounds: TKosRect);
procedure DoResize;
public
constructor Init(ACaption: String = '');
destructor Done;
procedure Write(Message: ShortString);
property Cursor: TTermKursor read FCursor;
end;*)

4
programs/develop/fp/rtl/system.pp
View File

@ -136,6 +136,7 @@ begin
end;
{$i kos_stdio.inc}
{-$i kos_term.inc}
procedure SysInitStdIO;
begin
@ -186,12 +187,13 @@ begin
SysResetFPU;
StackLength := CheckInitialStkLen(InitialStkLen);
StackBottom := Pointer(StackTop - StackLength);
InitHeap;
kos_initheap();
InitHeap;
SysInitExceptions;
FPC_CpuCodeInit();
InOutRes := 0;
InitSystemThreads;
if IsConsole then
Konsole.Init();
SysInitStdIO;
SetupCmdLine;