Source file: /~heha/hs/dos/zr.zip/ZR.PAS

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
Wrong umlauts? - Assume file is ANSI (CP1252) encoded