Play and Learn 2/19941.ZIP/19941/GERMAN/GERMANL/COMBO1.PAS

Pascal/Delphi Source File | 1994-02-05 | 19.4 KB | 731 lines

{$R-}    {Range checking off}
{$B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$M 65500,16384,655360} {Turbo 3 default stack and heap}

program COMBO;


Uses
  Crt;

const
   STRINGSIZE = 40;
   LARGESTRING = 80;
   SPACE = ' ';
   SENTINEL = '';

type
   STRING_40 = string[STRINGSIZE];
   STRING_80 = string[LARGESTRING];
   STACKTYPE = ^STACKNODE;
   STACKNODE = record
     LEVEL:  INTEGER;
     WORD:  STRING_80;
{! 1.^ The SYSTEM unit now uses this name as a standard identifier.}
     SAME, SUB, NEXT  : STACKTYPE
   end;


var
  FileName : STRING[20];
  FileName1 : STRING[20];
  LessonName : STRING[20];
  LessonNumber : STRING[20];
  Counter1 : integer;
  DOLOOP : BOOLEAN;
  ROOT, WRKLEAF1, WRKLEAF2 :  STACKTYPE;
  LEVELS : TEXT;
  FLOOR  : INTEGER;
  STUFF   : STACKNODE;
  INFILE  : TEXT;
  OUTFILE : TEXT;
  INFILE1 : TEXT;
  OUTFILE1: TEXT;
  WORD1 : STRING_80;
  INT1    : INTEGER;
  INSTR1  : STRING_80;
  INTER   : INTEGER;
  INST    : STRING_80;
  WORDS   : STRING_80;
  NUMS    : INTEGER;
  Y       : STRING_40;
  X       : BOOLEAN;
  IND     : INTEGER;
  CONT    : STRING_40;
  FLAGEXIT, FLAGADD : BOOLEAN;
  SAVESTR1, SAVESTR2, SAVESTR3, SAVESTR4, SAVESTR5 : STRING_80;
  VERB, NOUN, PREP, ART, QUESTION  : STRING_80;
  UTILNUM, NUM1, NUM2, NUM3, NUM4, NUM5 : INTEGER;
  TST1,TST2,TST3,TST4,TST5:   STRING_80;
  FOUND   :  BOOLEAN;
  NAME    :  STRING_40;
  LETTER  : CHAR;
  HOR     :  INTEGER;
  INPUT   :  CHAR;
  WORD : STRING_80;
  HORIZ : INTEGER;
  VERT  : INTEGER;

Procedure ClearRest;
  var
    X,Y   : integer;

  begin
    for Y := 4 to 20 do
      begin
        GotoXY(1,Y);
        ClrEol
      end
  end;

  procedure CreateWindow(X1,Y1,X2,Y2:  integer);


var
  border:  integer;

BEGIN

  window(1,1,80,25);
  GoToXY(X1,Y1) ; Write('┌'); GoToXY(X1,Y2); Write('└');
  For border  := (X1+1) to (X2-1) do
    begin
      GoToXY(border,Y1); Write('─');
      GoToXY(border,Y2); Write('─')
    end;
  GoToXY(X2,Y1); write('┐'); GoToXY(X2,Y2); Write('┘');
  for border :=(Y1+1) to (Y2-1) do
    begin
      GoToXY(X1,border); write('│');
      GoToXY(X2,border); write ('│')
    end;
  window(X1+1, Y1+1, X2-1, Y2-1);
  ClrScr;
  gotoXY(1,1);

END;

Procedure INPUTLINE (var  instring  : string_80);
var
  key  :  byte;
  FuncKey  : boolean;
  inchar : char;
  letter  : char;

function getkey : Byte;

begin
  FuncKey := false;
  repeat until KeyPressed;
    if KeyPressed then
      begin
        letter:=ReadKey;
        if letter = #0  then
          begin
            letter := ReadKey;
            FuncKey := true;
          end
      end;
      key:=ord(letter);
      Case key of
        01 : key := 132;
        15 : key := 148;
        21 : key := 129
      end;
      if FuncKey then
        begin
          Case key of
            01 : key := 132 ;
            30 : key := 142 ;
            15 : key := 148 ;
            24 : key := 153 ;
            21 : key := 129 ;
            22 : key := 154 ;
            31 : key := 225 ;
          end
        end;
        GetKey := key;

       end;

