CP/M/CPM_CDROM.iso/cpm/cpm86/trbtol86.lbr/CHAPTER4.PQS/CHAPTER4.PAS

Pascal/Delphi Source File | 1985-10-23 | 8KB | 397 lines

{
        Copyright (c) 1981
        By:     Bell Telephone Laboratories, Inc. and
                Whitesmith's Ltd.,

        This software is derived from the book
                "Software Tools in Pascal", by
                Brian W. Kernighan and P. J. Plauger
                Addison-Wesley, 1981
                ISBN 0-201-10342-7

        Right is hereby granted to freely distribute or duplicate this
        software, providing distribution or duplication is not for profit
        or other commercial gain and that this copyright notice remains
        intact.
}

PROCEDURE SORT;
CONST
  MAXCHARS=10000;
  MAXLINES=300;
  MERGEORDER=5;
TYPE
  CHARPOS=1..MAXCHARS;
  CHARBUF=ARRAY[1..MAXCHARS] OF CHARACTER;
  POSBUF=ARRAY[1..MAXLINES] OF CHARPOS;
  POS=0..MAXLINES;
  FDBUF=ARRAY[1..MERGEORDER]OF FILEDESC;
VAR
  LINEBUF:CHARBUF;
  LINEPOS:POSBUF;
  NLINES:POS;
  INFILE:FDBUF;
  OUTFILE:FILEDESC;
  HIGH,LOW,LIM:INTEGER;
  DONE:BOOLEAN;
  NAME:XSTRING;
FUNCTION GTEXT(VAR LINEPOS:POSBUF;VAR NLINES:POS;
  VAR LINEBUF:CHARBUF;INFILE:FILEDESC):BOOLEAN;
VAR
  I,LEN,NEXTPOS:INTEGER;
  TEMP:XSTRING;
  DONE:BOOLEAN;
BEGIN
  NLINES:=0;
  NEXTPOS:=1;
  REPEAT
    DONE:=(GETLINE(TEMP,INFILE,MAXSTR)=FALSE);
    IF(NOT DONE) THEN BEGIN
      NLINES:=NLINES+1;
      LINEPOS[NLINES]:=NEXTPOS;
      LEN:=XLENGTH(TEMP);
      FOR I:=1 TO LEN DO
        LINEBUF[NEXTPOS+I-1]:=TEMP[I];
      LINEBUF[NEXTPOS+LEN]:=ENDSTR;
      NEXTPOS:=NEXTPOS+LEN+1
    END
  UNTIL (DONE) OR (NEXTPOS>= MAXCHARS-MAXSTR)
    OR (NLINES>=MAXLINES);
  GTEXT:=DONE
END;

PROCEDURE PTEXT(VAR LINEPOS:POSBUF;NLINES:INTEGER;
  VAR LINEBUF:CHARBUF;OUTFILE:FILEDESC);
VAR
  I,J:INTEGER;
BEGIN
  FOR I:=1 TO NLINES DO BEGIN
      J:=LINEPOS[I];
      WHILE (LINEBUF[J]<>ENDSTR)DO BEGIN
        PUTCF(LINEBUF[J],OUTFILE);
        J:=J+1
      END
    END
END;



PROCEDURE EXCHANGE(VAR LP1,LP2:CHARPOS);
VAR
  TEMP:CHARPOS;
BEGIN
  TEMP:=LP1;
  LP1:=LP2;
  LP2:=TEMP
END;

FUNCTION CMP (I,J:CHARPOS;VAR LINEBUF:CHARBUF)
   :INTEGER;
BEGIN
  WHILE(LINEBUF[I]=LINEBUF[J])
   AND (LINEBUF[I]<>ENDSTR) DO BEGIN
     I:=I+1;
     J:=J+1
   END;
   IF(LINEBUF[I]=LINEBUF[J]) THEN
     CMP:=0
   ELSE IF (LINEBUF[I]=ENDSTR) THEN
     CMP:=-1
   ELSE IF (LINEBUF[J]=ENDSTR) THEN
     CMP:=+1
   ELSE IF (LINEBUF[I]<LINEBUF[J]) THEN
     CMP:=-1
   ELSE
     CMP:=+1
END;(*CMP*)


PROCEDURE QUICK(VAR LINEPOS:POSBUF; NLINE:POS;
  VAR LINEBUF:CHARBUF);
PROCEDURE RQUICK(LO,HI:INTEGER);
VAR
  I,J:INTEGER;
  PIVLINE:CHARPOS;
