'===========================================================================
' Subject: KELVINATOR - REDUCE SOURCE SIZE   Date: 10-13-99 (21:59)       
' Author:  Antoni Gual                       Code: QB, PDS                
' Origin:  agual@eic.ictnet.es             Packet: MISC.ABC
'===========================================================================
DECLARE SUB Intro ()
DECLARE FUNCTION BInstr% (FROM%, a$, c$)
DECLARE FUNCTION Kelvinate$ (a$)
DECLARE FUNCTION filesel$ (prompt$, match%)
DECLARE FUNCTION IsKeyword% (w$)
DECLARE FUNCTION IsLinenum% (a$)
DECLARE SUB LoadKwds ()
DECLARE FUNCTION Firstword$ (w$)
DECLARE FUNCTION Cleanout$ (a$)
'............................................................................
'KELVINATOR, by Antoni Gual  agual@eic.ictnet.es
'............................................................................
'This program could help yo if you are short of space in your IDE
' for a particular program.
'
'It will remove all that's unnecesary to run your program
'It has two levels:
' -First level removes indentation, tabs,blank lines, comments
'   giving an important gain of place in the IDE
'
' -Second level chains lines in one wherever it's possible, making a program
'   very difficult to read by 'reverse engineers', but perfectly runable.
'   (Well...this is what I tried to do.. No warranties!)
'   This second level does'nt give any valuable gain of space, it's only fun!
'
'No risk of destroying the original source as program outputs to a new file
'with the original's name and '.bak' extension.
'
'It's exactly the reverse of 'pretty printers', or a good way to prepare test
' programs for one of them :-)
'
'NOTE: The funny name comes from an equivalent program for LISP
'
'Check the self-contained file selection function!
'............................................................................
'Use it in your programs as you want, only give me credit.
'CONTACT ME WITH YOUR OPINIONS !!
'.............................................................................

DEFINT A-Z

'$INCLUDE: 'qb.bi'

CONST false = 0, true = NOT false
CONST nnum = "0123456789"
CONST inum = "0123456789-"
CONST fpnum = "0123456789-ED."



DIM SHARED metacom AS INTEGER
DIM SHARED estring$
DIM SHARED errata, words
REDIM SHARED qword$(0)
DIM SHARED inreg AS RegType
DIM SHARED crlf$: crlf$ = CHR$(13) + CHR$(10)
LoadKwds
Intro
filename$ = filesel$("Select file to Kelvinate", 0)
filename$ = LEFT$(filename$, INSTR(filename$, ".") - 1)

ON ERROR GOTO 0
OPEN filename$ + ".bas" FOR BINARY AS #1
a$ = " "
GET #1, , a$
CLOSE
IF a$ = CHR$(&HFC) THEN PRINT "The file is in QB format, please resave it in ASCII": END

INPUT "Clean rems only? [y/n]", k$: IF UCASE$(k$) = "Y" THEN klv = false ELSE klv = true
OPEN filename$ + ".bas" FOR INPUT AS #1
OPEN filename$ + ".bak" FOR OUTPUT AS #2

CLS : PRINT "Kelvinating file "; filename$; ".bas"; : LOCATE 2, 1: PRINT "Progress: ";
siz1& = LOF(1)
'main loop
DO
	ptr& = SEEK(1)
	LINE INPUT #1, a$
	LOCATE 2, 12: PRINT SPACE$(5); : LOCATE , 12: PRINT ptr& * 100 \ siz1&; " %";
	a$ = Cleanout$(a$)
	IF klv AND LEN(a$) AND NOT metacom THEN a$ = Kelvinate$(a$)
	IF LEN(a$) THEN PRINT #2, a$
LOOP UNTIL EOF(1)
IF klv THEN PRINT #2, Kelvinate$("")
LOCATE 3, 1: PRINT "Done!"
CLOSE
ERASE qword$
END

errorhandler: errata = ERR: RESUME NEXT



