'===========================================================================
' Subject: PACK TEXT                          Date: 06/02/92 (19:42)       
'  Author: Greg Estabrooks                    Code: QB, QBasic, PDS        
'  Origin: PACK,TEXT                        Packet: TEXT.ABC
'===========================================================================
'    Here is a routine that I developed to compress small strings. It
'usually compresses the string (text only) to about 52% of the original
'size of the string.

DEFINT A-Z

DECLARE SUB PackTxt (Text$, Comp$, sw%)

CLS

Text$ = "This is a test, this is only a test."

x = LEN(Text$)
PRINT "Text string     =  "; Text$
PRINT "Uncompress Len  = "; x
sw = 0
CALL PackTxt(Text$, Comp$, sw)

xx = LEN(Comp$)
PRINT
PRINT "Compress Len    = "; xx
PRINT "Compress   %    ="; xx / x
PRINT "Compress string =  "; Comp$

sw = 1
CALL PackTxt(Text$, Comp$, sw)
PRINT
PRINT "Returned Len    = "; LEN(Text$)
PRINT "Returned string =  "; Text$

'
SUB PackTxt (Text$, Comp$, sw)

   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 sw = 0 THEN
      Comp$ = ""
      DO
         cnt = cnt + 1
         char$ = MID$(Text$, cnt, 2)
         IF cnt = LEN(Text$) THEN
            Comp$ = temp$ + CHR$(ASC(MID$(Text$, cnt, 1)) - 32)
            EXIT SUB
         END IF
         xx = 1
ReDo:
         x = INSTR(xx, Dict$, char$)
         IF x > 0 THEN
            IF (x \ 2) = (x / 2) THEN
               xx = x + 1
               GOTO ReDo
            END IF
            temp$ = temp$ + CHR$((x \ 2) + 96)
            cnt = cnt + 1
         ELSE
            temp$ = temp$ + CHR$(ASC(MID$(Text$, cnt, 1)) - 32)
         END IF
      LOOP WHILE cnt < LEN(Text$)
      Comp$ = temp$
      EXIT SUB
   ELSE
      Text$ = ""
      FOR x = 1 TO LEN(Comp$)
         char = ASC(MID$(Comp$, x, 1))
         IF char > 95 THEN
            Text$ = Text$ + MID$(Dict$, (char - 96) * 2 + 1, 2)
         ELSE
            Text$ = Text$ + CHR$(ASC(MID$(Comp$, x, 1)) + 32)
         END IF
      NEXT
   END IF

END SUB