mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 17:50:22 +00:00
330 lines
6.6 KiB
Modula-2
330 lines
6.6 KiB
Modula-2
IMPLEMENTATION MODULE HuffChan;
|
|
|
|
(*
|
|
This module shows how to redefine standard IO file functions. It provides
|
|
functions for reading and writing packed files opened in Raw mode.
|
|
*)
|
|
|
|
IMPORT IOChan, IOLink, ChanConsts, IOConsts, SYSTEM, Strings;
|
|
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
|
|
|
|
CONST
|
|
rbldFrq = 512; (* means: every 512 bytes rebuild table *)
|
|
|
|
TYPE
|
|
charTap = POINTER TO ARRAY [0..MAX(INTEGER)-1] OF CHAR;
|
|
smbTp = POINTER TO smbT;
|
|
|
|
smbT = RECORD (* Huffman's tree *)
|
|
ch : CHAR;
|
|
n : CARDINAL; (* frequncy of char ch *)
|
|
left,right,next : smbTp;
|
|
END;
|
|
|
|
tblT = RECORD (* bit sequence for code *)
|
|
vl : CARDINAL; (* bit sequence *)
|
|
cnt : INTEGER; (* it length *)
|
|
END;
|
|
|
|
lclDataT = RECORD (* channel's local data *)
|
|
tRoot : smbTp;
|
|
htbl : ARRAY [0..255] OF tblT; (* code -> bit sequence table *)
|
|
ftbl : ARRAY [0..255] OF CARDINAL; (* frequncey table *)
|
|
wBf,rb1,rb2 : CARDINAL;
|
|
wbc,rbc,smc : INTEGER;
|
|
chid : IOChan.ChanId;
|
|
END;
|
|
lclDataTp = POINTER TO lclDataT;
|
|
charp = POINTER TO CHAR;
|
|
|
|
VAR
|
|
did : IOLink.DeviceId;
|
|
ldt : lclDataTp;
|
|
|
|
|
|
PROCEDURE Shf(a:CARDINAL; b : INTEGER) : CARDINAL; (* shl a,b (or shr) *)
|
|
BEGIN
|
|
RETURN SYSTEM.CAST(CARDINAL,SYSTEM.SHIFT(SYSTEM.CAST(BITSET,a),b));
|
|
END Shf;
|
|
|
|
PROCEDURE wrDword(a:CARDINAL); (* write 4 bytes to file *)
|
|
BEGIN
|
|
IOChan.RawWrite(ldt^.chid,SYSTEM.ADR(a),4);
|
|
END wrDword;
|
|
|
|
PROCEDURE rdDword() : CARDINAL; (* read 4 bytes from file *)
|
|
VAR
|
|
a,z : CARDINAL;
|
|
BEGIN
|
|
a:=0;
|
|
IOChan.RawRead(ldt^.chid,SYSTEM.ADR(a),4,z);
|
|
RETURN a;
|
|
END rdDword;
|
|
|
|
PROCEDURE wrSmb(ch : CHAR); (* write bit sequence for code ch *)
|
|
VAR
|
|
v,h : CARDINAL;
|
|
b,c : INTEGER;
|
|
BEGIN
|
|
WITH ldt^ DO
|
|
v:=htbl[ORD(ch)].vl;
|
|
c:=htbl[ORD(ch)].cnt;
|
|
IF c+wbc<=32 THEN
|
|
wBf:=Shf(wBf,c);
|
|
wBf:=wBf+v;
|
|
wbc:=wbc+c;
|
|
IF wbc=32 THEN
|
|
wrDword(wBf);
|
|
wBf:=0; wbc:=0;
|
|
END;
|
|
RETURN;
|
|
END;
|
|
b:=c+wbc-32;
|
|
h:=Shf(v,-b);
|
|
wBf:=Shf(wBf,32-wbc)+h;
|
|
wrDword(wBf);
|
|
wBf:=v-Shf(h,b);
|
|
wbc:=b;
|
|
END;
|
|
END wrSmb;
|
|
|
|
PROCEDURE flush(); (* write data in buffer *)
|
|
BEGIN
|
|
WITH ldt^ DO
|
|
wBf:=Shf(wBf,32-wbc);
|
|
wrDword(wBf);
|
|
END;
|
|
END flush;
|
|
|
|
PROCEDURE getSym() : CHAR; (* find code for first bit sequence in buffer *)
|
|
VAR
|
|
t,i : CARDINAL;
|
|
b : INTEGER;
|
|
BEGIN
|
|
WITH ldt^ DO
|
|
IF rbc<=32 THEN
|
|
rb2:=rdDword();
|
|
t:=Shf(rb2,-rbc);
|
|
IF rbc=32 THEN t:=0; END;
|
|
rb1:=rb1+t;
|
|
rb2:=Shf(rb2,32-rbc);
|
|
IF rbc=0 THEN rb2:=0; END;
|
|
rbc:=rbc+32;
|
|
END;
|
|
FOR i:=0 TO 255 DO
|
|
t:=Shf(rb1,htbl[i].cnt-32);
|
|
IF t=htbl[i].vl THEN
|
|
rb1:=Shf(rb1,htbl[i].cnt);
|
|
b:=32-htbl[i].cnt;
|
|
t:=Shf(rb2,-b);
|
|
rb1:=rb1+t;
|
|
rb2:=Shf(rb2,32-b);
|
|
rbc:=rbc+b-32;
|
|
RETURN CHR(i);
|
|
END;
|
|
END;
|
|
END;
|
|
END getSym;
|
|
|
|
PROCEDURE Insert(s : smbTp); (* insert new character in Huffman's tree *)
|
|
VAR
|
|
cr : smbTp;
|
|
BEGIN
|
|
WITH ldt^ DO
|
|
IF tRoot=NIL THEN
|
|
cr:=tRoot;
|
|
tRoot:=s;
|
|
s^.next:=cr;
|
|
RETURN;
|
|
ELSIF tRoot^.n<=s^.n THEN
|
|
cr:=tRoot;
|
|
tRoot:=s;
|
|
s^.next:=cr;
|
|
RETURN;
|
|
END;
|
|
cr:=tRoot;
|
|
WHILE (cr^.next<>NIL) & (cr^.next^.n>s^.n) DO
|
|
cr:=cr^.next;
|
|
END;
|
|
s^.next:=cr^.next;
|
|
cr^.next:=s;
|
|
END;
|
|
END Insert;
|
|
|
|
PROCEDURE BuildTree(); (* build Huffman's tree *)
|
|
VAR
|
|
cr,ocr,ncr : smbTp;
|
|
BEGIN
|
|
WITH ldt^ DO
|
|
LOOP
|
|
ocr:=NIL; cr:=tRoot;
|
|
WHILE cr^.next^.next<>NIL DO
|
|
ocr:=cr; cr:=cr^.next;
|
|
END;
|
|
NEW(ncr);
|
|
ncr^.n:=cr^.n+cr^.next^.n;
|
|
ncr^.left:=cr;
|
|
ncr^.right:=cr^.next;
|
|
IF ocr<>NIL THEN
|
|
ocr^.next:=NIL;
|
|
Insert(ncr);
|
|
ELSE
|
|
tRoot:=NIL;
|
|
Insert(ncr);
|
|
EXIT;
|
|
END;
|
|
END;
|
|
END;
|
|
END BuildTree;
|
|
|
|
PROCEDURE BuildTable(cr: smbTp; vl,n: CARDINAL); (* build table: code -> bit sequence *)
|
|
BEGIN
|
|
WITH ldt^ DO
|
|
IF cr^.left=NIL THEN
|
|
htbl[ORD(cr^.ch)].vl:=vl;
|
|
htbl[ORD(cr^.ch)].cnt:=n;
|
|
DISPOSE(cr);
|
|
RETURN;
|
|
END;
|
|
vl:=vl*2;
|
|
BuildTable(cr^.left,vl,n+1);
|
|
BuildTable(cr^.right,vl+1,n+1);
|
|
DISPOSE(cr);
|
|
END;
|
|
END BuildTable;
|
|
|
|
PROCEDURE clcTab(); (* build code/bitseq. table from frequency table *)
|
|
VAR
|
|
i : CARDINAL;
|
|
s : smbTp;
|
|
BEGIN
|
|
WITH ldt^ DO
|
|
tRoot:=NIL;
|
|
FOR i:=0 TO 255 DO
|
|
NEW(s);
|
|
s^.ch:=CHR(i);
|
|
s^.n:=ftbl[i];
|
|
s^.left:=NIL; s^.right:=NIL; s^.next:=NIL;
|
|
Insert(s);
|
|
END;
|
|
BuildTree();
|
|
BuildTable(tRoot,0,0);
|
|
END;
|
|
END clcTab;
|
|
|
|
PROCEDURE iniHuf();
|
|
VAR
|
|
i : CARDINAL;
|
|
BEGIN
|
|
WITH ldt^ DO
|
|
FOR i:=0 TO 255 DO
|
|
ftbl[i]:=1;
|
|
END;
|
|
wBf:=0; wbc:=0; rb1:=0; rb2:=0; rbc:=0;
|
|
smc:=0;
|
|
clcTab();
|
|
END;
|
|
END iniHuf;
|
|
|
|
|
|
PROCEDURE RawWrite(x: IOLink.DeviceTablePtr; buf: SYSTEM.ADDRESS;
|
|
len: CARDINAL);
|
|
VAR
|
|
i : CARDINAL;
|
|
ch : CHAR;
|
|
cht : charTap;
|
|
BEGIN
|
|
IF len = 0 THEN RETURN; END;
|
|
ldt:=SYSTEM.CAST(lclDataTp,x^.cd);
|
|
cht:=SYSTEM.CAST(charTap,buf);
|
|
WITH ldt^ DO
|
|
FOR i:=0 TO len-1 DO
|
|
ch:=cht^[i];
|
|
wrSmb(ch);
|
|
IF ch = 377C THEN wrSmb(ch); END;
|
|
ftbl[ORD(ch)]:=ftbl[ORD(ch)]+1; smc:=smc+1;
|
|
IF smc=rbldFrq THEN
|
|
clcTab();
|
|
smc:=0;
|
|
END;
|
|
END;
|
|
END;
|
|
x^.result:=IOChan.ReadResult(ldt^.chid);
|
|
END RawWrite;
|
|
|
|
PROCEDURE RawRead(x: IOLink.DeviceTablePtr; buf: SYSTEM.ADDRESS;
|
|
blen: CARDINAL; VAR len: CARDINAL);
|
|
VAR
|
|
i : CARDINAL;
|
|
cht : charTap;
|
|
ch : CHAR;
|
|
BEGIN
|
|
ldt:=SYSTEM.CAST(lclDataTp,x^.cd);
|
|
cht:=SYSTEM.CAST(charTap,buf);
|
|
IF (blen=0) OR (x^.result<>IOConsts.allRight) THEN len:=0; RETURN; END;
|
|
WITH ldt^ DO
|
|
FOR i:=0 TO blen-1 DO
|
|
ch:=getSym();
|
|
IF ch = 377C THEN
|
|
ch:=getSym();
|
|
IF ch = 0C THEN
|
|
x^.result:=IOConsts.endOfInput;
|
|
len:=i; cht^[i]:=0C;
|
|
RETURN;
|
|
END;
|
|
END;
|
|
cht^[i]:=ch;
|
|
ftbl[ORD(ch)]:=ftbl[ORD(ch)]+1; smc:=smc+1;
|
|
IF smc=rbldFrq THEN
|
|
clcTab();
|
|
smc:=0;
|
|
END;
|
|
END;
|
|
len:=blen;
|
|
END;
|
|
END RawRead;
|
|
|
|
PROCEDURE CreateAlias(VAR cid: ChanId; io: ChanId; VAR res: OpenResults);
|
|
VAR
|
|
x : IOLink.DeviceTablePtr;
|
|
BEGIN
|
|
IOLink.MakeChan(did,cid);
|
|
IF cid = IOChan.InvalidChan() THEN
|
|
res:=ChanConsts.outOfChans
|
|
ELSE
|
|
NEW(ldt);
|
|
IF ldt=NIL THEN
|
|
IOLink.UnMakeChan(did,cid);
|
|
res:=ChanConsts.outOfChans;
|
|
RETURN;
|
|
END;
|
|
x:=IOLink.DeviceTablePtrValue(cid,did,IOChan.notAvailable,"");
|
|
ldt^.chid:=io;
|
|
x^.cd:=ldt;
|
|
x^.doRawWrite:=RawWrite;
|
|
x^.doRawRead:=RawRead;
|
|
res:=ChanConsts.opened;
|
|
iniHuf();
|
|
x^.result:=IOConsts.allRight;
|
|
END;
|
|
END CreateAlias;
|
|
|
|
PROCEDURE DeleteAlias(VAR cid: ChanId);
|
|
VAR
|
|
x : IOLink.DeviceTablePtr;
|
|
BEGIN
|
|
x:=IOLink.DeviceTablePtrValue(cid,did,IOChan.notAvailable,"");
|
|
ldt:=x^.cd;
|
|
IF ldt^.rbc=0 THEN
|
|
wrSmb(377C);
|
|
wrSmb(0C);
|
|
flush();
|
|
END;
|
|
DISPOSE(ldt);
|
|
IOLink.UnMakeChan(did,cid);
|
|
END DeleteAlias;
|
|
|
|
BEGIN
|
|
IOLink.AllocateDeviceId(did);
|
|
END HuffChan.
|