RUN Flagazine: Run 16/unpacked-run16.zip/JPH.BAS

BASIC Source File | 1995-01-01 | 14KB | 519 lines

'
' JPH.BAS - Jarno Peschier, (c) RUN Flagazine (Huffman file compressor)
'

%No = 0
%Yes = NOT %No

$LIB ALL OFF
$OPTIMIZE SPEED
$STRING 32
$SOUND 0
$COM 0
$EVENT OFF
$OPTION CNTLBREAK ON

'=== INIT ==================================================================

TYPE HuffNode        'Hoe ziet een knoop van de Huffman boom eruit?
  Char AS STRING * 1    'Het teken
  Freq AS DWORD        'De frequentie
  Up   AS WORD        'Parent pointer
  Zero AS WORD        'Left pointer
  One  AS WORD        'Right pointer
END TYPE

TYPE FileHeader        'Hoe ziet de header van een JPH file eruit?
  ID    AS STRING * 17    'ID string
  Ver    AS BYTE        'JPH versie (alleen nog 1)
  File    AS STRING * 13    'Oorspronkelijke naam ingepakte file
  Size    AS DWORD    'Oorspronkelijke grootte ingepakte file
  Nodes AS WORD        'Aantal knopen Huffman boom
  Root    AS WORD        'Wortel van Huffman boom
  Res    AS STRING * 25    'Gereserveerde ruimte (header = 64 bytes)
END TYPE

%Top = 1024        'Aangeven dat knoop een wortel is
%MaxFiles = 1024    'Maximaal aantal files met wildcards

' De Huffman boom is een array van nodes (met onderlinge pointers)
DIM Huff(511) AS SHARED HuffNode
DIM NoOfNodes AS SHARED WORD
DIM Root AS SHARED WORD

' Opzoektabel met Huffman codes om coderen/decoderen te versnellen
DIM Code(255) AS SHARED STRING

' Buffers bij voor input/output (I/O)
DIM IOBuf AS SHARED STRING
DIM BitBuffer AS SHARED STRING

' Schermbuffer voor meldingen in windowtjes
DIM BeforeMsg AS SHARED STRING

' Roep het programma zelf aan
MainProgram
END

'=== MAIN ==================================================================

