|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 8891 (0x22bb)
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«
└─⟦1e8b2a66e⟧
└─⟦this⟧
--
-- Christophe MARCHAL
-- Probleme des 8 reines
-- sous FADA version 4 : 3 mars 1991
--
with expertSystem,chrono;
use expertSystem;
package reines is
subtype tTaille is natural range 0..9; -- jusqu'a 9 reines
type rangee is array(tTaille) of tTaille;
type object is record
echiquier : rangee := (others=>0) ;
niveau : tTaille :=0 ;
ouvert : boolean := FALSE ;
end record;
RangCourant : tTaille :=0; -- rangee courante
RangFinal : tTaille :=tTaille'LAST; -- but a atteindre
procedure enRoute (nbreReine : natural);
function niveauNonOuvert (niveau : tTaille) return collection.object;
function niveauFinal (niveau : tTaille) return collection.object;
procedure afficherSol (sol : collection.object);
procedure ajoutSituation (sit : expertSystem.reference;
rang : tTaille;
colonne : tTaille);
procedure fermeSituation (sit : expertSystem.reference);
function situationCorrecte (sit : expertSystem.reference;
rang : tTaille;
colonne : tTaille) return boolean;
end reines;
with expertSystem,chrono;
use expertSystem;
package body reines is
package behavior is new classBehavior(object,"QUEEN ",3000);
procedure enRoute(nbreReine : natural) is
init : Reines.object;
begin
RangCourant:=0;
RangFinal:=tTaille(nbreReine);
behavior.clear;
init.echiquier:=(others=>0);
init.niveau:=0;
init.ouvert:=false;
behavior.allocate(init);
end enRoute;
function niveauNonOuvert (niveau : tTaille) return collection.object is
function NiveauEtPasOuvert(uneRef : expertSystem.reference) return boolean is
begin
return( behavior.get(uneRef).niveau = niveau
and behavior.get(uneRef).ouvert = FALSE );
end NiveauEtPasOuvert;
function lesNiveaux is new collection.restrict(NiveauEtPasOuvert);
begin
return lesNiveaux(behavior.instances);
end niveauNonOuvert;
function niveauFinal(niveau : tTaille) return collection.object is
function NiveauFin (uneRef : expertSystem.reference) return boolean is
begin
return( behavior.get(uneRef).niveau = niveau ) ;
end NiveauFin;
function cesNiveaux is new collection.restrict(NiveauFin);
begin
return(cesNiveaux(behavior.instances));
end niveauFinal;
procedure dessine(n : natural) is
begin
for i in 1..n-1 loop put("| "); end loop;
put("| o ");
for i in n+1..RangFinal loop put("| "); end loop;
put_line("|");
end dessine;
procedure affiche(uneRef : expertSystem.reference) is
begin
put_line(" ");
put_line("Voici une solution : ");
for i in 1..4*RangFinal+1 loop put("="); end loop; put_line(" ");
for i in 1..RangFinal loop
dessine(reines.behavior.get(UneRef).echiquier(i));
for i in 1..4*RangFinal+1 loop put("="); end loop; put_line(" ");
end loop;
end affiche;
procedure lesAfficher is new collection.forAll(affiche);
procedure afficherSol( sol : collection.object) is
begin
put("Nombre de solutions :");
put(integer(collection.cardinality(sol)));
put_line(" ");
lesAfficher(sol);
end afficherSol;
procedure ajoutSituation (sit : expertSystem.reference;
rang : tTaille;
colonne : tTaille) is
situation : reines.object;
begin
situation := behavior.get(sit);
situation.echiquier(rang) := colonne;
situation.niveau := situation.niveau+1;
situation.ouvert := FALSE;
behavior.allocate(situation);
end ajoutSituation;
procedure fermeSituation (sit : expertSystem.reference) is
situation : reines.object;
begin
situation := behavior.get(sit);
situation.ouvert := TRUE;
behavior.set(sit,situation);
behavior.dispose(sit); -- suppression des situations inutiles
end fermeSituation;
function situationCorrecte (sit : expertSystem.reference; -- echiquier courant
rang : tTaille; -- nouvelle ligne
colonne : tTaille) -- position reine dans
return boolean is -- la ligne
-- rend VRAI si une reine peut etre mise en (rang,colonne) sans risque du aux
-- autres reines etant deja sur l'echiquier sur les lignes 1..rang-1
situation : reines.object;
begin
situation:= behavior.get(sit);
for ligne in 1..rang-1 loop
if situation.echiquier(ligne) = colonne -- meme colonne
or rang - ligne = abs(colonne-situation.echiquier(ligne)) -- meme diagonale a gauche
then return (FALSE);
end if;
end loop;
return TRUE;
end situationCorrecte;
end reines;
with expertSystem; use expertSystem;
with Reines; use Reines;
with Chrono;
package systExpertR is
procedure enRoute(nbreReine : natural ; affDem : boolean);
function continue return boolean;
end systExpertR;
package body systExpertR is
-- les variables internes :
type tContexte is (contexte0, contexte1, contexte2);
contexte: tContexte := contexte0;
-- les variables de l'application :
buts : collection .object;
solutions : collection .object;
situation : expertSystem.reference;
affDemande : boolean := TRUE; -- affichage demande ?
-- regles a utiliser dans le contexte 0 :
function regle0 return boolean is
begin
-- R-0-A
-- SI LE RANG COURANT DANS L'ECHIQUIER EST EGAL AU RANG A ATTEINDRE
-- ET SI L'ENSEMBLE DES SOLUTIONS EST VIDE
-- ALORS REMPLIR L'ENSEMBLE DES SOLUTIONS AVEC LES SITUATIONS DE NIVEAU
-- COURANT (QUI ONT DEJA ETE OUVERTES)
regleTrouverSolution:
begin
if RangCourant = RangFinal
and collection.cardinality(solutions)=0
then
solutions := niveauFinal(RangFinal);
return( TRUE ) ;
end if;
end regleTrouverSolution;
-- R-0-B
-- SI L'ENSEMBLE DES SOLUTIONS N'EST PAS VIDE
-- ALORS AFFICHER SON CONTENU
regleAfficherSol:
begin
if collection.cardinality(solutions)/=0
then
chrono.stop(0);
if affDemande then
afficherSol(solutions);
end if;
return( FALSE ) ; -- F I N I !
end if;
end regleAfficherSol;
-- R-0-C
-- SI LE RANG COURANT DANS L'ECHIQUIER EST DIFFERENT DU RANG A ATTEINDRE
-- ET SI L'ENSEMBLE DES BUTS EST VIDE
-- ALORS REMPLIR L'ENSEMBLE DES BUTS AVEC LES SITUATIONS DE NIVEAU COURANT
-- NON ENCORE OUVERTES
regleChercherBut:
begin
if RangCourant /= RangFinal
and collection.cardinality(buts)=0
then
buts := niveauNonOuvert(RangCourant);
put(" Nb buts niveau courant :");
put(integer(collection.cardinality(buts)));
put_line(" ");
return( TRUE ) ;
end if;
end regleChercherBut;
-- R-0-D
-- SI L'ENSEMBLE DES BUTS N'EST PAS VIDE
-- ALORS COMMENCER / CONTINUER A TRAITER SON CONTENU
regleTraiterBut:
begin
if collection.cardinality(buts)/=0
then
RangCourant := RangCourant + 1;
situation:=collection.first(buts);
for essai in 1..RangFinal loop
if situationCorrecte(situation,RangCourant,essai) then
ajoutSituation(situation,RangCourant,essai);
end if;
end loop;
fermeSituation(situation);
collection.remove(buts,situation);
if collection.cardinality(buts)/=0 then
RangCourant := RangCourant-1; -- continuer au meme niveau
end if; -- tq ens Buts pas vide
return( TRUE ) ;
end if;
end regleTraiterBut;
-- etc ... autres regles du contexte 0
return (FALSE); -- fin des regles de REGLE0
end regle0;
-- MISE EN ROUTE DU MOTEUR DU S-E
procedure enRoute(nbreReine : natural ;
affDem : boolean ) is
begin
-- initialisations
affDemande:=affDem;
collection.clear(buts);
collection.clear(solutions);
reines.enRoute(nbreReine);
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 systExpertR;
with expertSystem,systExpertR,chrono ;
use expertSystem;
procedure Reine is
nc : character;
ni : integer;
zero : constant natural := character'POS('0');
begin
put_line("Resolution du probleme des N reines");
put("Tapez un nombre entre 4 et 9 ");
get(nc);
put_line(" ");
ni:=character'pos(nc)-zero;
systExpertR.enRoute(ni,TRUE);
loop
exit when not systExpertR.continue;
end loop;
end Reine;
with expertSystem,systExpertR,chrono ;
use expertSystem;
procedure Mesure is
cpt : natural;
begin
put_line("Resolution du probleme des N reines");
put_line("Mesure des temps : ");
chrono.reset;
for ni in 4..9 loop
cpt:=1;
chrono.start(ni);
systExpertR.enRoute(ni,FALSE);
loop
exit when not systExpertR.continue;
cpt:=cpt+1;
end loop;
chrono.next(cpt);
end loop;
put_line(" ESSAI REINES REGLES DUREE");
chrono.display;
end Mesure;