'===========================================================================
' Subject: EX-PACK COMPRESSOR V0.80          Date: 11-28-97 (22:10)       
' Author:  Andrew Nagy                       Code: QB, PDS                
' Origin:  nagyi@bigfoot.com               Packet: PACKER.ABC
'===========================================================================
DEFINT A-Z

DECLARE SUB Test () 'this is not true test, just some infof about the packed file...
DECLARE SUB Info () 'info about bugtesters, betatesters, so...
DECLARE SUB Help () 'this screen shows if nothing entered for commandline
DECLARE SUB SpecEd () 'this sub is the SpecialEdition registrations place
DECLARE SUB PutByte (a) 'by Rich Geldreich
DECLARE SUB PutCode (a) 'by Rich Geldreich
DECLARE SUB Rebuild.Table (New.Entries) 'by Rich Geldreich
DECLARE FUNCTION GetByte () 'by Rich Geldreich
DECLARE SUB Hash (Prefix, Suffix, Index, Found) 'by Rich Geldreich
DECLARE SUB GetArg () 'gets the commandline parameters
DECLARE FUNCTION ExePath$ () 'EXE running from...

'$INCLUDE: 'c:\qb\qb.bi'

DIM SHARED Arg$(0 TO 85)
DIM SHARED spced$ 'the $ of the encoded-decoded SpecialEdition info

CONST True = -1, False = 0 'by Rich Geldreich

DIM SHARED Prefix(6576), Suffix(6576), Code(6576) 'by Rich Geldreich
DIM SHARED Used(4096) 'by Rich Geldreich
DIM SHARED ver$ 'the version# of EX-Pack
DIM SHARED comment$ 'comment like "FINAL!" or "FIRST BETA!!" or something like this...
'-==================================================================
ver$ = "0.80" 'version # (shows everywhere...)
comment$ = " FINAL!" 'comment if available (shows everywhere!!)
'-==================================================================

DIM SHARED InBuffer$, IAddress, IEndAddress, Iseg 'by Rich Geldreich
DIM SHARED OutBuffer$, OStartAddress, OAddress, OEndAddress, Oseg 'by Rich Geldreich

DIM SHARED CodeSize, CurrentBit, Char& 'by Rich Geldreich
DIM SHARED Shift(12) AS LONG 'by Rich Geldreich


FOR a = 0 TO 12: READ Shift(a): NEXT 'by Rich Geldreich
DATA 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192 'by Rich Geldreich
'dunno what is that....
x = 24
LOCATE , , 1
IF POS(0) <> 1 THEN PRINT

dae$ = STRING$(10, 0)   'date buffer (puts in header of packed file) by me.
InBuffer$ = STRING$(4000, 0)   'input buffer
OutBuffer$ = STRING$(4000, 0)  'output buffer


1 a& = SADD(OutBuffer$)
a& = a& - 65536 * (a& < 0)
Oseg = VARSEG(OutBuffer$) + (a& \ 16)     'Segment of buffer
OAddress = (a& MOD 16)                  'Current address in disk buffer
OEndAddress = OAddress + 4000           'End address of  buffer
OStartAddress = OAddress                'Start of buffer
CLS
' here opens the SpecialEdition keyfile
OPEN "expc.spc" FOR BINARY AS #8
IF LOF(8) = 0 THEN lfas = 1: CLOSE #8: GOTO tovabb ELSE CLOSE #8 'is it a true file?????
OPEN "expc.spc" FOR INPUT AS #8
INPUT #8, spced$
sss$ = spced$
CLOSE #8
tovabb:
IF lfas = 1 THEN KILL "expc.spc" ELSE 'it isn't exist
File$ = COMMAND$
GetArg 'gets commandline params...
'PRINT "The program running is: "; arg$(0)

IF Arg$(1) = "" THEN 'no commanline
    Help

