home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 18 / alk80x43.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-10-03  |  46.1 KB  |  1,255 lines
  1. {$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V+}
  2. {$M 65520,10590,10590}
  3.  
  4.                 {     Juergen Linz , Herzogstandstr. 32    }
  5.                 {   8500 Nuernberg 50 , Tel. 0911 / 84314  }
  6.                 {               03/89 - 05/89              }
  7.  
  8. PROGRAM ALKAN_NOMENKLATUR;
  9.  
  10. USES CRT;
  11.  
  12. TYPE
  13.     zchkett1 = STRING[60];
  14.     zchkett2 = STRING[255];
  15.     zeiger   = ^c_kette;
  16.     c_kette  = RECORD
  17.                      posit,laenge,niveau,anso,anlibr,anrebr,
  18.                      sumpos,revpos,sumanca,komplex           : INTEGER;
  19.                      anca                                    : zchkett1;
  20.                      atome                                   : zchkett2;
  21.                      vater,sohn,libr,rebr                    : zeiger;
  22.                END;
  23.     c_atom   = RECORD
  24.                      bind      : INTEGER;
  25.                      in_kette  : zeiger;
  26.                END;
  27.  
  28. VAR
  29.     x,y,ax,ay,dx,dy,nx,ny,sx,sy,
  30.     stelle,wertig,namlen          : INTEGER;
  31.     alt_anca                      : zchkett1;
  32.     alkan_name                    : zchkett2;
  33.     ketten_name                   : ARRAY[0 .. 70] OF STRING[15];
  34.     prfix1,prfix2                 : ARRAY[2 .. 20] OF STRING[15];
  35.     akt_atom                      : ARRAY [0 .. 40,0 .. 20] OF c_atom;
  36.     akt_kette,alte_kette,
  37.     wurzel,heapstart              : zeiger;
  38.  
  39. PROCEDURE namen_ermitteln(ptr : zeiger);
  40.  
  41. VAR
  42.    posstr  : STRING[2];
  43.  
  44. BEGIN
  45.      IF (ptr<>NIL) THEN
  46.      BEGIN
  47.           STR(ptr^.posit,posstr) ; alkan_name := alkan_name + posstr + '-';
  48.           IF ((ptr^.niveau>0) AND (ptr^.sohn<>NIL))
  49.              THEN alkan_name := alkan_name + '(';
  50.           namen_ermitteln(ptr^.sohn);
  51.           IF (COPY(alkan_name,LENGTH(alkan_name),1)=')')
  52.              THEN alkan_name := alkan_name + '-';
  53.           alkan_name := alkan_name + ketten_name[ptr^.laenge] + 'YL';
  54.           IF ((ptr^.niveau>0) AND (ptr^.sohn<>NIL))
  55.              THEN alkan_name := alkan_name + ')';
  56.           IF (ptr^.rebr<>NIL) THEN alkan_name := alkan_name + '-';
  57.           namen_ermitteln(ptr^.rebr);
  58.      END;
  59. END;
  60.  
  61. PROCEDURE namteil_finden(VAR name : zchkett2;
  62.                          VAR an,en,ver : INTEGER; proc : INTEGER); FORWARD;
  63.  
  64. PROCEDURE alphsort(VAR name : zchkett2 ; procnr : INTEGER);
  65.  
  66. VAR
  67.    an1,en1,ver1,an2,en2,ver2 : INTEGER;
  68.    hstr1,hstr2,hstr3,hstr4   : zchkett2;
  69.  
  70. BEGIN
  71.      an1 := 1 ; en1 := 0 ; ver1 := 0;
  72.      namteil_finden(name,an1,en1,ver1,procnr);
  73.      hstr1 := COPY(name,1,en1-an1+1);
  74.      name := COPY(name,en1+1,LENGTH(name)-en1);
  75.      WHILE ((POS('L',name)<>0) AND (POS('L',name)<>LENGTH(name))) DO
  76.      BEGIN
  77.           an1 := 1;en1 := 0;ver1 := 0;an2 := 1;en2 := 0;ver2 := 0;
  78.           namteil_finden(name,an1,en1,ver1,procnr);
  79.           WHILE (an2<LENGTH(hstr1)) DO
  80.           BEGIN
  81.                namteil_finden(hstr1,an2,en2,ver2,0);
  82.                hstr2 := COPY(name,an1,en1-an1+1) ; hstr3 := hstr2;
  83.                IF (COPY(hstr3,LENGTH(hstr3)-1,1)=')')
  84.                   THEN hstr3 := COPY(hstr3,1,LENGTH(hstr3)-2) + ']-';
  85.                IF (COPY(hstr2,LENGTH(hstr2),1)<>'-') THEN
  86.                BEGIN
  87.                     hstr2 := hstr2 + '-' ; hstr3 := hstr3 + '-';
  88.                END;
  89.                hstr4 := COPY(hstr1,ver2,en2-ver2+1);
  90.                IF (COPY(hstr4,LENGTH(hstr4)-1,1)=')')
  91.                   THEN hstr4 := COPY(hstr4,1,LENGTH(hstr4)-2) + ']-';
  92.                IF (COPY(hstr3,ver1-an1+1,LENGTH(hstr3)-ver1+an1) < hstr4)
  93.                THEN
  94.                BEGIN
  95.                     hstr1 := COPY(hstr1,1,an2-1) + hstr2
  96.                               + COPY(hstr1,an2,LENGTH(hstr1)-an2+1);
  97.                     name := COPY(name,en1+1,LENGTH(name)-en1);
  98.                     an2 := LENGTH(hstr1);
  99.                END
  100.                ELSE
  101.                BEGIN
  102.                     an2 := en2 + 1;
  103.                     IF (an2>LENGTH(hstr1)) THEN
  104.                     BEGIN
  105.                          hstr1 := hstr1 + COPY(name,an1,en1-an1+1);
  106.                          name := COPY(name,en1+1,LENGTH(name)-en1);
  107.                          an2 := LENGTH(hstr1);
  108.                     END;
  109.                END;
  110.                en2 := 0 ; ver2 := 0;
  111.           END;
  112.      END;
  113.      IF (COPY(hstr1,LENGTH(hstr1),1)='-')
  114.         THEN hstr2 := COPY(hstr1,1,LENGTH(hstr1)-1) ELSE hstr2 := hstr1;
  115.      IF (COPY(hstr2,LENGTH(hstr2),1)=')') THEN
  116.      BEGIN
  117.           hstr2 := hstr2 + '-' ; en1 := en1 + 1;
  118.      END;
  119.      name := hstr2 + name;
  120. END;
  121.  
  122. PROCEDURE namen_verkuerzen(VAR name : zchkett2 ; procnr : INTEGER);
  123.  
  124. VAR
  125.    an1,en1,ver1,an2,en2,ver2,anzahl,shift : INTEGER;
  126.    hstr                                   : zchkett2;
  127.  
  128. BEGIN
  129.      an1 := 1 ; en1 := 0 ; ver1 := 0;
  130.      WHILE ((POS('L',name)<>0) AND (an1<LENGTH(name))) DO
  131.      BEGIN
  132.           anzahl := 1 ; namteil_finden(name,an1,en1,ver1,procnr);
  133.           an2 := en1 + 1 ; en2 := 0 ; ver2 := 0 ; shift := 0;
  134.           WHILE (an2<LENGTH(name)) DO
  135.           BEGIN
  136.                namteil_finden(name,an2,en2,ver2,procnr);
  137.                IF (ver2<an2) THEN ver2 := an2;
  138.                hstr := COPY(name,ver2,en2-ver2+1);
  139.                IF ((en2<>LENGTH(name)) AND
  140.                   (COPY(hstr,LENGTH(hstr),1)<>'-'))
  141.                   THEN hstr := hstr + '-';
  142.                IF (COPY(name,ver1,en1-ver1+1) = hstr) THEN
  143.                BEGIN
  144.                     anzahl := anzahl + 1;
  145.                     name := COPY(name,1,an1 - 1)
  146.                           + COPY(name,an1,ver1-an1-1) + ','
  147.                           + COPY(name,an2,ver2-an2-1)
  148.                           + COPY(name,ver1-1,en1-ver1+2)
  149.                           + COPY(name,en1+1,an2-en1-1)
  150.                           + COPY(name,en2+1,LENGTH(name)-en2+1);
  151.                     ver1 := ver1 + ver2 - an2 ; en1 := en1 + ver2 - an2;
  152.                     an2 := en1 + 1;
  153.                END
  154.                ELSE an2 := en2 + 1;
  155.           END;
  156.           IF (anzahl>1) THEN
  157.              IF (POS('(',COPY(name,an1,en1-an1+1))<>0) THEN
  158.              BEGIN
  159.                   name := COPY(name,1,an1-1) + COPY(name,an1,ver1-an1-1)
  160.                           + '-' + prfix2[anzahl] + '-'
  161.                           + COPY(name,ver1,LENGTH(name)-ver1+2);
  162.                   shift := LENGTH(prfix2[anzahl]) + 1;
  163.              END
  164.              ELSE
  165.              BEGIN
  166.                   name := COPY(name,1,an1-1) + COPY(name,an1,ver1-an1-1)
  167.                           + '-' + prfix1[anzahl]
  168.                           + COPY(name,ver1,LENGTH(name)-ver1+2);
  169.                   shift := LENGTH(prfix1[anzahl]);
  170.              END;
  171.           an1 := en1 + 1 + shift ; en1 := 0 ; ver1 := 0;
  172.      END;
  173.      IF (COPY(hstr,LENGTH(hstr),1)='-')
  174.      THEN hstr := ''
  175.      ELSE IF (COPY(name,LENGTH(name)-LENGTH(hstr)-1,1)=')')
  176.           THEN name := COPY(name,1,LENGTH(name)-LENGTH(hstr)) + hstr
  177.           ELSE IF (COPY(name,LENGTH(name)-LENGTH(hstr),1)='-')
  178.                THEN name := COPY(name,1,LENGTH(name)-LENGTH(hstr)-1)+hstr;
  179. END;
  180.  
  181. PROCEDURE namteil_finden;
  182.  
  183. VAR
  184.    kl_auf,kl_zu,start,n : INTEGER;
  185.    hstr                 : zchkett2;
  186.    flag                 : BOOLEAN;
  187.  
  188. BEGIN
  189.      kl_auf := 0 ; kl_zu := 0 ; start := 0 ; flag := FALSE ; en := an;
  190.      WHILE ((flag=FALSE) AND (en<LENGTH(name))) DO
  191.      BEGIN
  192.           en := en + 1;
  193.           IF (COPY(name,en,1)='(') THEN
  194.           BEGIN
  195.                kl_auf := kl_auf + 1 ; IF (kl_auf=1) THEN start := en;
  196.           END;
  197.           IF (COPY(name,en,1)=')') THEN kl_zu := kl_zu + 1;
  198.           IF ((proc<>0) AND (kl_auf<>0) AND (kl_auf=kl_zu)) THEN
  199.           BEGIN
  200.                hstr := COPY(name,start+1,en-start-1);
  201.                CASE proc OF
  202.                    1 : BEGIN
  203.                             alphsort(hstr,proc);
  204.                             name := COPY(name,an,start-an+1) + hstr
  205.                                   + COPY(name,en,LENGTH(name)-en+start);
  206.                             IF (COPY(name,en,1)='L') THEN en := en + 1;
  207.                             IF (COPY(name,en,1)='-') THEN en := en - 1;
  208.                        END;
  209.                    2 : BEGIN
  210.                             namen_verkuerzen(hstr,proc);
  211.                             name := COPY(name,1,start) + hstr
  212.                                   + COPY(name,en,LENGTH(name)-en+start);
  213.                             en := start + LENGTH(hstr) + 1;
  214.                        END;
  215.                END;
  216.           END;
  217.           IF (((COPY(name,en,1)=')') OR
  218.               (COPY(name,en,1)='L')) AND (kl_auf=kl_zu)) THEN flag := TRUE;
  219.      END;
  220.      IF (COPY(name,en+1,1)='-') THEN en := en + 1;
  221.      n := en - 3;
  222.      WHILE (n>an) DO
  223.      BEGIN
  224.           IF ((kl_auf=0) AND (COPY(name,n,1)='-')) THEN
  225.           BEGIN
  226.                ver := n + 1 ; n := an;
  227.           END
  228.           ELSE IF ((kl_auf<>0) AND
  229.                    ((COPY(name,n,1)='L') OR (COPY(name,n,1)='-'))) THEN
  230.                BEGIN
  231.                     ver := n + 1 ; n := an;
  232.                END;
  233.           n := n - 1;
  234.      END;
  235.      IF ((proc=2) AND (POS('(',COPY(name,an,en-an+1))<>0))
  236.         THEN ver := start;
  237. END;
  238.  
  239. PROCEDURE alkan_benennen;
  240.  
  241. BEGIN
  242.      alkan_name := '' ; namen_ermitteln(wurzel);
  243.      alkan_name := COPY(alkan_name,3,LENGTH(alkan_name)-4) + 'AN';
  244.      namlen := LENGTH(alkan_name);
  245.      alphsort(alkan_name,1) ; namen_verkuerzen(alkan_name,2);
  246.      GOTOXY(1,41) ; CLREOL ; GOTOXY(1,42) ; CLREOL;
  247.      GOTOXY(1,43) ; CLREOL;
  248.      GOTOXY(1,41) ; WRITE(alkan_name) ; GOTOXY(x+1,y+1);
  249. END;
  250.  
  251. PROCEDURE neue_kette_initialisieren;
  252.  
  253. BEGIN
  254.      WITH akt_kette^ DO
  255.      BEGIN
  256.           posit := 0 ; laenge := 0 ; niveau := 0 ; anso := 0;
  257.           anlibr := 0 ; anrebr := 0 ; sumpos := 0 ; revpos := 0;
  258.           anca := '' ; sumanca := 0 ; komplex := 0 ; atome := '';
  259.           vater := NIL ; sohn := NIL ; libr := NIL ; rebr := NIL;
  260.      END;
  261. END;
  262.  
  263. PROCEDURE initialisieren;
  264.  
  265. CONST
  266.      zahlwort : ARRAY[0 .. 9] OF STRING[5] = ('','HEN','DO','TRI',
  267.                 'TETRA','PENTA','HEXA','HEPTA','OCTA','NONA');
  268.  
  269. VAR
  270.      m,n    : INTEGER;
  271.      strich : STRING[80];
  272.  
  273. BEGIN
  274.      CLRSCR ; ketten_name[0] := '';
  275.      ketten_name[10] := 'DEC' ; ketten_name[20] := 'COS';
  276.      ketten_name[30] := 'TRIACONT' ; ketten_name[40] := 'TETRACONT';
  277.      ketten_name[50] := 'PENTACONT' ; ketten_name[60] := 'HEXACONT';
  278.      FOR m := 0 TO 6 DO
  279.          FOR n := 0 TO 9 DO
  280.              ketten_name[m*10+n] := zahlwort[n] + ketten_name[m*10];
  281.      ketten_name[1] := 'METH' ; ketten_name[2] := 'ETH';
  282.      ketten_name[3] := 'PROP' ; ketten_name[4] := 'BUT';
  283.      FOR n := 5 TO 9 DO
  284.          ketten_name[n]:=COPY(ketten_name[n],1,LENGTH(ketten_name[n])-1);
  285.      ketten_name[20] := 'EICOS' ; ketten_name[21] := 'HENEICOS';
  286.      ketten_name[11] := 'UNDEC';
  287.      FOR n := 2 TO 20 DO
  288.          IF (n<10) THEN
  289.                    BEGIN
  290.                         prfix1[n] := zahlwort[n];
  291.                         prfix2[n] := prfix1[n] + 'KIS';
  292.                    END
  293.                    ELSE
  294.                    BEGIN
  295.                         prfix1[n] := ketten_name[n] + 'A';
  296.                         prfix2[n] := COPY(ketten_name[n],1,
  297.                                      LENGTH(ketten_name[n])-1) + 'KAKIS';
  298.                    END;
  299.      prfix1[2] := 'DI' ; prfix2[2] := 'BIS' ; prfix2[3] := 'TRIS';
  300.      strich := '' ; FOR n := 1 TO 80 DO strich := strich + '-';
  301.      FOR x := 0 TO 40 DO
  302.          FOR y := 0 TO 20 DO
  303.              akt_atom[x,y].bind := 0 ; akt_atom[x,y].in_kette := NIL;
  304.      MARK(heapstart) ; NEW(wurzel);
  305.      akt_kette := wurzel ; alte_kette := akt_kette;
  306.      neue_kette_initialisieren;
  307.      akt_kette^.laenge := 1 ; akt_kette^.atome :='0018';
  308.      akt_atom[0,9].in_kette := akt_kette;
  309.      x := 0 ; y := 18 ; dx := 1 ; dy := 0 ; sx := 0 ; sy := 9 ; wertig := 0;
  310.      GOTOXY(1,40) ; WRITELN(strich) ; GOTOXY(x+1,y+1) ; WRITE('C');
  311.      alkan_benennen;
  312. END;
  313.  
  314. PROCEDURE wertigkeit(ax,ay : INTEGER);
  315.  
  316. VAR
  317.    bit,richtung : INTEGER;
  318.  
  319. BEGIN
  320.      dx := 0 ; dy := 0 ; richtung := 0;
  321.      FOR bit := 0 TO 3 DO
  322.           IF (((akt_atom[ax,ay].bind) AND (1 SHL bit))<>0) THEN
  323.           BEGIN
  324.                wertig := wertig + 1 ; richtung := bit;
  325.           END;
  326.      CASE richtung OF
  327.           0 : dx := -1;
  328.           1 : dy := 1;
  329.           2 : dx := 1;
  330.           3 : dy := -1;
  331.      END;
  332. END;
  333.  
  334. PROCEDURE hauptkette_umdrehen;
  335.  
  336. VAR
  337.    pos,hilfe        : INTEGER;
  338.    hstr             : zchkett2;
  339.    zgr1,zgr2,zgr3   : zeiger;
  340.  
  341. BEGIN
  342.      IF (wurzel^.anso>0) THEN
  343.      BEGIN
  344.           zgr1 := wurzel^.sohn;
  345.           REPEAT
  346.                 zgr1^.posit := wurzel^.laenge - zgr1^.posit + 1;
  347.                 zgr2 := zgr1^.rebr ; zgr1^.rebr := zgr1^.libr;
  348.                 zgr1^.libr := zgr2 ; hilfe := zgr1^.anrebr;
  349.                 zgr1^.anrebr := zgr1^.anlibr ; zgr1^.anlibr := hilfe;
  350.                 IF (zgr2 = NIL) THEN zgr3 := zgr1;
  351.                 zgr1 := zgr2;
  352.           UNTIL (zgr1 = NIL);
  353.           wurzel^.sohn := zgr3 ; hilfe := wurzel^.sumpos;
  354.           wurzel^.sumpos := wurzel^.revpos ; wurzel^.revpos := hilfe;
  355.           pos := LENGTH(wurzel^.atome) - 3 ; hstr := '';
  356.           WHILE (pos>0) DO
  357.           BEGIN
  358.                hstr := hstr + COPY(wurzel^.atome,pos,4) ; pos := pos - 4;
  359.           END;
  360.           wurzel^.atome := hstr;
  361.      END;
  362. END;
  363.  
  364. PROCEDURE sumpos_gleich_revpos;
  365.  
  366. VAR
  367.    sumpos1,revpos1,sumpos2,revpos2 : INTEGER;
  368.    zgr1,zgr2                       : zeiger;
  369.  
  370. BEGIN
  371.      IF (wurzel^.anso>1) THEN
  372.      BEGIN
  373.           sumpos1 := 0 ; sumpos2 := 0 ; revpos1 := 0 ; revpos2 := 0;
  374.           zgr2 := wurzel^.sohn ; zgr1 := zgr2^.rebr;
  375.           WHILE (zgr1<>NIL) DO
  376.           BEGIN
  377.                IF ((ketten_name[zgr1^.laenge] < ketten_name[zgr2^.laenge])
  378.                OR ((ketten_name[zgr1^.laenge] = ketten_name[zgr2^.laenge])
  379.                AND (zgr1^.komplex<zgr2^.komplex))) THEN zgr2 := zgr1;
  380.                zgr1 := zgr1^.rebr;
  381.           END;
  382.           zgr1 := wurzel^.sohn;
  383.           WHILE (zgr1<>NIL) DO
  384.           BEGIN
  385.                IF (ketten_name[zgr1^.laenge] = ketten_name[zgr2^.laenge])
  386.                   THEN IF (zgr1^.komplex = zgr2^.komplex)
  387.                           THEN BEGIN
  388.                                     sumpos1 := sumpos1 + zgr1^.posit;
  389.                                     revpos1 := revpos1 + wurzel^.laenge
  390.                                                - zgr1^.posit + 1;
  391.                                END
  392.                                ELSE
  393.                                BEGIN
  394.                                     sumpos2 := sumpos2 + zgr1^.posit;
  395.                                     revpos2 := revpos2 + wurzel^.laenge
  396.                                                - zgr1^.posit + 1;
  397.                                END;
  398.                zgr1 := zgr1^.rebr;
  399.           END;
  400.           IF (revpos1<sumpos1) THEN hauptkette_umdrehen;
  401.           IF (revpos1=sumpos1)
  402.              THEN IF (revpos2<sumpos2) THEN hauptkette_umdrehen;
  403.      END;
  404. END;
  405.  
  406. PROCEDURE anca_str_neu(VAR neu_anca : zchkett1;lang1,lang2 : INTEGER);
  407.  
  408. VAR
  409.    pos,h0,h1,h2 : INTEGER;
  410.    l1,l2        : STRING[3];
  411.  
  412. BEGIN
  413.      STR(lang1,l1) ; STR(lang2,l2);
  414.      WHILE (LENGTH(l1)<3) DO l1 := '0' + l1;
  415.      WHILE (LENGTH(l2)<3) DO l2 := '0' + l2 ; IF (l2='000') THEN l2 := '';
  416.      pos := 1 ; VAL(l1,h2,h0) ; VAL(COPY(neu_anca,pos,3),h1,h0);
  417.      WHILE ((h2<>h1) AND (pos<LENGTH(neu_anca))) DO
  418.      BEGIN
  419.           pos := pos + 3 ; VAL(COPY(neu_anca,pos,3),h1,h0);
  420.      END;
  421.      neu_anca := COPY(neu_anca,1,pos-1)
  422.                  + COPY(neu_anca,pos+3,LENGTH(neu_anca)-pos-2);
  423.      pos := 1 ; VAL(l2,h2,h0) ; VAL(COPY(neu_anca,pos,3),h1,h0);
  424.      WHILE ((h2>h1) AND (pos<LENGTH(neu_anca))) DO
  425.      BEGIN
  426.           pos := pos + 3 ; VAL(COPY(neu_anca,pos,3),h1,h0);
  427.      END;
  428.      neu_anca := COPY(neu_anca,1,pos-1) + l2
  429.                  + COPY(neu_anca,pos,LENGTH(neu_anca)-pos+1);
  430. END;
  431.  
  432. PROCEDURE ketten_vergleich(VAR vater,sohn : zeiger);
  433.  
  434. VAR
  435.    pos_vater,pos_sohn,lang_vater,lang_sohn,niv_vater,niv_sohn,
  436.    anso_vater,anso_sohn,anlibr_vater,anlibr_sohn,
  437.    anrebr_vater,anrebr_sohn,sumpos_vater,sumpos_sohn,
  438.    revpos_vater,revpos_sohn,sumanca_vater,sumanca_sohn,
  439.    komplex_vater,komplex_sohn,pos,hilfe                    : INTEGER;
  440.    anca_vater,anca_sohn                                    : zchkett1;
  441.    atome_vater,atome_sohn,atom_neu                         : zchkett2;
  442.    atom1,atom2                                             : STRING[4];
  443.    flag,flag1,flag2                                        : BOOLEAN;
  444.    zgr1,zgr2,zgr3                                          : zeiger;
  445.  
  446. PROCEDURE neue_kettendaten_berechnen;
  447.  
  448. PROCEDURE komplex_vater_errechnen(ptr : zeiger);
  449.  
  450. BEGIN
  451.      IF (ptr<>NIL) THEN
  452.      BEGIN
  453.           komplex_vater_errechnen(ptr^.sohn);
  454.           komplex_vater := komplex_vater + (ptr^.niveau + 1) * ptr^.laenge;
  455.           komplex_vater_errechnen(ptr^.rebr);
  456.      END;
  457. END;
  458.  
  459. PROCEDURE komplex_sohn_errechnen(ptr : zeiger);
  460.  
  461. BEGIN
  462.      IF (ptr<>NIL) THEN
  463.      BEGIN
  464.           komplex_sohn_errechnen(ptr^.sohn);
  465.           komplex_sohn := komplex_sohn + (ptr^.niveau - 1) * ptr^.laenge;
  466.           komplex_sohn_errechnen(ptr^.rebr);
  467.      END;
  468. END;
  469.  
  470. BEGIN
  471.      pos_vater := sohn^.posit ; pos_sohn := vater^.posit;
  472.      lang_vater := vater^.laenge - sohn^.posit;
  473.      niv_vater := sohn^.niveau ; niv_sohn := vater^.niveau;
  474.      anso_vater := vater^.anso - sohn^.anlibr - 1;
  475.      anlibr_vater := sohn^.anlibr;anlibr_sohn := vater^.anlibr;
  476.      anrebr_vater := sohn^.anso ; anrebr_sohn := vater^.anrebr;
  477.      atom_neu := COPY(vater^.atome,1,sohn^.posit*4);
  478.      atome_vater := COPY(vater^.atome,sohn^.posit*4+1,
  479.                         LENGTH(vater^.atome)-sohn^.posit*4);
  480.      atome_sohn := atom_neu + sohn^.atome;
  481.      sumpos_vater := vater^.sumpos - sohn^.posit;
  482.      revpos_vater := vater^.revpos - (vater^.laenge - sohn^.posit + 1);
  483.      sumpos_sohn := sohn^.anso * sohn^.posit + sohn^.sumpos + pos_vater;
  484.      revpos_sohn := sohn^.revpos + lang_sohn - pos_vater + 1;
  485.      alt_anca := vater^.anca;
  486.      anca_str_neu(alt_anca,sohn^.sumanca+sohn^.laenge,0);
  487.      anca_vater := alt_anca ; anca_sohn := sohn^.anca;
  488.      sumanca_vater := vater^.sumanca - (sohn^.sumanca + sohn^.laenge);
  489.      sumanca_sohn := sohn^.sumanca;
  490.      komplex_vater := 0 ; komplex_sohn := 0;
  491.      zgr1 := sohn ; sohn := sohn^.libr;
  492.      WHILE (sohn<>NIL) DO
  493.      BEGIN
  494.           sumpos_vater := sumpos_vater - sohn^.posit;
  495.           sumpos_sohn := sumpos_sohn + sohn^.posit;
  496.           revpos_vater := revpos_vater - (vater^.laenge-sohn^.posit+1);
  497.           revpos_sohn := revpos_sohn + lang_sohn - sohn^.posit+1;
  498.           alt_anca := anca_vater;
  499.           anca_str_neu(alt_anca,sohn^.sumanca+sohn^.laenge,0);
  500.           anca_vater := alt_anca;
  501.           alt_anca := anca_sohn;
  502.           anca_str_neu(alt_anca,0,sohn^.sumanca+sohn^.laenge);
  503.           anca_sohn := alt_anca;
  504.           sumanca_vater := sumanca_vater - (sohn^.sumanca + sohn^.laenge);
  505.           sumanca_sohn := sumanca_sohn + sohn^.sumanca + sohn^.laenge;
  506.           komplex_sohn := komplex_sohn + sohn^.komplex
  507.                           + sohn^.laenge * sohn^.niveau;
  508.           sohn := sohn^.libr;
  509.      END;
  510.      sohn := zgr1 ; zgr1 := sohn^.rebr;
  511.      atom1 := COPY(zgr1^.vater^.atome,4*(zgr1^.posit-1)+1,4);
  512.      atom2 := COPY(sohn^.vater^.atome,4*(sohn^.posit-1)+1,4);
  513.      IF ((zgr1<>NIL) AND (atom1 = atom2)) THEN
  514.      BEGIN
  515.           anso_vater := anso_vater - 1 ; anrebr_vater := anrebr_vater + 1;
  516.           sumpos_vater := sumpos_vater - zgr1^.posit;
  517.           sumpos_sohn := sumpos_sohn + zgr1^.posit;
  518.           revpos_vater := revpos_vater-(vater^.laenge-zgr1^.posit+1);
  519.           revpos_sohn := revpos_sohn + lang_sohn - zgr1^.posit + 1;
  520.           alt_anca := anca_vater;
  521.           anca_str_neu(alt_anca,zgr1^.sumanca+zgr1^.laenge,0);
  522.           anca_vater := alt_anca;
  523.           alt_anca := anca_sohn;
  524.           anca_str_neu(alt_anca,0,zgr1^.sumanca+zgr1^.laenge);
  525.           anca_sohn := alt_anca;
  526.           sumanca_vater := sumanca_vater-(zgr1^.sumanca+zgr1^.laenge);
  527.           sumanca_sohn := sumanca_sohn + zgr1^.sumanca + zgr1^.laenge;
  528.           komplex_sohn := komplex_sohn + zgr1^.komplex
  529.                           + zgr1^.laenge * zgr1^.niveau;
  530.      END;
  531.      alt_anca := anca_sohn;
  532.      anca_str_neu(alt_anca,0,sumanca_vater+lang_vater);
  533.      anca_sohn := alt_anca;
  534.      sumanca_sohn := sumanca_sohn + sumanca_vater + lang_vater;
  535.      sumpos_vater := sumpos_vater - (anso_vater * pos_vater);
  536.      zgr3 := sohn^.rebr;
  537.      IF (atom1 = atom2) THEN zgr3 := zgr3^.rebr;
  538.      komplex_vater_errechnen(zgr3) ; komplex_sohn_errechnen(sohn^.sohn);
  539.      komplex_sohn := komplex_sohn + komplex_vater + niv_vater * lang_vater;
  540. END;
  541.  
  542. PROCEDURE neuen_baum_generieren;
  543.  
  544. VAR
  545.    xkoor,ykoor,h : INTEGER;
  546.    zgr           : zeiger;
  547.  
  548. PROCEDURE niv_pos_anpassen(ptr : zeiger);
  549.  
  550. BEGIN
  551.      IF (ptr<>NIL) THEN
  552.      BEGIN
  553.           niv_pos_anpassen(ptr^.sohn);
  554.           ptr^.niveau := ptr^.niveau + 1;
  555.           IF (ptr^.niveau <= niv_vater + 1) THEN
  556.           BEGIN
  557.                ptr^.anlibr := anso_vater - (vater^.anso-ptr^.anlibr);
  558.                ptr^.posit := ptr^.posit - pos_vater;
  559.           END;
  560.           niv_pos_anpassen(ptr^.rebr);
  561.      END;
  562. END;
  563.  
  564. PROCEDURE niv_anpassen(ptr : zeiger);
  565.  
  566. BEGIN
  567.      IF (ptr<>NIL) THEN
  568.      BEGIN
  569.           niv_anpassen(ptr^.sohn);
  570.           ptr^.niveau := ptr^.niveau - 1;
  571.           niv_anpassen(ptr^.rebr);
  572.      END;
  573. END;
  574.  
  575. PROCEDURE komplex_neu_berechnen(ptr : zeiger);
  576.  
  577. BEGIN
  578.      IF (ptr<>NIL) THEN
  579.      BEGIN
  580.           ptr^.komplex := 0;
  581.           komplex_neu_berechnen(ptr^.sohn);
  582.           IF (ptr^.vater<>NIL)
  583.           THEN ptr^.vater^.komplex := ptr^.vater^.komplex + ptr^.komplex
  584.                                       + (ptr^.niveau * ptr^.laenge);
  585.           komplex_neu_berechnen(ptr^.rebr);
  586.      END;
  587. END;
  588.  
  589. BEGIN
  590.      niv_pos_anpassen(zgr3) ; niv_anpassen(sohn^.sohn);
  591.      zgr := sohn ; sohn := sohn^.sohn;
  592.      WHILE (sohn<>NIL) DO
  593.      BEGIN
  594.           sohn^.posit := zgr^.posit + sohn^.posit;
  595.           sohn^.anlibr := anso_sohn - sohn^.anrebr - 1;
  596.           sohn := sohn^.rebr;
  597.      END;
  598.      sohn := zgr^.libr;
  599.      WHILE (sohn<>NIL) DO
  600.      BEGIN
  601.           sohn^.vater := zgr;
  602.           sohn^.anrebr := anso_sohn - sohn^.anlibr - 1;
  603.           sohn := sohn^.libr;
  604.      END;
  605.      sohn := zgr ; pos := 1;
  606.      WHILE (pos<LENGTH(atom_neu)) DO
  607.      BEGIN
  608.           val(COPY(atom_neu,pos,2),xkoor,h);
  609.           val(COPY(atom_neu,pos+2,2),ykoor,h);
  610.           akt_atom[TRUNC(xkoor/2),TRUNC(ykoor/2)].in_kette := sohn;
  611.           pos := pos + 4;
  612.      END;
  613.      WITH sohn^ DO
  614.      BEGIN
  615.           posit := pos_sohn ; laenge := lang_sohn;
  616.           niveau := niv_sohn ; anso := anso_sohn;
  617.           anlibr := anlibr_sohn ;anrebr := anrebr_sohn;
  618.           sumpos := sumpos_sohn ; revpos := revpos_sohn;
  619.           anca := anca_sohn ; atome := atome_sohn;
  620.           sumanca := sumanca_sohn ; komplex := komplex_sohn;
  621.      END;
  622.      WITH vater^ DO
  623.      BEGIN
  624.           posit := pos_vater ; laenge := lang_vater;
  625.           niveau := niv_vater ; anso := anso_vater;
  626.           anlibr := anlibr_vater ; anrebr := anrebr_vater;
  627.           sumpos := sumpos_vater ; revpos := revpos_vater;
  628.           anca := anca_vater ; atome := atome_vater;
  629.           sumanca := sumanca_vater ; komplex := komplex_vater;
  630.      END;
  631.      zgr := vater^.libr ; vater^.libr := sohn^.libr;
  632.      IF (sohn^.libr<>NIL) THEN sohn^.libr^.rebr := vater;
  633.      sohn^.libr := zgr;
  634.      IF (zgr<>NIL) THEN zgr^.rebr := sohn
  635.         ELSE IF (vater^.vater<>NIL)
  636.              THEN vater^.vater^.sohn := sohn ELSE wurzel := sohn;
  637.      zgr := vater^.rebr;
  638.      IF ((sohn^.rebr<>NIL) AND (atom1 = atom2)) THEN
  639.      BEGIN
  640.           vater^.rebr := sohn^.rebr ; sohn^.rebr^.libr := vater;
  641.           zgr2 := sohn^.rebr^.rebr ; sohn^.rebr^.rebr := sohn^.sohn;
  642.           IF (sohn^.sohn<>NIL) THEN sohn^.sohn^.libr := sohn^.rebr;
  643.           sohn^.rebr^.vater := sohn;
  644.      END
  645.      ELSE
  646.      BEGIN
  647.           zgr2 := sohn^.rebr ; vater^.rebr := sohn^.sohn;
  648.           IF (sohn^.sohn<>NIL) THEN sohn^.sohn^.libr := vater;
  649.      END;
  650.      sohn^.rebr := zgr;
  651.      IF (zgr<>NIL) THEN zgr^.libr := sohn;
  652.      zgr := vater^.sohn ; vater^.sohn := zgr2;
  653.      IF (zgr2<>NIL) THEN zgr2^.libr := NIL;
  654.      IF (sohn<>zgr) THEN sohn^.sohn := zgr ELSE sohn^.sohn := vater;
  655.      zgr2 := vater ; zgr := vater^.vater;
  656.      vater^.vater := sohn ; sohn^.vater := zgr;
  657.      komplex_neu_berechnen(wurzel);
  658. END;
  659.  
  660. BEGIN
  661.      flag1 := FALSE ; flag2 := FALSE;
  662.      lang_sohn := sohn^.posit + sohn^.laenge;
  663.      IF (lang_sohn>vater^.laenge) THEN flag1 := TRUE;
  664.      IF (lang_sohn=vater^.laenge) THEN flag2 := TRUE;
  665.      IF ((flag1=TRUE) OR (flag2=TRUE)) THEN
  666.      BEGIN
  667.           anso_sohn := sohn^.anlibr + sohn^.anso + 1;
  668.           IF ((sohn^.rebr<>NIL) AND (atom1 = atom2))
  669.              THEN anso_sohn := anso_sohn + 1;
  670.      END;
  671.      IF ((flag1<>TRUE) AND (flag2=TRUE)) THEN
  672.      BEGIN
  673.           flag2 := FALSE;
  674.           IF (anso_sohn>vater^.anso) THEN flag1 := TRUE;
  675.           IF (anso_sohn=vater^.anso) THEN flag2 := TRUE;
  676.      END;
  677.      IF ((flag1=TRUE) OR (flag2=TRUE)) THEN neue_kettendaten_berechnen;
  678.      IF ((flag1<>TRUE) AND (flag2=TRUE)) THEN
  679.      BEGIN
  680.           flag2 := FALSE ; flag := FALSE;
  681.           IF (vater^.revpos<vater^.sumpos) THEN
  682.           BEGIN
  683.                flag := TRUE;
  684.                hilfe := vater^.revpos ; vater^.revpos := vater^.sumpos;
  685.                vater^.sumpos := hilfe ; hilfe := revpos_sohn;
  686.                revpos_sohn := sumpos_sohn ; sumpos_sohn := hilfe;
  687.           END;
  688.           IF (sumpos_sohn<vater^.sumpos) THEN flag1 := TRUE;
  689.           IF ((niv_sohn = 0) AND (revpos_sohn<vater^.sumpos))
  690.              THEN flag1 := TRUE;
  691.           IF (sumpos_sohn=vater^.sumpos) THEN flag2 := TRUE;
  692.           IF ((niv_sohn = 0) AND (revpos_sohn=vater^.sumpos))
  693.              THEN flag2 := TRUE;
  694.           IF (flag = TRUE) THEN
  695.           BEGIN
  696.                hilfe := vater^.revpos ; vater^.revpos := vater^.sumpos;
  697.                vater^.sumpos := hilfe ; hilfe := revpos_sohn;
  698.                revpos_sohn := sumpos_sohn ; sumpos_sohn := hilfe;
  699.           END;
  700.      END;
  701.      IF ((flag1<>TRUE) AND (flag2=TRUE)) THEN
  702.      BEGIN
  703.           flag2 := FALSE;
  704.           IF (sumanca_sohn>vater^.sumanca) THEN flag1 := TRUE;
  705.           IF (sumanca_sohn=vater^.sumanca) THEN flag2 := TRUE;
  706.      END;
  707.      IF ((flag1<>TRUE) AND (flag2=TRUE)) THEN
  708.      BEGIN
  709.           flag2 := FALSE;
  710.           IF (anca_sohn=vater^.anca) THEN flag2 := TRUE
  711.           ELSE
  712.           BEGIN
  713.                pos := 1;
  714.                WHILE ((flag1<>TRUE) AND
  715.                       (COPY(anca_sohn,pos,3) >= COPY(vater^.anca,pos,3))
  716.                      AND (pos<LENGTH(anca_sohn))) DO
  717.                BEGIN
  718.                     IF (COPY(anca_sohn,pos,3) > COPY(vater^.anca,pos,3))
  719.                        THEN flag1 := TRUE;
  720.                     pos := pos + 3;
  721.                END;
  722.           END;
  723.      END;
  724.      IF ((flag1<>TRUE) AND (flag2=TRUE)) THEN
  725.      BEGIN
  726.           flag2 := FALSE;
  727.           IF (komplex_sohn<vater^.komplex) THEN flag1 := TRUE;
  728.      END;
  729.      IF (flag1=TRUE) THEN
  730.      BEGIN
  731.           flag1 := FALSE ; neuen_baum_generieren ; sohn := zgr2;
  732.      END;
  733. END;
  734.  
  735. PROCEDURE sohn_loeschen(VAR sohn : zeiger);
  736.  
  737. BEGIN
  738.      IF (sohn^.libr<>NIL) THEN sohn^.libr^.rebr := sohn^.rebr
  739.                           ELSE sohn^.vater^.sohn := sohn^.rebr;
  740.      IF (sohn^.rebr<>NIL) THEN sohn^.rebr^.libr := sohn^.libr;
  741.      alte_kette := sohn ; sohn := sohn^.libr;
  742.      WHILE (sohn<>NIL) DO
  743.      BEGIN
  744.           sohn^.anrebr := sohn^.anrebr - 1 ; sohn := sohn^.libr;
  745.      END;
  746.      sohn := alte_kette^.rebr;
  747.      WHILE (sohn<>NIL) DO
  748.      BEGIN
  749.           sohn^.anlibr := sohn^.anlibr - 1 ; sohn := sohn^.rebr;
  750.      END;
  751.      sohn := alte_kette ; sohn := sohn^.vater;
  752.      sohn^.anso := sohn^.anso - 1;
  753.      sohn^.sumpos := sohn^.sumpos - alte_kette^.posit;
  754.      sohn^.revpos := sohn^.revpos - sohn^.laenge + alte_kette^.posit-1;
  755.      sohn := alte_kette ; alte_kette := sohn^.vater;
  756.      DISPOSE(sohn) ; sohn := alte_kette;
  757. END;
  758.  
  759. PROCEDURE vergleich_mit_soehnen;
  760.  
  761. VAR
  762.    zgr1,zgr2 : zeiger;
  763.  
  764. BEGIN
  765.      zgr1 := akt_kette ; akt_kette := akt_kette^.sohn;
  766.      WHILE ((akt_kette<>NIL) AND (akt_kette^.rebr<>NIL))
  767.            DO akt_kette := akt_kette^.rebr;
  768.      WHILE (akt_kette<>NIL) DO
  769.      BEGIN
  770.           zgr2 := akt_kette^.libr;
  771.           ketten_vergleich(akt_kette^.vater,akt_kette);
  772.           IF (akt_kette^.laenge = 0) THEN
  773.           BEGIN
  774.                sohn_loeschen(akt_kette) ; zgr1 := akt_kette;
  775.           END;
  776.           akt_kette := zgr2;
  777.      END;
  778.      akt_kette := zgr1;
  779. END;
  780.  
  781. PROCEDURE baum_bindung_loeschen;
  782.  
  783. VAR
  784.    h0,h1,h2,h3  : INTEGER;
  785.  
  786. BEGIN
  787.      akt_kette^.laenge := akt_kette^.laenge - 1;
  788.      VAL(COPY(akt_kette^.atome,1,2),h1,h0);
  789.      VAL(COPY(akt_kette^.atome,3,2),h2,h0);
  790.      IF ((2*ax=h1) AND (2*ay=h2)) THEN
  791.      BEGIN
  792.           akt_kette^.atome :=
  793.               COPY(akt_kette^.atome,5,LENGTH(akt_kette^.atome)-4);
  794.           alte_kette := akt_kette ; akt_kette := akt_kette^.sohn;
  795.           WHILE (akt_kette<>NIL) DO
  796.           BEGIN
  797.                akt_kette^.posit := akt_kette^.posit - 1;
  798.                alte_kette^.sumpos := alte_kette^.sumpos - 1;
  799.                akt_kette := akt_kette^.rebr;
  800.           END;
  801.           akt_kette := alte_kette;
  802.      END
  803.      ELSE
  804.      BEGIN
  805.           akt_kette^.atome :=
  806.               COPY(akt_kette^.atome,1,LENGTH(akt_kette^.atome)-4);
  807.           alte_kette := akt_kette ; akt_kette := akt_kette^.sohn;
  808.           WHILE (akt_kette<>NIL) DO
  809.           BEGIN
  810.                alte_kette^.revpos := alte_kette^.revpos - 1;
  811.                akt_kette := akt_kette^.rebr;
  812.           END;
  813.           akt_kette := alte_kette;
  814.      END;
  815.      alte_kette := akt_kette;
  816.      WHILE (akt_kette^.vater <> NIL) DO
  817.      BEGIN
  818.           h3 := akt_kette^.laenge + akt_kette^.sumanca;
  819.           alt_anca := akt_kette^.vater^.anca;
  820.           anca_str_neu(alt_anca,h3 + 1,h3);
  821.           akt_kette^.vater^.anca := alt_anca;
  822.           akt_kette^.vater^.sumanca := akt_kette^.vater^.sumanca - 1;
  823.           akt_kette^.vater^.komplex := akt_kette^.vater^.komplex
  824.                                        - alte_kette^.niveau;
  825.           akt_kette := akt_kette^.vater;
  826.      END;
  827.      akt_kette := alte_kette;
  828.      IF (akt_kette^.laenge = 0) THEN sohn_loeschen(akt_kette);
  829.      IF (wurzel^.revpos<wurzel^.sumpos) THEN hauptkette_umdrehen;
  830.      IF (wurzel^.revpos=wurzel^.sumpos) THEN sumpos_gleich_revpos;
  831.      vergleich_mit_soehnen;
  832.      IF ((akt_kette<>NIL) AND (akt_kette^.niveau=0)) THEN
  833.      BEGIN
  834.           hauptkette_umdrehen ; vergleich_mit_soehnen;
  835.      END;
  836.      IF (wurzel^.revpos<=wurzel^.sumpos) THEN hauptkette_umdrehen;
  837.      IF (wurzel^.revpos=wurzel^.sumpos) THEN sumpos_gleich_revpos;
  838. END;
  839.  
  840. PROCEDURE array_bindung_loeschen;
  841.  
  842. BEGIN
  843.      ax := TRUNC(x/2) ; ay := TRUNC(y/2);
  844.      IF ((x/2=ax) AND (y/2=ay)) THEN
  845.      BEGIN
  846.           wertig := 0 ; wertigkeit(ax,ay);
  847.           IF (wertig=1) THEN
  848.           BEGIN
  849.                nx := TRUNC((x+2*dx)/2) ; ny := TRUNC((y+2*dy)/2);
  850.                akt_atom[ax,ay].bind := 0;akt_atom[ax,ay].in_kette  := NIL;
  851.                akt_atom[nx,ny].bind := ((akt_atom[nx,ny].bind) AND
  852.                                 (NOT(1 SHL (ABS((1-dx)+2*dy)))));
  853.                IF (akt_atom[nx,ny].bind = 0) THEN
  854.                BEGIN
  855.                     sx := nx ; sy := ny;
  856.                END;
  857.                baum_bindung_loeschen ; GOTOXY(x+1,y+1) ; WRITE(' ');
  858.                x := x + dx ; y := y + dy ; GOTOXY(x+1,y+1) ; WRITE(' ');
  859.           END;
  860.      END;
  861. END;
  862.  
  863. PROCEDURE baum_bindung_setzen;
  864.  
  865. VAR
  866.    h0,h1,h2,h3   : INTEGER;
  867.    xstr,ystr     : STRING[2];
  868.    zgr1,zgr2     : zeiger;
  869.  
  870. PROCEDURE position_festellen;
  871.  
  872. VAR
  873.    xstr,ystr : STRING[2];
  874.  
  875. BEGIN
  876.      stelle := 1 ; STR(2*ax,xstr) ; STR(2*ay,ystr);
  877.      IF (LENGTH(xstr)<2) THEN xstr := '0' + xstr;
  878.      IF (LENGTH(ystr)<2) THEN ystr := '0' + ystr;
  879.      WHILE ((xstr+ystr)<>COPY(akt_kette^.atome,stelle,4))
  880.            DO stelle := stelle + 4;
  881.      stelle := (stelle-1) DIV 4 + 1;
  882. END;
  883.  
  884. PROCEDURE sohn_einfuegen;
  885.  
  886. BEGIN
  887.      position_festellen;
  888.      IF (akt_kette^.sohn=NIL) THEN
  889.      BEGIN
  890.           alte_kette := akt_kette ; NEW(akt_kette);
  891.           neue_kette_initialisieren;
  892.           alte_kette^.sohn := akt_kette ; akt_kette^.vater := alte_kette;
  893.           akt_kette^.niveau := alte_kette^.niveau + 1;
  894.      END
  895.      ELSE
  896.      BEGIN
  897.           akt_kette := akt_kette^.sohn ; alte_kette := akt_kette;
  898.           WHILE ((akt_kette<>NIL) AND (alte_kette^.posit<stelle)) DO
  899.           BEGIN
  900.                alte_kette := akt_kette ; akt_kette := akt_kette^.rebr;
  901.           END;
  902.           NEW(akt_kette);
  903.           neue_kette_initialisieren;
  904.           IF (alte_kette^.posit>=stelle) THEN
  905.           BEGIN
  906.                IF (alte_kette^.libr<>NIL) THEN
  907.                BEGIN
  908.                     alte_kette^.libr^.rebr := akt_kette;
  909.                     akt_kette^.anrebr := alte_kette^.libr^.anrebr;
  910.                END
  911.                ELSE
  912.                BEGIN
  913.                     alte_kette^.vater^.sohn := akt_kette;
  914.                     akt_kette^.anrebr := alte_kette^.vater^.anso;
  915.                END;
  916.                akt_kette^.rebr := alte_kette;
  917.                akt_kette^.libr := alte_kette^.libr;
  918.                alte_kette^.libr := akt_kette;
  919.                akt_kette^.vater := alte_kette^.vater;
  920.                akt_kette^.anlibr := akt_kette^.vater^.anso
  921.                                      - akt_kette^.anrebr;
  922.                alte_kette := akt_kette ; akt_kette := akt_kette^.libr;
  923.                WHILE (akt_kette<>NIL) DO
  924.                BEGIN
  925.                     akt_kette^.anrebr := akt_kette^.anrebr + 1;
  926.                     akt_kette := akt_kette^.libr;
  927.                END;
  928.                akt_kette := alte_kette^.rebr;
  929.                WHILE (akt_kette<>NIL) DO
  930.                BEGIN
  931.                     akt_kette^.anlibr := akt_kette^.anlibr + 1;
  932.                     akt_kette := akt_kette^.rebr;
  933.                END;
  934.                akt_kette := alte_kette;
  935.           END
  936.           ELSE
  937.           BEGIN
  938.                akt_kette^.libr := alte_kette ; akt_kette^.rebr := NIL;
  939.                alte_kette^.rebr := akt_kette;
  940.                akt_kette^.vater := alte_kette^.vater;
  941.                akt_kette^.anlibr := akt_kette^.vater^.anso;
  942.                akt_kette^.anrebr := 0 ; alte_kette := akt_kette;
  943.                akt_kette := akt_kette^.libr;
  944.                WHILE (akt_kette<>NIL) DO
  945.                BEGIN
  946.                     akt_kette^.anrebr := akt_kette^.anrebr + 1;
  947.                     akt_kette := akt_kette^.libr;
  948.                END;
  949.                akt_kette := alte_kette;
  950.           END;
  951.           akt_kette^.niveau := akt_kette^.vater^.niveau + 1;
  952.      END;
  953. END;
  954.  
  955. BEGIN
  956.      IF (wertig>1) THEN
  957.      BEGIN
  958.           sohn_einfuegen;
  959.           akt_kette^.posit := stelle ; alte_kette := akt_kette;
  960.           akt_kette := akt_kette^.vater;
  961.           akt_kette^.anso := akt_kette^.anso + 1;
  962.           akt_kette^.sumpos := akt_kette^.sumpos + alte_kette^.posit;
  963.           akt_kette^.revpos := akt_kette^.revpos + akt_kette^.laenge
  964.                                - alte_kette^.posit + 1;
  965.           akt_kette := alte_kette;
  966.      END;
  967.      akt_kette^.laenge := akt_kette^.laenge + 1;
  968.      akt_atom[nx,ny].in_kette := akt_kette ; STR(x,xstr) ; STR(y,ystr);
  969.      IF (LENGTH(xstr)<2) THEN xstr := '0' + xstr;
  970.      IF (LENGTH(ystr)<2) THEN ystr := '0' + ystr;
  971.      VAL(COPY(akt_kette^.atome,1,2),h1,h0);
  972.      VAL(COPY(akt_kette^.atome,3,2),h2,h0);
  973.      IF ((2*ax=h1) AND (2*ay=h2) AND (wertig<>0) AND
  974.         (akt_kette^.niveau=0)) THEN
  975.      BEGIN
  976.           akt_kette^.atome := xstr + ystr + akt_kette^.atome;
  977.           alte_kette := akt_kette ; akt_kette := akt_kette^.sohn;
  978.           WHILE (akt_kette<>NIL) DO
  979.           BEGIN
  980.                akt_kette^.posit := akt_kette^.posit + 1;
  981.                alte_kette^.sumpos := alte_kette^.sumpos + 1;
  982.                akt_kette := akt_kette^.rebr;
  983.           END;
  984.           akt_kette := alte_kette;
  985.      END
  986.      ELSE
  987.      BEGIN
  988.           akt_kette^.atome := akt_kette^.atome + xstr + ystr;
  989.           alte_kette := akt_kette ; akt_kette := akt_kette^.sohn;
  990.           WHILE (akt_kette<>NIL) DO
  991.           BEGIN
  992.                alte_kette^.revpos := alte_kette^.revpos + 1;
  993.                akt_kette := akt_kette^.rebr;
  994.           END;
  995.           akt_kette := alte_kette;
  996.      END;
  997.      IF (wurzel^.revpos<=wurzel^.sumpos) THEN hauptkette_umdrehen;
  998.      IF (wurzel^.revpos=wurzel^.sumpos) THEN sumpos_gleich_revpos;
  999.      alte_kette := akt_kette;
  1000.      WHILE (akt_kette^.vater <> NIL) DO
  1001.      BEGIN
  1002.           h3 := akt_kette^.laenge + akt_kette^.sumanca;
  1003.           alt_anca := akt_kette^.vater^.anca;
  1004.           anca_str_neu(alt_anca,h3 - 1,h3);
  1005.           akt_kette^.vater^.anca := alt_anca;
  1006.           akt_kette^.vater^.sumanca := akt_kette^.vater^.sumanca + 1;
  1007.           akt_kette^.vater^.komplex := akt_kette^.vater^.komplex
  1008.                                        + alte_kette^.niveau;
  1009.           akt_kette := akt_kette^.vater;
  1010.      END;
  1011.      akt_kette := alte_kette ; zgr1 := akt_kette;
  1012.      WHILE (akt_kette^.vater<>NIL) DO
  1013.      BEGIN
  1014.           zgr2 := akt_kette^.vater;
  1015.           ketten_vergleich(akt_kette^.vater,akt_kette);
  1016.           IF (akt_kette^.vater^.niveau=0) THEN
  1017.           BEGIN
  1018.                hauptkette_umdrehen;
  1019.                ketten_vergleich(akt_kette^.vater,akt_kette);
  1020.                IF (wurzel^.revpos<=wurzel^.sumpos)THEN hauptkette_umdrehen;
  1021.                IF (wurzel^.revpos=wurzel^.sumpos)THEN sumpos_gleich_revpos;
  1022.           END;
  1023.           IF (zgr2<>akt_kette^.vater) THEN
  1024.           BEGIN
  1025.                akt_kette := zgr2 ; vergleich_mit_soehnen;
  1026.           END;
  1027.           akt_kette := akt_kette^.vater;
  1028.      END;
  1029.      akt_kette := zgr1;
  1030. END;
  1031.  
  1032. PROCEDURE array_bindung_setzen;
  1033.  
  1034. VAR
  1035.    hx,hy : INTEGER;
  1036.    flag  : BOOLEAN;
  1037.  
  1038. PROCEDURE bindung_erlaubt;
  1039.  
  1040. VAR
  1041.    h1,h2 : INTEGER;
  1042.  
  1043. BEGIN
  1044.      flag := FALSE ; h1 := 0 ; h2 := 0 ; alte_kette := akt_kette;
  1045.      WHILE (akt_kette^.vater<>NIL) DO
  1046.      BEGIN
  1047.           h1 := h1 + akt_kette^.posit;
  1048.           IF (akt_kette^.vater^.vater=NIL)
  1049.              THEN h2 := h2 + akt_kette^.vater^.laenge - akt_kette^.posit+1
  1050.              ELSE h2 := h2 + akt_kette^.posit;
  1051.           akt_kette := akt_kette^.vater;
  1052.      END;
  1053.      akt_kette := alte_kette;
  1054.      IF (akt_kette^.vater<>NIL) THEN
  1055.      BEGIN
  1056.           h1 := h1 + akt_kette^.laenge ; h2 := h2 + akt_kette^.laenge;
  1057.      END
  1058.      ELSE h1 := akt_kette^.laenge;
  1059.      IF ((h1<63) AND (h2<63))
  1060.         THEN flag := TRUE
  1061.         ELSE IF (wertig>1) THEN flag := TRUE;
  1062.      IF ((wertig>1) AND (akt_kette^.anso>19)) THEN flag := FALSE;
  1063.      IF ((wertig=1) AND (namlen - LENGTH(ketten_name[akt_kette^.laenge])
  1064.                 + LENGTH(ketten_name[akt_kette^.laenge+1])>255))
  1065.         THEN flag := FALSE;
  1066.      IF ((wertig>1) AND (namlen + 10 > 255)) THEN flag := FALSE;
  1067. END;
  1068.  
  1069. BEGIN
  1070.      ax := TRUNC((x - dx)/2) ; ay := TRUNC((y - dy)/2);
  1071.      hx := dx ; hy := dy ; wertig := 0 ; wertigkeit(ax,ay);
  1072.      dx := hx ; dy := hy ; bindung_erlaubt;
  1073.      IF (flag = TRUE)
  1074.      THEN IF (((x-dx)/2=ax) AND ((y-dy)/2=ay)) THEN
  1075.           BEGIN
  1076.                nx := TRUNC((x + dx)/2) ; ny := TRUNC((y + dy)/2);
  1077.                IF (((akt_atom[ax,ay].bind<>0) AND
  1078.                     (akt_atom[nx,ny].bind=0)) OR
  1079.                    ((akt_atom[ax,ay].bind=0) AND
  1080.                     ((ax=sx) AND (ay=sy)))) THEN
  1081.                BEGIN
  1082.                     akt_atom[ax,ay].bind := ((akt_atom[ax,ay].bind) OR
  1083.                                (1 SHL (ABS((1+dx)-2*dy))));
  1084.                     akt_atom[nx,ny].bind := ((akt_atom[nx,ny].bind) OR
  1085.                                (1 SHL (ABS((1-dx)+2*dy))));
  1086.                     IF (dx<>0) THEN WRITE('-') ELSE WRITE(':');
  1087.                     x := x + dx ; y := y + dy ; GOTOXY(x+1,y+1);WRITE('C');
  1088.                     baum_bindung_setzen;
  1089.                END;
  1090.           END;
  1091. END;
  1092.  
  1093. PROCEDURE alkan_eingabe;
  1094.  
  1095. VAR
  1096.    h  : INTEGER;
  1097.    ch : CHAR;
  1098.  
  1099. PROCEDURE highlight_aktkette(farbe1,farbe2 : INTEGER);
  1100.  
  1101. VAR
  1102.    x_neu,x_alt,y_neu,y_alt,dx,dy,pos,h : INTEGER;
  1103.  
  1104. BEGIN
  1105.      TEXTBACKGROUND(farbe1) ; TEXTCOLOR(farbe2);
  1106.      dx := 0 ; dy := 0 ; pos := 1 ; h := 0;
  1107.      VAL(COPY(akt_kette^.atome,pos,2),x_neu,h);
  1108.      VAL(COPY(akt_kette^.atome,pos+2,2),y_neu,h);
  1109.      WHILE (pos<LENGTH(akt_kette^.atome)) DO
  1110.      BEGIN
  1111.           x_alt := x_neu ; y_alt := y_neu;
  1112.           VAL(COPY(akt_kette^.atome,pos,2),x_neu,h);
  1113.           VAL(COPY(akt_kette^.atome,pos+2,2),y_neu,h);
  1114.           GOTOXY(x_neu+1,y_neu+1) ; WRITE('C');
  1115.           dx := (x_neu - x_alt) DIV 2 ; dy := (y_neu - y_alt) DIV 2;
  1116.           GOTOXY(x_alt + dx + 1,y_alt + dy + 1);
  1117.           IF (NOT((dx=0) AND (dy=0)))
  1118.              THEN IF (dx=0) THEN WRITE(':') ELSE WRITE('-');
  1119.           pos := pos + 4;
  1120.      END;
  1121.      TEXTBACKGROUND(0) ; TEXTCOLOR(15);
  1122.      GOTOXY(x+1,y+1);
  1123. END;
  1124.  
  1125. BEGIN
  1126.      REPEAT
  1127.            IF (NOT((x+dx<0) OR (x+dx>78))) THEN x := x + dx;
  1128.            IF (NOT((y+dy<0) OR (y+dy>38))) THEN y := y + dy;
  1129.            GOTOXY(x+1,y+1);
  1130.            IF (akt_atom[TRUNC(x/2),TRUNC(y/2)].bind<>0) THEN
  1131.            BEGIN
  1132.                 alte_kette := akt_kette;
  1133.                 IF (akt_kette<>akt_atom[TRUNC(x/2),TRUNC(y/2)].in_kette)
  1134.                    THEN highlight_aktkette(0,15);
  1135.                 akt_kette := akt_atom[TRUNC(x/2),TRUNC(y/2)].in_kette;
  1136.            END;
  1137.            highlight_aktkette(15,0);
  1138.            ch := READKEY;
  1139.            CASE ch OF
  1140.                 '2',#080 : BEGIN
  1141.                                 dx := 0 ; dy := 1;
  1142.                            END;
  1143.                 '4',#075 : BEGIN
  1144.                                 dx := -1 ; dy := 0;
  1145.                            END;
  1146.                 '6',#077 : BEGIN
  1147.                                 dx := 1 ; dy := 0;
  1148.                            END;
  1149.                 '8',#072 : BEGIN
  1150.                                 dx := 0 ; dy := -1;
  1151.                            END;
  1152.                 '5','+'  : BEGIN
  1153.                                 highlight_aktkette(0,15);
  1154.                                 array_bindung_setzen;
  1155.                                 alkan_benennen;
  1156.                            END;
  1157.                 '0','-'  : BEGIN
  1158.                                 highlight_aktkette(0,15);
  1159.                                 array_bindung_loeschen;
  1160.                                 alkan_benennen;
  1161.                            END;
  1162.                 #115     : BEGIN
  1163.                                 VAL(COPY(akt_kette^.atome,1,2),x,h);
  1164.                                 VAL(COPY(akt_kette^.atome,3,2),y,h);
  1165.                            END;
  1166.                 #116     : BEGIN
  1167.                                 VAL(COPY(akt_kette^.atome,
  1168.                                 LENGTH(akt_kette^.atome)-3,2),x,h);
  1169.                                 VAL(COPY(akt_kette^.atome,
  1170.                                 LENGTH(akt_kette^.atome)-1,2),y,h);
  1171.                            END;
  1172.                 'L','l'  : BEGIN
  1173.                                 RELEASE(heapstart);
  1174.                                 initialisieren;
  1175.                            END;
  1176.                 ELSE       BEGIN
  1177.                                 dx := 0 ; dy := 0;
  1178.                            END;
  1179.            END;
  1180.      UNTIL ch=#27;
  1181. END;
  1182.  
  1183. PROCEDURE titelbild;
  1184.  
  1185. BEGIN
  1186.      CLRSCR ; TEXTBACKGROUND(15) ; TEXTCOLOR(0);
  1187.      GOTOXY(24,3);WRITELN(' N  O  M  E  N  K  L  A  T  U  R ');
  1188.      GOTOXY(38,5);WRITELN(' von ');
  1189.      GOTOXY(30,7);WRITELN(' A  L  K  A  N  E  N ');
  1190.      GOTOXY(32,9);WRITELN(' nach IUPAC-Norm ');
  1191.      TEXTBACKGROUND(0) ; TEXTCOLOR(15);
  1192.      GOTOXY(30,13);WRITELN('        C       C    ');
  1193.      GOTOXY(30,14);WRITELN('        :       :    ');
  1194.      GOTOXY(30,15);WRITELN('    C   C   C   C    ');
  1195.      GOTOXY(30,16);WRITELN('    :   :   :   :    ');
  1196.      GOTOXY(30,17);WRITELN('C-C-C-C-C-C-C-C-C-C-C');
  1197.      GOTOXY(30,18);WRITELN('  :   :     :        ');
  1198.      GOTOXY(30,19);WRITELN('  C   C     C-C      ');
  1199.      GOTOXY(30,20);WRITELN('            :        ');
  1200.      GOTOXY(30,21);WRITELN('            C        ');
  1201.      GOTOXY(31,24);WRITE('(c) 1989 Jürgen Linz');
  1202.      DELAY(5000);
  1203. END;
  1204.  
  1205. PROCEDURE bedienungsanleitung;
  1206.  
  1207. VAR
  1208.    ch : CHAR;
  1209.  
  1210. BEGIN
  1211.      CLRSCR ; TEXTBACKGROUND(15) ; TEXTCOLOR(0);
  1212.      GOTOXY(20,1);WRITELN(' Nomenklatur von Alkanen nach IUPAC-Norm ');
  1213.      TEXTBACKGROUND(0) ; TEXTCOLOR(15) ; WRITELN;
  1214.      WRITE('Das Programm ermittelt zu jedem von Ihnen eingegebenen Alkan');
  1215.      WRITELN(' (gesättigter');
  1216.      WRITE('Kohlenwasserstoff) den nach der IUPAC-Norm zugehörigen');
  1217.      WRITELN(' chemischen Namen.'); WRITELN;
  1218.      WRITE('Es erwartet die Eingabe eines beliebigen Alkans als Gerüst-');
  1219.      WRITELN('Struktur-Formel') ; WRITELN('(ohne Wasserstoffatome).');
  1220.      GOTOXY(1,9);WRITE('Für die Eingabe benutzen Sie bitte');
  1221.      WRITELN(' Ziffernblock und/oder Pfeiltasten :');
  1222.      GOTOXY(5,11);WRITELN('<8> / <',chr(24),'>  :  Cursor nach oben');
  1223.      GOTOXY(5,12);WRITELN('<2> / <',chr(25),'>  :  Cursor nach unten');
  1224.      GOTOXY(45,11);WRITELN('<4> / <',chr(27),'>  :  Cursor nach links');
  1225.      GOTOXY(45,12);WRITELN('<6> / <',chr(26),'>  :  Cursor nach rechts');
  1226.      GOTOXY(5,13);WRITELN('<CTRL><',chr(27),'>  :  Cursor Kettenanfang');
  1227.      GOTOXY(45,13);WRITELN('<CTRL><',chr(26),'>  :  Cursor Kettenende');
  1228.      GOTOXY(5,15);WRITELN('<5> / <+>  :  Atom anfügen');
  1229.      GOTOXY(45,15);WRITELN('<0> / <->  :  Atom löschen');
  1230.      GOTOXY(5,17);WRITELN('<L> / <l>  :  Molekül löschen');
  1231.      GOTOXY(45,17);WRITELN('<ESC>      :  Ende der Eingabe');
  1232.      GOTOXY(1,19);WRITE('Bindungen werden immer in Richtung der letzten');
  1233.      WRITELN(' Cursorbewegung gesetzt.');
  1234.      WRITE('Es können nur Endatome gelöscht werden, wobei der Cursor');
  1235.      WRITELN(' direkt auf dem') ; WRITELN('Atom stehen muß.');
  1236.      WRITE('Das erste Atom ist vorgegeben, das letzte kann nicht gelöscht');
  1237.      WRITELN(' werden.');
  1238.      WRITE('<SHIFT><PRNT> bringt das Alkanmolekül mitsamt Namen zu');
  1239.      WRITELN(' Papier.');
  1240.      GOTOXY(30,25);WRITE('Weiter mit <RETURN>');
  1241.      REPEAT
  1242.            ch := readkey;
  1243.      UNTIL ch = #13;
  1244. END;
  1245.  
  1246. BEGIN
  1247.      titelbild;
  1248.      bedienungsanleitung;
  1249.      TEXTMODE(BW80+Font8x8);
  1250.      initialisieren;
  1251.      alkan_eingabe;
  1252.      TEXTMODE(BW80);
  1253.      CLRSCR;
  1254. END.
  1255.