259 lines
8.5 KiB
Plaintext
259 lines
8.5 KiB
Plaintext
*process source attributes xref or(!);
|
|
hencode: Proc Options(main);
|
|
/*--------------------------------------------------------------------
|
|
* 28.12.013 Walter Pachl translated from REXX
|
|
*-------------------------------------------------------------------*/
|
|
Dcl debug Bit(1) Init('0'b);
|
|
Dcl (i,j,k) Bin Fixed(15);
|
|
Dcl c Char(1);
|
|
Dcl s Char(100) Var Init('this is an example for huffman encoding');
|
|
Dcl sc Char(1000) Var Init('');
|
|
Dcl sr Char(100) Var Init('');
|
|
Dcl 1 cocc(100),
|
|
2 c Char(1),
|
|
2 occ Bin Fixed(31);
|
|
Dcl cocc_n Bin Fixed(15) Init(0);
|
|
dcl 1 node,
|
|
2 id Bin Fixed(15), /* Node id */
|
|
2 c Char(1), /* character */
|
|
2 occ Bin Fixed(15), /* number of occurrences */
|
|
2 left Bin Fixed(15), /* left child */
|
|
2 rite Bin Fixed(15), /* right child */
|
|
2 father Bin Fixed(15), /* father */
|
|
2 digit Pic'9', /* digit (0 or 1) */
|
|
2 term Pic'9'; /* 1=terminal node */
|
|
node='';
|
|
Dcl 1 m(100) Like node;
|
|
Dcl m_n Bin Fixed(15) Init(0);
|
|
Dcl father(100) Bin Fixed(15);
|
|
|
|
Dcl 1 t(100),
|
|
2 char Char(1),
|
|
2 code Char(20) Var;
|
|
Dcl t_n Bin Fixed(15) Init(0);
|
|
|
|
Do i=1 To length(s); /* first collect used characters */
|
|
c=substr(s,i,1); /* and number of occurrences */
|
|
Do j=1 To cocc_n;
|
|
If cocc(j).c=c Then Leave;
|
|
End;
|
|
If j<= cocc_n Then
|
|
cocc(j).occ+=1;
|
|
Else Do;
|
|
cocc(j).c=c;
|
|
cocc(j).occ=1;
|
|
cocc_n+=1;
|
|
End;
|
|
End;
|
|
|
|
Do j=1 To cocc_n; /* create initial node list */
|
|
node.id+=1;
|
|
node.c=cocc(j).c;
|
|
node.occ=cocc(j).occ;
|
|
node.term=1;
|
|
Call add_node;
|
|
End;
|
|
|
|
If debug Then
|
|
Call show;
|
|
|
|
Do While(pairs()); /* while there is more than one fatherless node */
|
|
Call mk_node; /* create a father node */
|
|
If debug Then
|
|
Call show;
|
|
End;
|
|
|
|
Call show; /* show the node table */
|
|
|
|
Call mk_trans; /* create the translate table */
|
|
Put Edit('The translate table:')(Skip,a);
|
|
Do i=1 To t_n; /* show it */
|
|
Put Edit(t(i).char,' -> ',t(i).code)(Skip,a,a,a);
|
|
End;
|
|
|
|
Call encode; /* encode the string s -> sc */
|
|
|
|
Put Edit('length(sc)=',length(sc)) /* show it */
|
|
(Skip,a,f(3));
|
|
Do i=1 By 70 To length(sc);
|
|
Put Edit(substr(sc,i,70))(Skip,a);
|
|
End;
|
|
|
|
Call decode; /* decode the string sc -> sr */
|
|
Put Edit('input : ',s)(skip,a,a);
|
|
Put Edit('result: ',sr)(skip,a,a);
|
|
Return;
|
|
|
|
add_node: Proc;
|
|
/*--------------------------------------------------------------------
|
|
* Insert the node according to increasing occurrences
|
|
*-------------------------------------------------------------------*/
|
|
il:
|
|
Do i=1 To m_n;
|
|
If m(i).occ>=node.occ Then Do;
|
|
Do k=m_n To i By -1;
|
|
m(k+1)=m(k);
|
|
End;
|
|
Leave il;
|
|
End;
|
|
End;
|
|
m(i)=node;
|
|
m_n+=1;
|
|
End;
|
|
|
|
show: Proc;
|
|
/*--------------------------------------------------------------------
|
|
* Show the contents of the node table
|
|
*-------------------------------------------------------------------*/
|
|
Put Edit('The list of nodes:')(Skip,a);
|
|
Put Edit('id c oc l r f d t')(Skip,a);
|
|
Do i=1 To m_n;
|
|
Put Edit(m(i).id,m(i).c,m(i).occ,
|
|
m(i).left,m(i).rite,m(i).father,m(i).digit,m(i).term)
|
|
(Skip,f(2),x(1),a,4(f(3)),f(2),f(3));
|
|
End;
|
|
End;
|
|
|
|
mk_node: Proc;
|
|
/*--------------------------------------------------------------------
|
|
* construct and store a new intermediate node or the top node
|
|
*-------------------------------------------------------------------*/
|
|
Dcl z Bin Fixed(15);
|
|
node='';
|
|
node.id=m_n+1; /* the next node id */
|
|
node.c='*';
|
|
ni=m_n+1;
|
|
loop:
|
|
Do i=1 To m_n; /* loop over node lines */
|
|
If m(i).father=0 Then Do; /* a fatherless node */
|
|
z=m(i).id; /* its id */
|
|
If node.left=0 Then Do; /* new node has no left child */
|
|
node.left=z; /* make this the lect child */
|
|
node.occ=m(i).occ; /* occurrences */
|
|
m(i).father=ni; /* store father info */
|
|
m(i).digit=0; /* digit 0 to be used */
|
|
father(z)=ni; /* remember z's father (redundant) */
|
|
End;
|
|
Else Do; /* New node has already left child */
|
|
node.rite=z; /* make this the right child */
|
|
node.occ=node.occ+m(i).occ; /* add in the occurrences */
|
|
m(i).father=ni; /* store father info */
|
|
m(i).digit=1; /* digit 1 to be used */
|
|
father(z)=ni; /* remember z's father (redundant) */
|
|
Leave loop;
|
|
End;
|
|
End;
|
|
End;
|
|
Call add_node;
|
|
End;
|
|
|
|
pairs: Proc Returns(Bit(1));
|
|
/*--------------------------------------------------------------------
|
|
* Return true if there are at least 2 fatherless nodes
|
|
*-------------------------------------------------------------------*/
|
|
Dcl i Bin Fixed(15);
|
|
Dcl cnt Bin Fixed(15) Init(0);
|
|
Do i=1 To m_n;
|
|
If m(i).father=0 Then Do;
|
|
cnt+=1;
|
|
If cnt>1 Then
|
|
Return('1'b);
|
|
End;
|
|
End;
|
|
Return('0'b);
|
|
End;
|
|
|
|
mk_trans: Proc;
|
|
/*--------------------------------------------------------------------
|
|
* Compute the codes for all terminal nodes (characters)
|
|
* and store the relation char -> code in array t(*)
|
|
*-------------------------------------------------------------------*/
|
|
Dcl (i,fi,fid,fidz,node,z) Bin Fixed(15);
|
|
Dcl code Char(20) Var;
|
|
Do i=1 To m_n; /* now we loop over all lines representing nodes */
|
|
If m(i).term Then Do; /* for each terminal node */
|
|
code=m(i).digit; /* its digit is the last code digit */
|
|
node=m(i).id; /* its id */
|
|
Do fi=1 To 1000; /* actually Forever */
|
|
fid=father(node); /* id of father */
|
|
If fid>0 Then Do; /* father exists */
|
|
fidz=zeile(fid); /* line that contains the father */
|
|
code=m(fidz).digit!!code; /* prepend the digit */
|
|
node=fid; /* look for next father */
|
|
End;
|
|
Else /* no father (we reached the top */
|
|
Leave;
|
|
End;
|
|
If length(code)>1 Then /* more than one character in input */
|
|
code=substr(code,2); /* remove the the top node's 0 */
|
|
call dbg(m(i).c!!' -> '!!code); /* character is encoded this way*/
|
|
ti_loop:
|
|
Do ti=1 To t_n;
|
|
If t(ti).char>m(i).c Then Do;
|
|
Do tj=t_n To ti By -1
|
|
t(tj+1)=t(tj);
|
|
End;
|
|
Leave ti_loop;
|
|
End;
|
|
End;
|
|
t(ti).char=m(i).c;
|
|
t(ti).code=code;
|
|
t_n+=1;
|
|
Call dbg(t(ti).char!!' -> '!!t(ti).code);
|
|
End;
|
|
End;
|
|
End;
|
|
|
|
zeile: Proc(nid) Returns(Bin Fixed(15));
|
|
/*--------------------------------------------------------------------
|
|
* find and return line number containing node-id
|
|
*-------------------------------------------------------------------*/
|
|
Dcl (nid,i) Bin Fixed(15);
|
|
do i=1 To m_n;
|
|
If m(i).id=nid Then
|
|
Return(i);
|
|
End;
|
|
Stop;
|
|
End;
|
|
|
|
dbg: Proc(txt);
|
|
/*--------------------------------------------------------------------
|
|
* Show text if debug is enabled
|
|
*-------------------------------------------------------------------*/
|
|
Dcl txt Char(*);
|
|
If debug Then
|
|
Put Skip List(txt);
|
|
End;
|
|
|
|
encode: Proc;
|
|
/*--------------------------------------------------------------------
|
|
* encode the string s -> sc
|
|
*-------------------------------------------------------------------*/
|
|
Dcl (i,j) Bin Fixed(15);
|
|
Do i=1 To length(s);
|
|
c=substr(s,i,1);
|
|
Do j=1 To t_n;
|
|
If c=t(j).char Then
|
|
Leave;
|
|
End;
|
|
sc=sc!!t(j).code;
|
|
End;
|
|
End;
|
|
|
|
decode: Proc;
|
|
/*--------------------------------------------------------------------
|
|
* decode the string sc -> sr
|
|
*-------------------------------------------------------------------*/
|
|
Dcl (i,j) Bin Fixed(15);
|
|
Do While(sc>'');
|
|
Do j=1 To t_n;
|
|
If substr(sc,1,length(t(j).code))=t(j).code Then
|
|
Leave;
|
|
End;
|
|
sr=sr!!t(j).char;
|
|
sc=substr(sc,length(t(j).code)+1);
|
|
End;
|
|
End;
|
|
|
|
End;
|