END
ELSE
END IF
File$ = Arg$(1) 'first parameter is file...
IF MID$(File$, LEN(File$), 1) = "." THEN a = 1 'havent got extension...
IF a = 1 THEN PRINT "File without extension cannot be packed!!" 'WOW!!!!!!
File$ = RTRIM$(File$) 'some tunings..
File$ = LTRIM$(File$)
out$ = File$
MID$(out$, LEN(File$), 1) = "_" 'output filename (ex. qb.ex_)
'here are the commandline parameters
IF UCASE$(Arg$(1)) = "/M" OR UCASE$(Arg$(2)) = "/M" OR UCASE$(Arg$(3)) = "/M" OR UCASE$(Arg$(4)) = "/M" THEN GOTO Demo
IF UCASE$(Arg$(1)) = "/B" OR UCASE$(Arg$(2)) = "/B" OR UCASE$(Arg$(3)) = "/B" OR UCASE$(Arg$(4)) = "/B" THEN Info ELSE Tst = 0
IF UCASE$(Arg$(1)) = "/A" OR UCASE$(Arg$(2)) = "/A" OR UCASE$(Arg$(3)) = "/A" OR UCASE$(Arg$(4)) = "/A" THEN SpecEd ELSE a = a
IF UCASE$(Arg$(2)) = "/T" OR UCASE$(Arg$(3)) = "/T" OR UCASE$(Arg$(4)) = "/T" THEN Test
'opens files
OPEN File$ FOR BINARY AS #1
FileLength& = LOF(1)
afl = LEN(FileLength&)
size$ = STRING$(lafl, 0)
'Is it there?
IF FileLength& = 0 THEN
    CLOSE #1
    KILL COMMAND$
    PRINT COMMAND$; " not found"
    END
END IF
'Open output file
OPEN out$ FOR BINARY AS #2
'Is it already there?
IF LOF(2) <> 0 THEN
    'Kill output file and reopen it
    CLOSE #2
    CLS
    PRINT "File called " + out$ + " already exist."
    PRINT "Overwrite/Skip (O/S) :"
    'LOCATE 2, 24
    DO
    IF UCASE$(INKEY$) = "O" THEN GOTO xxxx
    IF UCASE$(INKEY$) = "S" THEN RESET: PRINT "Skipped.": END 'ELSE PRINT "Wrong answer!!": RESET: END
    LOOP

xxxx:
    KILL out$
    OPEN out$ FOR BINARY AS #2
END IF
aa = LEN(Arg$(1))
ax$ = File$ + SPACE$(12 - aa) 'filename in header
id$ = "EXP" + UCASE$(ver$) 'ID of an EX-Packed file
'more commandline params...
IF UCASE$(Arg$(2)) = "/C" OR UCASE$(Arg$(3)) = "/C" OR UCASE$(Arg$(4)) = "/C" THEN crc$ = "N" ELSE crc$ = "Y"
IF UCASE$(Arg$(2)) = "/D" OR UCASE$(Arg$(3)) = "/D" OR UCASE$(Arg$(4)) = "/D" THEN ban = 0 ELSE ban = 1
IF UCASE$(Arg$(2)) = "/S" OR UCASE$(Arg$(3)) = "/S" OR UCASE$(Arg$(4)) = "/S" THEN tui = 0 ELSE tui = 1
IF UCASE$(Arg$(2)) = "/H" OR UCASE$(Arg$(3)) = "/H" OR UCASE$(Arg$(4)) = "/H" THEN spced = 0 ELSE IF spced$ <> "" THEN spced = 1
IF UCASE$(Arg$(2)) = "/T" OR UCASE$(Arg$(3)) = "/T" OR UCASE$(Arg$(4)) = "/T" THEN Test

'----------------
dae$ = DATE$
'woooooooow!!!!! puts everything out into file!
PUT #2, , id$ 'like 'EXP0.76'
PUT #2, , ax$ 'real name of file in 12 characters max
PUT #2, , dae$ 'actual date
PUT #2, , crc$ 'joke now, maybe I will make here something later...

'----------------
'CurrentLoc& - position in input file
CurrentLoc& = 2
'END
CLS
'Compression codes:
'Code 256 = end of file
'Code 257 = increase code size
'Code 258 = rebuild table
'Code 259 - 4095 = available for strings
StartCode = 259                 'First LZW code that is available
NextCode = 259
'The maximum code that can be represented in 9 bits
MaxCode = 512
'Start with 9 bit code size
CodeSize = 9
'Current bit position in Char& - use for PutCode
CurrentBit = 0
'Char& is a temporary buffer; accumulates codes from main program and
'puts them in the output file once complete bytes have been
'built
Char& = 0

GOSUB ClearTable
'Get first byte from file(it's a special case)
Prefix = GetByte
IF tui = 0 THEN GOTO t0
'GOTO hdr2
IF spced$ = "" THEN GOTO hdr2 ELSE GOTO hdr1 'if no SpecialEdition info
						'then goes to normal line else
						'goes to Special line
