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.
|
