paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 13:29:14 +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. 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. 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. Then you can start shooting in the box with a laser beam.
You enter the coordinates where the beam enters the box. You enter the coordinates where the beam enters the box.
(this must be on the edges, this means that one of the coordinates (this must be on the edges, this means that one of the coordinates
must be 1 or 9...) must be 1 or 9...)
The beam will bounce off the atoms (using normal bouncing), and you The beam will bounce off the atoms (using normal bouncing), and you
will be told where the beam exits. will be told where the beam exits.
From this you must guess where the atoms are... From this you must guess where the atoms are...
} }
Const MaxSize = 9; Const MaxSize = 9;
MaxAtom = 10; MaxAtom = 10;
Type TRow = Array [0..MaxSize+1] of byte; Type TRow = Array [0..MaxSize+1] of byte;
TPlane = Array [0..MaxSize+1] of TRow; TPlane = Array [0..MaxSize+1] of TRow;
TCube = Array [0..MaxSize+1] of TPlane; TCube = Array [0..MaxSize+1] of TPlane;
@ -24,7 +38,7 @@ Var
Cube : TCube; Cube : TCube;
Count,Guessed,x,y,z : Longint; Count,Guessed,x,y,z : Longint;
ans : string; ans : string;
Procedure FillCube; Procedure FillCube;
var i,x,y,z : longint; var i,x,y,z : longint;
@ -38,7 +52,7 @@ begin
repeat repeat
Write ('Enter number of atoms (1-',maxatom,') : '); Write ('Enter number of atoms (1-',maxatom,') : ');
readln (count); readln (count);
if (count<1) or (count>MaxAtom) then if (count<1) or (count>MaxAtom) then
writeln ('Invalid value entered. Please try again.'); writeln ('Invalid value entered. Please try again.');
until (count>0) and (count<=MaxAtom); until (count>0) and (count<=MaxAtom);
for I:=1 to count do for I:=1 to count do
@ -49,7 +63,7 @@ begin
z:=Random(MaxSize)+1; z:=Random(MaxSize)+1;
until Cube[x,y,z]=0; until Cube[x,y,z]=0;
Cube[x,y,z]:=1; Cube[x,y,z]:=1;
end; end;
end; end;
Procedure GetCoords (Var X,y,z : longint); Procedure GetCoords (Var X,y,z : longint);
@ -68,12 +82,12 @@ Procedure GetStart (Var x,y,z : longint);
Var OK : boolean; Var OK : boolean;
begin begin
Writeln ('Please enter beam start coordinates : '); Writeln ('Please enter beam start coordinates : ');
Repeat Repeat
GetCoords (x,y,z); GetCoords (x,y,z);
OK:=((X=1) or (X=MaxSize)) or ((y=1) or (Y=MaxSize)) or OK:=((X=1) or (X=MaxSize)) or ((y=1) or (Y=MaxSize)) or
((Z=1) or (z=maxsize)); ((Z=1) or (z=maxsize));
if Not OK then if Not OK then
writeln ('The beam should enter at an edge. Please try again'); writeln ('The beam should enter at an edge. Please try again');
until OK; until OK;
end; end;
@ -82,14 +96,14 @@ Function GetGuess : boolean;
Var OK : boolean; Var OK : boolean;
x,y,z : longint; x,y,z : longint;
begin begin
Writeln ('Please enter atom coordinates : '); Writeln ('Please enter atom coordinates : ');
Repeat Repeat
getcoords (x,y,z); getcoords (x,y,z);
OK:=((X>=1) or (X<=MaxSize)) or ((y>=1) or (Y<=MaxSize)) or OK:=((X>=1) or (X<=MaxSize)) or ((y>=1) or (Y<=MaxSize)) or
((Z>=1) or (z<=maxsize)); ((Z>=1) or (z<=maxsize));
if Not OK then if Not OK then
writeln ('These are not valid coordinates. Please try again'); writeln ('These are not valid coordinates. Please try again');
until OK; until OK;
GetGuess:=False; GetGuess:=False;
@ -100,7 +114,7 @@ begin
Writeln ('Correct guess !'); Writeln ('Correct guess !');
Cube[x,y,z]:=-Cube[x,y,z]; Cube[x,y,z]:=-Cube[x,y,z];
getguess:=true; getguess:=true;
end end
else else
Writeln ('Wrong guess !'); Writeln ('Wrong guess !');
end; end;
@ -129,8 +143,8 @@ begin
if dz<>0 then dz:=dz div abs(dz); if dz<>0 then dz:=dz div abs(dz);
if dy<>0 then dy:=dy div abs(dy); if dy<>0 then dy:=dy div abs(dy);
x:=x+dx;y:=y+dy;z:=z+dz; x:=x+dx;y:=y+dy;z:=z+dz;
until ((x=0) or (x=MaxSize+1)) or ((y=0) or (y=maxsize+1)) or until ((x=0) or (x=MaxSize+1)) or ((y=0) or (y=maxsize+1)) or
((z=0) or (z=maxsize+1)); ((z=0) or (z=maxsize+1));
Writeln ('Beam exited at : (',x-dx,',',y-dy,',',z-dz,')'); Writeln ('Beam exited at : (',x-dx,',',y-dy,',',z-dz,')');
end; end;
@ -142,7 +156,7 @@ begin
for x:=1 to MaxSize do for x:=1 to MaxSize do
for y:=1 to maxsize do for y:=1 to maxsize do
for z:=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,')'); writeln ('Atom at (',x,',',y,',',z,')');
end; end;
@ -154,7 +168,7 @@ begin
Write ('Shoot, guess or quit (s/g/q) : '); Write ('Shoot, guess or quit (s/g/q) : ');
readln (ans); readln (ans);
ans[1]:=Upcase(ans[1]); 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.'); writeln ('Invalid entry. Please try again.');
until ans[1] in ['S','G','Q']; until ans[1] in ['S','G','Q'];
Case ans[1] of Case ans[1] of
@ -168,5 +182,12 @@ begin
If Guessed=count then If Guessed=count then
Writeln ('Congratulations! All ',Count,' correct !') Writeln ('Congratulations! All ',Count,' correct !')
else else
Writeln ('Only ',guessed,' out of ',count,' correct...'); Writeln ('Only ',guessed,' out of ',count,' correct...');
end. 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 Eratos Example, Calculates all Prime Numbers from 1 to max
Translated By Eric Molitor (emolitor@freenet.fsu.edu)
****************************************************************************} 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,
{ Calculates all Prime Numbers from 1 to max } but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
program eratosthenes; program eratosthenes;
const const
@ -26,13 +30,21 @@ program eratosthenes;
for i:=1 to max do for i:=1 to max do
a[i]:=true; a[i]:=true;
for i:=2 to max div 2 do for i:=2 to max div 2 do
if a[i] then if a[i] then
for j:=2 to max div i do for j:=2 to max div i do
a[i*j]:=false; a[i*j]:=false;
writeln; writeln;
j:=0;
for i:=1 to max do for i:=1 to max do
if a[i] then begin
write(i:8); if a[i] then
begin
write(i:7);
inc(j);
if (j mod 10)=0 then
writeln;
end;
end;
writeln; writeln;
end; end;
@ -41,14 +53,11 @@ program eratosthenes;
eratos; eratos;
end. end.
{ {
$Log$ $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) * 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; {
$Id$
begin This file is part of the Free Pascal run time library.
writeln('Hello world'); Copyright (c) 1993-98 by the Free Pascal Development Team
end.
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 See the file COPYING.FPC, included in this distribution,
Translated By Eric Molitor (emolitor@freenet.fsu.edu) for details about the copyright.
History: This program is distributed in the hope that it will be useful,
29.10.1992 Version 1.0 but WITHOUT ANY WARRANTY; without even the implied warranty of
3.3.1995 an FPKPascal angepaát MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
}
**********************************************************************}
program count_lines; program count_lines;
{
Program that counts number of Lines in a file
}
uses uses
dos,crt; dos,crt;
@ -26,7 +31,7 @@ program count_lines;
d : ^td; d : ^td;
{$ifdef tp} {$ifdef tp}
count : word; count : word;
i,z : integer; i,z : integer;
{$else} {$else}
count,i,z : longint; count,i,z : longint;
{$endif} {$endif}
@ -36,9 +41,9 @@ program count_lines;
new(d); new(d);
if paramcount<1 then if paramcount<1 then
begin 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(' Multiple File Names and Wild Cards Allowed:');
writeln(' z.B LINES *.CPP STDIO.H *.ASM'); writeln(' Example: lines *.cpp stdio.h *.asm');
halt(1); halt(1);
end; end;
for i:=1 to paramcount do for i:=1 to paramcount do
@ -68,3 +73,10 @@ program count_lines;
gotoxy(1,wherey); gotoxy(1,wherey);
if lines=1 then writeln('1 Line') else writeln(lines,' Lines'); if lines=1 then writeln('1 Line') else writeln(lines,' Lines');
end. 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 @@
{**************************************************************************** {
$Id$
Copyright (c) 1994 by Florian Kl„mpfl This file is part of the Free Pascal run time library.
Copyright (c) 1993-98 by Florian Klaempfl
****************************************************************************}
Magic Square Example
{ Demonstrationsprogramm zu FPKPascal }
{ berechnet magische Quadrate (Summe alle Spalten, Zeilen und } See the file COPYING.FPC, included in this distribution,
{ Diagonalen ist gleich) } for details about the copyright.
program magic;
This program is distributed in the hope that it will be useful,
const but WITHOUT ANY WARRANTY; without even the implied warranty of
maxsize = 11; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
type **********************************************************************}
sqrtype = array[1..maxsize, 1..maxsize] of integer; program magic;
var {
square : sqrtype; Calculate a magic square (sum of the row, colums and diagonals is equal
size, row, sum : integer; }
procedure makesquare(var sq : sqrtype;limit : integer); const
maxsize = 11;
var
num,r,c : integer; type
sqrtype = array[1..maxsize, 1..maxsize] of longint;
begin
for r:=1 to limit do var
for c:=1 to limit do square : sqrtype;
sq[r, c] := 0; size, row, sum : longint;
if (limit and 1)<>0 then
begin procedure makesquare(var sq : sqrtype;limit : longint);
r:=(limit+1) div 2;
c:=limit; var
for num:=1 to limit*limit do num,r,c : longint;
begin
if sq[r,c]<>0 then begin
begin for r:=1 to limit do
dec(r); for c:=1 to limit do
if r<1 then sq[r, c] := 0;
r:=r+limit; if (limit and 1)<>0 then
c:=c-2; begin
if c<1 then r:=(limit+1) div 2;
c:=c+limit; c:=limit;
end; for num:=1 to limit*limit do
sq[r,c]:=num; begin
inc(r); if sq[r,c]<>0 then
if r>limit then begin
r:=r-limit; dec(r);
inc(c); if r<1 then
if c>limit then inc(r,limit);
c:=c-limit; dec(c,2);
end; if c<1 then
end; inc(c,limit);
end; end;
sq[r,c]:=num;
procedure writesquare(var sq : sqrtype;limit : integer); inc(r);
if r>limit then
var dec(r,limit);
row,col : integer; inc(c);
if c>limit then
begin dec(c,limit);
for row:=1 to Limit do end;
begin end;
for col:=1 to (limit div 2) do end;
write(sq[row,2*col-1]:4,' ',sq[row,2*col]:4,' ');
writeln(sq[row,limit]:4); procedure writesquare(var sq : sqrtype;limit : longint);
end;
end; var
row,col : longint;
begin
size:=3; begin
while (size<=maxsize) do for row:=1 to Limit do
begin begin
writeln('Magisches Quadrat mit der Seitenl„nge ',size); for col:=1 to (limit div 2) do
writeln; write(sq[row,2*col-1]:4,' ',sq[row,2*col]:4,' ');
makesquare(square,size); writeln(sq[row,limit]:4);
writesquare(square,size); end;
writeln; end;
sum:=0;
for row:=1 to size do begin
sum:=sum+square[row,1]; size:=3;
writeln('Summe in den Reihen, Spalten und Diagonalen = ', sum); while (size<=maxsize) do
writeln; begin
writeln; writeln('Magic Square with size ',size);
size:=size+2; writeln;
end; makesquare(square,size);
end. 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, } $Id$
{ bewegt, komprimiert, ausgelacht usw. werden. Allerdings bittscheen immer mit } This file is part of the Free Pascal run time library.
{ meinem (G)obbirait } Copyright (c) 1993-98 by Gernot Tenchio
USES GRAPH; Mandelbrot Example using the Graph unit
const shift:byte=12; See the file COPYING.FPC, included in this distribution,
for details about the copyright.
VAR SerchPoint,ActualPoint,NextPoint : PointType ;
LastColor : longint; This program is distributed in the hope that it will be useful,
Gd,Gm,Max_Color,Max_X_Width, but WITHOUT ANY WARRANTY; without even the implied warranty of
Max_Y_Width,Y_Width : INTEGER ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
Y1,Y2,X1,X2,Dy,Dx : Real ;
Zm : Integer ; **********************************************************************}
Flag : BOOLEAN ; program mandel;
LineY : ARRAY [0..600] OF BYTE;
LineX : ARRAY [0..100,0..600] OF INTEGER; {
CONST Mandelbrot example using the graph unit.
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); Note: For linux you need to run this program as root !!
TYPE }
ArrayType = array[1..50] of integer;
{------------------------------------------------------------------------------} uses
Graph;
FUNCTION CalcMandel(Point:PointType; z:integer) : Longint ;
var x,y,xq,yq,Cx,Cy : real ; const
shift:byte=12;
BEGIN
Cy:=y2 + dy*Point.y ; var
Cx:=x2 + dx*Point.x ; SerchPoint,ActualPoint,NextPoint : PointType;
X:=-Cx ; Y:=-Cy ; LastColor : longint;
REPEAT Gd,Gm,
xq:=x * x; Max_Color,Max_X_Width,
yq:=y * y ; Max_Y_Width,Y_Width : integer;
y :=x * y; Y1,Y2,X1,X2,Dy,Dx : Real;
y :=y + y - cy; Zm : Integer;
x :=xq - yq - cx ; Flag : boolean;
z :=z -1; LineY : array [0..600] OF BYTE;
UNTIL (Z=0) OR (Xq + Yq > 4 ); LineX : array [0..100,0..600] OF INTEGER;
IF Z=0 Then CalcMandel:=1 else CalcMandel:=(z mod Max_Color) + 1 ; const
END ; 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);
PROCEDURE Partition(VAR A : ArrayType; First, Last : Byte); type
{ ist nicht auf meinem Mist gewachsen. Weiss aber auch nicht mehr so richtig arrayType = array[1..50] of integer;
wo es herkommt. Allseits bekannter Sortieralgo }
VAR {------------------------------------------------------------------------------}
Right,Left : BYTE ; function CalcMandel(Point:PointType; z:integer) : Longint ;
V,Temp : integer; var
BEGIN x,y,xq,yq,Cx,Cy : real ;
V := A[(First + Last) SHR 1]; begin
Right := First; Cy:=y2 + dy*Point.y ;
Left := Last; Cx:=x2 + dx*Point.x ;
REPEAT X:=-Cx ; Y:=-Cy ;
WHILE (A[Right] < V) DO repeat
Right:=Right+1; xq:=x * x;
WHILE (A[Left] > V) DO yq:=y * y ;
Left:=Left-1; y :=x * y;
IF (Right <= Left) THEN y :=y + y - cy;
BEGIN x :=xq - yq - cx ;
Temp:=A[Left]; z :=z -1;
A[Left]:=A[Right]; until (Z=0) or (Xq + Yq > 4 );
A[Right]:=Temp; if Z=0 Then
Right:=Right+1; CalcMandel:=1
Left:=Left-1; else
END; CalcMandel:=(z mod Max_Color) + 1 ;
UNTIL Right > Left; end;
IF (First < Left) THEN
Partition(A, First, Left); {-----------------------------------------------------------------------------}
IF (Right < Last) THEN procedure Partition(var A : arrayType; First, Last : Byte);
Partition(A, Right, Last) var
END; Right,Left : byte ;
V,Temp : integer;
FUNCTION BlackScan(var NextPoint:PointType) : BOOLEAN ; begin
BEGIN V := A[(First + Last) SHR 1];
BlackScan:=TRUE; Right := First;
REPEAT Left := Last;
IF NextPoint.X=Max_X_Width THEN repeat
BEGIN while (A[Right] < V) do
IF NextPoint.Y < Y_Width THEN inc(Right);
BEGIN while (A[Left] > V) do
NextPoint.X:=0 ; Dec(Left);
NextPoint.Y:=NextPoint.Y+1; if (Right <= Left) then
END begin
ELSE Temp:=A[Left];
BEGIN A[Left]:=A[Right];
BlackScan:=FALSE; A[Right]:=Temp;
EXIT; Right:=Right+1;
END ; { IF } Left:=Left-1;
END ; { IF } end;
NextPoint.X:=NextPoint.X+1; until Right > Left;
UNTIL GetPixel(NextPoint.X,NextPoint.Y)=0; if (First < Left) then
END ; Partition(A, First, Left);
{------------------------------------------------------------------------------} if (Right < Last) then
PROCEDURE Fill(Ymin,Ymax,LastColor:integer); Partition(A, Right, Last)
VAR P1,P3,P4,P : INTEGER ; end;
Len,P2 : BYTE ;
Darray : ARRAYTYPE; {-----------------------------------------------------------------------------}
function BlackScan(var NextPoint:PointType) : boolean;
BEGIN begin
SetColor(LastColor); BlackScan:=true;
FOR P1:=Ymin+1 TO Ymax-1 DO repeat
BEGIN if NextPoint.X=Max_X_Width then
Len:=LineY[P1] ; begin
IF Len >= 2 THEN if NextPoint.Y < Y_Width then
BEGIN begin
FOR P2:=1 TO Len DO NextPoint.X:=0 ;
BEGIN NextPoint.Y:=NextPoint.Y+1;
Darray[P2]:=LineX[P2,P1] ; end
END; { FOR } else
IF Len > 2 THEN Partition(Darray,1,len); begin
P2:=1; BlackScan:=false;
REPEAT exit;
P3:= Darray[P2] ; P4:= Darray[P2 + 1]; end ; { IF }
IF P3 <> P4 THEN end ; { IF }
BEGIN NextPoint.X:=NextPoint.X+1;
LINE ( P3 , P1 , P4 , P1) ; until GetPixel(NextPoint.X,NextPoint.Y)=0;
IF Flag THEN end ;
BEGIN
P:=Max_Y_Width-P1; {------------------------------------------------------------------------------}
LINE ( P3 , P , P4 , P ) ; procedure Fill(Ymin,Ymax,LastColor:integer);
END; var
END; { IF } P1,P3,P4,P : integer ;
P2:=P2+2; Len,P2 : byte ;
UNTIL P2 >= Len ; Darray : arraytype;
END; { IF } begin
END; { FOR } SetColor(LastColor);
END; for P1:=Ymin+1 to Ymax-1 do
begin
{-----------------------------------------------------------------------------} Len:=LineY[P1] ;
if Len >= 2 then
Function NewPosition(Last:Byte):Byte; begin
begin for P2:=1 to Len do
newposition:=(((last+1) and 254)+6) and 7; Darray[P2]:=LineX[P2,P1] ;
END; if Len > 2 then
Partition(Darray,1,len);
{-----------------------------------------------------------------------------} P2:=1;
repeat
PROCEDURE CalcBounds; P3:= Darray[P2] ; P4:= Darray[P2 + 1];
VAR LastOperation,KK, if P3 <> P4 then
Position : Byte ; begin
foundcolor : longint; line ( P3 , P1 , P4 , P1) ;
Start,Found,NotFound : BOOLEAN ; if Flag then
MerkY,Ymax : Integer ; begin
LABEL L; P:=Max_Y_Width-P1;
BEGIN line ( P3 , P , P4 , P ) ;
REPEAT end;
FillChar(LineY,SizeOf(LineY),0) ; end; { IF }
ActualPoint:=NextPoint; P2:=P2+2;
LastColor:=CalcMandel(NextPoint,Zm) ; until P2 >= Len ;
PUTPIXEL (ActualPoint.X,ActualPoint.Y,LastColor); end; { IF }
IF Flag THEN PUTPIXEL (ActualPoint.X, end; { FOR }
Max_Y_Width-ActualPoint.Y,LastColor) ; end;
Ymax:=NextPoint.Y ;
MerkY:=NextPoint.Y ; {-----------------------------------------------------------------------------}
NotFound:=FALSE ; Function NewPosition(Last:Byte):Byte;
Start:=FALSE ; begin
LastOperation:=4 ; newposition:=(((last+1) and 254)+6) and 7;
REPEAT end;
Found:=FALSE ;
KK:=0 ; {-----------------------------------------------------------------------------}
Position:=NewPosition(LastOperation); procedure CalcBounds;
REPEAT var
LastOperation:=(Position+KK) AND 7 ; lastOperation,KK,
SerchPoint.X:=ActualPoint.X+Sx[LastOperation]; Position : Byte ;
SerchPoint.Y:=ActualPoint.Y+Sy[LastOperation]; foundcolor : longint;
IF ( (SerchPoint.X < 0) Start,Found,NotFound : boolean ;
OR (SerchPoint.X > Max_X_Width) MerkY,Ymax : Integer ;
OR (SerchPoint.Y < NextPoint.Y) label
OR (SerchPoint.Y > Y_Width) ) THEN GOTO L; L;
IF (SerchPoint.X=NextPoint.X) AND (SerchPoint.Y=NextPoint.Y) THEN begin
BEGIN repeat
Start:=TRUE ; FillChar(LineY,SizeOf(LineY),0) ;
Found:=TRUE ; ActualPoint:=NextPoint;
END LastColor:=CalcMandel(NextPoint,Zm) ;
ELSE putpixel (ActualPoint.X,ActualPoint.Y,LastColor);
BEGIN if Flag then
FoundColor:=GetPixel(SerchPoint.X,SerchPoint.Y) ; putpixel (ActualPoint.X,Max_Y_Width-ActualPoint.Y,LastColor) ;
IF FoundColor = 0 THEN Ymax:=NextPoint.Y ;
BEGIN MerkY:=NextPoint.Y ;
FoundColor:= CalcMandel (SerchPoint,Zm) ; NotFound:=false ;
Putpixel (SerchPoint.X,SerchPoint.Y,FoundColor) ; Start:=false ;
IF Flag THEN PutPixel (SerchPoint.X,Max_Y_Width-SerchPoint.Y, LastOperation:=4 ;
FoundColor) ; repeat
END ; Found:=false ;
IF FoundColor=LastColor THEN KK:=0 ;
BEGIN Position:=NewPosition(LastOperation);
IF ActualPoint.Y <> SerchPoint.Y THEN repeat
BEGIN LastOperation:=(Position+KK) and 7 ;
IF SerchPoint.Y = MerkY THEN LineY[ActualPoint.Y]:=LineY[ActualPoint.Y]-1; SerchPoint.X:=ActualPoint.X+Sx[LastOperation];
MerkY:= ActualPoint.Y ; SerchPoint.Y:=ActualPoint.Y+Sy[LastOperation];
LineY[SerchPoint.Y]:=LineY[SerchPoint.Y]+1; if ((SerchPoint.X < 0) or
END ; (SerchPoint.X > Max_X_Width) or
LineX[LineY[SerchPoint.Y],SerchPoint.Y]:=SerchPoint.X ; (SerchPoint.Y < NextPoint.Y) or
IF SerchPoint.Y > Ymax THEN Ymax:= SerchPoint.Y ; (SerchPoint.Y > Y_Width)) then
Found:=TRUE ; goto L;
ActualPoint:=SerchPoint ; if (SerchPoint.X=NextPoint.X) and (SerchPoint.Y=NextPoint.Y) then
END; begin
L: Start:=true ;
KK:=KK+1; Found:=true ;
IF KK > 8 THEN end
BEGIN else
Start:=TRUE ; begin
NotFound:=TRUE ; FoundColor:=GetPixel(SerchPoint.X,SerchPoint.Y) ;
END; if FoundColor = 0 then
END; begin
UNTIL Found OR (KK > 8); FoundColor:= CalcMandel (SerchPoint,Zm) ;
UNTIL Start ; Putpixel (SerchPoint.X,SerchPoint.Y,FoundColor) ;
if Flag then
IF not NotFound THEN Fill(NextPoint.Y,Ymax,LastColor) ; PutPixel (SerchPoint.X,Max_Y_Width-SerchPoint.Y,FoundColor) ;
UNTIL NOT BlackScan(NextPoint); end ;
END ; if FoundColor=LastColor then
{------------------------------------------------------------------------------} begin
{-----------------------} if ActualPoint.Y <> SerchPoint.Y then
{ MAINROUTINE } begin
{-----------------------} if SerchPoint.Y = MerkY then
LineY[ActualPoint.Y]:=LineY[ActualPoint.Y]-1;
BEGIN MerkY:= ActualPoint.Y ;
{$ifndef linux} LineY[SerchPoint.Y]:=LineY[SerchPoint.Y]+1;
gm:=$103; 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} {$else}
gm:=G800x600x256; gm:=$103;
gd:=$ff;
{$ifDEF TURBO}
gd:=detect;
{$endif}
{$endif} {$endif}
gd:=$ff; InitGraph(gd,gm,'D:\bp\bgi');
{$IFDEF TURBO} if GraphResult <> grOk then Halt(1);
gd:=detect; Max_X_Width:=GetMaxX;
{$ENDIF} Max_y_Width:=GetMaxY;
InitGraph(gd,gm,'D:\bp\bgi'); Max_Color:=GetMaxColor-1;
IF GraphResult <> grOk THEN Halt(1); ClearViewPort;
Max_X_Width:=GetMaxX;
Max_y_Width:=GetMaxY; x1:=-0.9;
Max_Color:=GetMaxColor-1; x2:= 2.2;
ClearViewPort; y1:= 1.25;
y2:=-1.25;
x1:=-0.9; zm:=90;
x2:= 2.2; dx:=(x1 - x2) / Max_X_Width ;
y1:= 1.25; dy:=(y1 - y2) / Max_Y_Width ;
y2:=-1.25; if abs(y1) = abs(y2) then
zm:=90; begin
dx:=(x1 - x2) / Max_X_Width ; flag:=true;
dy:=(y1 - y2) / Max_Y_Width ; Y_Width:=Max_Y_Width shr 1
end
IF ABS(y1) = ABS(y2) THEN else
BEGIN begin
flag:=TRUE ; Y_Width:=Max_Y_Width shr 1; flag:=false;
END Y_Width:=Max_Y_Width;
ELSE end;
BEGIN NextPoint.X:=0;
flag:=FALSE ; Y_Width:=Max_Y_Width; NextPoint.Y:=0;
END; LastColor:=CalcMandel(SerchPoint,zm);
NextPoint.X:=0; NextPoint.Y:=0; CalcBounds ;
LastColor:=CalcMandel(SerchPoint,zm); readln;
CalcBounds ; CloseGraph;
readln; end.
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 QuickSort Example
Translated by Eric Molitor (emolitor@freenet.fsu.edu)
****************************************************************************} 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 const
max = 1000; max = 100000;
type type
tlist = array[1..max] of integer; tlist = array[1..max] of longint;
var var
data : tlist; data : tlist;
procedure qsort(var a : tlist); procedure qsort(var a : tlist);
procedure sort(l,r: integer); procedure sort(l,r: longint);
var var
i,j,x,y: integer; i,j,x,y: longint;
begin begin
i:=l; i:=l;
j:=r; j:=r;
x:=a[(l+r) div 2]; x:=a[(l+r) div 2];
repeat repeat
while a[i]<x do i:=i+1; while a[i]<x do
while x<a[j] do j:=j-1; inc(i);
while x<a[j] do
dec(j);
if not(i>j) then if not(i>j) then
begin begin
y:=a[i]; y:=a[i];
a[i]:=a[j]; a[i]:=a[j];
a[j]:=y; a[j]:=y;
i:=i+1; inc(i);
j:=j-1; j:=j-1;
end; end;
until i>j; until i>j;
if l<j then sort(l,j); if l<j then
if i<r then sort(i,r); sort(l,j);
if i<r then
sort(i,r);
end; end;
begin begin
sort(1,max); sort(1,max);
end; end;
var var
i : longint; i : longint;
begin
begin write('Creating ',Max,' random numbers between 1 and 500000');
write('Creating ',Max,' random numbers between 1 and 30000'); randomize;
randomize; for i:=1 to max do
for i:=1 to max do data[i]:=random(500000);
data[i]:=random(30000); writeln;
write(#13#10'Sorting...'); writeln('Sorting...');
qsort(data); qsort(data);
writeln; writeln;
for i:=1 to max do for i:=1 to max do
write(data[i]:8); begin
write(data[i]:7);
if (i mod 10)=0 then
writeln;
end;
end. end.
{
$Log$
Revision 1.2 1998-09-11 10:55:26 peter
+ header+log
}