'===========================================================================
' Subject: INCLUDE SUB/FUNCTIONS              Date: 09-19-97 (15:43)       
'  Author: Sami Kyostila                      Code: QB, QBasic, PDS        
'  Origin: hiteck@mail.freenet.hut.fi       Packet: MISC.ABC
'===========================================================================
'---------------------------------------------------------------------
'               iNCLUDE.BAS - v1.1 (c) Sami Ky”stil„ 1997
'---------------------------------------------------------------------
'                          F R E E W A R E
'---------------------------------------------------------------------



'---------------------------------------------------------------------
'                       D E S C R I P T I O N
'---------------------------------------------------------------------
'Have you ever found a useful SUB/FUNCTION you'd like to copy into
'your own code? But then you find out how awkward it is to copy the
'subs and functions manually, one at a time. That's just what this
'useful program is for!
'---------------------------------------------------------------------




'---------------------------------------------------------------------
'                            U S A G E
'---------------------------------------------------------------------
'This program queries you for the input and output files. You don't need
'to type in extensions, .BAS is added if no other extension is found.
'You can safely add the subs/functions to existing programs, because the
'data is appended, so the existing data is not erased. Then it parses
'the files for subs and functions and checks if there are any duplicates.
'If a QBasic source file has duplicated subs or functions, then QBasic
'won't even load it. iNCLUDE prevents this by removing the duplicate subs
'and functions from the list. After this the program displays a list of
'subs and functions it has found in the input file. Press arrows to move
'the red cursor and Space to mark/unmark the sub/function for copying.
'After you have selected the necessary subs and functions then press Enter
'to start the process. Then the program will start copying the selected
'subs and functions. NOTE: The copying process involves a lot of calculation
'and data transfer, therefore it may take a while on slow computers. Load
'Smartdrive or similar software to speed up the process.
'---------------------------------------------------------------------




'---------------------------------------------------------------------
'This code may be used freely, as long as the original author is credited
'---------------------------------------------------------------------






DECLARE SUB Duplicate ()
DECLARE SUB Doit ()
DECLARE SUB MarkSUB ()
DECLARE SUB WaitKey ()
DECLARE SUB Parse (File$, Quiet)
DECLARE FUNCTION Lines% (File$)
DECLARE SUB Center (Text$)
DECLARE FUNCTION FileSelector$ (XStart!, YStart!, XEnd!, YEnd!, Dir$, FileSpecs$, Topic$, FileHelp$)
ON ERROR GOTO Errorhandler

SCREEN 0: CLS
WIDTH 80, 25


DIM SHARED Virhe
DIM SHARED Sourcedir$
DIM SHARED Total, DestTotal
DIM SHARED Inp$, Out$
DIM SHARED DestSUB$(200)




Total = 0
TYPE Subtype
  Desc AS STRING * 255
  First AS LONG
  Last AS LONG
  Selected AS LONG
END TYPE

DIM SHARED Sb(200) AS Subtype
DIM SHARED ku$, kd$, kl$, kr$

'define cursor keys
ku$ = CHR$(0) + CHR$(72)  'up
kr$ = CHR$(0) + CHR$(77)  'left
kd$ = CHR$(0) + CHR$(80)  'down
kl$ = CHR$(0) + CHR$(75)  'right






COLOR 14, 0: CLS
COLOR 15, 4
LOCATE 1, 1: PRINT STRING$(80, " ")
LOCATE 1, 1
Center "- iNCLUDE v1.1 (C) Sami Ky”stil„ 1997 - Distribute freely -"
VIEW PRINT 2 TO 25

COLOR 8, 0
LOCATE 3, 1

PRINT " This program appends SUBS/FUNCTIONS into your programs"
PRINT " from other programs, so you don't have to manually copy them."
PRINT " It scans the input file for SUBS/FUNCTIONS and appends the"
PRINT " ones of your choice to the output file."
PRINT " An extension of .BAS is assumed. This program can only handle"
PRINT " 200 SUBS/FUNCTIONS per file."
PRINT
COLOR 14
PRINT " þ Press Ctrl-C to quit"
PRINT
COLOR 7


INPUT "  Enter input file: ", Inp$

IF Inp$ = "" THEN
  COLOR 12
  PRINT
  PRINT "    * [Error] File not found or null file ("; Inp$; ")"
  END
END IF

IF INSTR(Inp$, ".") = 0 THEN Inp$ = Inp$ + ".BAS"
Inp$ = UCASE$(Inp$)
LOCATE 12, 21:  PRINT Inp$
PRINT

