unit Kernelunit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, AppEvnts, typenunit,dglopengl,Inifiles;
type
PKernel = ^TKernel;
Tfunc=procedure (data:PKernel);
stdcall;
PFunktionsglied=^TFunktionsglied;
TFunktionsglied=record
davor:PFunktionsglied;
Funktion:cardinal;
danach:PFunktionsglied;
end;
TKonsole=class
private
FMsgpos:integer;
FBGColor:TRGBi;
Fvisible:boolean;
Fontsize:byte;
procedure SetBGColor(BGColor:TRGBi);
procedure Setmsgpos(msgpos:integer);
procedure ChangeVisible(visible:boolean);
public
keycodes:TInifile;
Script:TStringlist;
Msglist:TStringlist;
keyboardinput:
array of word;
keycount:word;
Scriptpos:cardinal;
maxlines:word;
systemfont:cardinal;
systempfad:
string;
befehl:
string;
value:Tstrarr;
translatedkeyarray:
string;
dauer:cardinal;
change:boolean;
booted:boolean;
port:Tviewport;
constructor create(AOwner:TComponent);
destructor destroy;
override;
property BGColor:TRGBi
read FBGColor
write SetBGColor;
property visible:boolean
read Fvisible
write ChangeVisible;
property msgpos:integer
read fmsgpos
write Setmsgpos;
procedure Init(port:Tviewport);
procedure MsgToBuffer();
procedure addmsg(text:
string;color:TRGBi);
procedure addscript(text:
string);
function TranslateKeyarray():
string;
procedure Keyinterpret(Sender: TObject;
var Key: Word;
Shift: TShiftState);
procedure makefree;
end;
TOpenGL =class
private
fdc:Hdc;
fhrc:hglrc;
fviewport:TViewport;
procedure Setdc(
dc:hdc);
procedure Sethrc(hrc:hglrc);
procedure Setviewport(viewport:TViewport);
public
initialized:boolean;
smartrenderbool:boolean;
property dc:hdc
read fdc
write setdc;
property hrc:hglrc
read fhrc
write sethrc;
property viewport:TViewport
read fviewport
write Setviewport;
procedure SmartInitialize(Owner:TComponent);
procedure SmartRender(Owner:TComponent);
procedure SmartFinalize(Owner:TComponent);
procedure DestroyDC(Owner:TComponent);
procedure makefree;
end;
TKernel =
class(TForm)
ApplicationEvents1: TApplicationEvents;
procedure FormKeyDown(Sender: TObject;
var Key: Word;
Shift: TShiftState);
procedure ApplicationEvents1Idle(Sender: TObject;
var Done: Boolean);
procedure FormCreate(Sender: TObject);
private
Tempspeicher:Tvars;
{ Private-Deklarationen }
public
tryclose:boolean;
Konsole:TKonsole;
OpenGL:TOpenGL;
funcnames:TStringlist;
functions:
array of TFunc;
deletedfunctions:
array of cardinal;
dyndllnames:Tstringlist;
dyndlls:
array of Thandle;
{ Public-Deklarationen }
renderfunctionskette:PFunktionsglied;
procedure Initmemory();
procedure Freememory();
procedure Freedlls();
function GetMemoryVars():TVars;
function Registervariable(size:Byte):cardinal;
procedure Freevariable(address:cardinal);
procedure Funktionsketteabarbeiten(address:PFunktionsglied);
procedure freefunktionskette(address:PFunktionsglied);
function Addfunktionsglied(address:PFunktionsglied;functionindex:cardinal;position:cardinal):cardinal;
function Delfunktionsglied(address:PFunktionsglied;position:cardinal):boolean;
function Addfunktion(
dll:THandle;
name:pansichar):integer;
function Delfunktion(
index:cardinal):boolean;
procedure beenden();
end;
var
Kernel: TKernel;
procedure interpret(data:PKernel);
stdcall;
external '
script.dll';
implementation
{$R *.dfm}
procedure TKonsole.SetBGColor(BGColor:TRGBi);
begin
FBGColor[0]:=BGColor[0];
FBGColor[1]:=BGColor[1];
FBGColor[2]:=BGColor[2];
end;
procedure TKonsole.addmsg(text:
string;color:TRGBi);
begin
msglist.Add(inttostr((color[0]*1000000)+(color[1]*1000)+(color[2]))+'
;'+text);
msgpos:=msglist.Count-maxlines;
end;
procedure TKonsole.addscript(text:
string);
begin
dauer:=0;
script.Add(text);
end;
function TKonsole.TranslateKeyarray():
string;
var i,code:word;
precode:byte;
text:
string;
begin
result:='
';
text:='
';
if length(keyboardinput)>0
then
begin
for i:=0
to length(keyboardinput)-1
do
begin
code:=keyboardinput[i];
precode:=code
div 1000;
code:=code
mod 1000;
case precode
of
0 :
begin
text:=keycodes.ReadString('
nothing',inttostr(code),'
');
end;
//Nix
1 :
begin
text:=keycodes.ReadString('
shift',inttostr(code),'
');
end;
//Umschalt
2 :
begin
text:=keycodes.ReadString('
alt',inttostr(code),'
');
end;
//Alt
3 :
begin
text:=keycodes.ReadString('
shiftalt',inttostr(code),'
');
end;
//Alt+Umschalt
5 :
begin
text:=keycodes.ReadString('
ctrl',inttostr(code),'
');
end;
//Ctrl
6 :
begin
text:=keycodes.ReadString('
shiftctrl',inttostr(code),'
');
end;
//Umschalt+Ctrl
7 :
begin
text:=keycodes.ReadString('
altctrl',inttostr(code),'
');
end;
//ctrl+Alt
8 :
begin
text:=keycodes.ReadString('
shiftaltctrl',inttostr(code),'
');
end;
end;
//Umschalt+Alt+Ctrl
result:=result+text;
change:=true;
end;
end;
end;
constructor TKonsole.create(AOwner:TComponent);
begin
inherited create;
systempfad:=extractfiledir((aowner.Owner
as TApplication).ExeName);
Script:=Tstringlist.Create;
Script.LoadFromFile(systempfad+'
\startscript.txt');
Scriptpos:=0;
Msglist:=TStringlist.Create;
Msglist.LoadFromFile(systempfad+'
\readme.txt');
keycodes:=TInifile.Create(systempfad+'
\keycodes.ini');
change:=false;
booted:=false;
visible:=false;
dauer:=0;
bgcolor:=bgblue;
fontsize:=20;
translatedkeyarray:='
';
end;
procedure TKonsole.Init(port:Tviewport);
begin
self.port[0]:=port[0];
self.port[1]:=port[1];
self.port[2]:=port[2];
self.port[3]:=port[3];
maxlines:=port[3]
div fontsize;
dec(maxlines);
end;
procedure TKonsole.MsgToBuffer();
var line_s,color:
string;
line_b:
array of Byte;
i,j,lines:word;
icolor:cardinal;
r,g,b:byte;
begin
glcolor3f(bgcolor[0]/255,bgcolor[1]/255,bgcolor[2]/255);
glbegin(gl_quads);
glvertex3i(port[0],port[1],-1);
glvertex3i(port[0],port[1]+port[3],-1);
glvertex3i(port[0]+port[2],port[1]+port[3],-1);
glvertex3i(port[0]+port[2],port[1],-1);
glend;
if msglist.Count>0
then
begin
if maxlines>(msglist.Count-msgpos)
then lines:=(msglist.Count-msgpos)
else lines:=maxlines;
for j:=1
to lines
do
begin
line_s:=msglist.Strings[j+msgpos-1];
color:=copy(line_s,0,ansipos('
;',line_s)-1);
line_s:=copy(line_s,ansipos('
;',line_s)+1,length(line_s));
if color='
'
then glcolor3f(0.8,0.8,0.8)
else
begin
icolor:=strtoint(color);
r:=icolor
div(1000000);
g:=(icolor
mod(1000000))
div(1000);
b:=icolor
mod(1000);
glcolor3f(1/255*r,1/255*g,1/255*b);
end;
glrasterpos3i(port[0],port[1]+port[3]-(fontsize*j),-1);
gllistbase(systemfont);
setlength(line_b,length(line_s));
if length(line_b)>80
then setlength(line_b,80);
if length(line_s)>0
then for i:=1
to length(line_b)
do line_b[i-1]:=ord(line_s[i]);
if length(line_b)>0
then glcalllists(length(line_b),gl_unsigned_byte,line_b);
end;
end;
glcolor3f(1,1,0);
glrasterpos3i(port[0],port[1],-1);
gllistbase(systemfont);
line_s:=translatedkeyarray;
setlength(line_b,length(line_s));
if length(line_b)>80
then setlength(line_b,80);
if length(line_b)>0
then for i:=1
to length(line_b)
do line_b[i-1]:=ord(line_s[i]);
if length(line_b)>0
then glcalllists(length(line_b),gl_unsigned_byte,line_b);
end;
procedure TKonsole.Setmsgpos(msgpos:integer);
begin
if msgpos>(msglist.Count-maxlines)
then msgpos:=msglist.Count-maxlines;
if msgpos<0
then msgpos:=0;
fmsgpos:=msgpos;
change:=true;
end;
procedure TKonsole.ChangeVisible(visible:boolean);
begin
Fvisible:=visible;
keycount:=0;
setlength(keyboardinput,0);
if visible
then msgpos:=msglist.Count;
end;
procedure TKonsole.Keyinterpret(Sender:Tobject;
var Key:Word;Shift:TShiftstate);
var modkey:word;
begin
case key
of
38 :
if msgpos>0
then msgpos:=msgpos-1;
40 :
if msgpos<msglist.Count-1
then msgpos:=msgpos+1;
8 :
if high(keyboardinput)>-1
then
begin
setlength(keyboardinput,high(keyboardinput));
dec(keycount);
translatedkeyarray:=translatekeyarray;
end;
13 :
begin
Addmsg(translatedkeyarray,yellow);
translatedkeyarray:=translatekeyarray;
addscript(translatedkeyarray);
keycount:=0;
setlength(keyboardinput,keycount);
translatedkeyarray:=translatekeyarray;
end;
else begin
inc(keycount);
setlength(keyboardinput,keycount);
modkey:=key;
if ssshift
in shift
then modkey:=modkey+1000;
if ssalt
in shift
then modkey:=modkey+2000;
if ssCtrl
in shift
then modkey:=modkey+5000;
keyboardinput[keycount-1]:=modkey;
translatedkeyarray:=translatekeyarray;
end;
end;
end;
destructor TKonsole.destroy;
begin
if assigned(Msglist)
then msglist.Free;
//??????????????????????????
if assigned(script)
then script.Free;
if assigned(keycodes)
then keycodes.Free;
inherited destroy;
end;
procedure TKonsole.makefree;
begin
end;
{------------------------------------------------------------------------------}
procedure TOpenGL.Setdc(
dc:hdc);
begin
fdc:=
dc;
end;
procedure TOpenGL.Sethrc(hrc:hglrc);
begin
fhrc:=hrc;
end;
procedure TOpenGL.Setviewport(viewport:TViewport);
begin
fviewport[0]:=viewport[0];
fviewport[1]:=viewport[1];
fviewport[2]:=viewport[2];
fviewport[3]:=viewport[3];
end;
procedure TOpenGL.SmartInitialize(Owner:TComponent);
var Font : HFONT;
begin
if (Owner
is TKernel)
then
begin
initialized:=true;
smartrenderbool:=true;
dc:=getdc((Owner
as TKernel).Handle);
if not InitOpenGL
then
begin
messagedlg('
Konnte OpenGL nicht initialisieren',mterror,[mbok],0);
initialized:=false;
end;
hrc:= CreateRenderingContext(
DC,[opDoubleBuffered],32,24,0,0,0,0);
ActivateRenderingContext(
DC,hrc);
(Owner
as TKernel).Konsole.systemfont:=glgenlists(256);
Font:=CreateFont(16, 0, 0, 0, FW_MEDIUM, 0, 0, 0, ANSI_CHARSET, OUT_TT_PRECIS, CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY, FF_DONTCARE
or DEFAULT_PITCH, '
Courier New');
SelectObject (
DC, Font);
wglUseFontBitmaps (
DC, 0, 255, (Owner
as TKernel).Konsole.systemfont);
DeleteObject(font);
end;
end;
procedure TOpenGL.SmartRender(Owner:TComponent);
begin
if (Owner
is TKernel)
then
begin
glMatrixMode(GL_PROJECTION);
glloadidentity;
glviewport(0,0,(Owner
as TKernel).Width,(Owner
as TKernel).Height);
glortho(0,(Owner
as TKernel).Width,0,(Owner
as TKernel).Height,-1,1);
glMatrixMode(GL_MODELVIEW);
glclearcolor(0,0,0,0);
glclear(GL_COLOR_BUFFER_BIT
or GL_DEPTH_BUFFER_BIT);
glloadidentity;
gldisable(gl_depth_test);
gldisable(gl_texture_2d);
gldisable(gl_blend);
gldisable(gl_alpha_test);
gldisable(gl_fog);
gldisable(gl_lighting);
if (Owner
as TKernel).Konsole.visible
then
begin
(Owner
as Tkernel).Konsole.MsgToBuffer;
(Owner
as Tkernel).Konsole.change:=false;
end;
end;
end;
procedure TOpenGL.SmartFinalize(Owner:TComponent);
begin
if (Owner
is TKernel)
then
begin
swapbuffers((Owner
as TKernel).OpenGL.dc);
end;
end;
procedure TOpengl.DestroyDC(Owner:Tcomponent);
begin
if Owner
is TKernel
then
begin
gldeletelists((Owner
as TKernel).Konsole.systemfont,256);
initialized:=false;
smartrenderbool:=false;
DeactivateRenderingContext;
DestroyRenderingContext(hrc);
ReleaseDC((Owner
as TKernel).Handle,
dc);
end;
end;
procedure TOpenGL.makefree;
begin
end;
{------------------------------------------------------------------------------}
procedure TKernel.FormKeyDown(Sender: TObject;
var Key: Word;
Shift: TShiftState);
begin
if key=220
then konsole.visible:=not konsole.visible;
if konsole.visible
and Opengl.initialized
then Konsole.Keyinterpret(Sender,Key,Shift);
end;
procedure TKernel.ApplicationEvents1Idle(Sender: TObject;
var Done: Boolean);
begin
if tryclose
then beenden
else
begin
Funktionsketteabarbeiten(renderfunctionskette);
if Opengl.smartrenderbool
then
begin
Opengl.SmartRender(self);
Opengl.SmartFinalize(self);
end;
end;
end;
procedure TKernel.FormCreate(Sender: TObject);
var port:Tviewport;
begin
initmemory;
tryclose:=false;
port[2]:=640;
port[3]:=240;
if (clientWidth-port[2])>0
then port[0]:=(clientWidth-port[2])
div 2
else port[0]:=0;
port[1]:=100;
konsole:=TKonsole.Create(self);
konsole.Init(port);
OpenGL:=TOpengl.Create;
Opengl.SmartInitialize(self);
funcnames:=TStringlist.Create;
dyndllnames:=Tstringlist.Create;
setlength(functions,1);
setlength(deletedfunctions,0);
functions[high(functions)]:=interpret;
new(renderfunctionskette);
renderfunctionskette^.Funktion:=high(functions);
renderfunctionskette^.danach:=nil;
funcnames.Add('
script.dll;interpret;');
end;
procedure TKernel.beenden();
begin
Opengl.DestroyDC(self);
Opengl.makeFree;
Opengl.Free;
Konsole.Free;
freefunktionskette(renderfunctionskette.danach);
freedlls;
freememory;
if assigned(funcnames)
then freeandnil(funcnames);
if assigned(dyndllnames)
then freeandnil(dyndllnames);
self.Close;
end;
procedure TKernel.Initmemory();
begin
setlength(tempspeicher,0);
end;
procedure Tkernel.Freememory();
var i:integer;
begin
for i:=0
to high(tempspeicher)
do
begin
if tempspeicher[i].flag>0
then
begin
freemem(tempspeicher[i].address,tempspeicher[i].size);
finalize(tempspeicher[i]);
end;
end;
end;
function Tkernel.GetMemoryVars:Tvars;
begin
result:=Tempspeicher;
end;
procedure TKernel.Freedlls();
var i:integer;
begin
for i:=0
to high(dyndlls)
do
begin
freelibrary(dyndlls[i]);
end;
end;
function Tkernel.Registervariable(size:Byte):cardinal;
var i:integer;
found:boolean;
begin
found:=false;
if High(tempspeicher)=-1
then
begin
setlength(tempspeicher,1);
getmem(tempspeicher[0].address,size);
tempspeicher[0].size:=size;
tempspeicher[0].flag:=1;
result:=0;
end
else
begin
for i:=0
to high(tempspeicher)
do
begin
if Tempspeicher[i].address=nil
then
begin
getmem(tempspeicher[i].address,size);
tempspeicher[i].size:=size;
tempspeicher[i].flag:=1;
result:=i;
break;
found:=true;
end;
end;
if not found
then
begin
setlength(tempspeicher,length(tempspeicher)+1);
getmem(tempspeicher[high(tempspeicher)].address,size);
tempspeicher[high(tempspeicher)].size:=size;
tempspeicher[high(tempspeicher)].flag:=1;
result:=high(tempspeicher);
end;
end;
end;
procedure TKernel.Freevariable(address:cardinal);
begin
if address< high(tempspeicher)
then
begin
freemem(tempspeicher[address].address,tempspeicher[address].size);
tempspeicher[address].flag:=0;
end;
end;
procedure TKernel.Funktionsketteabarbeiten(address:PFunktionsglied);
begin
if assigned(address)
then
begin
functions[address^.Funktion](@self);
if not (address^.danach=nil)
then Funktionsketteabarbeiten(address^.danach);
end;
end;
procedure TKernel.freeFunktionskette(address:PFunktionsglied);
begin
if assigned(address)
then
begin
if not (address^.danach=nil)
then Funktionsketteabarbeiten(address^.danach);
dispose(address);
end;
end;
function TKernel.Addfunktion(
dll:THandle;
name:PAnsichar):integer;
var i:integer;
begin
result:=-1;
if high(deletedfunctions)>-1
then
begin
@functions[deletedfunctions[high(deletedfunctions)]]:=getprocaddress(
dll,
name);
result:=deletedfunctions[high(deletedfunctions)];
setlength(deletedfunctions,high(deletedfunctions));
end;
if result=-1
then
begin
setlength(functions,length(functions)+1);
setlasterror(0);
@functions[high(functions)]:=getprocaddress(
dll,
name);
i:=getlasterror;
if i>0
then
begin
konsole.addmsg('
SYSTEM-ERROR: '+syserrormessage(i),red);
end;
if @functions[high(functions)]=nil
then setlength(functions,high(functions))
else result:=high(functions);
end;
end;
function TKernel.Delfunktion(
index:cardinal):boolean;
begin
result:=false;
if index<length(functions)
then
begin
setlength(deletedfunctions,length(deletedfunctions)+1);
deletedfunctions[high(deletedfunctions)]:=index;
result:=true;
end;
end;
function TKernel.Addfunktionsglied(address:PFunktionsglied;functionindex:cardinal;position:cardinal):cardinal;
var i:cardinal;
glied:PFunktionsglied;
begin
for i:=0
to position-1
do
begin
if not (address.danach=nil)
then address:=address^.danach
else
begin
new(glied);
address^.danach:=glied;
glied^.Funktion:=functionindex;
glied^.davor:=address;
glied^.danach:=nil;
result:=i;
end;
end;
if not (address.danach=nil)
then
begin
new(glied);
glied^.danach:=address^.danach;
address^.danach:=glied;
glied^.Funktion:=functionindex;
glied^.davor:=address;
address:=glied^.danach;
address^.davor:=glied;
result:=position;
end;
end;
function TKernel.Delfunktionsglied(address:PFunktionsglied;position:cardinal):boolean;
var i:cardinal;
glied:PFunktionsglied;
auserhalb:boolean;
begin
result:=false;
auserhalb:=false;
for i:=0
to position-1
do
begin
if address.danach=nil
then auserhalb:=true;
end;
if not auserhalb
then
begin
glied:=address^.davor;
glied^.danach:=address^.danach;
dispose(address);
end;
end;
end.