paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 23:19:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ header+log

Browse Source
This commit is contained in:
peter 1998-09-11 10:55:20 +00:00
parent 857e290786
commit b8aa494108
8 changed files with 652 additions and 425 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
install/demo/Makefile Normal file
View File

@ -0,0 +1,94 @@
#
# $Id$
# This file is part of the Free Pascal run time library.
# Copyright (c) 1998 by the Free Pascal Development Team
#
# Makefile for the Free Pascal Examples
#
# See the file COPYING.FPC, included in this distribution,
# for details about the copyright.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
#####################################################################
# Include configuration makefile
#####################################################################
# Where are the include files ?
CFG=../cfg
#INC=../inc
#PROCINC=../$(CPU)
#OBJPAS=../objpas
# Get some defaults for Programs and OSes.
# This will set the following variables :
# inlinux COPY REPLACE DEL INSTALL INSTALLEXE MKDIR
# It will also set OPT for cross-compilation, and add required options.
# also checks for config file.
# it expects CFG INC PROCINC to be set !!
include $(CFG)/makefile.cfg
#####################################################################
# Objects
#####################################################################
EXEOBJECTS=hello lines eratos magic qsort mandel blackbox
UNITOBJECTS=
#####################################################################
# Main targets
#####################################################################
# Create Filenames
EXEFILES=$(addsuffix $(EXEEXT),$(EXEOBJECTS))
UNITFILES=$(addsuffix $(PPUEXT),$(UNITOBJECTS))
UNITOFILES=$(addsuffix $(OEXT),$(UNITOBJECTS))
.PHONY : all clean diffs install diffclean
all : $(EXEFILES) $(UNITFILES)
$(EXEFILES): %$(EXEEXT): %$(PASEXT)
$(PP) $(OPT) $*
$(UNITFILES): %$(PPUEXT): %$(PASEXT)
$(PP) $(OPT) $*
install : all
ifdef EXEOBJECTS
$(MKDIR) $(BININSTALLDIR)
$(INSTALLEXE) $(EXEFILES) $(BININSTALLDIR)
endif
ifdef UNITOBJECTS
$(MKDIR) $(UNITINSTALLDIR)
$(INSTALL) $(UNITFILES) $(UNITOFILES) $(UNITINSTALLDIR)
endif
clean:
-$(DEL) *$(OEXT) *$(ASMEXT) *$(PPUEXT) $(PPAS) link.res log
ifdef EXEOBJECTS
-$(DEL) $(EXEFILES)
endif
#####################################################################
# Files
#####################################################################
#####################################################################
# Default makefile targets
#####################################################################
include $(CFG)/makefile.def
#
# $Log$
# Revision 1.1 1998-09-11 10:55:20 peter
# + header+log
#
# Revision 1.1 1998/09/10 13:55:07 peter
# * updates
#
#

61
install/demo/blackbox.pp
View File

