From f7d9f2ab2e5ea2a4bf519733cf0f79d04fa1f944 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 19:02:20 -0600 Subject: [PATCH 01/14] typo in alien.fortran docs --- basis/alien/fortran/fortran-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor index 1b942d30c5..4accbf5965 100644 --- a/basis/alien/fortran/fortran-docs.factor +++ b/basis/alien/fortran/fortran-docs.factor @@ -44,7 +44,7 @@ HELP: fortran-invoke ; ARTICLE: "alien.fortran" "Fortran FFI" -"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code shared libraries written in Fortran." +"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." { $subsection "alien.fortran-types" } { $subsection POSTPONE: LIBRARY: } { $subsection POSTPONE: FUNCTION: } From 0d67f41ae6cc8551ea09e73bcdbf5a662e6f4d7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 19:28:21 -0600 Subject: [PATCH 02/14] update specialized-arrays docs --- basis/specialized-arrays/specialized-arrays-docs.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor index 1c1b3dbc59..9015cccd8f 100644 --- a/basis/specialized-arrays/specialized-arrays-docs.factor +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -28,6 +28,8 @@ $nl { $snippet "ulonglong" } { $snippet "float" } { $snippet "double" } + { $snippet "complex-float" } + { $snippet "complex-double" } { $snippet "void*" } { $snippet "bool" } } From 992da4c9675a3d346b5a69dfdb659190434e744f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:19:18 -0600 Subject: [PATCH 03/14] Fix copy-vm word on Unix --- basis/tools/deploy/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 22d6eb2ffa..ff851edce6 100755 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -12,7 +12,7 @@ destructors accessors ; IN: tools.deploy.backend : copy-vm ( executable bundle-name -- vm ) - [ prepend-path ] dip append vm over copy-file ; + prepend-path vm over copy-file ; : copy-fonts ( name dir -- ) deploy-ui? get [ From a1e45570f5e425dd62a72cfd41781ae391b8e85d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:57:26 -0600 Subject: [PATCH 04/14] rename graphics to images, add an word to load a path --- extra/images/authors.txt | 1 + extra/images/backend/authors.txt | 1 + extra/images/backend/backend.factor | 18 ++ extra/images/bitmap/authors.txt | 1 + extra/images/bitmap/bitmap-tests.factor | 30 +++ extra/images/bitmap/bitmap.factor | 146 ++++++++++++ extra/images/images.factor | 13 ++ extra/images/tags.txt | 1 + extra/images/test-images/1bit.bmp | Bin 0 -> 1662 bytes extra/images/test-images/octagon.tiff | Bin 0 -> 4334 bytes extra/images/test-images/rgb.tiff | Bin 0 -> 7916 bytes extra/images/test-images/rgb4bit.bmp | Bin 0 -> 5318 bytes extra/images/test-images/rgb8bit.bmp | Bin 0 -> 11078 bytes extra/images/test-images/thiswayup24.bmp | Bin 0 -> 60054 bytes extra/images/tiff/authors.txt | 1 + extra/images/tiff/tiff-tests.factor | 11 + extra/images/tiff/tiff.factor | 283 +++++++++++++++++++++++ extra/images/viewer/authors.txt | 1 + extra/images/viewer/viewer.factor | 69 ++++++ 19 files changed, 576 insertions(+) create mode 100644 extra/images/authors.txt create mode 100644 extra/images/backend/authors.txt create mode 100644 extra/images/backend/backend.factor create mode 100755 extra/images/bitmap/authors.txt create mode 100644 extra/images/bitmap/bitmap-tests.factor create mode 100755 extra/images/bitmap/bitmap.factor create mode 100644 extra/images/images.factor create mode 100644 extra/images/tags.txt create mode 100644 extra/images/test-images/1bit.bmp create mode 100644 extra/images/test-images/octagon.tiff create mode 100755 extra/images/test-images/rgb.tiff create mode 100644 extra/images/test-images/rgb4bit.bmp create mode 100644 extra/images/test-images/rgb8bit.bmp create mode 100644 extra/images/test-images/thiswayup24.bmp create mode 100755 extra/images/tiff/authors.txt create mode 100755 extra/images/tiff/tiff-tests.factor create mode 100755 extra/images/tiff/tiff.factor create mode 100755 extra/images/viewer/authors.txt create mode 100644 extra/images/viewer/viewer.factor diff --git a/extra/images/authors.txt b/extra/images/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/images/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/images/backend/authors.txt b/extra/images/backend/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/images/backend/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor new file mode 100644 index 0000000000..ef2a9a4248 --- /dev/null +++ b/extra/images/backend/backend.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel ; +IN: images.backend + +TUPLE: image width height depth pitch buffer ; + +GENERIC: load-image* ( path tuple -- image ) + +: load-image ( path class -- image ) + new load-image* ; + +: new-image ( width height depth buffer class -- image ) + new + swap >>buffer + swap >>depth + swap >>height + swap >>width ; inline diff --git a/extra/images/bitmap/authors.txt b/extra/images/bitmap/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/bitmap/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor new file mode 100644 index 0000000000..6865bfee3c --- /dev/null +++ b/extra/images/bitmap/bitmap-tests.factor @@ -0,0 +1,30 @@ +USING: images.bitmap images.viewer io.encodings.binary +io.files io.files.unique kernel tools.test ; +IN: images.bitmap.tests + +: test-bitmap32-alpha ( -- path ) + "resource:extra/images/bitmap/test-images/32alpha.bmp" ; + +: test-bitmap24 ( -- path ) + "resource:extra/images/bitmap/test-images/thiswayup24.bmp" ; + +: test-bitmap16 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb16bit.bmp" ; + +: test-bitmap8 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb8bit.bmp" ; + +: test-bitmap4 ( -- path ) + "resource:extra/images/bitmap/test-images/rgb4bit.bmp" ; + +: test-bitmap1 ( -- path ) + "resource:extra/images/bitmap/test-images/1bit.bmp" ; + +[ t ] +[ + test-bitmap24 + [ binary file-contents ] [ load-bitmap ] bi + + "test-bitmap24" unique-file + [ save-bitmap ] [ binary file-contents ] bi = +] unit-test diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor new file mode 100755 index 0000000000..220cdc153f --- /dev/null +++ b/extra/images/bitmap/bitmap.factor @@ -0,0 +1,146 @@ +! Copyright (C) 2007, 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien alien.c-types arrays byte-arrays columns +combinators fry grouping io io.binary io.encodings.binary +io.files kernel libc macros math math.bitwise math.functions +namespaces opengl opengl.gl prettyprint sequences strings +summary ui ui.gadgets.panes images.backend ; +IN: images.bitmap + +TUPLE: bitmap-image < image ; + +! Currently can only handle 24/32bit bitmaps. +! Handles row-reversed bitmaps (their height is negative) + +TUPLE: bitmap magic size reserved offset header-length width +height planes bit-count compression size-image +x-pels y-pels color-used color-important rgb-quads color-index +alpha-channel-zero? +buffer ; + +: array-copy ( bitmap array -- bitmap array' ) + over size-image>> abs memory>byte-array ; + +MACRO: (nbits>bitmap) ( bits -- ) + [ -3 shift ] keep '[ + bitmap new + 2over * _ * >>size-image + swap >>height + swap >>width + swap array-copy [ >>buffer ] [ >>color-index ] bi + _ >>bit-count + ] ; + +: bgr>bitmap ( array height width -- bitmap ) + 24 (nbits>bitmap) ; + +: bgra>bitmap ( array height width -- bitmap ) + 32 (nbits>bitmap) ; + +: 8bit>buffer ( bitmap -- array ) + [ rgb-quads>> 4 [ 3 head-slice ] map ] + [ color-index>> >array ] bi [ swap nth ] with map concat ; + +ERROR: bmp-not-supported n ; + +: raw-bitmap>buffer ( bitmap -- array ) + dup bit-count>> + { + { 32 [ color-index>> ] } + { 24 [ color-index>> ] } + { 16 [ bmp-not-supported ] } + { 8 [ 8bit>buffer ] } + { 4 [ bmp-not-supported ] } + { 2 [ bmp-not-supported ] } + { 1 [ bmp-not-supported ] } + } case >byte-array ; + +ERROR: bitmap-magic ; + +M: bitmap-magic summary + drop "First two bytes of bitmap stream must be 'BM'" ; + +: read2 ( -- n ) 2 read le> ; +: read4 ( -- n ) 4 read le> ; + +: parse-file-header ( bitmap -- bitmap ) + 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic + read4 >>size + read4 >>reserved + read4 >>offset ; + +: parse-bitmap-header ( bitmap -- bitmap ) + read4 >>header-length + read4 >>width + read4 >>height + read2 >>planes + read2 >>bit-count + read4 >>compression + read4 >>size-image + read4 >>x-pels + read4 >>y-pels + read4 >>color-used + read4 >>color-important ; + +: rgb-quads-length ( bitmap -- n ) + [ offset>> 14 - ] [ header-length>> ] bi - ; + +: color-index-length ( bitmap -- n ) + { + [ width>> ] + [ planes>> * ] + [ bit-count>> * 31 + 32 /i 4 * ] + [ height>> abs * ] + } cleave ; + +: parse-bitmap ( bitmap -- bitmap ) + dup rgb-quads-length read >>rgb-quads + dup color-index-length read >>color-index ; + +: load-bitmap ( path -- bitmap ) + binary [ + bitmap new + parse-file-header parse-bitmap-header parse-bitmap + ] with-file-reader ; + +: alpha-channel-zero? ( bitmap -- ? ) + buffer>> 4 3 [ 0 = ] all? ; + +: bitmap>image ( bitmap -- bitmap-image ) + { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave + bitmap-image new-image ; + +M: bitmap-image load-image* ( path bitmap -- bitmap-image ) + drop load-bitmap + dup raw-bitmap>buffer >>buffer + dup alpha-channel-zero? >>alpha-channel-zero? + bitmap>image ; + +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; + +: save-bitmap ( bitmap path -- ) + binary [ + B{ CHAR: B CHAR: M } write + [ + buffer>> length 14 + 40 + write4 + 0 write4 + 54 write4 + 40 write4 + ] [ + { + [ width>> write4 ] + [ height>> write4 ] + [ planes>> 1 or write2 ] + [ bit-count>> 24 or write2 ] + [ compression>> 0 or write4 ] + [ size-image>> write4 ] + [ x-pels>> 0 or write4 ] + [ y-pels>> 0 or write4 ] + [ color-used>> 0 or write4 ] + [ color-important>> 0 or write4 ] + [ rgb-quads>> write ] + [ color-index>> write ] + } cleave + ] bi + ] with-file-writer ; diff --git a/extra/images/images.factor b/extra/images/images.factor new file mode 100644 index 0000000000..eb4fc63fee --- /dev/null +++ b/extra/images/images.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: constructors kernel splitting unicode.case combinators +accessors images.bitmap images.tiff images.backend io.backend +io.pathnames ; +IN: images + +: ( path -- image ) + normalize-path dup "." split1-last nip >lower + { + { "bmp" [ bitmap-image load-image ] } + { "tiff" [ tiff-image load-image ] } + } case ; diff --git a/extra/images/tags.txt b/extra/images/tags.txt new file mode 100644 index 0000000000..04b54a06f4 --- /dev/null +++ b/extra/images/tags.txt @@ -0,0 +1 @@ +bitmap graphics diff --git a/extra/images/test-images/1bit.bmp b/extra/images/test-images/1bit.bmp new file mode 100644 index 0000000000000000000000000000000000000000..2f244c1d058bfd63c99009e24e43db3d2af59902 GIT binary patch literal 1662 zcmd6mu}&N@5QY~a(QcXY+PnZo8WyGJ9a2QJkP4yX)=xlQ0r3D)UI5Obx(-^kP>P00mA^ zwBUF^jlQ?E;2?IzW6rM6HrH!wQhyj)b6UoD@XeYt9ody`K1_Mt%?}f{KVbJy%jcAj zt>KGpdF1)G8#sXx#Xjmy4aWdZ=sgF-W=L!giOF7nXWqQfqxQZB=n3}M&%h;db954z z5E@tMx~mVf%2{3&6~$+BXh5o3M#kinNOWWu>rFlx|3%95W4uyouK-4#SClXoB~%*C^4(}0onQG*9L-9b-!uM&JH<>m6OjuQDiV1l8blvI&dpWsH&fqeed;%iU%z`!sV;|oL`;1cM@txn1q zeNvtP$iOI5M`t`8&@TI<PT&zE=wk>n#+W#})qlnu6j zqKlaxW~`Q2))-G*FH&~!a+~whBxMUv@;vdku#nh6UAzYFMb4TYyweT-0k9zwR(&q} gI+mcb*Vx}V%YV4a?71qPKl;*mGj7Ahc<-2B0n`=D`~Uy| literal 0 HcmV?d00001 diff --git a/extra/images/test-images/octagon.tiff b/extra/images/test-images/octagon.tiff new file mode 100644 index 0000000000000000000000000000000000000000..2b4ba3950db91cabdca87201b034b9d5bb97bdb3 GIT binary patch literal 4334 zcmebEWzb?^5a9U#|33ph%)r3Fk)M>iq_wp1aC33PQDSjsblTPcPoE|G*KPfGV*9@T zxG*8RtFp_tf4uVg|Cj6UNWvgJmDy$6gS`C~;Bx~m`$7ID*KU|wL2dw<5$x?Z50@LT z*-s6-G2GzeKNp)D(Cw$D-B{c(2i*{EN+;M>;{vx~ f5E45W%m%sb8PE)%?GWg(_8bGqA21r|GB5-H7Z-?3 literal 0 HcmV?d00001 diff --git a/extra/images/test-images/rgb.tiff b/extra/images/test-images/rgb.tiff new file mode 100755 index 0000000000000000000000000000000000000000..71cbaa9d6e807156f7da39a5b116c9edb3b0c9e1 GIT binary patch literal 7916 zcmeHMcT^MWw+#r=t3X6RRC<#hYUoXR4bnxLK!S7xL9Q1Cgh&@qz)BGldhfkA=^#Z! zK)@iqNqZASuUB2~z4iWmzr{LhhA%Uj$#>4#XP|nBx#_MiZEA7RYB3o_UO{CL} z`4T$qJq*th{=a--LJ$twGab&~cKEvCxzs}f`5@Q@BhyF!+F=vt__71{97L%+4=m~D z9hNH{W8PYvFe3@79lyErV~3@*N%(>r?VZKZG6v9RZ*Ra8q*7{>GX|VIe3PpS&ivIS z?^&LeK8z>{n<{)a0r?nEQ~udCf$vVwgS=r^3G-_E+gFv%6EeNwXFF*rvu!upuv%ip*n(QxuB?^&#g&vGP+-HfAYmMg3;dw@dhhE- z7lwbw-s{xtPa_7r)H!eP`Og6gK+u9n01s3Mwe9YxK(>9joB zKdeLc<9)C@<7q0Hep4&BWl`vzmVJm$=HO><-HG59e(!f5if>oVZ3om$S$LU4yFUfB z6l=gYlP)(zSA5i*kFB}`&gj8--?pg!q=9lx+FljysPXB#G^_Z^{Jl=egHLZQq*MH? zz&b1YcLJ@dTns|TBqR4c*JPu(iMM5XZYP`);$PR#kngFaC#sJ^^AU;>)~n*xtyJ8_ zgN8LKgf-rzkuIv|$0MT6L^gz+X{JKj(Z6uh5RYky!n@H76=YN&;B{jqFI3Gn_ns-> zAw9#=76VV-Z^ral&R6F99bBr?r|#!f?Gx%}&eFp}zpivgw~@)XYqp4XMaSU&;ws2# z5J+~KQY~4Mk25G((Th^x1stmt|j!3 zn3?TIU2Z-`Rj)OL3|sh^%W!}nw#+C9n_&)Zl6+=1yy&%BG_v5cbKZ3439PDsAoe%t z#*CG4U{?J7rL!l)Kkw*nibUKm4yda4545WJw0(U_=79*PN46{W?3mDv0TTSwoF_Nt zxRx}mPAdSeBB}1~A4rySZO}MX9%TrnO5;^xeO)D}(L=2q4Yweb`9fnuR;$x_5sY@j zQ)X19O2);=MaLPRSBv3At~M_k2GX}KCVLjO<;}!oDr>#$;OwC8y!F>#zxagnd-|N? zAq#GNxhg*6bn)yDpWIWv)H`bKr1t~5&qp+|tUHoU6EOS^ED7D5XUbBvC3Mj+M}tgT zIwMoSCx+alb2+#uJ*T1aw1|J8o1<8s#a*iNu93(r(8azoEr2oKdCal2S^{+ zTjmlfAs3;83uWe75d|hW_ttk4Iz?d>S?^XMyU-Hm3i6NdZ>Pv|By@e+xVlL%YZatw zxv~`?29;GsA*Q`gy;~OrXCkO44(Fc9B|6nOThCLl zSSY(_wv|;q->`NBA?wKAmtFaq-^-h;L;dedY4C^ zmx~eaXwoylG@^P*wdfSO(GHh*^!AFk)mQgvag}qE@AG$_A#LnZiP$fp>4cL)>eaZB zz3f^s2H_lRd8}&lS8_0EVqG3FAv`K)pg8B=dI*0I>7~)4RnE)eEs(2iVhj*g*nLt|BIWMV+WdGTc5dgoSZ-=&yzFhx<>^Gg0Jc^bAq5qa103 z5%49dqze)%6&njDY1!!S8WOt+Jy)5FDT5LRsyx@2U;k>v9-#R0PnBC&T{-@-PKF6L zHYJNB9_da$Dz`Z8YyY&>1uU^Schk4p+-19*{PcuV{q)VVWf9CjS8hGQ#3yjSUaih~ zPXm;N{pX|vE6;pV$Q#wHAdEl)*QAYJM!`FqBEtB{Z|(hxJ9)cCX(!T9V?^ zzEn}CS#JvN`#q>Zb-wFCHif3val~CudYtpe5kGOXqVk6dCBr;EoovJo451$!=twn> zXd{cvSW7VRipLzyq;j@z^jYFNp^{yZb*Z$*59v?*Q%a~%LvUMD!sJLU#f!~Q@tj+*kO;6TGBYT4MnWKI}*+*BwowPYUChPr0f(W zt0t@D9%<;QB%)~4z|fxNME$+(E*~`c16|rq_5YS_CE8#;aL-ldNbVrOlWyY25n$?}ZY972532(Q(wWr;q zTIKb&^VZeLz(4?;{Q^uMMtBTEx5o2!wX%Z3#lM&yK0VZlC|xLfxL1ED7sX3pV@^m4|G4^YcZtKcK?CN`73|acryP!g9=M+|zHN!Nn_81g1t$JtN3sMo3 z#zwhvetY_A!`fH}yQTqw>V<2m)?Y^K|~ggp&d6t}(CC;y`wqLm_OjV06%O*r;&) zUmZ|inMv^#-r`bi>YBfU%rFV#cI=}Mny%SG7U;xIvI{7q&z{Y=(uR}89HrH13qnZG zCs||;FKjS~+ur7iNpXP;F{S3@_RS6qhpd6cwnxmQ_!@;Rn9 zmX}o(t?$mdmp_RVV%r9z4B>Nq9Cc&s&quQ%sF0!eTiCYH zr;29YNrH)U*&t_T{;R)1g!Wk8$nyRjE7^=80-Rr10EFqZ+=YvJ;C+2Q>M%tXfzV27 zDW*`RRDqq1uq(94E2%4-;9~25XFjg7Z@8QI(WzLX>qso6XWr9e{AmJgG#KgXn-c2a{0K2~%i1*M zX>4qL|5wS$8i(TOnQecEr|67$`HiQacT&cilPcG0ND3PFWk@?%ODhnsUhm3B!5Ks4 z1pHZ(cy4Knl8jBJ~ZoImFYoiuGR?%I}%~henp-PZbe_Kh1MZ!$Rs5> zCy>`EPg9Rcm1UN5HH3w>y6pS1<^I_N*VXXw)PGVO?=~^7acaikUy4(<6SyK0!E^di zEBiOaF+tnTgI@YgfaJ4QyY&(2H4oDG-qeEK3856#68)`%=M&NL4TV?nSZWY6rjr zU7nKWU0Vis?W#BSj3Q*zKSyW#+!j~{U)mf4n2}}qd$T&sj@gbsdfRe%b^nG)RUq@H z{i9k+QoP{OTt?DNXx9b>{wo(0-)RL(BpXqY08a<8BB7bW+XjKf^SyQa(om|#XkN`V zae+#mGfI^H#^6%zMr-=!XtV<@RHtH(QIh|j7+9r`q~@Yp3=idRiowrR=k9Y#ikE)@!e6@(oy!n)bSFp55QYUVS~$r*D4|d-0zeEUfQBVOI=MgK3nGUfx;k z2?ObapK0T1%?eE69z=*cga3%V$)@}?VNF{_F1Z8F3HxOE+d)B7x$7014&cb<>Ac+& zvG+z9??ATLwdQ$&$Bd9zru25pJo?eCNE~$9sE|olFd#)@gTErU!y=;h3ZjxYI4~rA z&~{P!ad+QveeiPO*MnJtv}=pskkz2MaYu^j3%^cRYrU&8BlG!>dMzt{3(_^<1jUtg zUycgdoX_93{z2JWhUfWE9gX0v7yKXBI;$v%8&22cD%>OykBXfosBH^hCU2y|lG5li z$=m4V&j*A#+BWm^q6j$K+1wl{9Nfliq!HsW)ydAby?gN$l}#XxLe%|uiO9e#cLwv%q8tHwzN?1u=F(YQQ>GZFygKdnBAzJUX$D1zi`%<}j7dCHg z(%H%88)v~v?P4bEbH*jeh2zt?;6WD{cy4Z0d_RTh5lhQ^kI~LGNgxh)zJ682yi=NDgZpDccfJmN-73-wOGy3uRUA`qGT){-M zs8b_TUsdQ!-Q})#Gk50dKn4l2p}K9$1nd6{VAi2{c;~6|=nQs<|Ck4%)4dlw8PwJxVzeAI5cDftMNqyvmhbQjRmnZ{WoKSn0j z5aLZ3kVU3WVv=diOFk*uH}yN3PDUmYhyo({2J24=>P2@xhqYQP?n=$6es9N7Tq(~i zSIf!RLe3!ijsdLr?#uqquSPBC+LiOhT-@j_hOn}=gLfrUwG3b7w7W0NqJ4f zRn=*cMVo#T)iaSv6MzQ7y6L zpJN!{>SNF_;+OK&0V9Kn^e zf#b1Kh<0?Fvxwio^{jt5Tt+j(sKZX7*EqZHvglXo>f6uewyDx)fvA~0(w>VJqOD{<4i$%hd~86zvVtfBA0SZxw^a9*n>W8%Y> z>A{g~#_-aECHEuPvzl%1og)4Xe4Gr<|E~EAdrnEI)_*9){IKPkJK=_l;LqbXyR|E+ z!3efw&5VD?5+LnZyK~YCxv@sKWqupKrD-{?`wd?IY5bNt^oC}%>Lr%c*~8w<7XQfg z1Dgyhfa|hpFPJ5NI2pe+Uqd85u-CW7x z`Qg_MUz|)sA(OA-+Lo}nj@8xOZ&bXV9i!6jc6Ib$3gkH^br#ig;1^y~9$%lzxU6%$ zU)lan>eQi(oh3rTQF7QhN33HUV`N=$#ju>p{27dm_HmK=?<2}j*Am*$ z1xbyTdp1EMXk+*t;Q;piNC?9ILI|qD( z0xS-&Bfu5`D+KHfV0QrfejWA*2L4w8>~Fws1C|chbHG>u<2*T*0oM@%hCMm~Yxi(L zAbva$r~w}YswV(}&_uwSkbpqMWFSx|IS3>{0X!41BtTEhrvia?s6ik<8W3oc7FYv= zKvMJ|kkvU5D1-rcPe8w-03Cwxj(-pE0N{t6IzEpAo`iF9J_Rh}0_UfIqbCyxbn0Xs zcmdGqlXKvuKvXz*Am9O@A>bO?lXdJpbig|Bbs%EEz$e%E0oRk literal 0 HcmV?d00001 diff --git a/extra/images/test-images/rgb4bit.bmp b/extra/images/test-images/rgb4bit.bmp new file mode 100644 index 0000000000000000000000000000000000000000..0c6f00d06c025f6947899450afd91ace50e5b57a GIT binary patch literal 5318 zcmeH~J&xNj5QP;WN5~=4`v3&C50FFT3~?!6!4ht%;Vp6o}HvQbsetmbdm>Jba9`$>-CBW z&sXO?^>E{lhR9!(7a2zZE6-lcLCee=>GUfm*FpgFiOoJB;bmNH8kGz;lh9PADMtQ8LMIPr= zXg4}Uqs}^pqnuRP#EkO(krh!9^0kd57)N6zE6X#g6{4#dWUvKPGk8B|T2&OMaBU`Hog@}yCzSE?j_kY5ozzDdN&9^7!Rfd<~Nxb9m1`KP%+#GM8WL1Ugcx?c$r6yKiRhNYa{z z;u{%M*33`}Dz9KU-R}OvRzR|Q%B3OG4yLF=zP3^Z8GkYP&uMXERL-1k{?e{>`2>{r zXBYFNxa@j74)(^93d{zP*LoAcfxoXDV-do2s*vMm{E9N{zTBqwN zG1#7Iu*qn1FvMHgqeHitXfRDk6byN03)|m^F=c{JojpwQf{_*}O{7SdJ+KHc+c-;MVPqYwvxXF0!fj`A0o{+JNRhIw zhhH771rGBRM=g4>Jhcy1TLtv8%G#IcT;J`yria!-J7_cDVz(Y_*u}!5Rek=$$@DOrpS`!Ue5OClje^DA@<`&||frp?(E6`xTf`9`LAs?I3L<1HC9C!%%NUbIsupr>TL&(RC ziHHFU0uDTc{3tk0G+;r%frpSE6R(K|EC@L85Yi(gK@$yF5OCljC{O-gX)s_xz(M?k z{Ag)SG+;r%frpSEJEMsPEC@L85b`5wHPL_t0S6vJeq2Qp4OkFx;34Ek*=eEy3jz*2 zg#4I$O*CLZz^O0)4(h@>K~Je6{i$JyE#MP}Vt@5|TU~K{LG*Zv&s(|Tp58ji=Xs3z zCiTzo=xei<$Jcs|`@9#**2gO4Fny21H}C#hM=`7ITa8IC&NjW&%%^qhzG3Ke7hR$h zN~6q`M;tGcJc}c@0^70Y4#30y8Q|C zy=ie2&f=5B?4>m=p0~DnB;o066nSzUQ8jurS&T*-LZ8RIQYE4Lhq~g^c`RD22rW$G zQD3}kFU19!#i=fjrPtM>%JSsPW4S)nxASVfMehojBC)ci#672{$)) zs$Hj9bg7W4#wwlZQM60kU+L95s&s9v-m-T=RX*>z!h)x^UVC@AX?;y2t?ql91U4+1 zsm{6^1U4)=MRex-@|YE5q5G=ULUHC(=eNn)j*wzjr;>#IgV2AB2{8lx*Di6(ITJ5Hjk=w)u;ol zc4_0W;Z>6IXntf@l2-#oKgP8L%G&;Cd?k4`Q108|(c}>CT9j<%Q+rz;m-?p70=qmm zS)?R7*{*Z7@BIT~nX+vAy-e&}={sHs#|9e{ZsoQzy_pqb@<)vosqQn-@u4Rc98fFWRvas2os*BV7p%Oa#Sl zm0wg9X~oi~(tiDpOUI4()as$RbaKH{Iim_kTLlwAaSO_?s4ARd(Nk%9k-8Jrog+rZqi6H)kO8H6v z7zWA=Q}+QcKE&?EuerLmjmj}qIM!2QlF(Ag01M*NpQ+^F=*1D( zGX+S2<&aOZgo%{{lpw@I5UM;2+8cwDPO!BjKG*2}oYay(3yWxMk#GxLf>j9_d<2%D zahS5&qQukQh@5nYen)zv2oI}=APGm8-Lq3dNTXU6j!J|HG6HgwWh*s`d*^o{XPltl z%X7HV@6vOmQL07u&PAkkK+gu`uh*jimWi`)^i4QORcu>D!zv+&a)$)rp$s`6eu823 zyo%3yB(yDpty5DuvKnC7H7_!S)@3FHN>$vtop%Y(jvK!NU9A#!$`7eRyEwchIvVO3 zSq-oxTDYu`h0~=a1eM!w*vYXVoydgw;fEOZ(5+$#HV)lJ!Q|A$O0(b~C|2q6g;3!X z%Uwfzc6{{jm3k)MiLG^;v;-SZ)bf)2STzd{0`Jp8M51p_Xk`VTD4MwKPw9U4_|PGC z4T)bY-BnqFjf?&{Ek8BQf`cIU^jQ(=o1|LiE!007ICU$9Kln6m&uMhMH_8bIhX&LUQ!XaTr0uBN)nO^3nrdeJjWYhzae4is5R)Om7C}NDO3|^BRlgL|Ztl8QA8<&Y+2V&?t@V5LA=m8l?v-4vb-QkV zyFTn*={(oHTKDRV39Nf{##9gW{K(%cnSflab-NC|35T0~@YOne7R&Is39Nf{+$@*V z-xFB(>hD>s=(q{Uz52+j^;rMy{kThTj?+ipD;dSQTIbw{qg>a$I%<;3=Z8#S{bc=+ zgS^=`*1fvff&83y*46qsXL+Zcy!~Fiy@5NO#?R^Hy~irm-`l{?Imp6JblUb?5Y1EG zc(S_3`POfv#9^J(QPDr4Ns1ni5P_D7IWcuP>K~fSfp085*Kn@FAF@H1AP8GR7J;ROV3E+(S|5qQM?i$Lm+z`u z+1DYx?KdF@T4E!F(^6<2fmQ<{gq#p0tzBBajVEtP%~j01kw`zgwqnVFi`S@BykHTe6`l zsnSh_h8DE3ce7a=dnO@5)|c>PnfvG2#C9}wSs~k4aaOI~6c4i@XiHDTEl*cGMJsh%9L0UsBev*toY=NH@wLc=mYxr!$Sl&tw$4Nk z6TvlAs4*$pt(y?SR0vYtiDhmp*_>c260@i!l{G|cIh*_M`JicF$&@;3xu?WVt;iFH zBqe+IS&v*ZBB_hgTj4-K*7j7Me8bJs)~x5&>!D&u{u4{v(x`mDHgOnACFIdfd4An| zyZlV0H)`+t9{j`vp{_zs3*4_w9EMT}xz&6fubXd|-z&e1JM-@Ibo^-PRp&(#!{4)VH+)u;CMsff#Bxul_DNLuxQung6a>maU0v-TDavT@wD6u zZ7j8DnN)vcYBRG%8w!RgaEgJL=u7+%w46h#Tf;DZd~II>eTfDF;kwMT!s!x1TN2vF zrVU$#hVbocTwPVjR4`0+4T%6N31El-WX;kS*;9junU#&Ts7KIDk{aTGYy&dK5`iV} ziMOx6@g?X!o}+Rv^i1I>s1kg=wt}c!nXvUjO#!zmfF}hHGf#>2MJ<~JC_xLioH~tE zUg#V1k~w7i+P(z(CO#l5N0$Uj$|II<3BuG@2}560Nld^&10YjssC0$=_!=z8KoB6M zK?^6EEbC0tP7BGWyWGBSUzUVe2TJLZK;e5tO@JdH+}7&GVq)KrpA@20DBlAAsluFn;VN55{RV)h&>IRfK%i{mnzLXT)xaHJ4GsEEfwpg@?T5^~UGQjt=$4BgHEAMR>t6~gPKuNT&P6DH;?0llG* zr;)vZXo$e|-O$k`jVUKhxT2VZGID$G+-Sa;Ee!-G*w19HwjK zyC`NK-v>_1qKVR`wbR0Sd)xPI)`g$TeD9X!O!bukO0egdmQM@o-ERA~Rxh-eb^>~` zJI|Novb3))M==R0d&qKI_v(;24w~o%7!-ZGHueh5xs6sI;;(x(G_G5b>ifds ; + +TUPLE: ifd count ifd-entries next +processed-tags strips buffer ; +CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; + +TUPLE: ifd-entry tag type count offset/value ; +CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; + +SINGLETONS: photometric-interpretation +photometric-interpretation-white-is-zero +photometric-interpretation-black-is-zero +photometric-interpretation-rgb +photometric-interpretation-palette-color ; +ERROR: bad-photometric-interpretation n ; +: lookup-photometric-interpretation ( n -- singleton ) + { + { 0 [ photometric-interpretation-white-is-zero ] } + { 1 [ photometric-interpretation-black-is-zero ] } + { 2 [ photometric-interpretation-rgb ] } + { 3 [ photometric-interpretation-palette-color ] } + [ bad-photometric-interpretation ] + } case ; + +SINGLETONS: compression +compression-none +compression-CCITT-2 +compression-lzw +compression-pack-bits ; +ERROR: bad-compression n ; +: lookup-compression ( n -- compression ) + { + { 1 [ compression-none ] } + { 2 [ compression-CCITT-2 ] } + { 5 [ compression-lzw ] } + { 32773 [ compression-pack-bits ] } + [ bad-compression ] + } case ; + +SINGLETONS: resolution-unit +resolution-unit-none +resolution-unit-inch +resolution-unit-centimeter ; +ERROR: bad-resolution-unit n ; +: lookup-resolution-unit ( n -- object ) + { + { 1 [ resolution-unit-none ] } + { 2 [ resolution-unit-inch ] } + { 3 [ resolution-unit-centimeter ] } + [ bad-resolution-unit ] + } case ; + +SINGLETONS: predictor +predictor-none +predictor-horizontal-differencing ; +ERROR: bad-predictor n ; +: lookup-predictor ( n -- object ) + { + { 1 [ predictor-none ] } + { 2 [ predictor-horizontal-differencing ] } + [ bad-predictor ] + } case ; + +SINGLETONS: planar-configuration +planar-configuration-chunky +planar-configuration-planar ; +ERROR: bad-planar-configuration n ; +: lookup-planar-configuration ( n -- object ) + { + { 1 [ planar-configuration-chunky ] } + { 2 [ planar-configuration-planar ] } + [ bad-planar-configuration ] + } case ; + +SINGLETONS: sample-format +sample-format-unsigned-integer +sample-format-signed-integer +sample-format-ieee-float +sample-format-undefined-data ; +ERROR: bad-sample-format n ; +: lookup-sample-format ( sequence -- object ) + [ + { + { 1 [ sample-format-unsigned-integer ] } + { 2 [ sample-format-signed-integer ] } + { 3 [ sample-format-ieee-float ] } + { 4 [ sample-format-undefined-data ] } + [ bad-sample-format ] + } case + ] map ; + +SINGLETONS: extra-samples +extra-samples-unspecified-alpha-data +extra-samples-associated-alpha-data +extra-samples-unassociated-alpha-data ; +ERROR: bad-extra-samples n ; +: lookup-extra-samples ( sequence -- object ) + { + { 0 [ extra-samples-unspecified-alpha-data ] } + { 1 [ extra-samples-associated-alpha-data ] } + { 2 [ extra-samples-unassociated-alpha-data ] } + [ bad-extra-samples ] + } case ; + +SINGLETONS: image-length image-width x-resolution y-resolution +rows-per-strip strip-offsets strip-byte-counts bits-per-sample +samples-per-pixel new-subfile-type orientation +unhandled-ifd-entry ; + +ERROR: bad-tiff-magic bytes ; +: tiff-endianness ( byte-array -- ? ) + { + { B{ CHAR: M CHAR: M } [ big-endian ] } + { B{ CHAR: I CHAR: I } [ little-endian ] } + [ bad-tiff-magic ] + } case ; + +: read-header ( tiff -- tiff ) + 2 read tiff-endianness [ >>endianness ] keep + [ + 2 read endian> >>the-answer + 4 read endian> >>ifd-offset + ] with-endianness ; + +: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; + +: read-ifd ( -- ifd ) + 2 read endian> + 2 read endian> + 4 read endian> + 4 read endian> ; + +: read-ifds ( tiff -- tiff ) + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; + +ERROR: no-tag class ; + +: ?at ( key assoc -- value/key ? ) + dupd at* [ nip t ] [ drop f ] if ; inline + +: find-tag ( idf class -- tag ) + swap processed-tags>> ?at [ no-tag ] unless ; + +: read-strips ( ifd -- ifd ) + dup + [ strip-byte-counts find-tag ] + [ strip-offsets find-tag ] bi + 2dup [ integer? ] both? [ + seek-absolute seek-input read 1array + ] [ + [ seek-absolute seek-input read ] { } 2map-as + ] if >>strips ; + +ERROR: unknown-ifd-type n ; + +: bytes>bits ( n/byte-array -- n ) + dup byte-array? [ byte-array>bignum ] when ; + +: value-length ( ifd-entry -- n ) + [ count>> ] [ type>> ] bi { + { 1 [ ] } + { 2 [ ] } + { 3 [ 2 * ] } + { 4 [ 4 * ] } + { 5 [ 8 * ] } + { 6 [ ] } + { 7 [ ] } + { 8 [ 2 * ] } + { 9 [ 4 * ] } + { 10 [ 8 * ] } + { 11 [ 4 * ] } + { 12 [ 8 * ] } + [ unknown-ifd-type ] + } case ; + +ERROR: bad-small-ifd-type n ; + +: adjust-offset/value ( ifd-entry -- obj ) + [ offset/value>> 4 >endian ] [ type>> ] bi + { + { 1 [ 1 head endian> ] } + { 3 [ 2 head endian> ] } + { 4 [ endian> ] } + { 6 [ 1 head endian> 8 >signed ] } + { 8 [ 2 head endian> 16 >signed ] } + { 9 [ endian> 32 >signed ] } + { 11 [ endian> bits>float ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ endian> 32 >signed ] map ] } + { 10 [ 8 group [ "ii" unpack first2 / ] map ] } + { 11 [ 4 group [ "f" unpack ] map ] } + { 12 [ 8 group [ "d" unpack ] map ] } + [ unknown-ifd-type ] + } case ; + +: ifd-entry-value ( ifd-entry -- n ) + dup value-length 4 <= [ + adjust-offset/value + ] [ + [ offset/value>> seek-absolute seek-input ] + [ value-length read ] + [ type>> ] tri offset-bytes>obj + ] if ; + +: process-ifd-entry ( ifd-entry -- value class ) + [ ifd-entry-value ] [ tag>> ] bi { + { 254 [ new-subfile-type ] } + { 256 [ image-width ] } + { 257 [ image-length ] } + { 258 [ bits-per-sample ] } + { 259 [ lookup-compression compression ] } + { 262 [ lookup-photometric-interpretation photometric-interpretation ] } + { 273 [ strip-offsets ] } + { 274 [ orientation ] } + { 277 [ samples-per-pixel ] } + { 278 [ rows-per-strip ] } + { 279 [ strip-byte-counts ] } + { 282 [ x-resolution ] } + { 283 [ y-resolution ] } + { 284 [ planar-configuration ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 317 [ lookup-predictor predictor ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + [ nip unhandled-ifd-entry ] + } case ; + +: process-ifd ( ifd -- ifd ) + dup ifd-entries>> + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; + +: strips>buffer ( ifd -- ifd ) + dup strips>> concat >>buffer ; + +: ifd>image ( ifd -- image ) + { + [ image-width find-tag ] + [ image-length find-tag ] + [ bits-per-sample find-tag sum ] + [ buffer>> ] + } cleave tiff-image new-image ; + +: parsed-tiff>images ( tiff -- sequence ) + ifds>> [ ifd>image ] map ; + +! tiff files can store several images -- we just take the first for now +M: tiff-image load-image* ( path tiff-image -- image ) + drop binary [ + + read-header dup endianness>> [ + read-ifds + dup ifds>> [ process-ifd read-strips strips>buffer drop ] each + ] with-endianness + ] with-file-reader + parsed-tiff>images first ; diff --git a/extra/images/viewer/authors.txt b/extra/images/viewer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/viewer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor new file mode 100644 index 0000000000..4d5df4874a --- /dev/null +++ b/extra/images/viewer/viewer.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators images.bitmap kernel math +math.functions namespaces opengl opengl.gl ui ui.gadgets +ui.gadgets.panes ui.render images.tiff sequences multiline +images.backend images io.pathnames strings ; +IN: images.viewer + +TUPLE: image-gadget < gadget { image image } ; + +GENERIC: draw-image ( image -- ) + +M: image-gadget pref-dim* + image>> + [ width>> ] [ height>> ] bi + [ abs ] bi@ 2array ; + +M: image-gadget draw-gadget* ( gadget -- ) + origin get [ image>> draw-image ] with-translation ; + +: ( image -- gadget ) + \ image-gadget new-gadget + swap >>image ; + +: bits>gl-params ( n -- gl-bgr gl-format ) + { + { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } + { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } + { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } + } case ; + +M: bitmap-image draw-image ( bitmap -- ) + { + [ + height>> dup 0 < [ + drop + 0 0 glRasterPos2i + 1.0 -1.0 glPixelZoom + ] [ + 0 swap abs glRasterPos2i + 1.0 1.0 glPixelZoom + ] if + ] + [ width>> abs ] + [ height>> abs ] + [ depth>> bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; + +: image-window ( path -- gadget ) + [ dup ] [ open-window ] bi ; + +M: tiff-image draw-image ( tiff -- ) + 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom + { + [ height>> ] + [ width>> ] + [ depth>> bits>gl-params ] + [ buffer>> ] + } cleave glDrawPixels ; + +GENERIC: image. ( image -- ) + +M: string image. ( image -- ) gadget. ; + +M: pathname image. ( image -- ) gadget. ; + +M: image image. ( image -- ) gadget. ; From 4ff9557351d5026a84f31ad447dd1f9c4d3595b2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 20:57:59 -0600 Subject: [PATCH 05/14] remove the grpahics vocab --- extra/graphics/authors.txt | 1 - extra/graphics/bitmap/authors.txt | 1 - extra/graphics/bitmap/bitmap-tests.factor | 30 -- extra/graphics/bitmap/bitmap.factor | 139 --------- extra/graphics/bitmap/test-images/1bit.bmp | Bin 1662 -> 0 bytes extra/graphics/bitmap/test-images/rgb4bit.bmp | Bin 5318 -> 0 bytes extra/graphics/bitmap/test-images/rgb8bit.bmp | Bin 11078 -> 0 bytes .../bitmap/test-images/thiswayup24.bmp | Bin 60054 -> 0 bytes extra/graphics/tags.txt | 1 - extra/graphics/tiff/authors.txt | 1 - extra/graphics/tiff/rgb.tiff | Bin 7916 -> 0 bytes extra/graphics/tiff/tiff-tests.factor | 11 - extra/graphics/tiff/tiff.factor | 271 ------------------ extra/graphics/viewer/authors.txt | 1 - extra/graphics/viewer/viewer.factor | 66 ----- 15 files changed, 522 deletions(-) delete mode 100644 extra/graphics/authors.txt delete mode 100755 extra/graphics/bitmap/authors.txt delete mode 100644 extra/graphics/bitmap/bitmap-tests.factor delete mode 100755 extra/graphics/bitmap/bitmap.factor delete mode 100644 extra/graphics/bitmap/test-images/1bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/rgb4bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/rgb8bit.bmp delete mode 100644 extra/graphics/bitmap/test-images/thiswayup24.bmp delete mode 100644 extra/graphics/tags.txt delete mode 100755 extra/graphics/tiff/authors.txt delete mode 100755 extra/graphics/tiff/rgb.tiff delete mode 100755 extra/graphics/tiff/tiff-tests.factor delete mode 100755 extra/graphics/tiff/tiff.factor delete mode 100755 extra/graphics/viewer/authors.txt delete mode 100644 extra/graphics/viewer/viewer.factor diff --git a/extra/graphics/authors.txt b/extra/graphics/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/graphics/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/bitmap/authors.txt b/extra/graphics/bitmap/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/graphics/bitmap/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor deleted file mode 100644 index f8a125e855..0000000000 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ /dev/null @@ -1,30 +0,0 @@ -USING: graphics.bitmap graphics.viewer io.encodings.binary -io.files io.files.unique kernel tools.test ; -IN: graphics.bitmap.tests - -: test-bitmap32-alpha ( -- path ) - "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ; - -: test-bitmap24 ( -- path ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ; - -: test-bitmap16 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ; - -: test-bitmap8 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ; - -: test-bitmap4 ( -- path ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ; - -: test-bitmap1 ( -- path ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" ; - -[ t ] -[ - test-bitmap24 - [ binary file-contents ] [ load-bitmap ] bi - - "test-bitmap24" unique-file - [ save-bitmap ] [ binary file-contents ] bi = -] unit-test diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor deleted file mode 100755 index f8008dc7c1..0000000000 --- a/extra/graphics/bitmap/bitmap.factor +++ /dev/null @@ -1,139 +0,0 @@ -! Copyright (C) 2007, 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types arrays byte-arrays columns -combinators fry grouping io io.binary io.encodings.binary -io.files kernel libc macros math math.bitwise math.functions -namespaces opengl opengl.gl prettyprint sequences strings -summary ui ui.gadgets.panes ; -IN: graphics.bitmap - -! Currently can only handle 24/32bit bitmaps. -! Handles row-reversed bitmaps (their height is negative) - -TUPLE: bitmap magic size reserved offset header-length width -height planes bit-count compression size-image -x-pels y-pels color-used color-important rgb-quads color-index -alpha-channel-zero? -array ; - -: array-copy ( bitmap array -- bitmap array' ) - over size-image>> abs memory>byte-array ; - -MACRO: (nbits>bitmap) ( bits -- ) - [ -3 shift ] keep '[ - bitmap new - 2over * _ * >>size-image - swap >>height - swap >>width - swap array-copy [ >>array ] [ >>color-index ] bi - _ >>bit-count - ] ; - -: bgr>bitmap ( array height width -- bitmap ) - 24 (nbits>bitmap) ; - -: bgra>bitmap ( array height width -- bitmap ) - 32 (nbits>bitmap) ; - -: 8bit>array ( bitmap -- array ) - [ rgb-quads>> 4 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; - -ERROR: bmp-not-supported n ; - -: raw-bitmap>array ( bitmap -- array ) - dup bit-count>> - { - { 32 [ color-index>> ] } - { 24 [ color-index>> ] } - { 16 [ bmp-not-supported ] } - { 8 [ 8bit>array ] } - { 4 [ bmp-not-supported ] } - { 2 [ bmp-not-supported ] } - { 1 [ bmp-not-supported ] } - } case >byte-array ; - -ERROR: bitmap-magic ; - -M: bitmap-magic summary - drop "First two bytes of bitmap stream must be 'BM'" ; - -: read2 ( -- n ) 2 read le> ; -: read4 ( -- n ) 4 read le> ; - -: parse-file-header ( bitmap -- bitmap ) - 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic - read4 >>size - read4 >>reserved - read4 >>offset ; - -: parse-bitmap-header ( bitmap -- bitmap ) - read4 >>header-length - read4 >>width - read4 >>height - read2 >>planes - read2 >>bit-count - read4 >>compression - read4 >>size-image - read4 >>x-pels - read4 >>y-pels - read4 >>color-used - read4 >>color-important ; - -: rgb-quads-length ( bitmap -- n ) - [ offset>> 14 - ] [ header-length>> ] bi - ; - -: color-index-length ( bitmap -- n ) - { - [ width>> ] - [ planes>> * ] - [ bit-count>> * 31 + 32 /i 4 * ] - [ height>> abs * ] - } cleave ; - -: parse-bitmap ( bitmap -- bitmap ) - dup rgb-quads-length read >>rgb-quads - dup color-index-length read >>color-index ; - -: (load-bitmap) ( path -- bitmap ) - binary [ - bitmap new - parse-file-header parse-bitmap-header parse-bitmap - ] with-file-reader ; - -: alpha-channel-zero? ( bitmap -- ? ) - array>> 4 3 [ 0 = ] all? ; - -: load-bitmap ( path -- bitmap ) - (load-bitmap) - dup raw-bitmap>array >>array - dup alpha-channel-zero? >>alpha-channel-zero? ; - -: write2 ( n -- ) 2 >le write ; -: write4 ( n -- ) 4 >le write ; - -: save-bitmap ( bitmap path -- ) - binary [ - B{ CHAR: B CHAR: M } write - [ - array>> length 14 + 40 + write4 - 0 write4 - 54 write4 - 40 write4 - ] [ - { - [ width>> write4 ] - [ height>> write4 ] - [ planes>> 1 or write2 ] - [ bit-count>> 24 or write2 ] - [ compression>> 0 or write4 ] - [ size-image>> write4 ] - [ x-pels>> 0 or write4 ] - [ y-pels>> 0 or write4 ] - [ color-used>> 0 or write4 ] - [ color-important>> 0 or write4 ] - [ rgb-quads>> write ] - [ color-index>> write ] - } cleave - ] bi - ] with-file-writer ; diff --git a/extra/graphics/bitmap/test-images/1bit.bmp b/extra/graphics/bitmap/test-images/1bit.bmp deleted file mode 100644 index 2f244c1d058bfd63c99009e24e43db3d2af59902..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1662 zcmd6mu}&N@5QY~a(QcXY+PnZo8WyGJ9a2QJkP4yX)=xlQ0r3D)UI5Obx(-^kP>P00mA^ zwBUF^jlQ?E;2?IzW6rM6HrH!wQhyj)b6UoD@XeYt9ody`K1_Mt%?}f{KVbJy%jcAj zt>KGpdF1)G8#sXx#Xjmy4aWdZ=sgF-W=L!giOF7nXWqQfqxQZB=n3}M&%h;db954z z5E@tMx~mVf%2{3&6~$+BXh5o3M#kinNOWWu>rFlx|3%95W4uyouK-4#SClXoB~%*C^4(}0onQG*9L-9b-!uM&JH<>m6OjuQDiV1l8blvI&dpWsH&fqeed;%iU%z`!sV;|oL`;1cM@txn1q zeNvtP$iOI5M`t`8&@TI<PT&zE=wk>n#+W#})qlnu6j zqKlaxW~`Q2))-G*FH&~!a+~whBxMUv@;vdku#nh6UAzYFMb4TYyweT-0k9zwR(&q} gI+mcb*Vx}V%YV4a?71qPKl;*mGj7Ahc<-2B0n`=D`~Uy| diff --git a/extra/graphics/bitmap/test-images/rgb4bit.bmp b/extra/graphics/bitmap/test-images/rgb4bit.bmp deleted file mode 100644 index 0c6f00d06c025f6947899450afd91ace50e5b57a..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 5318 zcmeH~J&xNj5QP;WN5~=4`v3&C50FFT3~?!6!4ht%;Vp6o}HvQbsetmbdm>Jba9`$>-CBW z&sXO?^>E{lhR9!(7a2zZE6-lcLCee=>GUfm*FpgFiOoJB;bmNH8kGz;lh9PADMtQ8LMIPr= zXg4}Uqs}^pqnuRP#EkO(krh!9^0kd57)N6zE6X#g6{4#dWUvKPGk8B|T2&OMaBU`Hog@}yCzSE?j_kY5ozzDdN&9^7!Rfd<~Nxb9m1`KP%+#GM8WL1Ugcx?c$r6yKiRhNYa{z z;u{%M*33`}Dz9KU-R}OvRzR|Q%B3OG4yLF=zP3^Z8GkYP&uMXERL-1k{?e{>`2>{r zXBYFNxa@j74)(^93d{zP*LoAcfxoXDV-do2s*vMm{E9N{zTBqwN zG1#7Iu*qn1FvMHgqeHitXfRDk6byN03)|m^F=c{JojpwQf{_*}O{7SdJ+KHc+c-;MVPqYwvxXF0!fj`A0o{+JNRhIw zhhH771rGBRM=g4>Jhcy1TLtv8%G#IcT;J`yria!-J7_cDVz(Y_*u}!5Rek=$$@DOrpS`!Ue5OClje^DA@<`&||frp?(E6`xTf`9`LAs?I3L<1HC9C!%%NUbIsupr>TL&(RC ziHHFU0uDTc{3tk0G+;r%frpSE6R(K|EC@L85Yi(gK@$yF5OCljC{O-gX)s_xz(M?k z{Ag)SG+;r%frpSEJEMsPEC@L85b`5wHPL_t0S6vJeq2Qp4OkFx;34Ek*=eEy3jz*2 zg#4I$O*CLZz^O0)4(h@>K~Je6{i$JyE#MP}Vt@5|TU~K{LG*Zv&s(|Tp58ji=Xs3z zCiTzo=xei<$Jcs|`@9#**2gO4Fny21H}C#hM=`7ITa8IC&NjW&%%^qhzG3Ke7hR$h zN~6q`M;tGcJc}c@0^70Y4#30y8Q|C zy=ie2&f=5B?4>m=p0~DnB;o066nSzUQ8jurS&T*-LZ8RIQYE4Lhq~g^c`RD22rW$G zQD3}kFU19!#i=fjrPtM>%JSsPW4S)nxASVfMehojBC)ci#672{$)) zs$Hj9bg7W4#wwlZQM60kU+L95s&s9v-m-T=RX*>z!h)x^UVC@AX?;y2t?ql91U4+1 zsm{6^1U4)=MRex-@|YE5q5G=ULUHC(=eNn)j*wzjr;>#IgV2AB2{8lx*Di6(ITJ5Hjk=w)u;ol zc4_0W;Z>6IXntf@l2-#oKgP8L%G&;Cd?k4`Q108|(c}>CT9j<%Q+rz;m-?p70=qmm zS)?R7*{*Z7@BIT~nX+vAy-e&}={sHs#|9e{ZsoQzy_pqb@<)vosqQn-@u4Rc98fFWRvas2os*BV7p%Oa#Sl zm0wg9X~oi~(tiDpOUI4()as$RbaKH{Iim_kTLlwAaSO_?s4ARd(Nk%9k-8Jrog+rZqi6H)kO8H6v z7zWA=Q}+QcKE&?EuerLmjmj}qIM!2QlF(Ag01M*NpQ+^F=*1D( zGX+S2<&aOZgo%{{lpw@I5UM;2+8cwDPO!BjKG*2}oYay(3yWxMk#GxLf>j9_d<2%D zahS5&qQukQh@5nYen)zv2oI}=APGm8-Lq3dNTXU6j!J|HG6HgwWh*s`d*^o{XPltl z%X7HV@6vOmQL07u&PAkkK+gu`uh*jimWi`)^i4QORcu>D!zv+&a)$)rp$s`6eu823 zyo%3yB(yDpty5DuvKnC7H7_!S)@3FHN>$vtop%Y(jvK!NU9A#!$`7eRyEwchIvVO3 zSq-oxTDYu`h0~=a1eM!w*vYXVoydgw;fEOZ(5+$#HV)lJ!Q|A$O0(b~C|2q6g;3!X z%Uwfzc6{{jm3k)MiLG^;v;-SZ)bf)2STzd{0`Jp8M51p_Xk`VTD4MwKPw9U4_|PGC z4T)bY-BnqFjf?&{Ek8BQf`cIU^jQ(=o1|LiE!007ICU$9Kln6m&uMhMH_8bIhX&LUQ!XaTr0uBN)nO^3nrdeJjWYhzae4is5R)Om7C}NDO3|^BRlgL|Ztl8QA8<&Y+2V&?t@V5LA=m8l?v-4vb-QkV zyFTn*={(oHTKDRV39Nf{##9gW{K(%cnSflab-NC|35T0~@YOne7R&Is39Nf{+$@*V z-xFB(>hD>s=(q{Uz52+j^;rMy{kThTj?+ipD;dSQTIbw{qg>a$I%<;3=Z8#S{bc=+ zgS^=`*1fvff&83y*46qsXL+Zcy!~Fiy@5NO#?R^Hy~irm-`l{?Imp6JblUb?5Y1EG zc(S_3`POfv#9^J(QPDr4Ns1ni5P_D7IWcuP>K~fSfp085*Kn@FAF@H1AP8GR7J;ROV3E+(S|5qQM?i$Lm+z`u z+1DYx?KdF@T4E!F(^6<2fmQ<{gq#p0tzBBajVEtP%~j01kw`zgwqnVFi`S@BykHTe6`l zsnSh_h8DE3ce7a=dnO@5)|c>PnfvG2#C9}wSs~k4aaOI~6c4i@XiHDTEl*cGMJsh%9L0UsBev*toY=NH@wLc=mYxr!$Sl&tw$4Nk z6TvlAs4*$pt(y?SR0vYtiDhmp*_>c260@i!l{G|cIh*_M`JicF$&@;3xu?WVt;iFH zBqe+IS&v*ZBB_hgTj4-K*7j7Me8bJs)~x5&>!D&u{u4{v(x`mDHgOnACFIdfd4An| zyZlV0H)`+t9{j`vp{_zs3*4_w9EMT}xz&6fubXd|-z&e1JM-@Ibo^-PRp&(#!{4)VH+)u;CMsff#Bxul_DNLuxQung6a>maU0v-TDavT@wD6u zZ7j8DnN)vcYBRG%8w!RgaEgJL=u7+%w46h#Tf;DZd~II>eTfDF;kwMT!s!x1TN2vF zrVU$#hVbocTwPVjR4`0+4T%6N31El-WX;kS*;9junU#&Ts7KIDk{aTGYy&dK5`iV} ziMOx6@g?X!o}+Rv^i1I>s1kg=wt}c!nXvUjO#!zmfF}hHGf#>2MJ<~JC_xLioH~tE zUg#V1k~w7i+P(z(CO#l5N0$Uj$|II<3BuG@2}560Nld^&10YjssC0$=_!=z8KoB6M zK?^6EEbC0tP7BGWyWGBSUzUVe2TJLZK;e5tO@JdH+}7&GVq)KrpA@20DBlAAsluFn;VN55{RV)h&>IRfK%i{mnzLXT)xaHJ4GsEEfwpg@?T5^~UGQjt=$4BgHEAMR>t6~gPKuNT&P6DH;?0llG* zr;)vZXo$e|-O$k`jVUKhxT2VZGID$G+-Sa;Ee!-G*w19HwjK zyC`NK-v>_1qKVR`wbR0Sd)xPI)`g$TeD9X!O!bukO0egdmQM@o-ERA~Rxh-eb^>~` zJI|Novb3))M==R0d&qKI_v(;24w~o%7!-ZGHueh5xs6sI;;(x(G_G5b4#XP|nBx#_MiZEA7RYB3o_UO{CL} z`4T$qJq*th{=a--LJ$twGab&~cKEvCxzs}f`5@Q@BhyF!+F=vt__71{97L%+4=m~D z9hNH{W8PYvFe3@79lyErV~3@*N%(>r?VZKZG6v9RZ*Ra8q*7{>GX|VIe3PpS&ivIS z?^&LeK8z>{n<{)a0r?nEQ~udCf$vVwgS=r^3G-_E+gFv%6EeNwXFF*rvu!upuv%ip*n(QxuB?^&#g&vGP+-HfAYmMg3;dw@dhhE- z7lwbw-s{xtPa_7r)H!eP`Og6gK+u9n01s3Mwe9YxK(>9joB zKdeLc<9)C@<7q0Hep4&BWl`vzmVJm$=HO><-HG59e(!f5if>oVZ3om$S$LU4yFUfB z6l=gYlP)(zSA5i*kFB}`&gj8--?pg!q=9lx+FljysPXB#G^_Z^{Jl=egHLZQq*MH? zz&b1YcLJ@dTns|TBqR4c*JPu(iMM5XZYP`);$PR#kngFaC#sJ^^AU;>)~n*xtyJ8_ zgN8LKgf-rzkuIv|$0MT6L^gz+X{JKj(Z6uh5RYky!n@H76=YN&;B{jqFI3Gn_ns-> zAw9#=76VV-Z^ral&R6F99bBr?r|#!f?Gx%}&eFp}zpivgw~@)XYqp4XMaSU&;ws2# z5J+~KQY~4Mk25G((Th^x1stmt|j!3 zn3?TIU2Z-`Rj)OL3|sh^%W!}nw#+C9n_&)Zl6+=1yy&%BG_v5cbKZ3439PDsAoe%t z#*CG4U{?J7rL!l)Kkw*nibUKm4yda4545WJw0(U_=79*PN46{W?3mDv0TTSwoF_Nt zxRx}mPAdSeBB}1~A4rySZO}MX9%TrnO5;^xeO)D}(L=2q4Yweb`9fnuR;$x_5sY@j zQ)X19O2);=MaLPRSBv3At~M_k2GX}KCVLjO<;}!oDr>#$;OwC8y!F>#zxagnd-|N? zAq#GNxhg*6bn)yDpWIWv)H`bKr1t~5&qp+|tUHoU6EOS^ED7D5XUbBvC3Mj+M}tgT zIwMoSCx+alb2+#uJ*T1aw1|J8o1<8s#a*iNu93(r(8azoEr2oKdCal2S^{+ zTjmlfAs3;83uWe75d|hW_ttk4Iz?d>S?^XMyU-Hm3i6NdZ>Pv|By@e+xVlL%YZatw zxv~`?29;GsA*Q`gy;~OrXCkO44(Fc9B|6nOThCLl zSSY(_wv|;q->`NBA?wKAmtFaq-^-h;L;dedY4C^ zmx~eaXwoylG@^P*wdfSO(GHh*^!AFk)mQgvag}qE@AG$_A#LnZiP$fp>4cL)>eaZB zz3f^s2H_lRd8}&lS8_0EVqG3FAv`K)pg8B=dI*0I>7~)4RnE)eEs(2iVhj*g*nLt|BIWMV+WdGTc5dgoSZ-=&yzFhx<>^Gg0Jc^bAq5qa103 z5%49dqze)%6&njDY1!!S8WOt+Jy)5FDT5LRsyx@2U;k>v9-#R0PnBC&T{-@-PKF6L zHYJNB9_da$Dz`Z8YyY&>1uU^Schk4p+-19*{PcuV{q)VVWf9CjS8hGQ#3yjSUaih~ zPXm;N{pX|vE6;pV$Q#wHAdEl)*QAYJM!`FqBEtB{Z|(hxJ9)cCX(!T9V?^ zzEn}CS#JvN`#q>Zb-wFCHif3val~CudYtpe5kGOXqVk6dCBr;EoovJo451$!=twn> zXd{cvSW7VRipLzyq;j@z^jYFNp^{yZb*Z$*59v?*Q%a~%LvUMD!sJLU#f!~Q@tj+*kO;6TGBYT4MnWKI}*+*BwowPYUChPr0f(W zt0t@D9%<;QB%)~4z|fxNME$+(E*~`c16|rq_5YS_CE8#;aL-ldNbVrOlWyY25n$?}ZY972532(Q(wWr;q zTIKb&^VZeLz(4?;{Q^uMMtBTEx5o2!wX%Z3#lM&yK0VZlC|xLfxL1ED7sX3pV@^m4|G4^YcZtKcK?CN`73|acryP!g9=M+|zHN!Nn_81g1t$JtN3sMo3 z#zwhvetY_A!`fH}yQTqw>V<2m)?Y^K|~ggp&d6t}(CC;y`wqLm_OjV06%O*r;&) zUmZ|inMv^#-r`bi>YBfU%rFV#cI=}Mny%SG7U;xIvI{7q&z{Y=(uR}89HrH13qnZG zCs||;FKjS~+ur7iNpXP;F{S3@_RS6qhpd6cwnxmQ_!@;Rn9 zmX}o(t?$mdmp_RVV%r9z4B>Nq9Cc&s&quQ%sF0!eTiCYH zr;29YNrH)U*&t_T{;R)1g!Wk8$nyRjE7^=80-Rr10EFqZ+=YvJ;C+2Q>M%tXfzV27 zDW*`RRDqq1uq(94E2%4-;9~25XFjg7Z@8QI(WzLX>qso6XWr9e{AmJgG#KgXn-c2a{0K2~%i1*M zX>4qL|5wS$8i(TOnQecEr|67$`HiQacT&cilPcG0ND3PFWk@?%ODhnsUhm3B!5Ks4 z1pHZ(cy4Knl8jBJ~ZoImFYoiuGR?%I}%~henp-PZbe_Kh1MZ!$Rs5> zCy>`EPg9Rcm1UN5HH3w>y6pS1<^I_N*VXXw)PGVO?=~^7acaikUy4(<6SyK0!E^di zEBiOaF+tnTgI@YgfaJ4QyY&(2H4oDG-qeEK3856#68)`%=M&NL4TV?nSZWY6rjr zU7nKWU0Vis?W#BSj3Q*zKSyW#+!j~{U)mf4n2}}qd$T&sj@gbsdfRe%b^nG)RUq@H z{i9k+QoP{OTt?DNXx9b>{wo(0-)RL(BpXqY08a<8BB7bW+XjKf^SyQa(om|#XkN`V zae+#mGfI^H#^6%zMr-=!XtV<@RHtH(QIh|j7+9r`q~@Yp3=idRiowrR=k9Y#ikE)@!e6@(oy!n)bSFp55QYUVS~$r*D4|d-0zeEUfQBVOI=MgK3nGUfx;k z2?ObapK0T1%?eE69z=*cga3%V$)@}?VNF{_F1Z8F3HxOE+d)B7x$7014&cb<>Ac+& zvG+z9??ATLwdQ$&$Bd9zru25pJo?eCNE~$9sE|olFd#)@gTErU!y=;h3ZjxYI4~rA z&~{P!ad+QveeiPO*MnJtv}=pskkz2MaYu^j3%^cRYrU&8BlG!>dMzt{3(_^<1jUtg zUycgdoX_93{z2JWhUfWE9gX0v7yKXBI;$v%8&22cD%>OykBXfosBH^hCU2y|lG5li z$=m4V&j*A#+BWm^q6j$K+1wl{9Nfliq!HsW)ydAby?gN$l}#XxLe%|uiO9e#cLwv%q8tHwzN?1u=F(YQQ>GZFygKdnBAzJUX$D1zi`%<}j7dCHg z(%H%88)v~v?P4bEbH*jeh2zt?;6WD{cy4Z0d_RTh5lhQ^kI~LGNgxh)zJ682yi=NDgZpDccfJmN-73-wOGy3uRUA`qGT){-M zs8b_TUsdQ!-Q})#Gk50dKn4l2p}K9$1nd6{VAi2{c;~6|=nQs<|Ck4%)4dlw8PwJxVzeAI5cDftMNqyvmhbQjRmnZ{WoKSn0j z5aLZ3kVU3WVv=diOFk*uH}yN3PDUmYhyo({2J24=>P2@xhqYQP?n=$6es9N7Tq(~i zSIf!RLe3!ijsdLr?#uqquSPBC+LiOhT-@j_hOn}=gLfrUwG3b7w7W0NqJ4f zRn=*cMVo#T)iaSv6MzQ7y6L zpJN!{>SNF_;+OK&0V9Kn^e zf#b1Kh<0?Fvxwio^{jt5Tt+j(sKZX7*EqZHvglXo>f6uewyDx)fvA~0(w>VJqOD{<4i$%hd~86zvVtfBA0SZxw^a9*n>W8%Y> z>A{g~#_-aECHEuPvzl%1og)4Xe4Gr<|E~EAdrnEI)_*9){IKPkJK=_l;LqbXyR|E+ z!3efw&5VD?5+LnZyK~YCxv@sKWqupKrD-{?`wd?IY5bNt^oC}%>Lr%c*~8w<7XQfg z1Dgyhfa|hpFPJ5NI2pe+Uqd85u-CW7x z`Qg_MUz|)sA(OA-+Lo}nj@8xOZ&bXV9i!6jc6Ib$3gkH^br#ig;1^y~9$%lzxU6%$ zU)lan>eQi(oh3rTQF7QhN33HUV`N=$#ju>p{27dm_HmK=?<2}j*Am*$ z1xbyTdp1EMXk+*t;Q;piNC?9ILI|qD( z0xS-&Bfu5`D+KHfV0QrfejWA*2L4w8>~Fws1C|chbHG>u<2*T*0oM@%hCMm~Yxi(L zAbva$r~w}YswV(}&_uwSkbpqMWFSx|IS3>{0X!41BtTEhrvia?s6ik<8W3oc7FYv= zKvMJ|kkvU5D1-rcPe8w-03Cwxj(-pE0N{t6IzEpAo`iF9J_Rh}0_UfIqbCyxbn0Xs zcmdGqlXKvuKvXz*Am9O@A>bO?lXdJpbig|Bbs%EEz$e%E0oRk diff --git a/extra/graphics/tiff/tiff-tests.factor b/extra/graphics/tiff/tiff-tests.factor deleted file mode 100755 index f800b4d213..0000000000 --- a/extra/graphics/tiff/tiff-tests.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test graphics.tiff ; -IN: graphics.tiff.tests - -: tiff-test-path ( -- path ) - "resource:extra/graphics/tiff/rgb.tiff" ; - -: tiff-test-path2 ( -- path ) - "resource:extra/graphics/tiff/octagon.tiff" ; - diff --git a/extra/graphics/tiff/tiff.factor b/extra/graphics/tiff/tiff.factor deleted file mode 100755 index 0481af8747..0000000000 --- a/extra/graphics/tiff/tiff.factor +++ /dev/null @@ -1,271 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators io io.encodings.binary io.files -kernel pack endian tools.hexdump constructors sequences arrays -sorting.slots math.order math.parser prettyprint classes -io.binary assocs math math.bitwise byte-arrays grouping ; -IN: graphics.tiff - -TUPLE: tiff endianness the-answer ifd-offset ifds ; - -CONSTRUCTOR: tiff ( -- tiff ) - V{ } clone >>ifds ; - -TUPLE: ifd count ifd-entries next -processed-tags strips buffer ; -CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ; - -TUPLE: ifd-entry tag type count offset/value ; -CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ; - -SINGLETONS: photometric-interpretation -photometric-interpretation-white-is-zero -photometric-interpretation-black-is-zero -photometric-interpretation-rgb -photometric-interpretation-palette-color ; -ERROR: bad-photometric-interpretation n ; -: lookup-photometric-interpretation ( n -- singleton ) - { - { 0 [ photometric-interpretation-white-is-zero ] } - { 1 [ photometric-interpretation-black-is-zero ] } - { 2 [ photometric-interpretation-rgb ] } - { 3 [ photometric-interpretation-palette-color ] } - [ bad-photometric-interpretation ] - } case ; - -SINGLETONS: compression -compression-none -compression-CCITT-2 -compression-lzw -compression-pack-bits ; -ERROR: bad-compression n ; -: lookup-compression ( n -- compression ) - { - { 1 [ compression-none ] } - { 2 [ compression-CCITT-2 ] } - { 5 [ compression-lzw ] } - { 32773 [ compression-pack-bits ] } - [ bad-compression ] - } case ; - -SINGLETONS: resolution-unit -resolution-unit-none -resolution-unit-inch -resolution-unit-centimeter ; -ERROR: bad-resolution-unit n ; -: lookup-resolution-unit ( n -- object ) - { - { 1 [ resolution-unit-none ] } - { 2 [ resolution-unit-inch ] } - { 3 [ resolution-unit-centimeter ] } - [ bad-resolution-unit ] - } case ; - -SINGLETONS: predictor -predictor-none -predictor-horizontal-differencing ; -ERROR: bad-predictor n ; -: lookup-predictor ( n -- object ) - { - { 1 [ predictor-none ] } - { 2 [ predictor-horizontal-differencing ] } - [ bad-predictor ] - } case ; - -SINGLETONS: planar-configuration -planar-configuration-chunky -planar-configuration-planar ; -ERROR: bad-planar-configuration n ; -: lookup-planar-configuration ( n -- object ) - { - { 1 [ planar-configuration-chunky ] } - { 2 [ planar-configuration-planar ] } - [ bad-planar-configuration ] - } case ; - -ERROR: bad-sample-format n ; -SINGLETONS: sample-format -sample-format-unsigned-integer -sample-format-signed-integer -sample-format-ieee-float -sample-format-undefined-data ; -: lookup-sample-format ( seq -- object ) - [ - { - { 1 [ sample-format-unsigned-integer ] } - { 2 [ sample-format-signed-integer ] } - { 3 [ sample-format-ieee-float ] } - { 4 [ sample-format-undefined-data ] } - [ bad-sample-format ] - } case - ] map ; - -ERROR: bad-extra-samples n ; -SINGLETONS: extra-samples -extra-samples-unspecified-alpha-data -extra-samples-associated-alpha-data -extra-samples-unassociated-alpha-data ; -: lookup-extra-samples ( seq -- object ) - { - { 0 [ extra-samples-unspecified-alpha-data ] } - { 1 [ extra-samples-associated-alpha-data ] } - { 2 [ extra-samples-unassociated-alpha-data ] } - [ bad-extra-samples ] - } case ; - -SINGLETONS: image-length image-width x-resolution y-resolution -rows-per-strip strip-offsets strip-byte-counts bits-per-sample -samples-per-pixel new-subfile-type orientation -unhandled-ifd-entry ; - -ERROR: bad-tiff-magic bytes ; -: tiff-endianness ( byte-array -- ? ) - { - { B{ CHAR: M CHAR: M } [ big-endian ] } - { B{ CHAR: I CHAR: I } [ little-endian ] } - [ bad-tiff-magic ] - } case ; - -: read-header ( tiff -- tiff ) - 2 read tiff-endianness [ >>endianness ] keep - [ - 2 read endian> >>the-answer - 4 read endian> >>ifd-offset - ] with-endianness ; - -: push-ifd ( tiff ifd -- tiff ) over ifds>> push ; - -: read-ifd ( -- ifd ) - 2 read endian> - 2 read endian> - 4 read endian> - 4 read endian> ; - -: read-ifds ( tiff -- tiff ) - dup ifd-offset>> seek-absolute seek-input - 2 read endian> - dup [ read-ifd ] replicate - 4 read endian> - [ push-ifd ] [ 0 = [ read-ifds ] unless ] bi ; - -ERROR: no-tag class ; - -: ?at ( key assoc -- value/key ? ) - dupd at* [ nip t ] [ drop f ] if ; inline - -: find-tag ( idf class -- tag ) - swap processed-tags>> ?at [ no-tag ] unless ; - -: read-strips ( ifd -- ifd ) - dup - [ strip-byte-counts find-tag ] - [ strip-offsets find-tag ] bi - 2dup [ integer? ] both? [ - seek-absolute seek-input read 1array - ] [ - [ seek-absolute seek-input read ] { } 2map-as - ] if >>strips ; - -ERROR: unknown-ifd-type n ; - -: bytes>bits ( n/byte-array -- n ) - dup byte-array? [ byte-array>bignum ] when ; - -: value-length ( ifd-entry -- n ) - [ count>> ] [ type>> ] bi { - { 1 [ ] } - { 2 [ ] } - { 3 [ 2 * ] } - { 4 [ 4 * ] } - { 5 [ 8 * ] } - { 6 [ ] } - { 7 [ ] } - { 8 [ 2 * ] } - { 9 [ 4 * ] } - { 10 [ 8 * ] } - { 11 [ 4 * ] } - { 12 [ 8 * ] } - [ unknown-ifd-type ] - } case ; - -ERROR: bad-small-ifd-type n ; - -: adjust-offset/value ( ifd-entry -- obj ) - [ offset/value>> 4 >endian ] [ type>> ] bi - { - { 1 [ 1 head endian> ] } - { 3 [ 2 head endian> ] } - { 4 [ endian> ] } - { 6 [ 1 head endian> 8 >signed ] } - { 8 [ 2 head endian> 16 >signed ] } - { 9 [ endian> 32 >signed ] } - { 11 [ endian> bits>float ] } - [ bad-small-ifd-type ] - } case ; - -: offset-bytes>obj ( bytes type -- obj ) - { - { 1 [ ] } ! blank - { 2 [ ] } ! read c strings here - { 3 [ 2 [ endian> ] map ] } - { 4 [ 4 [ endian> ] map ] } - { 5 [ 8 [ "II" unpack first2 / ] map ] } - { 6 [ [ 8 >signed ] map ] } - { 7 [ ] } ! blank - { 8 [ 2 [ endian> 16 >signed ] map ] } - { 9 [ 4 [ endian> 32 >signed ] map ] } - { 10 [ 8 group [ "ii" unpack first2 / ] map ] } - { 11 [ 4 group [ "f" unpack ] map ] } - { 12 [ 8 group [ "d" unpack ] map ] } - [ unknown-ifd-type ] - } case ; - -: ifd-entry-value ( ifd-entry -- n ) - dup value-length 4 <= [ - adjust-offset/value - ] [ - [ offset/value>> seek-absolute seek-input ] - [ value-length read ] - [ type>> ] tri offset-bytes>obj - ] if ; - -: process-ifd-entry ( ifd-entry -- value class ) - [ ifd-entry-value ] [ tag>> ] bi { - { 254 [ new-subfile-type ] } - { 256 [ image-width ] } - { 257 [ image-length ] } - { 258 [ bits-per-sample ] } - { 259 [ lookup-compression compression ] } - { 262 [ lookup-photometric-interpretation photometric-interpretation ] } - { 273 [ strip-offsets ] } - { 274 [ orientation ] } - { 277 [ samples-per-pixel ] } - { 278 [ rows-per-strip ] } - { 279 [ strip-byte-counts ] } - { 282 [ x-resolution ] } - { 283 [ y-resolution ] } - { 284 [ planar-configuration ] } - { 296 [ lookup-resolution-unit resolution-unit ] } - { 317 [ lookup-predictor predictor ] } - { 338 [ lookup-extra-samples extra-samples ] } - { 339 [ lookup-sample-format sample-format ] } - [ nip unhandled-ifd-entry ] - } case ; - -: process-ifd ( ifd -- ifd ) - dup ifd-entries>> - [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; - -: strips>buffer ( ifd -- ifd ) - dup strips>> concat >>buffer ; - -: (load-tiff) ( path -- tiff ) - binary [ - - read-header dup endianness>> [ - read-ifds - dup ifds>> [ process-ifd read-strips strips>buffer drop ] each - ] with-endianness - ] with-file-reader ; - -: load-tiff ( path -- tiff ) (load-tiff) ; diff --git a/extra/graphics/viewer/authors.txt b/extra/graphics/viewer/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/extra/graphics/viewer/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor deleted file mode 100644 index 517ab4e010..0000000000 --- a/extra/graphics/viewer/viewer.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators graphics.bitmap kernel math -math.functions namespaces opengl opengl.gl ui ui.gadgets -ui.gadgets.panes ui.render graphics.tiff sequences ; -IN: graphics.viewer - -TUPLE: graphics-gadget < gadget image ; - -GENERIC: draw-image ( image -- ) -GENERIC: width ( image -- w ) -GENERIC: height ( image -- h ) - -M: graphics-gadget pref-dim* - image>> [ width ] keep height abs 2array ; - -M: graphics-gadget draw-gadget* ( gadget -- ) - origin get [ image>> draw-image ] with-translation ; - -: ( bitmap -- gadget ) - \ graphics-gadget new-gadget - swap >>image ; - -: bits>gl-params ( n -- gl-bgr gl-format ) - { - { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] } - { 24 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 8 [ GL_BGR GL_UNSIGNED_BYTE ] } - { 4 [ GL_BGR GL_UNSIGNED_BYTE ] } - } case ; - -M: bitmap draw-image ( bitmap -- ) - dup height>> 0 < [ - 0 0 glRasterPos2i - 1.0 -1.0 glPixelZoom - ] [ - 0 over height>> abs glRasterPos2i - 1.0 1.0 glPixelZoom - ] if - [ width>> ] keep - [ - [ height>> abs ] keep - bit-count>> bits>gl-params - ] keep array>> glDrawPixels ; - -M: bitmap width ( bitmap -- ) width>> ; -M: bitmap height ( bitmap -- ) height>> ; - -: bitmap. ( path -- ) - load-bitmap gadget. ; - -: bitmap-window ( path -- gadget ) - load-bitmap [ "bitmap" open-window ] keep ; - -M: tiff width ( tiff -- ) ifds>> first image-width find-tag ; -M: tiff height ( tiff -- ) ifds>> first image-length find-tag ; - -M: tiff draw-image ( tiff -- ) - [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip - ifds>> first - { - [ image-width find-tag ] - [ image-length find-tag ] - [ bits-per-sample find-tag sum bits>gl-params ] - [ buffer>> ] - } cleave glDrawPixels ; From 72b343ce03c39b765926de373eee0aee12dbf9b6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:15:57 -0600 Subject: [PATCH 06/14] fix images tests --- extra/images/bitmap/bitmap-tests.factor | 13 +++++-------- extra/images/bitmap/bitmap.factor | 11 ++++++++--- extra/images/tiff/tiff-tests.factor | 5 ++--- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor index 6865bfee3c..a2b3188749 100644 --- a/extra/images/bitmap/bitmap-tests.factor +++ b/extra/images/bitmap/bitmap-tests.factor @@ -2,23 +2,20 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test ; IN: images.bitmap.tests -: test-bitmap32-alpha ( -- path ) - "resource:extra/images/bitmap/test-images/32alpha.bmp" ; - : test-bitmap24 ( -- path ) - "resource:extra/images/bitmap/test-images/thiswayup24.bmp" ; + "resource:extra/images/test-images/thiswayup24.bmp" ; : test-bitmap16 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb16bit.bmp" ; + "resource:extra/images/test-images/rgb16bit.bmp" ; : test-bitmap8 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb8bit.bmp" ; + "resource:extra/images/test-images/rgb8bit.bmp" ; : test-bitmap4 ( -- path ) - "resource:extra/images/bitmap/test-images/rgb4bit.bmp" ; + "resource:extra/images/test-images/rgb4bit.bmp" ; : test-bitmap1 ( -- path ) - "resource:extra/images/bitmap/test-images/1bit.bmp" ; + "resource:extra/images/test-images/1bit.bmp" ; [ t ] [ diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index 220cdc153f..eb31dcd385 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -97,7 +97,7 @@ M: bitmap-magic summary dup rgb-quads-length read >>rgb-quads dup color-index-length read >>color-index ; -: load-bitmap ( path -- bitmap ) +: load-bitmap-data ( path -- bitmap ) binary [ bitmap new parse-file-header parse-bitmap-header parse-bitmap @@ -106,14 +106,19 @@ M: bitmap-magic summary : alpha-channel-zero? ( bitmap -- ? ) buffer>> 4 3 [ 0 = ] all? ; +: process-bitmap-data ( bitmap -- bitmap ) + dup raw-bitmap>buffer >>buffer + dup alpha-channel-zero? >>alpha-channel-zero? ; + +: load-bitmap ( path -- bitmap ) + load-bitmap-data process-bitmap-data ; + : bitmap>image ( bitmap -- bitmap-image ) { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave bitmap-image new-image ; M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap - dup raw-bitmap>buffer >>buffer - dup alpha-channel-zero? >>alpha-channel-zero? bitmap>image ; : write2 ( n -- ) 2 >le write ; diff --git a/extra/images/tiff/tiff-tests.factor b/extra/images/tiff/tiff-tests.factor index dcc4b05eab..9905e7ad79 100755 --- a/extra/images/tiff/tiff-tests.factor +++ b/extra/images/tiff/tiff-tests.factor @@ -4,8 +4,7 @@ USING: tools.test images.tiff ; IN: images.tiff.tests : tiff-test-path ( -- path ) - "resource:extra/images/tiff/rgb.tiff" ; + "resource:extra/images/test-images/rgb.tiff" ; : tiff-test-path2 ( -- path ) - "resource:extra/images/tiff/octagon.tiff" ; - + "resource:extra/images/test-images/octagon.tiff" ; From d887ff67888bd42e1ebecfd0a1316b90dbed9d5e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:26:52 -0600 Subject: [PATCH 07/14] fix screen capture --- extra/cap/cap.factor | 4 ++-- extra/images/bitmap/bitmap.factor | 32 +++++++++++++++---------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index 716435775d..1f62441028 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays kernel math namespaces -opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer +opengl.gl sequences math.vectors ui images.bitmap images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ; IN: cap @@ -27,4 +27,4 @@ IN: cap [ screenshot ] dip save-bitmap ; : screenshot. ( window -- ) - [ screenshot ] [ title>> ] bi open-window ; + [ screenshot ] [ title>> ] bi open-window ; diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor index eb31dcd385..50975b2bb3 100755 --- a/extra/images/bitmap/bitmap.factor +++ b/extra/images/bitmap/bitmap.factor @@ -21,22 +21,6 @@ buffer ; : array-copy ( bitmap array -- bitmap array' ) over size-image>> abs memory>byte-array ; -MACRO: (nbits>bitmap) ( bits -- ) - [ -3 shift ] keep '[ - bitmap new - 2over * _ * >>size-image - swap >>height - swap >>width - swap array-copy [ >>buffer ] [ >>color-index ] bi - _ >>bit-count - ] ; - -: bgr>bitmap ( array height width -- bitmap ) - 24 (nbits>bitmap) ; - -: bgra>bitmap ( array height width -- bitmap ) - 32 (nbits>bitmap) ; - : 8bit>buffer ( bitmap -- array ) [ rgb-quads>> 4 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; @@ -121,6 +105,22 @@ M: bitmap-image load-image* ( path bitmap -- bitmap-image ) drop load-bitmap bitmap>image ; +MACRO: (nbits>bitmap) ( bits -- ) + [ -3 shift ] keep '[ + bitmap new + 2over * _ * >>size-image + swap >>height + swap >>width + swap array-copy [ >>buffer ] [ >>color-index ] bi + _ >>bit-count bitmap>image + ] ; + +: bgr>bitmap ( array height width -- bitmap ) + 24 (nbits>bitmap) ; + +: bgra>bitmap ( array height width -- bitmap ) + 32 (nbits>bitmap) ; + : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; From e82f3a8518cef06407e9a3fd128eb8ef2f638eb6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:40:29 -0600 Subject: [PATCH 08/14] update ui.offscreen and ui.render --- extra/ui/offscreen/offscreen.factor | 2 +- extra/ui/render/test/test.factor | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 89c1c7f860..cf9370ed7f 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,5 +1,5 @@ ! (c) 2008 Joe Groff, see license for details -USING: accessors continuations graphics.bitmap kernel math +USING: accessors continuations images.bitmap kernel math sequences ui.gadgets ui.gadgets.worlds ui ui.backend destructors ; IN: ui.offscreen diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor index 2267c22a20..dcbc5b9600 100755 --- a/extra/ui/render/test/test.factor +++ b/extra/ui/render/test/test.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors colors arrays kernel sequences math byte-arrays -namespaces grouping fry cap graphics.bitmap +namespaces grouping fry cap images.bitmap ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons -ui.render ui opengl opengl.gl ; +ui.render ui opengl opengl.gl images ; IN: ui.render.test SINGLETON: line-test @@ -30,7 +30,7 @@ SYMBOL: render-output : bitmap= ( bitmap1 bitmap2 -- ? ) [ - [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi + [ [ buffer>> ] [ stride 4 align ] bi group ] [ stride ] bi '[ _ head twiddle ] map ] bi@ = ; @@ -38,7 +38,7 @@ SYMBOL: render-output screenshot [ render-output set-global ] [ - "resource:extra/ui/render/test/reference.bmp" load-bitmap + "resource:extra/ui/render/test/reference.bmp" bitmap= "is perfect" "needs work" ? "Your UI rendering " prepend message-window From 064e4c8d0969e325ed3ed58624e46ec13e25895d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 21:41:07 -0600 Subject: [PATCH 09/14] update offscreen docs --- extra/ui/offscreen/offscreen-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor index 5d800981bf..4123a83675 100644 --- a/extra/ui/offscreen/offscreen-docs.factor +++ b/extra/ui/offscreen/offscreen-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations ui.gadgets -graphics.bitmap strings ui.gadgets.worlds ; +images.bitmap strings ui.gadgets.worlds ; IN: ui.offscreen HELP: From 9f49b19306c89e5c692e21cc19e440d8c9baed99 Mon Sep 17 00:00:00 2001 From: Tim Wawrzynczak Date: Mon, 9 Feb 2009 21:50:04 -0600 Subject: [PATCH 10/14] Added extra/id3 vocab --- extra/id3/authors.txt | 0 extra/id3/id3-docs.factor | 10 ++ extra/id3/id3-tests.factor | 182 +++++++++++++++++++++++++++++++++++++ extra/id3/id3.factor | 154 +++++++++++++++++++++++++++++++ extra/id3/tests/blah.mp3 | Bin 0 -> 145 bytes extra/id3/tests/blah2.mp3 | Bin 0 -> 400 bytes extra/id3/tests/blah3.mp3 | Bin 0 -> 300 bytes 7 files changed, 346 insertions(+) create mode 100644 extra/id3/authors.txt create mode 100644 extra/id3/id3-docs.factor create mode 100644 extra/id3/id3-tests.factor create mode 100644 extra/id3/id3.factor create mode 100644 extra/id3/tests/blah.mp3 create mode 100644 extra/id3/tests/blah2.mp3 create mode 100644 extra/id3/tests/blah3.mp3 diff --git a/extra/id3/authors.txt b/extra/id3/authors.txt new file mode 100644 index 0000000000..e69de29bb2 diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor new file mode 100644 index 0000000000..1c77967ed1 --- /dev/null +++ b/extra/id3/id3-docs.factor @@ -0,0 +1,10 @@ +IN: id3 +USING: help.markup help.syntax sequences kernel ; + +HELP: id3-parse-mp3-file +{ $values { "path" "a path string" } { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no ID3 information." } + +ARTICLE: "id3" "ID3 tags" +{ $emphasis "id3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" + +ABOUT: "id3" diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor new file mode 100644 index 0000000000..d84f2c8726 --- /dev/null +++ b/extra/id3/id3-tests.factor @@ -0,0 +1,182 @@ +! Copyright (C) 2009 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test id3 ; +IN: id3.tests + +[ T{ mp3v2-file + { header T{ header f t 0 502 } } + { frames + { + T{ frame + { frame-id "COMM" } + { flags B{ 0 0 } } + { size 19 } + { data "eng, AG# 08E1C12E" } + } + T{ frame + { frame-id "TIT2" } + { flags B{ 0 0 } } + { size 15 } + { data "Stormy Weather" } + } + T{ frame + { frame-id "TRCK" } + { flags B{ 0 0 } } + { size 3 } + { data "32" } + } + T{ frame + { frame-id "TCON" } + { flags B{ 0 0 } } + { size 5 } + { data "(96)" } + } + T{ frame + { frame-id "TALB" } + { flags B{ 0 0 } } + { size 28 } + { data "Night and Day Frank Sinatra" } + } + T{ frame + { frame-id "PRIV" } + { flags B{ 0 0 } } + { size 39 } + { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" } + } + T{ frame + { frame-id "PRIV" } + { flags B{ 0 0 } } + { size 41 } + { data "WM/MediaClassSecondaryID" } + } + T{ frame + { frame-id "TPE1" } + { flags B{ 0 0 } } + { size 14 } + { data "Frank Sinatra" } + } + } + } +} +] [ "resource:extra/id3/tests/blah3.mp3" id3-parse-mp3-file ] unit-test + +[ + T{ mp3v2-file + { header + T{ header { version t } { flags 0 } { size 1405 } } + } + { frames + { + T{ frame + { frame-id "TIT2" } + { flags B{ 0 0 } } + { size 22 } + { data "Anthem of the Trinity" } + } + T{ frame + { frame-id "TPE1" } + { flags B{ 0 0 } } + { size 12 } + { data "Terry Riley" } + } + T{ frame + { frame-id "TALB" } + { flags B{ 0 0 } } + { size 11 } + { data "Shri Camel" } + } + T{ frame + { frame-id "TCON" } + { flags B{ 0 0 } } + { size 10 } + { data "Classical" } + } + T{ frame + { frame-id "UFID" } + { flags B{ 0 0 } } + { size 23 } + { data "http://musicbrainz.org" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 23 } + { data "MusicBrainz Artist Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 22 } + { data "musicbrainz_artistid" } + } + T{ frame + { frame-id "TRCK" } + { flags B{ 0 0 } } + { size 2 } + { data "1" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 22 } + { data "MusicBrainz Album Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 21 } + { data "musicbrainz_albumid" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 29 } + { data "MusicBrainz Album Artist Id" } + } + T{ frame + { frame-id "TXXX" } + { flags B{ 0 0 } } + { size 27 } + { data "musicbrainz_albumartistid" } + } + T{ frame + { frame-id "TPOS" } + { flags B{ 0 0 } } + { size 2 } + { data "1" } + } + T{ frame + { frame-id "TSOP" } + { flags B{ 0 0 } } + { size 1 } + } + T{ frame + { frame-id "TMED" } + { flags B{ 0 0 } } + { size 4 } + { data "DIG" } + } + } + } +} +] [ "resource:extra/id3/tests/blah2.mp3" id3-parse-mp3-file ] unit-test + +[ + T{ mp3v1-file + { title + "BLAH\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { artist + "ARTIST\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { album + "ALBUM\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { year "2009" } + { comment + "COMMENT\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" + } + { genre 89 } + } +] [ "resource:extra/id3/tests/blah.mp3" id3-parse-mp3-file ] unit-test + diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor new file mode 100644 index 0000000000..b2c2ec0621 --- /dev/null +++ b/extra/id3/id3.factor @@ -0,0 +1,154 @@ +! Copyright (C) 2009 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. +USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ; +IN: id3 + +! tuples + +TUPLE: header version flags size ; + +TUPLE: frame frame-id flags size data ; + +TUPLE: mp3v2-file header frames ; + +TUPLE: mp3v1-file title artist album year comment genre ; + +: ( -- object ) mp3v1-file new ; + +: ( header frames -- object ) mp3v2-file boa ; + +:
( -- object ) header new ; + +: ( -- object ) frame new ; + +28bitword ( seq -- int ) + 0 [ swap 7 shift bitor ] reduce ; + +: filter-text-data ( data -- filtered ) + [ printable? ] filter ; + +! frame details stuff + +: valid-frame-id? ( id -- ? ) + [ [ digit? ] [ LETTER? ] bi or ] all? ; + +: read-frame-id ( mmap -- id ) + 4 head-slice ; + +: read-frame-size ( mmap -- size ) + [ 4 8 ] dip subseq ; + +: read-frame-flags ( mmap -- flags ) + [ 8 10 ] dip subseq ; + +: read-frame-data ( frame mmap -- frame data ) + [ 10 over size>> 10 + ] dip filter-text-data ; + +! read whole frames + +: (read-frame) ( mmap -- frame ) + [ ] dip + { + [ read-frame-id ascii decode >>frame-id ] + [ read-frame-flags >byte-array >>flags ] + [ read-frame-size >28bitword >>size ] + [ read-frame-data ascii decode >>data ] + } cleave ; + +: read-frame ( mmap -- frame/f ) + dup read-frame-id valid-frame-id? [ (read-frame) ] [ drop f ] if ; + +: remove-frame ( mmap frame -- mmap ) + size>> 10 + tail-slice ; + +: read-frames ( mmap -- frames ) + [ dup read-frame dup ] + [ [ remove-frame ] keep ] + [ drop ] produce nip ; + +! header stuff + +: read-header-supported-version? ( mmap -- ? ) + 3 tail-slice [ { 4 } head? ] [ { 3 } head? ] bi or ; + +: read-header-flags ( mmap -- flags ) + 5 swap nth ; + +: read-header-size ( mmap -- size ) + [ 6 10 ] dip >28bitword ; + +: read-v2-header ( mmap -- id3header ) + [
] dip + { + [ read-header-supported-version? >>version ] + [ read-header-flags >>flags ] + [ read-header-size >>size ] + } cleave ; + +: drop-header ( mmap -- seq1 seq2 ) + dup 10 tail-slice swap ; + +: read-v2-tag-data ( seq -- mp3v2-file ) + drop-header read-v2-header swap read-frames ; + +! v1 information + +: skip-to-v1-data ( seq -- seq ) + 125 tail-slice* ; + +: read-title ( seq -- title ) + 30 head-slice ; + +: read-artist ( seq -- title ) + [ 30 60 ] dip subseq ; + +: read-album ( seq -- album ) + [ 60 90 ] dip subseq ; + +: read-year ( seq -- year ) + [ 90 94 ] dip subseq ; + +: read-comment ( seq -- comment ) + [ 94 124 ] dip subseq ; + +: read-genre ( seq -- genre ) + [ 124 ] dip nth ; + +: (read-v1-tag-data) ( seq -- mp3-file ) + [ ] dip + { + [ read-title ascii decode >>title ] + [ read-artist ascii decode >>artist ] + [ read-album ascii decode >>album ] + [ read-year ascii decode >>year ] + [ read-comment ascii decode >>comment ] + [ read-genre >fixnum >>genre ] + } cleave ; + +: read-v1-tag-data ( seq -- mp3-file ) + skip-to-v1-data (read-v1-tag-data) ; + +PRIVATE> + +! main stuff + +: id3-parse-mp3-file ( path -- object ) + [ + { + { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file ) + { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file ) + [ drop f ] ! ( mmap -- f ) + } cond + ] with-mapped-uchar-file ; + +! end diff --git a/extra/id3/tests/blah.mp3 b/extra/id3/tests/blah.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..3a60bffd340b9c8c0620dacefa74910529ad2b5e GIT binary patch literal 145 zcmZQzKm#F;?oK|A9%!OST*sgg&)^Uw0TiaAk5i~GiU=~t$iTqT+27aK)en~ekpNBc B2y*}c literal 0 HcmV?d00001 diff --git a/extra/id3/tests/blah2.mp3 b/extra/id3/tests/blah2.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..5d274299820c2dbab156db61c5e52bb83fc4fc80 GIT binary patch literal 400 zcmZutv2MaJ6m*+Tl(l6*NdAH%=*AWjKo-zM#7NnYQv$K%1mu_@Nc?-xq^J~li=Xc9 zolnR7&liGeoH*lsEboLkZeg-Cr@IZsOSzVXG!+j=J@8HNJk`3Q3#rnIyR#wCSD;a* zCG|v}D((ee))SzoL|Mvjp_XIj18WhI8M7aByZHflqJ=DuA3MDzJdWd9K<1Vjo+;{T zBTGZs`XWF;a&@~BXMqI2@TTCN@oVqb%xeFcspODfdA;3wS>9UJSvn8T?-I2ix%|Zn ag9w5;RuqKTpKOQok?jNJJ3gCWtLFzj*kz#r literal 0 HcmV?d00001 diff --git a/extra/id3/tests/blah3.mp3 b/extra/id3/tests/blah3.mp3 new file mode 100644 index 0000000000000000000000000000000000000000..19aaa94dc692ddbd4d329d6e073609bdda0cd6dd GIT binary patch literal 300 zcmeZtF=l1}0_HMje_vl9Ll}rt^U@h~6dc`^6$~s~4V?{*TthrVjDQmSKpb3>UzA&^ z5T2S?l95^z66EX+6a<-JY!u?`?+0YC0Ow^E~4K literal 0 HcmV?d00001 From 17724be48c5a8d3ba0a4a6126663d5cb0dc632e9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 22:05:44 -0600 Subject: [PATCH 11/14] factor out a load-tiff word --- extra/images/tiff/tiff.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor index a220475081..4be81af095 100755 --- a/extra/images/tiff/tiff.factor +++ b/extra/images/tiff/tiff.factor @@ -271,13 +271,15 @@ ERROR: bad-small-ifd-type n ; : parsed-tiff>images ( tiff -- sequence ) ifds>> [ ifd>image ] map ; -! tiff files can store several images -- we just take the first for now -M: tiff-image load-image* ( path tiff-image -- image ) - drop binary [ +: load-tiff ( path -- parsed-tiff ) + binary [ read-header dup endianness>> [ read-ifds dup ifds>> [ process-ifd read-strips strips>buffer drop ] each ] with-endianness - ] with-file-reader - parsed-tiff>images first ; + ] with-file-reader ; + +! tiff files can store several images -- we just take the first for now +M: tiff-image load-image* ( path tiff-image -- image ) + drop load-tiff parsed-tiff>images first ; From e5e98cc5cb348431743058125e6fe06e4e7245ea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 9 Feb 2009 22:05:58 -0600 Subject: [PATCH 12/14] undo load breakage --- extra/taxes/usa/usa.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index efdb969c01..bbfc332868 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs kernel math math.intervals namespaces sequences money math.order taxes.usa.w4 -taxes.usa.futa math.finance taxes.usa.fica -taxes.usa.federal ; +taxes.usa.futa math.finance ; IN: taxes.usa ! Withhold: FICA, Medicare, Federal (FICA is social security) From 204f5195f708b459cf176b1cc24366f93acb51fd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 9 Feb 2009 22:08:35 -0600 Subject: [PATCH 13/14] mark blas libs unportable till i sort out all the fortran abis --- basis/alien/fortran/tags.txt | 1 + basis/math/blas/ffi/tags.txt | 1 + basis/math/blas/matrices/tags.txt | 1 + basis/math/blas/vectors/tags.txt | 2 ++ 4 files changed, 5 insertions(+) diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt index 2a9b5def7a..58465edeb5 100644 --- a/basis/alien/fortran/tags.txt +++ b/basis/alien/fortran/tags.txt @@ -1,2 +1,3 @@ fortran ffi +unportable diff --git a/basis/math/blas/ffi/tags.txt b/basis/math/blas/ffi/tags.txt index f468a9989d..a4a4ea88ab 100644 --- a/basis/math/blas/ffi/tags.txt +++ b/basis/math/blas/ffi/tags.txt @@ -1,3 +1,4 @@ math bindings fortran +unportable diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 241ec1ecda..5118958180 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,2 +1,3 @@ math bindings +unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index ede10ab61b..5118958180 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1 +1,3 @@ math +bindings +unportable From 0ba4a08ea95d23c1970c15af06e2d897073b0e7f Mon Sep 17 00:00:00 2001 From: Tim Wawrzynczak Date: Mon, 9 Feb 2009 22:38:27 -0600 Subject: [PATCH 14/14] Fixed authors.txt and id3-docs --- extra/id3/authors.txt | 2 ++ extra/id3/id3-docs.factor | 13 ++++++++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/extra/id3/authors.txt b/extra/id3/authors.txt index e69de29bb2..ece617b969 100644 --- a/extra/id3/authors.txt +++ b/extra/id3/authors.txt @@ -0,0 +1,2 @@ +Tim Wawrzynczak + diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index 1c77967ed1..94128dc3b2 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -1,10 +1,17 @@ -IN: id3 +! Copyright (C) 2008 Tim Wawrzynczak +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax sequences kernel ; +IN: id3 HELP: id3-parse-mp3-file -{ $values { "path" "a path string" } { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no ID3 information." } +{ $values + { "path" "a path string" } + { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no (supported) ID3 information." } } +{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file" } ; ARTICLE: "id3" "ID3 tags" -{ $emphasis "id3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" +{ $emphasis "ID3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file" +"Parsing an MP3 file: " +{ $subsection id3-parse-mp3-file } ; ABOUT: "id3"