MODULE BobDemo;  

FROM SYSTEM IMPORT WORD,LONGWORD,ADDRESS,TSIZE,BYTE,ADR, SETREG,INLINE;
FROM Memory IMPORT MemReqSet, MemChip, MemFast, MemPublic,MemClear,AllocMem,
		   FreeMem;
FROM AmigaDOS IMPORT Lock, UnLock, Examine, FileLock, FileInfoBlock,
		     ModeOldFile,FileInfoBlockPtr, FileHandle, Open,
		     Read, Close;
FROM Intuition IMPORT Window, WindowPtr, ScreenPtr,MenuPtr, NewScreenPtr,  
		      NewScreen, Screen, ScreenFlags, ScreenFlagsSet, 
		      OpenScreen,WindowFlags, WindowFlagsSet, IDCMPFlags,
		      IDCMPFlagsSet,SetMenuStrip, CloseWindow, CloseScreen,
		      DisplayBeep;
FROM Drawing IMPORT Draw, Move, SetAPen;
FROM Gels IMPORT VSpriteFlags, VSpriteFlagsSet, BobFlags, BobFlagsSet,
		 VUserStuff, BUserStuff, AUserStuff, VSpritePtr, BobPtr,
		 DBufPacketPtr, GelsInfoPtr, VSprite, Bob, DBufPacket,
		 GelsInfo,BoundaryColMask,TopHit, BottomHit, LeftHit, RightHit, 
		 BoundaryColProc, GelColProc, AddBob, AddVSprite,
		 DoCollision, DrawGList, InitMasks, InitGels, RemBob, RemIBob,
		 RemVSprite, SetCollision, SortGList, collTable,
		 collTablePtr;
		 
FROM Rasters IMPORT RastPortPtr, RastPort;
FROM Views IMPORT ViewModes, ViewModesSet, ViewPortPtr, ViewPort, 
		  LoadRGB4, WaitBOVP;
FROM CIAHardware IMPORT ciaa,CIABITS,CIAGamePort0;

CONST	
	ChipMemSet = MemReqSet{MemClear,MemChip,MemPublic}; (* My ChipMemSet *)
	FastMemSet = MemReqSet{MemClear,MemFast,MemPublic}; (* My FastMemSet *)
	AnyMemSet = MemReqSet{MemClear,MemPublic}; (* Follow the Standards *)
	MyScreenViewSet = ViewModesSet{GenLockVideo,Sprites}; (* My ViewSet *)
	MyScreenFlags = ScreenFlagsSet{ScreenQuiet};
	MyBobFlags = BobFlagsSet{};
	MyVSprFlags = VSpriteFlagsSet{SaveBack,Overlay};

VAR

	XB,YB,
	MoverX,MoverY: INTEGER;

	NextLines,
	LastColors:	ARRAY [0..7] OF CARDINAL;

	MyColls:	BoundaryColProc;

	HeadPtr,
	TailPtr:	VSpritePtr;
	GelsPtr:	GelsInfoPtr;
	CollPtr:	collTablePtr;
	
	MyNewScreenPtr: NewScreenPtr; (* Pointer to NewScreenStructure *)
	MyScreen: 	ScreenPtr;    (* Pointer to ScreenStructure *)	
	MyRastPort:	RastPortPtr;  (* Pointer to RastPort of Screen *)
	MyViewPort:	ViewPortPtr;  (* Pointer to ViewPort of Screen *)
	
	IsGelsInfo,
	IsScreen,
	IsMemScreen:	BOOLEAN;      (* Flag for Screen opened succesfully *)

TYPE

	ObjectPtr = POINTER TO Object;
	Object = RECORD
			Name: 		ARRAY [0..7] OF CHAR;
			Bitplanes:	WORD;
			ImgOff:		INTEGER;
			KollOff:	INTEGER;
			XOff:		INTEGER;
			YOff:		INTEGER;
			Breite1:	INTEGER;
			Breite2:	INTEGER;
			Hoehe:		INTEGER;
			MskOff:		WORD;
		 END;

	MyStuffPtr = POINTER TO MyStuff;
	MyStuff	= RECORD
			MyID:		CARDINAL;
			MainMemAdr:	ObjectPtr;
			MainMemL:	LONGINT;
			BStructMemAdr:	BobPtr;
			VStructMemAdr:	VSpritePtr;
			BackMemAdr:	ADDRESS;
			BackMemLen:	INTEGER;
			BorderMemAdr:	ADDRESS;
			BorderLength:	INTEGER;
			Dummy:		CARDINAL;
		  END;
			
