home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / sonderh1 / unison.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1979-12-31  |  2.8 KB  |  113 lines
  1. {---------------------------------------------------------------------------}
  2.  
  3. PROGRAM unison_demo (Input, Output);
  4.  
  5. CONST maxstrlen = 80;
  6.  
  7. TYPE strtyp = STRING [maxstrlen];
  8.  
  9. VAR elem1, elem2: strtyp;
  10.     aehnlichkeit: INTEGER;
  11.  
  12. {---------------------------------------------------------------------------}
  13.  
  14. FUNCTION max (r1, r2: INTEGER): INTEGER;
  15.  
  16. BEGIN
  17.   IF r1>r2 THEN
  18.     max := r1
  19.   ELSE
  20.     max := r2;
  21. END;
  22.  
  23. {---------------------------------------------------------------------------}
  24. { Unison: Ermittlung des Prozentsatzes, zu dem 's1' in 's2' enthalten ist.  }
  25.  
  26. FUNCTION unison (s1, s2: strtyp): INTEGER;
  27.  
  28. VAR treffer, p1, p2, pt, diff: INTEGER;
  29.     hstr: strtyp;
  30.     test: ARRAY [1..maxstrlen] OF BOOLEAN;
  31.  
  32. BEGIN
  33.   IF Length(s1) < Length(s2) THEN
  34.   BEGIN
  35.     hstr := s2;
  36.     s2 := s1;
  37.     s1 := hstr;
  38.   END;
  39.   p1 := 1;
  40.   p2 := 1;
  41.   treffer := 0;
  42.   diff := max(Length(s1), Length(s2)) DIV 3 + abs(Length(s1)-Length(s2));
  43.   FOR pt := 1 TO Length(s1) DO
  44.     test[pt] := FALSE;
  45.   REPEAT
  46.     IF NOT(test[p1]) THEN
  47.     BEGIN
  48.       IF (s1[p1] = s2[p2]) AND (abs(p1-p2) <= diff) THEN
  49.       BEGIN
  50.         test[p1] := TRUE;
  51.         treffer := Succ(treffer);
  52.         p1 := Succ(p1);
  53.         p2 := Succ(p2);
  54.         IF p1 > Length(s1) THEN
  55.           p1 := 1
  56.       END
  57.       ELSE
  58.       BEGIN
  59.         test[p1] := FALSE;
  60.         p1 := Succ(p1);
  61.         IF p1 > Length(s1) THEN
  62.         BEGIN
  63.           WHILE (p1 > 1) AND NOT(test[p1]) DO
  64.             p1 := Pred(p1);
  65.           p2 := Succ(p2)
  66.         END;
  67.       END;
  68.     END
  69.     ELSE
  70.     BEGIN
  71.       p1 := Succ(p1);
  72.       IF p1 > Length(s1) THEN
  73.       BEGIN
  74.         REPEAT
  75.           p1 := Pred(p1)
  76.         UNTIL (p1 = 1) OR test[p1];
  77.         p2 := Succ(p2)
  78.       END;
  79.     END;
  80.   UNTIL p2 > Length(s2);
  81.   unison := 100 * treffer DIV Length(s1) ;
  82. END;
  83.  
  84. {---------------------------------------------------------------------------}
  85.  
  86. BEGIN {unison_demo}
  87.   REPEAT
  88.     WriteLn;
  89.     WriteLn('Aehnlichkeitstest:');
  90.     Write('Bitte das erste Wort eingeben:  ');   ReadLn(elem1);
  91.     Write('Bitte das zweite Wort eingeben: ');   ReadLn(elem2);
  92.     aehnlichkeit := unison(elem1, elem2);
  93.     Write('Die Ahnlichkeit betraegt ', aehnlichkeit:3);
  94.     Write('%, die Woerter sind also ');
  95.     IF aehnlichkeit = 100 THEN
  96.       WriteLn('gleich.')
  97.     ELSE IF aehnlichkeit >= 90 THEN
  98.       WriteLn('fast gleich.')
  99.     ELSE IF aehnlichkeit >= 80 THEN
  100.       WriteLn('sehr aehnlich.')
  101.     ELSE IF aehnlichkeit >= 70 THEN
  102.       WriteLn('aehnlich.')
  103.     ELSE IF aehnlichkeit >= 60 THEN
  104.       WriteLn('etwas aehnlich.')
  105.     ELSE IF aehnlichkeit >= 30 THEN
  106.       WriteLn('unterschiedlich.')
  107.     ELSE IF aehnlichkeit >= 10 THEN
  108.       WriteLn('sehr unterschiedlich.')
  109.     ELSE
  110.       WriteLn('total anders.')
  111.   UNTIL false;
  112. END.
  113.