aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Time for an 2014 update…

Browse source
This commit is contained in:
Ingy döt Net 2014-01-17 05:32:22 +00:00
parent 372c577f83
commit 09687c4926
2520 changed files with 34227 additions and 7318 deletions
Download patch file Download diff file Expand all files Collapse all files

258
Task/Huffman-coding/PL-I/huffman-coding.pli Normal file
View file

@ -0,0 +1,258 @@
*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;

257
Task/Huffman-coding/REXX/huffman-coding.rexx Normal file
View file

@ -0,0 +1,257 @@
/* REXX ---------------------------------------------------------------
* 27.12.2013 Walter Pachl
* 29.12.2013 -"- changed for test of s=xrange('00'x,'ff'x)
* Stem m contains eventually the following node data
* m.i.0id Node id
* m.i.0c character
* m.i.0o number of occurrences
* m.i.0l left child
* m.i.0r right child
* m.i.0f father
* m.i.0d digit (0 or 1)
* m.i.0t 1=a terminal node 0=an intermediate or the top node
*--------------------------------------------------------------------*/
Parse Arg s
If s='' Then
s='this is an example for huffman encoding'
Say 'We encode this string:'
Say s
debug=0
o.=0
c.=0
codel.=0
code.=''
father.=0
cl='' /* list of characters */
do i=1 To length(s)
Call memorize substr(s,i,1)
End
If debug Then Do
Do i=1 To c.0
c=c.i
Say i c o.c
End
End
n.=0
Do i=1 To c.0
c=c.i
n.i.0c=c
n.i.0o=o.c
n.i.0id=i
Call dbg i n.i.0id n.i.0c n.i.0o
End
n=c.0 /* number of nodes */
m.=0
Do i=1 To n /* construct initial array */
Do j=1 To m.0 /* sorted by occurrences */
If m.j.0o>n.i.0o Then
Leave
End
Do k=m.0 To j By -1
k1=k+1
m.k1.0id=m.k.0id
m.k1.0c =m.k.0c
m.k1.0o =m.k.0o
m.k1.0t =m.k.0t
End
m.j.0id=i
m.j.0c =n.i.0c
m.j.0o =n.i.0o
m.j.0t =1
m.0=m.0+1
End
If debug Then
Call show
Do While pairs()>1 /* while there are at least 2 fatherless nodes */
Call mknode /* create and fill a new father node */
If debug Then
Call show
End
Call show
c.=0
Do i=1 To m.0 /* now we loop over all lines representing nodes */
If m.i.0t Then Do /* for each terminal node */
code=m.i.0d /* its digit is the last code digit */
node=m.i.0id /* 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.0d||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.0c '->' code /* character is encoded this way */
char=m.i.0c
code.char=code
z=codel.0+1
codel.z=code
codel.0=z
char.code=char
End
End
Call show_char2code /* show used characters and corresponding codes */
codes.=0 /* now we build the array of codes/characters */
Do j=1 To codel.0
z=codes.0+1
code=codel.j
codes.z=code
chars.z=char.code
codes.0=z
Call dbg codes.z '----->' chars.z
End
sc='' /* here we ecnode the string */
Do i=1 To length(s) /* loop over input */
c=substr(s,i,1) /* a character */
sc=sc||code.c /* append the corresponding code */
End
Say 'Length of encoded string:' length(sc)
Do i=1 To length(sc) by 70
Say substr(sc,i,70)
End
sr='' /* now decode the string */
Do si=1 To 999 While sc<>''
Do i=codes.0 To 1 By -1 /* loop over codes */
cl=length(codes.i) /* length of code */
If left(sc,cl)==codes.i Then Do /* found on top of string */
sr=sr||chars.i /* append character to result */
sc=substr(sc,cl+1) /* cut off the used code */
Leave /* this was one character */
End
End
End
Say 'Input ' s
Say 'result' sr
Exit
show:
/*---------------------------------------------------------------------
* show all lines representing node data
*--------------------------------------------------------------------*/
Say ' i pp id c f l r d'
Do i=1 To m.0
Say right(i,2) right(m.i.0o,3) right(m.i.0id,2),
right(m.i.0f,2) right(m.i.0l,2) right(m.i.0r,2) m.i.0d m.i.0t
End
Call dbg copies('-',21)
Return
pairs: Procedure Expose m.
/*---------------------------------------------------------------------
* return number of fatherless nodes
*--------------------------------------------------------------------*/
res=0
Do i=1 To m.0
If m.i.0f=0 Then
res=res+1
End
Return res
mknode:
/*---------------------------------------------------------------------
* construct and store a new intermediate or the top node
*--------------------------------------------------------------------*/
new.=0
ni=m.0+1 /* the next node id */
Do i=1 To m.0 /* loop over node lines */
If m.i.0f=0 Then Do /* a fatherless node */
z=m.i.0id /* its id */
If new.0l=0 Then Do /* new node has no left child */
new.0l=z /* make this the lect child */
new.0o=m.i.0o /* occurrences */
m.i.0f=ni /* store father info */
m.i.0d='0' /* digit 0 to be used */
father.z=ni /* remember z's father (redundant) */
End
Else Do /* New node has already left child */
new.0r=z /* make this the right child */
new.0o=new.0o+m.i.0o /* add in the occurrences */
m.i.0f=ni /* store father info */
m.i.0d=1 /* digit 1 to be used */
father.z=ni /* remember z's father (redundant) */
Leave
End
End
End
Do i=1 To m.0 /* Insert new node according to occurrences */
If m.i.0o>=new.0o Then Do
Do k=m.0 To i By -1
k1=k+1
m.k1.0id=m.k.0id
m.k1.0o =m.k.0o
m.k1.0c =m.k.0c
m.k1.0l =m.k.0l
m.k1.0r =m.k.0r
m.k1.0f =m.k.0f
m.k1.0d =m.k.0d
m.k1.0t =m.k.0t
End
Leave
End
End
m.i.0id=ni
m.i.0c ='*'
m.i.0o =new.0o
m.i.0l =new.0l
m.i.0r =new.0r
m.i.0t =0
father.ni=0
m.0=ni
Return
zeile:
/*---------------------------------------------------------------------
* find and return line number containing node-id
*--------------------------------------------------------------------*/
do fidz=1 To m.0
If m.fidz.0id=arg(1) Then
Return fidz
End
Call dbg arg(1) 'not found'
Pull .
dbg:
/*---------------------------------------------------------------------
* Show text if debug is enabled
*--------------------------------------------------------------------*/
If debug=1 Then
Say arg(1)
Return
memorize: Procedure Expose c. o.
/*---------------------------------------------------------------------
* store characters and corresponding occurrences
*--------------------------------------------------------------------*/
Parse Arg c
If o.c=0 Then Do
z=c.0+1
c.z=c
c.0=z
End
o.c=o.c+1
Return
show_char2code:
/*---------------------------------------------------------------------
* show used characters and corresponding codes
*--------------------------------------------------------------------*/
cl=xrange('00'x,'ff'x)
Say 'char --> code'
Do While cl<>''
Parse Var cl c +1 cl
If code.c<>'' Then
Say ' 'c '-->' code.c
End
Return