(* ========================================================================= *)	
PROCEDURE MakeMyScreen();

BEGIN
	
   MyNewScreenPtr:=AllocMem(SIZE(NewScreen),AnyMemSet);
	IF (MyNewScreenPtr # NIL) THEN
	   IsMemScreen := TRUE;
		WITH MyNewScreenPtr^ DO
			LeftEdge  := 0;    (* Linke obere Ecke des Screens *)
			TopEdge   := 0;
			Width	  := 320;  (* 320 Pixel Breite *)
			Height	  := 256;  (* It is a PAL-Screen *)
			Depth	  := 5;	  (* 5 Planes = 32 Colors *)
			DetailPen := BYTE(1);	  (* ForeGroundPen *)
			BlockPen  := BYTE(0);    (* BackGroundPen *)
			ViewModes := MyScreenViewSet; (* Set Resolution *)
			Type	  := MyScreenFlags;   (* Special Flags *)
			Font	  := NIL;  (* StandardFont *)
			DefaultTitle := NIL; (* No Title *)
			Gadgets	  := NIL;	(* No special gadgets *)
			CustomBitMap := NIL;	(* No CustomBitMap *)
		END;
  
	   MyScreen:=OpenScreen(MyNewScreenPtr^);
 	   	IF (MyScreen = NIL) THEN
			IsScreen := FALSE;
		ELSE
			MyRastPort := ADR( MyScreen^.RastPort);
			MyViewPort := ADR( MyScreen^.ViewPort);
			IsScreen := TRUE;
		END;
	ELSE
	   IsMemScreen := FALSE; (* Can't open Screen *)
	END;
	
END MakeMyScreen;
(* ========================================================================= *)	
PROCEDURE CloseMyScreen();

BEGIN 

	IF IsScreen = TRUE THEN
		CloseScreen(MyScreen^);
	END;

	IF IsMemScreen = TRUE THEN
		FreeMem(MyNewScreenPtr,TSIZE(NewScreen));
	END;

END CloseMyScreen;

(* ========================================================================= *)
PROCEDURE AddMyBOB(Laenge: LONGINT; Buffer: ObjectPtr; NumID: CARDINAL);

CONST
	Planes = 5;
	FullByte = BYTE(255);

VAR
	ExtPtr:	MyStuffPtr;
	BackLen,
	BorderLen: INTEGER;
	index:   INTEGER;
	VStruct: VSpritePtr;
	BStruct: BobPtr;
BEGIN
	ExtPtr := ADDRESS(Buffer)+ADDRESS(Laenge);
	
	IF ODD(LONGCARD(ExtPtr)) = TRUE THEN
		ExtPtr := ADDRESS(LONGCARD(ExtPtr)+LONGCARD(1));
	END;

	WITH Buffer^ DO
	  BackLen := Breite1*2*Hoehe*Planes;		
	  BorderLen := Breite1*2;
	END;
	
	
	WITH ExtPtr^ DO

	  BackMemAdr := AllocMem(BackLen,ChipMemSet);
	  BorderMemAdr := AllocMem(BorderLen,ChipMemSet); 
	  VStructMemAdr := AllocMem(SIZE(VSprite),AnyMemSet);
          BStructMemAdr := AllocMem(SIZE(Bob),AnyMemSet);

		MyID := 	NumID;
		MainMemL := 	Laenge+LONGINT(SIZE(MyStuff));
		MainMemAdr := 	Buffer;
		BackMemLen := 	BackLen;
		BorderLength := BorderLen;


		VStruct := VStructMemAdr;
		BStruct := BStructMemAdr;

	END;
				
	WITH VStruct^ DO 
	   VSBob := ExtPtr^.BStructMemAdr;
	   Flags := MyVSprFlags;
	   Height := Buffer^.Hoehe;
	   Width  := Buffer^.Breite1;
	   Depth  := Planes;
	   ImageData := ADDRESS(Buffer)+ADDRESS(Buffer^.ImgOff);
	   BorderLine := ExtPtr^.BorderMemAdr;
	   CollMask := ADR(Buffer^.MskOff);
	   HitMask := BITSET{0};
	   MeMask := BITSET{0}; 
	   PlanePick := FullByte;
	   PlaneOnOff := FullByte;
	   VUserExt := ExtPtr;
	END;
			
	WITH BStruct^ DO
	   BobVSprite := ExtPtr^.VStructMemAdr;
	   Flags := MyBobFlags;
	   ImageShadow := ADR(Buffer^.MskOff);
	   SaveBuffer := ExtPtr^.BackMemAdr;
	END;				

	AddBob(BStruct^,MyRastPort^); 

END AddMyBOB;
(* ========================================================================= *)
PROCEDURE TestDraw();
BEGIN
	SortGList(MyRastPort^);
	DrawGList(MyRastPort^,MyViewPort^);
END TestDraw;
(* ========================================================================= *)
PROCEDURE GetLength(fname : ADDRESS):LONGINT; (* Laenge eine Datei *)
VAR
	flock : FileLock;
	fib : FileInfoBlockPtr;
	length : LONGINT;
BEGIN

 flock := Lock(fname,-2);
     IF (flock # NIL) THEN
       fib := AllocMem(TSIZE(FileInfoBlock),AnyMemSet);
      	  IF Examine(flock,fib^) AND (fib^.fibDirEntryType < 0D) THEN
		length := (fib^.fibSize);
	  ELSE
	        length := 0D;	  
	  END;
       UnLock(flock);
       FreeMem(fib,TSIZE(FileInfoBlock));
     ELSE
      length := 0D;
     END;	 		

RETURN length;

END GetLength;
(* ========================================================================= *)		
(* Routine entfernt Bob aus GelsListe und gibt Speicher frei *)
PROCEDURE RemMyBob(IDNum: CARDINAL);
	
VAR
	Found:		BOOLEAN;
	Searcher:	VSpritePtr;
	Finder:		MyStuffPtr;
	ReBob:		BobPtr;
BEGIN
	Searcher := GelsPtr^.gelHead;
	Found := FALSE;

	REPEAT 
		Finder := Searcher^.VUserExt;
		IF IDNum = Finder^.MyID THEN
			Found := TRUE;
		ELSE
			Searcher := Searcher^.NextVSprite;
		END;
	UNTIL Found = TRUE;

	ReBob := Searcher^.VSBob;
	RemIBob(ReBob^,MyRastPort^,MyViewPort^);

	WITH Finder^ DO
		FreeMem(BackMemAdr,BackMemLen);
		FreeMem(BorderMemAdr,BorderLength);
		FreeMem(BStructMemAdr,SIZE(Bob));
		FreeMem(VStructMemAdr,SIZE(VSprite));
		FreeMem(MainMemAdr,MainMemL);
	END;

END RemMyBob;						
(* ========================================================================= *)		
PROCEDURE MoveMyBob(IDNum: CARDINAL; X,Y: INTEGER);
VAR
	Found:		BOOLEAN;
	Searcher:	VSpritePtr;
	Finder:		MyStuffPtr;
	ReBob:		BobPtr;

BEGIN
	Searcher := GelsPtr^.gelHead;
	Found := FALSE;

	REPEAT 
		Finder := Searcher^.VUserExt;
		IF IDNum = Finder^.MyID THEN
			Found := TRUE;
		ELSE
			Searcher := Searcher^.NextVSprite;
		END;
	UNTIL Found = TRUE;

	Searcher^.X := X;
	Searcher^.Y := Y;

END MoveMyBob;

(* ========================================================================= *)		
PROCEDURE RemGels();

BEGIN
	FreeMem(HeadPtr,SIZE(VSprite));
	FreeMem(TailPtr,SIZE(VSprite));
	FreeMem(CollPtr,SIZE(collTable));
	FreeMem(GelsPtr,SIZE(GelsInfo));
END RemGels;
(* ========================================================================= *)		
(* Procedure erstellt GelsInfo *)
PROCEDURE GenGelsInfo();

BEGIN
	HeadPtr := AllocMem(SIZE(VSprite),AnyMemSet);	(* Get Mem. for Head *)
	TailPtr := AllocMem(SIZE(VSprite),AnyMemSet);	(* Get Mem. for Tail *)
	GelsPtr := AllocMem(SIZE(GelsInfo),AnyMemSet);  (* Get Mem. for GelsI *)
	CollPtr := AllocMem(SIZE(collTable),AnyMemSet); (* Get Mem. for Coll *)	

	IF (HeadPtr # NIL) AND (TailPtr # NIL) AND (GelsPtr # NIL) THEN
		GelsPtr^.nextLine := ADR(NextLines);
		GelsPtr^.lastColor := ADR(LastColors);
		GelsPtr^.collHandler := CollPtr;
		InitGels(HeadPtr^,TailPtr^,GelsPtr^);
		MyRastPort^.GelsInfo := GelsPtr;
	END;

END GenGelsInfo;
(* ========================================================================= *)		
(* Routine liest Bobdaten ein und konvertiert sie fuer die Amiga-Bob-Software *)
(* Uebergabe: FileName = Name der Daten auf der Diskette 
 	      Number = Identifikationsnummer des BOB's *)

PROCEDURE GetObject(FileName: ARRAY OF CHAR; Number : CARDINAL);
VAR
	FileLength,
	ReadedLength: LONGINT;
	MyHandle:   FileHandle;
	MyBuffer:   ObjectPtr;

BEGIN
	IF IsGelsInfo = FALSE THEN	   (* Ist GelsInfo schon aufgebaut *)
		GenGelsInfo();		   (* Erstelle GelsInfo *)
		IsGelsInfo := TRUE;	   (* GelsInfoFlag = TRUE *)
	END;

	FileLength := GetLength(ADR(FileName));	   (* Hole Laenge der Datei *)
	IF FileLength # LONGINT(0) THEN
	  MyBuffer := AllocMem(FileLength+LONGINT(SIZE(MyStuff)),ChipMemSet);
	   IF MyBuffer # NIL THEN
		MyHandle := Open(ADR(FileName),ModeOldFile);
		   IF MyHandle # NIL THEN 
			ReadedLength := Read(MyHandle,MyBuffer,FileLength);
		        IF ReadedLength = FileLength THEN
	    		   AddMyBOB(FileLength,MyBuffer,Number);
			   Close(MyHandle);
			ELSE
			   FreeMem(MyBuffer,FileLength+LONGINT(SIZE(MyStuff)));
			   Close(MyHandle);
			END;
		   ELSE
			FreeMem(MyBuffer,FileLength+LONGINT(SIZE(MyStuff)));			
		   END;
	   END;
	END;

END GetObject;

(* ========================================================================= *)		
PROCEDURE GetPalette(PalName: ARRAY OF CHAR);
VAR
	FileLength,
	ReadedLength: LONGINT;
	MyHandle:   FileHandle;
	PalBuffer:  ADDRESS;
BEGIN

	FileLength := GetLength(ADR(PalName));	   (* Hole Laenge der Datei *)
	IF FileLength # LONGINT(0) THEN
	  PalBuffer := AllocMem(FileLength,AnyMemSet);
	   IF PalBuffer # NIL THEN
		MyHandle := Open(ADR(PalName),ModeOldFile);
		   IF MyHandle # NIL THEN 
			ReadedLength := Read(MyHandle,PalBuffer,FileLength);
		        IF ReadedLength = FileLength THEN
			 LoadRGB4(MyViewPort^,PalBuffer,FileLength);
                	 FreeMem(PalBuffer,FileLength);
			 Close(MyHandle);
			ELSE
			 FreeMem(PalBuffer,FileLength);
			 Close(MyHandle);
			END;
		   ELSE
			FreeMem(PalBuffer,FileLength);			
		   END;
	   END;
	END;

END GetPalette;

(* ========================================================================= *)		
PROCEDURE SmallWait();

BEGIN
	XB := 100; YB := 160;
	WHILE CIAGamePort0 IN ciaa^.ciapra DO
		IF (XB > 260) OR (XB < 0) THEN
		   MoverX := -MoverX;
		END;
		IF (YB > 200) OR (YB < 0) THEN
		   MoverY := -MoverY;
		END;	

		INC(XB,MoverX);INC(YB,MoverY);
		MoveMyBob(1,XB,YB);
		TestDraw;
	END;

END SmallWait;  

(* ========================================================================= *)	
	
BEGIN

	MoverX := 8;MoverY := 8;
	IsGelsInfo := FALSE;
	MakeMyScreen;
	   GetPalette("TEST.PAL");
	   GetObject("TEST.OBJ",1);
		SmallWait;
	RemMyBob(1);
	CloseMyScreen;
	RemGels;

END BobDemo.