mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-17 16:09:17 +02:00
+ header+log
This commit is contained in:
peter
parent
857e290786
commit
b8aa494108
94
install/demo/Makefile
Normal file
94
install/demo/Makefile
Normal 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
|
||||
#
|
||||
#
|
||||
@ -1,7 +1,21 @@
|
||||
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.
|
||||
@ -170,3 +184,10 @@ begin
|
||||
else
|
||||
Writeln ('Only ',guessed,' out of ',count,' correct...');
|
||||
end.
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1998-09-11 10:55:20 peter
|
||||
+ header+log
|
||||
|
||||
}
|
||||
|
||||
@ -1,14 +1,18 @@
|
||||
{****************************************************************************
|
||||
{
|
||||
$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
|
||||
@ -30,9 +34,17 @@ program eratosthenes;
|
||||
for j:=2 to max div i do
|
||||
a[i*j]:=false;
|
||||
writeln;
|
||||
j:=0;
|
||||
for i:=1 to max do
|
||||
begin
|
||||
if a[i] then
|
||||
write(i:8);
|
||||
begin
|
||||
write(i:7);
|
||||
inc(j);
|
||||
if (j mod 10)=0 then
|
||||
writeln;
|
||||
end;
|
||||
end;
|
||||
writeln;
|
||||
end;
|
||||
|
||||
@ -43,12 +55,9 @@ program eratosthenes;
|
||||
|
||||
{
|
||||
$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
|
||||
}
|
||||
@ -1,3 +1,19 @@
|
||||
{
|
||||
$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
|
||||
|
||||
@ -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;
|
||||
@ -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
|
||||
|
||||
}
|
||||
|
||||
@ -1,28 +1,38 @@
|
||||
{****************************************************************************
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 1993-98 by Florian Klaempfl
|
||||
|
||||
Copyright (c) 1994 by Florian Kl„mpfl
|
||||
Magic Square Example
|
||||
|
||||
****************************************************************************}
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
{ Demonstrationsprogramm zu FPKPascal }
|
||||
{ berechnet magische Quadrate (Summe alle Spalten, Zeilen und }
|
||||
{ Diagonalen ist gleich) }
|
||||
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 integer;
|
||||
sqrtype = array[1..maxsize, 1..maxsize] of longint;
|
||||
|
||||
var
|
||||
square : sqrtype;
|
||||
size, row, sum : integer;
|
||||
size, row, sum : longint;
|
||||
|
||||
procedure makesquare(var sq : sqrtype;limit : integer);
|
||||
procedure makesquare(var sq : sqrtype;limit : longint);
|
||||
|
||||
var
|
||||
num,r,c : integer;
|
||||
num,r,c : longint;
|
||||
|
||||
begin
|
||||
for r:=1 to limit do
|
||||
@ -38,26 +48,26 @@ program magic;
|
||||
begin
|
||||
dec(r);
|
||||
if r<1 then
|
||||
r:=r+limit;
|
||||
c:=c-2;
|
||||
inc(r,limit);
|
||||
dec(c,2);
|
||||
if c<1 then
|
||||
c:=c+limit;
|
||||
inc(c,limit);
|
||||
end;
|
||||
sq[r,c]:=num;
|
||||
inc(r);
|
||||
if r>limit then
|
||||
r:=r-limit;
|
||||
dec(r,limit);
|
||||
inc(c);
|
||||
if c>limit then
|
||||
c:=c-limit;
|
||||
dec(c,limit);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure writesquare(var sq : sqrtype;limit : integer);
|
||||
procedure writesquare(var sq : sqrtype;limit : longint);
|
||||
|
||||
var
|
||||
row,col : integer;
|
||||
row,col : longint;
|
||||
|
||||
begin
|
||||
for row:=1 to Limit do
|
||||
@ -72,17 +82,24 @@ begin
|
||||
size:=3;
|
||||
while (size<=maxsize) do
|
||||
begin
|
||||
writeln('Magisches Quadrat mit der Seitenl„nge ',size);
|
||||
writeln('Magic Square with size ',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);
|
||||
inc(sum,square[row,1]);
|
||||
writeln('Sum of the rows,columns and diagonals = ', sum);
|
||||
writeln;
|
||||
writeln;
|
||||
size:=size+2;
|
||||
inc(size,2);
|
||||
end;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 1998-09-11 10:55:24 peter
|
||||
+ header+log
|
||||
|
||||
}
|
||||
|
||||
@ -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 }
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
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 ;
|
||||
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;
|
||||
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;
|
||||
|
||||
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 ;
|
||||
procedure Partition(var A : arrayType; First, Last : Byte);
|
||||
var
|
||||
Right,Left : byte ;
|
||||
V,Temp : integer;
|
||||
BEGIN
|
||||
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
|
||||
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
|
||||
end;
|
||||
until Right > Left;
|
||||
if (First < Left) then
|
||||
Partition(A, First, Left);
|
||||
IF (Right < Last) THEN
|
||||
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;
|
||||
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;
|
||||
end;
|
||||
|
||||
{-----------------------------------------------------------------------------}
|
||||
|
||||
PROCEDURE CalcBounds;
|
||||
VAR LastOperation,KK,
|
||||
procedure CalcBounds;
|
||||
var
|
||||
lastOperation,KK,
|
||||
Position : Byte ;
|
||||
foundcolor : longint;
|
||||
Start,Found,NotFound : BOOLEAN ;
|
||||
Start,Found,NotFound : boolean ;
|
||||
MerkY,Ymax : Integer ;
|
||||
LABEL L;
|
||||
BEGIN
|
||||
REPEAT
|
||||
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) ;
|
||||
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 ;
|
||||
NotFound:=false ;
|
||||
Start:=false ;
|
||||
LastOperation:=4 ;
|
||||
REPEAT
|
||||
Found:=FALSE ;
|
||||
repeat
|
||||
Found:=false ;
|
||||
KK:=0 ;
|
||||
Position:=NewPosition(LastOperation);
|
||||
REPEAT
|
||||
LastOperation:=(Position+KK) AND 7 ;
|
||||
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
|
||||
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
|
||||
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;
|
||||
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 ;
|
||||
end ;
|
||||
LineX[LineY[SerchPoint.Y],SerchPoint.Y]:=SerchPoint.X ;
|
||||
IF SerchPoint.Y > Ymax THEN Ymax:= SerchPoint.Y ;
|
||||
Found:=TRUE ;
|
||||
if SerchPoint.Y > Ymax then Ymax:= SerchPoint.Y ;
|
||||
Found:=true ;
|
||||
ActualPoint:=SerchPoint ;
|
||||
END;
|
||||
L:
|
||||
end;
|
||||
L:
|
||||
KK:=KK+1;
|
||||
IF KK > 8 THEN
|
||||
BEGIN
|
||||
Start:=TRUE ;
|
||||
NotFound:=TRUE ;
|
||||
END;
|
||||
END;
|
||||
UNTIL Found OR (KK > 8);
|
||||
UNTIL Start ;
|
||||
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 ;
|
||||
|
||||
IF not NotFound THEN Fill(NextPoint.Y,Ymax,LastColor) ;
|
||||
UNTIL NOT BlackScan(NextPoint);
|
||||
END ;
|
||||
{------------------------------------------------------------------------------}
|
||||
{-----------------------}
|
||||
{ MAINROUTINE }
|
||||
{-----------------------}
|
||||
|
||||
BEGIN
|
||||
{$ifndef linux}
|
||||
gm:=$103;
|
||||
{------------------------------------------------------------------------------
|
||||
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;
|
||||
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 ;
|
||||
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
|
||||
|
||||
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.
|
||||
}
|
||||
|
||||
@ -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
|
||||
var
|
||||
i : longint;
|
||||
|
||||
begin
|
||||
write('Creating ',Max,' random numbers between 1 and 30000');
|
||||
begin
|
||||
write('Creating ',Max,' random numbers between 1 and 500000');
|
||||
randomize;
|
||||
for i:=1 to max do
|
||||
data[i]:=random(30000);
|
||||
write(#13#10'Sorting...');
|
||||
data[i]:=random(500000);
|
||||
writeln;
|
||||
writeln('Sorting...');
|
||||
qsort(data);
|
||||
writeln;
|
||||
for i:=1 to max do
|
||||
write(data[i]:8);
|
||||
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
|
||||
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user