[Back to POINTERS SWAG index]  [Back to Main SWAG index]  [Original]

(*
Here is TALLY.PAS, a program that Matt Bousek <MBOUSEK@intel9.intel.com> wrote
to do a word frequency analysis on a text file.  It uses an AVL tree.  It
should compile under TP 6.0 or BP 7.0
*)
program word_freq(input,output);

type
    short_str = string[32];

{************AVLtree routines*********}
type
    balance_set = (left_tilt,neutral,right_tilt);
    memptr      = ^memrec;
    memrec = record
        balance     : balance_set;
        left,right  : memptr;
        count       : longint;
        key         : short_str;
    end;

    {**************************************}
    procedure rotate_right(var root:memptr);
    var ptr2,ptr3 : memptr;
    begin
        ptr2:=root^.right;
        if ptr2^.balance=right_tilt then begin
            root^.right:=ptr2^.left;
            ptr2^.left:=root;
            root^.balance:=neutral;
            root:=ptr2;
        end else begin
            ptr3:=ptr2^.left;
            ptr2^.left:=ptr3^.right;
            ptr3^.right:=ptr2;
            root^.right:=ptr3^.left;
            ptr3^.left:=root;
            if ptr3^.balance=left_tilt
                then ptr2^.balance:=right_tilt
                else ptr2^.balance:=neutral;
            if ptr3^.balance=right_tilt
                then root^.balance:=left_tilt
                else root^.balance:=neutral;
            root:=ptr3;
        end;
        root^.balance:=neutral;
    end;

    {*************************************}
    procedure rotate_left(var root:memptr);
    var ptr2,ptr3 : memptr;
    begin
        ptr2:=root^.left;
        if ptr2^.balance=left_tilt then begin
            root^.left:=ptr2^.right;
            ptr2^.right:=root;
            root^.balance:=neutral;
            root:=ptr2;
        end else begin
            ptr3:=ptr2^.right;
            ptr2^.right:=ptr3^.left;
            ptr3^.left:=ptr2;
            root^.left:=ptr3^.right;
            ptr3^.right:=root;
            if ptr3^.balance=right_tilt
                then ptr2^.balance:=left_tilt
                else ptr2^.balance:=neutral;
            if ptr3^.balance=left_tilt
                then root^.balance:=right_tilt
                else root^.balance:=neutral;
            root:=ptr3;
        end;
        root^.balance:=neutral;
    end;

    {*****************************************************************}
    procedure insert_mem(var root:memptr; x:short_str; var ok:boolean);
    begin
        if root=nil then begin
            new(root);
            with root^ do begin
                key:=x;
                left:=nil;
                right:=nil;
                balance:=neutral;
                count:=1;
            end;
            ok:=true;
        end else begin
            if x=root^.key then begin
                ok:=false;
                inc(root^.count);
            end else begin
                if x<root^.key then begin
                    insert_mem(root^.left,x,ok);
                    if ok then case root^.balance of
                        left_tilt  : begin
                                rotate_left(root);
                                ok:=false;
                            end;
                        neutral    : root^.balance:=left_tilt;
                        right_tilt : begin
                                root^.balance:=neutral;
                                ok:=false;
                            end;
                    end;
                end else begin
                    insert_mem(root^.right,x,ok);
                    if ok then case root^.balance of
                        left_tilt  : begin
                                root^.balance:=neutral;
                                ok:=false;
                            end;
                        neutral    : root^.balance:=right_tilt;
                        right_tilt : begin
                                rotate_right(root);
                                ok:=false;
                            end;
                    end;
                end;
            end;
        end;
    end;

    {*****************************************************}
    procedure insert_memtree(var root:memptr; x:short_str);
    var ok:boolean;
    begin
        ok:=false;
        insert_mem(root,x,ok);
    end;

    {*********************************}
    procedure dump_mem(var root:memptr);
    begin
        if root<>nil then begin
            dump_mem(root^.left);
            writeln(root^.count:5,' ',root^.key);
            dump_mem(root^.right);
        end;
    end;


{MAIN***************************************************************}
{*** This program was written by Matt Bousek sometime in 1992.   ***}
{*** The act of this posting over Internet makes the code public ***}
{*** domain, but it would be nice to keep this header.           ***}
{*** The basic AVL routines came from a book called "Turbo Algo- ***}
{*** rythms",  Sorry, I don't have the book here and I can't     ***}
{*** remember the authors or publisher.  Enjoy.  And remember,   ***}
{*** there is no free lunch...                                   ***}

const
    wchars:set of char=['''','a'..'z'];

var
    i,j         : word;
    aword       : short_str;
    subject     : text;
    wstart,wend : word;
    inword      : boolean;
    linecount   : longint;
    wordcount   : longint;
    buffer      : array[1..10240] of char;
    line        : string;
    filename    : string;
    tree        : memptr;

BEGIN
    tree:=nil;

    filename:=paramstr(1);
    if filename='' then filename:='tally.pas';
    assign(subject,filename);
    settextbuf(subject,buffer);
    reset(subject);

    wordcount:=0;
    linecount:=0;
    while not eof(subject) do begin
        inc(linecount);
        readln(subject,line);
        wstart:=0; wend:=0;
        for i:=1 to byte(line[0]) do begin
            if line[i] in ['A'..'Z'] then line[i]:=chr(ord(line[i])+32);
            inword:=(line[i] in wchars);
            if inword and (wstart=0) then wstart:=i;
            if inword and (wstart>0) then wend:=i;
            if not(inword) or (i=byte(line[0])) then begin
                if wend>wstart then begin
                    aword:=copy(line,wstart,wend+1-wstart);
                    j:=byte(aword[0]);
                    if (aword[j]='''') and (j>2) then begin {lose trailing '}
                        aword:=copy(aword,1,j-1);
                        dec(wend);
                        dec(j);
                    end;
                    if (aword[1]='''') and (j>2) then begin {lose leading '}
                        aword:=copy(aword,2,j-1);
                        inc(wstart);
                        dec(j);
                    end;
                    if (j>2) and (aword[j-1]='''') and (aword[j]='s') then
begin {lose trailing 's}
                        aword:=copy(aword,1,j-2);
                        dec(wend,2);
                        dec(j,2);
                    end;
                    if (j>2) then begin
                        inc(wordcount);
                        insert_memtree(tree,aword);
                    end;
                end; { **if wend>wstart** }
                wstart:=0; wend:=0;
            end; { **if not(inword)** }
        end; { **for byte(line[0])** }
    end; { **while not eof** }

dump_mem(tree);
writeln(linecount,' lines, ',wordcount,' words.');
END.

[Back to POINTERS SWAG index]  [Back to Main SWAG index]  [Original]