BEGIN
  IF (LO<HI) THEN BEGIN
    I:=LO;
    J:=HI;
    PIVLINE:=LINEPOS[J];
    REPEAT
      WHILE (I<J)
        AND (CMP(LINEPOS[I],PIVLINE,LINEBUF)<=0) DO
          I:=I+1;
      WHILE  (J>I)
        AND (CMP(LINEPOS[J],PIVLINE,LINEBUF)>=0) DO
          J:=J-1;
      IF(I<J) THEN
      (*OUT OF ORDER PAIR*)
        EXCHANGE(LINEPOS[I],LINEPOS[J])
    UNTIL (I>=J);
    EXCHANGE(LINEPOS[I],LINEPOS[HI]);
    IF(I-LO<HI-I) THEN BEGIN
      RQUICK(LO,I-1);
      RQUICK(I+1,HI)
    END
    ELSE BEGIN
      RQUICK(I+1,HI);
      RQUICK(LO,I-1)
    END
  END
END;(*RQUICK*)

BEGIN(*QUICK*)
  RQUICK(1,NLINES)
END;


PROCEDURE GNAME(N:INTEGER;VAR NAME:XSTRING);
VAR
  JUNK:INTEGER;
  BEGIN
    NAME[1]:=ORD('S');
    NAME[2]:=ORD('T');
    NAME[3]:=ORD('E');
    NAME[4]:=ORD('M');
    NAME[5]:=ORD('P');
    NAME[6]:=ENDSTR;
  JUNK:=ITOC(N,NAME,XLENGTH(NAME)+1)
END;

PROCEDURE GOPEN(VAR INFILE:FDBUF;F1,F2:INTEGER);
VAR
  NAME:XSTRING;
  I:1..MERGEORDER;
BEGIN
  FOR I:=1 TO F2-F1+1 DO BEGIN
    GNAME(F1+I-1,NAME);
    INFILE[I]:=MUSTOPEN(NAME,IOREAD)
  END
END;

PROCEDURE GREMOVE(VAR INFILE:FDBUF;F1,F2:INTEGER);
VAR
  NAME:XSTRING;
  I:1..MERGEORDER;
BEGIN
  FOR I:= 1 TO F2-F1+1 DO BEGIN
    XCLOSE(INFILE[I]);
    GNAME(F1+I-1,NAME);
    REMOVE(NAME)
  END
END;


FUNCTION MAKEFILE(N:INTEGER):FILEDESC;
VAR
  NAME:XSTRING;
BEGIN
  GNAME(N,NAME);

  MAKEFILE:=MUSTCREATE(NAME,IOWRITE)
END;

PROCEDURE MERGE(VAR INFILE:FDBUF; NF:INTEGER;
  OUTFILE:FILEDESC);

VAR
  I,J:INTEGER;
  LBP:CHARPOS;
  TEMP:XSTRING;

PROCEDURE REHEAP(VAR LINEPOS:POSBUF;NF:POS;
  VAR LINEBUF:CHARBUF);
VAR
  I,J:INTEGER;
BEGIN
  I:=1;
  J:=2*I;
  WHILE(J<=NF)DO BEGIN
    IF(J<NF) THEN
      IF(CMP(LINEPOS[J],LINEPOS[J+1],LINEBUF)>0)THEN
        J:=J+1;
    IF(CMP(LINEPOS[I],LINEPOS[J],LINEBUF)<=0)THEN
      I:=NF
    ELSE
      EXCHANGE(LINEPOS[I],LINEPOS[J]);(*PERCOLATE*)
    I:=J;
    J:=2*I
  END
END;

PROCEDURE SCCOPY(VAR S:XSTRING; VAR CB:CHARBUF;
  I:CHARPOS);
VAR J:INTEGER;
BEGIN
  J:=1;
  WHILE(S[J]<>ENDSTR)DO BEGIN
    CB[I]:=S[J];
    J:=J+1;
    I:=I+1
  END;
  CB[I]:=ENDSTR
END;

PROCEDURE CSCOPY(VAR CB:CHARBUF;I:CHARPOS;
  VAR S:XSTRING);
VAR J:INTEGER;
BEGIN
  J:=1;
  WHILE(CB[I]<>ENDSTR)DO BEGIN
    S[J]:=CB[I];
    I:=I+1;
    J:=J+1
  END;
  S[J]:=ENDSTR
END;

BEGIN(*MERGE*)
  J:=0;
  FOR I:=1 TO NF DO
    IF(GETLINE(TEMP,INFILE[I],MAXSTR)) THEN BEGIN
      LBP:=(I-1)*MAXSTR+1;
      SCCOPY(TEMP,LINEBUF,LBP);
      LINEPOS[I]:=LBP;
      J:=J+1
    END;
  NF:=J;
  QUICK(LINEPOS,NF,LINEBUF);
  WHILE (NF>0) DO BEGIN
    LBP:=LINEPOS[1];
    CSCOPY(LINEBUF,LBP,TEMP);
    PUTSTR(TEMP,OUTFILE);
    I:=LBP DIV MAXSTR +1;
    IF (GETLINE(TEMP,INFILE[I],MAXSTR))THEN
      SCCOPY(TEMP,LINEBUF,LBP)
    ELSE BEGIN
      LINEPOS[1]:=LINEPOS[NF];
      NF:=NF-1
    END;
    REHEAP(LINEPOS,NF,LINEBUF)
  END
