DECLARE SUB frame (left%, right%, top%, bottom%)
DECLARE SUB oldfile ()
DECLARE SUB mark ()
DECLARE SUB scan ()
DECLARE SUB traverse ()
DECLARE SUB pointers ()
DECLARE SUB rotate ()
DECLARE SUB intake ()
DECLARE SUB bldfile ()
DECLARE SUB newfile ()
REM BINARY TREE
TYPE kwicRec
  lf AS INTEGER
  hl AS STRING * 60
  pg AS STRING * 3
  dt AS STRING * 14
  rt AS INTEGER
  END TYPE
DIM SHARED kwic AS kwicRec
COMMON SHARED hl$, pg$, dt$, q$
COMMON SHARED pt%, ef%, n%
CLEAR , , 2000
CLS
LOCATE 5
PRINT TAB(29); "WELCOME TO TREEPROG": PRINT
PRINT TAB(28); "Please specify a file"
PRINT TAB(23); "(Example==> C:\TEMP.DAT)"
PRINT TAB(27); "and press ENTER to begin"
PRINT : PRINT TAB(27); "use ";
COLOR 0, 7
PRINT "C";
COLOR 7, 0
PRINT "aps for entry ";
COLOR 0, 7
PRINT "T";
COLOR 7, 0
PRINT "erms"
frame 18, 58, 2, 14
PRINT : PRINT : PRINT
DO
  LINE INPUT "File specification==> "; z$
LOOP UNTIL LEFT$(RIGHT$(z$, 4), 1) = "."
OPEN z$ FOR RANDOM AS #1 LEN = LEN(kwic)
y$ = LEFT$(z$, LEN(z$) - 3) + "TXT"
OPEN y$ FOR OUTPUT AS #2
DO
  CLS
  BEEP
  LINE INPUT "(B)uild or (M)anip or (X)Stop==> "; q$
  PRINT
  SELECT CASE UCASE$(q$)
    CASE "B"
      LINE INPUT "(N)ew file or (A)ppend to old==> "; q$
      SELECT CASE UCASE$(q$)
        CASE "N"
          newfile
          bldfile
        CASE "A"
          oldfile
          bldfile
      END SELECT
    CASE "M"
      LINE INPUT "(S)earch (D)elete (L)ist (X)==> "; q$
      q$ = UCASE$(q$)
      PRINT
      SELECT CASE q$
        CASE "S"
          CLOSE #2
          OPEN y$ FOR OUTPUT AS #2
          oldfile
          scan
          traverse
          IF hl$ <> "@" THEN
            LINE INPUT z$
          END IF
        CASE "D"
          oldfile
          scan
          mark
        CASE "L"
          CLOSE #2
          OPEN y$ FOR OUTPUT AS #2
          oldfile
          traverse
          LINE INPUT z$
        CASE "X"
      END SELECT
    CASE "X"
      CLOSE
      CLS
      END
  END SELECT
LOOP
SUB bldfile
  ef% = VAL(kwic.dt)
  DO
    ef% = ef% + 1
    intake
    rotate
  LOOP UNTIL hl$ = ""
  GET #1, 1, kwic
  kwic.dt = STR$(ef%)
  PUT #1, 1, kwic
END SUB
SUB frame (left%, right%, top%, bottom%)
  LOCATE top%, left%: PRINT CHR$(201)
  LOCATE top%, right%: PRINT CHR$(187)
  LOCATE bottom%, left%: PRINT CHR$(200)
  LOCATE bottom%, right%: PRINT CHR$(188)
  FOR vert% = top% + 1 TO bottom% - 1
    LOCATE vert%, left%: PRINT CHR$(186);
    LOCATE vert%, right%: PRINT CHR$(186);
  NEXT vert%
  horiz% = right% - left% - 1
  hline$ = STRING$(horiz%, 205)
  LOCATE top%, left% + 1: PRINT hline$
  LOCATE bottom%, left% + 1: PRINT hline$
END SUB
SUB intake
  PRINT
  LINE INPUT "HEADLINE==> "; hl$
  IF hl$ = "" THEN EXIT SUB
  LINE INPUT "PAGE==> "; pg$
  IF LEN(pg$) = 1 THEN
    pg$ = " " + pg$
  END IF
  PRINT "DATE==> "; kwic.dt;
  LINE INPUT "  OK? "; q$
  IF UCASE$(q$) = "N" THEN LINE INPUT "DATE==> "; dt$
  dt$ = UCASE$(dt$)
  pt% = 1
END SUB
SUB mark
  IF hl$ <> "@" THEN
    PRINT kwic.hl; kwic.dt; "P."; kwic.pg
    IF RIGHT$(kwic.hl, 1) = "@" THEN
      PRINT : PRINT "DELETED"
      LINE INPUT z$
    ELSE
      PRINT
      LINE INPUT "DELETE? "; q$
    END IF
    IF UCASE$(q$) = "Y" THEN
      kwic.hl = LEFT$(kwic.hl, 59) + "@"
      PUT #1, pt%, kwic
    END IF
  END IF
END SUB
SUB newfile
  LINE INPUT "Are you sure? "; q$
  IF UCASE$(q$) <> "Y" THEN EXIT SUB
  kwic.lf = 0
  kwic.hl = "*ROOT*" + SPACE$(53) + "@"
  kwic.pg = ""
  kwic.dt = "1"
  kwic.rt = 0
  ef% = 1
  PUT #1, ef%, kwic
END SUB
SUB oldfile
  GET #1, 1, kwic
  hl$ = ""
  pg$ = ""
  dt$ = ""
  n% = 0
