Posted to tcl by dbohdan at Fri Oct 12 20:11:52 GMT 2018view raw

  1. # PTJD, a pure Tcl (baseline) JPEG decoder.
  2. # Copyright (c) 2017 dbohdan and contributors listed in AUTHORS
  3. # License: MIT.
  4. namespace eval ::ptjd {
  5. variable version 0.1.0
  6. variable inverseDctMatrix {}
  7.  
  8. # Precompute the inverse DCT matrix.
  9. set pi 3.1415926535897931
  10. for {set x 0} {$x < 8} {incr x} {
  11. for {set u 0} {$u < 8} {incr u} {
  12. set alpha [expr {$u == 0 ? 1/sqrt(2) : 1}]
  13. lappend inverseDctMatrix [expr {
  14. $alpha * cos(((2*$x + 1) * $u * $pi)/16.0)
  15. }]
  16. }
  17. }
  18. unset alpha pi u x
  19. }
  20.  
  21. proc ::escape-unprintable s {
  22. set result {}
  23. foreach c [split $s {}] {
  24. set code [scan $c %c]
  25. if {(0x20 <= $code) && ($code <= 0x7F)} {
  26. append result $c
  27. } else {
  28. append result [format \\x%X $code]
  29. }
  30. }
  31. return $result
  32. }
  33.  
  34. proc ::ptjd::assert-equal {actual expected} {
  35. if {$actual ne $expected} {
  36. error "expected \"[escape-unprintable $expected]\",\
  37. but got \"[escape-unprintable $actual]\""
  38. }
  39. }
  40.  
  41. # Convert an integer to a string of binary digits. A [format %0${width}b $x]
  42. # substitute for Tcl 8.5.
  43. proc ::ptjd::int-to-binary-digits {x {width 0}} {
  44. # The credit for the trick used here goes to RS (https://tcl.wiki/15598).
  45. set bin [string trimleft [string map {
  46. 0 0000 1 0001 2 0010 3 0011 4 0100 5 0101 6 0110 7 0111
  47. 8 1000 9 1001 a 1010 b 1011 c 1100 d 1101 e 1110 f 1111
  48. } [format %x $x]] 0]
  49. if {($width) > 0 && ([string length $bin] < $width)} {
  50. set bin [string repeat 0 [expr {$width - [string length $bin]}]]$bin
  51. }
  52. return $bin
  53. }
  54.  
  55. proc ::ptjd::generate-huffman-codes table {
  56. set prefixes {}
  57. set codes {}
  58. for {set i 1} {$i <= 16} {incr i} {
  59. set values [lindex $table $i-1]
  60. for {set j 0} {($values ne {}) && ($j < (1 << $i))} {incr j} {
  61. set used 0
  62. foreach {prLen prefix} $prefixes {
  63. if {$j >> ($i - $prLen) == $prefix} {
  64. set used 1
  65. break
  66. }
  67. }
  68. if {$used} { continue }
  69. set values [lassign $values value]
  70. dict set codes [int-to-binary-digits $j $i] $value
  71. lappend prefixes $i $j
  72. }
  73. if {$values ne {}} {
  74. error "couldn't assign codes to values [list $values] (length $i)"
  75. }
  76. }
  77. return $codes
  78. }
  79.  
  80. # [binary scan] the variable $data in the caller's scope starting at the offset
  81. # $ptr in the same scope. Store the results in the variables listed in $args.
  82. proc ::ptjd::scan-at-ptr {format args} {
  83. upvar 1 data data ptr ptr
  84. foreach varName $args {
  85. upvar 1 $varName $varName
  86. }
  87. binary scan $data [concat @$ptr $format] {*}$args
  88. }
  89.  
  90. # Return a list containing the high and the low nibble (4-bit value) of a byte.
  91. proc ::ptjd::hi-lo byte {
  92. set byte [expr {$byte & 0xFF}]
  93. return [list [expr {$byte >> 4}] [expr {$byte & 0x0F}]]
  94. }
  95.  
  96. # Read quantization tables, Huffman tables and APP sections from $data starting
  97. # at $ptr until $until is encountered. Returns a list containing the new values
  98. # for $ptr, $qts, $huffdc and $huffac.
  99. proc ::ptjd::read-tables {until data ptr qts huffdc huffac} {
  100. while {[llength $qts] < 4} {
  101. lappend qts {}
  102. }
  103. while {[llength $huffdc] < 4} {
  104. lappend huffdc {}
  105. }
  106. while {[llength $huffac] < 4} {
  107. lappend huffac {}
  108. }
  109.  
  110. while 1 {
  111. scan-at-ptr {a2 Su} marker length
  112. switch -exact -- $marker {
  113. \xFF\xDB {
  114. # Quantization table.
  115. incr ptr 4
  116. set scanned 2
  117.  
  118. while {$scanned < $length} {
  119. scan-at-ptr {cu cu64} pqtq elements
  120. incr ptr 65
  121. incr scanned 65
  122. lassign [hi-lo $pqtq] pq tq
  123. if {$pq == 1} {
  124. error "16-bit quantization tables aren't supported"
  125. }
  126. lset qts $tq $elements
  127. }
  128. }
  129. \xFF\xC4 {
  130. # Huffman table.
  131. incr ptr 4
  132. set scanned 2
  133.  
  134. while {$scanned < $length} {
  135. scan-at-ptr {cu cu16} tcth bits
  136. incr scanned 17
  137. incr ptr 17
  138. lassign [hi-lo $tcth] tc th
  139. set huffval {}
  140. foreach li $bits {
  141. scan-at-ptr cu$li ln
  142. incr ptr $li
  143. lappend huffval $ln
  144. incr scanned $li
  145. }
  146. if {$tc == 0} {
  147. lset huffdc $th [generate-huffman-codes $huffval]
  148. } else {
  149. lset huffac $th [generate-huffman-codes $huffval]
  150. }
  151. }
  152. }
  153. default {
  154. if {$marker eq $until} {
  155. break
  156. } elseif {("\xFF\xE0" <= $marker) && ($marker <= "\xFF\xEF")} {
  157. # Skip APP0-APPF sections. APP0 is the JFIF header, APP1 is
  158. # the EXIF header, APPE is Adobe info.
  159. incr ptr [expr {$length + 2}]
  160. } else {
  161. error "unsupported section \"[binary encode hex $marker]\"\
  162. at 0x[format %x $ptr]"
  163. }
  164. }
  165. }
  166. }
  167.  
  168. return [list $ptr $qts $huffdc $huffac]
  169. }
  170.  
  171. proc ::ptjd::read-frame-header {data ptr} {
  172. scan-at-ptr {a2 Su} marker length
  173. assert-equal $marker \xFF\xC0
  174. incr ptr 4
  175. scan-at-ptr {cu Su Su cu} p y x nf
  176. incr ptr 6
  177. set components {}
  178. for {set i 0} {$i < $nf} {incr i} {
  179. scan-at-ptr {cu cu cu} c hv tq
  180. incr ptr 3
  181. lassign [hi-lo $hv] h v
  182. lappend components [dict create c $c h $h v $v tq $tq]
  183. }
  184. return [list $ptr [dict create p $p y $y x $x nf $nf \
  185. components $components]]
  186. }
  187. proc ::ptjd::read-scan-header {data ptr} {
  188. scan-at-ptr {a2 Su} marker _
  189. assert-equal $marker \xFF\xDA
  190. incr ptr 4
  191. scan-at-ptr cu ns
  192. incr ptr 1
  193. set components {}
  194. for {set i 1} {$i <= $ns} {incr i} {
  195. scan-at-ptr {cu cu} cs tdta
  196. incr ptr 2
  197. lassign [hi-lo $tdta] td ta
  198. lappend components [dict create cs $cs td $td ta $ta]
  199. }
  200. scan-at-ptr {cu cu cu} ss se ahal
  201. incr ptr 3
  202. lassign [hi-lo $ahal] ah al
  203. return [list $ptr [dict create ns $ns components $components \
  204. ss $ss se $se ah $ah al $al]]
  205. }
  206.  
  207. # Read $n bits from $bits. If there aren't $n bits in $bits, read enough bytes
  208. # from $data starting at $ptr into $bits and advance $ptr accordingly. Escaped
  209. # \xFF values are accounted for. Return the updated $ptr and $bits, and the $n
  210. # read bits.
  211. proc ::ptjd::get-bits {data ptr bits n} {
  212. while {[llength $bits] < $n} {
  213. scan-at-ptr B8 byte
  214. if {$byte eq "11111111"} {
  215. incr ptr
  216. scan-at-ptr H2 second
  217. switch -exact -- $second {
  218. 00 {
  219. # The value \xFF was escaped as \xFF\x00.
  220. }
  221. d9 {
  222. incr ptr -1
  223. return [list $ptr {} EOI]
  224. }
  225. default {
  226. error "can't understand marker 0xff$second\
  227. at 0x[format %x $ptr]"
  228. }
  229. }
  230. }
  231. lappend bits {*}[split $byte {}]
  232. incr ptr
  233. }
  234. set result [lrange $bits 0 $n-1]
  235. set bits [lrange $bits $n end]
  236. return [list $ptr $bits $result]
  237. }
  238.  
  239. # Read one Huffman code from $data. Return the associated value.
  240. proc ::ptjd::read-code {data ptr bits table {ct ""}} {
  241. set code {}
  242. while {![dict exists $table $code]} {
  243. if {$bits eq {}} {
  244. lassign [get-bits $data $ptr $bits 1] ptr bits bit
  245. } else {
  246. set bits [lassign $bits bit]
  247. }
  248. if {$bit eq "EOI"} {
  249. return [list $ptr $bits EOI]
  250. } else {
  251. append code $bit
  252. }
  253. if {[string length $code] > 16} {
  254. error "can't decode the [concat $ct code] \"$code\"\
  255. at 0x[format %x $ptr] ($table)"
  256. }
  257. }
  258. return [list $ptr $bits [dict get $table $code]]
  259. }
  260.  
  261. # Take a list of N bits and return a signed integer in the range
  262. # -2^N + 1 .. -2^(N - 1), 2^(N - 1) .. 2^N - 1 per the JPEG standard.
  263. # See "Table 5 - Huffman DC Value Encoding" at
  264. # http://www.impulseadventure.com/photo/jpeg-huffman-coding.html
  265. proc ::ptjd::restore-signed x {
  266. if {$x eq {}} {
  267. return 0
  268. } elseif {[lindex $x 0] == 0} {
  269. return [expr -0b[string map {0 1 1 0} [join $x {}]]]
  270. } else {
  271. return [expr 0b[join $x {}]]
  272. }
  273. }
  274.  
  275. proc ::ptjd::read-block {data ptr bits dct act {compN ""}} {
  276. # The DC component.
  277. set value {}
  278. lassign [read-code $data $ptr $bits $dct [concat $compN DC]] ptr bits value
  279. if {$value eq "EOI"} {
  280. return [list $ptr $bits {}]
  281. }
  282.  
  283. set dc 0
  284. if {$value > 0} {
  285. lassign [get-bits $data $ptr $bits $value] ptr bits dc
  286. set dc [restore-signed $dc]
  287. }
  288.  
  289. # The AC component.
  290. set ac {}
  291. while {[llength $ac] < 63} {
  292. lassign [read-code $data $ptr $bits $act [concat $compN AC]] \
  293. ptr bits rs
  294. if {$rs eq "EOI"} {
  295. break
  296. } elseif {$rs == 0x00} {
  297. # End of Block.
  298. break
  299. } elseif {$rs == 0xF0} {
  300. # ZRL -- sixteen zeros.
  301. lappend ac 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
  302. } else {
  303. lassign [hi-lo $rs] r s
  304. for {set i 0} {$i < $r} {incr i} {
  305. lappend ac 0
  306. }
  307.  
  308. set c 0
  309. if {$s > 0} {
  310. lassign [get-bits $data $ptr $bits $s] ptr bits c
  311. }
  312. lappend ac [restore-signed $c]
  313. }
  314. }
  315. while {[llength $ac] < 63} {
  316. lappend ac 0
  317. }
  318. set block [concat $dc $ac]
  319. return [list $ptr $bits $block]
  320. }
  321.  
  322. proc ::ptjd::dequantize-block {block qt} {
  323. set result {}
  324. foreach x $block y $qt {
  325. lappend result [expr {$x * $y}]
  326. }
  327. return $result
  328. }
  329.  
  330. proc ::ptjd::unzigzag block {
  331. set zigzag {
  332. 0 1 5 6 14 15 27 28
  333. 2 4 7 13 16 26 29 42
  334. 3 8 12 17 25 30 41 43
  335. 9 11 18 24 31 40 44 53
  336. 10 19 23 32 39 45 52 54
  337. 20 22 33 38 46 51 55 60
  338. 21 34 37 47 50 56 59 61
  339. 35 36 48 49 57 58 62 63
  340. }
  341. set reordered {}
  342. foreach i $zigzag {
  343. lappend reordered [lindex $block $i]
  344. }
  345. return $reordered
  346. }
  347.  
  348. proc ::ptjd::inverse-dct block {
  349. set result {}
  350. set m $::ptjd::inverseDctMatrix
  351. for {set y 0} {$y < 8} {incr y} {
  352. for {set x 0} {$x < 8} {incr x} {
  353. set sum 0
  354. for {set u 0} {$u < 8} {incr u} {
  355. set c1 [lindex $m [expr {8*$x + $u}]]
  356. for {set v 0} {$v < 8} {incr v} {
  357. set sum [expr {
  358. $sum + $c1*[lindex $block [expr {8*$v + $u}]]
  359. *[lindex $m [expr {8*$y + $v}]]
  360. }]
  361. }
  362. }
  363. lappend result [expr {round($sum / 4.0)}]
  364. }
  365. }
  366. return $result
  367. }
  368.  
  369. # Return the number of blocks for a dimension of the image.
  370. proc ::ptjd::block-count {pixels scale max} {
  371. set count [expr {($pixels + (8 * $max - 1))/(8*$max)*$max/$scale}]
  372. if {$count == 0} { set count 1 }
  373. return $count
  374. }
  375.  
  376. # Combine the blocks in $blocks into a color plane.
  377. proc ::ptjd::combine-blocks {hor vert blocks} {
  378. puts stderr "[llength $blocks] hor:$hor * vert:$vert = [expr {$hor*$vert}]"
  379. assert-equal [llength $blocks] [expr {$hor * $vert}]
  380. for {set i 0} {$i < 8*$vert} {incr i} {
  381. set plane($i) {}
  382. }
  383. set i 0
  384. foreach block $blocks {
  385. for {set j 0} {$j < 64} {incr j 8} {
  386. set y [expr {$i/$hor*8 + $j/8}]
  387. lappend plane($y) {*}[lrange $block $j $j+7]
  388. }
  389. incr i
  390. }
  391.  
  392. set result {}
  393. for {set i 0} {$i < 8*$vert} {incr i} {
  394. lappend result {*}$plane($i)
  395. }
  396. return $result
  397. }
  398.  
  399. # Crudely upscale a color plane by duplicating values; each of $scaleH and
  400. # $scaleV should be either 1 (no upscaling) or 2 (upscale in this direction).
  401. proc ::ptjd::scale-double {hor vert scaleH scaleV plane} {
  402. if {($scaleH ni {1 2})} {
  403. error "scaleH should be 1 or 2 (\"$scaleH\" given)"
  404. }
  405. if {($scaleV ni {1 2})} {
  406. error "scaleV should be 1 or 2 (\"$scaleV\" given)"
  407. }
  408. if {($scaleH == 1) && ($scaleV == 1)} { return $plane }
  409. set hor8 [expr {$hor*8}]
  410. for {set i 0} {$i < $hor8*$vert*8} {incr i $hor8} {
  411. set line [lrange $plane $i [expr {$i + $hor8 - 1}]]
  412. if {$scaleH == 2} {
  413. set scaled {}
  414. foreach c $line {
  415. lappend scaled $c $c
  416. }
  417. set line $scaled
  418. }
  419. lappend result {*}$line
  420. if {$scaleV == 2} {
  421. lappend result {*}$line
  422. }
  423. }
  424. assert-equal [expr {$scaleH*$scaleV*[llength $plane]}] [llength $result]
  425. return $result
  426. }
  427.  
  428. # Upscale a color plane somewhat less crudely; each of $scaleH and $scaleV
  429. # should be either 1 (no upscaling) or 2 (upscale in this direction).
  430. proc ::ptjd::scale-linear {hor vert scaleH scaleV plane} {
  431. if {($scaleH ni {1 2})} {
  432. error "scaleH should be 1 or 2 (\"$scaleH\" given)"
  433. }
  434. if {($scaleV ni {1 2})} {
  435. error "scaleV should be 1 or 2 (\"$scaleV\" given)"
  436. }
  437. if {($scaleH == 1) && ($scaleV == 1)} { return $plane }
  438. set hor8 [expr {$hor*8}]
  439. set prevLine {}
  440. for {set i 0} {$i < $hor8*$vert*8} {incr i $hor8} {
  441. set line [lrange $plane $i [expr {$i + $hor8 - 1}]]
  442. if {$scaleH == 2} {
  443. set scaled {}
  444. set prevC [lindex $line 0]
  445. foreach c $line {
  446. lappend scaled [expr {($prevC + $c) / 2}] $c
  447. }
  448. set line $scaled
  449. }
  450. if {$prevLine eq {}} { set prevLine $line }
  451. if {$scaleV == 1} {
  452. lappend result {*}$line
  453. } else { ;# $scaleV == 2
  454. set interp {}
  455. foreach c1 $prevLine c2 $line {
  456. lappend interp [expr {($c1 + $c2) / 2}]
  457. }
  458. lappend result {*}$interp {*}$line
  459. }
  460. }
  461. assert-equal [expr {$scaleH*$scaleV*[llength $plane]}] [llength $result]
  462. return $result
  463. }
  464.  
  465. # Crop a color plane to $width by $height.
  466. proc ::ptjd::crop {hor width height plane} {
  467. set hor8 [expr {$hor*8}]
  468. set result {}
  469. for {set i 0} {$i < $hor8*$height} {incr i $hor8} {
  470. lappend result {*}[lrange $plane $i [expr {$i + $width - 1}]]
  471. }
  472. return $result
  473. }
  474.  
  475. proc ::ptjd::clamp value {
  476. if {$value < 0} {
  477. return 0
  478. } elseif {$value > 255} {
  479. return 255
  480. } else {
  481. return $value
  482. }
  483. }
  484.  
  485. proc ::ptjd::ycbcr-to-rgb {y cb cr} {
  486. set r [clamp [expr {
  487. round($y + + 1.402 *($cr - 128))
  488. }]]
  489. set g [clamp [expr {
  490. round($y - 0.344136*($cb - 128) - 0.714136*($cr - 128))
  491. }]]
  492. set b [clamp [expr {
  493. round($y + 1.772 *($cb - 128) )
  494. }]]
  495. return [list $r $g $b]
  496. }
  497.  
  498. proc ::ptjd::decode {data {scaler ::ptjd::scale-double}} {
  499. set ptr 0
  500. set length [string length $data]
  501.  
  502. # Start of Image.
  503. scan-at-ptr a2 soi
  504. assert-equal $soi \xFF\xD8
  505. incr ptr 2
  506.  
  507. set qts {}
  508. set huffdc {}
  509. set huffac {}
  510.  
  511. # Parse tables until a Start of Frame marker is encountered.
  512. lassign [read-tables \xFF\xC0 $data $ptr $qts $huffdc $huffac] \
  513. ptr qts huffdc huffac
  514.  
  515. lassign [read-frame-header $data $ptr] ptr frame
  516. if {[dict get $frame nf] ni {1 3}} {
  517. error "unexpected number of components: [dict get $frame nf]"
  518. }
  519.  
  520. # The scan loop.
  521.  
  522. # Parse tables until a Start of Scan marker is encountered.
  523. lassign [read-tables \xFF\xDA $data $ptr $qts $huffdc $huffac] \
  524. ptr qts huffdc huffac
  525.  
  526. # Start of Scan.
  527. lassign [read-scan-header $data $ptr] ptr scan
  528.  
  529. # Read and decode the MCUs of the image.
  530. set bits {} ;# A bit buffer for [get-bits] and procs that use it.
  531. for {set i 1} {$i <= [dict get $frame nf]} {incr i} {
  532. set prevDc($i) 0
  533. set planeBlocks($i) {}
  534. incr i -1
  535. set component [lindex [dict get $frame components] $i]
  536. set repeats [expr {[dict get $component h]*[dict get $component v]}]
  537. lappend scanOrder {*}[lrepeat $repeats $i]
  538. incr i
  539. }
  540. unset component repeats
  541. puts stderr $scanOrder
  542. while 1 {
  543. foreach i $scanOrder {
  544. # Read a block.
  545. set scanComp [lindex [dict get $scan components] $i]
  546. set cs [dict get $scanComp cs]
  547. set dct [lindex $huffdc [dict get $scanComp td]]
  548. set act [lindex $huffac [dict get $scanComp ta]]
  549. lassign [read-block $data $ptr $bits $dct $act \
  550. "cs [expr {$i + 1}]"] \
  551. ptr bits block
  552.  
  553. # Transform a DC diff into a DC value.
  554. set dcv [lindex $block 0]
  555. incr dcv $prevDc($cs)
  556. set prevDc($cs) $dcv
  557. lset block 0 $dcv
  558.  
  559. # Dequantize the block.
  560. set frameComp [lindex [dict get $frame components] $i]
  561. set qt [lindex $qts [dict get $frameComp tq]]
  562. set blockDq [dequantize-block $block $qt]
  563. unset block
  564.  
  565. # Reorder the block.
  566. set blockReord [unzigzag $blockDq]
  567. unset blockDq
  568.  
  569. # Apply an inverse DCT to the block.
  570. set blockSpatDom [inverse-dct $blockReord]
  571. unset blockReord
  572. lappend planeBlocks($cs) $blockSpatDom
  573. }
  574. # End of Image.
  575. scan-at-ptr a2 eoi
  576. if {$eoi eq "\xFF\xD9"} break
  577. }
  578.  
  579. # Combine 8x8 blocks into planes.
  580. set planes {}
  581. set width [dict get $frame x]
  582. set height [dict get $frame y]
  583. set maxH 0
  584. set maxV 0
  585. for {set i 1} {$i <= [dict get $frame nf]} {incr i} {
  586. set component [lindex [dict get $frame components] [expr {$i - 1}]]
  587. set h [dict get $component h]
  588. set v [dict get $component v]
  589. if {$h > $maxH} { set maxH $h }
  590. if {$v > $maxV} { set maxV $v }
  591. }
  592. for {set i 1} {$i <= [dict get $frame nf]} {incr i} {
  593. set component [lindex [dict get $frame components] [expr {$i - 1}]]
  594. set h [dict get $component h]
  595. set v [dict get $component v]
  596. set scaleH [expr {$maxH/$h}]
  597. set scaleV [expr {$maxV/$v}]
  598. set horBlocks [block-count $width $scaleH $maxH]
  599. set vertBlocks [block-count $height $scaleV $maxV]
  600. unset component
  601. puts stderr "h:$h v:$v scaleH:$scaleH scaleV:$scaleV"
  602. puts stderr "hor:$horBlocks vert:$vertBlocks width:$width height:$height"
  603. set plane [combine-blocks $horBlocks $vertBlocks $planeBlocks($i)]
  604. unset planeBlocks($i)
  605. set shifted {}
  606. foreach x $plane {
  607. lappend shifted [clamp [expr {$x + 128}]]
  608. }
  609. unset plane
  610. set scaled [$scaler $horBlocks $vertBlocks $scaleH $scaleV \
  611. $shifted]
  612. unset shifted
  613. lappend planes [crop [expr {$scaleH*$horBlocks}] $width $height $scaled]
  614. }
  615.  
  616. if {[dict get $frame nf] == 1} {
  617. set decoded [lindex $planes 0]
  618. } else { ;# nf == 3
  619. set decoded {}
  620. foreach y [lindex $planes 0] \
  621. cb [lindex $planes 1] \
  622. cr [lindex $planes 2] {
  623. lappend decoded {*}[ycbcr-to-rgb $y $cb $cr]
  624. }
  625. }
  626. return [list [dict get $frame x] \
  627. [dict get $frame y] \
  628. [dict get $frame nf] \
  629. $decoded]
  630. }
  631.  
  632. proc ::ptjd::image-to-ppm {width height color data} {
  633. return "P[expr {$color == 1 ? 2 : 3}]\n$width $height\n255\n$data"
  634. }
  635.  
  636. proc ::ptjd::ppm-to-image ppm {
  637. scan $ppm "P%u\n%u %u\n255\n%n" format width height offset
  638. set data {}
  639. # Remove whitespace.
  640. foreach x [string range $ppm $offset end] {
  641. lappend data $x
  642. }
  643. if {$format == 2} {
  644. set color 1
  645. } elseif {$format == 3} {
  646. set color 3
  647. } else {
  648. error "only P2 and P3 are supported (\"$format\" given)"
  649. }
  650. if {$color == 1} {
  651. assert-equal [llength $data] [expr {$width * $height}]
  652. } else {
  653. assert-equal [llength $data] [expr {$width * $height * 3}]
  654. }
  655. return [list $width $height $color $data]
  656. }
  657.  
  658. namespace eval ::ptjd::demo {}
  659.  
  660. proc ::ptjd::demo::main {argv0 argv} {
  661. if {[llength $argv] != 1} {
  662. puts stderr "usage: $argv0 filename.jpg \[> filename.ppm\]"
  663. exit 1
  664. }
  665. lassign $argv filename
  666. set h [open $filename rb]
  667. set data [read $h]
  668. close $h
  669. puts [::ptjd::image-to-ppm {*}[::ptjd::decode $data]]
  670. }
  671.  
  672. # If this is the main script...
  673. if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
  674. ::ptjd::demo::main $argv0 $argv
  675. }