1 2(********************************************************************) 3(* *) 4(* jpeg.s7i Support for the JPEG image file format. *) 5(* Copyright (C) 2021 Thomas Mertes *) 6(* *) 7(* This file is part of the Seed7 Runtime Library. *) 8(* *) 9(* The Seed7 Runtime Library is free software; you can *) 10(* redistribute it and/or modify it under the terms of the GNU *) 11(* Lesser General Public License as published by the Free Software *) 12(* Foundation; either version 2.1 of the License, or (at your *) 13(* option) any later version. *) 14(* *) 15(* The Seed7 Runtime Library is distributed in the hope that it *) 16(* will be useful, but WITHOUT ANY WARRANTY; without even the *) 17(* implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR *) 18(* PURPOSE. See the GNU Lesser General Public License for more *) 19(* details. *) 20(* *) 21(* You should have received a copy of the GNU Lesser General *) 22(* Public License along with this program; if not, write to the *) 23(* Free Software Foundation, Inc., 51 Franklin Street, *) 24(* Fifth Floor, Boston, MA 02110-1301, USA. *) 25(* *) 26(********************************************************************) 27 28 29include "bytedata.s7i"; 30include "bitdata.s7i"; 31include "huffman.s7i"; 32include "draw.s7i"; 33 34 35const string: JPEG_MAGIC is "\16#ff;\16#d8;\16#ff;"; # Start of image (SOI) + ff 36 37const char: JPEG_MARKER_START is '\16#ff;'; 38const char: JPEG_SOF0 is '\16#c0;'; # Start Of Frame (Baseline) 39const char: JPEG_SOF1 is '\16#c1;'; # Start Of Frame (Extended sequential) 40const char: JPEG_SOF2 is '\16#c2;'; # Start Of Frame (Progressive) 41const char: JPEG_DHT is '\16#c4;'; # Define Huffman Table 42const char: JPEG_SOI is '\16#d8;'; # Start Of Image 43const char: JPEG_EOI is '\16#d9;'; # End Of Image 44const char: JPEG_SOS is '\16#da;'; # Start Of Scan 45const char: JPEG_DQT is '\16#db;'; # Define Quantization Table 46const char: JPEG_DRI is '\16#dd;'; # Define Restart Interval 47const char: JPEG_APP0 is '\16#e0;'; # Application Segment 0 48const char: JPEG_APP15 is '\16#ef;'; # Application Segment 15 49const char: JPEG_COM is '\16#fe;'; # Comment 50const char: JPEG_FILLER is '\16#ff;'; # Fill byte (ignored) 51 52const integer: JPEG_BLOCK_SIZE is 64; 53 54const integer: JPEG_COMPTYPE_LUMA is 1; 55const integer: JPEG_COMPTYPE_CHROMA_BLUE is 2; 56const integer: JPEG_COMPTYPE_CHROMA_RED is 3; 57 58const type: jpegComponent is new struct 59 var integer: quantizationTableIndex is 0; 60 end struct; 61 62const type: jpegScan is new struct 63 var integer: comptype is 0; 64 var integer: dcHuffmanTableIndex is 0; 65 var integer: acHuffmanTableIndex is 0; 66 end struct; 67 68const type: jpegHeader is new struct 69 var integer: precision is 0; 70 var integer: width is 0; 71 var integer: height is 0; 72 var integer: framebytes is 0; 73 var array array integer: quantizationTable is 4 times JPEG_BLOCK_SIZE times 0; 74 var array jpegComponent: component is 0 times jpegComponent.value; 75 var array jpegScan: scan is 0 times jpegScan.value; 76 var array huffmanTable: dcTable is 4 times huffmanTable.value; 77 var array huffmanTable: acTable is 4 times huffmanTable.value; 78 var array integer: lumaQuantization is 0 times 0; 79 var array integer: chromaBlueQuantization is 0 times 0; 80 var array integer: chromaRedQuantization is 0 times 0; 81 var integer: restartInterval is 0; 82 var integer: numberOfScans is 0; 83 var integer: startOfSpectral is 0; 84 var integer: endOfSpectral is 0; 85 var integer: approximationLow is 0; 86 var integer: approximationHigh is 0; 87 var boolean: progressive is FALSE; 88 var integer: vertical is 0; 89 var integer: horizontal is 0; 90 var integer: numLuma is 0; 91 var integer: unitLines is 0; 92 var integer: unitColumns is 0; 93 var integer: blockLines is 0; 94 var integer: blockColumns is 0; 95 end struct; 96 97const type: jpegMinimumCodedUnit is new struct 98 var array array integer: luma is 4 times JPEG_BLOCK_SIZE times 0; 99 var array array integer: chroma is 2 times JPEG_BLOCK_SIZE times 0; 100 end struct; 101 102const integer: CHROMA_BLUE is 1; 103const integer: CHROMA_RED is 2; 104 105 106const proc: readStartOfFrame (inout file: jpegFile, inout jpegHeader: header) is func 107 local 108 var integer: length is 0; 109 var integer: numComponents is 0; 110 var integer: comptype is 0; 111 var integer: sampling is 0; 112 var integer: index is 0; 113 begin 114 length := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE) - 2; 115 header.precision := ord(getc(jpegFile)); 116 header.height := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE); 117 header.width := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE); 118 numComponents := ord(getc(jpegFile)); 119 header.framebytes := header.width * header.height * numComponents; 120 header.component := numComponents times jpegComponent.value; 121 for index range 1 to numComponents do 122 comptype := ord(getc(jpegFile)); 123 if comptype <> index then 124 raise RANGE_ERROR; 125 end if; 126 sampling := ord(getc(jpegFile)); 127 if comptype = JPEG_COMPTYPE_LUMA then 128 header.vertical := sampling mod 16; 129 header.horizontal := sampling >> 4; 130 if header.vertical > 2 or header.horizontal > 2 then 131 raise RANGE_ERROR; 132 end if; 133 elsif sampling <> 16#11 or comptype > JPEG_COMPTYPE_CHROMA_RED then 134 raise RANGE_ERROR; 135 end if; 136 header.component[index].quantizationTableIndex := ord(getc(jpegFile)) + 1; 137 end for; 138 header.numLuma := header.vertical * header.horizontal; 139 header.unitLines := succ(pred(header.height) mdiv (8 * header.vertical)); 140 header.unitColumns := succ(pred(header.width) mdiv (8 * header.horizontal)); 141 header.blockLines := succ(pred(header.height) mdiv 8); 142 header.blockColumns := succ(pred(header.width) mdiv 8); 143 length -:= 6 + numComponents * 3; 144 if length <> 0 then 145 raise RANGE_ERROR; 146 end if; 147 end func; 148 149 150const proc: readDefineHuffmanTable (inout file: jpegFile, inout jpegHeader: header) is func 151 local 152 var integer: length is 0; 153 var array integer: numberOfCodesWithLength is 16 times 0; 154 var integer: maximumCodeLength is 0; 155 var string: huffmanValues is ""; 156 var integer: aByte is 0; 157 var integer: tableClass is 0; 158 var integer: tableNumber is 0; 159 var integer: numberOfCodes is 0; 160 var integer: codeLength is 0; 161 begin 162 length := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE) - 2; 163 while length > 0 do 164 aByte := ord(getc(jpegFile)); 165 tableClass := aByte >> 4; 166 tableNumber := succ(aByte mod 16); 167 numberOfCodes := 0; 168 maximumCodeLength := 0; 169 for codeLength range 1 to 16 do 170 numberOfCodesWithLength[codeLength] := ord(getc(jpegFile)); 171 if numberOfCodesWithLength[codeLength] <> 0 then 172 maximumCodeLength := codeLength; 173 end if; 174 numberOfCodes +:= numberOfCodesWithLength[codeLength]; 175 end for; 176 huffmanValues := gets(jpegFile, numberOfCodes); 177 if tableClass = 0 then 178 createHuffmanTableMsb(header.dcTable[tableNumber], maximumCodeLength, 179 numberOfCodesWithLength, huffmanValues); 180 elsif tableClass = 1 then 181 createHuffmanTableMsb(header.acTable[tableNumber], maximumCodeLength, 182 numberOfCodesWithLength, huffmanValues); 183 else 184 raise RANGE_ERROR; 185 end if; 186 length -:= 17 + numberOfCodes; 187 end while; 188 if length <> 0 then 189 raise RANGE_ERROR; 190 end if; 191 end func; 192 193 194const proc: readStartOfScan (inout file: jpegFile, inout jpegHeader: header) is func 195 local 196 var integer: length is 0; 197 var integer: index is 0; 198 var integer: aByte is 0; 199 begin 200 length := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE) - 2; 201 header.numberOfScans := ord(getc(jpegFile)); 202 header.scan := header.numberOfScans times jpegScan.value; 203 for index range 1 to header.numberOfScans do 204 header.scan[index].comptype := ord(getc(jpegFile)); 205 if header.scan[index].comptype > length(header.component) then 206 raise RANGE_ERROR; 207 else 208 aByte := ord(getc(jpegFile)); 209 header.scan[index].dcHuffmanTableIndex := succ(aByte >> 4); 210 header.scan[index].acHuffmanTableIndex := succ(aByte mod 16); 211 end if; 212 end for; 213 header.startOfSpectral := succ(ord(getc(jpegFile))); 214 header.endOfSpectral := succ(ord(getc(jpegFile))); 215 aByte := ord(getc(jpegFile)); 216 header.approximationHigh := aByte >> 4; 217 header.approximationLow := aByte mod 16; 218 if header.progressive and header.startOfSpectral = 1 and 219 header.endOfSpectral <> 1 then 220 raise RANGE_ERROR; 221 end if; 222 if header.startOfSpectral > header.endOfSpectral or 223 header.endOfSpectral > JPEG_BLOCK_SIZE then 224 raise RANGE_ERROR; 225 end if; 226 if header.startOfSpectral <> 1 and header.numberOfScans <> 1 then 227 raise RANGE_ERROR; 228 end if; 229 if header.approximationHigh <> 0 and 230 header.approximationHigh <> succ(header.approximationLow) then 231 raise RANGE_ERROR; 232 end if; 233 length -:= 4 + header.numberOfScans * 2; 234 if length <> 0 then 235 raise RANGE_ERROR; 236 end if; 237 end func; 238 239 240const proc: readDefineQuantizationTable (inout file: jpegFile, inout jpegHeader: header) is func 241 local 242 var integer: length is 0; 243 var integer: aByte is 0; 244 var integer: elementPrecision is 0; 245 var integer: tableNumber is 0; 246 var integer: index is 0; 247 begin 248 length := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE) - 2; 249 while length > 0 do 250 aByte := ord(getc(jpegFile)); 251 elementPrecision := aByte >> 4; 252 tableNumber := succ(aByte mod 16); 253 decr(length); 254 if elementPrecision = 0 then 255 for index range 1 to JPEG_BLOCK_SIZE do 256 header.quantizationTable[tableNumber][index] := ord(getc(jpegFile)); 257 end for; 258 length -:= JPEG_BLOCK_SIZE; 259 elsif elementPrecision = 1 then 260 for index range 1 to JPEG_BLOCK_SIZE do 261 header.quantizationTable[tableNumber][index] := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE) 262 end for; 263 length -:= 2 * JPEG_BLOCK_SIZE; 264 else 265 raise RANGE_ERROR; 266 end if; 267 end while; 268 if length <> 0 then 269 raise RANGE_ERROR; 270 end if; 271 end func; 272 273 274const proc: readDefineRestartInterval (inout file: jpegFile, inout jpegHeader: header) is func 275 local 276 var integer: length is 0; 277 begin 278 length := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE) - 2; 279 if length <> 2 then 280 raise RANGE_ERROR; 281 else 282 header.restartInterval := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE); 283 end if; 284 end func; 285 286 287const proc: readApplicationSegment (inout file: jpegFile, in integer: appNumber) is func 288 local 289 var integer: length is 0; 290 var string: data is ""; 291 var integer: pos is 1; 292 var string: identifier is ""; 293 begin 294 length := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE) - 2; 295 data := gets(jpegFile, length); 296 identifier := getAsciiz(data, pos); 297 end func; 298 299 300const proc: readComment (inout file: jpegFile) is func 301 local 302 var integer: length is 0; 303 var string: data is ""; 304 begin 305 length := bytes2Int(gets(jpegFile, 2), UNSIGNED, BE) - 2; 306 data := gets(jpegFile, length); 307 end func; 308 309 310## 311# Get a symbol with ''bitWidth'' bits from the ''stri'' bitstream. 312# Negative values are encoded with the highest bit set to zero. 313# 314const func integer: getSymbol (in string: stri, inout integer: bytePos, 315 inout integer: bitPos, in integer: bitWidth) is func 316 result 317 var integer: symbol is 0; 318 begin 319 symbol := getBitsMsb(stri, bytePos, bitPos, bitWidth); 320 if symbol < 1 << pred(bitWidth) then 321 # Negative value 322 symbol -:= pred(1 << bitWidth); 323 end if; 324 end func; 325 326 327## 328# Read a block of IDCT coefficients. 329# There is one DC coefficient and 63 AC coefficients. 330# The DC coefficient (the first value) describes the average block value. 331# @param dataBlock Destination for the 64 coefficients. 332# @param dcTable Huffman table for the DC coefficient. 333# @param acTable Huffman table for the 63 AC coefficients. 334# 335const proc: readBlock (inout array integer: dataBlock, 336 in string: stri, inout integer: bytePos, inout integer: bitPos, 337 in huffmanTable: dcTable, in huffmanTable: acTable) is func 338 local 339 var integer: bitWidth is 0; 340 var integer: index is 1; 341 var integer: aByte is 0; 342 var integer: zeros is 0; 343 begin 344 dataBlock := JPEG_BLOCK_SIZE times 0; 345 bitWidth := getHuffmanSymbolMsb(stri, bytePos, bitPos, dcTable); 346 if bitWidth <> 0 then 347 dataBlock[index] := getSymbol(stri, bytePos, bitPos, bitWidth); 348 end if; 349 repeat 350 aByte := getHuffmanSymbolMsb(stri, bytePos, bitPos, acTable); 351 zeros := aByte >> 4; 352 bitWidth := aByte mod 16; 353 if bitWidth = 0 then 354 if zeros = 15 then 355 index +:= 16; 356 if index >= JPEG_BLOCK_SIZE then 357 raise RANGE_ERROR; 358 end if; 359 end if; 360 else 361 index +:= succ(zeros); 362 dataBlock[index] := getSymbol(stri, bytePos, bitPos, bitWidth); 363 if index = JPEG_BLOCK_SIZE then 364 aByte := 0; 365 end if; 366 end if; 367 until aByte = 0; 368 end func; 369 370 371## 372# Undo zigzagging of coefficients. 373# @param dataBlock 64 coefficients to dezigzag. 374# @return The dezigzagged coefficients. 375# 376const func array integer: unzigzag (in array integer: dataBlock) is func 377 result 378 var array integer: unzigzag is JPEG_BLOCK_SIZE times 0; 379 local 380 const array integer: zigzag is [] ( 381 1, 2, 6, 7, 15, 16, 28, 29, 382 3, 5, 8, 14, 17, 27, 30, 43, 383 4, 9, 13, 18, 26, 31, 42, 44, 384 10, 12, 19, 25, 32, 41, 45, 54, 385 11, 20, 24, 33, 40, 46, 53, 55, 386 21, 23, 34, 39, 47, 52, 56, 61, 387 22, 35, 38, 48, 51, 57, 60, 62, 388 36, 37, 49, 50, 58, 59, 63, 64); 389 var integer: index is 0; 390 begin 391 for index range 1 to JPEG_BLOCK_SIZE do 392 unzigzag[index] := dataBlock[zigzag[index]]; 393 end for; 394 end func; 395 396 397## 398# Fast inverse discrete cosine transform for a block line or block column. 399# For the internal calculation the values are scaled by 2048. At the end of 400# the function the scaling is reversed. This way the same function can be 401# used for lines and columns. 402# @param a1 .. a8 The coefficients of a line or column. 403# 404const proc: fastIdct8 (inout integer: a1, inout integer: a2, inout integer: a3, 405 inout integer: a4, inout integer: a5, inout integer: a6, inout integer: a7, 406 inout integer: a8) is func 407 local 408 const integer: W1 is 2841; # 2048 * sqrt(2.0) * cos(1 * PI / 16) 409 const integer: W2 is 2676; # 2048 * sqrt(2.0) * cos(2 * PI / 16) 410 const integer: W3 is 2408; # 2048 * sqrt(2.0) * cos(3 * PI / 16) 411 const integer: W5 is 1609; # 2048 * sqrt(2.0) * cos(5 * PI / 16) 412 const integer: W6 is 1108; # 2048 * sqrt(2.0) * cos(6 * PI / 16) 413 const integer: W7 is 565; # 2048 * sqrt(2.0) * cos(7 * PI / 16) 414 var integer: x0 is 0; 415 var integer: x1 is 0; 416 var integer: x2 is 0; 417 var integer: x3 is 0; 418 var integer: x4 is 0; 419 var integer: x5 is 0; 420 var integer: x6 is 0; 421 var integer: x7 is 0; 422 var integer: x8 is 0; 423 begin 424 if a2 = 0 and a3 = 0 and a4 = 0 and a5 = 0 and a6 = 0 and a7 = 0 and a8 = 0 then 425 a2 := a1; 426 a3 := a1; 427 a4 := a1; 428 a5 := a1; 429 a6 := a1; 430 a7 := a1; 431 a8 := a1; 432 else 433 x0 := (a1 << 11) + 128; 434 x1 := a5 << 11; 435 x2 := a7; 436 x3 := a3; 437 x4 := a2; 438 x5 := a8; 439 x6 := a6; 440 x7 := a4; 441 442 # First stage 443 x8 := W7 * (x4 + x5); 444 x4 := x8 + (W1 - W7) * x4; 445 x5 := x8 - (W1 + W7) * x5; 446 x8 := W3 * (x6 + x7); 447 x6 := x8 - (W3 - W5) * x6; 448 x7 := x8 - (W3 + W5) * x7; 449 450 # Second stage 451 x8 := x0 + x1; 452 x0 -:= x1; 453 x1 := W6 * (x3 + x2); 454 x2 := x1 - (W2 + W6) * x2; 455 x3 := x1 + (W2 - W6) * x3; 456 x1 := x4 + x6; 457 x4 -:= x6; 458 x6 := x5 + x7; 459 x5 -:= x7; 460 461 # Third stage 462 x7 := x8 + x3; 463 x8 -:= x3; 464 x3 := x0 + x2; 465 x0 -:= x2; 466 x2 := (181 * (x4 + x5) + 128) >> 8; 467 x4 := (181 * (x4 - x5) + 128) >> 8; 468 469 # Fourth stage 470 a1 := (x7 + x1) >> 11; 471 a2 := (x3 + x2) >> 11; 472 a3 := (x0 + x4) >> 11; 473 a4 := (x8 + x6) >> 11; 474 a5 := (x8 - x6) >> 11; 475 a6 := (x0 - x4) >> 11; 476 a7 := (x3 - x2) >> 11; 477 a8 := (x7 - x1) >> 11; 478 end if; 479 end func; 480 481 482## 483# Perform a fast 2d inverse discrete cosine transform for a 8x8 block. 484# @param dataBlock 64 coefficients to transform. 485# 486const proc: idct8x8 (inout array integer: dataBlock) is func 487 local 488 var integer: index is 0; 489 begin 490 for index range 1 to 57 step 8 do 491 fastIdct8(dataBlock[index], 492 dataBlock[index + 1], 493 dataBlock[index + 2], 494 dataBlock[index + 3], 495 dataBlock[index + 4], 496 dataBlock[index + 5], 497 dataBlock[index + 6], 498 dataBlock[index + 7]); 499 end for; 500 for index range 1 to 8 do 501 fastIdct8(dataBlock[index], 502 dataBlock[index + 8], 503 dataBlock[index + 16], 504 dataBlock[index + 24], 505 dataBlock[index + 32], 506 dataBlock[index + 40], 507 dataBlock[index + 48], 508 dataBlock[index + 56]); 509 end for; 510 end func; 511 512 513## 514# Read and process a 8x8 block of IDCT coefficients. 515# This function is used for luma and chroma blocks. 516# The processed block contains luma or chroma values of an 8x8 517# area scaled with factor 8 to the range -1024 .. 1023. 518# The values are not clamped so they might also be higher or 519# lower than the limit. 520# 521const proc: processBlock (inout array integer: dataBlock, 522 in string: stri, inout integer: bytePos, inout integer: bitPos, 523 in huffmanTable: dcTable, in huffmanTable: acTable, 524 in array integer: quantizationTable, inout integer: diff) is func 525 local 526 var integer: index is 0; 527 begin 528 readBlock(dataBlock, stri, bytePos, bitPos, dcTable, acTable); 529 dataBlock[1] +:= diff; 530 diff := dataBlock[1]; 531 for index range 1 to JPEG_BLOCK_SIZE do 532 dataBlock[index] *:= quantizationTable[index]; 533 end for; 534 dataBlock := unzigzag(dataBlock); 535 idct8x8(dataBlock); 536 end func; 537 538 539const func integer: clampColor (in integer: col) is 540 return (col < 0 ? 0 : (col > 255 ? 255 : col)) * 256; 541 542 543## 544# Determine the pixel color from ''luminance'', ''chromaBlue'' and ''chromaRed''. 545# @param luminance Luminance scaled to 0 .. 255 (not clamped to it). 546# @param chromaBlue Blue croma scaled to -1024 .. 1023 (not clamped to it). 547# @param chromaRed Red croma scaled to -1024 .. 1023 (not clamped to it). 548# @return The pixel color in the RGB color space. 549# 550const func pixel: setPixel (in integer: luminance, in integer: chromaBlue, in integer: chromaRed) is 551 return rgbPixel(clampColor(chromaRed * 359 mdiv 2048 + luminance), 552 clampColor(luminance - (chromaBlue * 88 + chromaRed * 183) mdiv 2048), 553 clampColor(chromaBlue * 454 mdiv 2048 + luminance)); 554 555 556const proc: colorMinimumCodedUnit11 (in jpegHeader: header, in array integer: luma1, 557 in array integer: chromaBlue, in array integer: chromaRed, inout array array pixel: image, 558 in integer: mcuTopLine, in integer: mcuLeftColumn) is func 559 local 560 var integer: line is 0; 561 var integer: column is 0; 562 var integer: columnBeyond is 0; 563 var integer: dataIndex is 0; 564 var integer: luminance is 0; 565 begin 566 line := mcuTopLine; 567 column := mcuLeftColumn; 568 columnBeyond := column + 8; 569 for dataIndex range 1 to JPEG_BLOCK_SIZE do 570 if line <= header.height and column <= header.width then 571 luminance := luma1[dataIndex] mdiv 8 + 128; 572 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 573 end if; 574 incr(column); 575 if column = columnBeyond then 576 incr(line); 577 column := mcuLeftColumn; 578 end if; 579 end for; 580 end func; 581 582 583const proc: colorMinimumCodedUnit12 (in jpegHeader: header, in array integer: luma1, 584 in array integer: luma2, in array integer: chromaBlue, in array integer: chromaRed, 585 inout array array pixel: image, in integer: mcuTopLine, in integer: mcuLeftColumn) is func 586 local 587 var integer: blockLine is 0; 588 var integer: blockColumn is 0; 589 var integer: blockColumnMax is 0; 590 var integer: line is 1; 591 var integer: column is 1; 592 var integer: dataIndex is 0; 593 var integer: luminance is 0; 594 begin 595 blockColumnMax := min(7, header.width - mcuLeftColumn); 596 for blockLine range 0 to 7 do 597 line := mcuTopLine + blockLine; 598 if line <= header.height then 599 for blockColumn range 0 to blockColumnMax do 600 column := mcuLeftColumn + blockColumn; 601 luminance := luma1[blockLine * 8 + blockColumn + 1] mdiv 8 + 128; 602 dataIndex := succ(blockLine mdiv 2 * 8 + blockColumn); 603 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 604 end for; 605 end if; 606 end for; 607 for blockLine range 8 to 15 do 608 line := mcuTopLine + blockLine; 609 if line <= header.height then 610 for blockColumn range 0 to blockColumnMax do 611 column := mcuLeftColumn + blockColumn; 612 luminance := luma2[(blockLine - 8) * 8 + blockColumn + 1] mdiv 8 + 128; 613 dataIndex := succ(blockLine mdiv 2 * 8 + blockColumn); 614 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 615 end for; 616 end if; 617 end for; 618 end func; 619 620 621const proc: colorMinimumCodedUnit21 (in jpegHeader: header, in array integer: luma1, 622 in array integer: luma2, in array integer: chromaBlue, in array integer: chromaRed, 623 inout array array pixel: image, in integer: mcuTopLine, in integer: mcuLeftColumn) is func 624 local 625 var integer: blockLine is 0; 626 var integer: blockColumn is 0; 627 var integer: blockColumnMax1 is 0; 628 var integer: blockColumnMax2 is 0; 629 var integer: line is 1; 630 var integer: column is 1; 631 var integer: dataIndex is 0; 632 var integer: luminance is 0; 633 begin 634 blockColumnMax1 := min(7, header.width - mcuLeftColumn); 635 blockColumnMax2 := min(15, header.width - mcuLeftColumn); 636 for blockLine range 0 to min(7, header.height - mcuTopLine) do 637 line := mcuTopLine + blockLine; 638 for blockColumn range 0 to blockColumnMax1 do 639 column := mcuLeftColumn + blockColumn; 640 luminance := luma1[blockLine * 8 + blockColumn + 1] mdiv 8 + 128; 641 dataIndex := succ(blockLine * 8 + blockColumn mdiv 2); 642 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 643 end for; 644 for blockColumn range 8 to blockColumnMax2 do 645 column := mcuLeftColumn + blockColumn; 646 luminance := luma2[blockLine * 8 + blockColumn - 8 + 1] mdiv 8 + 128; 647 dataIndex := succ(blockLine * 8 + blockColumn mdiv 2); 648 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 649 end for; 650 end for; 651 end func; 652 653 654const proc: colorMinimumCodedUnit22 (in jpegHeader: header, in array integer: luma1, 655 in array integer: luma2, in array integer: luma3, in array integer: luma4, 656 in array integer: chromaBlue, in array integer: chromaRed, inout array array pixel: image, 657 in integer: mcuTopLine, in integer: mcuLeftColumn) is func 658 local 659 var integer: blockLine is 0; 660 var integer: blockColumn is 0; 661 var integer: blockColumnMax1 is 0; 662 var integer: blockColumnMax2 is 0; 663 var integer: line is 1; 664 var integer: column is 1; 665 var integer: dataIndex is 0; 666 var integer: luminance is 0; 667 begin 668 blockColumnMax1 := min(7, header.width - mcuLeftColumn); 669 blockColumnMax2 := min(15, header.width - mcuLeftColumn); 670 for blockLine range 0 to 7 do 671 line := mcuTopLine + blockLine; 672 if line <= header.height then 673 for blockColumn range 0 to blockColumnMax1 do 674 column := mcuLeftColumn + blockColumn; 675 luminance := luma1[blockLine * 8 + blockColumn + 1] mdiv 8 + 128; 676 dataIndex := succ(blockLine mdiv 2 * 8 + blockColumn mdiv 2); 677 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 678 end for; 679 for blockColumn range 8 to blockColumnMax2 do 680 column := mcuLeftColumn + blockColumn; 681 luminance := luma2[blockLine * 8 + blockColumn - 8 + 1] mdiv 8 + 128; 682 dataIndex := succ(blockLine mdiv 2 * 8 + blockColumn mdiv 2); 683 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 684 end for; 685 end if; 686 end for; 687 for blockLine range 8 to 15 do 688 line := mcuTopLine + blockLine; 689 if line <= header.height then 690 for blockColumn range 0 to blockColumnMax1 do 691 column := mcuLeftColumn + blockColumn; 692 luminance := luma3[(blockLine - 8) * 8 + blockColumn + 1] mdiv 8 + 128; 693 dataIndex := succ(blockLine mdiv 2 * 8 + blockColumn mdiv 2); 694 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 695 end for; 696 for blockColumn range 8 to blockColumnMax2 do 697 column := mcuLeftColumn + blockColumn; 698 luminance := luma4[(blockLine - 8) * 8 + blockColumn - 8 + 1] mdiv 8 + 128; 699 dataIndex := succ(blockLine mdiv 2 * 8 + blockColumn mdiv 2); 700 image[line][column] := setPixel(luminance, chromaBlue[dataIndex], chromaRed[dataIndex]); 701 end for; 702 end if; 703 end for; 704 end func; 705 706 707const proc: setupQuantization (inout jpegHeader: header) is func 708 begin 709 header.lumaQuantization := header.quantizationTable[header.component[1].quantizationTableIndex]; 710 if length(header.component) >= 2 then 711 header.chromaBlueQuantization := header.quantizationTable[header.component[2].quantizationTableIndex]; 712 if length(header.component) >= 3 then 713 header.chromaRedQuantization := header.quantizationTable[header.component[3].quantizationTableIndex]; 714 end if; 715 end if; 716 end func; 717 718 719## 720# Read an entropy coded segment. 721# The start of the next segment (e.g. Reset) ends the entropy coded segment. 722# In the segment the sequence "\16#ff;\0;" is replaced by "\16#ff;". 723# The segment ends, if a "\16#ff;" is not followed by "\0;" (introducing 724# the start of the next segment). The char after "\16#ff;" is stored in 725# bufferChar. Before the segment is returned "\16#ff;\16#ff;" is appended. 726# This allows a peek of 16 bits also at the end of the segment. 727# 728const func string: readEntropyCodedSegment (inout file: jpegFile) is func 729 result 730 var string: ecsData is ""; 731 local 732 var char: ch is ' '; 733 begin 734 repeat 735 ch := getc(jpegFile); 736 while ch <> JPEG_MARKER_START and ch <> EOF do 737 ecsData &:= ch; 738 ch := getc(jpegFile); 739 end while; 740 if ch = JPEG_MARKER_START then 741 ch := getc(jpegFile); 742 if ch = '\0;' then 743 ecsData &:= JPEG_MARKER_START; 744 end if; 745 end if; 746 until ch <> '\0;'; 747 ecsData &:= "\16#ff;\16#ff;"; 748 jpegFile.bufferChar := ch; 749 end func; 750 751 752const proc: loadMonochromeImage (inout file: jpegFile, in jpegHeader: header, 753 in huffmanTable: dcLumaTable, in huffmanTable: acLumaTable, 754 inout array array pixel: image) is func 755 local 756 var string: entropyCodedSegment is ""; 757 var integer: bytePos is 1; 758 var integer: bitPos is 0; 759 var integer: mcuTopLine is 0; 760 var integer: mcuLeftColumn is 0; 761 var integer: line is 0; 762 var integer: mcuCount is 0; 763 var integer: diffLuminance is 0; 764 var array integer: luma is JPEG_BLOCK_SIZE times 0; 765 var integer: blockLine is 0; 766 var integer: blockLineMax is 0; 767 var integer: blockColumn is 0; 768 var integer: blockColumnMax is 0; 769 var integer: grayIntensity is 0; 770 begin 771 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 772 image := header.height times header.width times pixel.value; 773 for mcuTopLine range 1 to header.height step 8 do 774 blockLineMax := min(7, header.height - mcuTopLine); 775 for mcuLeftColumn range 1 to header.width step 8 do 776 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 777 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 778 bytePos := 1; 779 bitPos := 0; 780 diffLuminance := 0; 781 end if; 782 processBlock(luma, entropyCodedSegment, bytePos, bitPos, 783 dcLumaTable, acLumaTable, header.lumaQuantization, diffLuminance); 784 blockColumnMax := min(7, header.width - mcuLeftColumn); 785 for blockLine range 0 to blockLineMax do 786 line := mcuTopLine + blockLine; 787 for blockColumn range 0 to blockColumnMax do 788 grayIntensity := clampColor(luma[succ(blockLine * 8 + blockColumn)] mdiv 8 + 128); 789 image[line][mcuLeftColumn + blockColumn] := 790 rgbPixel(grayIntensity, grayIntensity, grayIntensity); 791 end for; 792 end for; 793 incr(mcuCount); 794 end for; 795 end for; 796 end func; 797 798 799const proc: loadColorImage (inout file: jpegFile, in jpegHeader: header, 800 in huffmanTable: dcLumaTable, in huffmanTable: acLumaTable, 801 in huffmanTable: dcChromaBlueTable, in huffmanTable: acChromaBlueTable, 802 in huffmanTable: dcChromaRedTable, in huffmanTable: acChromaRedTable, 803 inout array array pixel: image) is func 804 local 805 var string: entropyCodedSegment is ""; 806 var integer: bytePos is 1; 807 var integer: bitPos is 0; 808 var integer: line is 0; 809 var integer: column is 0; 810 var integer: mcuCount is 0; 811 var integer: index is 0; 812 var integer: diffLuminance is 0; 813 var integer: diffChromaBlue is 0; 814 var integer: diffChromaRed is 0; 815 var array array integer: luma is 4 times JPEG_BLOCK_SIZE times 0; 816 var array integer: chromaBlue is JPEG_BLOCK_SIZE times 0; 817 var array integer: chromaRed is JPEG_BLOCK_SIZE times 0; 818 begin 819 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 820 image := header.height times header.width times pixel.value; 821 for line range 1 to header.height step header.vertical * 8 do 822 for column range 1 to header.width step header.horizontal * 8 do 823 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 824 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 825 bytePos := 1; 826 bitPos := 0; 827 diffLuminance := 0; 828 diffChromaBlue := 0; 829 diffChromaRed := 0; 830 end if; 831 for index range 1 to header.numLuma do 832 processBlock(luma[index], entropyCodedSegment, bytePos, bitPos, 833 dcLumaTable, acLumaTable, header.lumaQuantization, 834 diffLuminance); 835 end for; 836 processBlock(chromaBlue, entropyCodedSegment, bytePos, bitPos, 837 dcChromaBlueTable, acChromaBlueTable, 838 header.chromaBlueQuantization, diffChromaBlue); 839 processBlock(chromaRed, entropyCodedSegment, bytePos, bitPos, 840 dcChromaRedTable, acChromaRedTable, 841 header.chromaRedQuantization, diffChromaRed); 842 if header.horizontal = 1 then 843 if header.vertical = 1 then 844 colorMinimumCodedUnit11(header, luma[1], chromaBlue, chromaRed, 845 image, line, column); 846 else 847 colorMinimumCodedUnit12(header, luma[1], luma[2], 848 chromaBlue, chromaRed, image, line, column); 849 end if; 850 else 851 if header.vertical = 1 then 852 colorMinimumCodedUnit21(header, luma[1], luma[2], 853 chromaBlue, chromaRed, image, line, column); 854 else 855 colorMinimumCodedUnit22(header, luma[1], luma[2], luma[3], luma[4], 856 chromaBlue, chromaRed, image, line, column); 857 end if; 858 end if; 859 incr(mcuCount); 860 end for; 861 end for; 862 end func; 863 864 865const func PRIMITIVE_WINDOW: loadSequential (inout file: jpegFile, in jpegHeader: header) is func 866 result 867 var PRIMITIVE_WINDOW: pixmap is PRIMITIVE_WINDOW.value; 868 local 869 var integer: dcLumaIndex is 0; 870 var integer: acLumaIndex is 0; 871 var integer: dcCbIndex is 0; 872 var integer: acCbIndex is 0; 873 var integer: dcCrIndex is 0; 874 var integer: acCrIndex is 0; 875 var array array pixel: image is 0 times 0 times pixel.value; 876 begin 877 if header.scan[1].comptype <> JPEG_COMPTYPE_LUMA then 878 raise RANGE_ERROR; 879 end if; 880 dcLumaIndex := header.scan[1].dcHuffmanTableIndex; 881 acLumaIndex := header.scan[1].acHuffmanTableIndex; 882 if header.numberOfScans = 1 then 883 loadMonochromeImage(jpegFile, header, header.dcTable[dcLumaIndex], 884 header.acTable[acLumaIndex], image); 885 elsif header.numberOfScans = 3 then 886 if header.scan[2].comptype <> JPEG_COMPTYPE_CHROMA_BLUE or 887 header.scan[3].comptype <> JPEG_COMPTYPE_CHROMA_RED then 888 raise RANGE_ERROR; 889 end if; 890 dcCbIndex := header.scan[2].dcHuffmanTableIndex; 891 acCbIndex := header.scan[2].acHuffmanTableIndex; 892 dcCrIndex := header.scan[3].dcHuffmanTableIndex; 893 acCrIndex := header.scan[3].acHuffmanTableIndex; 894 loadColorImage(jpegFile, header, 895 header.dcTable[dcLumaIndex], header.acTable[acLumaIndex], 896 header.dcTable[dcCbIndex], header.acTable[acCbIndex], 897 header.dcTable[dcCrIndex], header.acTable[acCrIndex], 898 image); 899 else 900 raise RANGE_ERROR; 901 end if; 902 pixmap := imagePixmap(image); 903 end func; 904 905 906## 907# Read the DC coefficient of a block. 908# 909const proc: readDcValue (inout integer: dcCoefficient, 910 in string: stri, inout integer: bytePos, inout integer: bitPos, 911 in huffmanTable: dcTable, inout integer: diff, 912 in integer: approximationLow) is func 913 914 local 915 var integer: bitWidth is 0; 916 var integer: aValue is 0; 917 begin 918 bitWidth := getHuffmanSymbolMsb(stri, bytePos, bitPos, dcTable); 919 if bitWidth <> 0 then 920 aValue := getSymbol(stri, bytePos, bitPos, bitWidth); 921 end if; 922 aValue +:= diff; 923 diff := aValue; 924 dcCoefficient := aValue << approximationLow; 925 end func; 926 927 928const proc: readLumaDcOfAllBlocks (inout file: jpegFile, in jpegHeader: header, 929 in huffmanTable: dcTable, inout array array jpegMinimumCodedUnit: mcuImage) is func 930 local 931 var string: entropyCodedSegment is ""; 932 var integer: bytePos is 1; 933 var integer: bitPos is 0; 934 var integer: line is 0; 935 var integer: column is 0; 936 var integer: index is 0; 937 var integer: diffLuminance is 0; 938 var integer: mcuCount is 0; 939 begin 940 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 941 for line range 1 to header.blockLines do 942 for column range 1 to header.blockColumns do 943 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 944 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 945 bytePos := 1; 946 bitPos := 0; 947 diffLuminance := 0; 948 end if; 949 index := succ(2 * (pred(line) mod header.vertical) + pred(column) mod header.horizontal); 950 readDcValue(mcuImage[succ(pred(line) mdiv header.vertical)] 951 [succ(pred(column) mdiv header.horizontal)].luma[index][1], 952 entropyCodedSegment, bytePos, bitPos, dcTable, 953 diffLuminance, header.approximationLow); 954 incr(mcuCount); 955 end for; 956 end for; 957 end func; 958 959 960const proc: readDcValuesOfAllBlocks (inout file: jpegFile, in jpegHeader: header, 961 in integer: dcLumaIndex, in integer: dcCbIndex, in integer: dcCrIndex, 962 inout array array jpegMinimumCodedUnit: mcuImage) is func 963 local 964 var string: entropyCodedSegment is ""; 965 var integer: bytePos is 1; 966 var integer: bitPos is 0; 967 var integer: line is 0; 968 var integer: column is 0; 969 var integer: index is 0; 970 var integer: diffLuminance is 0; 971 var integer: diffChromaBlue is 0; 972 var integer: diffChromaRed is 0; 973 var integer: mcuCount is 0; 974 begin 975 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 976 for line range 1 to header.unitLines do 977 for column range 1 to header.unitColumns do 978 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 979 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 980 bytePos := 1; 981 bitPos := 0; 982 diffLuminance := 0; 983 diffChromaBlue := 0; 984 diffChromaRed := 0; 985 end if; 986 if dcLumaIndex <> 0 then 987 for index range 1 to header.numLuma do 988 readDcValue(mcuImage[line][column].luma[index][1], 989 entropyCodedSegment, bytePos, bitPos, header.dcTable[dcLumaIndex], 990 diffLuminance, header.approximationLow); 991 end for; 992 end if; 993 if dcCbIndex <> 0 then 994 readDcValue(mcuImage[line][column].chroma[CHROMA_BLUE][1], 995 entropyCodedSegment, bytePos, bitPos, header.dcTable[dcCbIndex], 996 diffChromaBlue, header.approximationLow); 997 end if; 998 if dcCrIndex <> 0 then 999 readDcValue(mcuImage[line][column].chroma[CHROMA_RED][1], 1000 entropyCodedSegment, bytePos, bitPos, header.dcTable[dcCrIndex], 1001 diffChromaRed, header.approximationLow); 1002 end if; 1003 incr(mcuCount); 1004 end for; 1005 end for; 1006 end func; 1007 1008 1009const proc: refineDcValuesOfAllBlocks (inout file: jpegFile, in jpegHeader: header, 1010 in integer: dcLumaIndex, in integer: dcCbIndex, in integer: dcCrIndex, 1011 inout array array jpegMinimumCodedUnit: mcuImage) is func 1012 local 1013 var string: entropyCodedSegment is ""; 1014 var integer: bytePos is 1; 1015 var integer: bitPos is 0; 1016 var integer: line is 0; 1017 var integer: column is 0; 1018 var integer: index is 0; 1019 var integer: mcuCount is 0; 1020 begin 1021 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1022 for line range 1 to header.unitLines do 1023 for column range 1 to header.unitColumns do 1024 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 1025 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1026 bytePos := 1; 1027 bitPos := 0; 1028 end if; 1029 if dcLumaIndex <> 0 then 1030 for index range 1 to header.numLuma do 1031 if getBitMsb(entropyCodedSegment, bytePos, bitPos) <> 0 then 1032 mcuImage[line][column].luma[index][1] +:= 1 << header.approximationLow; 1033 end if; 1034 end for; 1035 end if; 1036 if dcCbIndex <> 0 then 1037 if getBitMsb(entropyCodedSegment, bytePos, bitPos) <> 0 then 1038 mcuImage[line][column].chroma[CHROMA_BLUE][1] +:= 1 << header.approximationLow; 1039 end if; 1040 end if; 1041 if dcCrIndex <> 0 then 1042 if getBitMsb(entropyCodedSegment, bytePos, bitPos) <> 0 then 1043 mcuImage[line][column].chroma[CHROMA_RED][1] +:= 1 << header.approximationLow; 1044 end if; 1045 end if; 1046 incr(mcuCount); 1047 end for; 1048 end for; 1049 end func; 1050 1051 1052## 1053# Read the AC coefficients of a block. 1054# 1055const proc: readBlockAc (inout array integer: dataBlock, 1056 in string: stri, inout integer: bytePos, inout integer: bitPos, 1057 in huffmanTable: acTable, in integer: startOfSpectral, 1058 in integer: endOfSpectral, inout integer: eobRunLength, 1059 in integer: approximationLow) is func 1060 local 1061 var integer: bitWidth is 0; 1062 var integer: index is 1; 1063 var integer: aByte is 0; 1064 var integer: zeros is 0; 1065 var integer: bits is 0; 1066 begin 1067 index := pred(startOfSpectral); 1068 repeat 1069 aByte := getHuffmanSymbolMsb(stri, bytePos, bitPos, acTable); 1070 zeros := aByte >> 4; 1071 bitWidth := aByte mod 16; 1072 if bitWidth = 0 then 1073 if zeros = 15 then 1074 index +:= 16; 1075 if index >= JPEG_BLOCK_SIZE then 1076 raise RANGE_ERROR; 1077 end if; 1078 else 1079 eobRunLength := 1 << zeros; 1080 if zeros <> 0 then 1081 bits := getBitsMsb(stri, bytePos, bitPos, zeros); 1082 eobRunLength +:= bits; 1083 end if; 1084 decr(eobRunLength); 1085 aByte := 0; 1086 end if; 1087 else 1088 index +:= succ(zeros); 1089 dataBlock[index] := getSymbol(stri, bytePos, bitPos, bitWidth) << approximationLow; 1090 if index = endOfSpectral then 1091 aByte := 0; 1092 end if; 1093 end if; 1094 until aByte = 0; 1095 end func; 1096 1097 1098const proc: readLumaAcOfAllBlocks (inout file: jpegFile, in jpegHeader: header, 1099 in huffmanTable: acTable, inout array array jpegMinimumCodedUnit: mcuImage) is func 1100 local 1101 var string: entropyCodedSegment is ""; 1102 var integer: bytePos is 1; 1103 var integer: bitPos is 0; 1104 var integer: line is 0; 1105 var integer: column is 0; 1106 var integer: index is 0; 1107 var integer: mcuCount is 0; 1108 var integer: eobRunLength is 0; 1109 begin 1110 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1111 for line range 1 to header.blockLines do 1112 for column range 1 to header.blockColumns do 1113 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 1114 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1115 bytePos := 1; 1116 bitPos := 0; 1117 end if; 1118 if eobRunLength > 0 then 1119 decr(eobRunLength); 1120 else 1121 index := succ(2 * (pred(line) mod header.vertical) + pred(column) mod header.horizontal); 1122 readBlockAc(mcuImage[succ(pred(line) mdiv header.vertical)] 1123 [succ(pred(column) mdiv header.horizontal)].luma[index], 1124 entropyCodedSegment, bytePos, bitPos, acTable, 1125 header.startOfSpectral, header.endOfSpectral, 1126 eobRunLength, header.approximationLow); 1127 end if; 1128 incr(mcuCount); 1129 end for; 1130 end for; 1131 end func; 1132 1133 1134const proc: readChromaAcOfAllBlocks (inout file: jpegFile, in jpegHeader: header, 1135 in huffmanTable: acTable, inout array array jpegMinimumCodedUnit: mcuImage, 1136 in integer: chromaIndex) is func 1137 local 1138 var string: entropyCodedSegment is ""; 1139 var integer: bytePos is 1; 1140 var integer: bitPos is 0; 1141 var integer: line is 0; 1142 var integer: column is 0; 1143 var integer: mcuCount is 0; 1144 var integer: eobRunLength is 0; 1145 begin 1146 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1147 for line range 1 to header.unitLines do 1148 for column range 1 to header.unitColumns do 1149 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 1150 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1151 bytePos := 1; 1152 bitPos := 0; 1153 end if; 1154 if eobRunLength > 0 then 1155 decr(eobRunLength); 1156 else 1157 readBlockAc(mcuImage[line][column].chroma[chromaIndex], 1158 entropyCodedSegment, bytePos, bitPos, acTable, 1159 header.startOfSpectral, header.endOfSpectral, 1160 eobRunLength, header.approximationLow); 1161 end if; 1162 incr(mcuCount); 1163 end for; 1164 end for; 1165 end func; 1166 1167 1168const proc: refineNonZeroes (inout array integer: dataBlock, 1169 in string: stri, inout integer: bytePos, inout integer: bitPos, 1170 inout integer: spectral, in integer: endOfSpectral, 1171 in var integer: numberOfZeros, in integer: delta) is func 1172 local 1173 var boolean: enoughZeros is FALSE; 1174 var integer: bit is 0; 1175 begin 1176 while spectral <= endOfSpectral and not enoughZeros do 1177 if dataBlock[spectral] = 0 then 1178 if numberOfZeros = 0 then 1179 enoughZeros := TRUE; 1180 else 1181 decr(numberOfZeros); 1182 incr(spectral); 1183 end if; 1184 else 1185 bit := getBitMsb(stri, bytePos, bitPos); 1186 if bit <> 0 then 1187 if dataBlock[spectral] >= 0 then 1188 dataBlock[spectral] +:= delta; 1189 else 1190 dataBlock[spectral] -:= delta; 1191 end if; 1192 end if; 1193 incr(spectral); 1194 end if; 1195 end while; 1196 end func; 1197 1198 1199## 1200# Refine the AC coefficients of a block. 1201# 1202const proc: refineBlockAc (inout array integer: dataBlock, 1203 in string: stri, inout integer: bytePos, inout integer: bitPos, 1204 in huffmanTable: acTable, in integer: startOfSpectral, 1205 in integer: endOfSpectral, inout integer: eobRunLength, in integer: delta) is func 1206 local 1207 var integer: spectral is 0; 1208 var integer: coefficient is 0; 1209 var integer: bit is 0; 1210 var integer: aByte is 0; 1211 var integer: zeros is 0; 1212 var integer: bitWidth is 0; 1213 var integer: bits is 0; 1214 begin 1215 spectral := startOfSpectral; 1216 while spectral <= endOfSpectral and eobRunLength = 0 do 1217 coefficient := 0; 1218 aByte := getHuffmanSymbolMsb(stri, bytePos, bitPos, acTable); 1219 zeros := aByte >> 4; 1220 bitWidth := aByte mod 16; 1221 if bitWidth = 0 then 1222 if zeros <> 15 then 1223 eobRunLength := 1 << zeros; 1224 if zeros <> 0 then 1225 bits := getBitsMsb(stri, bytePos, bitPos, zeros); 1226 eobRunLength +:= bits; 1227 end if; 1228 end if; 1229 elsif bitWidth = 1 then 1230 coefficient := delta; 1231 bit := getBitMsb(stri, bytePos, bitPos); 1232 if bit = 0 then 1233 coefficient := -coefficient; 1234 end if; 1235 else 1236 raise RANGE_ERROR; 1237 end if; 1238 if eobRunLength = 0 then 1239 refineNonZeroes(dataBlock, stri, bytePos, bitPos, spectral, endOfSpectral, zeros, delta); 1240 if spectral > endOfSpectral then 1241 raise RANGE_ERROR; 1242 end if; 1243 if coefficient <> 0 then 1244 dataBlock[spectral] := coefficient; 1245 end if; 1246 incr(spectral); 1247 end if; 1248 end while; 1249 if eobRunLength > 0 then 1250 decr(eobRunLength); 1251 refineNonZeroes(dataBlock, stri, bytePos, bitPos, spectral, endOfSpectral, -1, delta); 1252 end if; 1253 end func; 1254 1255 1256const proc: refineLumaAcOfAllBlocks (inout file: jpegFile, in jpegHeader: header, 1257 in huffmanTable: acTable, inout array array jpegMinimumCodedUnit: mcuImage) is func 1258 local 1259 var string: entropyCodedSegment is ""; 1260 var integer: bytePos is 1; 1261 var integer: bitPos is 0; 1262 var integer: line is 0; 1263 var integer: column is 0; 1264 var integer: index is 0; 1265 var integer: mcuCount is 0; 1266 var integer: eobRunLength is 0; 1267 begin 1268 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1269 for line range 1 to header.blockLines do 1270 for column range 1 to header.blockColumns do 1271 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 1272 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1273 bytePos := 1; 1274 bitPos := 0; 1275 end if; 1276 index := succ(2 * (pred(line) mod header.vertical) + pred(column) mod header.horizontal); 1277 refineBlockAc(mcuImage[succ(pred(line) mdiv header.vertical)] 1278 [succ(pred(column) mdiv header.horizontal)].luma[index], 1279 entropyCodedSegment, bytePos, bitPos, acTable, 1280 header.startOfSpectral, header.endOfSpectral, 1281 eobRunLength, 1 << header.approximationLow); 1282 incr(mcuCount); 1283 end for; 1284 end for; 1285 end func; 1286 1287 1288const proc: refineChromaAcOfAllBlocks (inout file: jpegFile, in jpegHeader: header, 1289 in huffmanTable: acTable, inout array array jpegMinimumCodedUnit: mcuImage, 1290 in integer: chromaIndex) is func 1291 local 1292 var string: entropyCodedSegment is ""; 1293 var integer: bytePos is 1; 1294 var integer: bitPos is 0; 1295 var integer: line is 0; 1296 var integer: column is 0; 1297 var integer: mcuCount is 0; 1298 var integer: eobRunLength is 0; 1299 begin 1300 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1301 for line range 1 to header.unitLines do 1302 for column range 1 to header.unitColumns do 1303 if header.restartInterval <> 0 and mcuCount rem header.restartInterval = 0 and mcuCount > 0 then 1304 entropyCodedSegment := readEntropyCodedSegment(jpegFile); 1305 bytePos := 1; 1306 bitPos := 0; 1307 end if; 1308 refineBlockAc(mcuImage[line][column].chroma[chromaIndex], 1309 entropyCodedSegment, bytePos, bitPos, acTable, 1310 header.startOfSpectral, header.endOfSpectral, 1311 eobRunLength, 1 << header.approximationLow); 1312 incr(mcuCount); 1313 end for; 1314 end for; 1315 end func; 1316 1317 1318const proc: loadProgressive (inout file: jpegFile, in jpegHeader: header, 1319 inout array array jpegMinimumCodedUnit: mcuImage) is func 1320 local 1321 var integer: dcLumaIndex is 0; 1322 var integer: dcCbIndex is 0; 1323 var integer: dcCrIndex is 0; 1324 var integer: acLumaIndex is 0; 1325 var integer: acCbIndex is 0; 1326 var integer: acCrIndex is 0; 1327 var integer: index is 0; 1328 begin 1329 for index range 1 to header.numberOfScans do 1330 case header.scan[index].comptype of 1331 when {JPEG_COMPTYPE_LUMA}: 1332 dcLumaIndex := header.scan[index].dcHuffmanTableIndex; 1333 acLumaIndex := header.scan[index].acHuffmanTableIndex; 1334 when {JPEG_COMPTYPE_CHROMA_BLUE}: 1335 dcCbIndex := header.scan[index].dcHuffmanTableIndex; 1336 acCbIndex := header.scan[index].acHuffmanTableIndex; 1337 when {JPEG_COMPTYPE_CHROMA_RED}: 1338 dcCrIndex := header.scan[index].dcHuffmanTableIndex; 1339 acCrIndex := header.scan[index].acHuffmanTableIndex; 1340 otherwise: 1341 raise RANGE_ERROR; 1342 end case; 1343 end for; 1344 if header.startOfSpectral = 1 and header.endOfSpectral = 1 then 1345 if header.approximationHigh = 0 then 1346 if dcLumaIndex <> 0 and dcCbIndex = 0 and dcCrIndex = 0 then 1347 readLumaDcOfAllBlocks(jpegFile, header, header.dcTable[dcLumaIndex], 1348 mcuImage); 1349 else 1350 readDcValuesOfAllBlocks(jpegFile, header, dcLumaIndex, 1351 dcCbIndex, dcCrIndex, mcuImage); 1352 end if; 1353 else 1354 refineDcValuesOfAllBlocks(jpegFile, header, dcLumaIndex, 1355 dcCbIndex, dcCrIndex, mcuImage); 1356 end if; 1357 elsif header.approximationHigh = 0 then 1358 if acLumaIndex <> 0 then 1359 readLumaAcOfAllBlocks(jpegFile, header, header.acTable[acLumaIndex], 1360 mcuImage); 1361 elsif acCbIndex <> 0 then 1362 readChromaAcOfAllBlocks(jpegFile, header, header.acTable[acCbIndex], 1363 mcuImage, CHROMA_BLUE); 1364 elsif acCrIndex <> 0 then 1365 readChromaAcOfAllBlocks(jpegFile, header, header.acTable[acCrIndex], 1366 mcuImage, CHROMA_RED); 1367 end if; 1368 else 1369 if acLumaIndex <> 0 then 1370 refineLumaAcOfAllBlocks(jpegFile, header, header.acTable[acLumaIndex], 1371 mcuImage); 1372 elsif acCbIndex <> 0 then 1373 refineChromaAcOfAllBlocks(jpegFile, header, header.acTable[acCbIndex], 1374 mcuImage, CHROMA_BLUE); 1375 elsif acCrIndex <> 0 then 1376 refineChromaAcOfAllBlocks(jpegFile, header, header.acTable[acCrIndex], 1377 mcuImage, CHROMA_RED); 1378 end if; 1379 end if; 1380 end func; 1381 1382 1383## 1384# Process a 8x8 block of IDCT coefficients. 1385# This function is used for luma and chroma blocks. 1386# The resulting block contains luma or chroma values of an 8x8 1387# area scaled with factor 8 to the range -1024 .. 1023. 1388# The values are not clamped so they might also be higher or 1389# lower than the limit. 1390# 1391const proc: processBlock (inout array integer: dataBlock, in array integer: quantizationTable) is func 1392 local 1393 var integer: index is 0; 1394 begin 1395 for index range 1 to JPEG_BLOCK_SIZE do 1396 dataBlock[index] *:= quantizationTable[index]; 1397 end for; 1398 dataBlock := unzigzag(dataBlock); 1399 idct8x8(dataBlock); 1400 end func; 1401 1402 1403const proc: colorMinimumCodedUnit (in jpegHeader: header, 1404 inout jpegMinimumCodedUnit: minimumCodedUnit, 1405 in array integer: lumaQuantization, in array integer: chromaBlueQuantization, 1406 in array integer: chromaRedQuantization, inout array array pixel: image, 1407 in integer: line, in integer: column) is func 1408 local 1409 var integer: index is 0; 1410 begin 1411 for index range 1 to header.numLuma do 1412 processBlock(minimumCodedUnit.luma[index], lumaQuantization); 1413 end for; 1414 processBlock(minimumCodedUnit.chroma[CHROMA_BLUE], chromaBlueQuantization); 1415 processBlock(minimumCodedUnit.chroma[CHROMA_RED], chromaRedQuantization); 1416 1417 if header.horizontal = 1 then 1418 if header.vertical = 1 then 1419 colorMinimumCodedUnit11(header, minimumCodedUnit.luma[1], 1420 minimumCodedUnit.chroma[CHROMA_BLUE], 1421 minimumCodedUnit.chroma[CHROMA_RED], 1422 image, line, column); 1423 else 1424 colorMinimumCodedUnit12(header, minimumCodedUnit.luma[1], 1425 minimumCodedUnit.luma[2], 1426 minimumCodedUnit.chroma[CHROMA_BLUE], 1427 minimumCodedUnit.chroma[CHROMA_RED], 1428 image, line, column); 1429 end if; 1430 else 1431 if header.vertical = 1 then 1432 colorMinimumCodedUnit21(header, minimumCodedUnit.luma[1], 1433 minimumCodedUnit.luma[2], 1434 minimumCodedUnit.chroma[CHROMA_BLUE], 1435 minimumCodedUnit.chroma[CHROMA_RED], 1436 image, line, column); 1437 else 1438 colorMinimumCodedUnit22(header, minimumCodedUnit.luma[1], 1439 minimumCodedUnit.luma[2], 1440 minimumCodedUnit.luma[3], 1441 minimumCodedUnit.luma[4], 1442 minimumCodedUnit.chroma[CHROMA_BLUE], 1443 minimumCodedUnit.chroma[CHROMA_RED], 1444 image, line, column); 1445 end if; 1446 end if; 1447 end func; 1448 1449 1450const func PRIMITIVE_WINDOW: colorAllMinimumCodedUnits (in jpegHeader: header, 1451 inout array array jpegMinimumCodedUnit: mcuImage, in array integer: lumaQuantization, 1452 in array integer: chromaBlueQuantization, in array integer: chromaRedQuantization) is func 1453 result 1454 var PRIMITIVE_WINDOW: pixmap is PRIMITIVE_WINDOW.value; 1455 local 1456 var integer: line is 0; 1457 var integer: column is 0; 1458 var array array pixel: image is 0 times 0 times pixel.value; 1459 begin 1460 image := header.height times header.width times pixel.value; 1461 for line range 1 to length(mcuImage) do 1462 for column range 1 to length(mcuImage[line]) do 1463 colorMinimumCodedUnit(header, mcuImage[line][column], 1464 lumaQuantization, chromaBlueQuantization, 1465 chromaRedQuantization, image, 1466 succ(pred(line) * 8 * header.vertical), 1467 succ(pred(column) * 8 * header.horizontal)); 1468 end for; 1469 end for; 1470 pixmap := imagePixmap(image); 1471 end func; 1472 1473 1474(** 1475 * Reads a JPEG file into a pixmap. 1476 * @param jpegFile File that contains a JPEG image. 1477 * @return A pixmap with the JPEG image, or 1478 * PRIMITIVE_WINDOW.value if the the file does 1479 * not contain a JPEG magic number. 1480 * @exception RANGE_ERROR The file is not in the JPEG file format. 1481 *) 1482const func PRIMITIVE_WINDOW: readJpeg (inout file: jpegFile) is func 1483 result 1484 var PRIMITIVE_WINDOW: pixmap is PRIMITIVE_WINDOW.value; 1485 local 1486 var string: magic is ""; 1487 var boolean: readMarker is TRUE; 1488 var char: segmentMarker is ' '; 1489 var boolean: endOfImage is FALSE; 1490 var jpegHeader: header is jpegHeader.value; 1491 var array array jpegMinimumCodedUnit: mcuImage is 0 times 0 times jpegMinimumCodedUnit.value; 1492 begin 1493 magic := gets(jpegFile, length(JPEG_MAGIC)); 1494 if magic = JPEG_MAGIC then 1495 pixmap := newPixmap(1, 1); # Initialize graphic 1496 # Start Of Image (SOI) 1497 repeat 1498 if readMarker then 1499 segmentMarker := getc(jpegFile); 1500 end if; 1501 readMarker := TRUE; 1502 case segmentMarker of 1503 when {JPEG_SOF0, JPEG_SOF1}: 1504 readStartOfFrame(jpegFile, header); 1505 when {JPEG_SOF2}: 1506 readStartOfFrame(jpegFile, header); 1507 header.progressive := TRUE; 1508 mcuImage := header.unitLines times header.unitColumns times jpegMinimumCodedUnit.value; 1509 when {JPEG_DHT}: 1510 readDefineHuffmanTable(jpegFile, header); 1511 when {JPEG_EOI}: 1512 # End Of Image 1513 endOfImage := TRUE; 1514 readMarker := FALSE; 1515 when {JPEG_SOS}: 1516 readStartOfScan(jpegFile, header); 1517 if header.progressive then 1518 loadProgressive(jpegFile, header, mcuImage); 1519 else 1520 setupQuantization(header); 1521 pixmap := loadSequential(jpegFile, header); 1522 end if; 1523 segmentMarker := jpegFile.bufferChar; 1524 readMarker := FALSE; 1525 when {JPEG_DQT}: 1526 readDefineQuantizationTable(jpegFile, header); 1527 when {JPEG_DRI}: 1528 readDefineRestartInterval(jpegFile, header); 1529 when {JPEG_APP0 .. JPEG_APP15}: 1530 readApplicationSegment(jpegFile, ord(segmentMarker) - ord(JPEG_APP0)); 1531 when {JPEG_COM}: 1532 readComment(jpegFile); 1533 when {JPEG_FILLER}: 1534 # Fill byte (16#ff), which is ignored. 1535 segmentMarker := getc(jpegFile); 1536 readMarker := FALSE; 1537 otherwise: 1538 raise RANGE_ERROR; 1539 end case; 1540 if readMarker and getc(jpegFile) <> JPEG_MARKER_START then 1541 raise RANGE_ERROR; 1542 end if; 1543 until endOfImage; 1544 if header.progressive then 1545 setupQuantization(header); 1546 pixmap := colorAllMinimumCodedUnits(header, mcuImage, 1547 header.lumaQuantization, 1548 header.chromaBlueQuantization, 1549 header.chromaRedQuantization); 1550 end if; 1551 end if; 1552 end func; 1553 1554 1555(** 1556 * Reads a JPEG file with the given ''jpegFileName'' into a pixmap. 1557 * @param jpegFileName Name of the JPEG file. 1558 * @return A pixmap with the JPEG image, or 1559 * PRIMITIVE_WINDOW.value if the file cannot be opened or 1560 * does not contain a JPEG magic number. 1561 * @exception RANGE_ERROR The file is not in the JPEG file format. 1562 *) 1563const func PRIMITIVE_WINDOW: readJpeg (in string: jpegFileName) is func 1564 result 1565 var PRIMITIVE_WINDOW: pixmap is PRIMITIVE_WINDOW.value; 1566 local 1567 var file: jpegFile is STD_NULL; 1568 begin 1569 jpegFile := open(jpegFileName, "r"); 1570 if jpegFile <> STD_NULL then 1571 pixmap := readJpeg(jpegFile); 1572 close(jpegFile); 1573 end if; 1574 end func; 1575