;
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: }
math
bindings
fortran
+unportable
math
bindings
+unportable
math
+bindings
+unportable
{ $snippet "ulonglong" }
{ $snippet "float" }
{ $snippet "double" }
+ { $snippet "complex-float" }
+ { $snippet "complex-double" }
{ $snippet "void*" }
{ $snippet "bool" }
}
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 [
! 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
[ screenshot ] dip save-bitmap ;
: screenshot. ( window -- )
- [ screenshot <graphics-gadget> ] [ title>> ] bi open-window ;
+ [ screenshot <image-gadget> ] [ title>> ] bi open-window ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
+++ /dev/null
-! 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 <sliced-groups> [ 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 <sliced-groups> 3 <column> [ 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 ;
+++ /dev/null
-bitmap graphics
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! 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" ;
-
+++ /dev/null
-! 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> <ifd-entry> ;
-
-: read-ifds ( tiff -- tiff )
- dup ifd-offset>> seek-absolute seek-input
- 2 read endian>
- dup [ read-ifd ] replicate
- 4 read endian>
- [ <ifd> 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 <sliced-groups> [ endian> ] map ] }
- { 4 [ 4 <sliced-groups> [ endian> ] map ] }
- { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
- { 6 [ [ 8 >signed ] map ] }
- { 7 [ ] } ! blank
- { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
- { 9 [ 4 <sliced-groups> [ 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 [
- <tiff>
- 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) ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! 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 ;
-
-: <graphics-gadget> ( 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 <graphics-gadget> gadget. ;
-
-: bitmap-window ( path -- gadget )
- load-bitmap <graphics-gadget> [ "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 ;
--- /dev/null
+Tim Wawrzynczak
+
--- /dev/null
+! 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 (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"
+"Parsing an MP3 file: "
+{ $subsection id3-parse-mp3-file } ;
+
+ABOUT: "id3"
--- /dev/null
+! 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
+
--- /dev/null
+! 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 ;
+
+: <mp3v1-file> ( -- object ) mp3v1-file new ;
+
+: <mp3v2-file> ( header frames -- object ) mp3v2-file boa ;
+
+: <header> ( -- object ) header new ;
+
+: <frame> ( -- object ) frame new ;
+
+<PRIVATE
+
+! utility words
+
+: id3v2? ( mmap -- ? )
+ "ID3" head? ;
+
+: id3v1? ( mmap -- ? )
+ 128 tail-slice* "TAG" head? ;
+
+: >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 <slice> filter-text-data ;
+
+! read whole frames
+
+: (read-frame) ( mmap -- frame )
+ [ <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 <slice> >28bitword ;
+
+: read-v2-header ( mmap -- id3header )
+ [ <header> ] 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 <mp3v2-file> ;
+
+! 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 )
+ [ <mp3v1-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
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: images.bitmap images.viewer io.encodings.binary
+io.files io.files.unique kernel tools.test ;
+IN: images.bitmap.tests
+
+: test-bitmap24 ( -- path )
+ "resource:extra/images/test-images/thiswayup24.bmp" ;
+
+: test-bitmap16 ( -- path )
+ "resource:extra/images/test-images/rgb16bit.bmp" ;
+
+: test-bitmap8 ( -- path )
+ "resource:extra/images/test-images/rgb8bit.bmp" ;
+
+: test-bitmap4 ( -- path )
+ "resource:extra/images/test-images/rgb4bit.bmp" ;
+
+: test-bitmap1 ( -- path )
+ "resource:extra/images/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
--- /dev/null
+! 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 ;
+
+: 8bit>buffer ( bitmap -- array )
+ [ rgb-quads>> 4 <sliced-groups> [ 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-data ( path -- bitmap )
+ binary [
+ bitmap new
+ parse-file-header parse-bitmap-header parse-bitmap
+ ] with-file-reader ;
+
+: alpha-channel-zero? ( bitmap -- ? )
+ buffer>> 4 <sliced-groups> 3 <column> [ 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
+ 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 ;
+
+: 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 ;
--- /dev/null
+! 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
+
+: <image> ( path -- image )
+ normalize-path dup "." split1-last nip >lower
+ {
+ { "bmp" [ bitmap-image load-image ] }
+ { "tiff" [ tiff-image load-image ] }
+ } case ;
--- /dev/null
+bitmap graphics
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test images.tiff ;
+IN: images.tiff.tests
+
+: tiff-test-path ( -- path )
+ "resource:extra/images/test-images/rgb.tiff" ;
+
+: tiff-test-path2 ( -- path )
+ "resource:extra/images/test-images/octagon.tiff" ;
--- /dev/null
+! 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
+images.backend ;
+IN: images.tiff
+
+TUPLE: tiff-image < image ;
+
+TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
+CONSTRUCTOR: parsed-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 ;
+
+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> <ifd-entry> ;
+
+: read-ifds ( tiff -- tiff )
+ dup ifd-offset>> seek-absolute seek-input
+ 2 read endian>
+ dup [ read-ifd ] replicate
+ 4 read endian>
+ [ <ifd> 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 <sliced-groups> [ endian> ] map ] }
+ { 4 [ 4 <sliced-groups> [ endian> ] map ] }
+ { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
+ { 6 [ [ 8 >signed ] map ] }
+ { 7 [ ] } ! blank
+ { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
+ { 9 [ 4 <sliced-groups> [ 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 ;
+
+: load-tiff ( path -- parsed-tiff )
+ binary [
+ <parsed-tiff>
+ read-header dup endianness>> [
+ read-ifds
+ dup ifds>> [ process-ifd read-strips strips>buffer drop ] each
+ ] with-endianness
+ ] 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 )
+ \ 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 )
+ [ <image> <image-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 -- ) <image> <image-gadget> gadget. ;
+
+M: pathname image. ( image -- ) <image> <image-gadget> gadget. ;
+
+M: image image. ( image -- ) <image-gadget> gadget. ;
! 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)
! 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: <offscreen-world>
! (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
! Copyright (C) 2008, 2009 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 colors.constants ;
+ui.render ui opengl opengl.gl colors.constants images ;
IN: ui.render.test
SINGLETON: line-test
screenshot
[ render-output set-global ]
[
- "resource:extra/ui/render/test/reference.bmp" load-bitmap
+ "resource:extra/ui/render/test/reference.bmp" <image>
bitmap= "is perfect" "needs work" ?
"Your UI rendering " prepend
message-window
projects / factor.git / commitdiff
