Fix conflict
Slava Pestov
commit
6235e95052
|
|
@ -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: }
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
fortran
|
||||
ffi
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
math
|
||||
bindings
|
||||
fortran
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -1,2 +1,3 @@
|
|||
math
|
||||
bindings
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -1 +1,3 @@
|
|||
math
|
||||
bindings
|
||||
unportable
|
||||
|
|
|
|||
|
|
@ -28,6 +28,8 @@ $nl
|
|||
{ $snippet "ulonglong" }
|
||||
{ $snippet "float" }
|
||||
{ $snippet "double" }
|
||||
{ $snippet "complex-float" }
|
||||
{ $snippet "complex-double" }
|
||||
{ $snippet "void*" }
|
||||
{ $snippet "bool" }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
|
|
|
|||
|
|
@ -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 <graphics-gadget> ] [ title>> ] bi open-window ;
|
||||
[ screenshot <image-gadget> ] [ title>> ] bi open-window ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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" ;
|
||||
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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 ;
|
||||
|
||||
: <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 ;
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Tim Wawrzynczak
|
||||
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
! 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"
|
||||
|
|
@ -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<49>}`<60>#<23><>K<EFBFBD>H<EFBFBD>*(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
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
||||
: <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
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
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
|
||||
|
|
@ -4,8 +4,10 @@ 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
|
||||
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)
|
||||
|
|
@ -14,40 +16,24 @@ 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 ;
|
||||
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 [ >>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 )
|
||||
: 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>array ( bitmap -- array )
|
||||
: raw-bitmap>buffer ( bitmap -- array )
|
||||
dup bit-count>>
|
||||
{
|
||||
{ 32 [ color-index>> ] }
|
||||
{ 24 [ color-index>> ] }
|
||||
{ 16 [ bmp-not-supported ] }
|
||||
{ 8 [ 8bit>array ] }
|
||||
{ 8 [ 8bit>buffer ] }
|
||||
{ 4 [ bmp-not-supported ] }
|
||||
{ 2 [ bmp-not-supported ] }
|
||||
{ 1 [ bmp-not-supported ] }
|
||||
|
|
@ -95,19 +81,45 @@ 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
|
||||
] with-file-reader ;
|
||||
|
||||
: alpha-channel-zero? ( bitmap -- ? )
|
||||
array>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
|
||||
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)
|
||||
dup raw-bitmap>array >>array
|
||||
dup alpha-channel-zero? >>alpha-channel-zero? ;
|
||||
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 ;
|
||||
|
|
@ -116,7 +128,7 @@ M: bitmap-magic summary
|
|||
binary [
|
||||
B{ CHAR: B CHAR: M } write
|
||||
[
|
||||
array>> length 14 + 40 + write4
|
||||
buffer>> length 14 + 40 + write4
|
||||
0 write4
|
||||
54 write4
|
||||
40 write4
|
||||
|
|
@ -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
|
||||
|
||||
: <image> ( path -- image )
|
||||
normalize-path dup "." split1-last nip >lower
|
||||
{
|
||||
{ "bmp" [ bitmap-image load-image ] }
|
||||
{ "tiff" [ tiff-image load-image ] }
|
||||
} case ;
|
||||
|
Before Width: | Height: | Size: 1.6 KiB After Width: | Height: | Size: 1.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 11 KiB After Width: | Height: | Size: 11 KiB |
|
Before Width: | Height: | Size: 59 KiB After Width: | Height: | Size: 59 KiB |
|
|
@ -0,0 +1,10 @@
|
|||
! 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" ;
|
||||
|
|
@ -3,13 +3,14 @@
|
|||
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
|
||||
io.binary assocs math math.bitwise byte-arrays grouping
|
||||
images.backend ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff endianness the-answer ifd-offset ifds ;
|
||||
TUPLE: tiff-image < image ;
|
||||
|
||||
CONSTRUCTOR: tiff ( -- tiff )
|
||||
V{ } clone >>ifds ;
|
||||
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 ;
|
||||
|
|
@ -83,13 +84,13 @@ ERROR: bad-planar-configuration n ;
|
|||
[ 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 )
|
||||
ERROR: bad-sample-format n ;
|
||||
: lookup-sample-format ( sequence -- object )
|
||||
[
|
||||
{
|
||||
{ 1 [ sample-format-unsigned-integer ] }
|
||||
|
|
@ -100,12 +101,12 @@ sample-format-undefined-data ;
|
|||
} 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 )
|
||||
ERROR: bad-extra-samples n ;
|
||||
: lookup-extra-samples ( sequence -- object )
|
||||
{
|
||||
{ 0 [ extra-samples-unspecified-alpha-data ] }
|
||||
{ 1 [ extra-samples-associated-alpha-data ] }
|
||||
|
|
@ -259,13 +260,26 @@ ERROR: bad-small-ifd-type n ;
|
|||
: strips>buffer ( ifd -- ifd )
|
||||
dup strips>> concat >>buffer ;
|
||||
|
||||
: (load-tiff) ( path -- tiff )
|
||||
: 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 [
|
||||
<tiff>
|
||||
<parsed-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) ;
|
||||
! 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 ;
|
||||
|
|
@ -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 )
|
||||
\ 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. ;
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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: <offscreen-world>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! 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
|
||||
|
|
@ -40,7 +40,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" <image>
|
||||
bitmap= "is perfect" "needs work" ?
|
||||
"Your UI rendering " prepend
|
||||
message-window
|
||||
|
|
|
|||
Loading…
Reference in New Issue