INPUT "  Enter output file: ", Out$
 
IF Out$ = "" THEN
  COLOR 12
  PRINT
  PRINT "    * [Error] Null file ("; Out$; ")"
  END
END IF


IF INSTR(Out$, ".") = 0 THEN Out$ = Out$ + ".BAS"
Out$ = UCASE$(Out$)
LOCATE 14, 22:  PRINT Out$
PRINT
IF Inp$ = Out$ THEN COLOR 12: PRINT " * [Error] Source equals destination": END
COLOR 14
PRINT " þ Verifying input file "; Inp$; "...";

OPEN Inp$ FOR BINARY AS #1
IF LOF(1) = 0 THEN
  CLOSE
  KILL Inp$
  COLOR 12
  PRINT
  PRINT "    * [Error] File not found or null file ("; Inp$; ")"
  END
END IF

PRINT "Done"
COLOR 7
PRINT "     - File size:"; LOF(1); "bytes"
PRINT "     - Number of lines:"; Lines%(Inp$)
CLOSE

PRINT
COLOR 14
PRINT " þ Verifying output file "; Out$; "...";

OPEN Out$ FOR BINARY AS #1
IF LOF(1) = 0 THEN
  CLOSE
  KILL Out$
  COLOR 12
  PRINT
  PRINT "    * [Warning] File not found or null file ("; Out$; ")"
ELSE
  PRINT "Done"
  COLOR 7
  PRINT "     - File size:"; LOF(1); "bytes"
  PRINT "     - Number of lines:"; Lines%(Out$)
  CLOSE
END IF
  WaitKey


COLOR 14
PRINT
PRINT " þ Parsing output file "; Out$; "..."
Parse Out$, 1
DestTotal = Total
FOR i = 0 TO Total
  DestSUB$(i) = Sb(i).Desc$
  Sb(i).Desc$ = ""
  Sb(i).First = 0
  Sb(i).Last = 0
NEXT


COLOR 14
PRINT " þ Parsing input file "; Inp$; "..."
Parse Inp$, 0
COLOR 14
PRINT " þ Searching for duplicate SUBS/FUNCTIONS..."
Duplicate
CLS
COLOR 7
PRINT
Center " Choose the SUBS/FUNCTIONS to be added to the file " + Out$ + "."
Center " Mark/Unmark with <SPACE> - Confirm with <ENTER> - Cancel with <ESC>"
LOCATE 23, 1
COLOR 14
Center Inp$ + " > " + Out$
MarkSUB
Doit
VIEW PRINT: CLS
COLOR 7
Center "ú Thank you for using iNCLUDE v1.1 by Sami Ky”stil„ 1997 ú"
END


END
Errorhandler: Virhe = ERR: RESUME NEXT

SUB Center (Text$)                 'Centers text on screen
LOCATE , 40 - (LEN(Text$) \ 2)
PRINT Text$
END SUB

SUB Doit          'Copies the SUBS and FUNCTIONS to the file Out$ from Inp$
CLOSE

OPEN Inp$ FOR INPUT AS #1
OPEN Out$ FOR APPEND AS #2

IF Total = 0 THEN Sb(0).Selected = 1

WritingSub = -1

COLOR 0, 0
CLS
COLOR 14, 0
PRINT
PRINT " þ Appending to file "; Out$; "..."
OldRow = CSRLIN
OldCol = POS(1)
VIEW PRINT
COLOR 14, 4
LOCATE 1, 1: PRINT STRING$(80, " ")
LOCATE 1, 1: PRINT " Processing file "; Inp$; " > "; Out$; " - Line:"; Rivi; "/"; Totallines - 1
COLOR 7, 1
LOCATE 1, 71
PRINT STRING$(10, "°")
COLOR 7, 0
VIEW PRINT 2 TO 25
LOCATE OldRow, OldCol

COLOR 7



Totallines = Lines%(Inp$)

