BASIC source code for Arithmetic compression 
Author Message
 BASIC source code for Arithmetic compression

The source code below is a conversion from the latest version in
fortran in _Numerical_Recipes_.  

It is in uncompilable TrueBASIC for portability and understandability
(not in assembly, as recently posted by others here, which runs only
on Microsoft-Intel).

Of course the code comes with not warranty, expressed or implied.

1010       PROGRAM xarcode
1030 ! driver for routines arcmak, arcode
1040 !       INTEGER MC,MD,MQ,NWK,MAXBUF,MAXLINE
1050 let mc = 512
1060 let md = mc-1
1070 let mq = 2*mc-1
1080 let nwk = 20
1090 let maxbuf = 200
1100 let maxline = 80
1110 !       INTEGER nch,ncum,nrad,minint,jdif,nc,ilob,iupb,ncumfq
1120 !       INTEGER i,j,k,lc,n,nt,nfreq(256)
1130 dim nfreq(256)
1140 declare public ncumfq(), iupb(), ilob(), nch, nrad, minint, jdif,
nc, ncum  ! In: arccom_common
1150       SAVE /arccom/
1160 !       CHARACTER*1 code(MAXBUF)
1170 dim code$(maxbuf)
1180 !       CHARACTER*80 lin
1190 !       CHARACTER*200 mess,ness
1200 open #7: name "TEXT.DAT"
1210 for j = 1 to 256
1220 let nfreq(j) = 0
1230 ! Fortran Statement number 11
1240 ! Continue
1250 next j
1260 ! Fortran Statement number 1
1270 ! Continue
1280 for j = 1 to maxline
1290 def lin$(j:
1300 ! Error at source line: 19 Expected comma; found: :
1310 ! *error*         lin(j:j)=char(32)
1320 ! Fortran Statement number 12
1330 ! Continue
1340 next j
1350 ! Use FORMAT: "(a)"
1360 when exception in
1370 read #7: lin$
1380 use
1390 if end #7 then goto 1610
1400 stop    ! Fatal error
1410 end when
1420 for n = maxline to 1 step -1
1430 if (
1440 ! Error at source line: 23 Expected comma; found: :
1450 ! *error*         if (lin(n:n).ne.char(32)) goto 2
1460 ! Fortran Statement number 13
1470 ! Continue
1480 next n
1490 ! Fortran Statement number 2
1500 for k = 1 to min(maxline,n)
1510 let j = ord(*****lin$(k:[1:1])
1520 ! Error at source line: 26 Stuff at end of line: -31
1530 ! *error*         j=ichar(lin(k:k))-31
1540 if (j>=1) then let nfreq(j) = nfreq(j)+1
1570 ! Fortran Statement number 14
1580 ! Continue
1590 next k
1600 goto 1260
1610 ! Fortran Statement number 3
1620 close #7
1630 let nch = 96
1640 let nrad = 256
1650 ! here is the initialization that constructs the code
1660 call arcmak (nfreq(),nch,nrad)
1670 ! now ready to prompt for lines to encode
1680 ! Fortran Statement number 4
1690 ! Use FORMAT: *
1700 write#*:  "ENTER A LINE:"
1710 for j = 1 to maxline
1720 def mess$(j:
1730 ! Error at source line: 38 Expected comma; found: :
1740 ! *error*         mess(j:j)=char(32)
1750 ! Fortran Statement number 15
1760 ! Continue
1770 next j
1780 ! Use FORMAT: "(a)"
1790 when exception in
1800 read #*: mess$
1810 use
1820 if end #* then goto 2500
1830 stop    ! Fatal error
1840 end when
1850 for n = maxline to 1 step -1
1860 if (
1870 ! Error at source line: 42 Expected comma; found: :
1880 ! *error*         if (mess(n:n).ne.char(32)) goto 5
1890 ! Fortran Statement number 16
1900 ! Continue
1910 next n
1920 ! shift from 256 character alphabet to 96 printing characters
1930 ! Fortran Statement number 5
1940 for j = 1 to n
1950 def mess$(j:
1960 ! Error at source line: 46 Expected comma; found: :
1970 ! *error*         mess(j:j)=char(ichar(mess(j:j))-32)
1980 ! Fortran Statement number 17
1990 ! Continue
2000 next j
2010 ! message initialization
2020 let lc = 1
2030 call arcode (0,code$(),maxbuf,lc,0)
2040 ! here we arithmetically encode mess(1:n)
2050 for j = 1 to n
2060 call arcode (ord(*****mess$(j:[1:1]))
2070 ! Error at source line: 53 Stuff at end of line:
code,MAXBUF,lc,1)
2080 ! *error*         call arcode(ichar(mess(j:j)),code,MAXBUF,lc,1)
2090 ! Fortran Statement number 18
2100 ! Continue
2110 next j
2120 call arcode (nch,code$(),maxbuf,lc,1)
2130 ! message termination
2140 ! Use FORMAT: *
2150 write#*:  "LENGTH OF LINE INPUT, CODED="
2160 write#*:  n
2170 write#*:  lc
2180 ! Error at source line: 57 Stuff at end of line: 1
2190 ! *error*       write(*,*) 'LENGTH OF LINE INPUT, CODED=',n,lc-1
2200 ! here we decode the message, hopefully to get the original back
2210 let lc = 1
2220 call arcode (0,code$(),maxbuf,lc,0)
2230 for j = 1 to maxbuf
2240 call arcode (i,code$(),maxbuf,lc,-1)
2250 if (i=nch) then goto 2360
2280 def ness$(j:
2290 ! Error at source line: 64 Expected comma; found: :
2300 ! *error*         ness(j:j)=char(i)
2310 ! Fortran Statement number 19
2320 ! Continue
2330 next j
2340 print "ARCODE - NEVER GET HERE"
2350 line input ans_$
2360 ! Fortran Statement number 6
2370 let nt = j-1
2380 ! Use FORMAT: *
2390 write#*:  "DECODED OUTPUT:"
2400 ! Use FORMAT: "(1x,80a1)"
2410 ! Error at source line: 69 Bad boolean constant ,
2420 ! *error*       write(*,'(1x,80a1)')
(char(ichar(ness(j:j))+32),j=1,nt)
2430 if (nt<>n) then
2440 ! Use FORMAT: *
2450 write#*:  "ERROR ! J DECODED .NE. N INPUT"
2460 write#*:  j
2470 write#*:  n
2480 end if
2490 goto 1680
2500 ! Fortran Statement number 999
2510 ! Use FORMAT: *
2520 write#*:  "NORMAL COMPLETION"
2530 print "stop   "
2540 stop
2550 end
2560 sub arcmak (nfreq(),nchh,nradd)
2580 !       INTEGER nchh,nradd,nfreq(nchh),MC,NWK,MAXINT
2590 dim nfreq(nchh)
2600 let mc = 512
2610 let nwk = 20
2620 let maxint = 2147483647
2630 !       INTEGER
j,jdif,minint,nc,nch,nrad,ncum,ncumfq(MC+2),ilob(NWK),iupb(NWK)
2640 dim ncumfq(mc+2)
2650 dim ilob(nwk)
2660 dim iupb(nwk)
2670 declare public ncumfq(), iupb(), ilob(), nch, nrad, minint, jdif,
nc, ncum  ! In: arccom_common
2680       SAVE /arccom/
2690 if (nchh>mc) then
2700 print "MC too small in arcmak"
2710 line input ans_$
2720 end if
2730 if (nradd>256) then
2740 print "nradd may not exceed 256 in arcmak"
2750 line input ans_$
2760 end if
2770 let minint = ip(maxint/nradd)
2780 let nch = nchh
2790 let nrad = nradd
2800 let ncumfq(1) = 0
2810 for j = 2 to nch+1
2820 let ncumfq(j) = ip(ncumfq(j-1)+max(nfreq(j-1),1))
2830 ! Fortran Statement number 11
2840 ! Continue
2850 next j
2860 let ncumfq(nch+2) = ncumfq(nch+1)+1
2870 let ncum = ncumfq(nch+2)
2880 exit sub
2890 end sub
2900 sub arcode (ich,code$(),lcode,lcd,*****)
2920 !       INTEGER ich,isign,lcd,lcode,MC,NWK
2930 !       CHARACTER*1 code(lcode)
2940 dim code$(lcode)
2950 let mc = 512
2960 let nwk = 20
2970 ! U    USES arcsum
2980 !       INTEGER
ihi,j,ja,jdif,jh,jl,k,m,minint,nc,nch,nrad,ilob(NWK),iupb(NWK),ncumfq(MC+2),ncum,JTRY
2990 dim ilob(nwk)
3000 dim iupb(nwk)
3010 dim ncumfq(mc+2)
3020 declare public ncumfq(), iupb(), ilob(), nch, nrad, minint, jdif,
nc, ncum  ! In: arccom_common
3030       SAVE /arccom/
3040 def jtry(j,k,m) = ip((k*j)/m)
3050 if (
3060 ! Error at source line: 105 Expected left paren
3070 ! *error*       if (isign.eq.0) then
3080 let jdif = nrad-1
3090 for j = nwk to 1 step -1
3100 let iupb(j) = nrad-1
3110 let ilob(j) = 0
3120 let nc = j
3130 if (jdif>minint) then exit sub
3160 let jdif = (jdif+1)*nrad-1
3170 ! Fortran Statement number 11
3180 ! Continue
3190 next j
3200 print "NWK too small in arcode"
3210 line input ans_$
3220 else
3230 if (
3240 ! Error at source line: 116 Expected left paren
3250 ! *error*         if (isign.gt.0) then
3260 if (ich>nch or ich<0) then
3270 print "bad ich in arcode"
3280 line input ans_$
3290 end if
3300 else
3310 let ja = ord(code$(lcd)[1:1])-ilob(nc)
3320 for j = nc+1 to nwk
3330 let ja = ja*nrad+(ord(code$(j+lcd-nc)[1:1])-ilob(j))
3340 ! Fortran Statement number 12
3350 ! Continue
3360 next j
3370 let ich = 0
3380 let ihi = nch+1
3390 ! Fortran Statement number 1
3400 if (ihi-ich>1) then
3410 let m = ip((ich+ihi)/2)
3420 if (ja>=jtry(jdif,ncumfq(m+1),ncum)) then
3430 let ich = m
3440 else
3450 let ihi = m
3460 end if
3470 goto 3390
3480 end if
3490 if (ich=nch) then exit sub
3520 end if
3530 let jh = jtry(jdif,ncumfq(ich+2),ncum)
3540 let jl = jtry(jdif,ncumfq(ich+1),ncum)
3550 let jdif = jh-jl
3560 call arcsum (ilob(),iupb(),jh,nwk,nrad,nc)
3570 call arcsum (ilob(),ilob(),jl,nwk,nrad,nc)
3580 for j = nc to nwk
3590 if (ich<>nch and iupb(j)<>ilob(j)) then goto 3740
3620 if (lcd>lcode) then
3630 print "lcode too small in arcode"
3640 line input ans_$
3650 end if
3660 if (
3670 ! Error at source line: 144 Expected left paren
3680 ! *error*           if(isign.gt.0) code(lcd)=char(ilob(j))
3690 let lcd = lcd+1
3700 ! Fortran Statement number 13
3710 ! Continue
3720 next j
3730 exit sub
3740 ! Fortran Statement number 2
3750 let nc = j
3760 let j = 0
3770 ! Fortran Statement number 3
3780 if (jdif<minint) then
3790 let j = j+1
3800 let jdif = jdif*nrad
3810 goto 3770
3820 end if
3830 if (nc-j<1) then
3840 print "NWK too small in arcode"
3850 line input ans_$
3860 end if
3870 if (j<>0) then
3880 for k = nc to nwk
3890 let iupb(k-j) = iupb(k)
3900 let ilob(k-j) = ilob(k)
3910 ! Fortran Statement number 14
3920 ! Continue
3930 next k
3940 end if
3950 let nc = nc-j
3960 for k = nwk-j+1 to nwk
3970 let iupb(k) = 0
3980 let ilob(k) = 0
3990 ! Fortran Statement number 15
4000 ! Continue
4010 next k
4020 end if
4030 exit sub
4040 end sub
4050 sub arcsum (iin,iout,ja,nwk,nrad,nc)
4070 !       INTEGER ja,nc,nrad,nwk,iin(*),iout(*)
4080 ! Error at source line: 171 Do not recognize '*' in numeric
expression.
4090 ! *error*       INTEGER ja,nc,nrad,nwk,iin(*),iout(*)
4100 !       INTEGER j,jtmp,karry
4110 let karry = 0
4120 for j = nwk to nc+1 step -1
4130 let jtmp = ja
4140 let ja = ip(ja/nrad)
4150 def iout(j) = iin(j)+(jtmp-ja*nrad)+karry
4160 if (iout(j)>=nrad) then
4170 def iout(j) = iout(j)-nrad
4180 let karry = 1
4190 else
4200 let karry = 0
4210 end if
4220 ! Fortran Statement number 11
4230 ! Continue
4240 next j
4250 def iout(nc) = iin(nc)+ja+karry
4260 exit sub
4270 end sub
4280 module arccom_common
4290 public ncumfq(mc+2), iupb(nwk), ilob(nwk), nch, nrad, minint,
jdif, nc, ncum
4300 end module

~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

CEC Services, 2080 Kipling St, Lakewood, CO  80215-1502   USA
Voice: 303.231.9437;  Facsimile: .231.9438
~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~



Mon, 21 Sep 1998 03:00:00 GMT  
 BASIC source code for Arithmetic compression


           "The Right Reverend Colin James III" writes:

Quote:
> The source code below is a conversion from the latest version in
> FORTRAN in _Numerical_Recipes_.  

> It is in uncompilable TrueBASIC for portability and understandability
> (not in assembly, as recently posted by others here, which runs only
> on Microsoft-Intel).

> Of course the code comes with not warranty, expressed or implied.

> 1010       PROGRAM xarcode

[Snip]

Quote:
> 4300 end module

You should have entered this into my 'obscure' BASIC competition...

--
Cheers,

Ben

------------------====### legal notice ###====-----------------------
Microsoft Network is prohibited from redistributing this work in any
form,in whole or in part.  License to distribute this post is available to
Microsoft for $499.  Posting without permission constitutes an agreement to
these terms.



Mon, 21 Sep 1998 03:00:00 GMT  
 
 [ 2 post ] 

 Relevant Pages 

1. BASIC source code for Huffman compression

2. Visual Basic source-code to C++ source-code

3. Visual Basic source-code to C++ source-code

4. Visual Basic source-code to C++ source-code

5. LZW compression in vb (source code)

6. Looking for short, simple VB5 compression source code....

7. Free Source Code for compression tool control.

8. FREE Source Code to compression tool control (written in VB5)

9. FREE IN-MEMORY COMPRESSION OCX /W SOURCE CODE

10. any sample code of Arithmetic Coding in VB?

11. BASIC CGI scripts/ source code for basic interpreter

12. Quick Basic/Visual Basic source code

 

 
Powered by phpBB® Forum Software