SUB MainProgram
  DIM File(1024) AS LOCAL STRING
  DIM NoOfFiles AS LOCAL WORD
  DIM FileName AS LOCAL STRING
  DIM Path AS LOCAL STRING
  DIM I AS LOCAL INTEGER
  ' Laat zien wie we zijn
  PRINT
  PRINT"JPH 0.02, Copyright 13 augustus 1995, Jarno Peschier, RUN Flagazine 16"
  PRINT
  ' Geef helpscherm als helemaal geen parameters zijn opgegeven
  IF Command$ = "" THEN
    PRINT"Syntax: JPH [filespec]"
    PRINT
    PRINT"Als de opgegeven file een JPH gecomprimeerde file is dan"
    PRINT"zal die worden uitgepakt naar de originele naam."
    PRINT
    PRINT"Als de opgegeven file geen JPH gecomprimeerde file is dan"
    PRINT"zal die worden ingepakt tot een JPH door gebruik te maken"
    PRINT"van simpele Huffman compressie, zoals uitgelegd is in"
    PRINT"het programma over compressie op RUN Flagazine 16."
    PRINT
    PRINT"Als je een file met weinig redundatie erin probeert te"
    PRINT"comprimeren, is de kans erg groot dat het resultaat nog"
    PRINT"groter wordt dan het origineel. In dat geval heeft JPH"
    PRINT"compressie geen enkel nut. Hetzelfde geldt voor het com-"
    PRINT"primeren van een kleine file, waarvan de Huffman boom die"
    PRINT"nodig is al groter is dan de hele file."
  ELSE
    ' Bepaal alle files die voldoen aan de opgegeven file specificatie
    NoOfFiles = 0
    FileName = DIR$(COMMAND$)
    IF FileName <> "" THEN
      Path = UCASE$(COMMAND$)
      FOR I = LEN(Path) TO 1 STEP -1
        IF MID$(Path,I,1) = "\" THEN
          Path = LEFT$(Path,I)
          EXIT FOR
        END IF
      NEXT I
      IF TALLY(Path,"\") = 0 AND MID$(Path,2) <> ":" THEN Path = ""
      DO
        INCR NoOfFiles
        File(NoOfFiles) = FileName
        FileName = DIR$
      LOOP WHILE FileName <> "" AND NoOfFiles < %MaxFiles
      ' Handel iedere gevonden filenaam af
      FOR I = 1 TO NoOfFiles
        Handle Path+File(I)
      NEXT I
    ELSE
      PRINT"Bestand(en) niet gevonden"
    END IF
  END IF
END SUB

SUB Handle(BYVAL File AS STRING)    'Behandel een file
  IF IsJPH(File) THEN
    DeCompress File
  ELSE
    Compress File
  END IF
END SUB

SUB Compress(File AS STRING)        'Pak een file in tot een JPH file
  DIM Buffer AS LOCAL STRING
  DIM I AS LOCAL INTEGER
  PRINT File;
  BuildHuffmanTree File
  BuildCodeTable
  OPEN File FOR BINARY AS #2
  PRINT " --> ";StartWritingJPH(File);
  Message "File gecomprimeerd wegschrijven..."
  WHILE NOT EOF(2)
    GET$ #2,32000,Buffer
    FOR I = 1 TO LEN(Buffer)
      WriteBits Code(ASCII(MID$(Buffer,I,1)))
    NEXT I
  WEND
  RestoreScreen
  PRINT" ("+LTRIM$(STR$(LOF(1)*100\LOF(2)))+"% over)"
  StopWritingJPH
  CLOSE #2
END SUB

SUB DeCompress(File AS STRING)        'Pak een JPH file weer uit
  DIM Result AS LOCAL STRING
  DIM OriginalSize AS LOCAL DWORD
  DIM ToWrite AS LOCAL STRING
  Result = File
  OriginalSize = StartReadingJPH(Result)
  BuildDecodeTable
  WHILE DIR$(Result) <> ""
    BEEP
    PRINT Result+" bestaat al, geef een nieuwe naam: ";
    INPUT "",Result
    Result = UCASE$(Result)
  WEND
  PRINT File;" ==> ";Result
  Message "File uitpakken..."
  OPEN Result FOR BINARY AS #2
  WHILE NOT EndOfJPH
    BitBuffer = BitBuffer + ReadBits
    ToWrite = Lookup(BitBuffer)
    PUT$ #2, ToWrite
  WEND
  CLOSE #2
  RestoreScreen
  StopReadingJPH
END SUB

'=== HUFFMAN BOOM BOUWEN ====================================================

SUB BuildHuffmanTree(File AS STRING)    'Bouw een optimale Huffman boom
  DIM Freq(255) AS LOCAL DWORD        'voor de opgegeven file
  DIM Buffer AS LOCAL STRING
  DIM I AS LOCAL WORD
  DIM J AS LOCAL WORD
  DIM Node AS LOCAL HuffNode
  DIM BeforeMsg AS LOCAL STRING
  ' Frequentietabel op nul zetten
  FOR I = 0 TO 255
    Freq(I) = 0
  NEXT I
  ' Tekenfrequenties bepalen
  Message "Tekenfrequenties bepalen..."
  OPEN File FOR BINARY AS #1
  WHILE NOT EOF(1)
  GET$ #1, 32000, Buffer
    FOR I = 1 TO LEN(Buffer)
      INCR Freq(ASCII(MID$(Buffer,I,1)))
      IF Freq(ASCII(MID$(Buffer,I,1))) > 32000 THEN
      END IF
    NEXT I
  WEND
  CLOSE #1
  RestoreScreen
  ' Losse knopen in de Huffman boom zetten
  Message "Optimale Huffman boom bouwen..."
  NoOfNodes = 0
  FOR I = 0 TO 255
    IF Freq(I) > 0 THEN
      INCR NoOfNodes
      Node.Char = CHR$(I)
      Node.Freq = Freq(I)
      Node.Up = %Top
      Node.Zero = 0
      Node.One = 0
      Huff(NoOfNodes) = Node
    END IF
  NEXT I
  SortNodes
  ' Samenstellen knopen tot een optimale Huffman boom
  DO
    I = NextTopNode
    J = NextTopNode
    INCR NoOfNodes
    Node.Char = CHR$(0)
    Node.Freq = Huff(I).Freq + Huff(J).Freq
    Node.Up = %Top
    Node.Zero = I
    Node.One = J
    Huff(NoOfNodes) = Node
    SortNodes
  LOOP WHILE TopNodes > 1
  ' Parent pointers bepalen uit child pointers
  FOR I = 1 TO NoOfNodes
    IF Huff(I).Zero <> 0 THEN
      Huff(Huff(I).Zero).Up = I
    END IF
    IF Huff(I).One <> 0 THEN
      Huff(Huff(I).One).Up = I
    END IF
  NEXT I
  ' Wortel bepalen en opslaan
  Root = NextTopNode
  ' Huffman boom is klaar voor gebruik
  RestoreScreen
END SUB

SUB SortNodes
  DIM I AS LOCAL INTEGER
  DIM J AS LOCAL INTEGER
  DIM Temp AS LOCAL HuffNode
  ' Sorteer alle knopen op oplopende frequentie (insertion sort)
  FOR I = 2 TO NoOfNodes
    Temp = Huff(I)
    J = I - 1
    WHILE J > 0 AND Huff(J).Freq > Temp.Freq
      Huff(J+1) = Huff(J)
      DECR J
    WEND
    Huff(J+1) = Temp
  NEXT I
END SUB

FUNCTION NextTopNode AS INTEGER
  DIM I AS LOCAL INTEGER
  ' Zoek eerstvolgende knoop die een wortel is
  FOR I = 1 TO NoOfNodes
    IF Huff(I).Up = %Top THEN
      Huff(I).Up = 0
      NextTopNode = I
      EXIT FUNCTION
    END IF
  NEXT I
END FUNCTION

FUNCTION TopNodes AS INTEGER
  DIM N AS LOCAL INTEGER
  ' Tel het aantal wortels dat over is
  N = 0
  FOR I = 1 TO NoOfNodes
    IF Huff(I).Up = %Top THEN INCR N
  NEXT I
  TopNodes = N
END FUNCTION

'=== GEEF TEKEN BIJ HUFFMAN CODE EN VICE VERSA =============================

SUB BuildCodeTable
  DIM I AS LOCAL WORD
  FOR I = 1 TO NoOfNodes
    IF Huff(I).Zero + Huff(I).One = 0 THEN
      Code(ASCII(Huff(I).Char)) = HuffCode(ASCII(Huff(I).Char))
    END IF
  NEXT I
END SUB

FUNCTION HuffCode(Teken AS INTEGER) AS STRING
  DIM I AS LOCAL WORD
  DIM Node AS LOCAL WORD
  DIM Code AS LOCAL STRING
  FOR I = 1 TO NoOfNodes
    IF Huff(I).Char = CHR$(Teken) THEN
      Node = I
      EXIT FOR
    END IF
  NEXT I
  Code = ""
  DO
    IF Huff(Huff(Node).Up).Zero = Node THEN
      Code = "0" + Code
    ELSE
      Code = "1" + Code
    END IF
    Node = Huff(Node).Up
  LOOP WHILE Huff(Node).Up > 0
  HuffCode = Code
END FUNCTION

SUB BuildDecodeTable
  DIM I AS LOCAL WORD
  FOR I = 1 TO NoOfNodes
    IF Huff(I).Zero + Huff(I).One = 0 THEN
      Code(ASCII(Huff(I).Char)) = HuffCode(ASCII(Huff(I).Char))
    END IF
  NEXT I
END SUB

FUNCTION Lookup(BitString AS STRING) AS STRING
  DIM Node AS LOCAL WORD
  DIM Result AS LOCAL STRING
  DIM Code AS LOCAL STRING
  Node = Root
  Result = ""
  Code = BitString
  ' Afdalen in de boom en decoderen tot Code leeg is
  WHILE Code <> ""
    SELECT CASE LEFT$(Code,1)
      CASE "0": Node = Huff(Node).Zero
      CASE "1": Node = Huff(Node).One
      CASE ELSE: BEEP:END
    END SELECT
    Code = MID$(Code,2)
    IF Huff(Node).Zero + Huff(Node).One = 0 THEN
      Result = Result + Huff(Node).Char
      Node = Root
    END IF
  WEND
  ' Als we ergens middenin de boom eindigen, ga dan terug omhoog in de
  ' boom om de "rest" te vinden zodat je die in BitString kan laten.
  IF Node = Root THEN
    BitString = ""
  ELSE
    DO
      IF Huff(Huff(Node).Up).Zero = Node OR Node = Root THEN
        Code = "0" + Code
      ELSE
        Code = "1" + Code
      END IF
      Node = Huff(Node).Up
    LOOP WHILE Huff(Node).Up > 0
    BitString = Code
  END IF
  Lookup = Result
END FUNCTION

'=== DISK I/O ==============================================================

' General

FUNCTION IsJPH(File AS STRING) AS INTEGER    'Is de file een JPH file?
  DIM Header AS LOCAL FileHeader
  DIM Result AS LOCAL INTEGER
  IF DIR$(File) <> "" THEN Result = %Yes
  IF INSTR(File, ANY "*?") > 0 THEN Result = %No
  IF Result = %Yes THEN
    OPEN File FOR BINARY AS #1
      GET #1,,Header
      IF Header.ID <> "JPH compressed"+CHR$(10,13,26) THEN Result = %No
      IF Header.Ver <> 1 THEN Result = %No
    CLOSE #1
  END IF
  IsJPH = Result
END FUNCTION

' Output

FUNCTION StartWritingJPH(File AS STRING) AS STRING    'Begin JPH file
  DIM Header AS LOCAL FileHeader
  DIM I AS LOCAL WORD
  OPEN File FOR BINARY AS #1
  IF MID$(File,2,1) = ":" THEN File = MID$(File,3)
  WHILE INSTR(File,"\") > 0
    File = MID$(File,INSTR(File,"\")+1)
  WEND
  Header.ID    = "JPH compressed"+CHR$(10,13,26)
  Header.Ver   = 1
  Header.File  = File
  Header.Size  = LOF(1)
  Header.Nodes = NoOfNodes
  Header.Root  = Root
  Header.Res   = STRING$(LEN(Header.Res),0)
  CLOSE #1
  File = File + "."
  File = LEFT$(File,INSTR(File,"."))+"JPH"
  OPEN File FOR BINARY AS #1
  PUT #1,,Header
  FOR I = 1 TO NoOfNodes
    PUT #1,,Huff(I)
  NEXT I
  IOBuf = ""
  BitBuffer = ""
  StartWritingJPH = File
END FUNCTION

SUB WriteBits(BitString AS STRING)        'Schrijf bits naar JPH file
  BitBuffer = BitBuffer + BitString
  WHILE LEN(BitBuffer) > 7
    IOBuf = IOBuf + CHR$(VAL("&B"+LEFT$(BitBuffer,8)))
    BitBuffer = MID$(BitBuffer,9)
  WEND
  IF LEN(IOBuf) => 64 THEN
    PUT$ #1,IOBuf
    IOBuf = ""
  END IF
END SUB

SUB StopWritingJPH            'Stop met schrijven (buffer legen)
  BitBuffer = BitBuffer + STRING$(8-(LEN(BitBuffer) MOD 8),"0")
  WHILE BitBuffer <> ""
    IOBuf = IOBuf + CHR$(VAL("&B"+LEFT$(BitBuffer,8)))
    BitBuffer = MID$(BitBuffer,9)
  WEND
  PUT$ #1, IOBuf
  CLOSE #1
END SUB

' Input

FUNCTION StartReadingJPH(File AS STRING) AS DWORD    'Begin lezen JPH
  DIM Header AS LOCAL FileHeader
  DIM I AS LOCAL WORD
  IF IsJPH(File) THEN
    OPEN File FOR BINARY AS #1
    GET #1,,Header
    File = RTRIM$(Header.File)
    StartReadingJPH = Header.Size
    NoOfNodes = Header.Nodes
    Root = Header.Root
    FOR I = 1 TO NoOfNodes
      GET #1,,Huff(I)
    NEXT I
    IOBuf = ""
    BitBuffer = ""
  ELSE
    PRINT"Geen JPG file..."
    END 1
  END IF
END FUNCTION

FUNCTION EndOfJPH AS INTEGER        'Is het eind van de file bereikt?
  EndOfJPH = EOF(1)
END FUNCTION

FUNCTION ReadBits AS STRING        'Lees een blok van bits (2K maximum)
  DIM I AS LOCAL INTEGER
  GET$ #1,2024,IOBuf
  FOR I = 1 TO LEN(IOBuf)
    BitBuffer = BitBuffer+RIGHT$("00000000"+BIN$(ASCII(MID$(IOBuf,I,1))),8)
  NEXT I
  ReadBits = BitBuffer
END FUNCTION

SUB StopReadingJPH                              'Stop met lezen
  CLOSE #1
END SUB

'=== SCREEN I/O ============================================================

SUB Message(Msg AS STRING)
  DIM OldSeg AS LOCAL WORD
  DIM I AS LOCAL INTEGER
  DIM Y AS LOCAL INTEGER
  DIM X AS LOCAL INTEGER
  BeforeMsg = SaveScreen
  OldSeg = pbvDefSeg
  IF (pbvScrnCard AND 64) THEN
    DEF SEG = &HB000
  ELSE
    DEF SEG = &HB800
  END IF
  I = 40-LEN(Msg)\2
  FOR Y = 10 TO 12
    POKE$ Y*160+2*(I-2),REPEAT$(LEN(Msg)+4,CHR$(&H20,&H1F))
  NEXT Y
  Y = 11
  FOR X = I TO I+LEN(Msg)-1
    POKE Y*160+2*X,ASCII(MID$(Msg,X-I+1,1))
  NEXT X
  DEF SEG = OldSeg
END SUB

FUNCTION SaveScreen AS STRING
  DIM OldSeg AS LOCAL WORD
  OldSeg = pbvDefSeg
  IF (pbvScrnCard AND 64) THEN
    DEF SEG = &HB000
  ELSE
    DEF SEG = &HB800
  END IF
  SaveScreen = CHR$(CSRLIN)+CHR$(POS(0))+PEEK$(0,4000)
  DEF SEG = OldSeg
END FUNCTION

SUB RestoreScreen
  DIM OldSeg AS LOCAL WORD
  OldSeg = pbvDefSeg
  IF (pbvScrnCard AND 64) THEN
    DEF SEG = &HB000
  ELSE
    DEF SEG = &HB800
  END IF
  POKE$ 0, MID$(BeforeMsg,3,4000)
  DEF SEG = OldSeg
  LOCATE ASCII(LEFT$(BeforeMsg,1)),ASCII(MID$(BeforeMsg,2,1))
END SUB

'===========================================================================