'keywords
QData:
DATA ABS,ABSOLUTE,APPEND,ACCESS,AS,ALIAS,ASC,ANY,ATN

DATA BASE,BLOAD,BSAVE,BEEP,BYVAL,BINARY

DATA CALL,CLS,CALLS,COLOR,CASE,COMMAND$,COMMON,COM,CDBL
DATA CONST,CDECL,COS,CHAIN,CSNG,CHDIR,CSRLIN,CHR$,CVD
DATA CINT,CVDMBF,CIRCLE,CVI,CLEAR,CVL, CLNG,CVS,CLOSE,CVSMBF

DATA DATA,DEF,DEFINT,DEFLNG,DATE$,DEFSNG,DEFSTR,DECLARE,DIM
DATA DO,DOUBLE,DRAW, DEFDBL,$DYNAMIC

DATA ELSE, ERDEV,ELSEIF,ERDEV$,END,ERROR,ERL,ERR,ENVIRON
DATA ENVIRON$,EXIT,EOF,EXP,EQV,ERASE

DATA FIELD,FOR,FILEATTR,FRE,FILES,FREEFILE,FIX,FUNCTION

DATA GOTO,GOSUB,GET

DATA HEX$

DATA IF,INTERRUPT,INPUT$,IMP,INSTR,$INCLUDE,INT,INKEY$,INTEGER
DATA INP,IOCTL,IOCTL$,IS,INPUT

DATA KILL,KEY

DATA LBOUND,LOCATE,LCASE$,LOCK,LEFT$,LOF,LEN,LOG,LET,LONG
DATA LINE,LOOP,LPOS,LIST,LPRINT,LOC,LSET,LOCAL,LTRIM$

DATA MID$,MKL$,MKS$,MKD$,MKSMBF$,MKDIR,MOD,MKDMBF$,MKI$

DATA NAME,NEXT,NOT

DATA OCT$,OFF,ON,OPEN,OPTION,OR,OUT,OUTPUT

DATA PLAY,PAINT,POINT,PALETTE,POKE,PCOPY,POS,PEEK,PRESET,PEN
DATA PRINT,PSET,PMAP,PUT,RANDOM,RETURN,RANDOMIZE, RIGHT$,READ
DATA RMDIR,REDIM,RND,REM,RSET,RESET,RTRIM$,RESTORE,RUN,RESUME

DATA SADD,STRIG,SPC,SCREEN,SQR,STATIC,SEEK,$STATIC,STEP,SELECT
DATA STICK,SETMEM,STOP,SEG,SGN,STR$,SHARED,SHELL,SIGNAL,STRING
DATA SIN,STRING$,SINGLE,SUB,SLEEP,SWAP,SOUND,SYSTEM,SPACE$

DATA TAB,TAN,TO,THEN,TROFF,TRON,TIME$,TYPE,TIMER

DATA UBOUND,UNLOCK,UCASE$,UNTIL,USING,UEVENT

DATA VAL,VARSEG,VIEW,VARPTR,VARPTR$

DATA WAIT,WINDOW,WEND,WRITE,WHILE,WIDTH

DATA @@@

FUNCTION BInstr% (FROM, a$, c$)
	BInstr% = 0
	IF FROM > LEN(a$) THEN EXIT FUNCTION
	IF LEN(c$) = 0 THEN EXIT FUNCTION
	IF LEN(a$) = 0 THEN EXIT FUNCTION
	IF FROM <= 0 THEN FROM = LEN(a$)
	P1 = LEN(c$)
	car = ASC(MID$(c$, P1, 1))
	T2 = FROM
	DO WHILE T2
		IF ASC(MID$(a$, T2, 1)) = car THEN
			DO
				P1 = P1 - 1
				IF P1 = 0 THEN
					BInstr% = T2: EXIT FUNCTION
				ELSEIF T2 = 1 THEN
					BInstr% = 0: EXIT FUNCTION
				ELSE
					car = ASC(MID$(c$, P1, 1))
					T2 = T2 - 1
					IF ASC(MID$(a$, T2, 1)) <> car THEN
						P1 = LEN(c$): car = ASC(MID$(c$, P1, 1)): EXIT DO
					END IF
				END IF
			LOOP
		END IF
		T2 = T2 - 1
	LOOP