hdr1:
'decodes encoded SpecialEdition info
FOR tt = 1 TO LEN(spced$)
    yq% = 0
    xq% = ASC(MID$(spced$, tt, 1))
    'PRINT x%
    IF (xq% > 64 AND xq% < 91) OR (xq% > 96 AND xq% < 123) THEN
	 yq% = 13
	 xq% = xq% - yq%
	 IF xq% < 97 AND xq% > 83 THEN xq% = xq% + 26 ELSE IF xq% < 65 THEN xq% = xq% + 26
	 END IF
    MID$(spced$, tt, 1) = CHR$(xq%)
  NEXT tt
decoded$ = spced$
'==================================================================
IF spced = 0 THEN GOTO tib 'whats this??????????????
ss$ = sss$ + SPACE$(24 - LEN(sss$)) 'password buffer
be$ = "Y" 'marks password exist for unpacker program...
PUT #2, , be$ 'mark
PUT #2, , ss$ 'encoded password
'==================================================================
' prints the special line
tib:
aaa = LEN("EX-Pack v" + ver$ + comment$ + " SpecialEdition for: " + decoded$ + " by SNPG")
aab = 80 - aaa
COLOR 15, 3: PRINT SPACE$(aaa + aab)
LOCATE 1, 1: PRINT "EX-Pack v" + ver$ + comment$ + " by SNPG" + " ³SpecialEdition for: " + decoded$ + "³"
GOTO t0:
hdr2:
'prints normal line...
aaa = LEN("EX-Pack v" + ver$ + comment$ + " based on LZW by the SigmaNetworks Programming Group")
aab = 80 - aaa
COLOR 15, 3: PRINT SPACE$(aaa + aab)
LOCATE 1, 1: PRINT "EX-Pack v" + ver$ + comment$ + " based on LZW by the SigmaNetworks Programming Group"
be$ = "N"
PUT #2, , be$
t0:
COLOR 7, 0
IF crc$ = "N" THEN GOTO noc
PRINT "Adding CRC+ (tm) ..." 'joke
FOR azz& = 1 TO 500000
NEXT azz&
noc:
LOCATE 2, 1: PRINT "ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿"
LOCATE 3, 1: PRINT "³ Compressing "; File$
PRINT : PRINT : PRINT ""
'First line to start updating statistics
y = CSRLIN - 3
'Main compression loop
	LOCATE 3, 27: COLOR 7: PRINT " ³0% ±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±± 100%³": COLOR 7

DO
LOCATE , , 0
    DO
	
	IF CurrentLoc& > FileLength& THEN
	    PutCode Prefix
	    PutCode 256
	    PutCode 0: PutCode 0
	    OutBuffer$ = LEFT$(OutBuffer$, OAddress - OStartAddress)
	    LOCATE y, 1
	    'PRINT "Bytes In:"; CurrentLoc&; (100& * CurrentLoc&) \ FileLength&; "%"
	    BytesOut& = LOF(2) + (OAddress - OStartAddress)
	    'PRINT "Bytes Out:"; BytesOut&
	    PRINT "³ Packing done.         "
	    PRINT "³ Total Compression:"; 100 - ((100& * BytesOut&) \ CurrentLoc&); "%                         "
	    PUT #2, , OutBuffer$
	    CLOSE
