From 79445b4473802c17db1651c5996163a20236b88e Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 7 Dec 2020 14:50:46 -0800 Subject: [PATCH] images.jpeg: moving to extra/ --- images/jpeg/jpeg.factor | 372 ---------------------------------------- 1 file changed, 372 deletions(-) delete mode 100644 images/jpeg/jpeg.factor diff --git a/images/jpeg/jpeg.factor b/images/jpeg/jpeg.factor deleted file mode 100644 index eb4433a..0000000 --- a/images/jpeg/jpeg.factor +++ /dev/null @@ -1,372 +0,0 @@ -! Copyright (C) 2009 Marc Fauconneau. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays combinators -compression.huffman fry grouping images images.loader -images.processing io io.binary io.encodings.binary -io.streams.byte-array io.streams.limited io.streams.throwing -kernel locals math math.bitwise math.blas.matrices -math.blas.vectors math.constants math.functions math.matrices -math.order math.vectors memoize namespaces sequences -sequences.deep ; -QUALIFIED-WITH: bitstreams bs -IN: images.jpeg - -SINGLETON: jpeg-image - -TUPLE: loading-jpeg < image - { headers } - { bitstream } - { color-info initial: { f f f f } } - { quant-tables initial: { f f } } - { huff-tables initial: { f f f f } } - { components } ; - -{ "jpg" "jpeg" } [ jpeg-image ?register-image-class ] each - - ( headers bitstream -- image ) - loading-jpeg new swap >>bitstream swap >>headers ; - -SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP -APP JPG COM TEM RES ; - -! ISO/IEC 10918-1 Table B.1 -:: >marker ( byte -- marker ) - byte - { - { [ dup 0xCC = ] [ { DAC } ] } - { [ dup 0xC4 = ] [ { DHT } ] } - { [ dup 0xC9 = ] [ { JPG } ] } - { [ dup -4 shift 0xC = ] [ SOF byte 4 bits 2array ] } - - { [ dup 0xD8 = ] [ { SOI } ] } - { [ dup 0xD9 = ] [ { EOI } ] } - { [ dup 0xDA = ] [ { SOS } ] } - { [ dup 0xDB = ] [ { DQT } ] } - { [ dup 0xDC = ] [ { DNL } ] } - { [ dup 0xDD = ] [ { DRI } ] } - { [ dup 0xDE = ] [ { DHP } ] } - { [ dup 0xDF = ] [ { EXP } ] } - { [ dup -4 shift 0xD = ] [ RST byte 4 bits 2array ] } - - { [ dup -4 shift 0xE = ] [ APP byte 4 bits 2array ] } - { [ dup 0xFE = ] [ { COM } ] } - { [ dup -4 shift 0xF = ] [ JPG byte 4 bits 2array ] } - - { [ dup 0x01 = ] [ { TEM } ] } - [ { RES } ] - } - cond nip ; - -TUPLE: jpeg-chunk length type data ; - -: ( type length data -- jpeg-chunk ) - jpeg-chunk new - swap >>data - swap >>length - swap >>type ; - -TUPLE: jpeg-color-info - h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ; - -: ( h v quant-table -- jpeg-color-info ) - jpeg-color-info new - swap >>quant-table - swap >>v - swap >>h ; - -: jpeg> ( -- jpeg-image ) jpeg-image get ; - -: apply-diff ( dc color -- dc' ) - [ diff>> + dup ] [ diff<< ] bi ; - -: fetch-tables ( component -- ) - [ [ jpeg> quant-tables>> nth ] change-quant-table drop ] - [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ] - [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ; - -: read4/4 ( -- a b ) read1 16 /mod ; - -! headers - -: decode-frame ( header -- ) - data>> - binary - [ - read1 8 assert= - 2 read be> - 2 read be> - swap 2array jpeg> dim<< - read1 - [ - read1 read4/4 read1 - swap [ >>id ] keep jpeg> color-info>> set-nth - ] times - ] with-byte-reader ; - -: decode-quant-table ( chunk -- ) - dup data>> - binary - [ - length>> - 2 - 65 / - [ - read4/4 [ 0 assert= ] dip - 64 read - swap jpeg> quant-tables>> set-nth - ] times - ] with-byte-reader ; - -: decode-huff-table ( chunk -- ) - data>> [ binary ] [ length ] bi limit-stream [ - [ input-stream get stream>> [ count>> ] [ limit>> ] bi < ] - [ - read4/4 swap 2 * + - 16 read - dup [ ] [ + ] map-reduce read - binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader - swap jpeg> huff-tables>> set-nth - ] while - ] stream-throw-on-eof ; - -: decode-scan ( chunk -- ) - data>> - binary - [ - read1 - [ drop - read1 jpeg> color-info>> nth clone - read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi* - ] map jpeg> components<< - read1 0 assert= - read1 63 assert= - read1 16 /mod [ 0 assert= ] bi@ - ] with-byte-reader ; - -: singleton-first ( seq -- elt ) - [ length 1 assert= ] [ first ] bi ; - -ERROR: not-a-baseline-jpeg-image ; - -: baseline-parse ( -- ) - jpeg> headers>> [ type>> { SOF 0 } = ] any? [ not-a-baseline-jpeg-image ] unless - jpeg> headers>> - { - [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ] - [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ] - [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ] - [ [ type>> { SOS } = ] filter singleton-first decode-scan ] - } cleave ; - -: parse-marker ( -- marker ) - read1 0xFF assert= - read1 >marker ; - -: parse-headers ( -- chunks ) - [ parse-marker dup { SOS } = not ] - [ - 2 read be> - dup 2 - read - ] [ produce ] keep dip swap suffix ; - -MEMO: zig-zag ( -- zz ) - { - { 0 1 5 6 14 15 27 28 } - { 2 4 7 13 16 26 29 42 } - { 3 8 12 17 25 30 41 43 } - { 9 11 18 24 31 40 44 53 } - { 10 19 23 32 39 45 52 54 } - { 20 22 33 38 46 51 55 60 } - { 21 34 37 47 50 56 59 61 } - { 35 36 48 49 57 58 62 63 } - } flatten ; - -MEMO: yuv>bgr-matrix ( -- m ) - { - { 1 2.03211 0 } - { 1 -0.39465 -0.58060 } - { 1 0 1.13983 } - } ; - -: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ; - -:: dct-vect ( u v -- basis ) - { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2 - 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ; - -MEMO: dct-matrix ( -- m ) 64 [ 8 /mod dct-vect flatten ] map ; - -: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ; - -! : blocks ( component -- seq ) -! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ; - -: all-macroblocks ( quot: ( mb -- ) -- ) - [ - jpeg> - [ dim>> 8 v/n ] - [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi - [ ceiling ] map - coord-matrix flip concat - ] - [ each ] bi* ; inline - -: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ; - -: idct-factor ( b -- b' ) dct-matrix v.m ; - -MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; -: V.M ( x A -- x.A ) Mtranspose swap M.V ; -: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ; - -: idct ( b -- b' ) idct-factor ; - -:: draw-block ( block x,y color-id jpeg-image -- ) - block dup length>> sqrt >fixnum group flip - dup matrix-dim coord-matrix flip - [ - [ '[ _ [ second ] [ first ] bi ] dip nth nth ] - [ x,y v+ color-id jpeg-image draw-color ] bi - ] with each^2 ; - -: sign-extend ( bits v -- v' ) - swap [ ] [ 1 - 2^ < ] 2bi - [ -1 swap shift 1 + + ] [ drop ] if ; - -: read1-jpeg-dc ( decoder -- dc ) - [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ; - -: read1-jpeg-ac ( decoder -- run/ac ) - [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ; - -:: decode-block ( color -- pixels ) - color dc-huff-table>> read1-jpeg-dc color apply-diff - 64 0 :> coefs - 0 coefs set-nth - 0 :> k! - [ - color ac-huff-table>> read1-jpeg-ac - [ first 1 + k + k! ] [ second k coefs set-nth ] [ ] tri - { 0 0 } = not - k 63 < and - ] loop - coefs color quant-table>> v* - reverse-zigzag idct ; - -:: draw-macroblock-yuv420 ( mb blocks -- ) - mb { 16 16 } v* :> pos - 0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block - 1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block - 2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block - 3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block - 4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block - 5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ; - -:: draw-macroblock-yuv444 ( mb blocks -- ) - mb { 8 8 } v* :> pos - 3 [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ; - -:: draw-macroblock-y ( mb blocks -- ) - mb { 8 8 } v* :> pos - 0 blocks nth pos 0 jpeg> draw-block - 64 0 pos 1 jpeg> draw-block - 64 0 pos 2 jpeg> draw-block ; - - ! %fixme: color hack - ! color h>> 2 = - ! [ 8 group 2 matrix-zoom concat ] unless - ! pos { 8 8 } v* color jpeg> draw-block ; - -: decode-macroblock ( -- blocks ) - jpeg> components>> - [ - [ mb-dim first2 * ] - [ [ decode-block ] curry replicate ] bi - ] map concat ; - -: cleanup-bitstream ( bytes -- bytes' ) - binary [ - [ - { 0xFF } read-until - read1 [ 0x00 = and ] keep swap - ] - [ drop ] produce - swap >marker { EOI } assert= - swap suffix - { 0xFF } join - ] with-byte-reader ; - -: setup-bitmap ( image -- ) - dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim - BGR >>component-order - ubyte-components >>component-type - f >>upside-down? - dup dim>> first2 * 3 * 0 >>bitmap - drop ; - -ERROR: unsupported-colorspace ; -SINGLETONS: YUV420 YUV444 Y MAGIC! ; - -:: detect-colorspace ( jpeg-image -- csp ) - jpeg-image color-info>> sift :> colors - MAGIC! - colors length 1 = [ drop Y ] when - colors length 3 = - [ - colors [ mb-dim { 1 1 } = ] all? - [ drop YUV444 ] when - - colors unclip - [ [ mb-dim { 1 1 } = ] all? ] - [ mb-dim { 2 2 } = ] bi* and - [ drop YUV420 ] when - ] when ; - -! this eats ~50% cpu time -: draw-macroblocks ( mbs -- ) - jpeg> detect-colorspace - { - { YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] } - { YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] } - { Y [ [ first2 draw-macroblock-y ] each ] } - [ unsupported-colorspace ] - } case ; - -! this eats ~25% cpu time -: color-transform ( yuv -- rgb ) - { 128 0 0 } v+ yuv>bgr-matrix swap m.v - [ 0 max 255 min >fixnum ] map ; - -: baseline-decompress ( -- ) - jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append - >byte-array bs: jpeg> bitstream<< - jpeg> - [ bitstream>> ] - [ [ [ ] with map ] change-huff-tables drop ] bi - jpeg> components>> [ fetch-tables ] each - [ decode-macroblock 2array ] collector - [ all-macroblocks ] dip - jpeg> setup-bitmap draw-macroblocks - jpeg> bitmap>> 3 [ color-transform ] map! drop - jpeg> [ >byte-array ] change-bitmap drop ; - -ERROR: not-a-jpeg-image ; - -: loading-jpeg>image ( loading-jpeg -- image ) - dup jpeg-image [ - baseline-parse - baseline-decompress - ] with-variable ; - -: load-jpeg ( stream -- loading-jpeg ) - [ - parse-marker { SOI } = [ not-a-jpeg-image ] unless - parse-headers - contents - ] with-input-stream ; - -PRIVATE> - -M: jpeg-image stream>image ( stream jpeg-image -- bitmap ) - drop load-jpeg loading-jpeg>image ; -- 2.34.1