Basic lossless string encoding example

[jvanegmond]

I'm adding a Burrows Wheeler transform later.

Run this in SciTE or you will not be able to read the console:

expandcollapse popup

Dim $In = "BWAABBBWAABWWWAABWAAAAAABWAABWAABWAA"
Dim $Out = ""

Dim $Char = StringSplit($In,"")
Dim $Buffer = "", $i = 1
Dim $Result[1]

While $i <= $Char[0]
    $Buffer &= $Char[$i]
    
    If ($i+1 <= $Char[0]) AND (Not ($Char[$i] == $Char[$i+1])) Then
        _Add($Buffer)
        $Buffer = ""
    EndIf
    
    $i += 1
WEnd
_Add($Buffer)

For $i = 1 to UBound($Result)-1
    ;If (StringLen($Result[$i]) == 1) Then
    ;   $Out &= $Result[$i]
    ;Else
        $Out &= StringLen($Result[$i]) & StringLeft($Result[$i],1)
    ;EndIf
Next

ConsoleWrite("String length before: " & StringLen($In) & @CRLF)
ConsoleWrite("String length after: " & StringLen($Out) & @CRLF)
ConsoleWrite("KB saved: " & ((StringLen($In)-StringLen($Out))/1024) & " ( " & (StringLen($In)-StringLen($Out)) & " bytes or " & Round((StringLen($In)-StringLen($Out))/StringLen($In)*100,1) &  "% )" & @CRLF)
ConsoleWrite("In : " & StringLeft($In,100) & @CRLF)
ConsoleWrite("Out: " & StringLeft($Out,100) & @CRLF)

Func _Add($String)
    $n = UBound($Result)
    Redim $Result[$n+1]
    $Result[$n] = $String
EndFunc

Edited October 6, 2008 by Manadar

[trancexx]

Nice.

I'm fascinated by the simplicity of, for example, LZW algorithm and its ability to exploit many patterns.

[spudw2k]

Here's my go at the Burrows-Wheeler algo.

expandcollapse popup

#include <Array.au3>
 
Local $sText = "SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES"
$timer = TimerInit()
Local $sBWT = _BWT($sText)
ConsoleWrite(TimerDiff($timer) & @CRLF)
$timer = TimerInit()
Local $sBWTInverse = _BWTInverse($sBWT)
ConsoleWrite(TimerDiff($timer) & @CRLF)
$timer = 0
 
Msgbox(0,"_BWT",$sText & @CRLF & $sBWT)
Msgbox(0,"_BWTInverse",$sBWT & @CRLF & $sBWTInverse)
 
Func _BWT($sInput)
   If Not IsString($sInput) Then Return SetError(1,0,False)
   Local $sTransform = $sInput & Chr(3)
   Local $aRotationsTable[StringLen($sTransform)]
   Local $iSubscripts = UBound($aRotationsTable)
   For $i = 0 To $iSubscripts - 1
   $aRotationsTable[$i] = $sTransform
   $sTransform = StringTrimLeft($sTransform,1) & StringLeft($sTransform,1)
   Next
   $aRotationsTable = __BWTTableSort($aRotationsTable)
   $sTransform = ""
   For $i = 0 to $iSubscripts - 1
   $sTransform &= StringRight($aRotationsTable[$i],1)
   Next
   Return $sTransform
EndFunc
 
Func _BWTInverse($sInput)
   If Not IsString($sInput) Then Return SetError(1,0,False)
   If Not StringInstr($sInput, Chr(3)) Then Return SetError(2,0,False)
   Local $aSortTable[StringLen($sInput)]
   Local $iSubscripts = UBound($aSortTable)
   Local $aAddTable[$iSubscripts]
   For $i = 0 to $iSubscripts - 1
   For $j = 0 To $iSubscripts - 1
   $aAddTable[$j] = StringMid($sInput, $j + 1, 1) & $aSortTable[$j]
   Next
   If $i < $iSubscripts - 1 Then $aSortTable = __BWTInverseSort($aAddTable)
   Next
   For $i = 0 to $iSubscripts - 1
   If StringLeft($aAddTable[$i],1) = Chr(3) Then Return StringTrimLeft($aAddTable[$i],1)
   Next
EndFunc
 
Func __BWTInverseSort($aTable)
   Local $iSubscripts = UBound($aTable)
   Local $iEOFRow = 0
   Local $sEOFRowString = ""
   _ArraySort($aTable)
   For $i = 0 To $iSubscripts - 1
   If StringLeft($aTable[$i], 1) = Chr(3) Then
   $iEOFRow = $i
   $sEOFRowString = $aTable[$i]
   $i = $iSubscripts - 1
   EndIf
   Next
   _ArrayDelete($aTable, $iEOFRow)
   _ArrayAdd($aTable, $sEOFRowString)
   Return $aTable
EndFunc
 
Func __BWTTableSort($aTable)
   Local $iSubscripts = UBound($aTable) - 1
   Local $aBWTTable[$iSubscripts]
   For $i = 0 To $iSubscripts - 1
   $aBWTTable[$i] = $aTable[$i]
   Next
   _ArraySort($aBWTTable)
   Redim $aBWTTable[$iSubscripts + 1]
   $aBWTTable[$iSubscripts] = $aTable[$iSubscripts]
   Return $aBWTTable
EndFunc

working on inverse.

edit: Had another go at this...with inverse.  It has issues with special chars...still a fun exercise.

Edited February 26, 2015 by spudw2k

[Fossil Rock]

To trancexx... I dare ya.