IF tui = 0 THEN GOTO t2
IF ban = 1 THEN GOTO okl ELSE SYSTEM
okl:
COLOR 15:
LOCATE 9:
PRINT "                 ±±±±±±±     ±±±±±   ±±±   ±±  ±±±±±±±   ±±   "
PRINT "                 ±±     ±±  ±     ±  ±± ±  ±±  ±        ±±±±   "
PRINT "                 ±±      ±  ±     ±  ±± ±  ±±  ±        ±±±±  "
PRINT "                 ±±      ±  ±     ±  ±± ±  ±±  ±±±±      ±±  "
PRINT "                 ±±      ±  ±     ±  ±±  ± ±±  ±         ±± "
PRINT "                 ±±     ±±  ±     ±  ±±  ± ±±  ±            "
PRINT "                 ±±±±±±±     ±±±±±   ±±   ±±±  ±±±±±±±   ±± "
t2:
COLOR 7, 0
SYSTEM
ELSE
	    
	    Suffix = GetByte
	    CurrentLoc& = CurrentLoc& + 1
	    'We now have a Prefix:Suffix to search for.
	    'If the search fails, put the Prefix in the output file
	    'and set the Prefix equal to the character which caused
	    'the failure.

	    Hash Prefix, Suffix, Index, Found
	    IF Found = True THEN
		Prefix = Code(Index)
		'update how many times this string was used
		Used(Prefix) = Used(Prefix) + 1
	    END IF
	END IF
    LOOP WHILE Found = True

    'only increase the code size when required
    DO WHILE Prefix >= MaxCode AND CodeSize < 12
	PutCode 257
	MaxCode = MaxCode * 2
	CodeSize = CodeSize + 1
    LOOP
   
    PutCode Prefix

    'Put the new string into the hash table.
    Prefix(Index) = Prefix
    Suffix(Index) = Suffix
    Code(Index) = NextCode  'remember this string's code

    'Prefix is now equal to the character that caused the failure now.
    Prefix = Suffix
 
    NextCode = NextCode + 1
    'if there are too many strings then rebuild the encoding table
    IF NextCode > 4096 THEN
	   
	PutCode 258 'send rebuild table code to decompressor

	Rebuild.Table New.Entries
	NextCode = New.Entries + StartCode
	  
	IF NextCode > 4096 THEN
	    GOSUB ClearTable
	    NextCode = StartCode        'reset NextCode to top of tree
	END IF

	CodeSize = 9
	MaxCode = 512

	
    END IF

    'let the impatient user know we haven't hung up (yet!)
    PrintCounter = PrintCounter + 1     'see if time to update the
    IF PrintCounter = 512 THEN          'screen
	LOCATE y, 1
	  
	PRINT "³ Packed     :"; (100& * CurrentLoc&) \ FileLength&; "%"
	LOCATE 4, 28: PRINT "ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´"
	'LOCATE 5, 28: PRINT "³"
	  
	BytesOut& = LOF(2) + (OAddress - OStartAddress)
	IF tui = 0 THEN GOTO t1
	x = x + 1
	bbbbb = (((100& * CurrentLoc&) \ FileLength&) * 20) \ 64
	LOCATE 3, bbbbb + 32: COLOR 15: PRINT "±": COLOR 7
t1:
	LOCATE 5:
	PRINT "³ Compression:"; 100 - ((100& * BytesOut&) \ CurrentLoc&); "% "
	LOCATE 5, 68: PRINT "³"
	LOCATE 6: PRINT "ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ"
	PrintCounter = 0
    END IF
LOOP
'clears the hash table
ClearTable:
    FOR a = 0 TO 6576
	Prefix(a) = -1
	Suffix(a) = -1
	Code(a) = -1
    NEXT
RETURN
Demo:
'plugin part, maybe more plugins
CLS
OPEN "demo.plg" FOR BINARY AS #1
d& = LOF(1)
IF d& = 0 THEN RESET: PRINT "A demo may be here... Get the plugin called 'DEMO.PLG' !": KILL "demo.plg": END ELSE
SHELL "ren demo.plg demo.exe"
SHELL "demo"
SHELL "ren demo.exe demo.plg"
PRINT "Plugin running ended..."

FUNCTION ExePath$ STATIC
   DIM Regs AS RegType                       'Allocate space for TYPE
						'  RegType
   Regs.ax = &H5100                          'DOS function 51h
   INTERRUPT &H21, Regs, Regs                '  Get PSP Address

   DEF SEG = Regs.bx                         'Regs.bx returns PSP sgmnt.
   EnvSeg% = PEEK(&H2C) + PEEK(&H2D) * 256   'Get environment address
   DEF SEG = EnvSeg%                         'Set environment address

   DO
	  Byte% = PEEK(Offset%)                  'Take a byte

	  IF Byte% = 0 THEN                      'Items are ASCIIZ
	   Count% = Count% + 1                 '  terminated

	   IF Count% AND EXEFlag% THEN         'EXE also ASCIIZ terminated
	   EXIT DO                          'Exit at the end
	   ELSEIF Count% = 2 THEN              'Last entry in env. is
	   EXEFlag% = -1                    '  terminated with two
	   Offset% = Offset% + 2            '  NULs.  Two bytes ahead
	  END IF                              '  is the EXE file name.
	  ELSE                                   'If Byte% <> 0, reset
	   Count% = 0                          '  zero counter

	   IF EXEFlag% THEN                    'If EXE name found,
		Temp$ = Temp$ + CHR$(Byte%)      '  build string
	   END IF
	END IF

	Offset% = Offset% + 1                  'To grab next byte...
    LOOP                                      'Do it again

   DEF SEG                                   'Reset default segment
   ExePath$ = Temp$                      'Return value
   Temp$ = ""                                'Clean up

END FUNCTION

'-----------------------------------------------------------------------
SUB GetArg
Arg$(0) = ExePath$
IF COMMAND$ = "" THEN EXIT SUB
i = 1: j = 1
DO UNTIL i >= LEN(COMMAND$)
    WHILE MID$(COMMAND$, i, 1) <> " " AND MID$(COMMAND$, i, 1) <> ""
	Arg$(j) = Arg$(j) + MID$(COMMAND$, i, 1)
	i = i + 1
    WEND
    i = i + 1: j = j + 1
