Release notes:
Figure it out for yourself! I shall post a more refined version later.
WARNING: Writes to TEST.JPG.
DECLARE FUNCTION JPEG.Y% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
DECLARE FUNCTION JPEG.Cb% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
DECLARE FUNCTION JPEG.Cr% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
DECLARE FUNCTION JPEG.ACHuff$ (RLE AS INTEGER, AC AS INTEGER, Huff() AS STRING, A AS INTEGER)
DECLARE SUB JPEG.Begin (FileNo AS INTEGER, W AS INTEGER, H AS INTEGER, Sampling() AS INTEGER, State AS ANY, QT() AS INTEGER, Huff() AS STRING)
DECLARE FUNCTION JPEG.Block.Huffman$ (B() AS INTEGER, LastDC AS INTEGER, Huff() AS STRING, A AS INTEGER)
DECLARE SUB JPEG.Block.Output (FileNo AS INTEGER, B() AS INTEGER, State AS ANY, QT() AS INTEGER, Huff() AS STRING)
DECLARE SUB JPEG.Block.Transform (B() AS INTEGER, O() AS INTEGER, QT() AS INTEGER, A AS INTEGER)
DECLARE FUNCTION JPEG.Category% (X AS INTEGER)
DECLARE FUNCTION JPEG.DCHuff$ (DC AS INTEGER, Huff() AS STRING, A AS INTEGER)
DECLARE SUB JPEG.GenerateHuffmanTable (HT() AS STRING, A AS INTEGER, B AS INTEGER)
DECLARE SUB JPEG.StandardQT (Quality AS SINGLE, QT() AS INTEGER)
DECLARE SUB JPEG.Finish (FileNo AS INTEGER, State AS ANY)
DECLARE SUB PutChar (FileNo AS INTEGER, Char AS INTEGER)
DECLARE SUB JPEG.PutWord (FileNo AS INTEGER, Word AS INTEGER)
DEFINT A-Z
DIM SHARED Pi AS DOUBLE
Pi = 3.14159265358979#
TYPE JPEGState
YCount AS INTEGER
CbCount AS INTEGER
CrCount AS INTEGER
YDC AS INTEGER
CbDC AS INTEGER
CrDC AS INTEGER
Position AS INTEGER
Leftovers AS STRING * 8
END TYPE
DIM Huff(0 TO 255, 0 TO 1, 0 TO 1) AS STRING
DIM QT(0 TO 7, 0 TO 7, 0 TO 1) AS INTEGER
DIM State AS JPEGState
DIM Sampling(0 TO 2, 0 TO 1) AS INTEGER
Sampling(0, 0) = 2 'Sampling factor (x then y) for luminance
Sampling(0, 1) = 2
Sampling(1, 0) = 1 'Sampling factor for blue chrominance
Sampling(1, 1) = 1
Sampling(2, 0) = 1 'Sampling factor for red chrominance
Sampling(2, 1) = 1
'Delete file then open for binary
OPEN "Test.JPG" FOR OUTPUT AS #1
CLOSE
OPEN "Test.JPG" FOR BINARY AS #1
FOR BlockY = 0 TO 1
FOR BlockX = 0 TO 1
FOR Y = 0 TO 7: FOR X = 0 TO 7
B(X, Y) = JPEG.Y(0, 214 / SQR(SQR((SuperBlockX * 16 + BlockX * 8 + X - 63.5) ^ 2 + (SuperBlockY * 16 + BlockY * 8 + Y - 63.5) ^ 2)), 0)
NEXT X, Y
JPEG.Block.Output 1, B(), State, QT(), Huff()
NEXT BlockX, BlockY
FOR Y = 0 TO 7: FOR X = 0 TO 7
B(X, Y) = JPEG.Cb(0, 214 / SQR(SQR((SuperBlockX * 16 + 2 * X - 63) ^ 2 + (SuperBlockY * 16 + 2 * Y - 63) ^ 2)), 0)
NEXT X, Y
JPEG.Block.Output 1, B(), State, QT(), Huff()
FOR Y = 0 TO 7: FOR X = 0 TO 7
B(X, Y) = JPEG.Cr(0, 214 / SQR(SQR((SuperBlockX * 16 + 2 * X - 63) ^ 2 + (SuperBlockY * 16 + 2 * Y - 63) ^ 2)), 0)
NEXT X, Y
JPEG.Block.Output 1, B(), State, QT(), Huff()
NEXT SuperBlockX, SuperBlockY
JPEG.Finish 1, State
CLOSE
END
Huff0:
DATA 0
DATA 1, 0
DATA 5, 1, 2, 3, 4, 5
DATA 1, 6
DATA 1, 7
DATA 1, 8
DATA 1, 9
DATA 1, 10
DATA 1, 11
DATA 0, 0, 0, 0, 0, 0, 0
Huff1:
DATA 0
DATA 3, 0, 1, 2
DATA 1, 3
DATA 1, 4
DATA 1, 5
DATA 1, 6
DATA 1, 7
DATA 1, 8
DATA 1, 9
DATA 1, 10
DATA 1, 11
DATA 0, 0, 0, 0, 0
Huff2:
DATA 0
DATA 2, 1, 2
DATA 1, 3
DATA 3, 0, 4, &H11
DATA 3, 5, &H12, &H21
DATA 2, &H31, &H41
DATA 4, 6, &H13, &H51, &H61
DATA 3, 7, &H22, &H71
DATA 5, &H14, &H32, &H81, &H91, &HA1
DATA 5, &H08, &H23, &H42, &HB1, &HC1
DATA 4, &H15, &H52, &HD1, &HF0
DATA 4, &H24, &H33, &H62, &H72
DATA 0
DATA 0
DATA 1, &H82
DATA 125, &H09, &H0A, &H16, &H17, &H18, &H19, &H1A, &H25, &H26, &H27, &H28, &H29, &H2A, &H34, &H35, &H36
DATA &H37, &H38, &H39, &H3A, &H43, &H44, &H45, &H46, &H47, &H48, &H49, &H4A, &H53, &H54, &H55, &H56
DATA &H57, &H58, &H59, &H5A, &H63, &H64, &H65, &H66, &H67, &H68, &H69, &H6A, &H73, &H74, &H75, &H76
DATA &H77, &H78, &H79, &H7A, &H83, &H84, &H85, &H86, &H87, &H88, &H89, &H8A, &H92, &H93, &H94, &H95
DATA &H96, &H97, &H98, &H99, &H9A, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &HA9, &HAA, &HB2, &HB3
DATA &HB4, &HB5, &HB6, &HB7, &HB8, &HB9, &HBA, &HC2, &HC3, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, &HCA
DATA &HD2, &HD3, &HD4, &HD5, &HD6, &HD7, &HD8, &HD9, &HDA, &HE1, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7
DATA &HE8, &HE9, &HEA, &HF1, &HF2, &HF3, &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, &HFA
Huff3:
DATA 0
DATA 2, 0, 1
DATA 1, 2
DATA 2, 3, &H11
DATA 4, 4, 5, &H21, &H31
DATA 4, 6, &H12, &H41, &H51
DATA 3, 7, &H61, &H71
DATA 4, &H13, &H22, &H32, &H81
DATA 7, 8, &H14, &H42, &H91, &HA1, &HB1, &HC1
DATA 5, 9, &H23, &H33, &H52, &HF0
DATA 4, &H15, &H62, &H72, &HD1
DATA 4, &HA, &H16, &H24, &H34
DATA 0
DATA 1, &HE1
DATA 2, &H25, &HF1
DATA 119, &H17, &H18, &H19, &H1A, &H26, &H27, &H28, &H29, &H2A, &H35, &H36, &H37, &H38, &H39, &H3A, &H43
DATA &H44, &H45, &H46, &H47, &H48, &H49, &H4A, &H53, &H54, &H55, &H56, &H57, &H58, &H59, &H5A, &H63
DATA &H64, &H65, &H66, &H67, &H68, &H69, &H6A, &H73, &H74, &H75, &H76, &H77, &H78, &H79, &H7A, &H82
DATA &H83, &H84, &H85, &H86, &H87, &H88, &H89, &H8A, &H92, &H93, &H94, &H95, &H96, &H97, &H98, &H99
DATA &H9A, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &HA9, &HAA, &HB2, &HB3, &HB4, &HB5, &HB6, &HB7
DATA &HB8, &HB9, &HBA, &HC2, &HC3, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, &HCA, &HD2, &HD3, &HD4, &HD5
DATA &HD6, &HD7, &HD8, &HD9, &HDA, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7, &HE8, &HE9, &HEA, &HF2, &HF3
DATA &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, &HFA
StandardQT:
DATA 16, 11, 10, 16, 24, 40, 51, 61
DATA 12, 12, 14, 19, 26, 58, 60, 55
DATA 14, 13, 16, 24, 40, 57, 69, 56
DATA 14, 17, 22, 29, 51, 87, 80, 62
DATA 18, 22, 37, 56, 68, 109, 103, 77
DATA 24, 35, 55, 64, 81, 104, 113, 92
DATA 49, 64, 78, 87, 103, 121, 120, 101
DATA 72, 92, 95, 98, 112, 100, 103, 99
DATA 17, 18, 24, 47, 99, 99, 99, 99
DATA 18, 24, 26, 66, 99, 99, 99, 99
DATA 24, 26, 56, 99, 99, 99, 99, 99
DATA 47, 66, 99, 99, 99, 99, 99, 99
DATA 99, 99, 99, 99, 99, 99, 99, 99
DATA 99, 99, 99, 99, 99, 99, 99, 99
DATA 99, 99, 99, 99, 99, 99, 99, 99
DATA 99, 99, 99, 99, 99, 99, 99, 99
DEFSNG A-Z
FUNCTION JPEG.ACHuff$ (RLE AS INTEGER, AC AS INTEGER, Huff() AS STRING, A AS INTEGER)
DIM H AS STRING, C AS INTEGER, Y AS INTEGER, T AS INTEGER, X AS INTEGER
C = JPEG.Category(AC)
Y = RLE * 16 + C
T = 1
X = AC + (AC < 0)
WHILE C
IF X AND T THEN H = "1" + H ELSE H = "0" + H
T = T * 2
C = C - 1
WEND
JPEG.ACHuff = Huff(Y, 1, A) + H
END FUNCTION
SUB JPEG.Begin (FileNo AS INTEGER, W AS INTEGER, H AS INTEGER, Sampling() AS INTEGER, State AS JPEGState, QT() AS INTEGER, Huff() AS STRING)
DIM I AS INTEGER, J AS INTEGER, X AS INTEGER, Y AS INTEGER, T AS INTEGER
PutChar FileNo, 0
FOR Y = 0 TO 7: FOR X = 0 TO 7
PutChar FileNo, QT(X, Y, 0)
NEXT X, Y
PutChar FileNo, 1
FOR Y = 0 TO 7: FOR X = 0 TO 7
PutChar FileNo, QT(X, Y, 1)
NEXT X, Y
'DHT
PutChar FileNo, 255
PutChar FileNo, 196
T = 2 + 4 * (16 + 1)
RESTORE Huff0
FOR I = 1 TO 16 * 4
READ X
FOR J = 1 TO X
READ Y
T = T + 1
NEXT
NEXT
JPEG.PutWord FileNo, T
PutChar FileNo, 0
RESTORE Huff0
FOR I = 1 TO 16
READ X
PutChar FileNo, X
FOR J = 1 TO X
READ Y
NEXT
NEXT
RESTORE Huff0
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
READ Y
PutChar FileNo, Y
NEXT
NEXT
PutChar FileNo, 1
RESTORE Huff1
FOR I = 1 TO 16
READ X
PutChar FileNo, X
FOR J = 1 TO X
READ Y
NEXT
NEXT
RESTORE Huff1
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
READ Y
PutChar FileNo, Y
NEXT
NEXT
PutChar FileNo, 16
RESTORE Huff2
FOR I = 1 TO 16
READ X
PutChar FileNo, X
FOR J = 1 TO X
READ Y
NEXT
NEXT
RESTORE Huff2
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
READ Y
PutChar FileNo, Y
NEXT
NEXT
PutChar FileNo, 17
RESTORE Huff3
FOR I = 1 TO 16
READ X
PutChar FileNo, X
FOR J = 1 TO X
READ Y
NEXT
NEXT
RESTORE Huff3
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
READ Y
PutChar FileNo, Y
NEXT
NEXT
FUNCTION JPEG.Block.Huffman$ (B() AS INTEGER, LastDC AS INTEGER, Huff() AS STRING, A AS INTEGER)
DIM H AS STRING, DC AS INTEGER, I AS INTEGER
DIM C AS INTEGER
DC = B(0) - LastDC
H = JPEG.DCHuff(DC, Huff(), A)
B(64) = -1
I = 1
DO
C = 0
IF B(I) = 0 THEN
DO
I = I + 1
C = C + 1
LOOP WHILE B(I) = 0
IF I = 64 THEN
H = H + Huff(0, 1, A)
EXIT DO
END IF
WHILE C >= 16
H = H + Huff(&HF0, 1, A)
C = C - 16
WEND
END IF
H = H + JPEG.ACHuff(C, B(I), Huff(), A)
I = I + 1
LOOP WHILE I < 64
JPEG.Block.Huffman = H
END FUNCTION
SUB JPEG.Block.Output (FileNo AS INTEGER, B() AS INTEGER, State AS JPEGState, QT() AS INTEGER, Huff() AS STRING)
DIM O(0 TO 64) AS INTEGER, H AS STRING
State.Position = State.Position + 1
IF State.Position > State.YCount + State.CbCount + State.CrCount THEN State.Position = 1
IF State.Position <= State.YCount THEN
JPEG.Block.Transform B(), O(), QT(), 0
H = RTRIM$(State.Leftovers) + JPEG.Block.Huffman(O(), State.YDC, Huff(), 0)
State.YDC = O(0)
ELSE
JPEG.Block.Transform B(), O(), QT(), 1
IF State.Position <= State.YCount + State.CbCount THEN
H = RTRIM$(State.Leftovers) + JPEG.Block.Huffman(O(), State.CbDC, Huff(), 1)
State.CbDC = O(0)
ELSE
H = RTRIM$(State.Leftovers) + JPEG.Block.Huffman(O(), State.CrDC, Huff(), 1)
State.CrDC = O(0)
END IF
END IF
DIM I AS INTEGER, J AS INTEGER, K AS INTEGER, T AS INTEGER
FOR I = 1 TO LEN(H) - 7 STEP 8
K = 128
T = 0
FOR J = I TO I + 7
IF MID$(H, J, 1) = "1" THEN T = T OR K
K = K \ 2
NEXT
PutChar FileNo, T
IF T = 255 THEN PutChar FileNo, 0
NEXT
State.Leftovers = RIGHT$(H, LEN(H) AND 7)
END SUB
SUB JPEG.Block.Transform (B() AS INTEGER, O() AS INTEGER, QT() AS INTEGER, A AS INTEGER)
DIM U AS INTEGER, V AS INTEGER, X AS INTEGER, Y AS INTEGER, Dir AS INTEGER
DIM B2(0 TO 7, 0 TO 7) AS INTEGER
DIM T AS SINGLE
FOR V = 0 TO 7: FOR U = 0 TO 7
T = 0
FOR Y = 0 TO 7: FOR X = 0 TO 7
T = T + B(X, Y) * COS((2 * X + 1) * U * Pi / 16) * COS((2 * Y + 1) * V * Pi / 16)
NEXT X, Y
T = T / 4
IF U = 0 THEN T = T / SQR(2)
IF V = 0 THEN T = T / SQR(2)
B2(U, V) = CINT(T / QT(U, V, A))
NEXT U, V
X = 0: Y = 0
U = 0
Dir = 0
DO
O(U) = B2(X, Y)
U = U + 1
IF U = 64 THEN EXIT DO
IF Dir THEN
IF Y = 7 THEN
X = X + 1
Dir = 0
ELSEIF X = 0 THEN
Y = Y + 1
Dir = 0
ELSE
X = X - 1
Y = Y + 1
END IF
ELSE
IF Y = 0 THEN
X = X + 1
Dir = 1
ELSEIF X = 7 THEN
Y = Y + 1
Dir = 1
ELSE
X = X + 1
Y = Y - 1
END IF
END IF
LOOP
END SUB
FUNCTION JPEG.Category% (X AS INTEGER)
DIM T AS INTEGER, I AS INTEGER
T = ABS(X)
WHILE T
T = T \ 2
I = I + 1
WEND
JPEG.Category = I
END FUNCTION
FUNCTION JPEG.Cb% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
JPEG.Cb = -.1687 * R - .3313 * G + .5 * B
END FUNCTION
FUNCTION JPEG.Cr% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
JPEG.Cr = .5 * R - .4187 * G - .0813 * B
END FUNCTION
FUNCTION JPEG.DCHuff$ (DC AS INTEGER, Huff() AS STRING, A AS INTEGER)
DIM H AS STRING, C AS INTEGER, Y AS INTEGER, T AS INTEGER, X AS INTEGER
C = JPEG.Category(DC)
Y = C
T = 1
X = DC + (DC < 0)
WHILE C
IF X AND T THEN H = "1" + H ELSE H = "0" + H
T = T * 2
C = C - 1
WEND
JPEG.DCHuff = Huff(Y, 0, A) + H
END FUNCTION
SUB JPEG.Finish (FileNo AS INTEGER, State AS JPEGState)
DIM H AS STRING, K AS INTEGER, T AS INTEGER, I AS INTEGER
H = RTRIM$(State.Leftovers)
IF LEN(H) THEN
H = H + "1111111"
K = 128
T = 0
FOR I = 1 TO 8
IF MID$(H, I, 1) = "1" THEN T = T OR K
K = K \ 2
NEXT
PutChar FileNo, T
IF T = 255 THEN PutChar FileNo, 0
END IF
PutChar FileNo, 255
PutChar FileNo, 217
END SUB
SUB JPEG.GenerateHuffmanTable (HT() AS STRING, A AS INTEGER, B AS INTEGER)
DIM S AS STRING, I AS INTEGER, J AS INTEGER, T AS INTEGER
DIM X AS INTEGER, Y AS INTEGER
S = ""
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
IF S = "" THEN
S = "0000000000000000"
ELSE
WHILE MID$(S, T, 1) = "1"
MID$(S, T, 1) = "0"
T = T - 1
WEND
MID$(S, T, 1) = "1"
END IF
READ Y
HT(Y, A, B) = LEFT$(S$, I)
T = I
NEXT
NEXT
END SUB
SUB JPEG.PutWord (FileNo AS INTEGER, Word AS INTEGER)
DIM C AS STRING * 1
C = CHR$(Word \ 256)
PUT #1, , C
C = CHR$(Word AND 255)
PUT #1, , C
END SUB
SUB JPEG.StandardQT (Quality AS SINGLE, QT() AS INTEGER)
DIM I AS INTEGER, X AS INTEGER, Y AS INTEGER, T AS INTEGER
RESTORE StandardQT
FOR I = 0 TO 1: FOR Y = 0 TO 7: FOR X = 0 TO 7
READ T
QT(X, Y, I) = T * Quality
IF QT(X, Y, I) = 0 THEN QT(X, Y, I) = 1
NEXT X, Y, I
END SUB
FUNCTION JPEG.Y% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
JPEG.Y = .299 * R + .587 * G + .114 * B - 128
END FUNCTION
SUB PutChar (FileNo AS INTEGER, Char AS INTEGER)
DIM C AS STRING * 1
C = CHR$(Char)
PUT #1, , C
END SUB
This message has been edited by Mikrondel on Feb 13, 2009 7:49 PM
Functions jpeg.cb%, jpeg.cbcr%, and jpeg.y% need to have the % signs cut off or a dup def occurs. All other functions are fine. Ran prgram and got a green square with a round hole in the middle, about 4K.
Pete
This message has been edited by The-Universe on Feb 13, 2009 7:55 PM
It's roughly 10 times faster than before (but the new sample image is more difficult to encode, hence a comparison with the previous version will give misleading results). I also fixed a MAJOR bug with the quality tables which essentially made any image look crappy unless at 100% quality.
I will get around to some docs eventually, but until then... figure it out for yourself! :)
'WARNING: OVERWRITES TEST.JPG
DECLARE FUNCTION Atan2! (X AS SINGLE, Y AS SINGLE)
DECLARE SUB PutChar (FileNo AS INTEGER, Char AS INTEGER)
DECLARE SUB JPEG.Precalc ()
DECLARE SUB JPEG.Begin (FileNo AS INTEGER, W AS INTEGER, H AS INTEGER, Sampling() AS INTEGER, State AS ANY, QT() AS INTEGER, Huff() AS INTEGER)
DECLARE SUB JPEG.Block.Output (B() AS INTEGER, State AS ANY, QT() AS INTEGER, Huff() AS INTEGER)
DECLARE SUB JPEG.StandardQT (quality AS SINGLE, QT() AS INTEGER)
DECLARE SUB JPEG.Finish (State AS ANY)
DECLARE FUNCTION JPEG.Category% (X AS INTEGER)
DECLARE FUNCTION JPEG.Cb% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
DECLARE FUNCTION JPEG.Cr% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
DECLARE FUNCTION JPEG.Y% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
TYPE JPEGState
FileNo AS INTEGER
YCount AS INTEGER
CbCount AS INTEGER
CrCount AS INTEGER
YDC AS INTEGER
CbDC AS INTEGER
CrDC AS INTEGER
Position AS INTEGER
Leftover AS INTEGER
LeftoverBits AS INTEGER
END TYPE
'The following are internal to JPEG.
DECLARE SUB JPEG.ACHuff (RLE AS INTEGER, AC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS ANY)
DECLARE SUB JPEG.Block.Huffman (B() AS INTEGER, LastDC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS ANY)
DECLARE SUB JPEG.Block.Transform (B() AS INTEGER, O() AS INTEGER, QT() AS INTEGER, A AS INTEGER)
DECLARE SUB JPEG.DCHuff (DC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS ANY)
DECLARE SUB JPEG.GenerateHuffmanTable (Huff() AS INTEGER, A AS INTEGER, B AS INTEGER)
DECLARE SUB JPEG.PutBinString (BS AS INTEGER, Length AS INTEGER, State AS ANY)
DECLARE SUB JPEG.PutByte (FileNo AS INTEGER, Byte AS INTEGER)
DECLARE SUB JPEG.PutRightBinString (BS AS INTEGER, Length AS INTEGER, State AS ANY)
DECLARE SUB JPEG.PutWord (FileNo AS INTEGER, Word AS INTEGER)
DECLARE FUNCTION JPEG.Shift% (I AS INTEGER, N AS INTEGER)
DEFINT A-Z
DIM SHARED Pow2(0 TO 15) AS LONG
DIM SHARED Cosine(0 TO 7, 0 TO 7) AS SINGLE
DIM SHARED ZigZagX(0 TO 63) AS INTEGER, ZigZagY(0 TO 63) AS INTEGER
JPEG.Precalc
DIM Huff(0 TO 255, 0 TO 1, 0 TO 1, 0 TO 1) AS INTEGER
DIM QT(0 TO 7, 0 TO 7, 0 TO 1) AS INTEGER
DIM State AS JPEGState
DIM Sampling(0 TO 2, 0 TO 1) AS INTEGER
Sampling(0, 0) = 2 'Sampling factor (x then y) for luminance
Sampling(0, 1) = 2
Sampling(1, 0) = 1 'Sampling factor for "blue" chrominance
Sampling(1, 1) = 1
Sampling(2, 0) = 1 'Sampling factor for "red" chrominance
Sampling(2, 1) = 1
'Delete file then open for binary
OPEN "Test.JPG" FOR OUTPUT AS #1
CLOSE
OPEN "Test.JPG" FOR BINARY AS #1
'Set quality tables
'The smaller the paramter, the higher the quality
'0.01 is 100% quality
JPEG.StandardQT .5, QT()
FOR SuperY = 0 TO 127 STEP 16
FOR SuperX = 0 TO 127 STEP 16
'Output the luminance blocks
FOR BlockY = 0 TO 15 STEP 8
FOR BlockX = 0 TO 15 STEP 8
FOR OffY = 0 TO 7: FOR OffX = 0 TO 7
X! = OffX + BlockX + SuperX - 63.5
Y! = OffY + BlockY + SuperY - 63.5
D! = SQR(X! * X! + Y! * Y!) / 6 + Atan2(X!, Y!)
R = 255
G = 255 - (COS(D!) + 1) * 127.5
B = 255 - (COS(D!) + 1) * 127.5
B(OffX, OffY) = JPEG.Y(R, G, B)
NEXT OffX, OffY
JPEG.Block.Output B(), State, QT(), Huff()
NEXT BlockX, BlockY
'Output the blue chrominance block
FOR OffY = 0 TO 7: FOR OffX = 0 TO 7
X! = OffX * 2 + SuperX - 63
Y! = OffY * 2 + SuperY - 63
D! = SQR(X! * X! + Y! * Y!) / 6 + Atan2(X!, Y!)
R = 255
G = 255 - (COS(D!) + 1) * 127.5
B = 255 - (COS(D!) + 1) * 127.5
B(OffX, OffY) = JPEG.Cb(R, G, B)
NEXT OffX, OffY
JPEG.Block.Output B(), State, QT(), Huff()
'Output the red chrominance block
FOR OffY = 0 TO 7: FOR OffX = 0 TO 7
X! = OffX * 2 + SuperX - 63
Y! = OffY * 2 + SuperY - 63
D! = SQR(X! * X! + Y! * Y!) / 6 + Atan2(X!, Y!)
R = 255
G = 255 - (COS(D!) + 1) * 127.5
B = 255 - (COS(D!) + 1) * 127.5
B(OffX, OffY) = JPEG.Cr(R, G, B)
NEXT OffX, OffY
JPEG.Block.Output B(), State, QT(), Huff()
NEXT SuperX, SuperY
JPEG.Finish State
CLOSE
END
Huff0:
DATA 0
DATA 1, 0
DATA 5, 1, 2, 3, 4, 5
DATA 1, 6
DATA 1, 7
DATA 1, 8
DATA 1, 9
DATA 1, 10
DATA 1, 11
DATA 0, 0, 0, 0, 0, 0, 0
Huff1:
DATA 0
DATA 3, 0, 1, 2
DATA 1, 3
DATA 1, 4
DATA 1, 5
DATA 1, 6
DATA 1, 7
DATA 1, 8
DATA 1, 9
DATA 1, 10
DATA 1, 11
DATA 0, 0, 0, 0, 0
Huff2:
DATA 0
DATA 2, 1, 2
DATA 1, 3
DATA 3, 0, 4, &H11
DATA 3, 5, &H12, &H21
DATA 2, &H31, &H41
DATA 4, 6, &H13, &H51, &H61
DATA 3, 7, &H22, &H71
DATA 5, &H14, &H32, &H81, &H91, &HA1
DATA 5, &H08, &H23, &H42, &HB1, &HC1
DATA 4, &H15, &H52, &HD1, &HF0
DATA 4, &H24, &H33, &H62, &H72
DATA 0
DATA 0
DATA 1, &H82
DATA 125, &H09, &H0A, &H16, &H17, &H18, &H19, &H1A, &H25, &H26, &H27, &H28, &H29, &H2A, &H34, &H35, &H36
DATA &H37, &H38, &H39, &H3A, &H43, &H44, &H45, &H46, &H47, &H48, &H49, &H4A, &H53, &H54, &H55, &H56
DATA &H57, &H58, &H59, &H5A, &H63, &H64, &H65, &H66, &H67, &H68, &H69, &H6A, &H73, &H74, &H75, &H76
DATA &H77, &H78, &H79, &H7A, &H83, &H84, &H85, &H86, &H87, &H88, &H89, &H8A, &H92, &H93, &H94, &H95
DATA &H96, &H97, &H98, &H99, &H9A, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &HA9, &HAA, &HB2, &HB3
DATA &HB4, &HB5, &HB6, &HB7, &HB8, &HB9, &HBA, &HC2, &HC3, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, &HCA
DATA &HD2, &HD3, &HD4, &HD5, &HD6, &HD7, &HD8, &HD9, &HDA, &HE1, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7
DATA &HE8, &HE9, &HEA, &HF1, &HF2, &HF3, &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, &HFA
Huff3:
DATA 0
DATA 2, 0, 1
DATA 1, 2
DATA 2, 3, &H11
DATA 4, 4, 5, &H21, &H31
DATA 4, 6, &H12, &H41, &H51
DATA 3, 7, &H61, &H71
DATA 4, &H13, &H22, &H32, &H81
DATA 7, 8, &H14, &H42, &H91, &HA1, &HB1, &HC1
DATA 5, 9, &H23, &H33, &H52, &HF0
DATA 4, &H15, &H62, &H72, &HD1
DATA 4, &HA, &H16, &H24, &H34
DATA 0
DATA 1, &HE1
DATA 2, &H25, &HF1
DATA 119, &H17, &H18, &H19, &H1A, &H26, &H27, &H28, &H29, &H2A, &H35, &H36, &H37, &H38, &H39, &H3A, &H43
DATA &H44, &H45, &H46, &H47, &H48, &H49, &H4A, &H53, &H54, &H55, &H56, &H57, &H58, &H59, &H5A, &H63
DATA &H64, &H65, &H66, &H67, &H68, &H69, &H6A, &H73, &H74, &H75, &H76, &H77, &H78, &H79, &H7A, &H82
DATA &H83, &H84, &H85, &H86, &H87, &H88, &H89, &H8A, &H92, &H93, &H94, &H95, &H96, &H97, &H98, &H99
DATA &H9A, &HA2, &HA3, &HA4, &HA5, &HA6, &HA7, &HA8, &HA9, &HAA, &HB2, &HB3, &HB4, &HB5, &HB6, &HB7
DATA &HB8, &HB9, &HBA, &HC2, &HC3, &HC4, &HC5, &HC6, &HC7, &HC8, &HC9, &HCA, &HD2, &HD3, &HD4, &HD5
DATA &HD6, &HD7, &HD8, &HD9, &HDA, &HE2, &HE3, &HE4, &HE5, &HE6, &HE7, &HE8, &HE9, &HEA, &HF2, &HF3
DATA &HF4, &HF5, &HF6, &HF7, &HF8, &HF9, &HFA
StandardQT:
DATA 16, 11, 10, 16, 24, 40, 51, 61
DATA 12, 12, 14, 19, 26, 58, 60, 55
DATA 14, 13, 16, 24, 40, 57, 69, 56
DATA 14, 17, 22, 29, 51, 87, 80, 62
DATA 18, 22, 37, 56, 68, 109, 103, 77
DATA 24, 35, 55, 64, 81, 104, 113, 92
DATA 49, 64, 78, 87, 103, 121, 120, 101
DATA 72, 92, 95, 98, 112, 100, 103, 99
DATA 17, 18, 24, 47, 99, 99, 99, 99
DATA 18, 24, 26, 66, 99, 99, 99, 99
DATA 24, 26, 56, 99, 99, 99, 99, 99
DATA 47, 66, 99, 99, 99, 99, 99, 99
DATA 99, 99, 99, 99, 99, 99, 99, 99
DATA 99, 99, 99, 99, 99, 99, 99, 99
DATA 99, 99, 99, 99, 99, 99, 99, 99
DATA 99, 99, 99, 99, 99, 99, 99, 99
DEFSNG A-Z
FUNCTION Atan2! (X AS SINGLE, Y AS SINGLE)
'Code borrowed from London
Atan2 = ATN(Y / X) - ATN(1) * 4 * (X < 0 - 2 * (X < 0 AND Y < 0))
END FUNCTION
SUB JPEG.ACHuff (RLE AS INTEGER, AC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS JPEGState)
DIM C AS INTEGER, X AS INTEGER
C = JPEG.Category(AC)
X = RLE * 16 + C
JPEG.PutBinString Huff(X, 1, A, 0), Huff(X, 1, A, 1), State
JPEG.PutRightBinString AC + (AC < 0), C, State
END SUB
SUB JPEG.Begin (FileNo AS INTEGER, W AS INTEGER, H AS INTEGER, Sampling() AS INTEGER, State AS JPEGState, QT() AS INTEGER, Huff() AS INTEGER)
DIM I AS INTEGER, J AS INTEGER, X AS INTEGER, Y AS INTEGER, T AS INTEGER
PutChar FileNo, 0
FOR I = 0 TO 63
PutChar FileNo, QT(ZigZagX(I), ZigZagY(I), 0)
NEXT
PutChar FileNo, 1
FOR I = 0 TO 63
PutChar FileNo, QT(ZigZagX(I), ZigZagY(I), 1)
NEXT
'DHT
PutChar FileNo, 255
PutChar FileNo, 196
T = 2 + 4 * (16 + 1)
RESTORE Huff0
FOR I = 1 TO 16 * 4
READ X
FOR J = 1 TO X
READ Y
T = T + 1
NEXT
NEXT
JPEG.PutWord FileNo, T
PutChar FileNo, 0
RESTORE Huff0
FOR I = 1 TO 16
READ X
PutChar FileNo, X
FOR J = 1 TO X
READ Y
NEXT
NEXT
RESTORE Huff0
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
READ Y
PutChar FileNo, Y
NEXT
NEXT
PutChar FileNo, 1
RESTORE Huff1
FOR I = 1 TO 16
READ X
PutChar FileNo, X
FOR J = 1 TO X
READ Y
NEXT
NEXT
RESTORE Huff1
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
READ Y
PutChar FileNo, Y
NEXT
NEXT
PutChar FileNo, 16
RESTORE Huff2
FOR I = 1 TO 16
READ X
PutChar FileNo, X
FOR J = 1 TO X
READ Y
NEXT
NEXT
RESTORE Huff2
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
READ Y
PutChar FileNo, Y
NEXT
NEXT
PutChar FileNo, 17
RESTORE Huff3
FOR I = 1 TO 16
READ X
PutChar FileNo, X
FOR J = 1 TO X
READ Y
NEXT
NEXT
RESTORE Huff3
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
READ Y
PutChar FileNo, Y
NEXT
NEXT
SUB JPEG.Block.Huffman (B() AS INTEGER, LastDC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS JPEGState)
DIM DC AS INTEGER, I AS INTEGER
DIM C AS INTEGER
DC = B(0) - LastDC
JPEG.DCHuff DC, Huff(), A, State
B(64) = -1
I = 1
DO
C = 0
IF B(I) = 0 THEN
DO
I = I + 1
C = C + 1
LOOP WHILE B(I) = 0
IF I = 64 THEN
JPEG.PutBinString Huff(0, 1, A, 0), Huff(0, 1, A, 1), State
EXIT DO
END IF
WHILE C >= 16
JPEG.PutBinString Huff(&HF0, 1, A, 0), Huff(&HF0, 1, A, 1), State
C = C - 16
WEND
END IF
JPEG.ACHuff C, B(I), Huff(), A, State
I = I + 1
LOOP WHILE I < 64
END SUB
SUB JPEG.Block.Output (B() AS INTEGER, State AS JPEGState, QT() AS INTEGER, Huff() AS INTEGER)
DIM O(0 TO 64) AS INTEGER
State.Position = State.Position + 1
IF State.Position > State.YCount + State.CbCount + State.CrCount THEN State.Position = 1
IF State.Position <= State.YCount THEN
JPEG.Block.Transform B(), O(), QT(), 0
JPEG.Block.Huffman O(), State.YDC, Huff(), 0, State
State.YDC = O(0)
ELSE
JPEG.Block.Transform B(), O(), QT(), 1
IF State.Position <= State.YCount + State.CbCount THEN
JPEG.Block.Huffman O(), State.CbDC, Huff(), 1, State
State.CbDC = O(0)
ELSE
JPEG.Block.Huffman O(), State.CrDC, Huff(), 1, State
State.CrDC = O(0)
END IF
END IF
END SUB
SUB JPEG.Block.Transform (B() AS INTEGER, O() AS INTEGER, QT() AS INTEGER, A AS INTEGER)
DIM U AS INTEGER, V AS INTEGER, X AS INTEGER, Y AS INTEGER
DIM B2(0 TO 7, 0 TO 7) AS SINGLE
DIM T AS SINGLE
FOR V = 0 TO 7: FOR U = 0 TO 7
T = 0
FOR X = 0 TO 7
T = T + B(X, V) * Cosine(X, U)
NEXT X
B2(U, V) = T
NEXT U, V
FOR U = 0 TO 7: FOR V = 0 TO 7
T = 0
FOR Y = 0 TO 7
T = T + B2(U, Y) * Cosine(Y, V)
NEXT Y
T = T / 4
IF U = 0 THEN T = T / SQR(2)
IF V = 0 THEN T = T / SQR(2)
B(U, V) = CINT(T / QT(U, V, A))
NEXT V, U
FOR U = 0 TO 63
O(U) = B(ZigZagX(U), ZigZagY(U))
NEXT
END SUB
FUNCTION JPEG.Category% (X AS INTEGER)
DIM T AS INTEGER, I AS INTEGER
T = ABS(X)
WHILE T
T = T \ 2
I = I + 1
WEND
JPEG.Category = I
END FUNCTION
FUNCTION JPEG.Cb% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
JPEG.Cb = -.1687 * R - .3313 * G + .5 * B
END FUNCTION
FUNCTION JPEG.Cr% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
JPEG.Cr = .5 * R - .4187 * G - .0813 * B
END FUNCTION
SUB JPEG.DCHuff (DC AS INTEGER, Huff() AS INTEGER, A AS INTEGER, State AS JPEGState)
DIM C AS INTEGER
C = JPEG.Category(DC)
JPEG.PutBinString Huff(C, 0, A, 0), Huff(C, 0, A, 1), State
JPEG.PutRightBinString DC + (DC < 0), C, State
END SUB
SUB JPEG.Finish (State AS JPEGState)
DEF SEG = VARSEG(State.Leftover)
IF State.LeftoverBits > 8 THEN
JPEG.PutByte State.FileNo, PEEK(VARPTR(State.Leftover) + 1)
POKE VARPTR(State.Leftover) + 1, State.Leftover AND 255
State.LeftoverBits = State.LeftoverBits - 8
END IF
IF State.LeftoverBits THEN
JPEG.PutByte State.FileNo, PEEK(VARPTR(State.Leftover) + 1) OR (Pow2(8 - State.LeftoverBits) - 1)
END IF
DEF SEG
SUB JPEG.GenerateHuffmanTable (Huff() AS INTEGER, A AS INTEGER, B AS INTEGER)
DIM S AS LONG, I AS INTEGER, J AS INTEGER, T AS INTEGER
DIM X AS INTEGER, Y AS INTEGER
S = -1
FOR I = 1 TO 16
READ X
FOR J = 1 TO X
IF S = -1 THEN
S = 0
ELSE
S = S + Pow2(T)
END IF
READ Y
IF S AND 32768 THEN Huff(Y, A, B, 0) = CINT(S AND 32767&) OR -32768 ELSE Huff(Y, A, B, 0) = S
Huff(Y, A, B, 1) = I
T = 16 - I
NEXT
NEXT
END SUB
SUB JPEG.Precalc
DIM X AS INTEGER, Y AS INTEGER, T AS INTEGER, Dir AS INTEGER, L AS LONG
L = 1
FOR X = 0 TO 15
Pow2(X) = L
L = L + L
NEXT
FOR Y = 0 TO 7
FOR X = 0 TO 7
Cosine(X, Y) = COS((2 * X + 1) * Y * .1963495)
NEXT X, Y
X = 0: Y = 0
T = 0
Dir = 0
DO
ZigZagX(T) = X
ZigZagY(T) = Y
T = T + 1
IF T = 64 THEN EXIT DO
IF Dir THEN
IF Y = 7 THEN
X = X + 1
Dir = 0
ELSEIF X = 0 THEN
Y = Y + 1
Dir = 0
ELSE
X = X - 1
Y = Y + 1
END IF
ELSE
IF Y = 0 THEN
X = X + 1
Dir = 1
ELSEIF X = 7 THEN
Y = Y + 1
Dir = 1
ELSE
X = X + 1
Y = Y - 1
END IF
END IF
LOOP
END SUB
SUB JPEG.PutBinString (BS AS INTEGER, Length AS INTEGER, State AS JPEGState)
DIM Temp AS INTEGER
Temp = BS
State.Leftover = State.Leftover OR JPEG.Shift(Temp, State.LeftoverBits)
State.LeftoverBits = State.LeftoverBits + Length
IF State.LeftoverBits >= 16 THEN
DEF SEG = VARSEG(State.Leftover)
JPEG.PutByte State.FileNo, PEEK(VARPTR(State.Leftover) + 1)
DEF SEG
JPEG.PutByte State.FileNo, State.Leftover AND 255
State.LeftoverBits = State.LeftoverBits - 16
State.Leftover = Temp
END IF
END SUB
SUB JPEG.PutByte (FileNo AS INTEGER, Byte AS INTEGER)
DIM C AS STRING * 1
C = CHR$(Byte)
PUT FileNo, , C
IF Byte = 255 THEN C = CHR$(0): PUT FileNo, , C
END SUB
SUB JPEG.PutRightBinString (BS AS INTEGER, Length AS INTEGER, State AS JPEGState)
DIM Temp AS LONG
IF Length THEN
Temp = (CLNG(BS) AND Pow2(Length) - 1) * Pow2(16 - Length)
IF Temp AND 32768 THEN Temp = Temp OR -65536
JPEG.PutBinString CINT(Temp), Length, State
END IF
END SUB
SUB JPEG.PutWord (FileNo AS INTEGER, Word AS INTEGER)
DIM C AS STRING * 1
C = CHR$(Word \ 256)
PUT FileNo, , C
C = CHR$(Word AND 255)
PUT FileNo, , C
END SUB
FUNCTION JPEG.Shift% (I AS INTEGER, N AS INTEGER)
DIM T AS LONG
IF N = 0 THEN
JPEG.Shift = I
I = 0
EXIT FUNCTION
END IF
T = CLNG(I) AND 65535
JPEG.Shift = T \ Pow2(N)
T = (T AND (Pow2(N) - 1)) * Pow2((16 - N) AND 15)
IF T AND 32768 THEN I = CINT(T AND 32767&) OR -32768 ELSE I = CINT(T)
END FUNCTION
SUB JPEG.StandardQT (quality AS SINGLE, QT() AS INTEGER)
DIM I AS INTEGER, X AS INTEGER, Y AS INTEGER, T AS INTEGER
RESTORE StandardQT
FOR I = 0 TO 1: FOR Y = 0 TO 7: FOR X = 0 TO 7
READ T
QT(X, Y, I) = T * quality
IF QT(X, Y, I) = 0 THEN QT(X, Y, I) = 1
NEXT X, Y, I
END SUB
FUNCTION JPEG.Y% (R AS INTEGER, G AS INTEGER, B AS INTEGER)
JPEG.Y = .299 * R + .587 * G + .114 * B - 128
END FUNCTION
SUB PutChar (FileNo AS INTEGER, Char AS INTEGER)
DIM C AS STRING * 1
C = CHR$(Char)
PUT FileNo, , C
END SUB