END;


BEGIN
  HIGH:=0;
  REPEAT (*INITIAL FORMTION OF RUNS*)
    DONE:=GTEXT(LINEPOS,NLINES,LINEBUF,STDIN);
    QUICK(LINEPOS,NLINES,LINEBUF);
    HIGH:=HIGH+1;
    OUTFILE:=MAKEFILE(HIGH);
    PTEXT(LINEPOS,NLINES,LINEBUF,OUTFILE);
    XCLOSE(OUTFILE)
  UNTIL (DONE);
  LOW:=1;
  WHILE (LOW<HIGH) DO BEGIN
    LIM:=MIN(LOW+MERGEORDER-1,HIGH);
    GOPEN(INFILE,LOW,LIM);
    HIGH:=HIGH+1;
    OUTFILE:=MAKEFILE(HIGH);
    MERGE(INFILE,LIM-LOW+1,OUTFILE);
    XCLOSE(OUTFILE);
    GREMOVE(INFILE,LOW,LIM);
    LOW:=LOW+MERGEORDER
  END;
  GNAME(HIGH,NAME);
  OUTFILE:=OPEN(NAME,IOREAD);
  FCOPY(OUTFILE,STDOUT);
  XCLOSE(OUTFILE);
  REMOVE(NAME)
END;

PROCEDURE UNIQUE;
VAR
  BUF:ARRAY[0..1] OF XSTRING;
  CUR:0..1;
BEGIN
  CUR:=1;
  BUF[1-CUR][1]:=ENDSTR;
  WHILE (GETLINE(BUF[CUR],STDIN,MAXSTR))DO
    IF (NOT EQUAL (BUF[CUR],BUF[1-CUR])) THEN BEGIN
      PUTSTR(BUF[CUR],STDOUT);
      CUR:=1-CUR
    END
END;

PROCEDURE KWIC;
CONST
  FOLD=DOLLAR;
VAR
  BUF:XSTRING;

PROCEDURE PUTROT(VAR BUF:XSTRING);
VAR I:INTEGER;

PROCEDURE ROTATE(VAR BUF:XSTRING;N:INTEGER);
VAR I:INTEGER;
BEGIN
  I:=N;
  WHILE (BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
    PUTC(BUF[I]);
    I:=I+1
  END;
  PUTC(FOLD);
  FOR I:=1 TO N-1 DO
    PUTC(BUF[I]);
  PUTC(NEWLINE)
END;(*ROTATE*)

BEGIN(*PUTROT*)
  I:=1;
  WHILE(BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
    IF (ISALPHANUM(BUF[I])) THEN BEGIN
      ROTATE(BUF,I);(*TOKEN STATRS AT "I"*)
    REPEAT
      I:=I+1
    UNTIL (NOT ISALPHANUM(BUF[I]))
  END;
  I:=I+1
  END

END;(*PUTROT*)

BEGIN(*KWIC*)
  WHILE(GETLINE(BUF,STDIN,MAXSTR))DO
    PUTROT(BUF)
END;

PROCEDURE UNROTATE;
CONST
  MAXOUT=80;
  MIDDLE=40;
  FOLD=DOLLAR;
VAR
  INBUF,OUTBUF:XSTRING;
  I,J,F:INTEGER;
BEGIN
  WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO BEGIN
    FOR I:=1 TO MAXOUT-1 DO
      OUTBUF[I]:=BLANK;
    F:=INDEX(INBUF,FOLD);
    J:=MIDDLE-1;
    FOR I:=XLENGTH(INBUF)-1 DOWNTO F+1 DO BEGIN
      OUTBUF[J]:=INBUF[I];
      J:=J-1;
      IF(J<=0)THEN
        J:=MAXOUT-1
    END;
    J:=MIDDLE+1;
    FOR I:=1 TO F-1 DO BEGIN
      OUTBUF[J]:=INBUF[I];
      J:=J MOD (MAXOUT-1) +1
    END;
    FOR J:=1 TO MAXOUT-1 DO
      IF(OUTBUF[J]<>BLANK) THEN
        I:=J;
    OUTBUF[I+1]:=ENDSTR;
    PUTSTR(OUTBUF,STDOUT);
    PUTC(NEWLINE)
  END
END;