1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250: 251: 252: 253: 254: 255: 256: 257: 258: 259: 260: 261: 262: 263: 264: 265: 266: 267: 268: 269: 270: 271: 272: 273: 274: 275: 276: 277: 278: 279: 280: 281: 282: 283: 284: 285: 286: 287: 288: 289: 290: 291: 292: 293: 294: 295: 296: 297: 298: 299: 300: 301: 302: 303: 304: 305: 306: 307: 308: 309: 310: 311: 312: 313: 314: 315: 316: 317: 318: 319: 320: 321: 322: 323: 324: 325: 326: 327: 328: 329: 330: 331: 332: 333: 334: 335: 336: 337: 338: 339: 340: 341: 342: 343: 344: 345: 346: 347: 348: 349: 350: 351: 352: 353: 354: 355: 356: 357: 358: 359: 360: 361: 362: 363: 364: 365: 366: 367: 368: 369: 370: 371: 372: 373: 374: 375: 376: 377: 378: 379: 380: 381: 382: 383: 384: 385: 386: 387: 388: 389: 390: 391: 392: 393: 394: 395: 396: 397: 398: 399: 400: 401: 402: 403: 404: 405: 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: 417: 418: 419: 420: 421: 422: 423: 424: 425: 426: 427: 428: 429: 430: 431: 432: 433: 434: 435: 436: 437: 438: 439: 440: 441: 442: 443: 444: 445: 446: 447: 448: 449: 450: 451: 452: 453: 454: 455: 456: 457: 458: 459: 460: 461: 462: 463: 464: 465: 466: 467: 468: 469: 470: 471: 472: 473: 474: 475: 476: 477: 478: 479: 480: 481: 482: 483: 484: 485: 486:
|
program LOGICAL; uses crt; const hmax = 4; nmax = 6; bmax = 40; PUNKTE : integer = 0; LEVEL : integer = 0;
type Index = 0..nmax; hIndex = 1..hmax; nIndex = 1..nmax; bIndex = 0..bmax; Praed = (neb,gem,pos); Bed = record pr : Praed; p1,q1 : hIndex; p2,q2 : nIndex; vz : boolean; end; Register = array[nIndex,nIndex] of Index;
var R : array[hIndex] of Register; Bedsatz : array[bIndex] of Bed; BedZahl : bIndex; RndFeld : array[hIndex,nIndex] of nIndex; h : hIndex; n : nIndex; Ende:Boolean;
procedure Begruessung; begin ClrScr; writeln('LOGICAL':34); writeln('-------':34); writeln('Version 3.0/Mai 1985':70); writeln(' (c) Ulrich A. Kern ':70); writeln; writeln; writeln('Ein Spiel fuer Knobler und Tueftler.'); writeln('Viel Spass beim Loesen!'); writeln; writeln('Ihr aktueller Punktestand: ',PUNKTE); end;
procedure Zufall; var i : hIndex; j,k,zn : nIndex; doppelt : boolean; begin randomize; if PUNKTE<1 then LEVEL:=1 else if PUNKTE>15 then LEVEL:=5 else LEVEL:=PUNKTE div 3; repeat n:=random(nmax-2)+3; h:=random(hmax)+1 until n+h=LEVEL+3; writeln('LEVEL : ':60,LEVEL:2); write ('Fuer die ':60); case LEVEL of 1 : writeln('Anfaenger !'); 2 : writeln('Fortgeschrittenen !'); 3 : writeln('Gescheiten !'); 4 : writeln('Tueftler !'); 5 : writeln('Knobelfuechse !'); end; for i:=1 to h do for j:=1 to n do begin repeat doppelt:=false; zn:=random(nmax)+1; k:=1; while (k<j) and not(doppelt) do begin doppelt:=(zn=RndFeld[i,k]); k:=k+1 end; until not doppelt; RndFeld[i,j]:=zn; end end;
procedure Machbed; var i : hIndex; j : nIndex; b : bIndex; doppelt : boolean; BTemp : Bed; begin BedZahl:=0; repeat with BTemp do begin pr:=neb; p1:=random(h)+1; q1:=random(h)+1; repeat p2:=random(n)+1; q2:=random(n)+1 until (p2<>q2) or (p1<>q1); if (p1>q1) or((p1=q1) and (p2>q2)) then begin i:=p1; p1:=q1; q1:=i; j:=p2; p2:=q2; q2:=j end; b:=0; doppelt:=false; vz:=(abs(p2-q2)=1); while (b<BedZahl) and not(doppelt) do begin b:=b+1; doppelt:=(p1=BedSatz[b].p1) and (p2=BedSatz[b].p2) and (q1=BedSatz[b].q1) and (q2=BedSatz[b].q2); end; end; if not doppelt then begin Bedzahl:=BedZahl+1; BedSatz[Bedzahl]:=BTemp end; until BedZahl=(n-1)*h-1 end;
procedure Macheindeutig; var t : bIndex; i,k : 0..hmax; j : 0..nmax; o : 1..6; Ende,w : boolean; BTemp : bed; zn : 0..6; antw:char;
procedure ordnen; var b : bIndex; BTemp : bed; SEnde : boolean; begin repeat SEnde:=true; for b:=1 to BedZahl-1 do if BedSatz[b].q1<BedSatz[b+1].q1 then begin BTemp:=BedSatz[b]; BedSatz[b]:=BedSatz[b+1]; BedSatz[b+1]:=BTemp; SEnde:=false end; until SEnde end;
procedure sieben; var i,j : bIndex; begin i:=0; repeat i:=i+1; if (BedSatz[i].pr<>neb) and (BedSatz[i].vz=true) then begin j:=0; repeat j:=j+1; if (BedSatz[i].pr=BedSatz[j].pr) and (BedSatz[j].vz=false) then if ( (BedSatz[i].pr=pos) and (BedSatz[i].p1=BedSatz[j].p1) and ( (BedSatz[i].p2=BedSatz[j].p2) or (BedSatz[i].q2=BedSatz[j].q2) ) ) or ( (BedSatz[i].pr=gem) and ( ( (BedSatz[i].p1=BedSatz[j].p1) and (BedSatz[i].p2=BedSatz[j].p2) and (BedSatz[i].q1=BedSatz[j].q1) ) or ( (BedSatz[i].q1=BedSatz[j].q1) and (BedSatz[i].q2=BedSatz[j].q2) and (BedSatz[i].p1=BedSatz[j].p1) ) ) ) then begin BedSatz[j]:=BedSatz[BedZahl]; BedZahl:=BedZahl-1; j:=0 end; until j>=BedZahl end until i>=BedZahl end;
procedure variiere(x : Index); var hz,i : hIndex; procedure korrigiere(x,y : nIndex); var i,j : Index; begin for i:=y to n do begin for j:=1 to i-1 do R[x,i,j]:=R[x,i-1,j]; R[x,i,i]:=i end; end; procedure init(x : hIndex); begin R[x,1,1]:=1; korrigiere(x,2) end; function EOP(x : hIndex) : boolean; begin EOP:=(R[x,1,1]=0) end; procedure perm(x : hIndex); var i,j : Index; function EOR(x : hIndex; y : nIndex) : boolean; begin EOR:=(R[x,y,1]=y) end; procedure rot(x : hIndex; y : nIndex); var i,z : Index; begin i:=1; while R[x,y,i]<>y do i:=i+1; z:=R[x,y,i]; R[x,y,i]:=R[x,y,i-1]; R[x,y,i-1]:=z end; begin i:=n; while EOR(x,i) and (i>1) do i:=i-1; if i=1 then R[x,1,1]:=0 else rot(x,i); if (i<>1) and (i<>n) then korrigiere(x,i+1); if x=1 then write('*') end;
begin if x=0 then for i:=1 to h do init(i) else if not(Ende) then begin t:=BedZahl+1; hz:=x+1; repeat hz:=hz-1; perm(hz) until not(EOP(hz)) or (hz=1); while hz<h do begin hz:=hz+1; init(hz) end; if EOP(1) then Ende:=true end end;
function s(var x : hIndex; var y : nIndex) : nIndex; var i : nIndex; begin i:=1; while R[x,n,i]<>y do i:=i+1; s:=i end;
begin writeln('>> BITTE WARTEN <<':20); writeln; ordnen; Ende:=false; variiere(0); variiere(h); repeat t:=BedZahl; repeat with BedSatz[t] do case pr of pos : case vz of true : while (s(p1,p2)<>q2) and not(Ende) do variiere(p1); false : while (s(p1,p2)= q2) and not(Ende) do variiere(p1); end; gem : case vz of true : while (s(p1,p2)<>s(q1,q2)) and not(Ende) do variiere(q1); false : while (s(p1,p2)= s(q1,q2)) and not(Ende) do variiere(q1); end; neb : case vz of true : while (abs(s(p1,p2)-s(q1,q2))<>1) and not(Ende) do variiere(q1); false : while (abs(s(p1,p2)-s(q1,q2))= 1) and not(Ende) do variiere(q1); end end; t:=t-1; until Ende or (t=0); if not(Ende) then begin repeat i:=random(h)+1; j:=random(n)+1; until R[i,n,j]<>j; with BTemp do begin k:=0; for zn:=1 to h do if R[zn,n,j]=j then k:=zn; if k>0 then zn:=3 else zn:=0; o:=random(3)+1+zn; p1:=i; p2:=R[i,n,j]; case o of 1,2 : begin pr:=pos; vz:=false; q1:=p1; q2:=j end; 3 : begin pr:=pos; vz:=true; q1:=p1; q2:=p2 end; 4 : begin pr:=gem; vz:=false; q1:=k; q2:=j end; 5,6 : begin pr:=gem; vz:=true; q1:=k; q2:=p2 end; end; if (pr=gem) and (p1>q1) then begin i:=p1; p1:=q1; q1:=i; j:=p2; p2:=q2; q2:=j end; BedZahl:=BedZahl+1; BedSatz[BedZahl]:=BTemp; ordnen; sieben; end end; until Ende; writeln; write('Weiter mit RETURN') ; repeat antw:=readkey until antw in[#13]; end;
procedure Dialog; const name : array[hIndex,nIndex] of string[10] = (('Franzose','Pole','Schotte','Korse','Grieche','Ire'), ('rot','schwarz','blau','gruen','gelb','braun'), ('Honda','BMW','Fiat','Rover','Audi','Renault'), ('Limo','Wasser','Milch','Bier','Kakao','Schnaps')); zeile : array[1..20] of string[50] = ('Der #1 und der #2 wohnen ~nebeneinander', 'Der #1 wohnt ~im $-ten Haus', 'Neben dem #2en Haus wohnt ~der #1', 'Im #2en Haus wohnt ~der #1', 'Der Mann mit dem #2 ist ~der Nachbar des #1n', 'Der #1 faehrt ~den #2', 'Der #1 ist ~der Nachbar des #2-Trinkers', 'Das Lieblingsgetraenk des #1n ist ~#2', 'Das #1e und das #2e Haus stehen ~nebeneinander', 'Das $-te Haus ist ~#1', 'Der #2-Fahrer wohnt ~neben dem #1en Haus', 'Im #1en Haus wohnt ~der Mann mit dem #2', 'Der #2freund wohnt ~neben dem #1en Haus', '#2 wird ~im #1en Haus getrunken', 'Der #1-Fahrer und der #2 Fahrer sind ~Nachbarn', 'Im $-ten Haus wohnt ~der #1-Fahrer', 'Der #1-Fahrer und der #2-Trinker sind ~Nachbarn', 'Der #1-Fahrer staerkt sich ~mit #2', '#1- und #2geniesser wohnen ~nebeneinander', '#1 trinkt man ~im $-ten Haus'); wvz : array[boolean] of string[6] = ('nicht ',''); Frage : array[1..hmax] of string[30] = ('In welchem Haus wohnt der', 'Welches Haus ist', 'Zu welchem Haus gehoert der', 'In welchem Haus trinkt man'); var i,j : integer; Z : array[bIndex] of bIndex; antw : char; a : nIndex;
procedure printline(x : Bed); var i,p : integer; c,d : char; begin with x do begin p:=2*hmax*p1-2*hmax-p1*p1+p1-1+2*q1; if pr<>neb then p:=p+1; for i:=1 to length(zeile[p]) do begin c:=zeile[p][i]; d:=zeile[p][i+1]; if not (c in ['#','1','2','$','~']) then write(c) else if d='1' then write(name[p1,RndFeld[p1,p2]]) else if d='2' then write(name[q1,RndFeld[q1,q2]]) else if c='$' then write(chr(48+q2)) else if c='~' then write(wvz[vz]); end; writeln('.') end end;
procedure printnamen(x : hIndex); var i,j : Index; a : array[index] of index; w : boolean; begin a[1]:=random(n)+1; for i:=2 to n do repeat a[i]:=random(n)+1; w:=true; for j:=1 to i-1 do if a[j]=a[i] then w:=false until w; for i:=1 to n-1 do if i<n-1 then write(name[x,RndFeld[x,a[i]]],', ') else writeln(name[x,RndFeld[x,a[i]]],' oder ',name[x,RndFeld[x,a[n]]],'.') end;
procedure wuerfeln; var i,j : 1..30; w : boolean; begin for i:=1 to BedZahl do repeat Z[i]:=random(BedZahl)+1; w:=true; for j:=1 to i-1 do if Z[j]=Z[i] then w:=false until w end;
procedure Machfrage(x : hindex; var y : nindex); var o,i : integer; w : boolean; begin repeat o:=random(n)+1; w:=true; i:=0; while (i<BedZahl) and w do begin i:=i+1; w:=(BedSatz[i].pr<>pos) or not(BedSatz[i].vz) or (BedSatz[i].q2<>o) end until w; write(frage[x],' ',name[x,RndFeld[x,o]],' (1..',n:1,')? '); y:=o end;
begin ClrScr; writeln('In der Europastrasse stehen ',n,' Haeuser nebeneinander.'); write('In jedem wohnt ein Landsmann: '); printnamen(1); if h>1 then begin write('Jedes hat eine andere Farbe: '); printnamen(2) end; if h>2 then begin write('Zu jedem gehoert ein Auto: '); printnamen(3) end; if h>3 then begin write('Und ein Lieblingsgetraenk: '); printnamen(4) end; writeln; wuerfeln; for i:=1 to BedZahl do printline(BedSatz[Z[i]]);
writeln; for i:=1 to h do begin Machfrage(i,a); repeat antw:=readkey until antw in ['1'..chr(48+n)]; write(antw); if (ord(antw)-48)=a then begin writeln(' Richtig!'); PUNKTE:=PUNKTE+3 end else begin writeln(' Falsch! '); PUNKTE:=PUNKTE-3 end; end; writeln; for i:=1 to h do begin for j:=1 to n do write(name[i,RndFeld[i,j]]:10); writeln end; writeln; write('Weiter mit >RETURN< Ende mit >ESC<'); repeat antw:=readkey until antw in[#13,#27]; Ende:=antw=#27 end;
begin Ende:=False; repeat Begruessung; Zufall; Machbed; Macheindeutig; Dialog; until Ende or (PUNKTE>20);
ClrScr; writeln('Sie haben es geschafft!'); writeln('Gratuliere, Sie sind der LOGICAL-Meister.')
end. |