'===========================================================================
' Subject: SUPER TEXT PACKER                 Date: 01-04-96 (00:58)       
' Author:  Hauke Daempfling                  Code: QB, QBasic, PDS        
' Origin:  hcd@berlin.snafu.de             Packet: TEXT.ABC
'===========================================================================
DECLARE SUB PackTxt (text$)
' Super Text/String Packer/Unpacker for QB4.5
'     Originally by Greg Estabrooks
'  Slightly changed by Hauke Daempfling

'(small note: all documentation is by Hauke :) )

'This program (or rather the PackTxt sub) packs/unpacks
' strings to about 52% of their original size. All I can say is
' that this is one of the best code snippets I've ever seen. :)
' Actually, it's brilliant :).

' I changed it from its original version in the following ways:
' 1) The sub adds CHR$(255) to a packed string to indicate that
'    it is packed. (For automatic packing/unpacking)
' 2) The sub checks if the values of the characters in the string are
'    between 32 and 127 to reduce errors while packing.
' 3) Last but not least, I've added some documatation.

'Usage is very simple. Take a string (A$, for example) and call PackTxt:
' A$ = "This is a test string for the text packer."
' PackTxt A$
'The string will be packed and CHR$(255) added to the beginning to indicate
'that it is packed. To unpack a string just call PackTxt again:
' PackTxt A$
'There. That's all there is to it. Have fun :)

'PackTxt SUB begins here
DEFINT A-Z
'This sub packs strings to about 52% of their original size. The sub
' automatically checks if the string is packed or not and unpacks/packs
' it accordingly. (neat, huh?)
' Don't play around with the dictionary or you can lower the packing
' ratio (when I got it there was a single space missing and that
' reduced the ratio by about 10%!).
' NOTE: text$ may only contain ASCII characters with the values 32-127!
SUB PackTxt (text$)
'the commets here are cluttered up... delete them if you want
  
   'The dictionary... it may look like junk, but it is prerry much the heart
   ' of the packer (so don't mess it up :) )
   d1$ = "  e  as  tinthouerhet anreesr d onn or o i y wo tontyo. neisarte"
   d2$ = "ed,  ctiy  bat snd fal pensestvengitu talehaurllcousa  mf dfoof "
   d3$ = "siril  hmeg om Icehironsasiossbedepe rli Tetel nicho lilprcactut"
   d4$ = "Thpaeceachh wige ebuaisursulmawaotowtsmploI solyee Cunm rtieno S"
   d5$ = "diwhs.rafincademe.irplk  ury Pwoacos gams,duayavucColamowe Aoopu"
   Dict$ = d1$ + d2$ + d3$ + d4$ + d5$
   IF LEN(Dict$) <> 320 THEN              'just to check...
     PRINT "PACKING ERROR: Dictionray has the wrong size"
     EXIT SUB
   END IF
  
   IF NOT LEFT$(text$, 1) = CHR$(255) THEN 'check if the string is packed
     'the string isn't packed so pack it...
     IF LEN(text$) < 4 THEN EXIT SUB 'no use with strings less than 4 chars.
    
     FOR a = 1 TO LEN(text$)              'check if there are any characters
       v = ASC(MID$(text$, a, 1))         ' with values out of range (they
       IF v < 32 OR v > 127 THEN EXIT SUB ' _cannot_ be packed otherwise)
     NEXT a
    
     DO
      
       cnt = cnt + 1               'read pointer in text$
       char$ = MID$(text$, cnt, 2) 'characters to be checked for in Dict$
      
       IF cnt = LEN(text$) THEN    'if the end of the string has been reached
         text$ = CHR$(255) + temp$ + CHR$(ASC(MID$(text$, cnt, 1)) - 32)
         EXIT SUB                   '^^^^ add the last character
       END IF
      
       xx = 1 'read pointer in Dict$
ReDo:
       x = INSTR(xx, Dict$, char$)4;1;120;1;0xp
       IF x THEN           'if the characters from text$ are in Dict$
         IF (x \ 2) = (x / 2) THEN 'if the instr of the characters can't be
           xx = x + 1              ' divided by 2 then look again (it needs
           GOTO ReDo               ' to be divided so it can be packed)
         END IF
         temp$ = temp$ + CHR$((x \ 2) + 96) 'add the instr of the characters
         cnt = cnt + 1                      ' in Dict$ to temp$ (note that
              '^^^ characters shouldn't     ' it's stored so that it's more
                 ' be compressed twice      ' than 95)
       ELSE
         'if the characters aren't found store the first character
         '(note that it's less than 95 and that cnt is only moved up _1_)
         temp$ = temp$ + CHR$(ASC(MID$(text$, cnt, 1)) - 32)
       END IF
     LOOP WHILE cnt < LEN(text$)
     text$ = CHR$(255) + temp$ 'copy temp$ into text$ and add CHR$(255)
     EXIT SUB                  ' to indicate a packed string
   ELSE
     'text$ is packed so unpack it
     comp$ = RIGHT$(text$, LEN(text$) - 1) 'remove CHR$(255)
     text$ = ""                            're-init text$
     FOR x = 1 TO LEN(comp$)
       char = ASC(MID$(comp$, x, 1))
       IF char > 95 THEN 'if char > 95 then char is the instr of the
                         ' unpacked characters in Dict$, remember?
         text$ = text$ + MID$(Dict$, (char - 96) * 2 + 1, 2)
       ELSE 'if the characters weren't found in Dict$ they were stored
            ' with a value less than 95 (most are found, though)
         text$ = text$ + CHR$(ASC(MID$(comp$, x, 1)) + 32)
       END IF
     NEXT x
   END IF
END SUB