END FUNCTION

FUNCTION Cleanout$ (a$)
	metacom = false
	'trim tabs and spaces at end of line
	DO WHILE LEFT$(a$, 1) = CHR$(9) OR LEFT$(a$, 1) = CHR$(32): a$ = MID$(a$, 2): LOOP
	 

	'skip null lines
	IF a$ = "" THEN GOTO nooutput
 
	'comments with' skipped if not metacommands
	IF LEFT$(a$, 1) = "'" THEN
		IF MID$(a$, 2, 1) = "$" THEN metacom = true: GOTO trim ELSE GOTO nooutput
	END IF
  
	'skip REMS
	IF LEFT$(a$, 4) = "REM " THEN
		IF MID$(a$, 6, 1) = "$" THEN metacom = true: GOTO trim ELSE GOTO nooutput
	END IF
  
	'delete double spaces and ' rems not at the beggining of line
	'create a string mask, to skip them in next parses
  
	estring$ = SPACE$(LEN(a$))  'shared
	strng = false: spa = false
	SWAP t$, a$: a$ = ""
	FOR i = 1 TO LEN(t$)
		car = ASC(MID$(t$, i))
		SELECT CASE car:
		CASE 32:
			IF NOT strng THEN
				IF spa THEN GOTO skipcar ELSE spa = true
			END IF
		CASE 9:
			IF NOT strng THEN
			  car = 32: IF spa THEN GOTO skipcar ELSE spa = true
			END IF
		CASE 34: spa = false: strng = NOT strng
		CASE 39:
			IF NOT strng THEN EXIT FOR
		CASE ELSE
			spa = false
		END SELECT
		a$ = a$ + CHR$(car)
		IF strng THEN MID$(estring$, LEN(a$), 1) = "X"
skipcar:
	NEXT
   
	'clear unneeded " from data
	IF LEFT$(a$, 5) = "DATA " THEN
		FOR i = LEN(a$) TO 6 STEP -1
			IF MID$(a$, i, 1) = " " AND MID$(estring$, i, 1) = " " THEN
				a$ = LEFT$(a$, i - 1) + MID$(a$, i + 1)
				estring$ = LEFT$(estring$, i - 1) + MID$(estring$, i + 1)
			END IF
		NEXT
		strg = 0
		FOR i = LEN(a$) TO 5 STEP -1
			IF strg = 0 THEN IF MID$(estring$, i, 1) = "X" THEN strg = i
			IF strg AND MID$(estring$, i, 1) = " " THEN
				IF espa = 0 THEN
					t$ = a$
					a$ = LEFT$(t$, i) + MID$(t$, i + 2, strg - i - 1) + MID$(t$, strg + 2)
					estring$ = LEFT$(estring$, i) + SPACE$(strg - i - 1) + MID$(estring$, strg + 2)
				END IF
				strg = 0: espa = 0
			END IF
			IF strg THEN
				b = ASC(MID$(a$, i, 1))
				IF b = 32 OR b = 44 OR b = 58 THEN espa = 1
			END IF
		NEXT
	END IF
trim:

	'trim REM rems
	rm = INSTR(a$, "REM")
	IF rm THEN IF ASC(MID$(estring$, rm)) = 32 THEN a$ = LEFT$(a$, rm - 1)


	'trim spaces,tabs and : at the line end
	b = ASC(RIGHT$(a$, 1))
	DO WHILE b = 9 OR b = 32
	a$ = LEFT$(a$, LEN(a$) - 1): b = ASC(RIGHT$(a$, 1))
	LOOP

	'skip null lines
	IF a$ = "" THEN GOTO nooutput

	Cleanout$ = a$
