* initial release

packages/extra/amunits/demos/bezier2.pas

@@ -0,0 +1,290 @@
+Program Bezier;
+{$mode objfpc}
+
+{  This program draws Bezier curves in the slow, simple, recursive
+   way.  When it first runs, you enter points in the window by
+   clicking the left mouse button.  After you double click on the
+   last point, the program begins drawing the curve.
+
+   Since this is a highly recursive program, it's speed decreases
+   dramatically as you enter more points.  It can handle six or
+   seven points with reasonable speed, but if you enter ten you
+   might want to go see a movie while it draws.  It also uses
+   more stack space as you enter more points, but I hasn't blown
+   a 4k stack yet.
+}
+
+{
+   Translated to fpc pascal from pcq pascal.
+   Updated the source a bit.
+   04 Apr 2001.
+
+   Changed to use systemvartags, OpenScreenTags
+   and OpenWindowTags. Also Text to Gtext.
+   09 Nov 2002.
+
+   [email protected]
+}
+
+uses exec, intuition, graphics, utility, pastoc, systemvartags;
+
+type
+    PointRec = Record
+        X, Y : integer;
+    end;
+
+Const
+    w  : pWindow  = Nil;
+    s  : pScreen   = Nil;
+
+{
+    This will make the new look for screen.
+    SA_Pens, Integer(pens)
+}
+    pens : array [0..0] of integer = (not 0);
+
+
+
+Var
+    m  : pMessage;
+    rp : pRastPort;
+
+    PointCount : integer;
+    Points : Array [1..15] of PointRec;
+
+    t, tprime : Real;
+
+    LastX, LastY : integer;
+
+Procedure CleanUpAndDie;
+begin
+    if w <> Nil then begin
+	Forbid;
+	repeat until GetMsg(w^.UserPort) = Nil;
+	CloseWindow(w);
+	Permit;
+    end;
+    if s <> Nil then
+	CloseScreen(s);
+    halt(0);
+end;
+
+
+Procedure DrawLine;
+begin
+    Move(rp, Points[PointCount].X, Points[PointCount].Y);
+    Draw(rp, LastX, LastY);
+end;
+
+Procedure GetPoints;
+var
+    LastSeconds,
+    LastMicros	: longint;
+    IM : pIntuiMessage;
+    StoreMsg : tIntuiMessage;
+    Leave : Boolean;
+    OutOfBounds : Boolean;
+    BorderLeft, BorderRight,
+    BorderTop, BorderBottom : integer;
+
+    Procedure AddPoint;
+    begin
+	Inc(PointCount);
+	with Points[PointCount] do begin
+	    X := StoreMsg.MouseX;
+	    Y := StoreMsg.MouseY;
+	end;
+	with StoreMsg do begin
+	    LastX := MouseX;
+	    LastY := MouseY;
+	    LastSeconds := Seconds;
+	    LastMicros := Micros;
+	end;
+	SetAPen(rp, 2);
+	SetDrMd(rp, JAM1);
+	DrawEllipse(rp, LastX, LastY, 5, 3);
+	SetAPen(rp, 3);
+	SetDrMd(rp, COMPLEMENT);
+	DrawLine;
+    end;
+
+    Function CheckForExit : Boolean;
+    {   This function determines whether the user wanted to stop
+	entering points.  I added the position tests because my
+	doubleclick time is too long, and I was too lazy to dig
+	out Preferences to change it. }
+    begin
+	with StoreMsg do
+	    CheckForExit := DoubleClick(LastSeconds, LastMicros,
+					Seconds, Micros) and
+			    (Abs(MouseX - Points[PointCount].X) < 5) and
+			    (Abs(MouseY - Points[PointCount].Y) < 3);
+    end;
+
+    Procedure ClearIt;
+    {  This just clears the screen when you enter your first point }
+    begin
+	SetDrMd(rp, JAM1);
+	SetAPen(rp, 0);
+	RectFill(rp, BorderLeft, BorderTop,
+		     BorderRight, BorderBottom);
+	SetDrMd(rp, COMPLEMENT);
+	SetAPen(rp, 3);
+    end;
+
+begin
+    Move(rp, 252, 30);
+    GText(rp, 'Enter points by pressing the left mouse button', 46);
+    Move(rp, 252, 40);
+    GText(rp, 'Double click on the last point to begin drawing', 47);
+    ModifyIDCMP(w, IDCMP_CLOSEWINDOW or IDCMP_MOUSEBUTTONS or IDCMP_MOUSEMOVE);
+    SetDrMd(rp, COMPLEMENT);
+    PointCount := 0;
+    Leave := False;
+    OutOfBounds := False;
+    BorderLeft := w^.BorderLeft;
+    BorderRight := 639 - w^.BorderRight;
+    BorderTop := w^.BorderTop;
+    BorderBottom := 189 - w^.BorderBottom;
+    repeat
+        IM := pIntuiMessage(WaitPort(w^.UserPort));
+        IM := pIntuiMessage(GetMsg(w^.UserPort));
+        StoreMsg := IM^;
+        ReplyMsg(pMessage(IM));
+        case StoreMsg.IClass of
+           IDCMP_MOUSEMOVE : if PointCount > 0 then begin
+			     if not OutOfBounds then
+				 DrawLine;
+           		     LastX := StoreMsg.MouseX;
+           		     LastY := StoreMsg.MouseY;
+			     if (LastX > BorderLeft) and
+				(LastX < BorderRight) and
+				(LastY > BorderTop) and
+				(LastY < BorderBottom) then begin
+				 DrawLine;
+				 OutOfBounds := False;
+			     end else
+				 OutOfBounds := True;
+           		 end;
+           IDCMP_MOUSEBUTTONS : if StoreMsg.Code = SELECTUP then begin
+           			if PointCount > 0 then
+				    Leave := CheckForExit
+				else
+				    ClearIt;
+           			if (not Leave) and (not OutOfBounds) then
+				    AddPoint;
+           		    end;
+           IDCMP_CLOSEWINDOW : CleanUpAndDie;
+        end;
+    until Leave or (PointCount > 14);
+    if not Leave then
+        DrawLine;
+    ModifyIDCMP(w, IDCMP_CLOSEWINDOW);
+    SetDrMd(rp, JAM1);
+    SetAPen(rp, 1);
+end;
+
+{
+   These two function just implement the de Casteljau
+algorithm, which looks like:
+
+         r            r-1         r-1
+	B  = (1-t) * B    +  t * B
+         i            i           i+1
+
+   Where r and i are meant to be subscripts and superscripts.  R is
+   a level number, where zero represents the data points and
+   (the number of points - 1) represents the curve points.  I is
+   the point numbers, starting from zero normally but in this
+   program starting from 1.  t is the familiar 'parameter' running
+   from 0 to 1 in arbitrary increments.
+}
+
+Function BezierX(r, i : integer) : Real;
+begin
+    if r = 0 then
+	BezierX := real(Points[i].X)
+    else
+	BezierX := tprime * BezierX(Pred(r), i) + t * BezierX(Pred(r), Succ(i));
+end;
+
+Function BezierY(r, i : integer) : Real;
+begin
+    if r = 0 then
+	BezierY := real(Points[i].Y)
+    else
+	BezierY := tprime * BezierY(Pred(r), i) + t * BezierY(Pred(r), Succ(i));
+end;
+
+Procedure DrawBezier;
+var
+    increment : Real;
+begin
+    increment := 0.01; { This could be a function of PointCount }
+    t := 0.0;
+    tprime := 1.0;
+    Move(rp, Trunc(BezierX(Pred(PointCount), 1)),
+	     Trunc(BezierY(Pred(PointCount), 1)));
+    t := t + increment;
+    tprime := 1.0 - t;
+    while t <= 1.0 do begin
+	Draw(rp, Trunc(BezierX(Pred(PointCount), 1)),
+		 Trunc(BezierY(Pred(PointCount), 1)));
+	t := t + increment;
+	tprime := 1.0 - t;
+	if GetMsg(w^.UserPort) <> Nil then
+	    CleanUpAndDie;
+    end;
+    t := 1.0;
+    tprime := 0.0;
+    Draw(rp, Trunc(BezierX(Pred(PointCount), 1)),
+	     Trunc(BezierY(Pred(PointCount), 1)));
+end;
+
+begin
+      s := OpenScreenTags(nil,[SA_Pens, @pens,
+      SA_Depth,     2,
+      SA_DisplayID, HIRES_KEY,
+      SA_Title,     'Simple Bezier Curves',
+      TAG_END]);
+
+    if s = NIL then CleanUpAndDie;
+
+      w := OpenWindowTags(nil,[
+      WA_IDCMP,        IDCMP_CLOSEWINDOW,
+      WA_Left,         0,
+      WA_Top,          s^.BarHeight +1,
+      WA_Width,        s^.Width,
+      WA_Height,       s^.Height - (s^.BarHeight + 1),
+      WA_DepthGadget,  ltrue,
+      WA_DragBar,      ltrue,
+      WA_CloseGadget,  ltrue,
+      WA_ReportMouse,  ltrue,
+      WA_SmartRefresh, ltrue,
+      WA_Activate,     ltrue,
+      WA_Title,        'Close the Window to Quit',
+      WA_CustomScreen, s,
+      TAG_END]);
+
+    IF w=NIL THEN CleanUpAndDie;
+
+	    	rp := w^.RPort;
+	    	GetPoints;
+	    	DrawBezier;
+		m := WaitPort(w^.UserPort);
+		Forbid;
+		repeat
+		    m := GetMsg(w^.UserPort);
+		until m = nil;
+		Permit;
+     CleanUpAndDie;
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+
+  