END SUB
SUB pointers
  hl$ = UCASE$(hl$)
  GET #1, pt%, kwic
  IF hl$ <= kwic.hl THEN
    IF kwic.lf = 0 THEN
      kwic.lf = ef%
      PUT #1, pt%, kwic
      kwic.lf = 0
      kwic.hl = hl$
      kwic.pg = pg$
      kwic.dt = dt$
      kwic.rt = 0
      PUT #1, ef%, kwic
      EXIT SUB
    ELSE
      pt% = kwic.lf
    END IF
  ELSE
    IF kwic.rt = 0 THEN
      kwic.rt = ef%
      PUT #1, pt%, kwic
      kwic.lf = 0
      kwic.hl = hl$
      kwic.pg = pg$
      kwic.dt = dt$
      kwic.rt = 0
      PUT #1, ef%, kwic
      EXIT SUB
    ELSE
      pt% = kwic.rt
    END IF
  END IF
  pointers
END SUB
SUB rotate
  IF hl$ = "" THEN EXIT SUB
  FOR i = 1 TO LEN(hl$)
    t$ = hl$
    p = ASC(MID$(hl$, i, 1))
    IF p > 64 AND p < 91 THEN
      IF i = 1 THEN
        pointers
      ELSE
        pt% = 1
        ef% = ef% + 1
        hl$ = MID$(hl$, i) + "/ " + LEFT$(hl$, i - 1)
        pointers
      END IF
    END IF
    hl$ = t$
  NEXT i
END SUB
SUB scan
  CLS
  LINE INPUT "TARGET KEY==> "; hl$
  hl$ = UCASE$(hl$)
  PRINT
  IF q$ = "S" THEN
    LINE INPUT "OUTPUT TO PRINTER? "; q$
    q$ = UCASE$(q$)
    PRINT
  END IF
  DO
    IF hl$ > LEFT$(kwic.hl, LEN(hl$)) THEN
      IF kwic.rt = 0 THEN
        PRINT "STEM NOT FOUND"
        hl$ = "@"
        LINE INPUT z$
        EXIT SUB
      ELSE
        pt% = kwic.rt
        GET #1, pt%, kwic
      END IF
    ELSE
      IF hl$ < LEFT$(kwic.hl, LEN(hl$)) THEN
        IF kwic.lf = 0 THEN
          PRINT "STEM NOT FOUND"
          hl$ = "@"
          LINE INPUT z$
          EXIT SUB
        ELSE
          pt% = kwic.lf
          GET #1, pt%, kwic
        END IF
      ELSE
        EXIT SUB
      END IF
    END IF
  LOOP
END SUB
SUB traverse
  IF RIGHT$(kwic.hl, 1) <> "@" THEN
    kwic.hl = LEFT$(kwic.hl, LEN(kwic.hl) - 2) + "  "
  END IF
  IF kwic.lf = 0 AND kwic.rt = 0 THEN
    IF RIGHT$(kwic.hl, 1) <> "@" AND LEFT$(kwic.hl, LEN(hl$)) = hl$ THEN
      PRINT kwic.hl; kwic.dt; "P."; kwic.pg
      IF q$ = "Y" THEN
        LPRINT kwic.hl; kwic.dt; "P."; kwic.pg
      END IF
      w$ = kwic.hl + kwic.dt + "P." + kwic.pg
      WRITE #2, w$
      n% = n% + 1
      IF n% = 23 THEN
        n% = 0
        LINE INPUT z$
      END IF
    END IF
  END IF
  IF kwic.lf <> 0 AND kwic.rt <> 0 THEN
    lh$ = kwic.hl
    gp$ = kwic.pg
    td$ = kwic.dt
    rt% = kwic.rt
    GET #1, kwic.lf, kwic
    traverse
    IF RIGHT$(lh$, 1) <> "@" AND LEFT$(lh$, LEN(hl$)) = hl$ THEN
      PRINT lh$; td$; "P."; gp$
      IF q$ = "Y" THEN
        LPRINT lh$; td$; "P."; gp$
      END IF
      w$ = lh$ + td$ + "P." + gp$
      WRITE #2, w$
      n% = n% + 1
      IF n% = 23 THEN
        n% = 0
        LINE INPUT z$
      END IF
    END IF
    GET #1, rt%, kwic
    traverse
  END IF
  IF kwic.lf <> 0 AND kwic.rt = 0 THEN
    lh$ = kwic.hl
    gp$ = kwic.pg
    td$ = kwic.dt
    GET #1, kwic.lf, kwic
    traverse
    IF RIGHT$(lh$, 1) <> "@" AND LEFT$(lh$, LEN(hl$)) = hl$ THEN
      PRINT lh$; td$; "P."; gp$
      IF q$ = "Y" THEN
        LPRINT lh$; td$; "P."; gp$
      END IF
      w$ = lh$ + td$ + "P." + gp$
      WRITE #2, w$
      n% = n% + 1
      IF n% = 23 THEN
        n% = 0
        LINE INPUT z$
      END IF
    END IF
  END IF
  IF kwic.lf = 0 AND kwic.rt <> 0 THEN
    IF RIGHT$(kwic.hl, 1) <> "@" AND LEFT$(kwic.hl, LEN(hl$)) = hl$ THEN
      PRINT kwic.hl; kwic.dt; "P."; kwic.pg
      IF q$ = "Y" THEN
        LPRINT kwic.hl; kwic.dt; "P."; kwic.pg
      END IF
      w$ = kwic.hl + kwic.dt + "P." + kwic.pg
      WRITE #2, w$
      n% = n% + 1
      IF n% = 23 THEN
        n% = 0
        LINE INPUT z$
      END IF
    END IF
    GET #1, kwic.rt, kwic
    traverse
  END IF
END SUB