EXIT FUNCTION
nooutput:
	Cleanout$ = ""
END FUNCTION

FUNCTION filesel$ (prompt$, match%) 'Allows user to select a file
'............................................................................
'SELF-CONTAINED FILE SELECTOR FUNCTION by Antoni Gual (agual@eic.ictnet.es)
'----------------------------------------------------------------------------
'match% on input  0= must match 1=must not match 2=indiferent
'match% on output 1=found       0=not found
'----------------------------------------------------------------------------
'This single function will add to your programs an 'user friendly' file
'  selection interface.
'To use it follow the steps:
'
'    -Enable the program for interrupt handling.
'       /lqb and '$INCLUDE: 'QB.BI'  for QuickBasic
'       use one of the ABC interrupt interface routines in QBasic
'            NOTE: If you don't want to add interrupt access to your program
'            simply uncomment the indicated line, the function will work
'            and will loose only the ability of changing drive.
'
'    -Add three lines to the main part of the module. Uncomment them! ;)
'       In the DIM part:
'
'       DIM shared inreg AS REGTYPE   'only if you have interrupt access
'       DIM SHARED errata AS INTEGER
'
'       Past the END of the program:
'
'       errorhandler:errata=ERR:RESUME NEXT
'
'    -Last but not Least: Add this function to your program!
'
'and thatïs all! Call filesel$, it will return with the filename you selected.
'It detects and handles all disk errors I'm able to imaginate.
'
'Only a WARNING: It changes the default drive and path to where the file is!
'.............................................................................
'Use it in your programs as you want, only give me credit.
'CONTACT ME WITH YOUR OPINIONS !!
'.............................................................................
'Version History:
'        detecta error de dar como nombre un path
'8/10/99 gesti¢n de match
'8/10/99 comprobaci¢n de letra de unidad
'8/10/99 usa freefile para test de fichero existente
'8/10/99 color segun drive/path/file
'pdte    a¤adir gesti¢n de extensi¢n
'pdte    no modificar dir actual, devolver path completo a fichero
'
'(Just in case you read spanish: 'pdte' is my shorthand for TO DO...)
'............................................................................
'The real thing:
'............................................................................
'error messages
CONST pak$ = ". Press a key.."
CONST pnf$ = "Path not Found"
CONST ddne$ = "Drive does not Exist"
CONST dnr$ = "Drive not ready. [Retry/Abort]"
CONST fdne$ = "File not found"
CONST ifn$ = "Invalid File Name"
CONST idn$ = "Invalid Drive Name"
CONST pfe$ = "Path-file error"
ff$ = ""
filnum = FREEFILE
'screen reset, start error handler
VIEW PRINT: COLOR 7, 0: CLS
ON ERROR GOTO errorhandler

DO
	GOSUB VIEWFILES
'
'UNCOMMENT NEXT LINE IF YOU DON'T HAVE INTERRUPT ACCESS!!
'GOTO ASKPATH
'
askdrive:
	COLOR 15, 4: CLS
	GOSUB question: INPUT ; "Drive [Enter:Current]>", drive$
'if no input, go ask path
	IF LEN(drive$) THEN
R3:
		IF LEN(drive$) > 2 THEN ERROR 64: GOTO BADDRIVE
		DRIV% = ASC(UCASE$(drive$)) - 65
		IF DRIV% < 0 OR DRIV% > 23 THEN ERROR 64: GOTO BADDRIVE
		inreg.ax = &HE00: inreg.dx = DRIV%
		CALL INTERRUPT(&H21, inreg, inreg)
'probably the drive we asked for does'nt exist
		inreg.ax = &H1900
		CALL INTERRUPT(&H21, inreg, inreg)
		IF (inreg.ax AND &HFF) <> DRIV% THEN ERROR 68
