10. Obrnuti problem kraljica/XDS/QUEENS2.MOD

   1 MODULE Queens2;
   2 (*upgrade za xds *)
   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 = INTEGER;*)
  19         Interval = [1 .. MaxDim];
  20     DomenCene = INTEGER; (*[0 .. MaxDim * MaxDim];*)
  21     DomenBrojaKraljica = INTEGER; (*[1 .. MaxDim * MaxDim];*)
  22
  23     PPolozaj = POINTER TO SPolozaj;
  24     SPolozaj = RECORD
  25                  Ko, Vr: INTEGER;
  26                  Cena: DomenCene;
  27                  Veza: PPolozaj;
  28                END;
  29
  30     PKraljica = POINTER TO SKraljica;
  31     SKraljica = RECORD
  32                   Pre, Sled: PKraljica;
  33                   Kandidati: PPolozaj;
  34                   TekKo, TekVr: INTEGER;
  35                 END;
  36
  37     StanjeTip = RECORD
  38                   Cena: DomenCene;
  39                   PrvaKra, TekKra: PKraljica;
  40                 END;
  41     StatusTip = (stZauzeto, stNapadnuto, stSlobodno);
  42     ResenjeTip = RECORD
  43                    Cena: DomenCene;
  44                    Poz: ARRAY Interval, Interval OF StatusTip;
  45                  END;
  46   VAR
  47     BrojKol, BrojVrs: INTEGER;
  48     BrojKraljica: INTEGER;
  49
  50   PROCEDURE Unos();
  51   BEGIN
  52     REPEAT
  53       WrLn;
  54       WrStr('Unesite broj Kolona sahovske table (od 1 do ');
  55       WrCard(MaxDim, 1);
  56       WrStr(') ------- ');
  57       BrojKol:= RdCard();
  58     UNTIL OK AND (1 <= BrojKol) AND (BrojKol <= MaxDim);
  59     REPEAT
  60       WrLn;
  61       WrStr('Unesite broj Vrsta sahovske table (od 1 do ');
  62       WrCard(MaxDim, 1);
  63       WrStr(') ------- ');
  64       BrojVrs:= RdCard();
  65     UNTIL OK AND (1 <= BrojVrs) AND (BrojVrs <= MaxDim);
  66     REPEAT
  67       WrLn;
  68       WrStr('Unesite broj kraljica (od 1 do ');
  69       WrCard(BrojKol * BrojVrs, 1);
  70       WrStr(') ------- ');
  71       BrojKraljica:= RdCard();
  72     UNTIL OK AND (1 <= BrojKraljica) AND (BrojKraljica <= BrojKol * BrojVrs);
  73   END Unos;
  74
  75   PROCEDURE Postavi(VAR Stanje: StanjeTip);
  76     VAR
  77       Temp: PPolozaj;
  78   BEGIN
  79     WITH Stanje DO
  80       Temp:= TekKra^.Kandidati;
  81       TekKra^.Kandidati:= Temp^.Veza;
  82       TekKra^.TekKo:= Temp^.Ko;
  83       TekKra^.TekVr:= Temp^.Vr;
  84       Cena:= Temp^.Cena;
  85       DISPOSE(Temp);
  86     END;
  87   END Postavi;
  88
  89   PROCEDURE Inicijalizacija(VAR Stanje: StanjeTip; VAR Br: CARDINAL);
  90     VAR
  91       Tek, Pom: PKraljica;
  92       i: DomenBrojaKraljica;
  93   BEGIN
  94     Br:= 0;
  95     WITH Stanje DO
  96       Cena:= 0;
  97       NEW(PrvaKra);
  98       TekKra:= PrvaKra;
  99       Tek:= PrvaKra;
 100       Tek^.Pre:= NIL;
 101       FOR i:= 2 TO BrojKraljica DO
 102         Pom:= Tek;
 103         NEW(Tek^.Sled);
 104         Tek:= Tek^.Sled;
 105         Tek^.Pre:= Pom;
 106       END;
 107       Tek^.Sled:= NIL;
 108     END;
 109   END Inicijalizacija;
 110
 111   PROCEDURE Ispitaj(Ko, Vr: INTEGER; Granica: PKraljica; VAR Stanje: StanjeTip; VAR Status: StatusTip);
 112     VAR
 113       Tek: PKraljica;
 114       Jos: BOOLEAN;
 115   BEGIN
 116     WITH Stanje DO
 117       Tek:= PrvaKra;
 118       Jos:= Tek # Granica;
 119       Status:= stSlobodno;
 120       WHILE Jos DO
 121         IF (Tek^.TekKo = Ko) AND (Tek^.TekVr = Vr) THEN
 122           Status:= stZauzeto;
 123           Jos:= FALSE;
 124         ELSE
 125           IF (Tek^.TekKo = Ko) OR (Tek^.TekVr = Vr) OR (ABS(Tek^.TekKo - Ko) = ABS(Tek^.TekVr - Vr)) THEN
 126             Status:= stNapadnuto;
 127           END;
 128           IF Tek^.Sled= Granica THEN
 129             Jos:= FALSE;
 130           ELSE
 131             Tek:= Tek^.Sled;
 132           END;
 133         END;
 134       END;
 135     END;
 136   END Ispitaj;
 137
 138   PROCEDURE Stampa(VAR Resenje: ResenjeTip);
 139     CONST
 140       ImeFajla = "Resenje.txt";
 141     VAR
 142       Ko, Vr: INTEGER;
 143       Izlaz: FIO.File;
 144   BEGIN
 145     IF FIO.Exists(ImeFajla) THEN
 146       Izlaz:= FIO.Append(ImeFajla);
 147     ELSE
 148       Izlaz:= FIO.Create(ImeFajla);
 149     END;
 150     WrLn;
 151     WrStr('-----------------------------------------------------------------');
 152     WrStr('---------------');
 153     WrLn;
 154     FIO.WrLn(Izlaz);
 155     WrStr('Kraljice treba staviti na sledeca polja:');
 156     FIO.WrStr(Izlaz, 'Kraljice treba staviti na sledeca polja:');
 157     WrLn;
 158     FIO.WrLn(Izlaz);
 159     FOR Vr:= BrojVrs TO 1 BY -1 DO
 160       WrLn;
 161       FIO.WrLn(Izlaz);
 162       FOR Ko:= 1 TO BrojKol DO
 163         CASE Resenje.Poz[Ko, Vr] OF
 164           stZauzeto: WrStr(' Q');
 165                      FIO.WrStr(Izlaz, ' Q'); |
 166           stNapadnuto: WrStr(' x');
 167                        FIO.WrStr(Izlaz, ' x');
 168         ELSE
 169           WrStr(' .');
 170           FIO.WrStr(Izlaz, ' .');
 171         END;
 172       END;
 173     END;
 174     WrLn;
 175     FIO.WrLn(Izlaz);
 176     WrLn;
 177     FIO.WrLn(Izlaz);
 178     WrStr('Broj slobodnih polja je: ');
 179     FIO.WrStr(Izlaz, 'Broj slobodnih polja je: ');
 180     WrCard(BrojKol * BrojVrs - Resenje.Cena, 1);
 181     FIO.WrCard(Izlaz, BrojKol * BrojVrs - Resenje.Cena, 1);
 182     FIO.Close(Izlaz);
 183   END Stampa;
 184
 185   PROCEDURE Dame(BrojKol, BrojVrs: INTEGER);
 186     VAR
 187       Stanje: StanjeTip;
 188       Resenje: ResenjeTip;
 189       MinCena: DomenCene;
 190       Br: CARDINAL;
 191
 192     PROCEDURE NadjiKandidate(VAR Stanje: StanjeTip);
 193
 194       PROCEDURE NadjiCenu(k, v: INTEGER; VAR Cena: DomenCene; VAR Stanje: StanjeTip);
 195         VAR
 196           Ko, Vr: INTEGER;
 197           Status: StatusTip;
 198       BEGIN
 199         Cena:= 0;
 200         FOR Ko:= 1 TO BrojKol DO
 201           FOR Vr:= 1 TO BrojVrs DO
 202             IF (Ko # k) AND (Vr # v) AND (ABS(Ko - k) # ABS(Vr - v)) THEN
 203               Ispitaj(Ko, Vr, Stanje.TekKra, Stanje, Status);
 204               IF Status # stSlobodno THEN
 205                 INC(Cena);
 206               END;
 207             ELSE
 208               INC(Cena);
 209             END;
 210           END;
 211         END;
 212       END NadjiCenu;
 213
 214       PROCEDURE Ubaci(VAR Prvi, Novi: PPolozaj);
 215         VAR
 216           Tek: PPolozaj;
 217       BEGIN
 218         IF (Prvi = NIL) OR (Novi^.Cena < Prvi^.Cena) THEN
 219           Novi^.Veza:= Prvi;
 220           Prvi:= Novi;
 221         ELSE
 222           Tek:= Prvi;
 223           WHILE (Tek^.Veza # NIL) AND (Tek^.Veza^.Cena < Novi^.Cena) DO
 224             Tek:= Tek^.Veza;
 225           END;
 226           Novi^.Veza:= Tek^.Veza;
 227           Tek^.Veza:= Novi;
 228         END;
 229       END Ubaci;
 230
 231       VAR
 232         k, v: INTEGER;
 233         Temp, Prvi: PPolozaj;
 234         NovaCena: DomenCene;
 235         PocKol, PocVrs: INTEGER;
 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: INTEGER;
 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   VAR
 310         as,df : Interval;
 311
 312 BEGIN
 313   Unos();
 314   WrLn;
 315   WrStr('Sacekajte !!!');
 316   WrLn;
 317   Dame(BrojKol, BrojVrs);
 318   as := 5;
 319   df := 6;
 320 END Queens2.