begin
  instring := '';
  Repeat
    inchar := chr(Getkey) ;
         If (key = 8) then
            begin
              Delete(instring,length(instring),1);
              gotoXY(Horiz,Vert);
              ClrEol;
              write(instring)
            end
         Else if (key <> 8) then
           begin
             instring := instring + inchar ;
            { if length(instring) = 35 then
               begin
                 X := WhereX;
                 Y := WhereY;
                 gotoXY(length(instring)+4,Y);
                 write('You only have three letters left.');
                 gotoXY(X,Y);
                 delay(900);
                 ClrEol
               end}
           end;
    If (((key <> 13) or (length(instring) <> 80))and (key<>8)) then write(inchar)
  Until ((key = 13) or (length(instring)=80)) ;
  If (key = 13) then Delete(instring,length(instring),1);
    If length(instring)<> 0 then
      begin
        while Copy(instring,length(instring),1) = chr(32) do
        delete(instring,length(instring),1);
        while pos(space,instring)=1 do
        Delete(instring,1,1)
      end
End ;

function GETREC(var WORKINT: INTEGER;var  WORKSTR:  STRING_80;
                var WORKFILE: TEXT): boolean;
   begin
        if not EOF(WORKFILE) then
            begin
              readln(WORKFILE, WORKINT);
              readln(WORKFILE, WORKSTR);
              GETREC := TRUE
            end
        else begin
               GETREC := FALSE
             end
   end;

procedure PUTREC(var INT1: INTEGER; var INST:  STRING_80);
   begin

            begin
              writeln(OUTFILE1, INT1);
              writeln(OUTFILE1, INST);
            end

   end;

procedure MAKE(var STACK : STACKTYPE);

begin
  STACK := NIL
end;

procedure PUSH(var LEAF: STACKTYPE; var STACK: STACKTYPE);

begin
  LEAF^.NEXT := STACK;
  STACK      := LEAF
end;

function POP(var LEAF : STACKTYPE; var STACK: STACKTYPE): boolean;

begin
  if (STACK = NIL) then
    POP := FALSE
  else
    begin
      LEAF := STACK;
      STACK := STACK^.NEXT;
      LEAF^.NEXT := NIL;
      POP := TRUE
    end
end;


function FINDBRANCH (var W, X, Y, Z, N : INTEGER;
                     var OUTSTRNG1, OUTSTRNG2, OUTSTRNG3, OUTSTRNG4, OUTSTRNG5: STRING_80;
        ar LEAF: STACKTYPE; var STACK: STACKTYPE);

begin
  LEAF^.NEXT := STACK;
  STACK      := LEAF
end;

function POP(var LEAF : STACKTYPE; var STACK: STACKTYPE): boolean;

begin
  if (STACK = NIL) then
    POP := FALSE
  else
    begin
      LEAF := STACK;
      STACK := STACK^.NEXT;
      LEAF^.NEXT := NIL;
      POP := TRUE
    end
end;