BADDRIVE:
		SELECT CASE errata
		CASE 64:
		msgerr$ = idn$ + pak$: GOSUB errmsg: GOTO askdrive
		CASE 68: msgerr$ = ddne$ + pak$: GOSUB errmsg: GOTO askdrive
		CASE 71: msgerr$ = dnr$: GOSUB errmsg: IF a$ = "R" THEN GOTO R3 ELSE GOTO askdrive
		END SELECT
		GOSUB VIEWFILES
	END IF

askpath:
'what is in?  Here we trap the no disk error
	COLOR 14, 4: CLS
R4:
	IF errata = 71 THEN msgerr$ = dnr$: GOSUB errmsg: IF a$ = "R" THEN GOTO R4 ELSE GOTO askdrive
	GOSUB question: INPUT ; "Path [Enter:Current]>", path$
'if no input go ask filename
	IF LEN(path$) THEN
R1:
		CHDIR path$
		IF errata = 53 OR errata = 76 THEN msgerr$ = pnf$ + pak$: GOSUB errmsg: GOTO askpath
		IF errata = 71 THEN msgerr$ = dnr$: GOSUB errmsg: IF a$ = "R" THEN GOTO R1 ELSE GOTO askdrive
		GOSUB VIEWFILES
	END IF
askname:
	COLOR 7, 4: CLS
	GOSUB question: INPUT ; "File [Enter:New path]>", name$
'does it exist?
R2:
	OPEN name$ FOR INPUT AS #filnum
	SELECT CASE errata
	CASE 76: msgerr$ = pnf$ + pak$: GOSUB errmsg: GOTO askname
	CASE 53:
		IF match = 0 THEN
			LOCATE 2, 1: msgerr$ = fdne + pak$: GOSUB errmsg: GOTO askname
		ELSE
			ff$ = " NOT ": GOTO outofthere
		END IF
	CASE 64: LOCATE 2, 1: msgerr$ = ifn$ + pak$: GOSUB errmsg: GOTO askname
	CASE 71: msgerr$ = dnr$: GOSUB errmsg: IF a$ = "R" THEN GOTO R2 ELSE GOTO askdrive
	CASE 75: msgerr$ = pfe$ + pak$: GOSUB errmsg: GOTO askname
	END SELECT
r5:
CLOSE #filnum
LOOP UNTIL LEN(name$)

outofthere:
'file exists: return
msgerr$ = "File " + UCASE$(name$) + ff$ + " found.." + pak$: GOSUB errmsg
VIEW PRINT: COLOR 7, 0: CLS

IF LEN(ff$) THEN match% = 0 ELSE match = 1
filesel$ = name$
ON ERROR GOTO 0
EXIT FUNCTION

VIEWFILES:
	VIEW PRINT 3 TO 25: COLOR 7, 0: CLS : FILES:
	VIEW PRINT 1 TO 2:
RETURN

question:
LOCATE 1, 1: PRINT SPACE$(80); : LOCATE 1, 1: PRINT prompt$ + "? -->Select ";
RETURN

errmsg:
LOCATE 2, 1: PRINT msgerr$; : a$ = UCASE$(INPUT$(1)): LOCATE 2, 1: PRINT SPACE$(80)
errata = 0
RETURN

END FUNCTION

FUNCTION Firstword$ (w$)
   STATIC a$, ptr
   IF LEN(w$) = 0 AND ptr = 0 THEN Firstword$ = "": EXIT FUNCTION
   IF LEN(w$) THEN a$ = w$: ptr = 1
   s = INSTR(ptr, a$, " ")
   IF s = 0 THEN
	  Firstword$ = MID$(a$, ptr)
	  ptr = 0
   ELSE
	  Firstword$ = MID$(a$, ptr, s - ptr)
	  ptr = s + 1
   END IF
END FUNCTION

SUB IDEAS
'      Los programas que saca no siempre funcionan
'      No reconoce IF ... GOTO ni IF... GOSUB
'      Podrian empaquetarse los DATA
'      tambi‚n los if-then-else internos
END SUB

