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 '===============================================================================