Announcement

Collapse
No announcement yet.

PB/DOS - RunLengthEncoding/Decoding

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PB/DOS - RunLengthEncoding/Decoding

    Code:
    '-------------------------------------------------------------------------------
    '     Unit: rlepack1.pbl
    '    Zweck: Datenblock packen/entpacken mit primitivem RLE/RLL-Verfahren
    '    Stand: 13.07.98
    '  Version: 1.00
    '    Autor: M.Hoffmann
    '  Sprache: PowerBASIC 3.5
    ' Historie:
    ' 13.07.98: 1.00 - Erste Version.
    ' ACHTUNG : Dieses Packen hat einen gravierenden Nachteil: Es wird immer nur
    '           1 Byte betrachtet; Folgen wie 'ababababab...' werden daher nicht
    '           als sich wiederholende Sequenz betrachtet. Daher bringt das Packen
    '           z.B. eines Videodumps mit dieser Methode nichts (Chr/Attr-Wechsel)!
    '-------------------------------------------------------------------------------
    ' c: rlepack1.pbu      1913  20.07.98  10:03  v1.00
    
    '---Compilersteuerung-----------------------------------------------------------
    
    $compile  unit
    $cpu      80386
    $debug    map-,pbdebug-,path-,unit-
    $dim      all
    $error    bounds-,numeric-,overflow-,stack-
    $event    off
    $float    emulate
    $optimize size
    $option   cntlbreak-,gosub-,signed-
    defint    a-z
    
    '---Globale Variablen-----------------------------------------------------------
    
    '---Routinen--------------------------------------------------------------------
    
    function RLECodes local private as string
       dim temp as local string*256
       dim i    as local integer
       for i=1 to 256
          asc(temp,i) = i-1
       next
       function = temp
    end function
    
    '-------------------------------------------------------------------------------
    
    function RLEPack (block as string) local public as string
    
       dim new  as local string  ' Rückgabepuffer
       dim Ctr  as local integer ' Anzahl wiederholter Vorkommnisse eines Zeichens
       dim i    as local integer ' Zähler von [1..LängeEingabeString], diverses
       dim j    as local integer ' Offset-Merker
       dim c    as local integer ' Asciicode des aktuell gelesenen Zeichens
       dim l    as local integer ' Asciicode des zuletzt gelesenen Zeichens
       dim kenn as local integer ' Kennung für gepackte Sequenz
    
       ' Versuch, im Datenblock nicht vorhandenes Zeichen als Kennung zu ermitteln
       kenn = verify(RLECodes,block)-1
       ' Falls alle Zeichen mindestens einmal vorkommen, ist das Zeichen mit dem
       ' geringsten Vorkommnis als Kennung zu verwenden, da das notwendige Kodieren
       ' dieser Zeichen den Datenblock ja vergrößert
       if kenn = 0 then
          for i=0 to 255
             kenn = min%(kenn,tally(block,chr$(i)))
          next
       end if
    
       l = ascii(block,1)
       j = 1
       ctr = 1
       for i = 2 to len(block)
          c = ascii(block,i)
          if c = l then
             incr ctr ' erstmal nichts ausgeben, da Sequenz folgen könnte
          else
             ' Zeichenwechsel aufgetreten; wenn zuvor eine Sequenz auftrat oder das
             ' Kennbyte selbst, Kodierung ausgeben, sonst die Zeichen schreiben
             if ctr > 4 or l = kenn then
                new = new & chr$(kenn,l) & mki$(ctr)
             else
                new = new & mid$(block,j,i-j)
             end if
             j = i
             ctr = 1
          end if
          l = c
       next
       if ctr > 4 or l = kenn then
          new = new & chr$(kenn,l) & mki$(ctr)
       else
          new = new & mid$(block,j,i-j)
       end if
    
       function = chr$(kenn) & new
    
    end function
    
    '-------------------------------------------------------------------------------
    
    function RLEUnpack (block as string) local public as string
    
       dim new  as local string  ' Rückgabepuffer
       dim Ctr  as local integer ' Anzahl wiederholter Vorkommnisse eines Zeichens
       dim i    as local integer ' Zähler von [1..LängeEingabeString], diverses
       dim c    as local integer ' Asciicode des aktuell gelesenen Zeichens
       dim kenn as local integer ' Kennung für gepackte Sequenz
    
       kenn = ascii(block,1)
       for i = 2 to len(block)
          c = ascii(block,i)
          if c = kenn then
             new = new & string$(cvi(block,i+2),ascii(block,i+1))
             incr i,3
          else
             new = new & chr$(c)
          end if
       next
    
       function = new
    
    end function
    
    '===============================================================================
    ------------------
Working...
X