function FINDBRANCH (var W, X, Y, Z, N : INTEGER;
                     var OUTSTRNG1, OUTSTRNG2, OUTSTRNG3, OUTSTRNG4, OUTSTRNG5: STRING_80;
        := FINDPTR^.WORD;
      FINDPTR   := FINDPTR^.SUB;
      while ((X <> 1) and (FINDPTR <> NIL)) do
        begin
          FINDPTR := FINDPTR^.SAME;
          X := X - 1
        end;
        X := B;
        if FINDPTR = NIL then FLAG := FALSE
        else
          begin
            OUTSTRNG2 := FINDPTR^.WORD;
            FINDPTR   := FINDPTR^.SUB;
            while ((Y <> 1) and (FINDPTR <> NIL)) do
              begin
                FINDPTR := FINDPTR^.SAME;
                Y := Y - 1;
              end;
              Y := C;
              if FINDPTR = NIL then FLAG := FALSE
              else
                begin
                  OUTSTRNG3 := FINDPTR^.WORD;
                  FINDPTR   := FINDPTR^.SUB;
                  while ((Z <> 1) and (FINDPTR <> NIL)) do
                    begin
                      FINDPTR := FINDPTR^.SAME;
                      Z := Z - 1;
                    end;
                    Z := D;
                    if FINDPTR = NIL then FLAG := FALSE
                    else
                      begin
                        OUTSTRNG4 := FINDPTR^.WORD;
                        FINDPTR   := FINDPTR^.SUB;
                      end
                end
          end
    end;
  if FLAG then FINDBRANCH := TRUE
      else FINDBRANCH := FALSE
end;



{procedure PRINTTREE(var STEM : STACKTYPE);

var
  FLAGEND : BOOLEAN;
  Q,R,S,T,U : INTEGER;
  PRNTSTR1, PRNTSTR2, PRNTSTR3, PRNTSTR4, PRNTSTR5: STRING_40;



begin
  FLAGEND := FALSE;
  WRITELN('BEGIN PRINTING ALL COMBINATIONS:');
  Q :=1; R:=1; S:=1; T:=1;
  while not FLAGEND do begin
    if FINDBRANCH(Q,R,S,T,U, PRNTSTR1,PRNTSTR2,PRNTSTR3,PRNTSTR4,PRNTSTR5,STEM) then begin
      WRITE(PRNTSTR1+' ');
      WRITE(PRNTSTR2+' ');
      WRITE(PRNTSTR3+' ');
      WRITELN(PRNTSTR4);
      T := T + 1
    end
    else begin
      if(PRNTSTR1='EMPTY') then FLAGEND := TRUE
      else begin
        if(PRNTSTR2='EMPTY') then begin
          Q := Q+1;
          R := 1;
        end
          else begin
            if(PRNTSTR3='EMPTY') then begin
              R := R+1;
              S := 1
            end
              else begin
                if(PRNTSTR4='EMPTY') then begin
                  S := S+1;
                  T := 1
                end
              end
          end
      end
    end
  end
end;}






function SCANTREE(var WRKINT : INTEGER ; WRKSTR : STRING_80;
                  var BEGINPTR : STACKTYPE;
                  var SUBPTR   : STACKTYPE): boolean;

var
  SCANPTR  :  STACKTYPE;
  TRAILPTR :  STACKTYPE;

begin
  if (BEGINPTR = NIL) then begin
       SCANTREE := FALSE
     end
   else begin
     TRAILPTR := BEGINPTR;
     SCANPTR  := BEGINPTR;
     if (WRKINT <> SCANPTR^.LEVEL) then begin
       SCANPTR := SCANPTR^.SUB;
     end;
     if (SCANPTR = NIL) then
       begin
         SCANTREE := FALSE;
         SUBPTR := TRAILPTR
       end
       else begin
         while ((SCANPTR <> NIL) and (SCANPTR^.WORD <> WRKSTR)) do
           begin
             TRAILPTR := SCANPTR;
             SCANPTR := SCANPTR^.SAME
           end;
           if (SCANPTR = NIL) then begin
             SCANTREE := FALSE;
             SUBPTR := TRAILPTR
           end
           else begin
             SCANTREE := TRUE;
             SUBPTR := SCANPTR
           end
       end
   end
end;

function ISBRANCH(var ININT1 : INTEGER ; var INSTR1 : STRING_80;
                  var ININT2 : INTEGER ; var INSTR2 : STRING_80;
                  var ININT3 : INTEGER ; var INSTR3 : STRING_80;
                  var ININT4 : INTEGER ; var INSTR4 : STRING_80;
                  var ROOT   : STACKTYPE): boolean;

var
  ISPTR1, ISPTR2, ISPTR3, ISPTR4 : STACKTYPE;


begin
  ISBRANCH := FALSE;
  if SCANTREE(ININT1, INSTR1, ROOT, ISPTR1) then begin
    if SCANTREE(ININT2, INSTR2, ISPTR1, ISPTR2) then begin
      if SCANTREE(ININT3, INSTR3, ISPTR2, ISPTR3) then begin
        if SCANTREE(ININT4, INSTR4, ISPTR3, ISPTR4) then
          ISBRANCH := TRUE
        end
      end
    end
end;



procedure ADDELE(var WRKINT: INTEGER; var WRKSTR : STRING_80;
                 var BEGINPTR : STACKTYPE;
                 var SUBPTR   : STACKTYPE);

var
  ADDPTR   : STACKTYPE;

begin
  NEW(ADDPTR);
  ADDPTR^.LEVEL := WRKINT;
  ADDPTR^.WORD  := WRKSTR;
  ADDPTR^.SAME  := NIL;
  ADDPTR^.SUB   := NIL;
  if (BEGINPTR = NIL) then begin
    BEGINPTR := ADEUDóöUJƒ<QYIQJöh╘ü    %9AQH4(Çüò╣É4(Çüò▒═öüëò¥Ñ╕4(ÇÇö⌐àÿÇíAQIx╣1Y0Ç≡°üMU    AQIx╣1Y0ñü╤íò╕UE
        end
      end
    end
end;



procedure ADDELE(var WRKINT: INTEGER; var WRKSTR : STRING_80;
                 var BEGINPTR : STACKTYPE;
                 var SUBPTR   : STACKTYPE);

var
  ADDPTR   : STACKTYPE;

begin
  NEW(ADDPTR);
  ADDPTR^.LEVEL := WRKINT;
  ADDPTR^.WORD  := WRKSTR;
  ADDPTR^.SAME  := NIL;
  ADDPTR^.SUB   := NIL;
  if (BEGINPTR = NIL) then begin
    BEGINPTR :=$AEDUVS2LJ*Ñ*ÑCRPTV@┬.MQ╨ä"
èAíD¡╠üíD¡ÄlñL¼φ-┴íD    QA°s├30≡0É39°8≡ÇÉ≡0É38I≡0q: STRING_80;
                     var ROOT   : STACKTYPE);


var
  TEMPPTR1 : STACKTYPE;
  TEMPPTR2 : STACKTYPE;
  TEMPPTR3 : STACKTYPE;
  TEMPPTR4 : STACKTYPE;
  TEMPPTR5 : STACKTYPE;

begin
  if not (SCANTREE(ININT1, INSTR1, ROOT,     TEMPPTR1)) then
  ADDELE(ININT1, INSTR1,ROOT,    TEMPPTR1);
  if not (SCANTREE(ININT2, INSTR2, TEMPPTR1, TEMPPTR2)) then
  ADDELE(ININT2, INSTR2,TEMPPTR1,TEMPPTR2);
  if not (SCANTREE(ININT3, INSTR3, TEMPPTR2, TEMPPTR3)) then
  ADDELE(ININT3, INSTR3,TEMPPTR2,TEMPPTR3);
  if not (SCANTREE(ININT4, INSTR4, TEMPPTR3, TEMPPTR4)) then
  ADDELE(ININT4, INSTR4,TEMPPTR3,TEMPPTR4);
  if not (SCANTREE(ININT5, INSTR5, TEMPPTR4, TEMPPTR5)) then
  ADDELE(ININT5, INSTR5,TEMPPTR4,TEMPPTR5)
end;


procedure BREAKTREE(var STEM : STACKTYPE);

var
  BRKPTR    : STACKTYPE;
  STACKPTR  : STACKTYPE;
  WRKINT    : INTEGER;
  WRKSTR    : STRING_80;

begin
  ASSIGN (OUTFILE1, FileName1);
  REWRITE(OUTFILE1);
  MAKE(STACKPTR);
  PUSH(STEM, STACKPTR);
  while POP(BRKPTR, STACKPTR) do
    begin
      if (BRKPTR^.SAME <> NIL) then PUSH(BRKPTR^.SAME,STACKPTR);
      if (BRKPTR^.SUB  <> NIL) then PUSH(BRKPTR^.SUB, STACKPTR);
      WRKINT := BRKPTR^.LEVEL;
      WRKSTR := BRKPTR^.WORD;
      PUTREC(WRKINT, WRKSTR);
    end;
    CLOSE(OUTFILE1)
end;

procedure ADDLEAVES(var BRANCH  : STACKTYPE; var PASSLEAF: STACKTYPE;
                     var PASSFILE : TEXT);

var
  TEMPLEAF   :  STACKTYPE;
  ININT      :  INTEGER;
  INSTR      :  STRING_80;
  FLAGEND    :  BOOLEAN;
  INFILE     :  TEXT;

begin
    if not GETREC(ININT, INSTR, PASSFILE) then PASSLEAF := NIL
    else
      begin
        NEW(TEMPLEAF);
        TEMPLEAF^.SAME:=NIL;
        TEMPLEAF^.SUB:=NIL;
        TEMPLEAF^.LEVEL  := ININT;
        TEMPLEAF^.WORD := INSTR;
        if TEMPLEAF^.LEVEL > BRANCH^.LEVEL then
          begin
            BRANCH^.SUB  := TEMPLEAF;
            ADDLEAVES(BRANCH^.SUB, PASSLEAF, PASSFILE);
            TEMPLEAF := PASSLEAF
          end;
        if ((TEMPLEAF <> NIL) AND (TEMPLEAF^.LEVEL = BRANCH^.LEVEL)) then
          begin
            BRANCH^.SAME := TEMPLEAF;
            ADDLEAVES(BRANCH^.SAME, PASSLEAF, PASSFILE);
            TEMPLEAF := PASSLEAF
          end;
        if ((TEMPLEAF <> NIL) AND (TEMPLEAF^.LEVEL < BRANCH^.LEVEL)) then
          begin
            PASSLEAF := TEMPLEAF
          end;
     end;
end;

procedure RECALLTREE (var LEAF  :  STACKTYPE);

  var
    TEMPREC, PASSREC : STACKTYPE;
    WORKINT  : INTEGER;
    WORKSTR  : STRING_80;
    INFILE   : TEXT;

begin

        WRITELN('NAME OF DATA FILE [.TRE WILL BE ADDED]');
        READ(NAME);
        ASSIGN(INFILE,NAME +'.TRE');
        RESET(INFILE);
        X :=GETREC(WORKINT,WORKSTR,INFILE);
        NEW(TEMPREC);
        TEMPREC^.SAME:=NIL;
        TEMPREC^.SUB:=NIL;
        TEMPREC^.LEVEL := WORKINT;
        TEMPREC^.WORD := WORKSTR;
        LEAF  :=  TEMPREC;
        PASSREC := NIL;
        ADDLEAVES(LEAF, PASSREC, INFILE);
        CLOSE(INFILE)
end;
begin
  make(root);
  word1:='book';
  TextMode(C80);
  DOLOOP := true;
  FLAGADD := true;
  ClrScr;
  GotoXY(1,25);
  Write('ä = Ctrl-a   ü = Ctrl-u  ö = Ctrl-o  ß = Alt-s  Ä = Alt-a  Ü = Alt-u   Ö = Alt-o');
  While DOLOOP do
  begin
  WORD :='EMPTY';
  Num1 := 25;
  CreateWindow(1,1,80,22);
  ClrScr;
  GotoXY(1,1);
  WRITELN('                           QUESTION DATA GENERATOR');
  WRITELN('  This program creates data files of the questions and answers to be');
  WRITELN('  maniplated
begin
  make(root);
  word1:='book';
  TextMode(C80);
  DOLOOP := true;
  FLAGADD := true;
  ClrScr;
  GotoXY(1,25);
  Write('ä = Ctrl-a   ü = Ctrl-u  ö = Ctrl-o  ß = Alt-s  Ä = Alt-a  Ü = Alt-u   Ö = Alt-o');
  While DOLOOP do
  begin
  WORD :='EMPTY';
  Num1 := 25;
  CreateWindow(1,1,80,22);
  ClrScr;
  GotoXY(1,1);
  WRITELN('                           QUESTION DATA GENERATOR');
  WRITELN('  This program creates data files of the questions and answers to be');
  WRITELN('  maniplated gth ');
  WRITELN('  of any data string is 80 characters. Should you exceed the maximum,');
  WRITELN('  the excess will not be accepted. First the program asks for the question');
  WRITELN('  which will be entered by pressing return.  Then the possible answers ');
  WRITELN('  are to be entered one element at a time. If more than one answer is desired');
  WRITELN('  enter "Y" or press return to enter another set of answers. All answers will');
  WRITELN('  be coded to correspond to their respective questions.');
  WRITELN('  YOU MUST HAVE COMMAND.COM ON YOUR DISK TO BE ABLE TO SAVE YOUR FILE.');
  WRITELN('  To enter the lesson name, use six or less characters, since');
  WRITELN('  the file name itself can be no longer than eight character and the lesson');
  WRITE('  number will be added. Enter name and press return:');
  READLN(LessonName);
  WRITE('  Enter the lesson number and press return:');
  READLN(LessonNumber);
  FileName := LessonName+LessonNumber +'.DAT';
  ASSIGN (OUTFILE, FileName);
  REWRITE (OUTFILE);
  Counter1:=1;
   savestr1 := 'EMPTY'; savestr2 := 'EMPTY';
   savestr3 := 'EMPTY'; savestr4 := 'EMPTY';
   savestr5 := 'EMPTY';
    ClrScr;
    Word1 := 'book';
    while WORD1 <> SENTINEL do
      begin
        WRITELN('Input data and press return. PRESS RETURN ALONE TO QUIT.');
        WRITELN ('Input word(s) or sentence ',counter1,'.');
        Horiz := WhereX;
        Vert  := WhereY;
        INPUTLINE (WORD1);
        WRITELN (OUTFILE, WORD1);
        WRITELN;
             flagadd := true;
             if WORD1 = SENTINEL then flagadd := false;
             while flagadd do begin
                num1 := 1; num2 := 2; num3 := 3; num4 := 4; num5 := 5;
                writeln('CURRENT FIRST ELEMENT IS ',savestr1);
                writeln('ENTER NEW FIRST ELEMENT =>');
                horiz:=WhereX;
                Vert := WhereY;
                ClrEol;
                inputline(verb);
                if verb = '' then
                    verb := savestr1
                else
                    savestr1 := verb;
                writeln;
                writeln('CURRENT SECOND ELEMENT IS ',savestr2);
                writeln('ENTER NEW SECOND ELEMENT =>');
                horiz:=WhereX;
                Vert := WhereY;
                ClrEol;
                inputline(noun);
                if noun = '' then
                    noun := savestr2
                else
                    savestr2 := noun;
                writeln;
                writeln('CURRENT THIRD ELEMENT IS ',savestr3);
                writeln('ENTER NEW THIRD ELEMENT =>');
                horiz:=WhereX;
                Vert := WhereY;
                ClrEol;
                inputline(prep);
                if prep = '' then
                    prep := savestr3
                else
                    savestr3 := prep;
                writeln;
                writeln('CURRENT FOURTH ELEMENT IS ',savestr4);
                writeln('ENTER NEW FOURTH ELEMENT =>');
                horiz:=WhereX;
                Vert := WhereY;
                ClrEol;
                inputline(art);
                {if art = '' then
                    art := savestr4
                else}
                    savestr4 := art;
                str(Counter1, Question);
                createbrch(num1,verb,num2,noun,num3,prep,num4,art,num5,Question,root);
                writeln(verb + ' ',noun + ' ',prep + ' ',art);
                write('ADD ANOTHER BRANCH Y/N');
                readln(cont);
                if ((cont = 'n')or(cont='N')) then
                  begin
                    flagadd := false;
                    ClrScr
                  end
                  else
                    begin
                      ClearRest;
                      GotoXY(1,4)
                    end
            end;
            counter1 := counter1+1;
          end;
 CLOSE (OUTFILE);
        begin
             FileName1 := LessonName+LessonNumber +'.TRE';
             breaktree(ROOT);
          end;
  ClrScr;
  GotoXY(15,10);
  write('Willst du noch eine Aufgabe machen? ("J" oder "N")');
      input := Readkey;
      If not ((input = 'J')OR(input='j'))
      then doloop := false;
      ClrScr;
   end; {of outer Doloop}
   window(1,1,80,25);
   ClrScr;
   GotoXY(16,10);
   writeln('Ende. Bis zur nächsten Aufgabe! Tschüß!');
   GotoXY(1,23);
   TextMode(C80)
end.