+ header+log

install/demo/Makefile

@@ -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
+#
+#

install/demo/blackbox.pp

@@ -1,21 +1,35 @@
+{
+    $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;
+
 {
-  (c) 1998 Michael Van Canneyt
-  
   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
+
+}

install/demo/eratos.pp

@@ -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 ([email protected])
+    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
-    * the algorythm was wrong (unnecessary checks were made)
+  Revision 1.5  1998-09-11 10:55:21  peter
+    + header+log
 
-  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
+  Revision 1.4  1998/09/04 17:38:15  pierre
+    * the algorythm was wrong (unnecessary checks were made)
 }

install/demo/hello.pp

@@ -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.
   

install/demo/lines.pp

@@ -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 ([email protected])
+    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
+
+}
+  

install/demo/magic.pp

@@ -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
+
+}
+  

install/demo/mandel.pp

@@ -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
+
+}

install/demo/qsort.pp

@@ -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 ([email protected])
+    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 qsort(var a : tlist);
 
+    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
+
+}