OPTION BASE 0
OPTION ARITHMETIC decimal_HIGH
PRINT
PRINT "＜ハフマン圧縮法に似た頻回文字圧縮法＞"
PRINT
PRINT "Q W A D G Q D Q D E G D W Q A Q D Q S A Q W"
PRINT
PRINT "２進数化： A=1, B=10, C=11, D=100, ・・・・・"
PRINT
LET TX1$="QWADGQDQDEGDWQAQDQSAQW"
LET N=LEN(TX1$)   ! 文字数を得る
DIM Q$(N),R$(N+1),W(N),F(N+1),E(N),T(N),TT(N),H(N),HH(100),G(2,N),L(2,N),P(N),JJ(N)
MAT F=ZER
MAT H=ZER
MAT L=ZER
LET Z=0
FOR i=1 TO N
   LET Q$(i)=TX1$(i:i)   ! 一文字ずつ得る
   LET W(i)=ORD(Q$(i))   ! キャラクターコード化
   LET F(i)=totwo(W(i)-64)  ! ２進数化
   CALL keta(W(i)-64,ZZ)
   LET Z=Z+ZZ
   PRINT F(i);
NEXT i
PRINT
PRINT
PRINT "上記の数列は空白(１空白＝２文字）も含めて";Z+2*N-2;"文字です。"
FOR i=1 TO N
   LET E(i)=F(i)
NEXT i
PRINT
PRINT "並べ替え："
CALL sort(F,N)
FOR i=1 TO N
   PRINT F(i);
NEXT i
PRINT
PRINT
LET C=1
LET a=0
FOR i=2 TO N+1
   IF F(i)=F(i-1) THEN
      LET C=C+1
   ELSE
      LET H(i-C)=C
      PRINT USING "########":F(i-C);
      PRINT "： ";H(i-C);"個"
      LET HH(i-C)=H(i-C)*10+a
      LET G(1,a+1)=HH(i-C)
      LET G(2,a+1)=F(i-C)
      LET a=a+1
      LET C=1
   END IF
NEXT i
PRINT
PRINT
CALL tros(G,N)
LET Y=0
LET M=1
DO UNTIL G(1,M)=0
   LET L(1,M)=G(2,M)
   LET Y=Y+10^M
   LET L(2,M)=Y
   LET M=M+1
LOOP
FOR i=1 TO M-1
   PRINT USING "########":L(1,i);
   PRINT "  ⇒  ";
   PRINT USING "########":L(2,i)
NEXT i
PRINT
PRINT
LET D=0
LET r=1
FOR i=1 TO N
   FOR j=1 TO M-1
      IF E(i)=L(1,j) THEN
         LET T(r)=L(2,j)
         CALL ket(T(r),V)
         LET r=r+1
         LET D=D+V
      END IF
   NEXT j
NEXT i
FOR i=1 TO N
   PRINT T(i);
NEXT i
PRINT
PRINT
LET DD=D
LET X=0
FOR i=1 TO N
   CALL ket(T(i),V)
   LET D=D-V
   LET X=X+T(i)*10^D
NEXT i
PRINT
PRINT X
PRINT
PRINT "上記の数は";DD;"桁です。 ここからは、逆に解凍していきます。"
PRINT
PRINT
DIM QQ$(DD)
LET GG$=STR$(x)   ! 数字を文字化
FOR i=1 TO DD
   LET QQ$(i)=GG$(i:i)   ! 一文字ずつ得る
NEXT i
LET b=0
LET k=O
FOR i=1 TO DD
   IF QQ$(i)="0" THEN
      LET P(b+1)=suk(i-k-1)
      LET k=i
      LET b=b+1
   END IF
NEXT i
FOR i=1 TO N
   PRINT P(i);
NEXT i
PRINT
PRINT
LET r=1
FOR i=1 TO N
   FOR j=1 TO M-1
      IF P(i)=L(2,j) THEN
         LET TT(r)=L(1,j)
         LET r=r+1
      END IF
   NEXT j
NEXT i
FOR i=1 TO N
   PRINT TT(i);
NEXT i
PRINT
PRINT
FOR i=1 TO N
   LET JJ(i)=twoto(TT(i))+64
NEXT i
FOR i=1 TO N
   PRINT CHR$(JJ(i));" ";   ! キャラクターコードを文字化
NEXT i
PRINT
PRINT
END


EXTERNAL FUNCTION totwo(x)
OPTION ARITHMETIC decimal_HIGH
LET C=O
LET D=0
DO UNTIL x=0
   LET r=MOD(x,2)
   LET D=D+r*10^C
   LET x=(x-r)/2
   LET C=C+1
LOOP
LET totwo=D
END FUNCTION

EXTERNAL FUNCTION twoto(x)
OPTION ARITHMETIC decimal_HIGH
LET XT$=STR$(x)   ! 数字を文字化
LET N=LEN(XT$)    ! 文字数を得る
DIM QQ$(N),RR(N)
FOR i=1 TO N
   LET QQ$(i)=XT$(i:i)    ! 一文字ずつ得る
   LET RR(i)=VAL(QQ$(i))  ! 文字を数字化
NEXT i
LET C=O
LET k=1
DO UNTIL k=N+1
   LET C=C+RR(k)*2^(N-k)
   LET k=k+1
LOOP
LET twoto=C
END FUNCTION

EXTERNAL FUNCTION suk(x)
OPTION ARITHMETIC decimal_HIGH
LET xx=x
LET C=O
DO UNTIL xx=0
   LET C=C+10^xx
   LET xx=xx-1
LOOP
LET suk=C
END FUNCTION

EXTERNAL SUB keta(x,Q)
OPTION ARITHMETIC decimal_HIGH
IF x=0 THEN
   LET Q=1
ELSE
   LET Q=INT(LOG10(x)/LOG10(2))+1
END IF
END SUB

EXTERNAL SUB ket(x,Q)
OPTION ARITHMETIC decimal_HIGH
LET xx=x
LET Q=1
DO UNTIL xx<10
   LET xx=xx/10
   LET Q=Q+1
LOOP
END SUB

EXTERNAL SUB sort(a(),m)
OPTION ARITHMETIC decimal_HIGH
FOR i=1 TO m-1
   FOR j=i+1 TO m
      IF a(i)>a(j) THEN
         LET t=a(j) 
         LET a(j)=a(i)
         LET a(i)=t
      END IF
   NEXT j
NEXT i
END SUB

EXTERNAL SUB tros(a(,),m)
OPTION ARITHMETIC decimal_HIGH
FOR i=1 TO m-1
   FOR j=i+1 TO m
      IF a(1,i)<a(1,j) THEN
         LET t=a(1,j) 
         LET a(1,j)=a(1,i)
         LET a(1,i)=t
         LET s=a(2,j)
         LET a(2,j)=a(2,i)
         LET a(2,i)=s
      END IF
   NEXT j
NEXT i
END SUB