LOOP
END SUB

'Reads one byte from the input buffer, and fills the buffer if it's emty.
FUNCTION GetByte STATIC
    IF IAddress = IEndAddress THEN
	GET #1, , InBuffer$
	a& = SADD(InBuffer$)
	a& = a& - 65536 * (a& < 0)
	Iseg = VARSEG(InBuffer$) + (a& \ 16)
	IAddress = (a& MOD 16)
	IEndAddress = IAddress + 4000
    END IF
    DEF SEG = Iseg
    GetByte = PEEK(IAddress)
    IAddress = IAddress + 1
END FUNCTION

SUB GetPal (Attr%, Red%, Green%, Blue%) 'SUB to get a color attribute
OUT &H3C7, Attr%
OUT &H3C8, Attr%
Red% = INP(&H3C9)
Green% = INP(&H3C9)
Blue% = INP(&H3C9)
END SUB

'Attempts to finds a prefix:suffix string.
SUB Hash (Prefix, Suffix, Index, Found)
    
    Index = (Prefix * 256& XOR Suffix) MOD 6577 'XOR hashing
    IF Index = 0 THEN  'is Index lucky enough to be 0?
	Offset = 1     'Set offset to 1, because 6577-0=6577
    ELSE
	Offset = 6577 - Index
    END IF
    DO 'until we find a match or don't
	IF Code(Index) = -1 THEN      'is there nothing here?
	    Found = False             'yup, not found
	    EXIT SUB
	'is this entry what we're looking for?
	ELSEIF Prefix(Index) = Prefix AND Suffix(Index) = Suffix THEN
	    Found = True              'yup, found
	    EXIT SUB
	ELSE 'retry until we find what were looking for or we find a blank
		'entry
	    Index = Index - Offset
	    IF Index < 0 THEN 'is index too far down?
		Index = Index + 6577 'yup, bring it up then
	    END IF
	END IF
    LOOP
END SUB

SUB Help
COLOR 7, 0
CLS
IF spced$ = "" THEN GOTO hdrrr2 ELSE GOTO hdrrr1
hdrrr1:
FOR tt = 1 TO LEN(spced$)
    y% = 0
    x% = ASC(MID$(spced$, tt, 1))
    'PRINT x%
    IF (x% > 64 AND x% < 91) OR (x% > 96 AND x% < 123) THEN
	 y% = 13
	 x% = x% - y%
	 IF x% < 97 AND x% > 83 THEN x% = x% + 26 ELSE IF x% < 65 THEN x% = x% + 26
	 END IF
    MID$(spced$, tt, 1) = CHR$(x%)
  NEXT tt
decoded$ = spced$
aaa = LEN("EX-Pack v" + ver$ + comment$ + "  SpecialEdition for: " + decoded$ + " by SNPG ")
aab = 80 - aaa
COLOR 15, 3: PRINT SPACE$(aaa + aab)
LOCATE 1, 1: PRINT "EX-Pack v" + ver$ + comment$ + " by SNPG" + " ³SpecialEdition for: " + decoded$ + "³"
GOTO huha
hdrrr2:
aaa = LEN("EX-Pack v" + ver$ + comment$ + " based on LZW by the SigmaNetworks Programming Group")
aab = 80 - aaa
COLOR 15, 3: PRINT SPACE$(aaa + aab)
LOCATE 1, 1: PRINT "EX-Pack v" + ver$ + comment$ + " based on LZW by the SigmaNetworks Programming Group"
huha:
COLOR 7, 0
PRINT "Build information : 08-12-1997"; " Build 1"
PRINT
COLOR 15, 0
PRINT "Syntax : expc.exe filename.ext /options"
COLOR 7, 0
PRINT
PRINT "Options :"
PRINT "/c - Don't add CRC+ Recovery"
PRINT "/h - Don't add SpecialEdition info into header (24 bytes smaller file)"
PRINT "/d - Don't shows the big DONE! bannner on the end."
PRINT "/s - Standard output mode, no friendly TUI."
PRINT "/a - (*) SpecialEdition registarion."
PRINT "/t - Tests the header of packed file"
PRINT
PRINT "/b - About the authors, BETA testers."
PRINT "/m - A waveing flag. Try it!"
PRINT
PRINT
PRINT "For files with a (*) sign, see the documentation."
END
END SUB