SUB Intro
COLOR 7, 0
CLS
COLOR 13
PRINT "............................................................................"
PRINT "                 KELVINATOR, by Antoni Gual  agual@eic.ictnet.es"
PRINT "............................................................................"
COLOR 7
PRINT "This program could help yo if you are short of place in your IDE to run a"
PRINT " particular program."
PRINT "It will remove all that's unnecesary to run your program"
PRINT "It has two levels:"
PRINT " -First level removes indentation, tabs, blank lines, comments, unneeded"
PRINT "   quotes in data, giving an important gain of place in IDE .This part is safe."
PRINT " -Second level chains lines in one wherever it's; possible, making a program"
PRINT "   very difficult to read by ' reverse engineers', but runable in theory."
PRINT "   At the moment, the resultant program can run in a 90% of cases and still does"
PRINT "   what itïs suposed to do in 80% of the cases. There's a place for improvement."
PRINT "No risk of destroying the original source as program outputs to a new file"
PRINT "with the original's name and '.bak' extension."
PRINT "It's exactly the reverse of 'pretty printers', or a good way to prepare test"
PRINT " programs for one of them :-)"
PRINT "NOTE: The funny name comes from an equivalent program for LISP"
PRINT "Check the self-contained file selection function!"
COLOR 14
PRINT "............................................................................"
PRINT "Use it in your programs as you want, only give me credit."
PRINT "CONTACT ME WITH YOUR OPINIONS !!";
LOCATE 25, 1: COLOR 12: PRINT "Press any key.."; : a$ = INPUT$(1)
END SUB

FUNCTION IsKeyword (w$)
	IsKeyword = false
	IF w$ <> UCASE$(w$) THEN EXIT FUNCTION
	IF w$ < qword$(1) THEN EXIT FUNCTION
	IF w$ > qword$(words) THEN EXIT FUNCTION
	P1 = 1: P2 = words
	DO
		p3 = (P1 + P2) \ 2: a$ = qword$(p3)
		IF w$ = a$ THEN IsKeyword = true: EXIT FUNCTION
		IF w$ < a$ THEN P2 = p3 - 1:  ELSE P1 = p3 + 1
	LOOP UNTIL P1 > P2
END FUNCTION

FUNCTION IsLinenum (a$)
	IsLinenum = false
	FOR i = 1 TO LEN(a$) - 1
		IF NOT INSTR(nnum, MID$(a$, i, 1)) THEN EXIT FUNCTION
	NEXT
	IsLinenum = true
END FUNCTION

FUNCTION Kelvinate$ (a$)

STATIC w$
	IF a$ = "" THEN Kelvinate$ = w$: w$ = "": EXIT FUNCTION
	fw$ = Firstword(a$)
   
	' with line numbers we start a new line
	IF IsLinenum(fw$) THEN PRINT #2, w$: w$ = a$: GOTO startline
   
	'check for kwd
	IF NOT IsKeyword(fw$) THEN
	   
		' with labels we start a new line
		IF RIGHT$(fw$, 1) = ":" THEN
			GOTO startline
		'sub names
		ELSE
			'sub names without parameters at beggining of line require CALL
			IF LEN(w$) = 0 THEN IF LEN(a$) = LEN(fw$) THEN a$ = "CALL " + a$
			GOTO addtoline
		END IF

	'treat line depending on starting kwd
	ELSE
		SELECT CASE fw$
		'sub and function headers must be in a line of their own
		CASE "SUB", "FUNCTION":     GOTO ownline
		'CASE "SELECT", "CASE":      GOTO STARTLINE
	   
		'pack as many data fit in a single line
		CASE "DATA":
			 GOTO startline
		CASE "ELSE", "ELSEIF"
			GOTO ownline
		CASE "END"
			dummy$ = Firstword(a$): swd$ = Firstword$("")
			SELECT CASE swd$
			CASE "SELECT", "IF": GOTO startline
			CASE ELSE: GOTO addtoline
			END SELECT
		CASE ELSE
			'if it has a then and it's not the last thing in line must end line
			b = BInstr%(0, a$, " THEN")
			IF b = 0 THEN GOTO addtoline
			IF b < LEN(a$) - 5 THEN
				GOTO finishline
			ELSE
				GOTO ownline
			END IF
		END SELECT
	END IF
