1 REM Ins{nd av Kristoffer Eriksson <5357> 1987-07-15 00.41.26 (DUMP) 20 ! +---------------------------------------------------------------+ 30 ! ! HUFFMANN - (De)Komprimering av filer medelst Huffmann-kodning.! 40 ! ! F|r Basic-II (ABC800-serien). ! 50 ! ! Av Kristoffer Eriksson "SKE", ABC-klubben <5357>. ! 60 ! ! F}r kopieras fritt endast f|r icke-kommersiella syften. ! 70 ! +---------------------------------------------------------------+ 80 ! 90 ! Ver--/-Datum--/-Sign-/-Kommentar---- 100 ! 1.00 / 870714 / SKE 110 ! 120 ! Skrivet i Basic som programmet {r, {r det alldeles f|r l}ngsamt f|r 130 ! praktiskt bruk... 140 ! 150 ! Tr{dnoder: 160 ! Freq(): Frekvens, Tree(,1): Gren1, Tree(,2): Gren2, Tree(,3): Pool-l{nk 170 ! L|ven placeras i de f|rsta 256 noderna med samma nodnr som teckenkoderna. 180 ! Codel anger antal p}b|rjade bytes, sista anv{nda bit. 190 ! 200 INTEGER : EXTEND 210 ! 220 Maxnode=255 230 DIM Tree(0:Maxnode*2,1:3),Freq(0:Maxnode*2),Sort(0:Maxnode) 240 DIM Codes$=Maxnode/16*Maxnode+Maxnode,Codep(0:Maxnode),Codel(0:Maxnode) 250 ! 260 ; "HUFFMANN-komprimering av filer." 270 ; 'Om inte annat anges antas Huffmann-filerna ha extensionen ".HFM".' 280 ; 290 ; "Komprimera eller Dekomprimera (K/D) ? "; 300 Dir=FNSvar("KD") 310 INPUT "Infil: "Infil$ 320 IF Infil$="" THEN 750 330 Infil$=FNCaps$(Infil$) 340 ! 350 WHILE Dir=2 360 ! Dekomprimera 370 Infil$=FNDefext$(Infil$,"HFM") 380 Z=FNOpenhuffile(Infil$) 390 IF Z=-1 THEN 310 400 IF Z=-2 THEN ; '"' Infil$ '" {r inte en Huffmann-fil.' 410 IF Z=-3 THEN ; 'Filen {r komprimerad p} ett s{tt denna programversion inte klarar av.' 420 IF Z THEN 740 430 ; "Storlek =" Bsize. "bytes =" INT(Bsize./252.) "sektorer." 440 Bfil$=FNPathname$(Infil$)+Bfil$ 450 INPUT "Utfil ("+Bfil$+"): "Utfil$ 460 IF Utfil$="" THEN Utfil$=Bfil$ 470 IF FNOpen(Utfil$,2,2) THEN ; "Dekomprimeringen stoppad." : GOTO 740 480 Z=FNHdecompress 490 CLOSE 500 END 510 WEND 520 ! 530 ! Komprimera 540 IF FNOpen(Infil$,1,0) THEN 310 550 Z=INSTR(1,Infil$,".") 560 Utfil$=LEFT$(Infil$,Z+(Z=0 AND LEN(Infil$)+1)-1)+".HFM" 570 INPUT "Utfil ("+Utfil$+"): "Hfil$ 580 IF Hfil$="" THEN Hfil$=Utfil$ ELSE Hfil$=FNDefext$(FNCaps$(Hfil$),"HFM") 590 ! 600 ; "Konstruerar kodningstr{d." 610 Z=FNPoolinit+FNTreeinit 620 Z=FNFreq 630 IF Z=3 THEN ; "Filen {r tom." : GOTO 740 640 IF Z=2 THEN Z=FNRemoveunused 650 Z=FNConstructtree 660 ! Z=FNShowtree 670 Z=FNCodeinit 680 ; "Komprimerar." 690 IF FNPrephuffile(Hfil$,FNBasename$(Infil$)) THEN 740 700 Z=FNHcompress 710 ; 720 ; "Originalfilen =" Bsize. "bytes." 730 ; "Krympt fil =" Hsize. "bytes =" INT(Hsize./Bsize.*1000)/10 "% (inkl administrativ info)." 740 CLOSE 750 END 760 ! 770 DEF FNPoolinit 780 FOR I=0 TO Maxnode-1 790 Tree(I,3)=I+1 800 NEXT I 810 Tree(Maxnode,3)=-1 820 Poolp=0 830 RETURN 0 840 FNEND 850 ! 860 DEF FNTreeinit 870 FOR I=0 TO 2*Maxnode 880 Tree(I,1)=-1 : Tree(I,2)=-1 890 NEXT I 900 Treep=-1 910 RETURN 0 920 FNEND 930 ! 940 DEF FNFreq LOCAL G$=1,Ant 950 ON ERROR GOTO 1010 960 Ant=32767 ! Med fler tecken riskerar man att |verskrida heltalsomr}det 970 WHILE Ant 980 GET #1 G$ : Freq(ASCII(G$))=Freq(ASCII(G$))+1 990 Ant=Ant-1 : WEND 1000 RETURN 1 1010 IF ERRCODE<>38 THEN ; "Felkod" ERRCODE "p} infilen." : STOP 1020 IF POSIT(1)=0 THEN RETURN 3 1030 IF Ant=32767 THEN RETURN 3 1040 RETURN 2 1050 FNEND 1060 ! 1070 DEF FNRemoveunused LOCAL P 1080 WHILE Poolp<>-1 : IF Freq(Poolp)=0 THEN Poolp=Tree(Poolp,3) : WEND 1090 IF Poolp=-1 THEN RETURN 0 1100 P=Poolp 1110 WHILE Tree(P,3)<>-1 1120 IF Freq(Tree(P,3))=0 THEN Tree(P,3)=Tree(Tree(P,3),3) ELSE P=Tree(P,3) 1130 WEND 1140 ! Z=FNShowpool 1150 RETURN 0 1160 FNEND 1170 ! 1180 DEF FNRemovesmallest LOCAL P,Pp,R,Pr,F 1190 IF Poolp=-1 THEN RETURN -1 1200 P=Poolp : Poolp=Tree(P,3) : Tree(P,3)=-1 : RETURN P 1210 ! --- 1220 F=Freq(Poolp) : R=Poolp : Pr=-1 1230 P=Tree(Poolp,3) : Pp=Poolp 1240 WHILE P<>-1 1250 IF Tree(P,0)-1 1390 IF F<=Freq(P) THEN Tree(New,3)=P : Tree(Pp,3)=New : RETURN 0 1400 Pp=P : P=Tree(P,3) : WEND 1410 Tree(New,3)=-1 : Tree(Pp,3)=New : RETURN 0 1420 ! (0 sorteras som 1, s} inte 0-noder bildar ett obalanserat tr{d.) 1430 FNEND 1440 ! 1450 DEF FNConstructtree 1460 IF Poolp=-1 THEN ; "Ingen pool" : STOP 1470 IF Tree(Poolp,3)=-1 THEN Treep=Poolp : RETURN 0 1480 Z=FNSortpool 1490 Treep=Maxnode+1 1500 WHILE 1 1510 Tree(Treep,1)=FNRemovesmallest 1520 Tree(Treep,2)=FNRemovesmallest 1530 Freq(Treep)=Freq(Tree(Treep,1))+Freq(Tree(Treep,2)) 1540 IF Poolp=-1 THEN RETURN 0 1550 Z=FNInsert(Treep) 1560 Treep=Treep+1 1570 WEND 1580 FNEND 1590 ! 1600 ! Sortera l{gsta frekvenser f|rst i listan 1610 DEF FNSortpool LOCAL S,Max 1620 Max=FNSortinit 1630 Z=FNQsort(0,Max) 1640 Poolp=Sort(0) : S=1 1650 WHILE S<=Max 1660 Tree(Sort(S-1),3)=Sort(S) 1670 S=S+1 : WEND 1680 Tree(Sort(Max),3)=-1 1690 ! Z=FNShowpool 1700 RETURN 0 1710 FNEND 1720 ! 1730 DEF FNSortinit LOCAL P,S 1740 P=Poolp : WHILE P<>-1 1750 Sort(S)=P : S=S+1 1760 P=Tree(P,3) : WEND 1770 RETURN S-1 1780 FNEND 1790 ! 1800 DEF FNQsort(L,R) LOCAL I,J 1810 IF R-L<9 THEN RETURN FNIsort(L,R) 1820 I=L : J=R 1830 X=Freq(Sort((L+R)/2)) 1840 WHILE I<=J 1850 WHILE Freq(Sort(I))=L 1980 IF Freq(X)0 2070 ; 2080 Col=Col/2 : Level=Level+1 2090 IF Col>0 THEN WEND 2100 ; 2110 RETURN 0 2120 FNEND 2130 ! 2140 DEF FNShowlevel(Start,Col,Wid,Level) 2150 IF Start=-1 THEN RETURN 0 2160 IF Level<>0 THEN RETURN FNShowlevel(Tree(Start,1),Col-Wid,Wid/2,Level-1)+FNShowlevel(Tree(Start,2),Col+Wid,Wid/2,Level-1) 2170 IF Col>0 THEN ; TAB(Col); 2180 IF Tree(Start,1)=-1 THEN ; NUM$(Start) ":"; 2190 ; NUM$(Freq(Start)); 2200 RETURN 1 2210 FNEND 2220 ! 2230 DEF FNShowpool LOCAL P 2240 P=Poolp 2250 WHILE P<>-1 2260 ; NUM$(P) " "; 2270 P=Tree(P,3) 2280 WEND 2290 ; 2300 RETURN 0 2310 FNEND 2320 ! 2330 DEF FNShowcode(Code$,Ln) LOCAL Byte,Bit 2340 Byte=0 : Bit=1 2350 WHILE SWAP%(Byte)+Bit<>Ln 2360 Bit=Bit/2 : IF Bit=0 THEN Bit=128 : Byte=Byte+1 2370 ; CHR$(48-((ASCII(RIGHT$(Code$,Byte)) AND Bit)<>0)); 2380 WEND 2390 RETURN 0 2400 FNEND 2410 ! 2420 DEF FNCodeinit 2430 DIM Code$=60 : Code$=STRING$(60,0) 2440 IF Treep=-1 THEN RETURN 0 2450 RETURN FNCodenode(Tree(Treep,1),1,128,0)+FNCodenode(Tree(Treep,2),1,128,1) 2460 FNEND 2470 ! 2480 DEF FNCodenode(Node,Byte,Bit,Vl) 2490 IF Vl THEN MID$(Code$,Byte,1)=CHR$(ASCII(RIGHT$(Code$,Byte)) OR Bit) 2500 ! IF Tree(Node,1)=-1 THEN ; USING " ###: " Node; : Z=FNShowcode(Code$,SWAP%(Byte)+Bit) 2510 IF Tree(Node,1)=-1 THEN Codep(Node)=LEN(Codes$)+1 : Codel(Node)=SWAP%(Byte)+Bit : Codes$=Codes$+LEFT$(Code$,Byte) : GOTO 2540 2520 Z=FNCodenode(Tree(Node,1),Byte-(Bit=1),Bit/2+(Bit=1 AND 128),0) 2530 Z=FNCodenode(Tree(Node,2),Byte-(Bit=1),Bit/2+(Bit=1 AND 128),1) 2540 IF Vl THEN MID$(Code$,Byte,1)=CHR$(ASCII(RIGHT$(Code$,Byte)) AND NOT Bit) 2550 RETURN 0 2560 FNEND 2570 ! 2580 DEF FNPutbit(Vl) 2590 IF Vl THEN Sbytebuf=Sbytebuf OR Sbit 2600 Sbit=Sbit/2 2610 IF Sbit=0 THEN PUT #2 CHR$(Sbytebuf) : Sbit=128 : Sbytebuf=0 2620 RETURN 0 2630 FNEND 2640 ! 2650 DEF FNPutbitstring(S$,Bytes,Bit) LOCAL Byte,Dfac,Mfac 2660 WHILE Sbit=128 2670 IF Bit=1 THEN PUT #2 S$ : RETURN 0 2680 PUT #2 LEFT$(S$,Bytes-1) : Sbytebuf=ASCII(RIGHT$(S$,Bytes)) AND 256-Bit : Sbit=Bit/2 : RETURN 0 2690 WEND 2700 Dfac=128/Sbit : Mfac=Sbit+Sbit 2710 Byte=1 : WHILE Byte128/Sbit THEN Sbit=Bit/(256/Sbit) : RETURN 0 2770 PUT #2 CHR$(Sbytebuf) 2780 Sbytebuf=ASCII(RIGHT$(S$,Byte))*Mfac 2790 Sbit=Bit*Sbit 2800 RETURN 0 2810 FNEND 2820 ! 2830 DEF FNGetbit LOCAL Vl,G$=1 2840 IF Sbit=0 THEN GET #1 G$ : Sbytebuf=ASCII(G$) : Sbit=128 2850 Vl=Sbytebuf AND Sbit : Sbit=Sbit/2 2860 RETURN Vl 2870 FNEND 2880 ! 2890 DEF FNGet8bits LOCAL G$=1,Vl 2900 GET #1 G$ 2910 IF Sbit=0 THEN RETURN ASCII(G$) 2920 Vl=128/Sbit*Sbytebuf AND 255 2930 Sbytebuf=ASCII(G$) 2940 RETURN Vl OR Sbytebuf/(Sbit+Sbit) 2950 FNEND 2960 ! 2970 DEF FNBasename$(Fil$) LOCAL P 2980 P=LEN(Fil$) : WHILE P 2990 IF INSTR(1,"/:",MID$(Fil$,P,1)) THEN RETURN RIGHT$(Fil$,P+1) 3000 P=P-1 : WEND 3010 RETURN Fil$ 3020 FNEND 3030 DEF FNPathname$(Fil$) LOCAL P 3040 P=LEN(Fil$) : WHILE P 3050 IF INSTR(1,"/:",MID$(Fil$,P,1)) THEN RETURN LEFT$(Fil$,P) 3060 P=P-1 : WEND 3070 RETURN "" 3080 FNEND 3090 DEF FNDefext$(Fil$,Ext$) 3100 IF INSTR(1,Fil$,".") THEN RETURN Fil$ ELSE RETURN Fil$+"."+Ext$ 3110 FNEND 3120 ! 3130 DEF FNPrephuffile(Hfil$,Bfil$) 3140 Z=FNOpen(Hfil$,2,2) : IF Z THEN RETURN Z 3150 PUT #2 CVT%$(9967) ! Magic 3160 PUT #2 CHR$(1,1,1,8) ! Huffmann, Version, tokenset, tokensize 3170 PUT #2 STRING$(7,0) ! Size, extra 3180 PUT #2 CHR$(LEN(Bfil$))+Bfil$ 3190 Sbit=128 : Sbytebuf=0 3200 Z=FNPuttree(Treep) 3210 RETURN 0 3220 FNEND 3230 ! 3240 DEF FNOpenhuffile(Hfil$) LOCAL G$=4 3250 Z=FNOpen(Hfil$,1,0) : IF Z THEN RETURN Z 3260 GET #1 G$ COUNT 2 : IF CVT$%(G$)<>9967 THEN RETURN -2 3270 GET #1 G$ COUNT 4 : IF G$<>CHR$(1,1,1,8) THEN RETURN -3 3280 GET #1 G$ COUNT 3 3290 Bsize.=CVT$%(LEFT$(G$,2)) : IF Bsize.<0. THEN Bsize.=65536.+Bsize. 3300 Bsize.=Bsize.+ASCII(RIGHT$(G$,3))*256. 3310 GET #1 G$ COUNT 4 3320 GET #1 G$ : GET #1 Bfil$ COUNT ASCII(G$) 3330 Poolp=Maxnode+1 : Treep=Poolp 3340 Sbit=0 3350 Z=FNGettree 3360 ! Z=FNShowtree 3370 RETURN 0 3380 FNEND 3390 ! 3400 DEF FNPuttree(Node) 3410 IF Tree(Node,1)=-1 THEN Z=FNPutbit(1)+FNPutbitstring(CHR$(Node),1,1) : RETURN 0 3420 RETURN FNPutbit(0)+FNPuttree(Tree(Node,1))+FNPuttree(Tree(Node,2)) 3430 FNEND 3440 ! 3450 DEF FNGettree LOCAL Node 3460 IF FNGetbit THEN G=FNGet8bits : Tree(G,1)=-1 : Tree(G,2)=-1 : RETURN G 3470 Node=Poolp : Poolp=Poolp+1 3480 Tree(Node,1)=FNGettree : Tree(Node,2)=FNGettree 3490 RETURN Node 3500 FNEND 3510 ! 3520 DEF FNHcompress LOCAL G$=1,G 3530 ON ERROR GOTO 3590 3540 POSIT #1,0 3550 WHILE 1 3560 GET #1 G$ : G=Codel(ASCII(G$)) 3570 Z=FNPutbitstring(MID$(Codes$,Codep(ASCII(G$)),SWAP%(G) AND 255),SWAP%(G) AND 255,G AND 255) 3580 WEND 3590 IF ERRCODE<>38 THEN ; "Felkod" ERRCODE "p} infil" : STOP 3600 IF Sbit<>128 THEN PUT #2 CHR$(Sbytebuf) 3610 Hsize.=POSIT(2) 3620 Bsize.=POSIT(1) 3630 POSIT #2,6. ! Size 3640 PUT #2 CVT%$(Bsize.-INT(Bsize./65536.)*65536.)+CHR$(INT(Bsize./65536.)) 3650 RETURN 0 3660 FNEND 3670 ! 3680 DEF FNHdecompress LOCAL P,Cnt. 3690 ON ERROR GOTO 3770 3700 Cnt.=Bsize. 3710 WHILE Cnt.>0 3720 P=Treep 3730 WHILE Tree(P,1)<>-1 : P=Tree(P,1-(FNGetbit<>0)) : WEND 3740 PUT #2 CHR$(P) 3750 Cnt.=Cnt.-1 : WEND 3760 RETURN 0 3770 IF ERRCODE=38 THEN ; "Huffmann-filen har tappat slutet." ELSE ; "Felkod" ERRCODE "p} huffmann-filen." 3780 RETURN -1 3790 FNEND 3800 ! 3810 DEF FNSvar(Alt$) LOCAL I$=160,P 3820 WHILE 1 3830 ON ERROR GOTO 3900 : INPUT LINE I$ 3840 P=LEN(I$)-2 : ; STRING$(P,8) SPACE$(P) STRING$(P,8); 3850 I$=FNCaps$(LEFT$(I$,1)) 3860 P=INSTR(1,Alt$,I$) 3870 IF P THEN ; MID$(Alt$,P,1) : RETURN P 3880 ; CHR$(7); 3890 WEND 3900 IF ERRCODE=53 THEN I$=CHR$(PEEK(65507)) : GOTO 3860 ELSE 3880 3910 FNEND 3920 ! 3930 DEF FNCaps$(S$) LOCAL T$=160,P,K 3940 T$=S$ 3950 P=LEN(S$) : WHILE P 3960 K=ASCII(RIGHT$(S$,P)) : IF K>=96 AND K<127 THEN MID$(T$,P,1)=CHR$(K-32) 3970 P=P-1 : WEND 3980 RETURN T$ 3990 FNEND 4000 ! 4010 ! Prep: 0=\ppna gammal fil, 2=Alltid prepare 4020 DEF FNOpen(F$,Filnr,Prep) LOCAL P 4030 IF Prep=2 THEN 4100 4040 ! __\ppna gammal fil__ 4050 ON ERROR GOTO 4070 : OPEN F$ AS FILE Filnr 4060 RETURN 0 4070 IF ERRCODE<>21 THEN 4220 4080 IF Prep=0 THEN ; CHR$(7) 'Hittar inte filen "' F$ '".' : RETURN ERRCODE 4090 ! 4100 ! __Skapa ny fil______ 4110 ON ERROR GOTO 4180 : OPEN F$ AS FILE Filnr 4120 ; CHR$(7) 'Filen "' F$ '" finns redan. Skriv |ver J/N ? '; 4130 ON FNSvar("NJ") GOTO 4140,4150 4140 RETURN -1 4150 ON ERROR GOTO 4220 : CLOSE Filnr 4160 GOTO 4190 4170 ! 4180 IF ERRCODE<>21 THEN 4220 4190 ON ERROR GOTO 4220 : PREPARE F$ AS FILE Filnr 4200 RETURN 0 4210 ! 4220 ; CHR$(7) 'Kan inte |ppna filen "' F$ '". Felkod' ERRCODE 4230 RETURN ERRCODE 4240 FNEND