Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
dd9ceba26a
basis
alien
io/launcher/windows/nt
pack
tools/deploy
core/slots
extra
cap
graphics
taxes/usa
ui
render/test
|
|
@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ;
|
|||
|
||||
M: array stack-size drop "void*" stack-size ;
|
||||
|
||||
M: array c-type-boxer-quot drop f ;
|
||||
M: array c-type-boxer-quot drop [ ] ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry call ;
|
||||
accessors combinators effects continuations fry call classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -13,18 +13,20 @@ DEFER: *char
|
|||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
class
|
||||
boxer boxer-quot unboxer unboxer-quot
|
||||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
: new-c-type ( class -- type )
|
||||
new
|
||||
int-regs >>reg-class
|
||||
object >>class ; inline
|
||||
{ class class initial: object }
|
||||
boxer
|
||||
{ boxer-quot callable }
|
||||
unboxer
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
{ reg-class initial: int-regs }
|
||||
size
|
||||
align
|
||||
stack-align? ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type new-c-type ;
|
||||
\ c-type new ;
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
|
|
@ -224,7 +226,7 @@ M: f byte-length drop 0 ;
|
|||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- type )
|
||||
long-long-type new-c-type ;
|
||||
long-long-type new ;
|
||||
|
||||
M: long-long-type unbox-parameter ( n type -- )
|
||||
c-type-unboxer %unbox-long-long ;
|
||||
|
|
|
|||
|
|
@ -42,3 +42,18 @@ C-UNION: barx
|
|||
[ ] [ \ foox-x "help" get execute ] unit-test
|
||||
[ ] [ \ set-foox-x "help" get execute ] unit-test
|
||||
] when
|
||||
|
||||
C-STRUCT: nested
|
||||
{ "int" "x" } ;
|
||||
|
||||
C-STRUCT: nested-2
|
||||
{ "nested" "y" } ;
|
||||
|
||||
[ 4 ] [
|
||||
"nested-2" <c-object>
|
||||
"nested" <c-object>
|
||||
4 over set-nested-x
|
||||
over set-nested-2-y
|
||||
nested-2-y
|
||||
nested-x
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -2,10 +2,18 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc fry
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order ;
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order
|
||||
quotations ;
|
||||
IN: alien.structs
|
||||
|
||||
TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ;
|
||||
TUPLE: struct-type
|
||||
size
|
||||
align
|
||||
fields
|
||||
{ boxer-quot callable }
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable } ;
|
||||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests
|
|||
"out.txt" temp-file ascii file-lines first
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ "( scratchpad ) " ] [
|
||||
<process>
|
||||
console-vm "-run=listener" 2array >>command
|
||||
+closed+ >>stdin
|
||||
try-process
|
||||
+stdout+ >>stderr
|
||||
ascii [ input-stream get contents ] with-process-reader
|
||||
] unit-test
|
||||
|
||||
: launcher-test-path ( -- str )
|
||||
|
|
@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests
|
|||
|
||||
"append-test" temp-file ascii file-contents
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -87,12 +87,12 @@ CONSTANT: packed-length-table
|
|||
{ CHAR: D 8 }
|
||||
}
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: pack ( str -- quot )
|
||||
[ pack-table at '[ _ execute ] ] { } map-as
|
||||
'[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ch>packed-length ( ch -- n )
|
||||
packed-length-table at ; inline
|
||||
|
||||
|
|
@ -113,14 +113,14 @@ PRIVATE>
|
|||
: start/end ( seq -- seq1 seq2 )
|
||||
[ 0 [ + ] accumulate nip dup ] keep v+ ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: unpack ( str -- quot )
|
||||
[ [ ch>packed-length ] { } map-as start/end ]
|
||||
[ [ unpack-table at '[ @ ] ] { } map-as ] bi
|
||||
[ '[ [ _ _ ] dip <slice> @ ] ] 3map
|
||||
'[ [ _ cleave ] output>array ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: unpack-native ( seq str -- seq )
|
||||
'[ _ _ unpack ] with-native-endian ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -11,8 +11,8 @@ tools.deploy.config.editor bootstrap.image io.encodings.utf8
|
|||
destructors accessors ;
|
||||
IN: tools.deploy.backend
|
||||
|
||||
: copy-vm ( executable bundle-name extension -- vm )
|
||||
[ prepend-path ] dip append vm over copy-file ;
|
||||
: copy-vm ( executable bundle-name -- vm )
|
||||
prepend-path vm over copy-file ;
|
||||
|
||||
: copy-fonts ( name dir -- )
|
||||
deploy-ui? get [
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ IN: tools.deploy.macosx
|
|||
} cleave
|
||||
]
|
||||
[ create-app-plist ]
|
||||
[ "Contents/MacOS/" append-path "" copy-vm ] 2tri
|
||||
[ "Contents/MacOS/" append-path copy-vm ] 2tri
|
||||
dup OCT: 755 set-file-permissions ;
|
||||
|
||||
: deploy.app-image ( vocab bundle-name -- str )
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: tools.deploy.unix
|
|||
|
||||
: create-app-dir ( vocab bundle-name -- vm )
|
||||
dup "" copy-fonts
|
||||
"" copy-vm
|
||||
copy-vm
|
||||
dup OCT: 755 set-file-permissions ;
|
||||
|
||||
: bundle-name ( -- str )
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.files io.directories kernel namespaces sequences system
|
||||
tools.deploy.backend tools.deploy.config
|
||||
tools.deploy.config.editor assocs hashtables prettyprint
|
||||
combinators windows.shell32 windows.user32 ;
|
||||
USING: io io.files io.pathnames io.directories kernel namespaces
|
||||
sequences locals system splitting tools.deploy.backend
|
||||
tools.deploy.config tools.deploy.config.editor assocs hashtables
|
||||
prettyprint combinators windows.shell32 windows.user32 ;
|
||||
IN: tools.deploy.windows
|
||||
|
||||
: copy-dll ( bundle-name -- )
|
||||
|
|
@ -15,13 +15,18 @@ IN: tools.deploy.windows
|
|||
"resource:zlib1.dll"
|
||||
} swap copy-files-into ;
|
||||
|
||||
:: copy-vm ( executable bundle-name extension -- vm )
|
||||
vm "." split1-last drop extension append
|
||||
bundle-name executable ".exe" append append-path
|
||||
[ copy-file ] keep ;
|
||||
|
||||
: create-exe-dir ( vocab bundle-name -- vm )
|
||||
dup copy-dll
|
||||
deploy-ui? get [
|
||||
dup copy-freetype
|
||||
dup "" copy-fonts
|
||||
] when
|
||||
".exe" copy-vm ;
|
||||
[ copy-freetype ]
|
||||
[ "" copy-fonts ]
|
||||
[ ".exe" copy-vm ] tri
|
||||
] [ ".com" copy-vm ] if ;
|
||||
|
||||
M: winnt deploy*
|
||||
"resource:" [
|
||||
|
|
|
|||
|
|
@ -151,6 +151,7 @@ M: class initial-value* no-initial-value ;
|
|||
{ [ array bootstrap-word over class<= ] [ { } ] }
|
||||
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
|
||||
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
|
||||
{ [ quotation bootstrap-word over class<= ] [ [ ] ] }
|
||||
[ dup initial-value* ]
|
||||
} cond nip ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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,9 +0,0 @@
|
|||
! Copyright (C) 2009 Your name.
|
||||
! 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" ;
|
||||
|
||||
|
||||
|
|
@ -1,227 +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 ;
|
||||
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 ;
|
||||
|
||||
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
|
||||
|
||||
TUPLE: ifd-entry tag type count offset ;
|
||||
|
||||
CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ;
|
||||
|
||||
|
||||
TUPLE: photometric-interpretation color ;
|
||||
|
||||
CONSTRUCTOR: photometric-interpretation ( color -- object ) ;
|
||||
|
||||
SINGLETONS: white-is-zero black-is-zero rgb palette-color ;
|
||||
|
||||
ERROR: bad-photometric-interpretation n ;
|
||||
|
||||
: lookup-photometric-interpretation ( n -- singleton )
|
||||
{
|
||||
{ 0 [ white-is-zero ] }
|
||||
{ 1 [ black-is-zero ] }
|
||||
{ 2 [ rgb ] }
|
||||
{ 3 [ palette-color ] }
|
||||
[ bad-photometric-interpretation ]
|
||||
} case <photometric-interpretation> ;
|
||||
|
||||
|
||||
TUPLE: compression method ;
|
||||
|
||||
CONSTRUCTOR: compression ( method -- object ) ;
|
||||
|
||||
SINGLETONS: no-compression CCITT-2 pack-bits lzw ;
|
||||
|
||||
ERROR: bad-compression n ;
|
||||
|
||||
: lookup-compression ( n -- compression )
|
||||
{
|
||||
{ 1 [ no-compression ] }
|
||||
{ 2 [ CCITT-2 ] }
|
||||
{ 5 [ lzw ] }
|
||||
{ 32773 [ pack-bits ] }
|
||||
[ bad-compression ]
|
||||
} case <compression> ;
|
||||
|
||||
TUPLE: image-length n ;
|
||||
CONSTRUCTOR: image-length ( n -- object ) ;
|
||||
|
||||
TUPLE: image-width n ;
|
||||
CONSTRUCTOR: image-width ( n -- object ) ;
|
||||
|
||||
TUPLE: x-resolution n ;
|
||||
CONSTRUCTOR: x-resolution ( n -- object ) ;
|
||||
|
||||
TUPLE: y-resolution n ;
|
||||
CONSTRUCTOR: y-resolution ( n -- object ) ;
|
||||
|
||||
TUPLE: rows-per-strip n ;
|
||||
CONSTRUCTOR: rows-per-strip ( n -- object ) ;
|
||||
|
||||
TUPLE: strip-offsets n ;
|
||||
CONSTRUCTOR: strip-offsets ( n -- object ) ;
|
||||
|
||||
TUPLE: strip-byte-counts n ;
|
||||
CONSTRUCTOR: strip-byte-counts ( n -- object ) ;
|
||||
|
||||
TUPLE: bits-per-sample n ;
|
||||
CONSTRUCTOR: bits-per-sample ( n -- object ) ;
|
||||
|
||||
TUPLE: samples-per-pixel n ;
|
||||
CONSTRUCTOR: samples-per-pixel ( n -- object ) ;
|
||||
|
||||
SINGLETONS: no-resolution-unit
|
||||
inch-resolution-unit
|
||||
centimeter-resolution-unit ;
|
||||
|
||||
TUPLE: resolution-unit type ;
|
||||
CONSTRUCTOR: resolution-unit ( type -- object ) ;
|
||||
|
||||
ERROR: bad-resolution-unit n ;
|
||||
|
||||
: lookup-resolution-unit ( n -- object )
|
||||
{
|
||||
{ 1 [ no-resolution-unit ] }
|
||||
{ 2 [ inch-resolution-unit ] }
|
||||
{ 3 [ centimeter-resolution-unit ] }
|
||||
[ bad-resolution-unit ]
|
||||
} case <resolution-unit> ;
|
||||
|
||||
|
||||
TUPLE: predictor type ;
|
||||
CONSTRUCTOR: predictor ( type -- object ) ;
|
||||
|
||||
SINGLETONS: no-predictor horizontal-differencing-predictor ;
|
||||
|
||||
ERROR: bad-predictor n ;
|
||||
|
||||
: lookup-predictor ( n -- object )
|
||||
{
|
||||
{ 1 [ no-predictor ] }
|
||||
{ 2 [ horizontal-differencing-predictor ] }
|
||||
[ bad-predictor ]
|
||||
} case <predictor> ;
|
||||
|
||||
|
||||
TUPLE: planar-configuration type ;
|
||||
CONSTRUCTOR: planar-configuration ( type -- object ) ;
|
||||
|
||||
SINGLETONS: chunky planar ;
|
||||
|
||||
ERROR: bad-planar-configuration n ;
|
||||
|
||||
: lookup-planar-configuration ( n -- object )
|
||||
{
|
||||
{ 1 [ no-predictor ] }
|
||||
{ 2 [ horizontal-differencing-predictor ] }
|
||||
[ bad-predictor ]
|
||||
} case <planar-configuration> ;
|
||||
|
||||
|
||||
TUPLE: new-subfile-type n ;
|
||||
CONSTRUCTOR: new-subfile-type ( n -- object ) ;
|
||||
|
||||
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 ;
|
||||
|
||||
: with-tiff-endianness ( tiff quot -- tiff )
|
||||
[ dup endianness>> ] dip with-endianness ; inline
|
||||
|
||||
: 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
|
||||
] with-tiff-endianness ;
|
||||
|
||||
: read-strips ( ifd -- ifd )
|
||||
dup processed-tags>>
|
||||
[ [ strip-byte-counts instance? ] find nip n>> ]
|
||||
[ [ strip-offsets instance? ] find nip n>> ] bi
|
||||
[ seek-absolute seek-input read ] { } 2map-as >>strips ;
|
||||
|
||||
! ERROR: unhandled-ifd-entry data n ;
|
||||
|
||||
: unhandled-ifd-entry ;
|
||||
|
||||
: ifd-entry-value ( ifd-entry -- n )
|
||||
dup count>> 1 = [
|
||||
offset>>
|
||||
] [
|
||||
[ offset>> seek-absolute seek-input ] [ count>> read ] bi
|
||||
] if ;
|
||||
|
||||
: process-ifd-entry ( ifd-entry -- object )
|
||||
[ ifd-entry-value ] [ tag>> ] bi {
|
||||
{ 254 [ <new-subfile-type> ] }
|
||||
{ 256 [ <image-width> ] }
|
||||
{ 257 [ <image-length> ] }
|
||||
{ 258 [ <bits-per-sample> ] }
|
||||
{ 259 [ lookup-compression ] }
|
||||
{ 262 [ lookup-photometric-interpretation ] }
|
||||
{ 273 [ <strip-offsets> ] }
|
||||
{ 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 ] }
|
||||
{ 317 [ lookup-predictor ] }
|
||||
[ unhandled-ifd-entry swap 2array ]
|
||||
} case ;
|
||||
|
||||
: process-ifd ( ifd -- ifd )
|
||||
dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ;
|
||||
|
||||
: (load-tiff) ( path -- tiff )
|
||||
binary [
|
||||
<tiff>
|
||||
read-header
|
||||
read-ifds
|
||||
dup ifds>> [ process-ifd read-strips drop ] each
|
||||
] with-file-reader ;
|
||||
|
||||
: load-tiff ( path -- tiff )
|
||||
(load-tiff) ;
|
||||
|
||||
! TODO: duplicate ifds = error, seeking out of bounds = error
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,50 +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 ;
|
||||
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 ;
|
||||
|
||||
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>> {
|
||||
{ 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
|
||||
] 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 ;
|
||||
|
|
@ -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"
|
||||
|
|
@ -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" ;
|
||||
|
|
@ -0,0 +1,285 @@
|
|||
! 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 ;
|
||||
|
|
@ -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. ;
|
||||
|
|
@ -11,5 +11,4 @@ IN: taxes.usa.futa
|
|||
|
||||
: futa-tax ( salary w4 -- x )
|
||||
drop futa-base-rate min
|
||||
futa-tax-rate futa-tax-offset-credit -
|
||||
* ;
|
||||
futa-tax-rate futa-tax-offset-credit - * ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! 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 ;
|
||||
namespaces sequences money math.order taxes.usa.w4
|
||||
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 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" <image>
|
||||
bitmap= "is perfect" "needs work" ?
|
||||
"Your UI rendering " prepend
|
||||
message-window
|
||||
|
|
|
|||
Loading…
Reference in New Issue