SUB Info
CLS
IF spced$ = "" THEN GOTO hdrr2 ELSE GOTO hdrr1
hdrr1:
FOR tt = 1 TO LEN(spced$)
    y% = 0
    x% = ASC(MID$(spced$, tt, 1))
    'PRINT x%
    IF (x% > 64 AND x% < 91) OR (x% > 96 AND x% < 123) THEN
	 y% = 13
	 x% = x% - y%
	 IF x% < 97 AND x% > 83 THEN x% = x% + 26 ELSE IF x% < 65 THEN x% = x% + 26
	 END IF
    MID$(spced$, tt, 1) = CHR$(x%)
  NEXT tt
decoded$ = spced$
aaa = LEN("EX-Pack v" + ver$ + comment$ + "  SpecialEdition for: " + decoded$ + " by SNPG ")
aab = 80 - aaa
COLOR 15, 3: PRINT SPACE$(aaa + aab)
LOCATE 1, 1: PRINT "EX-Pack v" + ver$ + comment$ + " by SNPG" + " ³SpecialEdition for: " + decoded$ + "³"
'RESET
'END
GOTO tovbb
hdrr2:
aaa = LEN("EX-Pack v" + ver$ + comment$ + " based on LZW by the SigmaNetworks Programming Group")
aab = 80 - aaa
COLOR 15, 3: PRINT SPACE$(aaa + aab)
LOCATE 1, 1: PRINT "EX-Pack v" + ver$ + comment$ + " based on LZW by the SigmaNetworks Programming Group"
tovbb:
COLOR 7, 0
COLOR 15
PRINT "About the authors and the beta testers:"
COLOR 7
PRINT
PRINT "Authors:"
PRINT "Andras Nagy  - TUI, code, header,so.."
PRINT "Peter Radics - Tips, testing."
PRINT
PRINT "Beta testers:"
PRINT "Ferenc Sorosics - Wide testing!! Explored many bugs!"
PRINT
PRINT "Contact us:"
PRINT "Info & Updates : http://www.mygale.org/~sgpr/our.htm"
PRINT "Electronic Mail: nagyi@bigfoot.com"
END
END SUB

'Throws a byte into the output buffer and writes the buffer if it's full.
SUB PutByte (a) STATIC
    IF OAddress = OEndAddress THEN
	PUT #2, , OutBuffer$
	OAddress = OStartAddress
    END IF
    DEF SEG = Oseg
    POKE OAddress, a
    OAddress = OAddress + 1
END SUB

'Throws one multi-bit code to the output file.
SUB PutCode (a) STATIC
    SHARED MaxCode
    IF a >= MaxCode THEN STOP

    Char& = Char& + a * Shift(CurrentBit)
    CurrentBit = CurrentBit + CodeSize
    DO WHILE CurrentBit > 7
	PutByte Char& AND 255
	Char& = Char& \ 256
	CurrentBit = CurrentBit - 8
    LOOP
END SUB

'This is the "experimental" part of the program. This procedure eliminates
'any strings which are not used in the encoding table: the usual result of
'doing this is greater compression.
'It isn't documented well yet... I'm still working on it.
SUB Rebuild.Table (New.Entries)
    DIM p(4096), S(4096), U(4096) AS LONG, Pn(4096), c(4096)
    DIM Location(4096)
   
    SHARED StartCode, MaxCode, Prefix
    Num.Entries = 0
    
    FOR a = 0 TO 6576
	c = Code(a)
	IF c <> -1 THEN 'valid code?
	    IF Used(c) > 0 THEN 'was it used at all?
		Used(c) = 0
		p = Prefix(a): S = Suffix(a)
		p(Num.Entries) = p          'put it into a temporary table
		S(Num.Entries) = S
		U(Num.Entries) = p * 4096& + S
		c(c) = Num.Entries
		Num.Entries = Num.Entries + 1
	    END IF
	END IF
    NEXT
    

    Num.Entries = Num.Entries - 1
    FOR a = 0 TO Num.Entries
	Pn(a) = a
    NEXT
	'sort the table according to it's prefix:suffix
    Mid = Num.Entries \ 2
    DO
	FOR a = 0 TO Num.Entries - Mid
	    IF U(Pn(a)) > U(Pn(a + Mid)) THEN
		SWAP Pn(a), Pn(a + Mid)
		Swap.Flag = True
		CompareLow = a - Mid
		CompareHigh = a
		DO WHILE CompareLow >= 0
		    IF U(Pn(CompareLow)) > U(Pn(CompareHigh)) THEN
			SWAP Pn(CompareLow), Pn(CompareHigh)
			CompareHigh = CompareLow
			CompareLow = CompareLow - Mid
		    ELSE
			EXIT DO
		    END IF
		LOOP
		  
	    END IF
	NEXT
	
	Mid = Mid \ 2
    LOOP WHILE Mid > 0
    
    
    FOR a = 0 TO Num.Entries
	Location(Pn(a)) = a
    NEXT
    'clear the old hash table
    FOR a = 0 TO 6576
	Prefix(a) = -1
	Suffix(a) = -1
	Code(a) = -1
    NEXT
    
    'put each prefix:suffix into the hash table
    FOR A1 = 0 TO Num.Entries
	a = Pn(A1)
	  
	p = p(a)
	S = S(a)
	IF p >= StartCode THEN 'is it pointing twards a string?
	    p = StartCode + Location(c(p)) 'yup; update the pointer
	END IF
	IF S >= StartCode THEN
	    S = StartCode + Location(c(S))
	END IF
	'where does this prefix:suffix go?
	Hash p, S, Index, 0
	'put it there
	Prefix(Index) = p
	Suffix(Index) = S
	Code(Index) = A1 + StartCode
	
    NEXT
    '# of entries in the hash table now
    New.Entries = Num.Entries + 1