packages/extra/amunits/demos/checkmem.pas

@@ -0,0 +1,39 @@
+program checkmem;
+
+uses exec, amigados;
+
+var
+  chipfirst,
+  chipsecond,
+  fastfirst,
+  fastsecond : longint;
+
+begin
+
+  if ParamCount <> 1 then begin
+     writeln('Usage: CheckMem ProgramName');
+     halt(10);
+  end;
+
+  chipfirst := AvailMem(MEMF_CHIP);
+  fastfirst := AvailMem(MEMF_FAST);
+ 
+
+  if Execute(ParamStr(1),0,0) then begin
+     chipsecond := AvailMem(MEMF_CHIP);
+     fastsecond := AvailMem(MEMF_FAST);
+    
+     writeln('Memory loss (Chip): ',chipsecond-chipfirst);
+     writeln('Memory loss (Fast): ',fastsecond-fastfirst);
+     halt;
+  end else writeln('Could''t run the program');
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+
+  

packages/extra/amunits/demos/deviceinfo.pas

@@ -0,0 +1,112 @@
+
+{ *************************************************************************
+  **									 **
+  **  DeviceInfo  -  Version 1.0,	  (C)1992  by  Thomas Schmid     **
+  **						     Im Grenzacherhof 12 **
+  **   This programm is Public Domain,		     CH- 4058 Basel	 **
+  **   coded 18.02.1992 in PCQ-Pascal(1.2b).                             **
+  **   Gibt Info über angegebenes Device aus.				 **
+  **						 Usage :		 **
+  **							DeviceInfo Dfx:  **
+  **									 **
+  *************************************************************************
+}
+
+{
+   Translated to fpc pascal.
+   24 Mar 2001.
+
+   [email protected]
+}
+
+Program DeviceInfo;
+
+uses exec,amigados,strings;
+
+Const
+  MaxSize = 80;
+
+Var
+  MyLock	  : longint;
+  Inf		  : pInfoData;
+  Ok		  : Boolean;
+  Myfile	  : string;
+  S, S1		  : String;
+  Size, Used, Bpb : Integer;
+
+Procedure Cls;
+
+Begin
+  WriteLn('   DeviceInfo V1.0 © 1992, by T.Schmid, Written in PCQ V1.2b',#10);
+		
+End;
+
+Procedure AsdaLaVista(warum : String ; code : longint);
+
+Begin
+  If Inf   <> Nil Then ExecFreeMem(Inf,SizeOf(tInfoData));
+  If warum <> '' Then WriteLn('',warum,'');
+  halt(code);
+End;
+
+
+Begin
+  
+  
+  If ParamCount = 0 Then AsdaLaVista(' DiskInfo V1.0, © 1992 T.Schmid - Usage : DiskInfo Dfx:',0);
+  MyFile := ParamStr(1) + #0;
+
+  Inf:=pInfoData( AllocMem( SizeOf(tInfoData), MEMF_PUBLIC ) );
+  If Inf=Nil Then AsdaLaVista('No memory',5);
+
+  s:= 'Writeenabled';
+  s1:= 'Dos';
+
+  MyLock:=Lock(@Myfile[1],ACCESS_READ);
+  If MyLock = 0 Then AsdaLaVista('Can''t get a lock.',5);
+
+  Ok:=Info(MyLock,Inf);
+  Unlock(MyLock);		{ ------- Wichtig !! -------- }
+
+  If Ok = FALSE Then AsdaLaVista('Can''t get info on this Device.',10);
+
+  Bpb  := Inf^.id_BytesPerBlock;
+  Size := Inf^.id_NumBlocks     * Bpb DIV 1024;
+  Used := Inf^.id_NumBlocksUsed * Bpb DIV 1024;
+  Cls;
+
+  WriteLn('   Info about Device          :  ', Myfile, '');
+  WriteLn('   Size                       :  ', Size, ' KBytes  ','');
+  WriteLn('   Size used                  :  ', Used, ' KBytes  ','');
+  WriteLn('   Free                       :  ', Size-Used, ' KBytes  ','');
+  WriteLn('   Number of Bytes per Block  :  ', Inf^.id_BytesPerBlock, '');
+
+  Case Inf^.id_DiskType of
+	ID_NO_DISK_PRESENT : S1:='No Disk';
+	ID_UNREADABLE_DISK : S1:='Can''t read Disk';
+	ID_NOT_REALLY_DOS  : S1:='No Dos-Disk';
+	ID_KICKSTART_DISK  : S1:='Kickstart-Disk';
+  End;
+
+  WriteLn('   Disk Type                  :  ',S1,'');
+  WriteLn('   Type of error              :  ',Inf^.id_NumSoftErrors,'');
+
+  Case Inf^.id_DiskState of
+	ID_WRITE_PROTECTED : S:='Writeprotected';
+	ID_VALIDATING      : S:='Is Validated';
+  End;
+  WriteLn('   Device Status              :  ',S,'');
+
+  { wichtig : }
+  AsdaLaVista(#10 + '  C U in next CF !' + #10,0);
+
+End.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+
+  

packages/extra/amunits/demos/dirdemo.pas

@@ -0,0 +1,113 @@
+PROGRAM DirDemo;
+{$mode objfpc}
+
+{ 
+    How you can use unit linklist.
+    21 Mar 2001.
+
+    Changed to use printf in amigalib.
+    25 Nov 2002.
+
+    [email protected]
+}
+
+uses Amigados, exec, strings, linklist,pastoc, amigalib;
+
+CONST BufferSize = 2048;
+      CSI      = chr($9b);
+
+VAR ExData       : pExAllData;
+    PData        : pExAllData;
+    EAC          : pExAllControl;
+    MyLock       : FileLock;
+    AnyMore      : BOOLEAN;
+    FileList     : pList;
+    DirList      : pList;
+    tempnode     : pFPCNode;
+    Buffer       : PChar;
+    i,temp       : longint;
+    TotalSize    : longint;
+    TheDir       : string;
+
+PROCEDURE CleanUp(TheMsg : STRING; ErrCode : INTEGER);
+BEGIN
+    IF EAC <> NIL THEN FreeDosObject(DOS_EXALLCONTROL,EAC);
+    IF MyLock <> 0 THEN UnLock(MyLock);
+    IF ExData <> NIL THEN ExecFreeMem(ExData,BufferSize);
+    IF DirList <> NIL THEN DestroyList(DirList);
+    IF FileList <> NIL THEN DestroyList(FileList);
+    IF Buffer <> NIL THEN StrDispose(Buffer);
+    IF TheMsg <> '' THEN WriteLN(TheMsg);
+    Halt(ErrCode);
+END;
+
+PROCEDURE Usage;
+BEGIN
+    Write(CSI, '1m', 'DirDemo'#10,CSI,'0m', 'For FPC Pascal USAGE: DirDemo ThePath'#10);
+    CleanUp('',0);
+END;
+
+BEGIN
+    Buffer := StrAlloc(255);
+    IF ParamCount <> 1 then Usage;
+    TheDir := ParamStr(1);
+    CreateList(FileList);
+    CreateList(DirList);
+    TotalSize := 0;
+
+    EAC := AllocDosObject(DOS_EXALLCONTROL,NIL);
+    IF EAC = NIL THEN CleanUp('No AllocDosObject',10);
+
+    ExData := AllocMem(BufferSize,0);
+    EAC^.eac_LastKey := 0;
+    EAC^.eac_MatchString := NIL;
+    EAC^.eac_MatchFunc := NIL;
+    MyLock:=Lock(pas2c(TheDir),SHARED_LOCK);
+    IF MyLock=0 THEN CleanUp('No lock on directory',10);
+
+    REPEAT
+        AnyMore := ExAll(MyLock,ExData,BufferSize,ED_SIZE,EAC);
+        temp := IOErr;
+        PData := ExData;
+        FOR i := 1 TO EAC^.eac_Entries DO BEGIN
+            IF PData^.ed_Type >= 0 THEN BEGIN
+                tempnode := AddNewNode(DirList,PData^.ed_Name);
+            END ELSE BEGIN
+                tempnode := AddNewNode(FileList,PData^.ed_Name);
+                tempnode^.ln_Size := PData^.ed_Size;
+            END;
+            PData := PData^.ed_Next;
+        END;
+    UNTIL (AnyMore=FALSE) AND (temp=ERROR_NO_MORE_ENTRIES);
+
+    SortList(DirList);
+    SortList(FileList);
+
+    Write(CSI, '1m');
+    Write(CSI, '32m');
+    WriteLN('Directory of: "', TheDir,'"');
+    tempnode := GetFirstNode(DirList);
+
+    FOR i := 1 TO NodesInList(DirList) DO BEGIN
+        printf('%-30s  <DIR>'#10,[long(GetNodeData(tempnode))]);
+        tempnode := GetNextNode(tempnode);
+    END;
+    Write(CSI, '0m');
+    tempnode := GetFirstNode(FileList);
+    FOR i := 1 TO NodesInList(FileList) DO BEGIN
+        printf('%-30s%7ld'#10 ,[long(GetNodeData(tempnode)),tempnode^.ln_Size]);
+        TotalSize := TotalSize + tempnode^.ln_Size;
+        tempnode := GetNextNode(tempnode);
+    END;
+
+    WriteLN('The total size is ',TotalSize,' Byte.');
+    CleanUp('',0);
+END.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+  

packages/extra/amunits/demos/easter.pas

@@ -0,0 +1,85 @@
+Program easter;
+
+{
+    easter v1.0
+    © 1995 by Andreas Tetzl
+    FREEWARE
+
+    
+    This is a little program to calculate the date of
+    easter for years between 1583 and 2299.
+
+    Start it in a shell with the year as argument.
+
+}
+
+{
+    Translated to fpc pascal.
+    21 Mar 2001.
+
+    [email protected]
+}
+
+uses amigados;
+
+const version : pchar = '$VER: easter v1.0 (3-Nov-95) by Andreas Tetzl';
+
+VAR i,a,b,c,d,e,m,n : Integer;
+    year, month, day : longint;
+
+
+BEGIN
+
+  if (ParamStr(1) = '?') or (ParamStr(1) = '') then
+   BEGIN
+    Writeln('YEAR/N');
+    halt(20);
+   END;
+
+  i:=StrToLong(ParamStr(1),year);
+  if (year<1583) or (year>2299) then
+   BEGIN
+    Writeln('only years between 1583 and 2299 allowed');
+    halt(20);
+   END;
+
+  Case year of
+    1583..1699 : BEGIN m:=22; n:=2; END;
+    1700..1799 : BEGIN m:=23; n:=3; END;
+    1800..1899 : BEGIN m:=23; n:=4; END;
+    1900..2099 : BEGIN m:=24; n:=5; END;
+    2100..2199 : BEGIN m:=24; n:=6; END;
+    2200..2299 : BEGIN m:=25; n:=0; END;
+  end;
+
+  a:=year mod 19;
+  b:=year mod 4;
+  c:=year mod 7;
+  d:=(19*a+m) mod 30;
+  e:=(2*b+4*c+6*d+n) mod 7;
+
+  day:=22+d+e;
+  if day<=31 then
+   month:=3
+  else
+   BEGIN
+    month:=4;
+    day:=d+e-9;
+   END;
+
+  if (month=4) and (day=26) then day:=19;
+  if (month=4) and (day=25) and (d=28) and (e=6) and (a>10) then day:=18;
+
+  Write(year,'-');
+  if month=3 then Write('Mar') else Write('Apr');
+  Writeln('-',day);
+END.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+
+  

packages/extra/amunits/demos/easygadtools.pas

@@ -0,0 +1,188 @@
+PROGRAM EasyGadtools;
+{$mode objfpc}
+
+{
+    This is just a test on how to make a unit EasyGadtools.
+
+    Feel free to make any changes or improvements on this
+    example. If you make a unit or have a unit to handle
+    gadtools in an easy way let me know.
+    24 Jul 2000.
+
+    Changed to use systemvartags.
+    25 Nov 2002.
+    
+    [email protected]
+
+}
+
+USES Intuition, Exec, Graphics, GadTools, Utility, pastoc,systemvartags;
+
+CONST
+
+     strarray : array[0..4] of PChar = ('A cycle',
+                                        'test',
+                                        'for',
+                                        'FPC Pascal',
+                                        nil);
+
+
+VAR
+  ps                : pScreen;
+  vi                : Pointer;
+  ng                : tNewGadget;
+  glist,gad         : pGadget;
+  wp                : pWindow;
+  HFont             : word;
+  HGadget           : word;
+  DistGad           : word;
+  HG                : word;
+  attr              : pTextAttr;
+
+function NewGadget(left,top,width,height : Integer; txt : PChar; txtattr: pTextAttr;
+                   id : word; flags: Longint; visinfo, userdata : Pointer): tNewGadget;
+var
+    ng : tNewGadget;
+begin
+    with ng do begin
+        ng_LeftEdge   := left;
+        ng_TopEdge    := top;
+        ng_Width      := width;
+        ng_Height     := height;
+        ng_GadgetText := txt;
+        ng_TextAttr   := txtattr;
+        ng_GadgetID   := id;
+        ng_Flags      := flags;
+        ng_VisualInfo := visinfo;
+        ng_UserData   := userdata;
+    END;
+    NewGadget := ng;
+end;
+
+PROCEDURE CleanUp(why : string; rc : BYTE);
+BEGIN
+  IF assigned(wp) THEN CloseWindow(wp);
+  IF assigned(glist) THEN FreeGadgets(glist);
+  IF assigned(vi) THEN FreeVisualInfo(vi);
+  if why <> '' then writeln(why);
+  HALT(rc);
+END;
+
+{ Clones some datas from default pubscreen for fontsensitive
+  placing of gadgets. }
+PROCEDURE CloneDatas;
+BEGIN
+  ps := LockPubScreen(NIL);
+  IF ps = NIL THEN CleanUp('Can''t get a lock on public screen',20)
+  ELSE
+  BEGIN
+     HFont := ps^.Font^.ta_YSize;
+     attr := ps^.Font;
+     vi := GetVisualInfoA(ps,NIL);
+     UnLockPubScreen(NIL, ps);
+     IF vi = NIL THEN CleanUp('Can''t get VisualInfo', 20);
+  END;
+END;
+
+function ButtonGadget(id,left,top,width,height:word; txt:pchar): pGadget;
+begin
+   ng := NewGadget(left,top,width,height,txt,attr,id,PLACETEXT_IN,vi,nil);
+   gad := CreateGadgetA(BUTTON_KIND,gad,@ng,nil);
+   ButtonGadget := gad;
+end;
+
+function ButtonGadget(id,left,top,width,height:word; txt: string): pGadget;
+begin
+   ButtonGadget := ButtonGadget(id,left,top,width,height,pas2c(txt));
+end;
+
+function CycleGadget(id,left,top,width,height:word; txt:pchar ; thearr : Pointer): pGadget;
+begin
+   ng := NewGadget(left,top,width,height,txt,attr,id,PLACETEXT_LEFT,vi,nil);
+   gad := CreateGadget(CYCLE_KIND,gad,@ng,[
+                                         GTCY_Labels,thearr,
+                                         TAG_END]);
+   CycleGadget := gad;
+end;
+
+PROCEDURE GenerateWindow;
+BEGIN
+  glist := NIL; gad := CreateContext(addr(glist));
+  IF gad = NIL THEN CleanUp('Can''t create GadList', 20);
+
+  gad := ButtonGadget(0,10,HG,200,HGadget,'File Requester');
+  HG := HG + DistGad;
+
+  gad := ButtonGadget(1,10,HG,200,HGadget,'Font Requester');
+  HG := HG + DistGad;
+
+  gad := ButtonGadget(2,10,HG,200,HGadget,'Screen Requester');
+  HG := HG + DistGad + 3;
+
+  gad := CycleGadget(3,100,HG,100,HGadget,'Cycle me',@strarray);
+  HG := HG + DistGad+4;
+
+  gad := ButtonGadget(4,10,HG,96,HGadget,'OK');
+  gad := ButtonGadget(5,115,HG,96,HGadget,'Cancel');
+
+  HG := HG + 5;
+
+  if gad = nil then CleanUp('Can''t create gadgets',20);
+
+  wp := OpenWindowTags(NIL,[
+                WA_Gadgets, glist,
+                WA_Title, 'Test of EasyGadtools',
+                WA_Left,100,
+                WA_Top,100,
+                WA_Flags, WFLG_SMART_REFRESH OR WFLG_NOCAREREFRESH OR
+                                WFLG_DEPTHGADGET OR WFLG_DRAGBAR OR WFLG_CLOSEGADGET OR
+                                WFLG_ACTIVATE,
+                WA_Idcmp, IDCMP_GADGETUP OR IDCMP_CLOSEWINDOW,
+                WA_InnerWidth, 215,
+                WA_InnerHeight, HG,
+                TAG_DONE]);
+
+  IF wp = NIL THEN CleanUp('Can''t open window', 20);
+END;
+
+PROCEDURE MainWait;
+VAR
+  msg : pIntuiMessage;
+  iclass : LONG;
+  ende : BOOLEAN;
+BEGIN
+  ende := FALSE;
+  REPEAT
+    msg := pIntuiMessage(WaitPort(wp^.UserPort));
+     msg := GT_GetIMsg(wp^.UserPort);
+     WHILE msg <> NIL DO
+     BEGIN
+        iclass := msg^.IClass;
+        GT_ReplyIMsg(msg);
+        CASE iclass OF
+          IDCMP_CLOSEWINDOW : ende := TRUE;
+          IDCMP_GADGETUP : writeln('You clicked on a gadget');
+        ELSE END;
+       msg := GT_GetIMsg(wp^.UserPort);
+     END;
+  UNTIL ende;
+END;
+
+BEGIN
+  CloneDatas;
+  HGadget := HFont +6;
+  DistGad := HGadget +4;
+  HG := HFont + 10;
+  GenerateWindow;
+  MainWait;
+  CleanUp('',0);
+END.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+
+  

packages/extra/amunits/demos/getdate.pas

@@ -0,0 +1,144 @@
+Program GetDate;
+
+{ GetDate v1.0 1995 by Andreas Tetzl }
+{ Public Domain }
+
+{
+  Translated to fpc pascal
+  19 Mar 2001.
+
+  [email protected]
+}
+
+uses amigados, strings;
+
+const template : pchar = 'Format/K,Help/S';
+
+      version : pchar = '$VER: GetDate 1.0 (21.2.95)';
+
+VAR DS : tDateStamp;
+    DT : tDateTime;
+    rda : pRDArgs;
+    WeekDay, Date, Time, hours, mins, secs, day, month, year : pchar;
+    vec : Array[0..1] of longint;
+    i : longint;
+    LFormat : pchar;
+
+Procedure PrintFormat;
+VAR Str : string;
+    tmp : string;
+Begin
+ Str := strpas(LFormat);
+ tmp := '';
+ For i:=1 to length(Str) do
+  begin
+
+   If Str[i]='%' then
+    Begin
+     Case UpCase(Str[i+1]) of
+      ('D') : tmp := tmp + strpas(Date);
+      ('W') : tmp := tmp + strpas(WeekDay);
+      ('T') : tmp := tmp + strpas(Time);
+      ('H') : tmp := tmp + strpas(hours);
+      ('M') : tmp := tmp + strpas(Mins);
+      ('S') : tmp := tmp + strpas(Secs);
+      ('A') : tmp := tmp + strpas(Day);
+      ('O') : tmp := tmp + strpas(Month);
+      ('Y') : tmp := tmp + strpas(Year);
+     end;
+     i:=i+1;
+    end
+   else
+    tmp := tmp + Str[i];
+  end;
+ Writeln(tmp);
+end;
+
+Procedure Help;
+Begin
+ Writeln(#10'GetDate v1.0 1995 by Andreas Tetzl');
+ Writeln('Public Domain'#10);
+ Writeln('How to use the placeholders for Format:'#10);
+ Writeln(' %d : Datum');
+ Writeln(' %w : Weekday');
+ Writeln(' %t : Time with Hour, Minutes and Seconds');
+ Writeln(' %h : Hour');
+ Writeln(' %m : Minutes');
+ Writeln(' %s : Seconds');
+ Writeln(' %a : Day');
+ Writeln(' %o : Month');
+ Writeln(' %y : Year'#10);
+ Exit;
+end;
+
+begin
+ For i:=0 to 1 do Vec[i]:=0;
+
+ rda:=ReadArgs(Template,@vec,NIL);
+ If rda=NIL then
+  Begin
+   If PrintFault(IoErr,NIL) then;
+   halt(10);
+  end;
+
+ LFormat:=StrAlloc(100);
+
+ If StrComp(pointer(vec[0]),pchar('')) <> 0 then StrCopy(LFormat,pointer(vec[0])) else LFormat:=NIL;
+
+
+ If vec[1]<>0 then Help;
+
+ WeekDay:=StrAlloc(LEN_DATSTRING);
+ Date:=StrAlloc(LEN_DATSTRING);
+ Time:=StrAlloc(LEN_DATSTRING);
+ Hours:=StrAlloc(10);
+ Mins:=StrAlloc(10);
+ Secs:=StrAlloc(10);
+ Day:=StrAlloc(10);
+ Month:=StrAlloc(10);
+ Year:=StrAlloc(10);
+
+ DateStamp(pDateStamp(@DS));
+ DT.dat_Stamp:=DS;
+ DT.dat_Format:=Format_DOS;
+ DT.dat_StrDay:=WeekDay;
+ DT.dat_StrDate:=Date;
+ DT.dat_StrTime:=Time;
+ If DateToStr(@DT) then begin
+
+ StrlCopy(hours,Time,2);
+
+ StrlCopy(Mins,addr(Time[3]),2);
+ StrlCopy(Secs,addr(Time[6]),2);
+ StrlCopy(Day,Date,2);
+ StrlCopy(Month,addr(Date[3]),3);
+ StrlCopy(Year,addr(Date[7]),2);
+
+ { In den deutschen Locale-Strings von OS3.0 scheint ein Fehler zu sein. }
+ { Am Datums-String ist hinten noch ein Leerzeichen, also '16-Feb-95 '.  }
+ { Hier wird geprüft, ob das letzte Zeichen ein Leerzeichen ist.         }
+ { Das Leerzeichen wird dann durch '\0' (Stringende) ersetzt.            }
+ If Date[StrLen(Date)-1]=' ' then Date[StrLen(Date)-1]:=#0;
+end;
+ If LFormat=NIL then
+  Writeln(WeekDay,' ',Date,' ',Time)
+ else 
+  PrintFormat;
+
+ StrDispose(LFormat);
+ StrDispose(WeekDay);
+ StrDispose(date);
+ StrDispose(Time);
+ StrDispose(hours);
+ StrDispose(mins);
+ StrDispose(secs);
+ StrDispose(Day);
+ StrDispose(Month);
+ StrDispose(Year);
+end.
+
+{
+  $Log
+}
+
+  

packages/extra/amunits/demos/getfontasl.pas

@@ -0,0 +1,41 @@
+PROGRAM GetFontAsltest;
+
+uses easyasl,msgbox,amigautils;
+
+{
+   An example to get a font with easyasl.
+   24 Jan 2000.
+
+   [email protected]
+}
+
+VAR
+    myfont : tFPCFontInfo;
+    dummy  : BOOLEAN;
+
+
+BEGIN
+
+    dummy := GetFontAsl('Pick a font',myfont,NIL);
+    IF dummy THEN BEGIN
+       MessageBox('FPC Pascal Request',
+                  'You picked as font   :' + myfont.nfi_Name + #10 +
+                  'The fontsize is      :' + longtostr(myfont.nfi_Size) + #10 +
+                  'The fontstyle is     :' + longtostr(myfont.nfi_Style) + #10 +
+                  'The flags are set to :' + longtostr(myfont.nfi_Flags) + #10 +
+                  'Frontpen is number   :' + longtostr(myfont.nfi_FrontPen) + #10 +
+                  'And as the backpen   :' + longtostr(myfont.nfi_BackPen) + #10 +
+                  'And finally drawmode :' + longtostr(myfont.nfi_DrawMode),
+                  'Nice font!');
+    END ELSE
+       MessageBox('FPC Pascal request','You didn''t pick a font','Why not?');
+END.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+
+  

packages/extra/amunits/demos/getmultifiles.pas

@@ -0,0 +1,57 @@
+program asltest;
+
+uses exec,easyasl, linklist, strings, amigautils;
+
+{
+   How to get more files than one with easyasl.
+   Just remeber that you have to use linklist and
+   not an ordinary list.
+
+   24 Jan 2000.
+
+   [email protected]
+}
+
+VAR
+
+  pdummy   : array [0..108] of char;
+
+  path     : PChar;
+  dummy    : boolean;
+  mylist   : pList;
+  mynode   : pFPCNode;
+  temp     : Longint;
+
+begin
+
+  path := @pdummy;
+  CreateList(mylist);
+  StrpCopy(path,'sys:');
+  dummy := GetMultiAsl('test of getmulti',path,mylist,nil,nil);
+  If dummy then begin
+      writeln;
+      writeln('Number of files picked ',NodesInList(mylist));
+      writeln('And the winner are:');
+      PrintList(mylist);
+      writeln(chr(10) + 'Press Return' + chr(10));
+      readln;
+
+      writeln('And now path plus file');
+      mynode := GetFirstNode(mylist);
+      FOR temp := 1 TO NodesInList(mylist) DO BEGIN
+         writeln(PathAndFile(path,GetNodeData(mynode)));
+         mynode := GetNextNode(mynode);
+      END;
+  end else writeln('You didn''t pick any files');
+  DestroyList(mylist);
+END.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+
+  
+

packages/extra/amunits/demos/listtest.pas

@@ -0,0 +1,150 @@
+PROGRAM test;
+
+{
+    A small test of linklist unit.
+
+    [email protected]
+}
+
+uses
+{$ifdef Amiga}
+    exec,
+{$endif}
+    linklist, strings;
+
+    VAR
+
+    Mylist   : pList;
+    MyNode   : pFPCNode;
+    i        : Longint;
+    temp     : Longint;
+    buffer   : PChar;
+    bufsize  : Longint;
+    templist : pList;
+
+
+BEGIN
+    CreateList(Mylist);
+
+    AddNewNode(Mylist,'Monday');
+    AddNewNode(Mylist,'Tuesday');
+    AddNewNode(Mylist,'Wednesday');
+    AddNewNode(Mylist,'Thursday');
+    AddNewNode(Mylist,'Friday');
+    AddNewNode(Mylist,'Saterday');
+    AddNewNode(Mylist,'Sunday');
+
+    writeln;
+    WriteLN('This is the list');
+    PrintList(Mylist);
+
+    writeln;
+    WriteLN('Now we are going to remove the last node');
+    WriteLN('>> Press return');
+    readln;
+    RemoveLastNode(Mylist);
+    PrintList(Mylist);
+    writeln;
+
+    WriteLN('>> Press return to get the size of the list');
+    writeln;
+    readln;
+    WriteLN('The size of allocated list is ', SizeOfList(Mylist));
+    writeln;
+
+    writeln('Now we are going to print all strings' +#10+ 'in the list with the internal commands');
+    WriteLN('>> Press return');
+    readln;
+
+    i := NodesInList(Mylist);
+    MyNode := GetFirstNode(Mylist);
+    FOR temp := 1 TO i DO BEGIN
+        WriteLN(MyNode^.ln_Name);
+        MyNode := GetNextNode(MyNode);
+    END;
+
+    writeln;
+    WriteLN('We will move the last node to the top');
+    WriteLN('>> Press return');
+    readln;
+    MyNode := GetLastNode(Mylist);
+    MoveNodeTop(Mylist,MyNode);
+    PrintList(Mylist);
+    writeln;
+
+    WriteLN('We shall change the value in one node');
+    WriteLN('>> Press return');
+    readln;
+    MyNode := GetFirstNode(Mylist);
+    MyNode := GetNextNode(MyNode);
+    UpDateNode(MyNode,'This is the new day');
+    PrintList(Mylist);
+    writeln;
+
+    MyNode := GetNextNode(MyNode);
+    WriteLN('Now we delete one node');
+    WriteLN('>> Press return');
+    readln;
+    WriteLN('This node is going to be deleted ',GetNodeData(MyNode));
+    DeleteNode(MyNode);
+    PrintList(Mylist);
+
+    writeln;
+    WriteLN('Sort the list');
+    WriteLN('>> Press return');
+    readln;
+    SortList(Mylist);
+    PrintList(Mylist);
+
+    writeln;
+    writeln('Search for a node, in this case Friday');
+    WriteLN('>> Press return');
+    readln;
+    MyNode := FindNodeData(Mylist,'Friday');
+    IF MyNode <> NIL THEN BEGIN
+        WriteLN('found the node ',MyNode^.ln_Name);
+        { or writeln('found the node ',GetNodeData(MyNode));  }
+    END ELSE BEGIN
+        WriteLN('Node not found');
+    END;
+
+    writeln;
+    WriteLN('And now copy the list to a stringbuffer' +#10+ 'and print it');
+    WriteLN('>> Press return');
+    readln;
+    bufsize := SizeOfList(Mylist);
+    buffer := StrAlloc(bufsize);
+    ListToBuffer(Mylist,buffer);
+    WriteLN(buffer);
+
+    writeln;
+    WriteLN('Now we try to copy the list to a new list');
+    WriteLN('>> Press return');
+    readln;
+    templist := CopyList(Mylist);
+    IF templist <> NIL THEN BEGIN
+        WriteLN('That went well, the new list is here');
+        PrintList(templist);
+        DestroyList(templist);
+    END ELSE BEGIN
+        WriteLN('no copy of list');
+    END;
+
+    writeln;
+    WriteLN('Press return to destroy the list');
+    readln;
+    DestroyList(Mylist);
+    writeln;
+    WriteLN('All done');
+END.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:26  nils
+    * initial release
+
+}
+
+  
+
+

packages/extra/amunits/demos/penshare.pas

@@ -0,0 +1,115 @@
+Program PenShare;
+{$mode objfpc}
+
+{ Dieses Programm demonstriert die ObtainPen Funktion der graphics.lib V39+
+
+  Ab OS3.0 gibt es sogenanntes Pen Sharing. Das bedeutet, daß sich
+  verschiedene Programme die Farben der Workbench teilen. Zum Beispiel
+  können Sie mit Multiview 2 Bilder mit 256 auf der Workbench anzeigen,
+  wobei beide noch relativ gut aussehen.
+
+  Mit der Funktion ObtainPen können Sie sich ein Farbregister mit einem
+  ganz bestimmten Farbwert reservieren lassen.
+
+  Es gibt noch eine zweite Funktion namens ObtainBestPen (Multiview
+  benutzt diese Fkt.). Mit ihr werden die Farbwerte nicht 100%ig exakt
+  behandelt. So wird z.B. zwei leicht unterschiedlichen Rottönen dasselbe
+  Farbregister zugeordnet.
+
+
+  Autor: Andreas Tetzl
+  Datum: 22.12.1994
+}
+
+{
+  Translated to fpc pascal
+  20 Mar 2001.
+
+  Reworked to use systemvartags.
+  Text to GText.
+  28 Nov 2002.
+
+  [email protected]
+}
+
+uses exec, graphics, intuition, utility,systemvartags;
+
+VAR RP : pRastPort;
+    Win : pWindow;
+    Colors : Array[0..2] of longint;
+    Msg : pMessage;
+    VP : pViewPort;
+    i : Integer;
+
+
+PROCEDURE CleanExit(Why : String; RC : longint);
+Begin
+ For i:=0 to 2 do
+  If Colors[i]<>-1 then ReleasePen(VP^.ColorMap,Colors[i]);
+
+ If Win<>NIL then CloseWindow(Win);
+ If Why<>'' then Writeln(Why);
+ halt(RC);
+end;
+
+Begin
+ For i:=0 to 2 do Colors[i]:=-1; { Farbwerte vorbelegen (wegen CleanExit()) }
+
+
+  Win:=OpenWindowTags(nil,[WA_Width,150,
+                        WA_Height,100,
+                        WA_Title,'PenShare',
+                        WA_Flags,WFLG_CLOSEGADGET+WFLG_DRAGBAR,
+                        WA_IDCMP,IDCMP_CLOSEWINDOW,
+                        TAG_END]);
+
+
+
+ If Win=NIL then CleanExit('Can''t open window',10);
+ VP:=ViewPortAddress(Win);
+ RP:=Win^.RPort;
+
+ { Für n geben Sie die gewünschte Farbregisternummer }
+ { an (-1, wenn es Ihnen egal ist).                  }
+ { Die folgenden drei RGB-Werte müssen die ganzen    }
+ { 32 Bit ausnutzen. Wenn Sie z.B. für Rot den Wert  }
+ { $F0 setzen wollen, müssen Sie in r den Wert       }
+ { $F0F0F0F0 einsetzen !                             }
+ { Wenn Sie die Farbe später verändern               }
+ { (z.B. ColorCycling), müssen Sie im Flags          }
+ { Parameter PENF_EXCLUSIVE setzen !                 }
+ { (siehe Include:graphics/View.i                    }
+
+ Colors[0]:=ObtainPen(VP^.ColorMap,-1,$FFFFFFFF,0,0,0); { Rot  }
+ Colors[1]:=ObtainPen(VP^.ColorMap,-1,0,$FFFFFFFF,0,0); { Grün }
+ Colors[2]:=ObtainPen(VP^.ColorMap,-1,0,0,$FFFFFFFF,0); { Blau }
+ If (Colors[0]=-1) or (Colors[1]=-1) or (Colors[1]=-1) then
+  CleanExit('Please set more colors for Workbench.',10);
+
+ SetAPen(RP,Colors[0]);
+ Move(RP,40,40);
+ GText(RP,'Red',3);
+
+ SetAPen(RP,Colors[1]);
+ Move(RP,40,60);
+ GText(RP,'Green',5);
+
+ SetAPen(RP,Colors[2]);
+ Move(RP,40,80);
+ GText(RP,'Blue',4);
+
+ Msg:=WaitPort(Win^.UserPort);
+ Msg:=GetMsg(Win^.UserPort);
+ ReplyMsg(Msg);
+
+ CleanExit('',0);
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:27  nils
+    * initial release
+
+}
+
+

packages/extra/amunits/demos/showdevs.pas

@@ -0,0 +1,128 @@
+program ShowDevs;
+
+{
+
+  Programm       : Devices  - listet angemeldet Devices auf
+  Sprache        : PCQ-Pascal 1.2b nach einem kleinen Hack von
+                   mir in MCC-Pascal V2.04
+  Autor          : Andreas Neumann für Purity
+  Datum          : 01.03.1992
+
+}
+
+{
+
+  Translated to fpc pascal
+  24 Mar 2001.
+
+  [email protected]
+
+}
+
+
+uses exec,amigados;
+
+CONST   Device_Types : Array [0..2] OF pchar = (('DEVICE     '),
+                                                 ('DIRECTORY  '),
+                                                 ('VOLUME     '));
+
+VAR
+    mydosbase    : pDOSLibrary;
+    myrootptr    : pRootNode;
+    myinfoptr    : pDosInfo;
+    mydeviceptr  : pDeviceNode;
+    mystr        : pchar;
+    eingabe      : CHAR;
+    mystartup    : pFileSysStartupMsg;
+    myenvec      : pDOSEnvec;
+    i            : longint;
+
+BEGIN
+ WRITELN;
+ WRITELN ('Device-Lister PD © 1992 by Andreas Neumann (NEUDELSoft) für Purity');
+
+ mydosbase:= pDOSLibrary(_DosBase);
+
+ { Man braucht ja die Adresse der DOSLibrary                      }
+
+ myrootptr:=mydosbase^.dl_Root;
+ myinfoptr:=BADDR(myrootptr^.rn_Info);
+ mydeviceptr:=BADDR(myinfoptr^.di_DevInfo);
+
+ { Man hangelt sich von Struktur zu Struktur                      }
+
+ WHILE mydeviceptr<>NIL DO
+ BEGIN
+  WITH mydeviceptr^ DO
+  BEGIN
+   WRITELN;
+
+   {mystr:=Address(Integer(BPTRtoAPTR(dn_Name))+1);}
+   mystr:=pointer(longint(BADDR(dn_Name))+1);
+
+   { Trick : dn_Name ist ein BSTR. Dies ist ein BPTR auf ein Feld, das }
+   {         mit der Anzahl der Stringzeichen beginnt (daher +1) und   }
+   {         dann die Zeichen enthält.                                 }
+
+   WRITELN ('Name        : ',mystr,':');
+   WRITELN ('Type        : ',Device_Types[dn_Type]);
+   IF NOT (dn_Lock=0) THEN
+    WRITELN ('there is a lock on this Device')
+   ELSE
+    WRITELN;
+   WRITELN;
+
+   mystartup:=BADDR(dn_Startup);
+   myenvec:=BADDR(mystartup^.fssm_Environ);
+
+   IF (NOT(dn_Startup=0)) AND (dn_Type=DLT_DEVICE) AND (myenvec^.de_SizeBlock>0) THEN
+   BEGIN
+
+    {          es ist ein dateiorientiertes Device !!!             }
+    {  im Gegensatz hierzu : ein logisches Device wie L: oder S:   }
+
+    WRITELN ('More information regarding the Organisation of Devices: ');
+    WITH myenvec^ DO
+    BEGIN
+     WRITELN;
+     WRITELN ('Size of the sectors        : ',de_SizeBlock*4,' Bytes');
+     WRITELN ('Number of sectors per Block: ',de_SectorPerBlock);
+     WRITELN ('Blocks per Track           : ',de_BlocksPerTrack);
+     WRITELN ('Startcylinder              : ',de_LowCyl);
+     WRITELN ('Endcylinder                : ',de_HighCyl);
+     WRITELN ('Surfaces                   : ',de_Surfaces);
+
+     i:=(de_HighCyl+1-de_LowCyl)*(de_Surfaces)*
+         (de_BlocksPerTrack)*(de_SectorPerBlock)*(de_SizeBlock*4);
+
+     { Anzahl der Zylinder * Anzahl der Oberflächen * Anzahl der Blöcke
+        pro Spur * Anzahl der Sektoren pro Block * Größe eines
+        Blockes * 4                                                     }
+
+     WRITELN ('Storage capacity  : ',i,' Bytes    = ',i DIV 1024,' KBytes');
+    END;
+    WRITELN;
+    writeln('The exec unit number is ',mystartup^.fssm_Unit);
+   END;
+  END;
+
+  WRITELN ('(M)ore oder (S)top ?');
+  READLN (eingabe);
+
+  mydeviceptr:=BADDR(mydeviceptr^.dn_Next);
+  IF (UpCase(eingabe)='S') THEN mydeviceptr:=NIL;
+ END;
+
+ WRITELN ('Good Bye. NEUDELSoft wünscht noch viel Spaß mit Amiga und Pascal.');
+
+END.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:27  nils
+    * initial release
+
+}
+
+  
+

packages/extra/amunits/demos/simple_timer.pas

@@ -0,0 +1,220 @@
+program simpletimer;
+
+
+uses exec, timer, amigados, amigalib;
+
+
+
+{ manifest constants -- 'never will change' }
+const  
+     SECSPERMIN   = (60);
+     SECSPERHOUR  = (60*60);
+     SECSPERDAY   = (60*60*24);
+
+var
+     seconds : longint;
+     tr      : ptimerequest;      { IO block for timer commands }
+     oldtimeval : ttimeval;   { timevals to store times     }
+     mytimeval  : ttimeval;
+     currentval : ttimeval;
+
+Function Create_Timer(theUnit : longint) : pTimeRequest;
+var
+    Error : longint;
+    TimerPort : pMsgPort;
+    TimeReq : pTimeRequest;
+begin
+    TimerPort := CreatePort(Nil, 0);
+    if TimerPort = Nil then 
+	Create_Timer := Nil;
+    TimeReq := pTimeRequest(CreateExtIO(TimerPort,sizeof(tTimeRequest)));
+    if TimeReq = Nil then begin
+	DeletePort(TimerPort);
+	Create_Timer := Nil;
+    end; 
+    Error := OpenDevice(TIMERNAME, theUnit, pIORequest(TimeReq), 0);
+    if Error <> 0 then begin
+	DeleteExtIO(pIORequest(TimeReq));
+	DeletePort(TimerPort);
+	Create_Timer := Nil;
+    end;
+    TimerBase := pointer(TimeReq^.tr_Node.io_Device); 
+    Create_Timer := pTimeRequest(TimeReq);
+end;
+
+Procedure Delete_Timer(WhichTimer : pTimeRequest);
+var
+    WhichPort : pMsgPort;
+begin
+    
+    WhichPort := WhichTimer^.tr_Node.io_Message.mn_ReplyPort;
+    if assigned(WhichTimer) then begin
+        CloseDevice(pIORequest(WhichTimer));
+        DeleteExtIO(pIORequest(WhichTimer));
+    end;
+    if assigned(WhichPort) then
+        DeletePort(WhichPort);
+end;
+
+procedure wait_for_timer(tr : ptimerequest; tv : ptimeval);
+begin
+    tr^.tr_node.io_Command := TR_ADDREQUEST; { add a new timer request }
+
+    { structure assignment }
+    tr^.tr_time.tv_secs := tv^.tv_secs;
+    tr^.tr_time.tv_micro := tv^.tv_micro;
+
+    { post request to the timer -- will go to sleep till done }
+    DoIO(pIORequest(tr));
+end;
+
+{ more precise timer than AmigaDOS Delay() }
+function time_delay(tv : ptimeval; theunit : longint): longint;
+var
+    tr : ptimerequest;
+begin
+    { get a pointer to an initialized timer request block }
+    tr := create_timer(theunit);
+
+    { any nonzero return says timedelay routine didn't work. }
+    if tr = NIL then time_delay := -1;
+
+    wait_for_timer(tr, tv);
+
+    { deallocate temporary structures }
+    delete_timer(tr);
+    time_delay := 0;
+end;
+
+function set_new_time(secs : longint): longint;
+var
+    tr : ptimerequest;
+begin
+    tr := create_timer(UNIT_MICROHZ);
+
+    { non zero return says error }
+    if tr = nil then set_new_time := -1;
+  
+    tr^.tr_time.tv_secs := secs;
+    tr^.tr_time.tv_micro := 0;
+    tr^.tr_node.io_Command := TR_SETSYSTIME;
+    DoIO(pIORequest(tr));
+
+    delete_timer(tr);
+    set_new_time := 0;
+end;
+
+function get_sys_time(tv : ptimeval): longint;
+var
+    tr : ptimerequest;
+begin
+    tr := create_timer( UNIT_MICROHZ );
+
+    { non zero return says error }
+    if tr = nil then get_sys_time := -1;
+
+    tr^.tr_node.io_Command := TR_GETSYSTIME;
+    DoIO(pIORequest(tr));
+
+   { structure assignment }
+   tv^ := tr^.tr_time;
+
+   delete_timer(tr);
+   get_sys_time := 0;
+end;
+
+
+
+
+procedure show_time(secs : longint);
+var
+   days,hrs,mins : longint;
+begin
+   { Compute days, hours, etc. }
+   mins := secs div 60;
+   hrs := mins div 60;
+   days := hrs div 24;
+   secs := secs  mod 60;
+   mins := mins mod 60;
+   hrs := hrs mod 24;
+
+   { Display the time }
+   writeln('*   Hour Minute Second  (Days since Jan.1,1978)');
+   writeln('*   ', hrs, ':   ',mins,':   ', secs,'       (  ',days, ' )');
+   writeln;
+end;
+
+
+begin
+   writeln('Timer test');
+
+   { sleep for two seconds }
+   currentval.tv_secs := 2;
+   currentval.tv_micro := 0;
+   time_delay(@currentval, UNIT_VBLANK);
+   writeln('After 2 seconds delay');
+
+   { sleep for four seconds }
+   currentval.tv_secs := 4;
+   currentval.tv_micro := 0;
+   time_delay(@currentval, UNIT_VBLANK);
+   writeln('After 4 seconds delay');
+
+   { sleep for 500,000 micro-seconds = 1/2 second }
+   currentval.tv_secs := 0;
+   currentval.tv_micro := 500000;
+   time_delay(@currentval, UNIT_MICROHZ);
+   writeln('After 1/2 second delay');
+
+   writeln('DOS Date command shows: ');
+   Execute('date', 0, 0);
+
+   { save what system thinks is the time....we'll advance it temporarily }
+   get_sys_time(@oldtimeval);
+   writeln('Original system time is:');
+   show_time(oldtimeval.tv_secs );
+
+   writeln('Setting a new system time');
+
+   seconds := 1000 * SECSPERDAY + oldtimeval.tv_secs;
+
+   set_new_time( seconds );
+   { (if user executes the AmigaDOS DATE command now, he will}
+   { see that the time has advanced something over 1000 days }
+
+   write('DOS Date command now shows: ');
+   Execute('date', 0, 0);
+
+   get_sys_time(@mytimeval);
+   writeln('Current system time is:');
+   show_time(mytimeval.tv_secs);
+
+   { Added the microseconds part to show that time keeps }
+   { increasing even though you ask many times in a row  }
+
+   writeln('Now do three TR_GETSYSTIMEs in a row (notice how the microseconds increase)');
+   writeln;
+   get_sys_time(@mytimeval);
+   writeln('First TR_GETSYSTIME      ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
+   get_sys_time(@mytimeval);
+   writeln('Second TR_GETSYSTIME     ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
+   get_sys_time(@mytimeval);
+   writeln('Third TR_GETSYSTIME      ',mytimeval.tv_secs,'.', mytimeval.tv_micro);
+   writeln;
+   writeln('Resetting to former time');
+   set_new_time(oldtimeval.tv_secs);
+
+   get_sys_time(@mytimeval);
+   writeln('Current system time is:');
+   show_time(mytimeval.tv_secs);
+
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:27  nils
+    * initial release
+
+}
+
+  

packages/extra/amunits/demos/snow.pas

@@ -0,0 +1,186 @@
+Program Snowflake;
+{$mode objfpc}
+{ This program draws a fractal snowflake pattern.  I think I got it out
+of some magazine years ago.  It was written, as I remember it, for the
+PC in BASIC, which I converted to AmigaBASIC.  I have long since
+forgotten the details of how it worked, so I could not give the
+variables meaningful names.  To the original author, by the way, goes
+the credit for those names.  Invoke the program with the line "Snow
+<level>", where <level> is a digit between 1 and 6.  In order to get a
+feel for what's going on, try running the levels in order.  Level 6
+takes a long time, and frankly doesn't look as good as level 5.  }
+
+{
+   Translated to fpc pascal from pcq pascal.
+   Updated the source to the new style. Will
+   now also open a screen.
+   04 Apr 2001.
+
+   Reworked to use systemvartags.
+   28 Nov 2002.
+
+   [email protected]
+}
+
+
+uses exec,intuition,graphics,utility,systemvartags;
+
+
+
+var
+    dx : array [0..11] of real;
+    dy : array [0..11] of real;
+    sd : array [0..6] of Longint;
+    rd : array [0..6] of Longint;
+    sn : array [0..6] of Longint;
+    ln : array [0..6] of real;
+    a  : real;
+    nc : Longint;
+    x, y, t : real;
+    w  : pWindow;
+    s  : pScreen;
+    rp : pRastPort;
+    n  : Longint;
+    d, ns, i, j : Longint;
+    l : real;
+    m : pMessage;
+
+const
+     pens : array [0..0] of integer = (not 0);
+
+Procedure usage;
+begin
+    writeln('Usage: Snow <level>');
+    writeln('       where <level> is between 1 and 6');
+    halt(20);
+end;
+
+procedure CleanUp(why : string; err : longint);
+begin
+    if assigned(w) then CloseWindow(w);
+    if assigned(s) then CloseScreen(s);
+    if why <> '' then writeln(why);
+    halt(err);
+end;
+
+Function readcycles: Longint;
+var
+    cycles : Longint;
+begin
+    if paramcount <> 1 then usage;
+    cycles := ord(paramstr(1)[1]) - ord('0');
+    if (cycles > 6) or (cycles < 1) then
+	usage;
+    readcycles := cycles;
+end;
+
+
+procedure initarrays;
+begin
+    sd[0] := 0;
+    rd[0] := 0;
+    sd[1] := 1;
+    rd[1] := 0;
+    sd[2] := 1;
+    rd[2] := 7;
+    sd[3] := 0;
+    rd[3] := 10;
+    sd[4] := 0;
+    rd[4] := 0;
+    sd[5] := 0;
+    rd[5] := 2;
+    sd[6] := 1;
+    rd[6] := 2;
+
+    for n := 0 to 6 do
+	ln[n] := 1.0 / 3.0;
+    ln[2] := sqrt(ln[1]);
+    a := 0.0;
+    for n := 6 to 11 do begin
+	dy[n] := sin(a);
+	dx[n] := cos(a);
+        a := a + 0.52359;
+    end;
+    for n := 0 to 5 do begin
+	dx[n] := -(dx[n + 6]);
+	dy[n] := -(dy[n + 6]);
+    end;
+    x := 534.0;
+    y := 151.0;
+    t := 324.0;
+end;
+
+begin
+    nc := readcycles();
+    initarrays;
+
+    s := OpenScreenTags(nil, [SA_Pens,   @pens,
+      SA_Depth,     2,
+      SA_DisplayID, HIRES_KEY,
+      SA_Title,     'Simple Fractal SnowFlakes',
+      TAG_END]);
+    
+    if s = NIL then CleanUp('No screen',20);
+
+      w := OpenWindowTags(nil, [
+         WA_IDCMP,        IDCMP_CLOSEWINDOW,
+         WA_Left,         0,
+         WA_Top,          s^.BarHeight +1,
+         WA_Width,        s^.Width,
+         WA_Height,       s^.Height - (s^.BarHeight + 1),
+         WA_DepthGadget,  ltrue,
+         WA_DragBar,      ltrue,
+         WA_CloseGadget,  ltrue,
+         WA_ReportMouse,  ltrue,
+         WA_SmartRefresh, ltrue,
+         WA_Activate,     ltrue,
+         WA_Title,        'Close the Window to Quit',
+         WA_CustomScreen, s,
+         TAG_END]);
+
+    if w = nil then CleanUp('No window',20);
+
+	rp := w^.RPort;
+        SetAPen(rp,2);
+	for n := 0 to nc do
+	    sn[n] := 0;
+
+	Move(rp, trunc(x), trunc(y));
+
+	repeat
+	    d := 0;
+	    l := t;
+	    ns := 0;
+
+	    for n := 1 to nc do begin
+		i := sn[n];
+		l := l * ln[i];
+		j := sn[n - 1];
+		ns := ns + sd[j];
+		if odd(ns) then
+		    d := (d + 12 - rd[i]) mod 12
+		else
+		    d := (d + rd[i]) mod 12;
+	    end;
+
+	    x := x + 1.33 * l * dx[d];
+	    y := y - 0.5 * l * dy[d];
+
+	    Draw(rp, trunc(x), trunc(y));
+	    sn[nc] := sn[nc] + 1;
+	    n := nc;
+	    while (n >= 1) and (sn[n] = 7) do begin
+		sn[n] := 0;
+		sn[n - 1] := sn[n - 1] + 1;
+		n := n - 1;
+	    end;
+	until sn[0] <> 0;
+	m := WaitPort(w^.UserPort);
+	forbid;
+	repeat
+	    m := GetMsg(w^.UserPort);
+	until m = nil;
+	permit;
+        CleanUp('',0);
+  
+end.

packages/extra/amunits/demos/wbtest.pas

@@ -0,0 +1,64 @@
+program wbtest;
+
+{
+
+     Try to start the program from both cli and wb.
+     If from wb then click also on the icons, arg1.info,
+     arg2.info and arg3.info.
+     11 Nov 2000.
+
+     Changed to use MessagBox, to show the workbench
+     args create an icon for wbtest.
+     28 Nov 2002.
+
+     [email protected]
+}
+
+uses wbargs, msgbox;
+
+var
+   i : integer;
+   dummy : string;
+   
+
+Function IntToStr (I : Longint) : String;
+Var
+    S : String;
+begin
+    Str (I,S);
+    IntToStr:=S;
+end;
+
+
+begin
+  if not isconsole then begin
+       dummy := 'started from wb' +#10;
+       dummy := dummy + 'The Programs name is: ' + ProgramName +#10;
+       dummy := dummy + 'Number of args are: ' + inttostr(WBArgCount) +#10;
+       if WBArgCount > 0 then begin
+          dummy := dummy + 'And the args are:' +#10;
+          for i := 1 to WBArgCount do dummy := dummy + 'Arg number ' + inttostr(i) +
+	                ' is: ' + GetWBArg(i) +#10;
+       end;
+       dummy := dummy + 'The programs name with GetWBArg(0) is: ' + GetWBArg(0);
+       MessageBox('FPC WorkBench', dummy, 'Nice');
+   end else begin
+       writeln('started fromcli');
+       writeln('The program name is: ',ProgramName);
+       writeln('Number of args are: ',ParamCount);
+       if ParamCount > 0 then begin
+          writeln('And the args are:');
+          for i := 1 to ParamCount do writeln('Arg number ',i,' is: ',ParamStr(i));
+       end;
+       writeln('The programs name with ParamStr(0) is: ',ParamStr(0));
+   end;
+end.
+
+{
+  $Log$
+  Revision 1.1  2002-11-28 19:42:27  nils
+    * initial release
+
+}
+
+