fjpg
Description of the page content
Forth toolkit to read information from JPEG files.
I wrote this Forth program because I needed to know the width and height of a given image in my program fhp.
Source code
\ ---------------------------------------------
cr .( fjpg )
\ Copyright (C) 2006,2007,2009,2013,2014 Marcos Cruz (programandala.net)
\ Licencia/License/Permesilo: http://programandala.net/license
\ Herramientas para leer información de archivos JPEG.
\ Info-legiloj por JPEG-dosieroj.
\ Tools to read JPEG files information.
\ Programa escrito en Forth con Gforth.
\ Programo verkita en Fortho per Gforth.
\ Program written in Forth with Gforth.
\ ---------------------------------------------
\ History
\ 2014-02-28: Typo fixed in comment.
\ 2014-02-24: Copied to Galope in order to improve it and reuse it.
\ Typos fixed in comments. '2+' and '2-' changed to '2 +' and '2 -'
\ por Gforth.
\ 2013-09-25: Changes in the source: no tabs, no spaces at the end of
\ lines, no empty lines... ANS Forth removed from the header. Forth
\ words are changed to lowercase.
\ 2009-02-20: New word: 'jpg-close'.
\ 2007-10-19: Bug found and fixed: The x and y are not found in
\ pictures taken with a Nikon Coolpix 3100. The reason was that the
\ JPEG size header was after the first 16 KiB, the size of the used
\ buffer. But my Forth 5mx 'read-file' word had a limitation
\ inherited from the OPL command ioread(): it could not read more than
\ 16 KiB in a single operation. So i wrote a new OPL procedure to
\ call ioread as many times as needed to read the desired lenght.
\ Then I increased the JPEG buffer to 64 KiB, what seems enough...
\ 'jpg-search2' and 'jpg-search-xy' were written for debugging this.
\ 2006-04-03: '.jpg-data' improved: Now you can 'abort' also *before*
\ the dumping. 'jpg-dump' modified: Now it doesn't show the data
\ bytes out of the headers.
\ 2006-04-02: '.jpg-data' improved: Now it asks for confirmation
\ *before* the dumping.
\ 2006-04-01: 'jpg-xy' fixed: it returned y x insted of x y.
\ 2006-03-30: First working version of 'jpg-xy'.
\ 2006-03-29: First working version of 'jpg-dump'.
\ 2006-03-28: Start. My first goal is to get the width and height of a
\ JPEG image file. i need that to improve my program fhp, a Forth
\ HTML Preprocessor.
\ ---------------------------------------------
marker fjpg
: 16@ ( c-addr -- n )
\ Fetch litle-endian 16 bits.
dup c@ 256 * swap 1+ c@ +
;
65536 constant #jpg-buffer \ must be enough to hold all JPEG headers we will need
create jpg-buffer #jpg-buffer allot
: jpg-load ( fileid -- )
\ Fill the buffer with the beginning of the a jpeg image file, to make it the current one.
[ base @ hex ]
jpg-buffer #jpg-buffer
2dup erase
rot read-file abort" Read image file error in jpg-load ."
drop jpg-buffer @ ffff and d8ff <> abort" Not a JPEG file in jpg-load ."
[ base ! ]
;
variable jpg-fileid
: jpg-open ( c-addr u -- fileid )
\ Open a JPEG image file and make it the current one.
[ base @ hex ]
r/o bin open-file abort" JPEG image open file error in jpg-open ."
dup jpg-fileid !
dup jpg-load
[ base ! ]
;
: jpg-close ( -- )
\ Close the current JPEG image.
jpg-fileid @ close-file abort" JPEG image close file error in jpg-close ."
;
: >jpg-data ( c-addr -- c-addr2 u2 )
\ c-addr = address of a JPEG marker
\ c-addr2 u2 = data region of the JPEG header
dup 4 + swap 2 + 16@ 2 -
;
: >jpg-marker ( c-addr -- u )
\ c-addr = address of a JPEG marker
\ u = byte offset from c-addr to the next JPEG marker
2 + 16@ 2 +
;
: .jpg-data ( c-addr u -- )
\ Dump the data of a JPEG header.
cr ." [d]ump? [a]bort? Any other key to continue" cr
key case
[char] d
of
cr dump
." [a]bort? Any other key to continue" cr
key [char] a =
if abort then
endof
[char] a of abort endof
>r 2drop r> \ discard data, savig the case selector
endcase
;
: .jpg-header ( c-addr -- u )
\ show a jpeg header.
\ c-addr = address of a jpeg marker
\ u = byte offset from c-addr to the next marker
dup >jpg-data 2dup
." , " . ." bytes from " . ." :"
.jpg-data >jpg-marker
;
: >jpg-xy ( c-addr -- x y )
\ c-addr = address of the proper jpeg marker
\ x y = size of the jpeg image
7 + dup 16@ swap 2 - 16@
;
: .jpg-xy ( c-addr -- )
\ show the jpeg image size.
\ c-addr = address of the proper jpeg marker
>jpg-xy swap ." x=" . ." y=" .
;
: jpg-header ( c-addr -- n )
\ identify and show a new jpeg header.
\ c-addr = address of the jpeg marker
\ u = byte offset to the next marker, or 0 if the marker found was the end of image
[ base @ hex ]
dup 1+ c@ dup . ." marker: "
case \ marker id
c0 of ." frame" dup .jpg-xy .jpg-header endof
c1 of ." unknown (frame?)" dup .jpg-xy .jpg-header endof \ xxx debug 2007-10-19
c2 of ." unknown (frame?)" dup .jpg-xy .jpg-header endof
c3 of ." unknown (frame?)" dup .jpg-xy .jpg-header endof \ xxx debug 2007-10-19
c4 of ." define huffman table" .jpg-header endof
\ from e0 to ef are reserved for applications:
e0 of ." jfif" .jpg-header endof
e1 of ." exim" .jpg-header endof
d8 of ." start of image" drop 2 endof
d9 of ." end of image" drop 0 endof
da of ." start of scan" .jpg-header endof
db of ." define quantization" .jpg-header endof
fe of ." comment" .jpg-header endof
>r \ preserve case selector for endcase
." unknown" .jpg-header
r>
endcase
[ base ! ]
;
: jpg-xy ( -- x y )
\ return the size of the current jpeg file.
[ base @ hex ]
jpg-buffer dup #jpg-buffer + swap 2 +
do
i 16@
case
ffc0 of i >jpg-xy leave endof
ffc2 of i >jpg-xy leave endof
endcase
i >jpg-marker
+loop
[ base ! ]
;
\ debug tools
: jpg-dump ( -- )
\ dump the content of the current jpeg image, header after header, until the buffer end.
\ this word was written to learn about the jpeg format and write the other words.
[ base @ hex ]
jpg-buffer dup #jpg-buffer + swap
do
i dup cr . ." : "
dup c@ dup .
ff =
if
jpg-header
else
\ ." byte out of header: " c@ . 1
drop 1
then
dup 0= abort" end of jpeg image in jpg-dump ."
+loop
[ base ! ]
;
0 value jpg-searched \ byte
: jpg-search ( b -- )
\ search a byte in the current jpeg file.
\ this word was written to find out where the image width and height are stored.
to jpg-searched cr
#jpg-buffer jpg-buffer + jpg-buffer
do
[char] . emit
i c@ jpg-searched =
if
cr jpg-searched . ." found at " i .
i 16 - 32 .jpg-data
then
loop
;
0 value jpg-searched2 \ byte
defer jpg-found2
: (jpg-found2) ( c-addr -- )
\ default action after a successful search of two bytes.
32 .jpg-data
;
' (jpg-found2) is jpg-found2
: jpg-search2 ( b1 b2 -- )
\ Search the current JPEG file for two bytes.
to jpg-searched2
to jpg-searched cr
#jpg-buffer jpg-buffer + jpg-buffer
do
[char] . emit
i c@ jpg-searched =
i 1+ c@ jpg-searched2 = and
if jpg-found2 then
loop
;
: jpg-search-xy ( -- )
\ Search and show any possible frame header in the current JPEG file.
\ This word was written to find out why the size
\ could not be found in pictures taken with a Nikon Coolpix 3100.
[ base @ hex ]
' jpg-xy is jpg-found2
ff c0 jpg-searched2
' (jpg-found2) is jpg-found2
[ base ! ]
;
\ ---------------------------------------------
\ Testing
false [if]
: jpg-test ( c-addr u -- )
\ Test an image
\ c-addr u = image file
jpg-open
jpg-dump
jpg-close
;
: img1 s" c:\tmp\20071001153657_muestra.jpg" ;
: img2 s" c:\tmp\alforja-saco\200709261743_alforjas_saco.jpg" ;
: img3 s" c:\tmp\alforja-saco\200709261742_alforjas_saco.jpg" ;
img1 jpg-test
img2 jpg-test
img3 jpg-test
[then]
.( fjpg ok!)