EXIT FUNCTION


startline:
IF LEN(w$) THEN Kelvinate$ = w$
w$ = a$: EXIT FUNCTION


finishline:
  IF LEN(w$) + LEN(a$) <= 253 THEN
	  IF LEN(w$) THEN
		  IF RIGHT$(w$, 1) <> ":" THEN col$ = ": " ELSE col$ = " "
		  w$ = w$ + col$ + a$: Kelvinate$ = w$: w$ = "": EXIT FUNCTION
	  END IF
  END IF

ownline:
IF LEN(w$) THEN w$ = w$ + crlf$
Kelvinate$ = w$ + a$: w$ = "": EXIT FUNCTION


addtoline:
	IF LEN(w$) + LEN(a$) <= 253 THEN
		IF LEN(w$) THEN
			IF RIGHT$(w$, 1) <> ":" THEN col$ = ": " ELSE col$ = " "
			w$ = w$ + col$ + a$: Kelvinate$ = "": EXIT FUNCTION
		ELSE
			w$ = a$: Kelvinate$ = "": EXIT FUNCTION
		END IF
	ELSE
	   lima = 253 - LEN(w$)
	   DO
			colon = BInstr%(lima, a$, ":")
			IF colon THEN IF MID$(estring$, colon, 1) = " " THEN EXIT DO
			lima = colon - 1
	   LOOP UNTIL colon = 0
	   IF colon THEN
		w$ = w$ + ": " + LEFT$(a$, colon - 1): Kelvinate$ = w$
		w$ = MID$(a$, colon + 2): EXIT FUNCTION
	   ELSE
		Kelvinate$ = w$: w$ = a$: EXIT FUNCTION
	   END IF
	END IF


chaindata:
	IF LEN(w$) + LEN(a$) <= 256 THEN
		w$ = w$ + "," + MID$(a$, 6): RETURN
	ELSE
	   lima = 252 - LEN(w$)
	   DO
		   comma = BInstr%(lima, a$, ",")
		   IF comma THEN IF MID$(estring$, comma, 1) = " " THEN EXIT DO
		   lima = comma - 1
	   LOOP UNTIL comma = 0
	   IF comma THEN
		w$ = w$ + "," + MID$(a$, 6, comma - 7): PRINT #2, w$: w$ = "DATA " + MID$(a$, comma + 1)
	   ELSE
		PRINT #2, w$: w$ = a$: RETURN
	   END IF
	END IF
RETURN

END FUNCTION

SUB LoadKwds 'load kwds from DATA, sorts, counts and search for duplicates

'LOAD KWD DATA

'SNIPPET READ STRINGS FROM DATA WITH SENTINEL

RESTORE QData
words = 0
DO WHILE a$ <> "@@@"
	 words = words + 1: READ a$
LOOP
words = words - 1
REDIM qword$(1 TO words)
RESTORE QData
FOR i = 1 TO words
  READ qword$(i)
NEXT

'END SNIPPET

'SNIPPET BUBBLESORT

FOR i = 2 TO words
   J = i
   DO WHILE qword$(J) < qword$(J - 1)
	  SWAP qword$(J), qword$(J - 1)
	  J = J - 1
	  IF J < 2 THEN EXIT DO
   LOOP
NEXT

'END SNIPPET

CLS : COLOR 15

'snippet find equal
FOR i = 2 TO words
 IF qword$(i) = qword$(i - 1) THEN
	PRINT "ERROR Repeated Kwd "; i; ": "; qword$(i); "= "; qword$(i - 1)
 END IF
NEXT
'PRINT i; " Keywords in list": PRINT
'end snippet

'FOR i = 1 TO words: PRINT qword$(i); " "; : NEXT
'A$ = INPUT$(1)


END SUB