Merge branch 'master' into euler
commit
bc9bf6839b
|
@ -0,0 +1,31 @@
|
|||
USING: accessors arrays byte-arrays kernel math namespaces
|
||||
opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer
|
||||
models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry ;
|
||||
IN: cap
|
||||
|
||||
: screenshot-array ( world -- byte-array )
|
||||
dim>> product 3 * <byte-array> ;
|
||||
|
||||
: gl-screenshot ( gadget -- byte-array )
|
||||
[
|
||||
GL_BACK glReadBuffer
|
||||
GL_PACK_ALIGNMENT 1 glPixelStorei
|
||||
0 0
|
||||
] dip
|
||||
[ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
|
||||
[ screenshot-array ] bi
|
||||
[ glReadPixels ] keep ;
|
||||
|
||||
: screenshot ( window -- bitmap )
|
||||
[ gl-screenshot ]
|
||||
[ dim>> first2 ] bi
|
||||
bgr>bitmap ;
|
||||
|
||||
: save-screenshot ( window path -- )
|
||||
[ screenshot ] dip save-bitmap ;
|
||||
|
||||
: screenshot. ( window -- )
|
||||
[ screenshot <graphics-gadget> ] [ title>> ] bi open-window ;
|
||||
|
||||
|
||||
|
|
@ -15,6 +15,14 @@ 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 array ;
|
||||
|
||||
: bgr>bitmap ( array height width -- bitmap )
|
||||
bitmap new
|
||||
2over * 3 * >>size-image
|
||||
swap >>height
|
||||
swap >>width
|
||||
swap [ >>array ] [ >>color-index ] bi
|
||||
24 >>bit-count ;
|
||||
|
||||
: raw-bitmap>string ( str n -- str )
|
||||
{
|
||||
{ 32 [ "32bit" throw ] }
|
||||
|
@ -74,7 +82,7 @@ M: bitmap-magic summary
|
|||
|
||||
: save-bitmap ( bitmap path -- )
|
||||
binary [
|
||||
"BM" write
|
||||
"BM" >byte-array write
|
||||
dup array>> length 14 + 40 + 4 >le write
|
||||
0 4 >le write
|
||||
54 4 >le write
|
||||
|
@ -87,10 +95,10 @@ M: bitmap-magic summary
|
|||
[ bit-count>> 24 or 2 >le write ]
|
||||
[ compression>> 0 or 4 >le write ]
|
||||
[ size-image>> 4 >le write ]
|
||||
[ x-pels>> 4 >le write ]
|
||||
[ y-pels>> 4 >le write ]
|
||||
[ color-used>> 4 >le write ]
|
||||
[ color-important>> 4 >le write ]
|
||||
[ x-pels>> 0 or 4 >le write ]
|
||||
[ y-pels>> 0 or 4 >le write ]
|
||||
[ color-used>> 0 or 4 >le write ]
|
||||
[ color-important>> 0 or 4 >le write ]
|
||||
[ rgb-quads>> write ]
|
||||
[ color-index>> write ]
|
||||
} cleave
|
||||
|
|
Loading…
Reference in New Issue