FOR Rivi = 0 TO Totallines - 1
  OldRow = CSRLIN
  OldCol = POS(1)
  VIEW PRINT
  COLOR 14, 4
  LOCATE 1, 1: PRINT " Processing file "; Inp$; " > "; Out$; " - Line:"; Rivi; "/"; Totallines - 1; "  "; INT(Rivi / (Totallines - 1) * 100); "%"
  COLOR 15, 1
  LOCATE 1, 71
  PRINT STRING$(INT(Rivi / (Totallines - 1) * 100) \ 10, "Û")
  COLOR 7, 0
  VIEW PRINT 2 TO 25
  LOCATE OldRow, OldCol

  LINE INPUT #1, Line$
  IF WritingSub = -1 THEN
    FOR i = 0 TO Total
      IF Rivi = Sb(i).First - 1 AND Sb(i).Selected = 1 THEN
        PRINT " ú Adding "; LEFT$(Sb(i).Desc, 68)
        COLOR 8
        PRINT "      - Start:";
        COLOR 2
        PRINT "   Line"; Rivi
        COLOR 7
        WritingSub = i
      END IF
    NEXT
  END IF
  IF WritingSub <> -1 THEN
    PRINT #2, Line$
    IF Rivi = Sb(WritingSub).Last THEN
      COLOR 8
      PRINT "      - End:";
      COLOR 2
      PRINT "     Line"; Rivi
      COLOR 7
      WritingSub = -1
    END IF
  END IF


NEXT

CLOSE

WaitKey
END SUB

SUB Duplicate     'Searches for duplicate SUBS/FUNTIONS
COLOR 7
Found = 0

FromTotal = Total
FOR i = 0 TO FromTotal - 1
  FOR i2 = 0 TO DestTotal - 1
    Sub$ = UCASE$(RTRIM$(Sb(i).Desc))
    Sub2$ = UCASE$(RTRIM$(DestSUB$(i2)))


    IF LEFT$(Sub$, 3) = "SUB" THEN
      IF INSTR(Sub$, "(") = 0 THEN
        SubName$ = MID$(Sub$, 5, 255)
      ELSE
        SubName$ = MID$(Sub$, 5, INSTR(5, Sub$, " ") - 5)
      END IF
    END IF

    IF LEFT$(Sub$, 8) = "FUNCTION" THEN
      IF INSTR(Sub$, "(") = 0 THEN
        SubName$ = MID$(Sub$, 10, 255)
      ELSE
        SubName$ = MID$(Sub$, 10, INSTR(5, Sub$, " ") - 10)
      END IF
    END IF


    IF LEFT$(Sub2$, 3) = "SUB" THEN
      IF INSTR(Sub2$, "(") = 0 THEN
        SubName2$ = MID$(Sub2$, 5, 255)
      ELSE
        SubName2$ = MID$(Sub2$, 5, INSTR(5, Sub2$, " ") - 5)
      END IF
    END IF

    IF LEFT$(Sub2$, 8) = "FUNCTION" THEN
      IF INSTR(Sub2$, "(") = 0 THEN
        SubName2$ = MID$(Sub2$, 10, 255)
      ELSE
        SubName2$ = MID$(Sub2$, 10, INSTR(5, Sub2$, " ") - 10)
      END IF
    END IF

    IF SubName$ = SubName2$ THEN
      Found = 1
      COLOR 7
      PRINT "   ú Found duplicate SUB/FUNCTION: ";
      COLOR 2: PRINT SubName$
      Sb(i).Desc = STRING$(255, " ")
      Sb(i).First = 0
      Sb(i).Last = 0
      Sb(i).Selected = 0
    END IF

  NEXT
NEXT
DIM DummyDesc$(200)
DIM DummyFirst(200)
DIM DummyLast(200)


Index = 0
FOR i = 0 TO FromTotal - 1
  IF LEFT$(Sb(i).Desc, 1) <> " " THEN
    DummyDesc$(Index) = RTRIM$(Sb(i).Desc)
    DummyFirst(Index) = Sb(i).First
    DummyLast(Index) = Sb(i).Last
    Sb(i).Desc = ""
    Index = Index + 1
  END IF
NEXT


Total = Index

FOR i = 0 TO Total
  Sb(i).Desc = DummyDesc$(i)
  Sb(i).First = DummyFirst(i)
  Sb(i).Last = DummyLast(i)
NEXT

ERASE DummyDesc$, DummyFirst, DummyLast
IF Found = 0 OR DestTotal <= 0 THEN COLOR 7: PRINT "   ú None found"

IF Total < 0 THEN
  COLOR 12
  PRINT " * [Error] No SUBS/FUNCTIONS left to copy"
  END
END IF

WaitKey
END SUB

FUNCTION Lines% (File$)         'Count number of lines in File$

Lin% = 0

CountFile = FREEFILE
OPEN File$ FOR INPUT AS #CountFile

DO
  IF EOF(CountFile) THEN EXIT DO
  LINE INPUT #CountFile, Dummy$
  Lin% = Lin% + 1
