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

'===============================================================================
------------------