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