DataMuseum.dk

top - download

    Length: 9502 (0x251e)
    Types: TextFile
    Notes: R1k Text-file segment

└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
    └─ ⟦5a81ac88f⟧ »Space Info Vol 1« 
        └─⟦96ab87ac6⟧ 
            └─⟦this⟧ 

TextFile

-- Christophe MARCHAL : SYSTEME EXPERT QUI REMPLI DES BOITES AVEC DES BRIQUES
--			EN PERDANT LE MINIMUM DE PLACE PUIS CALCULANT LA
--			FACTORIELLE DE 7 ENSUITE ( 2 contextes)

-- VERSION FINALE POLY-PAQUETAGE 

-- fichier se4.ada pour version 4 de FADA


with expertSystem; use  expertSystem;


package Boites is

	type object is record
		taille   : natural  :=1;
		remplie  : boolean  :=FALSE;
	end record;

	package behavior  is new classBehavior(object, "BOXES     ");

	cBoite  : collection.object;


	function LesBoites return collection.object ;

	function taille(aRef : reference) return natural;

	procedure occuper(aRef : reference);
	procedure liberer(aRef : reference);

	procedure enRoute;

end Boites;



package body Boites is

	function BoiteConvient(aRef : reference) return boolean is
	begin
		return (behavior.get(aRef).remplie = FALSE and
		        behavior.get(aRef).taille >=50 and
		        behavior.get(aRef).taille <=200);
	end BoiteConvient;

	function LesBoites000 is new collection.restrict(BoiteConvient);

	function LesBoites return collection.object is
	begin
	    return (LesBoites000(behavior.instances));
	end LesBoites;

	function taille(aRef : reference) return natural is
	begin
		return(behavior.get(aRef).taille); 
	end taille;

	procedure occuper(aRef : reference) is
	uneBoite : object;
	begin
		put("Taille de la boite: ");
		uneBoite:=behavior.get(aRef);
   		put(uneBoite.taille);
		put_line(" ");
   		uneBoite.remplie  := TRUE;
   		behavior.set(aRef,UneBoite);
	end occuper;

	procedure liberer(aRef : reference) is
	uneBoite : object;
	begin
		uneBoite:=behavior.get(aRef);
   		uneBoite.remplie  := FALSE;
   		behavior.set(aRef,UneBoite);
	end liberer;


	procedure enRoute is
	uneBoite : object;
	begin

		put_line("Creation de boites vides de differentes tailles");
		for i in 7..56 loop
			uneBoite.taille := i*6;
			behavior.allocate(uneBoite);
		end loop;

	end enRoute;

end Boites;





with expertSystem; use  expertSystem;

package Briques is

	type tCouleur is (rose, grise, blanche);

	type object is record
		taille   : natural  := 1;
		couleur  : tCouleur := rose;
		emballee : boolean  := FALSE;
	end record;

	package behavior is new classBehavior(object,"BRICK     ");

	cBrique : collection.object;

	function LesBriques return collection.object ;

	function taille(aRef : reference) return natural;

	procedure emballer(aRef : reference);

	procedure enRoute;

end Briques;




package body Briques is

	function BriqueConvient(aRef : reference) return boolean is
	begin
		return (behavior.get(aRef).emballee = FALSE and
		        behavior.get(aRef).taille >=50 and
		        behavior.get(aRef).taille <=200);
	end BriqueConvient;

	function LesBriques000 is new collection.restrict(BriqueConvient);

	function LesBriques return collection.object is
	begin 
		 return ( LesBriques000(behavior.instances) ) ;
	end LesBriques;

	function taille(aRef : reference) return natural is
	begin
		return(behavior.get(aRef).taille); 
	end taille;


	procedure emballer(aRef : reference) is
	uneBrique : object;
	begin
		put("Taille de la brique : ");
		uneBrique:=behavior.get(aRef);
   		put(uneBrique.taille);
		put_line(" ");
   		uneBrique.emballee  := TRUE;
   		behavior.set(aRef,uneBrique);
	end emballer;

	procedure enRoute is
	uneBrique : object;
	begin
		put_line("Creation de briques de differentes tailles");
		put_line("Association au mieux selon la taille...");
		for i in 10..30 loop
	   		uneBrique.taille := i*5;
			behavior.allocate(uneBrique);
		end loop;
	end enRoute;

end Briques;



with expertSystem; use  expertSystem;


package Nombres is

	type object is record
		but      : natural :=1;
		courant  : natural :=1;
		resultat : natural :=1;
	end record;

	resInter : natural:=1;

	unNombre : object;

	refNombreCourant : reference;

	function leResultat(c: collection.object) return reference;

	function butAtteint return boolean;

	procedure continuer;

	procedure calculerFact;

	procedure afficherFact;

	procedure enRoute;

end Nombres;