END SUB

SUB SetPal (Attr%, Red%, Green%, Blue%) 'SUB to set a color attribute
OUT &H3C7, Attr%
OUT &H3C8, Attr%
OUT &H3C9, Red%
OUT &H3C9, Green%
OUT &H3C9, Blue%
END SUB

SUB SpecEd
x:
CLS
COLOR 15, 3: PRINT "SpecialEdition Registration v1.05 for EX-Pack v0.76g and above                  "
COLOR 7, 0
PRINT
INPUT "Enter name (Min. 5, max. 24 chars) : ", spa$
IF spa$ = "" THEN PRINT "Aborted.": END
IF LEN(spa$) < 5 THEN PRINT "You must enter minimum 5 characters.": END
IF LEN(spa$) > 24 THEN PRINT "You must enter maximum 24 characters.": END
Tst$ = spa$
INPUT "Enter key for name: ", spb$
GOTO ROT13
bn:
IF spb$ = Tst$ THEN
PRINT "Key OK!! SpecialEdition info saved into 'EXPC.SPC'!"
OPEN "expc.spc" FOR OUTPUT AS #5
WRITE #5, spb$
CLOSE #5
END
ELSE
BEEP: COLOR 12: PRINT "Wrong key!!!!": END
END IF

ROT13:
  FOR tt = 1 TO LEN(Tst$)
    y% = 0
    x% = ASC(MID$(Tst$, tt, 1))
    'PRINT x%
    IF (x% > 64 AND x% < 91) OR (x% > 96 AND x% < 123) THEN
	 y% = 13
	 x% = x% - y%
	 IF x% < 97 AND x% > 83 THEN x% = x% + 26 ELSE IF x% < 65 THEN x% = x% + 26
	 END IF
    MID$(Tst$, tt, 1) = CHR$(x%)
  NEXT tt
GOTO bn
END SUB

SUB Test
'UNDER CONSTRUCTION!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
CLS
IF spced$ = "" THEN GOTO hdrrrr2 ELSE GOTO hdrrrr1
hdrrrr1:
FOR tt = 1 TO LEN(spced$)
    y% = 0
    x% = ASC(MID$(spced$, tt, 1))
    'PRINT x%
    IF (x% > 64 AND x% < 91) OR (x% > 96 AND x% < 123) THEN
	 y% = 13
	 x% = x% - y%
	 IF x% < 97 AND x% > 83 THEN x% = x% + 26 ELSE IF x% < 65 THEN x% = x% + 26
	 END IF
    MID$(spced$, tt, 1) = CHR$(x%)
  NEXT tt
decoded$ = spced$
aaa = LEN("EX-Pack v" + ver$ + comment$ + "  SpecialEdition for: " + decoded$ + " by SNPG ")
aab = 80 - aaa
COLOR 15, 3: PRINT SPACE$(aaa + aab)
LOCATE 1, 1: PRINT "EX-Pack v" + ver$ + comment$ + " by SNPG" + " ³SpecialEdition for: " + decoded$ + "³"
'RESET
'END
GOTO tovbbb
hdrrrr2:
aaa = LEN("EX-Pack v" + ver$ + comment$ + " based on LZW by the SigmaNetworks Programming Group")
aab = 80 - aaa
COLOR 15, 3: PRINT SPACE$(aaa + aab)
LOCATE 1, 1: PRINT "EX-Pack v" + ver$ + comment$ + " based on LZW by the SigmaNetworks Programming Group"
tovbbb:
COLOR 15, 0: PRINT "Testing archive header..."

