Simple animation in Pascal
phi5...@yahoo.ca
I started learning computer Science not long ago. I learned Clean
(well), OCAML (more or less), and Bigloo Scheme (quite well). Two
weeks ago, I became curious about Pascal, and downloaded Free Pascal,
and Vintage Turbo Pascal. As my first program, I tried to write a
simple animation in Free Pascal. In Clean, even complex game work
without a single flick. The same is true of Bigloo or Stalin Scheme.
However, my program in Pascal is flicking. I guess that I am doing
some stupid mistake, that some one used to Pascal can show me without
difficulty. Below is my flicking program; I am sending you the
version, but the same thing happens in Turbo Pascal, Windows Free
Pascal, and Lazarus; by the way, Lazarus animation demo flicks too.
BTW, Clean has an unfill function that prevents flicking. Does Pascal
has something like that? I would like to use BGI graphics, because it
is easier to handle. Thanx.
Program Bgi_Example;
Uses Crt, dos, Graph;
Var Gd,Gm : SmallInt;
procedure animate;
var
backbuf : pointer;
backsize, i : word;
begin
backsize:=imagesize(0,0,50,50);
getmem(backbuf,backsize);
setfillstyle(1,14);
setcolor(14);
for i:=1 to 500 do
begin
{ Save the background flics even more }
//getimage(0+i,0,50+i,50,backbuf^);
setcolor(0);
sector(20+(i-1),20,30,330,20,20);
setcolor(14);
sector(20+i,20,30,330,20,20);
delay(5); { Delay a bit }
// putimage(0+i,0,backbuf^,0);
end;
freemem(backbuf,backsize);
end;
Begin
Gd := VGA; //Detect;
Gm := VGAHi;
InitGraph(Gd, Gm,'');
animate;
SetTextStyle(SmallFont, HorizDir, 2);
OutTextXY(100, 100, 'Hello, World');
Readkey;
CloseGraph;
End.
Wolf Behrenhoff
> Hi,...
> I guess that I am doing
> some stupid mistake, that some one used to Pascal can show me without
> difficulty. Below is my flicking program; I am sending you the
> version, but the same thing happens in Turbo Pascal, Windows Free
> Pascal, and Lazarus; by the way, Lazarus animation demo flicks too.
> BTW, Clean has an unfill function that prevents flicking. Does Pascal
> has something like that? I would like to use BGI graphics, because it
> is easier to handle. Thanx.
I haven't done anything with unit Graph for ages, but I still remember
having used the procedure WaitRetrace (see below) just before drawing. I
doubt that this function sill works under modern operating systems - and
I wouldn't use BGI graphics any longer even if BGI might seem to be
easier to handle for you.
procedure WaitRetrace;
begin
repeat until port[$3da] and 8 = 8;
repeat until port[$3da] and 8 = 0;
end;
- Wolf
Scott Moore
I played with retrace timings for a while, it is fairly much a waste of
time, because you are betting that you can get your drawing done in the
retrace time (not the draw time). Using double buffered graphics is how
the pros do this job, and it makes it easy. See if you can double buffer
the screen surface.
Scott Moore
Il mago delle comete
I took the following code from the TP7 Borland example and I have
slighty modified it to avoid flickering with inclusion of double
buffer, if you retain the video mode setting it works under FPC too
(VESA mode have problem with the XORput paste). In TP you have to set
the variable PathToDriver.
program Sprite;
uses
Crt, Graph;
var
GraphDriver : integer; { The Graphics device driver }
GraphMode : integer; { The Graphics mode value }
MaxX, MaxY : word; { The maximum resolution of the screen }
ErrorCode : integer; { Reports any graphics errors }
MaxColor : word; { The maximum color value available }
procedure Initialize;
{ Initialize graphics and report any errors that may occur }
var
PathToDriver : string; { Stores the DOS path to *.BGI & *.CHR }
begin
GraphDriver := VGA;
GraphMode := VGAHi;
PathToDriver := '';
InitGraph(GraphDriver, GraphMode, PathToDriver);
ErrorCode := GraphResult; { preserve error return }
if ErrorCode <> grOK then { error? }
begin
Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
Halt(1); { Some other error:
terminate }
end;
Randomize; { init random number generator }
MaxColor := GetMaxColor; { Get the maximum allowable drawing color
}
MaxX := GetMaxX; { Get screen resolution values }
MaxY := GetMaxY;
end; { Initialize }
procedure PutImagePlay;
{ Demonstrate the GetImage and PutImage commands }
const
r = 20;
StartX = 100;
StartY = 50;
var
CurPort : ViewPortType;
procedure MoveSaucer(var X, Y : integer; Width, Height : integer);
var
Step : integer;
begin
Step := Random(2*r);
if Odd(Step) then
Step := -Step;
X := X + Step;
Step := Random(r);
if Odd(Step) then
Step := -Step;
Y := Y + Step;
{ Make saucer bounce off viewport walls }
with CurPort do
begin
if (x1 + X + Width - 1 > x2) then
X := x2-x1 - Width + 1
else
if (X < 0) then
X := 0;
if (y1 + Y + Height - 1 > y2) then
Y := y2-y1 - Height + 1
else
if (Y < 0) then
Y := 0;
end;
end; { MoveSaucer }
var
Pausetime : word;
Saucer : pointer;
Pos : array[1..2] of record
X, Y : integer;
XOld, YOld : integer;
end;
ulx, uly : word;
lrx, lry : word;
Size : word;
I : word;
begin
{ PaintScreen }
SetViewPort(0, 0, MaxX, MaxY, ClipOn);
ClearViewPort;
GetViewSettings(CurPort);
{ DrawSaucer }
Ellipse(StartX, StartY, 0, 360, r, (r div 3)+2);
Ellipse(StartX, StartY-4, 190, 357, r, r div 3);
Line(StartX+7, StartY-6, StartX+10, StartY-12);
Circle(StartX+10, StartY-12, 2);
Line(StartX-7, StartY-6, StartX-10, StartY-12);
Circle(StartX-10, StartY-12, 2);
SetFillStyle(SolidFill, MaxColor);
FloodFill(StartX+1, StartY+4, GetColor);
{ ReadSaucerImage }
ulx := StartX-(r+1);
uly := StartY-14;
lrx := StartX+(r+1);
lry := StartY+(r div 3)+3;
Size := ImageSize(ulx, uly, lrx, lry);
GetMem(Saucer, Size);
GetImage(ulx, uly, lrx, lry, Saucer^);
PutImage(ulx, uly, Saucer^, XORput); { erase image }
{ Plot some "stars" }
for I := 1 to 1000 do
PutPixel(Random(MaxX), Random(MaxY), Random(MaxColor));
Pos[1].X := MaxX div 3;
Pos[1].Y := MaxY div 2;
Pos[2].X := MaxX div 3*2;
Pos[2].Y := MaxY div 2;
PauseTime := 70;
{ Move the saucer around }
repeat
SetVisualPage(0);
SetActivePage(1); { double buffer }
for I := 1 to 2 do { draw image }
PutImage(Pos[I].X, Pos[I].Y, Saucer^, XORput);
SetVisualPage(1);
for I := 1 to 2 do begin
Pos[I].XOld := Pos[I].X;
Pos[I].YOld := Pos[I].Y;
end;
for I := 1 to 2 do { width/height }
MoveSaucer(Pos[I].X, Pos[I].Y, lrx - ulx + 1, lry - uly + 1);
Delay(PauseTime);
for I := 1 to 2 do { erase image }
PutImage(Pos[I].XOld, Pos[I].YOld, Saucer^, XORput);
until KeyPressed;
FreeMem(Saucer, size);
end; { PutImagePlay }
begin { program body }
Initialize;
PutImagePlay;
CloseGraph;
end.
--
Omega e' omega e basta