DECLARE SUB repl (z$, y$, x$)
DECLARE SUB hurl (z!, z$)
DECLARE SUB cast (z$)
DECLARE SUB copyright ()
DECLARE SUB cybertla ()
DECLARE SUB instructions ()
DECLARE SUB oops ()
DECLARE FUNCTION exist! (z$, a!)
DIM SHARED h.1, v.1, h.2, v.2 AS INTEGER
DIM SHARED c.b.f, c.b.b AS INTEGER: c.b.f = 1: c.b.b = 0 ' border
DIM SHARED c.u.f, c.u.b AS INTEGER: c.u.f = 2: c.u.b = 0 ' text: upper
DIM SHARED c.l.f, c.l.b AS INTEGER: c.l.f = 10: c.l.b = 0 ' text: lower
DIM SHARED c.t.f, c.t.b AS INTEGER: c.t.f = 3: c.t.b = 0 ' text: message
DIM SHARED utla$, unam$, uver$, upar$, udat$
utla$ = "PDC"
unam$ = "PCBoard (File) Description Compressor"
uver$ = "2.00112ß"
upar$ = "sourcefile targetfile"
udat$ = "92/7/23"
COLOR 7, 0: WIDTH 80, 25: CLS
COLOR c.t.f, c.t.b
cybertla
COLOR 14, 0: LOCATE 1, 1
PRINT " ███▄ ███▄ ▄███ "
PRINT " █▄▄█ █▄▄█ █▄▄▄ "
PRINT " ██ ███▀ ▀███ "
PRINT
DIM SHARED bad$
DIM SHARED ps(1 TO 4) AS STRING * 64: pn = 0
z1$ = UCASE$(LTRIM$(RTRIM$(COMMAND$)))
z1 = INSTR(z1$, " ")
DO WHILE (pn < 3) AND (z1 > 0)
pn = pn + 1
ps(pn) = LEFT$(z1$, z1 - 1)
z1$ = MID$(z1$, z1 + 1)
z1 = INSTR(z1$, " ")
LOOP
IF (pn < 3) AND (LEN(LTRIM$(z1$)) > 0) THEN
pn = pn + 1
ps(pn) = z1$
END IF
IF RTRIM$(ps(1)) = "" THEN bad$ = "Parameters required": oops: GOTO fin
IF RTRIM$(ps(1)) = "?" THEN instructions: GOTO fin
IF RTRIM$(ps(1)) = "/?" THEN instructions: GOTO fin
IF RTRIM$(ps(1)) = "HELP" THEN instructions: GOTO fin
IF RTRIM$(ps(1)) = "/HELP" THEN instructions: GOTO fin
IF pn < 1 THEN bad$ = "sourcefile required (ie: NEW)": oops: GOTO fin
IF pn < 2 THEN bad$ = "targetfile required (ie: NEW.FIX)": oops: GOTO fin
IF pn > 2 THEN bad$ = "Too many variables": oops: GOTO fin
IF exist(ps(1), 1) = 0 THEN bad$ = "No such sourcefile": oops: GOTO fin
IF exist(ps(2), 1) = 1 THEN bad$ = "Targetfile exists": oops: GOTO fin
COLOR c.b.f, c.b.b
LOCATE 4, 1: PRINT "┌"; STRING$(78, "─"); "┐";
LOCATE 14, 1: PRINT "├"; STRING$(78, "─"); "┤";
LOCATE 24, 1: PRINT "└"; STRING$(78, "─"); "┘";
FOR r = 1 TO 9
LOCATE 4 + r, 1: PRINT "│"; : LOCATE 4 + r, 80: PRINT "│";
LOCATE 14 + r, 1: PRINT "│"; : LOCATE 14 + r, 80: PRINT "│";
NEXT
COLOR c.t.f, c.t.b
LOCATE 25, 1: PRINT " Working, Please standby.";
CLOSE #1: OPEN ps(1) FOR INPUT ACCESS READ LOCK WRITE AS #1
CLOSE #2: OPEN ps(2) FOR OUTPUT ACCESS WRITE LOCK READ WRITE AS #2
VIEW PRINT 5 TO 13: h.1 = POS(0): v.1 = CSRLIN: v.1 = 13: PRINT
VIEW PRINT 15 TO 23: h.2 = POS(0): v.2 = CSRLIN: v.2 = 23: PRINT
locked = 0
specs$ = ""
desc$ = ""
tail$ = ""
DO WHILE EOF(1) = 0
LINE INPUT #1, z1$
z1$ = LEFT$(z1$ + STRING$(80, " "), 80)
z2$ = UCASE$(LTRIM$(RTRIM$(z1$)))
special = 0
IF LEFT$(z2$, 15) = "| UPLOADED BY: " THEN special = 1
' room for multiple exceptions, date clauses, etc ...
SELECT CASE special
CASE 1
z2$ = MID$(z1$, 32)
repl z2$, " ", " "
hurl 1, STRING$(31, " ") + z2$
tail$ = STRING$(31, " ") + z2$
' could opt to add tail$ to tail$ for many clauses, with CRLFs
CASE ELSE
IF locked = 1 THEN status = 1 ELSE status = 0
IF MID$(z1$, 26, 1) = "-" OR MID$(z1$, 29, 1) = "-" THEN
status = status + 10
END IF
SELECT CASE status
CASE 0 ' looking for file, line is not a file starter
hurl 2, z1$
CASE 1 ' reading description for a file, line is not a file starter
desc$ = RTRIM$(desc$) + " " + RTRIM$(MID$(z1$, 34))
CASE 10 ' looking for a file, line contains file info
locked = 1
specs$ = LEFT$(z1$, 33)
desc$ = RTRIM$(MID$(z1$, 34))
CASE 11 ' reading description for a file, line contains file info
GOSUB crush
specs$ = LEFT$(z1$, 33)
desc$ = RTRIM$(MID$(z1$, 34))
END SELECT
hurl 1, z1$
END SELECT
LOOP
IF locked = 1 THEN GOSUB crush
VIEW PRINT 4 TO 25: COLOR 7, 0: CLS
VIEW PRINT 1 TO 25: LOCATE 5, 1
fin:
COLOR c.t.f, c.t.b
copyright
COLOR 7, 0
CLOSE
END
crush:
desc$ = desc$ + " "
repl desc$, " ", " "
first$ = LEFT$(desc$, 46)
DO WHILE (RIGHT$(first$, 1) <> " ") AND (LEN(first$) > 0)
first$ = LEFT$(first$, LEN(first$) - 1): LOOP
IF first$ = "" THEN first$ = LEFT$(desc$, 45)
hurl 2, specs$ + first$
remains$ = LTRIM$(MID$(desc$, LEN(first$) + 1))
DO WHILE LEN(remains$) > 0
another$ = LEFT$(remains$, 46) ' trailing space already
DO WHILE (RIGHT$(another$, 1) <> " ") AND (LEN(another$) > 0)
another$ = LEFT$(another$, LEN(another$) - 1)
LOOP
IF another$ = "" THEN another$ = LEFT$(remains$, 45)
hurl 2, STRING$(31, " ") + "| " + another$
remains$ = LTRIM$(MID$(remains$, LEN(another$) + 1))
LOOP
IF tail$ <> "" THEN
hurl 2, tail$
tail$ = ""
END IF
RETURN
SUB cast (z$)
' z$ : string
'----------------------------------------------------------------------------
PRINT LEFT$(z$, 79)
END SUB
SUB copyright
' no parameters
'----------------------------------------------------------------------------
cast utla$ + " (c) Copyright 19" + LEFT$(udat$, 2) + " westsmith"
cast "You may use these programs in any environment, without any remuneration to me."
cast "Feel free to distribute copies, as long as all the files are included together"
cast "in CYB" + RIGHT$("0" + LTRIM$(STR$(INT(VAL(uver$)))), 2) + utla$ + ".* and are not modified. If you find this utility to be of use, do"
cast "yourself a favour and pick up a copy of NEUROMANCER, by William Gibson."
PRINT
END SUB
SUB cybertla
' no parameters
'----------------------------------------------------------------------------
cast " ¬¥⌐ " + utla$ + " " + uver$ + " " + unam$
cast " <<> westsmith " + udat$ + ", The FlatEarth BBS, CyberNET 1:416/803.0"
cast " A Cybertool, " + qq$ + "Long live William Gibson." + qq$
PRINT
END SUB
FUNCTION exist (z$, a)
' z$ : filename to check for
' a : filenumber to use
'----------------------------------------------------------------------------
CLOSE #a: OPEN z$ FOR BINARY ACCESS WRITE LOCK READ WRITE AS a
IF LOF(a) = 0 THEN
CLOSE #a
KILL z$
exist = 0
ELSE
exist = 1
END IF
CLOSE #a
END FUNCTION
SUB hurl (z, z$)
IF z = 1 THEN
VIEW PRINT 5 TO 13: LOCATE v.1, h.1: PRINT : LOCATE v.1, h.1
z1 = c.u.f: z2 = c.u.b
ELSE
PRINT #2, RTRIM$(z$)
VIEW PRINT 15 TO 23: LOCATE v.2, h.2: PRINT : LOCATE v.2, h.2
z1 = c.l.f: z2 = c.l.b
END IF
COLOR c.b.f, c.b.b: PRINT "│";
COLOR z1, z2: PRINT LEFT$(z$ + STRING$(78, " "), 78);
COLOR c.b.f, c.b.b: PRINT "│";
IF z = 1 THEN
h.1 = POS(0): v.1 = CSRLIN
ELSE
h.2 = POS(0): v.2 = CSRLIN
END IF
END SUB
SUB instructions
' no parameters
'----------------------------------------------------------------------------
COLOR 10, 0
cast " Format: " + utla$ + " " + upar$
PRINT
COLOR 2, 0
cast " [█] " + qq$ + "WHY WOULD I WANT TO COMPRESS MY PCBOARD FILE DESCRIPTIONS?" + qq$
cast " └─ PCBoard's rather handy capacity for directly inserting file descriptions"
cast " can save a sysop a lot of work but the standard ID file doesn't use the"
cast " full default width that PCBoard allows, spreading text across less-than"
cast " full lines. This can mean several extra screens-full of listing for users."
cast ""
cast " " + utla$ + " will read in the full description for each file, remove extra spaces"
cast " and then re-write the text using as few lines as possible. The sourcefile"
cast " should be a regular PCBoard directory listing, which can be replaced by"
cast " the targetfile once " + utla$ + " has finished."
PRINT
END SUB
SUB oops
' no parameters
'----------------------------------------------------------------------------
COLOR 12, 0
cast " <!> ERROR: " + bad$
cast " Type " + utla$ + " /HELP for basic instructions"
cast ""
cast " Format: " + utla$ + " " + upar$
PRINT
END SUB
SUB repl (z$, y$, x$)
' z$ : string to work on
' y$ : replace
' x$ : with
'----------------------------------------------------------------------------
z = INSTR(z$, y$)
DO WHILE z > 0
z$ = LEFT$(z$, z - 1) + x$ + MID$(z$, z + LEN(y$))
z = INSTR(z$, y$)
LOOP
END SUB
