Code: Select all
#lang "fblite"
option gosub
option explicit
dim shared as ushort rstint,s
dim shared as ubyte a,r,g,b,cnum,sambits,bbits,bcom,dbuf,ybh,ybv
dim shared as integer x,y,z,ff1,h,v,l,xx,yy,zz,bh,bv,m,i0,i1,i2,c0,c1,c2
dim shared as integer bbytes,bho,bvo,blksdone
dim shared as single z1,z2,z3,pi
dim shared cr(1 to 4) as ubyte
dim shared cq(1 to 4) as ubyte
dim shared ced(1 to 8) as ubyte
dim shared olddc(1 to 4) as short
dim shared qtable(0 to 3,0 to 63) as ubyte
dim shared htl(0 to 7,0 to 15) as ubyte
dim shared htable(0 to 7,0 to 2047) as ubyte
dim shared hcode(0 to 7,0 to 2047) as ushort
dim shared blk(0 to 79) as short
dim shared blk2(0 to 63) as short
dim shared blk3(0 to 63) as single
dim shared blk4(1 to 6,0 to 63) as ubyte
dim shared filebuf(0 to 4095) as ubyte
dim shared zigzag(0 to 63) as ubyte => _
{ 0,1,8,16,9,2,3,10,17,24,32,25,18,11,4,5, _
12,19,26,33,40,48,41,34,27,20,13,6,7,14,21,28, _
35,42,49,56,57,50,43,36,29,22,15,23,30,37,44,51, _
58,59,52,45,38,31,39,46,53,60,61,54,47,55,62,63 }
dim shared itable(0 to 4095) as single
pi=3.1415926
' build a lookup table to speed up iDCT later
zz=0
for y=0 to 7
for x=0 to 7
z1=1
if x=0 then z1=z1*.707107
if y=0 then z1=z1*.707107
for yy=0 to 7
for xx=0 to 7
itable(zz)=z1*cos(pi*x*((xx*2)+1)/16)*cos(pi*y*((yy*2)+1)/16)
zz+=1
next xx
next yy
next x
next y
? command$
ff1=freefile
open command$ for binary as #ff1
startparse:
get #ff1,,s
if s=&HD8FF then goto startparse 'start marker
if s=&HD9FF then sleep:end 'end of image
if s=&HC2FF then ? "progressive mode not supported":sleep:end
if s=&HDDFF then 'restart interval
get #ff1,,a:x=a:get #ff1,,a:x=(x shl 8)+a ' header length
get #ff1,,a:rstint=a:get #ff1,,a:rstint=(rstint shl 8)+a
goto startparse
end if
if s=&HDBFF then 'quantization table
get #ff1,,a:x=a:get #ff1,,a:x=(x shl 8)+a ' header length
a209:
get #ff1,,a:b=(a and 15) ' table number
' (bit 4 indicates 16-bit table, but only 8-bit is supported)
for y=0 to 63
get #ff1,,qtable(b,y) ' quantization values in zigzag order
next y
if x>67 then x=x-65:goto a209
goto startparse
end if
if s=&HC4FF then 'huffman table
get #ff1,,a:x=a:get #ff1,,a:x=(x shl 8)+a ' header length
a208:
get #ff1,,a:b=(a and 15) ' table number
if (a and 16) then b+=4
for y=0 to 15:get #ff1,,htl(b,y):next y
zz=0
for y=0 to 15
for z=0 to htl(b,y)-1
get #ff1,,htable(b,zz):zz+=1
next z
next y
' build huffman code table
xx=0:zz=0
for y=0 to 15
for z=0 to htl(b,y)-1
hcode(b,zz)=xx:zz+=1:xx+=1
next z
xx+=xx
next y
if x>zz+19 then x=x-zz-17:goto a208
goto startparse
end if
if s=&HC0FF then 'baseline DCT JPEG header
get #ff1,,a:x=a:get #ff1,,a:x=(x shl 8)+a ' header length
get #ff1,,sambits ' bits per sample
get #ff1,,a:v=a:get #ff1,,a:v=(v shl 8)+a ' number of lines
get #ff1,,a:h=a:get #ff1,,a:h=(h shl 8)+a ' number of pixels/line
get #ff1,,cnum ' number of components
for y=0 to cnum-1
get #ff1,,a ' component identifier
get #ff1,,cr(a) ' component resolution (h is the high nibble)
get #ff1,,cq(a) ' quantization table selection
next y
goto startparse
end if
if s=&HDAFF then 'start of scan
get #ff1,,a:x=a:get #ff1,,a:x=(x shl 8)+a ' header length
get #ff1,,a ' number of components in scan
for y=0 to a-1
get #ff1,,b ' component identifier
get #ff1,,g
ced(b)=(g shr 4) ' DC entropy coding huffman table
ced(b+4)=(g and 15)+4 ' AC entropy coding huffman table
next y
get #ff1,,a ' start of spectral selection (?)
get #ff1,,a ' end of spectral selection (?)
get #ff1,,a ' approximation bit positions (?)
' start decompressing and display data
screen 19,32
bbits=0:bbytes=4096:blksdone=0
ybh=(cr(1) shr 4):ybv=(cr(1) and 15)
for bv=0 to v-1 step ybv*8
for bh=0 to h-1 step ybh*8
for dbuf=1 to ybh*ybv
bcom=1
gosub decodeblk
next dbuf
if cnum=1 then
for y=0 to 7
for x=0 to 7
pset (x+bh,y+bv),blk4(1,x+(y shl 3))*&H10101
next x
next y
goto a207
end if
bcom=2:dbuf=5
gosub decodeblk
bcom=3:dbuf=6
gosub decodeblk
dbuf=0
for yy=1 to ybv
for xx=1 to ybh
dbuf+=1
bvo=((yy-1) shl 3)+bv
bho=((xx-1) shl 3)+bh
for y=0 to 7
for x=0 to 7
i0=blk4(dbuf,x+(y shl 3))
if ybh=1 then
z=x
else
z=(x shr 1)+((xx-1) shl 2)
end if
if ybv=1 then
z+=(y shl 3)
else
z+=(((y shr 1)+((yy-1) shl 2)) shl 3)
end if
i1=blk4(5,z)-128
i2=blk4(6,z)-128
' convert to RGB
c0=1.402*i2+i0
c1=i0-.34414*i1-.71414*i2
c2=1.772*i1+i0
if c0<0 then c0=0
if c0>255 then c0=255
if c1<0 then c1=0
if c1>255 then c1=255
if c2<0 then c2=0
if c2>255 then c2=255
pset (x+bho,y+bvo),(c0 shl 16)+(c1 shl 8)+c2
next x
next y
next xx
next yy
a207:
if inkey$="q" then end
blksdone+=1
if blksdone=rstint then
blksdone=0:bbits=0:bbytes+=2
for y=1 to 4:olddc(y)=0:next y
end if
next bh
next bv
sleep
end
end if
if (s and 255)<>255 then ? "error: unexpected data":sleep:end
skipchunk:
get #ff1,,a:x=a:get #ff1,,a:x=(x shl 8)+a
for y=3 to x:get #ff1,,a:next y
goto startparse
decodeblk:
' get DC coefficient
gosub readcode
blk(0)=olddc(bcom)+m:olddc(bcom)=blk(0)
' get AC coefficients
bcom+=4:z=1
a206:
gosub readcode
if x=0 then for y=z to 63:blk(y)=0:next y:goto a205
for y=1 to (x shr 4):blk(z)=0:z+=1:next y
blk(z)=m:z+=1
if z<64 then goto a206
a205:
bcom=bcom-4
' dequantize and un-zigzag
for x=0 to 63
blk2(zigzag(x))=blk(x)*qtable(cq(bcom),x)
next x
clear blk3(0),0,256
' iDCT
for y=0 to 63
z1=blk2(y)
if z1<>0 then
yy=(y shl 6)
for xx=0 to 63
blk3(xx)+=z1*itable(yy+xx)
next xx
end if
next y
' normalize
for x=0 to 63
y=blk3(x)+512
if y>1020 then y=1020
if y<0 then y=0
blk4(dbuf,x)=(y shr 2)
next x
return
readbit:
if bbits=0 then
if bbytes>4095 then get #ff1,,filebuf():bbytes=bbytes-4096
a=filebuf(bbytes):bbits=8:bbytes+=1
if a=255 then bbytes+=1
end if
xx+=xx+(a shr 7)
a+=a:bbits=bbits-1
return
readcode:
xx=0:yy=0:zz=0
a200:
gosub readbit
y=htl(ced(bcom),yy)
for x=1 to y
if hcode(ced(bcom),zz)=xx then goto a201
zz+=1
next x
yy+=1:if yy=16 then ? "decode error":sleep:end
goto a200
a201:
x=htable(ced(bcom),zz)
m=0
if (x and 15)>0 then
gosub readbit
m=-2:if (xx and 1) then m=1
xx=0:for y=2 to (x and 15):gosub readbit:m+=m:next y
if m<0 then m+=1
m+=xx
end if
return