COLOR 7, 0
OPEN Arg$(1) FOR BINARY AS #6
id$ = STRING$(7, 0)
ax$ = STRING$(12, 0)
crc$ = STRING$(1, 0)
dt$ = STRING$(10, 0)
size& = LOF(6)
GET #6, , id$
PRINT "Header version   : "; id$
IF id$ = "EXP0.80" THEN id$ = "EXP0.76"
IF id$ = "EXP0.76" THEN GOTO oksi ELSE RESET: GOTO hujjaj
hujjaj:
OPEN Arg$(1) FOR BINARY AS #5
id$ = STRING$(8, 0)
ax$ = STRING$(12, 0)
crc$ = STRING$(1, 0)
dt$ = STRING$(10, 0)
size& = LOF(5)
GET #5, , id$
PRINT "Header version   : "; id$
IF id$ = "EXP0.45A" OR id$ = "EXP0.50A" OR id$ = "EXP0.60A" OR id$ = "EXP0.70B" OR id$ = "EXP0.76G" THEN GOTO oksi ELSE RESET: PRINT "Not a valid packed file.": END
oksi:
IF id$ = "EXP0.45A" THEN
GET #5, , ax$
PRINT "Packed file name : "; ax$
PRINT "Packed size      :"; size&; "bytes"
END
END IF
IF id$ = "EXP0.50A" THEN
GET #5, , ax$
GET #5, , dt$
PRINT "Packed file name : "; ax$
PRINT "Packed on date   : "; dt$
PRINT "Packed size      :"; size&; "bytes"

END
END IF
IF id$ = "EXP0.60A" THEN
GET #5, , ax$
GET #5, , dt$
PRINT "Packed file name : "; ax$
PRINT "Packed on date   : "; dt$
PRINT "CRC+ Recovery    : Present! (Built in...)"
PRINT "Packed size      :"; size&; "bytes"
END
END IF
IF id$ = "EXP0.70B" THEN
GET #5, , ax$
GET #5, , dt$
GET #5, , crc$
PRINT "Packed file name : "; ax$
PRINT "Packed on date   : "; dt$
IF crc$ = "Y" THEN crc$ = "Present!"
PRINT "CRC+ Recovery    : "; crc$
PRINT "Packed size      :"; size&; "bytes"

END
END IF
IF id$ = "EXP0.76G" THEN
GET #5, , ax$
GET #5, , dt$
GET #5, , crc$
IF spced$ <> "" THEN GET #5, , spccode$ ELSE
PRINT "Packed file name : "; ax$
PRINT "Packed on date   : "; dt$
IF crc$ = "Y" THEN crc$ = "Present!"
PRINT "CRC+ Recovery    : "; crc$
PRINT "Packed size      :"; size&; "bytes"
END
END IF

IF id$ = "EXP0.76" THEN
GET #6, , ax$
GET #6, , dt$
GET #6, , crc$
ssss$ = STRING$(1, 0)
GET #6, , ssss$
IF ssss$ = "N" THEN GOTO nincsn
IF ssss$ = "Y" THEN GOTO vann ELSE GOTO nincsn
vann:
bevan$ = STRING$(24, 0)
GET #6, , bevan$
PRINT "Packed file name : "; ax$
PRINT "Packed on date   : "; dt$
IF crc$ = "Y" THEN crc$ = "Present!"
PRINT "CRC+ Recovery    : "; crc$
PRINT "Packed size      :"; size&; "bytes"

FOR tt = 1 TO LEN(bevan$)
    y% = 0
    x% = ASC(MID$(bevan$, tt, 1))
    'PRINT x%
    IF (x% > 64 AND x% < 91) OR (x% > 96 AND x% < 123) THEN
	 y% = 13
	 x% = x% - y%
	 IF x% < 97 AND x% > 83 THEN x% = x% + 26 ELSE IF x% < 65 THEN x% = x% + 26
	 END IF
    MID$(bevan$, tt, 1) = CHR$(x%)
  NEXT tt
decoded$ = bevan$
PRINT "SpecialEdition   : "; decoded$
END
nincsn:
PRINT "Packed file name : "; ax$
PRINT "Packed on date   : "; dt$
IF crc$ = "Y" THEN crc$ = "Present!"
PRINT "CRC+ Recovery    : "; crc$
PRINT "Packed size      :"; size&; "bytes"

END
END IF

END SUB