program Zahlenraetsel;
{h#s 08/00: Lösung von Zahlenrätseln}
{Dieses Programm verläßt sich darauf, daß alle globalen Variablen
automatisch mit Null initialisiert sein!}
{$I-,R-,S-,Q-}
{$M $4000,0,0}
uses WinDos,Strings;
type
ADez=(x1,x10,x100,x1000);
TDez=array[ADez] of Integer;
AZif=(a,b,c,d,e,f,g,h,i,j);
TZif=array[AZif] of TDez;
PCE=^Word;
TCE=record
next: Word;
ce: array[0..31] of Word; {Compilierter Ausdruck}
formula: array[0..29] of Char; {Ursprüngliche Formel}
end;
{Aufbau Compilierter Ausdruck:
1 WORD NEXT-Zeiger
n-mal:
1 WORD Summanden einer Zahl <m>
m WORD NEAR-Zeiger auf Summanden
1 WORD NEAR-Zeiger auf Operation (push, add, sub, mult, divi)
1 WORD =0 Null-Test des "Stacks" und Ende}
function istty(var f: Text): Boolean; assembler;
asm les bx,[f]
mov bx,es:TTextRec[bx].handle
mov ax,4400h
int 21h
mov al,FALSE
test dl,80h
jz @@e {ist Datei}
test dl,3
jz @@e {ist weder stdin noch stdout}
inc al
@@e:
end;
{Operationen, jeweils PE: AX=Operand, DI=Quelle und Ziel (eigentlich: Stack)}
{z.Z. keine Klammerebenen, DI=TOS(top-of-stack), DX<>0 bei Überlauf oder Rest}
procedure push; assembler;
asm xchg di,ax
end;
procedure add; assembler;
asm add di,ax
end;
procedure sub; assembler;
asm sub di,ax
end;
procedure mult; assembler;
asm imul di
xchg di,ax
end;
procedure divi; assembler;
asm xchg di,ax
cwd
idiv di
xchg di,ax
end;
procedure divr; assembler; {Modulo-Division}
asm xchg di,ax
cwd
idiv di
xchg di,dx
xor dx,dx {niemals Überlauf}
end;
procedure divir; assembler; {Inverse Division (rechs durch links)}
asm cwd
idiv di
xchg di,ax
end;
procedure ProcessTCE; assembler;
{Compilierten Ausdruck berechnen,
PE: SI=PCE,
PA: Z=1 wenn Null
VR: ax,bx,cx,dx,si,di}
asm xor di,di
xor dx,dx
@@l: add si,2
mov cx,[si]
jcxz @@e {zum Test: Stack=0?}
xor ax,ax
@@l1: add si,2
mov bx,[si]
add ax,[bx] {Zahl zusammensetzen}
loop @@l1
add si,2
call word ptr [si]
or dx,dx {DX muß 0 bleiben, sonst Überlauf oder Rest}
jz @@l
jmp @@ex {mit NZ, Ausdruck unberechenbar}
@@e: or di,di
@@ex:
end;
var
CEAnchor: Word; {NEAR-Zeiger auf verkette Liste}
function TestAllTCEs: Boolean; assembler; {liefert TRUE bei Treffer}
asm mov si,offset CEAnchor
@@l: mov si,[si]
or si,si
jz @@ok
push si
call ProcessTCE
pop si
jz @@l {Ergebnis Null - nächster Ausdruck!}
mov al,FALSE
jmp @@e
@@ok: mov al,TRUE
@@e:
end;
var
Ziffern: TZif; {alle 10x4 Ziffern}
Starts: array[AZif] of ShortInt; {Startwerte 0 oder 1}
LastZif,FreeZif: AZif;
Letters: array[AZif] of Char;
const
Mult10: array[ADez] of Integer=(1,10,100,1000);
var
Used: array[0..9] of Boolean; {ob Ziffer bereits in Beschlag ist}
function Letter2Zif(letter: Char; var Zif: AZif): Boolean;
{ersetzt Buchstaben durch variable und Ziffern durch feste <Zif>
Variable <Zif> sind am Anfang, feste <Zif> am Ende von <Letters>}
var
z: AZif;
dez: ADez;
i: Integer;
begin
Letter2Zif:=false;
letter:=Upcase(letter);
case letter of
'0'..'9': begin
if FreeZif<j then begin
for z:=Succ(FreeZif) to j do begin
if letter=Letters[z] then begin
Zif:=z;
Letter2Zif:=true; {gefunden}
exit;
end;
end;
end;
if LastZif<FreeZif then begin {Eintrag}
z:=FreeZif;
Dec(FreeZif);
i:=Ord(letter)-Ord('0'); {in Zahl umrechnen}
Used[i]:=true; {sperren für Variablen!}
for dez:=LOW(dez) to HIGH(dez) do begin
Ziffern[z][dez]:=i*Mult10[dez];
end;
Zif:=z;
Letters[z]:=letter;
Letter2Zif:=true;
end;
end;
'A'..'Z': begin
if LastZif in [a..j] then begin
for z:=LOW(z) to LastZif do begin
if letter=Letters[z] then begin
Zif:=z;
Letter2Zif:=true; {gefunden}
exit;
end;
end;
end;
if LastZif=FreeZif then exit; {kein Platz für neue Ziffer!}
Inc(LastZif);
z:=LastZif;
Zif:=z;
Letters[z]:=letter;
Letter2Zif:=true; {neuer Buchstabe hinzugefügt}
end;
else exit; {kein Buchstabe oder Zahl: Fehler!}
end;
end;
var
ErrorIndex: Word;
function CompileTCE(CE: PCE; expr: PChar):Boolean;
{liefert TRUE wenn OK}
var
c: Char;
Zif: AZif;
SavedOp: Word; {near-Funktionszeiger}
CounterPointer, DownPointer: PCE;
IntPointer: ^Integer;
begin
ErrorIndex:=0;
CompileTCE:=false;
CE^:=0; Inc(CE); {next-Feld nullsetzen}
SavedOp:=ofs(push);
CounterPointer:=nil;
repeat
c:=Upcase(expr^);
case c of
' ',#9: ; {Leerzeichen übergehen}
'+','-','=','*','/','%','\': begin
CE^:=SavedOp;
Inc(CE);
case c of
'+': SavedOp:=Ofs(add);
'-','=': SavedOp:=Ofs(sub);
'*': SavedOp:=Ofs(mult);
'/': SavedOp:=Ofs(divi);
'%': SavedOp:=Ofs(divr); {Rest-Division (modulo)}
'\': SavedOp:=Ofs(divir); {inverse Division}
end;
CounterPointer:=nil;
end;
#0: begin
CE^:=SavedOp; Inc(CE);
CE^:=0; {Abschluß: Null-Test}
CompileTCE:=true;
exit;
end;
else
if not Letter2Zif(c,Zif) then exit; {Umrechnen in Index}
if CounterPointer=nil then begin
CounterPointer:=CE; Inc(CE);
CounterPointer^:=0;
Starts[Zif]:=1; {als erste Ziffer niemals Null}
{BUG: außer einstellig, dieser Fall fällt hier mal unter den Tisch}
end else begin
if CounterPointer^=4 then exit; {Fehler: Zahl zu lang}
end;
IntPointer:=@Ziffern[Zif][x1];
CE^:=ofs(IntPointer^); {Zeiger eintragen}
DownPointer:=CE; {Alle anderen Zeiger müssen um 2 erhöht werden}
Inc(CE);
repeat
asm mov si,word ptr [DownPointer] {alles NEAR}
mov si,[si]
cmp word ptr [si],-1
jnz @@1
mov word ptr [si],0 {"Wird benutzt" markieren (löscht -1)}
@@1: end;
Dec(DownPointer);
if DownPointer=CounterPointer then break;
Inc(DownPointer^,sizeof(Integer));
until false;
Inc(CounterPointer^);
end;
Inc(expr);
Inc(ErrorIndex);
until false;
end;
var
TCEs: array[0..3] of TCE;
TCEUsage: Integer;
function AddTCE(expr: PChar): Boolean;
begin
AddTCE:=false;
if TCEUsage=HIGH(TCEs) then exit; {zuviel}
with TCEs[TCEUsage] do begin
if not CompileTCE(@next,expr) then exit; {Fehler}
StrCopy(formula,expr);
next:=CEAnchor; {in EVL einhängen}
CEAnchor:=Ofs(next);
end;
Inc(TCEUsage);
AddTCE:=true;
end;
var
tick: Word absolute $40:$6C;
prevtick: Word;
starttick: Word;
sol: Word; {Anzahl Lösungen}
procedure PutSol; {Zahlen ausgaben}
var
I: AZif;
begin
for I:=LOW(I) to LastZif do Write(Ziffern[i][x1]:2);
end;
procedure Substitute(s: PChar);
{in Zeichenkette Buchstaben durch Lösungs-Ziffern ersetzen}
var
c: Char;
Zif: AZif;
begin
while s^<>#0 do begin
c:=s^;
if Letter2Zif(c,Zif) {Umrechnen in Index}
then Write(Ziffern[Zif][x1])
else Write(c);
Inc(s);
end;
end;
procedure TwoSpaces;
begin
Write(' ');
end;
procedure Test;
begin
if TestAllTCEs then begin
PutSol;
asm mov di,offset CEAnchor
@@l:
mov di,[di];
or di,di
jz @@e
push di
call TwoSpaces
pop di
push di
push ds
lea ax,TCE[di].formula
push ax
call Substitute
pop di
jmp @@l
@@e:
end;
Inc(sol);
WriteLn;
end;
end;
procedure DoForLoop(R: AZif);
{Rekursive Funktion, die alle Kombinationen durchspielt}
var
I: Integer;
Dez: ADez;
IP: ^Integer;
begin
for I:=Starts[R] to 9 do begin
if not Used[I] then begin
Used[I]:=true;
for Dez:=LOW(Dez) to HIGH(Dez) do begin
IP:=@Ziffern[R][Dez];
if IP^=-1 then break;
IP^:=I*Mult10[Dez];
end;
if R<LastZif then DoForLoop(Succ(R)) {je nach Ziffernzahl}
else begin
if Tick-PrevTick>=3 then begin
if istty(output) then begin
PutSol;
Write(#13);
end;
PrevTick:=Tick;
end;
Test;
end;
Used[I]:=false;
end;
end;
end;
var
k: AZif;
s: array[0..15] of Char;
pn: Integer;
w: Word;
const
Beispiel='ba*bc=cba';
begin
if istty(output)
then WriteLn('Programm zum gewaltsamen Lösen von Zahlenrätseln, h#s 08/00');
FillChar(Starts,sizeof(Starts),0);
FillChar(Ziffern,sizeof(Ziffern),$FF); {um die Multiplikation zu sparen}
ShortInt(LastZif):=-1; FreeZif:=j;
pn:=GetArgCount;
if pn<1 then begin
WriteLn;
WriteLn('Parameter: Gleichungen in der Form abc*d+efg=hij');
WriteLn('Unterschiedliche Buchstaben (A..Z) = unterschiedliche Ziffern,');
WriteLn('Vorgabe-Ziffern = feste Ziffern (Geschwindigkeitssteigerung)');
WriteLn('Als Operatoren sind + - * / % \ erlaubt; Rangfolge nach Kettenregel');
WriteLn('[ % = Rest-Division, \ = umgekehrte Division (rechts durch links) ]');
WriteLn('Nach = darf kein Ausdruck stehen, ggf. umstellen! (= wirkt wie -)');
WriteLn;
WriteLn('Beispielrechnung:',Beispiel);
WriteLn;
if not AddTCE(Beispiel) then begin
WriteLn('Blödsinn im Programm!');
halt(1);
end;
end else begin
for pn:=pn downto 1 do begin
GetArgStr(s,pn,sizeof(s));
if not AddTCE(s) then begin
WriteLn;
WriteLn('Fehlerhafter Ausdruck!');
WriteLn;
WriteLn(s);
for ErrorIndex:=ErrorIndex downto 1 do Write(' ');
WriteLn('^-----hier, z.B. zu lange Zahl (max. 4 Stellen),');
WriteLn('zu viele Variablen oder Konstanten (max. 10 selbstverständlich),'+
' falsche Zeichen');
halt(1);
end;
end;
end;
if istty(output) then WriteLn('Start...');
starttick:=tick;
for k:=LOW(k) to LastZif do Write(' ',Letters[k]);
w:=CEAnchor;
while w<>0 do begin
TwoSpaces; Write(TCE(Ptr(Seg(w),w)^).formula);
w:=TCE(Ptr(Seg(w),w)^).next;
end;
WriteLn;
DoForLoop(a);
if istty(output) then Write(' '#13'...Stop, ');
case sol of
0: Write('keine Lösung');
1: Write('1 Lösung');
else Write(sol,' Lösungen');
end;
WriteLn(' nach ca. ',(tick-starttick+9) div 18,' Sekunden');
end.
| Detected encoding: OEM (CP437) | 1
|
|
|