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