LOOP
Lines% = Lin%
CLOSE CountFile

END FUNCTION

SUB MarkSUB               'Displays the SUB and FUNCTION list and allows the
Sel = 0                   'user to select/deselect SUBS/FUNCTIONS
Scroll = 0
YStart = 6
YEnd = 22
LOCATE YStart, 1

FOR i = 0 TO 200
  Sb(i).Selected = 0
NEXT


YLen = YEnd - YStart - 1

LOCATE YStart, 1
FOR i = Scroll TO YLen + Scroll
  IF i >= 200 THEN EXIT FOR
  IF i = Sel THEN COLOR 15, 4 ELSE COLOR 7, 1
  PRINT "  "; LEFT$(Sb(i).Desc, 78)
NEXT

DO
  k$ = INKEY$
  IF k$ <> "" THEN
    IF k$ = ku$ THEN Sel = Sel - 1
    IF k$ = kd$ THEN Sel = Sel + 1
    IF k$ = CHR$(27) THEN COLOR 7, 0: END
    IF k$ = CHR$(13) THEN EXIT SUB
    IF k$ = " " THEN
      IF Sb(Sel).Selected = 1 THEN Sb(Sel).Selected = 0: GOTO Add
      IF Sb(Sel).Selected = 0 THEN Sb(Sel).Selected = 1
Add:
      Sel = Sel + 1
    END IF
    IF Sel > Scroll + YLen THEN Scroll = Scroll + 1
    IF Sel < Scroll THEN Scroll = Scroll - 1

    IF Scroll < 0 THEN Scroll = 0
    IF Scroll >= Total - YLen - 1 THEN Scroll = Total - YLen - 1
    IF Sel < 0 THEN Sel = 0
    IF Sel > Total - 1 THEN Sel = Total - 1

    LOCATE YStart, 1
    FOR i = Scroll TO YLen + Scroll
      IF i >= 200 THEN EXIT FOR
      IF i = Sel THEN COLOR 15, 4 ELSE COLOR 7, 1
      IF i > -1 THEN
        IF Sb(i).Selected = 1 THEN PRINT CHR$(16) + " ";  ELSE PRINT "  ";
        PRINT LEFT$(Sb(i).Desc, 78)
      END IF
    NEXT
  END IF
LOOP

END SUB

SUB Parse (File$, Quiet)        'Parses File$ for SUBS/FUNCTIONS
COLOR 7                         'If Quiet = 1 then doesn't print list
Total = 0

FOR i = 0 TO 200
  Sb(i).Selected = 0
NEXT


OPEN File$ FOR INPUT AS #1
Lin! = 0
FoundSub = 0

DO
  IF EOF(1) THEN EXIT DO
  LINE INPUT #1, Line$
  Line$ = LTRIM$(Line$)
  Lin! = Lin! + 1
  IF LEFT$(Line$, 4) = "SUB " OR LEFT$(Line$, 9) = "FUNCTION " THEN
    IF FoundSub = 0 THEN
      IF Quiet = 0 THEN
        PRINT "    ú Found "; LEFT$(Line$, 68)
        COLOR 8
        PRINT "      - Start:";
        COLOR 2
        PRINT " Line"; Lin!
      END IF
      Sb(Total).Desc = Line$
      Sb(Total).First = Lin!

      LastSub$ = Line$
      FoundSub = 1
    ELSE
      COLOR 12
      PRINT
      PRINT Line$
      PRINT "    * [Error] Did not find end of "; LastSub$; ""
      END
    END IF
  END IF

  IF LEFT$(UCASE$(Line$), 7) = "END SUB" OR LEFT$(UCASE$(Line$), 12) = "END FUNCTION" THEN
    IF Quiet = 0 THEN
      COLOR 8
      PRINT "      - End:";
      COLOR 2
      PRINT "   Line"; Lin!
      COLOR 7
    END IF
    Sb(Total).Last = Lin!
    Total = Total + 1
    FoundSub = 0
  END IF

LOOP
CLOSE
IF Total = 0 AND Quiet = 0 THEN COLOR 12: PRINT " * [Error] No SUBS/FUNCTIONS found": END
COLOR 14
PRINT " þ Found"; Total; "SUBS/FUNCTIONS in file "; File$
WaitKey


END SUB

SUB WaitKey             'Displays a prompt and waits for keypress
PRINT
COLOR 8
PRINT " ú Press any key to continue"
PRINT
DO: LOOP UNTIL INKEY$ <> ""
CLS
END SUB