Hi, Can anyone check this prj to see it's happening the same than me?
Hi,
I have a little program working with Crt units without problem. I have
change the print way form, I have pushing Crt Commands inen Fifo (GotoXY,
ClrScr, ClrEol, Write,...) and I have created a Thread class to pop this
commands to execute it. Problem seems to be cursor position in tty which
is not working okey perhaps for using threads? Is any funtion to
syncronizing tty each time is writing or changing cursor position? version
of compiler a compiling output,
====================================================
Free Pascal Compiler version 2.0.0 [2005/05/15] for i386 Copyright (c)
1993-2005 by Florian Klaempfl Target OS: Linux for i386 Compiling test.dpr
Linking test_386 25 Lines compiled, 0.4 sec
====================================================
I have attached an example in order to test it,
tia!
best regards.
unit ApilarCrt;
interface
uses
{$IFDEF LINUX}
cthreads,
crt,
{$ENDIF}
Classes,
SysUtils;
procedure EscrituraDirecta(valor: boolean);
procedure ApilarWrite(cadena: string);
procedure ApilarWriteLn(cadena: string); overload;
procedure ApilarWriteLn; overload;
procedure ApilarClrScr;
procedure ApilarClrEol;
procedure ApilarGotoXY(x: byte; y: byte);
function LeerTeclado: char;
implementation
uses
{$IFDEF LINUX}
// Crt,
{$ELSE}
Win32Crt,
ShareMem,
{$ENDIF}
SyncObjs, Contnrs,
Utilidades;
const MAXIMOS_MSGS_APILAR = 1000;
type
TipoDatosApilarCrt = (APILAR_CRT_WRITE, APILAR_CRT_WRITELN,
APILAR_CRT_WRITELN_STR, APILAR_CRT_CLRSCR,
APILAR_CRT_CLREOL, APILAR_CRT_GOTOXY);
TipoApilarCrt = record
tipo: TipoDatosApilarCrt;
x: byte;
y: byte;
cadena: string;
end;
p_TipoApilarCrt = ^TipoApilarCrt;
TApilarCrtFifo = class
private
ColaApilarCrt: TQueue;
FCritSect: TCriticalSection;
function intNumApilarCrtMsg: integer;
function intPeekApilarCrtMsg(var msg: TipoApilarCrt; borrar: boolean):
boolean;
public
constructor Create;
destructor Destroy; override;
procedure PushApilarCrtMsg(msg: TipoApilarCrt);
function PopApilarCrtMsg(var msg: TipoApilarCrt): boolean;
function PeekApilarCrtMsg(var msg: TipoApilarCrt): boolean;
published
property NumApilarCrtMsg: integer read intNumApilarCrtMsg;
end;
TThreadApilarCrt = class(TThread)
private
intCola: TApilarCrtFifo;
public
constructor Create(cola: TApilarCrtFifo);
destructor Destroy;
procedure Execute; override;
end;
var
intEscrituraDirecta: boolean;
ApilarCrtFifo: TApilarCrtFifo;
ThreadCrtFifo: TThreadApilarCrt;
// ------------------------------------------------------
// **** TApilarCrtFifo ****
// ------------------------------------------------------
constructor TApilarCrtFifo.Create;
begin
inherited;
ColaApilarCrt := TQueue.Create;
FCritSect := TCriticalSection.Create;
end;
destructor TApilarCrtFifo.Destroy;
var
I: Integer;
intmsg: p_TipoApilarCrt;
begin
FCritSect.Enter;
(*
for I := 0 to ColaCan.count - 1 do
begin
Dispose(p_can_msg_t(ColaCan[I]));
end;
*)
while (ColaApilarCrt.Count > 0) do
begin
intmsg := ColaApilarCrt.Pop;
end;
ColaApilarCrt.Free;
FCritSect.Leave;
FCritSect.Free;
inherited;
end;
function TApilarCrtFifo.intNumApilarCrtMsg: integer;
begin
FCritSect.Enter;
intNumApilarCrtMsg := ColaApilarCrt.Count;
FCritSect.Leave;
end;
procedure TApilarCrtFifo.PushApilarCrtMsg(msg: TipoApilarCrt);
var
intmsg: p_TipoApilarCrt;
begin
FCritSect.Enter;
if ColaApilarCrt.Count < MAXIMOS_MSGS_APILAR then
begin
new(intmsg);
intmsg^ := msg;
ColaApilarCrt.Push(intmsg);
end;
FCritSect.Leave;
end;
function TApilarCrtFifo.intPeekApilarCrtMsg(var msg: TipoApilarCrt; borrar:
boolean): boolean;
var
intmsg: p_TipoApilarCrt;
begin
intPeekApilarCrtMsg := false;
if ColaApilarCrt.Count = 0 then
begin
exit;
end;
intmsg := ColaApilarCrt.Peek;
if intmsg <> nil then
begin
msg := intmsg^;
if borrar then
begin
intmsg := ColaApilarCrt.Pop; // eliminar el registro
dispose(intmsg);
end;
intPeekApilarCrtMsg := true;
end;
end;
function TApilarCrtFifo.PeekApilarCrtMsg(var msg: TipoApilarCrt): boolean;
var
intmsg: p_TipoApilarCrt;
begin
FCritSect.Enter;
PeekApilarCrtMsg := intPeekApilarCrtMsg(msg, false);
FCritSect.Leave;
end;
function TApilarCrtFifo.PopApilarCrtMsg(var msg: TipoApilarCrt): boolean;
var
intmsg: p_TipoApilarCrt;
begin
FCritSect.Enter;
PopApilarCrtMsg := intPeekApilarCrtMsg(msg, true);
FCritSect.Leave;
end;
// ------------------------------------------------------
// **** TThreadApilarCrt ****
// ------------------------------------------------------
constructor TThreadApilarCrt.Create(cola: TApilarCrtFifo);
begin
intCola := cola;
inherited create(true);
end;
destructor TThreadApilarCrt.Destroy;
begin
inherited Destroy;
end;
procedure TThreadApilarCrt.execute;
var
msg: TipoApilarCrt;
x1,y1 : byte;
begin
while not Terminated do
begin
sleep(100);
while intCola.NumApilarCrtMsg > 0 do
// if intCola.NumApilarCrtMsg > 0 then
begin
intCola.PopApilarCrtMsg(msg);
case msg.tipo of
APILAR_CRT_WRITE:
begin
Write(msg.cadena);
end;
APILAR_CRT_WRITELN:
begin
Writeln;
end;
APILAR_CRT_WRITELN_STR:
begin
Writeln(msg.cadena);
end;
APILAR_CRT_CLRSCR:
begin
ClrScr;
end;
APILAR_CRT_CLREOL:
begin
ClrEol;
end;
APILAR_CRT_GOTOXY:
begin
GotoXY(msg.x, msg.y);
// sleep(100);
end;
end;
end;
end;
end;
// *************** FUNCIONES DE CONSOLA *************************************
procedure EscrituraDirecta(valor: boolean);
begin
intEscrituraDirecta := valor;
if not intEscrituraDirecta then
begin
Window(1,1,80,25);
if not assigned(ApilarCrtFifo) then
begin
ApilarCrtFifo := TApilarCrtFifo.Create;
if assigned(ApilarCrtFifo) then
ThreadCrtFifo := TThreadApilarCrt.Create(ApilarCrtFifo);
if assigned(ThreadCrtFifo) then
ThreadCrtFifo.Resume;
end;
end;
end;
procedure ApilarWrite(cadena: string);
var
msg: TipoApilarCrt;
begin
if intEscrituraDirecta then
Write(cadena)
else
begin
msg.tipo := APILAR_CRT_WRITE;
msg.cadena := cadena;
ApilarCrtFifo.PushApilarCrtMsg(msg);
end;
end;
procedure ApilarWriteLn(cadena: string); overload;
var
msg: TipoApilarCrt;
begin
if intEscrituraDirecta then
WriteLn(cadena)
else
begin
msg.tipo := APILAR_CRT_WRITELN_STR;
msg.cadena := cadena;
ApilarCrtFifo.PushApilarCrtMsg(msg);
end;
end;
procedure ApilarWriteLn; overload;
var
msg: TipoApilarCrt;
begin
if intEscrituraDirecta then
WriteLn
else
begin
msg.tipo := APILAR_CRT_WRITELN;
ApilarCrtFifo.PushApilarCrtMsg(msg);
end;
end;
procedure ApilarClrScr;
var
msg: TipoApilarCrt;
begin
if intEscrituraDirecta then
ClrScr
else
begin
msg.tipo := APILAR_CRT_CLRSCR;
ApilarCrtFifo.PushApilarCrtMsg(msg);
end;
end;
procedure ApilarClrEol;
var
msg: TipoApilarCrt;
begin
if intEscrituraDirecta then
ClrEol
else
begin
msg.tipo := APILAR_CRT_CLREOL;
ApilarCrtFifo.PushApilarCrtMsg(msg);
end;
end;
procedure ApilarGotoXY(x: byte; y: byte);
var
msg: TipoApilarCrt;
begin
if intEscrituraDirecta then
GotoXY(x, y)
else
begin
msg.tipo := APILAR_CRT_GOTOXY;
msg.x := x;
msg.y := y;
ApilarCrtFifo.PushApilarCrtMsg(msg);
end;
end;
{$IFDEF LINUX}
function LeerTeclado_int: char;
var
ch: char;
begin
ch := #0;
if KeyPressed then
begin
ch := ReadKey;
case ch of
#0:
begin
ch := ReadKey; {Read ScanCode}
end;
end;
end;
LeerTeclado_int := ch;
end;
function LeerTeclado: char;
var
ch: char;
begin
ch := LeerTeclado_int;
if ch <> #0 then
begin
while (LeerTeclado_int <> #0) do
begin
end;
end;
LeerTeclado := ch;
end;
{$ELSE}
function LeerTeclado: char;
begin
// LeerTeclado := chr(byte(readKey_int(10)));
LeerTeclado := char(readKey_int(10));
end;
{$ENDIF}
initialization
intEscrituraDirecta := false;
end.
program Test;
uses
ApilarCrt;
var
done : boolean;
begin
done := false;
EscrituraDirecta(false);
ApilarClrScr;
while(not done) do
begin
ApilarGotoXY(1,1);
ApilarWriteln('1,1 point one');
ApilarGotoXY(5,5);
ApilarWriteln('5,5 point two');
ApilarGotoXY(60,15);
ApilarWriteln('60,15 point three');
ApilarGotoXY(25,20);
ApilarWriteln('25,20 point four');
if LeerTeclado = #3 then done := true;
end;
end._______________________________________________
fpc-pascal maillist - fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-pascal