@ -1,21 +1,35 @@
Program blackbox;
{
(c) 1998 Michael Van Canneyt
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by Michael Van Canneyt
Blackbox Game Example
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
Program blackbox;
{
The object of the game is simple : You have a box of 9x9x9 cells.
you can enter a number of atoms that will be put in the box.
Then you can start shooting in the box with a laser beam.
You enter the coordinates where the beam enters the box.
(this must be on the edges, this means that one of the coordinates
must be 1 or 9...)
The beam will bounce off the atoms (using normal bouncing), and you
will be told where the beam exits.
The beam will bounce off the atoms (using normal bouncing), and you
will be told where the beam exits.
From this you must guess where the atoms are...
}
Const MaxSize = 9;
MaxAtom = 10;
Type TRow = Array [0..MaxSize+1] of byte;
TPlane = Array [0..MaxSize+1] of TRow;
TCube = Array [0..MaxSize+1] of TPlane;
@ -24,7 +38,7 @@ Var
Cube : TCube;
Count,Guessed,x,y,z : Longint;
ans : string;
Procedure FillCube;
var i,x,y,z : longint;
@ -38,7 +52,7 @@ begin
repeat
Write ('Enter number of atoms (1-',maxatom,') : ');
readln (count);
if (count<1) or (count>MaxAtom) then
if (count<1) or (count>MaxAtom) then
writeln ('Invalid value entered. Please try again.');
until (count>0) and (count<=MaxAtom);
for I:=1 to count do
@ -49,7 +63,7 @@ begin
z:=Random(MaxSize)+1;
until Cube[x,y,z]=0;
Cube[x,y,z]:=1;
end;
end;
end;
Procedure GetCoords (Var X,y,z : longint);
@ -68,12 +82,12 @@ Procedure GetStart (Var x,y,z : longint);
Var OK : boolean;
begin
Writeln ('Please enter beam start coordinates : ');
Writeln ('Please enter beam start coordinates : ');
Repeat
GetCoords (x,y,z);
OK:=((X=1) or (X=MaxSize)) or ((y=1) or (Y=MaxSize)) or
((Z=1) or (z=maxsize));
if Not OK then
if Not OK then
writeln ('The beam should enter at an edge. Please try again');
until OK;
end;
@ -82,14 +96,14 @@ Function GetGuess : boolean;
Var OK : boolean;
x,y,z : longint;
begin
Writeln ('Please enter atom coordinates : ');
Writeln ('Please enter atom coordinates : ');
Repeat
getcoords (x,y,z);
OK:=((X>=1) or (X<=MaxSize)) or ((y>=1) or (Y<=MaxSize)) or
((Z>=1) or (z<=maxsize));
if Not OK then
if Not OK then
writeln ('These are not valid coordinates. Please try again');
until OK;
GetGuess:=False;
@ -100,7 +114,7 @@ begin
Writeln ('Correct guess !');
Cube[x,y,z]:=-Cube[x,y,z];
getguess:=true;
end
end
else
Writeln ('Wrong guess !');
end;
@ -129,8 +143,8 @@ begin
if dz<>0 then dz:=dz div abs(dz);
if dy<>0 then dy:=dy div abs(dy);
x:=x+dx;y:=y+dy;z:=z+dz;
until ((x=0) or (x=MaxSize+1)) or ((y=0) or (y=maxsize+1)) or
((z=0) or (z=maxsize+1));
until ((x=0) or (x=MaxSize+1)) or ((y=0) or (y=maxsize+1)) or
((z=0) or (z=maxsize+1));
Writeln ('Beam exited at : (',x-dx,',',y-dy,',',z-dz,')');
end;
@ -142,7 +156,7 @@ begin
for x:=1 to MaxSize do
for y:=1 to maxsize do
for z:=1 to maxsize do
if Cube[x,y,z]<>0 then
if Cube[x,y,z]<>0 then
writeln ('Atom at (',x,',',y,',',z,')');
end;
@ -154,7 +168,7 @@ begin
Write ('Shoot, guess or quit (s/g/q) : ');
readln (ans);
ans[1]:=Upcase(ans[1]);
if not (ans[1] in ['S','G','Q']) then
if not (ans[1] in ['S','G','Q']) then
writeln ('Invalid entry. Please try again.');
until ans[1] in ['S','G','Q'];
Case ans[1] of
@ -168,5 +182,12 @@ begin
If Guessed=count then
Writeln ('Congratulations! All ',Count,' correct !')
else
Writeln ('Only ',guessed,' out of ',count,' correct...');
Writeln ('Only ',guessed,' out of ',count,' correct...');
end.
{
$Log$
Revision 1.2 1998-09-11 10:55:20 peter
+ header+log
}

45
install/demo/eratos.pp
View File

@ -1,14 +1,18 @@
{****************************************************************************
$Id$
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by Florian Klaempfl
Copyright (c) 1993,94 by Florian Kl„mpfl
Translated By Eric Molitor (emolitor@freenet.fsu.edu)
Eratos Example, Calculates all Prime Numbers from 1 to max
****************************************************************************}
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
{ Demonstration Program in FPKPascal }
{ Calculates all Prime Numbers from 1 to max }
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program eratosthenes;
const
@ -26,13 +30,21 @@ program eratosthenes;
for i:=1 to max do
a[i]:=true;
for i:=2 to max div 2 do
if a[i] then
if a[i] then
for j:=2 to max div i do
a[i*j]:=false;
writeln;
j:=0;
for i:=1 to max do
if a[i] then
write(i:8);
begin
if a[i] then
begin
write(i:7);
inc(j);
if (j mod 10)=0 then
writeln;
end;
end;
writeln;
end;
@ -41,14 +53,11 @@ program eratosthenes;
eratos;
end.
{
{
$Log$
Revision 1.4 1998-09-04 17:38:15 pierre
Revision 1.5 1998-09-11 10:55:21 peter
+ header+log
Revision 1.4 1998/09/04 17:38:15 pierre
* the algorythm was wrong (unnecessary checks were made)
Revision 1.3 1998/04/06 12:23:21 pierre
* log problem
Revision 1.2 1998/04/06 12:17:00 pierre
* made array a global to avoid stack overflow
}

26
install/demo/hello.pp
View File

@ -1,6 +1,22 @@
program hello;
begin
writeln('Hello world');
end.
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by the Free Pascal Development Team
Hello World Example
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program hello;
begin
writeln('Hello world');
end.

34
install/demo/lines.pp
View File

@ -1,17 +1,22 @@
{
LINES.PP
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by Florian Klaempfl
Program that counts number of Lines in a file
Line Counter Example
Copyright (c) 1992,95 by FP Kl„mpfl
Translated By Eric Molitor (emolitor@freenet.fsu.edu)
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
History:
29.10.1992 Version 1.0
3.3.1995 an FPKPascal angepaát
}
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program count_lines;
{
Program that counts number of Lines in a file
}
uses
dos,crt;
@ -26,7 +31,7 @@ program count_lines;
d : ^td;
{$ifdef tp}
count : word;
i,z : integer;
i,z : integer;
{$else}
count,i,z : longint;
{$endif}
@ -36,9 +41,9 @@ program count_lines;
new(d);
if paramcount<1 then
begin
writeln('Usage: LINES FILENAME.EXT [FILENAME.EXT] ...');
writeln('Usage: ',paramstr(0),' filename.ext [filename.ext] ...');
writeln(' Multiple File Names and Wild Cards Allowed:');
writeln(' z.B LINES *.CPP STDIO.H *.ASM');
writeln(' Example: lines *.cpp stdio.h *.asm');
halt(1);
end;
for i:=1 to paramcount do
@ -68,3 +73,10 @@ program count_lines;
gotoxy(1,wherey);
if lines=1 then writeln('1 Line') else writeln(lines,' Lines');
end.
{
$Log$
Revision 1.2 1998-09-11 10:55:23 peter
+ header+log
}

193
install/demo/magic.pp
View File

@ -1,88 +1,105 @@
{****************************************************************************
Copyright (c) 1994 by Florian Kl„mpfl
****************************************************************************}
{ Demonstrationsprogramm zu FPKPascal }
{ berechnet magische Quadrate (Summe alle Spalten, Zeilen und }
{ Diagonalen ist gleich) }
program magic;
const
maxsize = 11;
type
sqrtype = array[1..maxsize, 1..maxsize] of integer;
var
square : sqrtype;
size, row, sum : integer;
procedure makesquare(var sq : sqrtype;limit : integer);
var
num,r,c : integer;
begin
for r:=1 to limit do
for c:=1 to limit do
sq[r, c] := 0;
if (limit and 1)<>0 then
begin
r:=(limit+1) div 2;
c:=limit;
for num:=1 to limit*limit do
begin
if sq[r,c]<>0 then
begin
dec(r);
if r<1 then
r:=r+limit;
c:=c-2;
if c<1 then
c:=c+limit;
end;
sq[r,c]:=num;
inc(r);
if r>limit then
r:=r-limit;
inc(c);
if c>limit then
c:=c-limit;
end;
end;
end;
procedure writesquare(var sq : sqrtype;limit : integer);
var
row,col : integer;
begin
for row:=1 to Limit do
begin
for col:=1 to (limit div 2) do
write(sq[row,2*col-1]:4,' ',sq[row,2*col]:4,' ');
writeln(sq[row,limit]:4);
end;
end;
begin
size:=3;
while (size<=maxsize) do
begin
writeln('Magisches Quadrat mit der Seitenl„nge ',size);
writeln;
makesquare(square,size);
writesquare(square,size);
writeln;
sum:=0;
for row:=1 to size do
sum:=sum+square[row,1];
writeln('Summe in den Reihen, Spalten und Diagonalen = ', sum);
writeln;
writeln;
size:=size+2;
end;
end.
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by Florian Klaempfl
Magic Square Example
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program magic;
{
Calculate a magic square (sum of the row, colums and diagonals is equal
}
const
maxsize = 11;
type
sqrtype = array[1..maxsize, 1..maxsize] of longint;
var
square : sqrtype;
size, row, sum : longint;
procedure makesquare(var sq : sqrtype;limit : longint);
var
num,r,c : longint;
begin
for r:=1 to limit do
for c:=1 to limit do
sq[r, c] := 0;
if (limit and 1)<>0 then
begin
r:=(limit+1) div 2;
c:=limit;
for num:=1 to limit*limit do
begin
if sq[r,c]<>0 then
begin
dec(r);
if r<1 then
inc(r,limit);
dec(c,2);
if c<1 then
inc(c,limit);
end;
sq[r,c]:=num;
inc(r);
if r>limit then
dec(r,limit);
inc(c);
if c>limit then
dec(c,limit);
end;
end;
end;
procedure writesquare(var sq : sqrtype;limit : longint);
var
row,col : longint;
begin
for row:=1 to Limit do
begin
for col:=1 to (limit div 2) do
write(sq[row,2*col-1]:4,' ',sq[row,2*col]:4,' ');
writeln(sq[row,limit]:4);
end;
end;
begin
size:=3;
while (size<=maxsize) do
begin
writeln('Magic Square with size ',size);
writeln;
makesquare(square,size);
writesquare(square,size);
writeln;
sum:=0;
for row:=1 to size do
inc(sum,square[row,1]);
writeln('Sum of the rows,columns and diagonals = ', sum);
writeln;
writeln;
inc(size,2);
end;
end.
{
$Log$
Revision 1.2 1998-09-11 10:55:24 peter
+ header+log
}

545
install/demo/mandel.pp
View File

@ -1,256 +1,293 @@
{ Mandelbrot 2 (C)opyright 1994 by Gernot Tenchio }
{ dieses Programm kann modifiziert, geloescht, verschenkt, kopiert, validiert, }
{ bewegt, komprimiert, ausgelacht usw. werden. Allerdings bittscheen immer mit }
{ meinem (G)obbirait }
USES GRAPH;
const shift:byte=12;
VAR SerchPoint,ActualPoint,NextPoint : PointType ;
LastColor : longint;
Gd,Gm,Max_Color,Max_X_Width,
Max_Y_Width,Y_Width : INTEGER ;
Y1,Y2,X1,X2,Dy,Dx : Real ;
Zm : Integer ;
Flag : BOOLEAN ;
LineY : ARRAY [0..600] OF BYTE;
LineX : ARRAY [0..100,0..600] OF INTEGER;
CONST
SX : ARRAY [0..7] OF SHORTINT=(-1, 0, 1, 1, 1, 0,-1,-1);
SY : ARRAY [0..7] OF SHORTINT=(-1,-1,-1, 0, 1, 1, 1, 0);
TYPE
ArrayType = array[1..50] of integer;
{------------------------------------------------------------------------------}
FUNCTION CalcMandel(Point:PointType; z:integer) : Longint ;
var x,y,xq,yq,Cx,Cy : real ;
BEGIN
Cy:=y2 + dy*Point.y ;
Cx:=x2 + dx*Point.x ;
X:=-Cx ; Y:=-Cy ;
REPEAT
xq:=x * x;
yq:=y * y ;
y :=x * y;
y :=y + y - cy;
x :=xq - yq - cx ;
z :=z -1;
UNTIL (Z=0) OR (Xq + Yq > 4 );
IF Z=0 Then CalcMandel:=1 else CalcMandel:=(z mod Max_Color) + 1 ;
END ;
{-----------------------------------------------------------------------------}
PROCEDURE Partition(VAR A : ArrayType; First, Last : Byte);
{ ist nicht auf meinem Mist gewachsen. Weiss aber auch nicht mehr so richtig
wo es herkommt. Allseits bekannter Sortieralgo }
VAR
Right,Left : BYTE ;
V,Temp : integer;
BEGIN
V := A[(First + Last) SHR 1];
Right := First;
Left := Last;
REPEAT
WHILE (A[Right] < V) DO
Right:=Right+1;
WHILE (A[Left] > V) DO
Left:=Left-1;
IF (Right <= Left) THEN
BEGIN
Temp:=A[Left];
A[Left]:=A[Right];
A[Right]:=Temp;
Right:=Right+1;
Left:=Left-1;
END;
UNTIL Right > Left;
IF (First < Left) THEN
Partition(A, First, Left);
IF (Right < Last) THEN
Partition(A, Right, Last)
END;
FUNCTION BlackScan(var NextPoint:PointType) : BOOLEAN ;
BEGIN
BlackScan:=TRUE;
REPEAT
IF NextPoint.X=Max_X_Width THEN
BEGIN
IF NextPoint.Y < Y_Width THEN
BEGIN
NextPoint.X:=0 ;
NextPoint.Y:=NextPoint.Y+1;
END
ELSE
BEGIN
BlackScan:=FALSE;
EXIT;
END ; { IF }
END ; { IF }
NextPoint.X:=NextPoint.X+1;
UNTIL GetPixel(NextPoint.X,NextPoint.Y)=0;
END ;
{------------------------------------------------------------------------------}
PROCEDURE Fill(Ymin,Ymax,LastColor:integer);
VAR P1,P3,P4,P : INTEGER ;
Len,P2 : BYTE ;
Darray : ARRAYTYPE;
BEGIN
SetColor(LastColor);
FOR P1:=Ymin+1 TO Ymax-1 DO
BEGIN
Len:=LineY[P1] ;
IF Len >= 2 THEN
BEGIN
FOR P2:=1 TO Len DO
BEGIN
Darray[P2]:=LineX[P2,P1] ;
END; { FOR }
IF Len > 2 THEN Partition(Darray,1,len);
P2:=1;
REPEAT
P3:= Darray[P2] ; P4:= Darray[P2 + 1];
IF P3 <> P4 THEN
BEGIN
LINE ( P3 , P1 , P4 , P1) ;
IF Flag THEN
BEGIN
P:=Max_Y_Width-P1;
LINE ( P3 , P , P4 , P ) ;
END;
END; { IF }
P2:=P2+2;
UNTIL P2 >= Len ;
END; { IF }
END; { FOR }
END;
{-----------------------------------------------------------------------------}
Function NewPosition(Last:Byte):Byte;
begin
newposition:=(((last+1) and 254)+6) and 7;
END;
{-----------------------------------------------------------------------------}
PROCEDURE CalcBounds;
VAR LastOperation,KK,
Position : Byte ;
foundcolor : longint;
Start,Found,NotFound : BOOLEAN ;
MerkY,Ymax : Integer ;
LABEL L;
BEGIN
REPEAT
FillChar(LineY,SizeOf(LineY),0) ;
ActualPoint:=NextPoint;
LastColor:=CalcMandel(NextPoint,Zm) ;
PUTPIXEL (ActualPoint.X,ActualPoint.Y,LastColor);
IF Flag THEN PUTPIXEL (ActualPoint.X,
Max_Y_Width-ActualPoint.Y,LastColor) ;
Ymax:=NextPoint.Y ;
MerkY:=NextPoint.Y ;
NotFound:=FALSE ;
Start:=FALSE ;
LastOperation:=4 ;
REPEAT
Found:=FALSE ;
KK:=0 ;
Position:=NewPosition(LastOperation);
REPEAT
LastOperation:=(Position+KK) AND 7 ;
SerchPoint.X:=ActualPoint.X+Sx[LastOperation];
SerchPoint.Y:=ActualPoint.Y+Sy[LastOperation];
IF ( (SerchPoint.X < 0)
OR (SerchPoint.X > Max_X_Width)
OR (SerchPoint.Y < NextPoint.Y)
OR (SerchPoint.Y > Y_Width) ) THEN GOTO L;
IF (SerchPoint.X=NextPoint.X) AND (SerchPoint.Y=NextPoint.Y) THEN
BEGIN
Start:=TRUE ;
Found:=TRUE ;
END
ELSE
BEGIN
FoundColor:=GetPixel(SerchPoint.X,SerchPoint.Y) ;
IF FoundColor = 0 THEN
BEGIN
FoundColor:= CalcMandel (SerchPoint,Zm) ;
Putpixel (SerchPoint.X,SerchPoint.Y,FoundColor) ;
IF Flag THEN PutPixel (SerchPoint.X,Max_Y_Width-SerchPoint.Y,
FoundColor) ;
END ;
IF FoundColor=LastColor THEN
BEGIN
IF ActualPoint.Y <> SerchPoint.Y THEN
BEGIN
IF SerchPoint.Y = MerkY THEN LineY[ActualPoint.Y]:=LineY[ActualPoint.Y]-1;
MerkY:= ActualPoint.Y ;
LineY[SerchPoint.Y]:=LineY[SerchPoint.Y]+1;
END ;
LineX[LineY[SerchPoint.Y],SerchPoint.Y]:=SerchPoint.X ;
IF SerchPoint.Y > Ymax THEN Ymax:= SerchPoint.Y ;
Found:=TRUE ;
ActualPoint:=SerchPoint ;
END;
L:
KK:=KK+1;
IF KK > 8 THEN
BEGIN
Start:=TRUE ;
NotFound:=TRUE ;
END;
END;
UNTIL Found OR (KK > 8);
UNTIL Start ;
IF not NotFound THEN Fill(NextPoint.Y,Ymax,LastColor) ;
UNTIL NOT BlackScan(NextPoint);
END ;
{------------------------------------------------------------------------------}
{-----------------------}
{ MAINROUTINE }
{-----------------------}
BEGIN
{$ifndef linux}
gm:=$103;
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by Gernot Tenchio
Mandelbrot Example using the Graph unit
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program mandel;
{
Mandelbrot example using the graph unit.
Note: For linux you need to run this program as root !!
}
uses
Graph;
const
shift:byte=12;
var
SerchPoint,ActualPoint,NextPoint : PointType;
LastColor : longint;
Gd,Gm,
Max_Color,Max_X_Width,
Max_Y_Width,Y_Width : integer;
Y1,Y2,X1,X2,Dy,Dx : Real;
Zm : Integer;
Flag : boolean;
LineY : array [0..600] OF BYTE;
LineX : array [0..100,0..600] OF INTEGER;
const
SX : array [0..7] OF SHORTINT=(-1, 0, 1, 1, 1, 0,-1,-1);
SY : array [0..7] OF SHORTINT=(-1,-1,-1, 0, 1, 1, 1, 0);
type
arrayType = array[1..50] of integer;
{------------------------------------------------------------------------------}
function CalcMandel(Point:PointType; z:integer) : Longint ;
var
x,y,xq,yq,Cx,Cy : real ;
begin
Cy:=y2 + dy*Point.y ;
Cx:=x2 + dx*Point.x ;
X:=-Cx ; Y:=-Cy ;
repeat
xq:=x * x;
yq:=y * y ;
y :=x * y;
y :=y + y - cy;
x :=xq - yq - cx ;
z :=z -1;
until (Z=0) or (Xq + Yq > 4 );
if Z=0 Then
CalcMandel:=1
else
CalcMandel:=(z mod Max_Color) + 1 ;
end;
{-----------------------------------------------------------------------------}
procedure Partition(var A : arrayType; First, Last : Byte);
var
Right,Left : byte ;
V,Temp : integer;
begin
V := A[(First + Last) SHR 1];
Right := First;
Left := Last;
repeat
while (A[Right] < V) do
inc(Right);
while (A[Left] > V) do
Dec(Left);
if (Right <= Left) then
begin
Temp:=A[Left];
A[Left]:=A[Right];
A[Right]:=Temp;
Right:=Right+1;
Left:=Left-1;
end;
until Right > Left;
if (First < Left) then
Partition(A, First, Left);
if (Right < Last) then
Partition(A, Right, Last)
end;
{-----------------------------------------------------------------------------}
function BlackScan(var NextPoint:PointType) : boolean;
begin
BlackScan:=true;
repeat
if NextPoint.X=Max_X_Width then
begin
if NextPoint.Y < Y_Width then
begin
NextPoint.X:=0 ;
NextPoint.Y:=NextPoint.Y+1;
end
else
begin
BlackScan:=false;
exit;
end ; { IF }
end ; { IF }
NextPoint.X:=NextPoint.X+1;
until GetPixel(NextPoint.X,NextPoint.Y)=0;
end ;
{------------------------------------------------------------------------------}
procedure Fill(Ymin,Ymax,LastColor:integer);
var
P1,P3,P4,P : integer ;
Len,P2 : byte ;
Darray : arraytype;
begin
SetColor(LastColor);
for P1:=Ymin+1 to Ymax-1 do
begin
Len:=LineY[P1] ;
if Len >= 2 then
begin
for P2:=1 to Len do
Darray[P2]:=LineX[P2,P1] ;
if Len > 2 then
Partition(Darray,1,len);
P2:=1;
repeat
P3:= Darray[P2] ; P4:= Darray[P2 + 1];
if P3 <> P4 then
begin
line ( P3 , P1 , P4 , P1) ;
if Flag then
begin
P:=Max_Y_Width-P1;
line ( P3 , P , P4 , P ) ;
end;
end; { IF }
P2:=P2+2;
until P2 >= Len ;
end; { IF }
end; { FOR }
end;
{-----------------------------------------------------------------------------}
Function NewPosition(Last:Byte):Byte;
begin
newposition:=(((last+1) and 254)+6) and 7;
end;
{-----------------------------------------------------------------------------}
procedure CalcBounds;
var
lastOperation,KK,
Position : Byte ;
foundcolor : longint;
Start,Found,NotFound : boolean ;
MerkY,Ymax : Integer ;
label
L;
begin
repeat
FillChar(LineY,SizeOf(LineY),0) ;
ActualPoint:=NextPoint;
LastColor:=CalcMandel(NextPoint,Zm) ;
putpixel (ActualPoint.X,ActualPoint.Y,LastColor);
if Flag then
putpixel (ActualPoint.X,Max_Y_Width-ActualPoint.Y,LastColor) ;
Ymax:=NextPoint.Y ;
MerkY:=NextPoint.Y ;
NotFound:=false ;
Start:=false ;
LastOperation:=4 ;
repeat
Found:=false ;
KK:=0 ;
Position:=NewPosition(LastOperation);
repeat
LastOperation:=(Position+KK) and 7 ;
SerchPoint.X:=ActualPoint.X+Sx[LastOperation];
SerchPoint.Y:=ActualPoint.Y+Sy[LastOperation];
if ((SerchPoint.X < 0) or
(SerchPoint.X > Max_X_Width) or
(SerchPoint.Y < NextPoint.Y) or
(SerchPoint.Y > Y_Width)) then
goto L;
if (SerchPoint.X=NextPoint.X) and (SerchPoint.Y=NextPoint.Y) then
begin
Start:=true ;
Found:=true ;
end
else
begin
FoundColor:=GetPixel(SerchPoint.X,SerchPoint.Y) ;
if FoundColor = 0 then
begin
FoundColor:= CalcMandel (SerchPoint,Zm) ;
Putpixel (SerchPoint.X,SerchPoint.Y,FoundColor) ;
if Flag then
PutPixel (SerchPoint.X,Max_Y_Width-SerchPoint.Y,FoundColor) ;
end ;
if FoundColor=LastColor then
begin
if ActualPoint.Y <> SerchPoint.Y then
begin
if SerchPoint.Y = MerkY then
LineY[ActualPoint.Y]:=LineY[ActualPoint.Y]-1;
MerkY:= ActualPoint.Y ;
LineY[SerchPoint.Y]:=LineY[SerchPoint.Y]+1;
end ;
LineX[LineY[SerchPoint.Y],SerchPoint.Y]:=SerchPoint.X ;
if SerchPoint.Y > Ymax then Ymax:= SerchPoint.Y ;
Found:=true ;
ActualPoint:=SerchPoint ;
end;
L:
KK:=KK+1;
if KK > 8 then
begin
Start:=true ;
NotFound:=true ;
end;
end;
until Found or (KK > 8);
until Start ;
if not NotFound then
Fill(NextPoint.Y,Ymax,LastColor) ;
until not BlackScan(NextPoint);
end ;
{------------------------------------------------------------------------------
MAINROUTINE
------------------------------------------------------------------------------}
begin
{$ifdef Linux}
gm:=0;
gd:=0;
{$else}
gm:=G800x600x256;
gm:=$103;
gd:=$ff;
{$ifDEF TURBO}
gd:=detect;
{$endif}
{$endif}
gd:=$ff;
{$IFDEF TURBO}
gd:=detect;
{$ENDIF}
InitGraph(gd,gm,'D:\bp\bgi');
IF GraphResult <> grOk THEN Halt(1);
Max_X_Width:=GetMaxX;
Max_y_Width:=GetMaxY;
Max_Color:=GetMaxColor-1;
ClearViewPort;
x1:=-0.9;
x2:= 2.2;
y1:= 1.25;
y2:=-1.25;
zm:=90;
dx:=(x1 - x2) / Max_X_Width ;
dy:=(y1 - y2) / Max_Y_Width ;
IF ABS(y1) = ABS(y2) THEN
BEGIN
flag:=TRUE ; Y_Width:=Max_Y_Width shr 1;
END
ELSE
BEGIN
flag:=FALSE ; Y_Width:=Max_Y_Width;
END;
NextPoint.X:=0; NextPoint.Y:=0;
LastColor:=CalcMandel(SerchPoint,zm);
CalcBounds ;
readln;
CloseGraph;
END.
InitGraph(gd,gm,'D:\bp\bgi');
if GraphResult <> grOk then Halt(1);
Max_X_Width:=GetMaxX;
Max_y_Width:=GetMaxY;
Max_Color:=GetMaxColor-1;
ClearViewPort;
x1:=-0.9;
x2:= 2.2;
y1:= 1.25;
y2:=-1.25;
zm:=90;
dx:=(x1 - x2) / Max_X_Width ;
dy:=(y1 - y2) / Max_Y_Width ;
if abs(y1) = abs(y2) then
begin
flag:=true;
Y_Width:=Max_Y_Width shr 1
end
else
begin
flag:=false;
Y_Width:=Max_Y_Width;
end;
NextPoint.X:=0;
NextPoint.Y:=0;
LastColor:=CalcMandel(SerchPoint,zm);
CalcBounds ;
readln;
CloseGraph;
end.
{
$Log$
Revision 1.3 1998-09-11 10:55:25 peter
+ header+log
}

79
install/demo/qsort.pp
View File

@ -1,63 +1,84 @@
{****************************************************************************
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by the Free Pascal Development Team
Copyright (c) 1993,94 by Florian Kl„mpfl
Translated by Eric Molitor (emolitor@freenet.fsu.edu)
QuickSort Example
****************************************************************************}
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
{ Demonstration Program in FPKPascal }
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program quicksort;
const
max = 1000;
max = 100000;
type
tlist = array[1..max] of integer;
tlist = array[1..max] of longint;
var
data : tlist;
procedure qsort(var a : tlist);
procedure sort(l,r: integer);
procedure sort(l,r: longint);
var
i,j,x,y: integer;
i,j,x,y: longint;
begin
i:=l;
j:=r;
x:=a[(l+r) div 2];
repeat
while a[i]<x do i:=i+1;
while x<a[j] do j:=j-1;
while a[i]<x do
inc(i);
while x<a[j] do
dec(j);
if not(i>j) then
begin
y:=a[i];
a[i]:=a[j];
a[j]:=y;
i:=i+1;
inc(i);
j:=j-1;
end;
until i>j;
if l<j then sort(l,j);
if i<r then sort(i,r);
if l<j then
sort(l,j);
if i<r then
sort(i,r);
end;
begin
sort(1,max);
end;
var
i : longint;
begin
write('Creating ',Max,' random numbers between 1 and 30000');
randomize;
for i:=1 to max do
data[i]:=random(30000);
write(#13#10'Sorting...');
qsort(data);
writeln;
for i:=1 to max do
write(data[i]:8);
var
i : longint;
begin
write('Creating ',Max,' random numbers between 1 and 500000');
randomize;
for i:=1 to max do
data[i]:=random(500000);
writeln;
writeln('Sorting...');
qsort(data);
writeln;
for i:=1 to max do
begin
write(data[i]:7);
if (i mod 10)=0 then
writeln;
end;
end.
{
$Log$
Revision 1.2 1998-09-11 10:55:26 peter
+ header+log
}