Cas11/QUEENS.MOD

   1 MODULE Queens;
   2
   3   FROM IO IMPORT
   4     WrStr, WrLn, WrCard, RdCard, OK;
   5
   6   FROM SYSTEM IMPORT
   7     TSIZE;
   8
   9   FROM Storage IMPORT
  10     ALLOCATE, DEALLOCATE;
  11
  12   IMPORT FIO;
  13
  14   CONST
  15     MaxDim = 50;
  16
  17   TYPE
  18     Indeks = [1 .. MaxDim];
  19     DomenCene = [0 .. MaxDim * MaxDim];
  20     DomenBrojaKraljica = [1 .. MaxDim * MaxDim];
  21
  22     PPolozaj = POINTER TO SPolozaj;
  23     SPolozaj = RECORD
  24                  Ko, Vr: Indeks;
  25                  Cena: DomenCene;
  26                  Veza: PPolozaj;
  27                END;
  28
  29     PKraljica = POINTER TO SKraljica;
  30     SKraljica = RECORD
  31                   Pre, Sled: PKraljica;
  32                   Kandidati: PPolozaj;
  33                   TekKo, TekVr: Indeks;
  34                 END;
  35
  36     StanjeTip = RECORD
  37                   Cena: DomenCene;
  38                   PrvaKra, TekKra: PKraljica;
  39                 END;
  40     StatusTip = (stZauzeto, stNapadnuto, stSlobodno);
  41     ResenjeTip = RECORD
  42                    Cena: DomenCene;
  43                    Poz: ARRAY Indeks, Indeks OF StatusTip;
  44                  END;
  45   VAR
  46     BrojKol, BrojVrs: Indeks;
  47     BrojKraljica: DomenBrojaKraljica;
  48
  49   PROCEDURE Unos();
  50   BEGIN
  51     REPEAT
  52       WrLn;
  53       WrStr('Unesite broj Kolona sahovske table (od 1 do ');
  54       WrCard(MaxDim, 1);
  55       WrStr(') ------- ');
  56       BrojKol:= RdCard();
  57     UNTIL OK AND (1 <= BrojKol) AND (BrojKol <= MaxDim);
  58     REPEAT
  59       WrLn;
  60       WrStr('Unesite broj Vrsta sahovske table (od 1 do ');
  61       WrCard(MaxDim, 1);
  62       WrStr(') ------- ');
  63       BrojVrs:= RdCard();
  64     UNTIL OK AND (1 <= BrojVrs) AND (BrojVrs <= MaxDim);
  65     REPEAT
  66       WrLn;
  67       WrStr('Unesite broj kraljica (od 1 do ');
  68       WrCard(BrojKol * BrojVrs, 1);
  69       WrStr(') ------- ');
  70       BrojKraljica:= RdCard();
  71     UNTIL OK AND (1 <= BrojKraljica) AND (BrojKraljica <= BrojKol * BrojVrs);
  72   END Unos;
  73
  74   PROCEDURE Postavi(VAR Stanje: StanjeTip);
  75     VAR
  76       Temp: PPolozaj;
  77   BEGIN
  78     WITH Stanje DO
  79       Temp:= TekKra^.Kandidati;
  80       TekKra^.Kandidati:= Temp^.Veza;
  81       TekKra^.TekKo:= Temp^.Ko;
  82       TekKra^.TekVr:= Temp^.Vr;
  83       Cena:= Temp^.Cena;
  84       DISPOSE(Temp);
  85     END;
  86   END Postavi;
  87
  88   PROCEDURE Inicijalizacija(VAR Stanje: StanjeTip; VAR Br: CARDINAL);
  89     VAR
  90       Tek, Pom: PKraljica;
  91       i: DomenBrojaKraljica;
  92   BEGIN
  93     Br:= 0;
  94     WITH Stanje DO
  95       Cena:= 0;
  96       NEW(PrvaKra);
  97       TekKra:= PrvaKra;
  98       Tek:= PrvaKra;
  99       Tek^.Pre:= NIL;
 100       FOR i:= 2 TO BrojKraljica DO
 101         Pom:= Tek;
 102         NEW(Tek^.Sled);
 103         Tek:= Tek^.Sled;
 104         Tek^.Pre:= Pom;
 105       END;
 106       Tek^.Sled:= NIL;
 107     END;
 108   END Inicijalizacija;
 109
 110   PROCEDURE Ispitaj(Ko, Vr: Indeks; Granica: PKraljica; VAR Stanje: StanjeTip; VAR Status: StatusTip);
 111     VAR
 112       Tek: PKraljica;
 113       Jos: BOOLEAN;
 114   BEGIN
 115     WITH Stanje DO
 116       Tek:= PrvaKra;
 117       Jos:= Tek # Granica;
 118       Status:= stSlobodno;
 119       WHILE Jos DO
 120         IF (Tek^.TekKo = Ko) AND (Tek^.TekVr = Vr) THEN
 121           Status:= stZauzeto;
 122           Jos:= FALSE;
 123         ELSE
 124           IF (Tek^.TekKo = Ko) OR (Tek^.TekVr = Vr) OR (ABS(Tek^.TekKo - Ko) = ABS(Tek^.TekVr - Vr)) THEN
 125             Status:= stNapadnuto;
 126           END;
 127           IF Tek^.Sled= Granica THEN
 128             Jos:= FALSE;
 129           ELSE
 130             Tek:= Tek^.Sled;
 131           END;
 132         END;
 133       END;
 134     END;
 135   END Ispitaj;
 136
 137   PROCEDURE Stampa(VAR Resenje: ResenjeTip);
 138     CONST
 139       ImeFajla = "Resenje.txt";
 140     VAR
 141       Ko, Vr: Indeks;
 142       Izlaz: FIO.File;
 143   BEGIN
 144     IF FIO.Exists(ImeFajla) THEN
 145       Izlaz:= FIO.Append(ImeFajla);
 146     ELSE
 147       Izlaz:= FIO.Create(ImeFajla);
 148     END;
 149     WrLn;
 150     WrStr('-----------------------------------------------------------------');
 151     WrStr('---------------');
 152     WrLn;
 153     FIO.WrLn(Izlaz);
 154     WrStr('Kraljice treba staviti na sledeca polja:');
 155     FIO.WrStr(Izlaz, 'Kraljice treba staviti na sledeca polja:');
 156     WrLn;
 157     FIO.WrLn(Izlaz);
 158     FOR Vr:= BrojVrs TO 1 BY -1 DO
 159       WrLn;
 160       FIO.WrLn(Izlaz);
 161       FOR Ko:= 1 TO BrojKol DO
 162         CASE Resenje.Poz[Ko, Vr] OF
 163           stZauzeto: WrStr(' Q');
 164                      FIO.WrStr(Izlaz, ' Q'); |
 165           stNapadnuto: WrStr(' x');
 166                        FIO.WrStr(Izlaz, ' x');
 167         ELSE
 168           WrStr(' .');
 169           FIO.WrStr(Izlaz, ' .');
 170         END;
 171       END;
 172     END;
 173     WrLn;
 174     FIO.WrLn(Izlaz);
 175     WrLn;
 176     FIO.WrLn(Izlaz);
 177     WrStr('Broj slobodnih polja je: ');
 178     FIO.WrStr(Izlaz, 'Broj slobodnih polja je: ');
 179     WrCard(BrojKol * BrojVrs - Resenje.Cena, 1);
 180     FIO.WrCard(Izlaz, BrojKol * BrojVrs - Resenje.Cena, 1);
 181     FIO.Close(Izlaz);
 182   END Stampa;
 183
 184   PROCEDURE Dame(BrojKol, BrojVrs: Indeks; BrojKraljica: DomenBrojaKraljica);
 185     VAR
 186       Stanje: StanjeTip;
 187       Resenje: ResenjeTip;
 188       MinCena: DomenCene;
 189       Br: CARDINAL;
 190
 191     PROCEDURE NadjiKandidate(VAR Stanje: StanjeTip);
 192
 193       PROCEDURE NadjiCenu(k, v: Indeks; VAR Cena: DomenCene; VAR Stanje: StanjeTip);
 194         VAR
 195           Ko, Vr: Indeks;
 196           Status: StatusTip;
 197       BEGIN
 198         Cena:= 0;
 199         FOR Ko:= 1 TO BrojKol DO
 200           FOR Vr:= 1 TO BrojVrs DO
 201             IF (Ko # k) AND (Vr # v) AND (ABS(Ko - k) # ABS(Vr - v)) THEN
 202               Ispitaj(Ko, Vr, Stanje.TekKra, Stanje, Status);
 203               IF Status # stSlobodno THEN
 204                 INC(Cena);
 205               END;
 206             ELSE
 207               INC(Cena);
 208             END;
 209           END;
 210         END;
 211       END NadjiCenu;
 212
 213       PROCEDURE Ubaci(VAR Prvi, Novi: PPolozaj);
 214         VAR
 215           Tek: PPolozaj;
 216       BEGIN
 217         IF (Prvi = NIL) OR (Novi^.Cena < Prvi^.Cena) THEN
 218           Novi^.Veza:= Prvi;
 219           Prvi:= Novi;
 220         ELSE
 221           Tek:= Prvi;
 222           WHILE (Tek^.Veza # NIL) AND (Tek^.Veza^.Cena < Novi^.Cena) DO
 223             Tek:= Tek^.Veza;
 224           END;
 225           Novi^.Veza:= Tek^.Veza;
 226           Tek^.Veza:= Novi;
 227         END;
 228       END Ubaci;
 229
 230       VAR
 231         k, v: Indeks;
 232         Temp, Prvi: PPolozaj;
 233         NovaCena: DomenCene;
 234         Status: StatusTip;
 235         PocKol, PocVrs: CARDINAL;
 236
 237     BEGIN
 238       Prvi:= NIL;
 239       IF Stanje.TekKra = Stanje.PrvaKra THEN
 240         PocKol:= 1;
 241       ELSE
 242         PocKol:= Stanje.TekKra^.Pre^.TekKo;
 243       END;
 244       FOR k:= PocKol TO BrojKol DO
 245         IF (k = PocKol) AND (Stanje.TekKra # Stanje.PrvaKra) THEN
 246           PocVrs:= Stanje.TekKra^.Pre^.TekVr + 1;
 247         ELSE
 248           PocVrs:= 1;
 249         END;
 250         FOR v:= PocVrs TO BrojVrs DO
 251           NadjiCenu(k, v, NovaCena, Stanje);
 252           IF NovaCena < MinCena THEN
 253             NEW(Temp);
 254             WITH Temp^ DO
 255               Veza:= NIL;
 256               Ko:= k;
 257               Vr:= v;
 258               Cena:= NovaCena;
 259             END;
 260             Ubaci(Prvi, Temp);
 261           END;
 262         END;
 263       END;
 264       Stanje.TekKra^.Kandidati:= Prvi;
 265     END NadjiKandidate;
 266
 267     PROCEDURE ZapamtiResenje(VAR Stanje: StanjeTip; VAR Resenje: ResenjeTip);
 268       VAR
 269         Ko, Vr: Indeks;
 270         Status: StatusTip;
 271     BEGIN
 272       Resenje.Cena:= Stanje.Cena;
 273       FOR Ko:= 1 TO BrojKol DO
 274         FOR Vr:= 1 TO BrojVrs DO
 275           Ispitaj(Ko, Vr, NIL, Stanje, Status);
 276           Resenje.Poz[Ko, Vr]:= Status;
 277         END;
 278       END;
 279     END ZapamtiResenje;
 280
 281   BEGIN
 282     Inicijalizacija(Stanje, Br);
 283     MinCena:= BrojKol * BrojVrs  + 1;
 284     NadjiKandidate(Stanje);
 285     WITH Stanje DO
 286       WHILE TekKra # NIL DO
 287         WHILE TekKra^.Kandidati # NIL DO
 288           IF TekKra = PrvaKra THEN
 289             INC(Br);
 290             WrCard(Br, 4);
 291           END;
 292           Postavi(Stanje);
 293           IF TekKra^.Sled = NIL THEN
 294             IF Cena < MinCena THEN
 295               MinCena:= Cena;
 296               ZapamtiResenje(Stanje, Resenje);
 297             END;
 298           ELSE
 299             TekKra:= TekKra^.Sled;
 300             NadjiKandidate(Stanje);
 301           END;
 302         END;
 303         TekKra:= TekKra^.Pre;
 304       END;
 305       Stampa(Resenje);
 306     END;
 307   END Dame;
 308
 309 BEGIN
 310   Unos();
 311   WrLn;
 312   WrStr('Sacekajte !!!');
 313   WrLn;
 314   Dame(BrojKol, BrojVrs, BrojKraljica);
 315 END Queens.