package body Nombres is

	package behavior is new classBehavior(object,"NUMBERS   ");


	procedure mult(r:reference) is
		unNombre : object;
	begin
		-- effet de bord : resInter augmente
		unNombre:=behavior.get(r);
		resInter:=resInter * unNombre.courant;
		unNombre.resultat:=resInter;
		behavior.set(r,unNombre);
	end mult;



	function dernier(laMeilleure, uneAutre: reference) return boolean is
	begin
		return ( behavior.get(laMeilleure).resultat
		       >
		       behavior.get(uneAutre).resultat) ;
	end dernier;

	function leResultat000 is new collection.theMost(dernier);

	function leResultat(c: collection.object) return reference is
	begin
		return ( leResultat000(c) );
	end leResultat;

			-- partage de unNombre entre butAtteint et continuer
	function butAtteint return boolean is
        begin
		unNombre:=behavior.get(refNombreCourant);
		return (unNombre.courant = unNombre.but);
	end butAtteint;

	procedure continuer is
	begin
		unNombre.courant := unNombre.courant + 1;
		refNombreCourant := behavior.allocate(unNombre);
	end continuer;
	

	procedure calculFact is new collection.forAll(mult);

	procedure calculerFact is
	begin
		calculFact( behavior.instances );
	end calculerFact;

	procedure afficherFact is
	begin
		put_line(" ");
		put("Resultat factoriel: ");

		refNombreCourant:=leResultat( behavior.instances );

	   	put(behavior.get(refNombreCourant).resultat);
		put_line(" ");

	end afficherFact;

	procedure enRoute is
	begin

		unNombre.but:=7;
		resInter:=1;

		refNombreCourant:=behavior.allocate(unNombre);
		put_line(" ");
		put(" Calcul de factorielle de : ");
		put(unNombre.but);
		put_line(" ... ");

	end enRoute;

end Nombres;




with expertSystem; use  expertSystem;
with Briques,Boites,Nombres;
use  Briques,Boites,Nombres;

package systExpertSe4 is

	procedure enRoute;
	function  continue return boolean;

end systExpertSe4;


package body systExpertSe4 is


			-- les variables internes :

	type tContexte is (contexte0, contexte1, contexte2);

	contexte: tContexte := contexte0;


			-- les variables de l'application :

	couples     : tupleCollection.object;
	coupleIdeal : tuple          .object;



-- les fonctions necessaires pour les regles intra-fait :

	function caEntre(r1,r2:reference) return boolean is
	begin
		return (Boites .taille(r1) > 
		        Briques.taille(r2)  );
	end caEntre;

	function apparier is new tupleCollection.join2(caEntre);


	function ecartMinimal(leMeilleur, unAutre: tuple.object) return boolean is
	begin
		return Boites. taille(tuple.first( leMeilleur)) -
		       Briques.taille(tuple.second(leMeilleur))
		       <
		       Boites .taille(tuple.first( unAutre)) -
		       Briques.taille(tuple.second(unAutre));
	end ecartMinimal;

	function leMeilleurCouple is new tupleCollection.theMost(ecartMinimal);


			-- regles a utiliser dans le contexte 0 :

	function regle0 return boolean is
	begin

-- domaine d'application des regles 0:
-- si il existe des couples (brique, boite) dans les ensembles de boites et de
-- briques qui sont libres tel que la brique rentre dans la boite alors choisir
-- le couple le mieux adapte (le moins de place perdue) et mettre la brique
-- dans la boite


			-- preparation de la condition

				-- 1ere restriction : cherche les boites libres
				--		      cherche les briques libres

-- SI EXISTE BOITES <BO> LIBRES ...

		cBoite  := LesBoites;

-- SI EXISTE BRIQUES <BR> LIBRES ...

		cBrique := LesBriques;	
	
				-- on essaye d'apparier 2 a 2

-- SI BOITE <BO> CONVIENT PHYSIQUEMENT AVEC BRIQUE <BR> ...

		couples := apparier(cBoite , cBrique,2000);

			-- evaluation de la condition :

-- (REGLE 0-A)
-- SI IL NE RESTE PLUS DE PAIRES <BO>,<BR> ALORS CHANGEMENT DE CONTEXTE

		if tupleCollection.isNull(couples) then
			contexte:=contexte1;
			return( TRUE ) ; 
		end if;
-- REGLE 0-B
-- SI IL Y A DES PAIRES <BO>,<BR> ALORS CHERCHER LA MEILLEUR DE CES PAIRES ...

		if not tupleCollection.isNull(couples) then

			coupleIdeal := leMeilleurCouple(couples);

-- ET ATTRIBUER L'UN A L'AUTRE ...

			put_line(" MEILLEUR COUPLE ACTUEL ");

	   		occuper(tuple.first(coupleIdeal));
		   	emballer(tuple.second(coupleIdeal));

	   		return(TRUE);

		end if;

-- REGLE 0-C ...
-- etc ... autres regles du contexte 0


		return (FALSE);		-- fin des regles de REGLE0

	end regle0;



	function regle1 return boolean is
	begin
				-- prepa conditions


-- REGLE 1-A
-- SI BUT NON ATTEINT ALORS CONTINUER VERS LE BUT

		if not butAtteint then 
		   continuer;
		   return ( TRUE );
		end if;

-- REGLE 1-B
-- SI BUT ATTEINT ALORS CALCULER LES RESULTATS GLOBAUX PUIS AFFICHER CELUI
-- QUI ETAIT RECHERCHE

		if butAtteint then
		   calculerFact;
		   afficherFact;
		   return ( FALSE );	-- fini
		end if;

-- REGLE 1-C ...


		return (FALSE);		-- fin des regles de REGLE 1
		
	end regle1;


-- MISE EN ROUTE DU MOTEUR DU S-E

	procedure enRoute is
	begin

				-- creation des objets : REGLE 0
		Boites .enRoute;
		Briques.enRoute;
				-- creation des objets : REGLE 1
		Nombres.enRoute;

	end enRoute;


-- ENTRETIENT DU MOTEUR DU S-E

	function continue return boolean is
		resu : boolean;
	begin
		case contexte is
			when contexte0 => resu:=regle0;
			when contexte1 => resu:=regle1;
			when others    => resu:=FALSE;
		end case;
		return(resu);
	end continue;

end systExpertSe4;




with systExpertSe4;

procedure emballer is
begin

    systExpertSe4.enRoute;
    loop
       exit when not systExpertSe4.continue;
    end loop;

end emballer