Move normalize-scanline-order implementation from images.bitmap to images
Add upside-down? slot to image tuple Update cap for recent changesdb4
							parent
							
								
									073333f245
								
							
						
					
					
						commit
						ff3c5b28bd
					
				| 
						 | 
					@ -108,11 +108,6 @@ M: bitmap-image load-image* ( path bitmap -- bitmap )
 | 
				
			||||||
    load-bitmap-data process-bitmap-data
 | 
					    load-bitmap-data process-bitmap-data
 | 
				
			||||||
    fill-image-slots ;
 | 
					    fill-image-slots ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: bitmap-image normalize-scan-line-order
 | 
					 | 
				
			||||||
    dup dim>> '[
 | 
					 | 
				
			||||||
        _ first 4 * <sliced-groups> reverse concat
 | 
					 | 
				
			||||||
    ] change-bitmap ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
MACRO: (nbits>bitmap) ( bits -- )
 | 
					MACRO: (nbits>bitmap) ( bits -- )
 | 
				
			||||||
    [ -3 shift ] keep '[
 | 
					    [ -3 shift ] keep '[
 | 
				
			||||||
        bitmap-image new
 | 
					        bitmap-image new
 | 
				
			||||||
| 
						 | 
					@ -121,6 +116,7 @@ MACRO: (nbits>bitmap) ( bits -- )
 | 
				
			||||||
            swap >>width
 | 
					            swap >>width
 | 
				
			||||||
            swap array-copy [ >>bitmap ] [ >>color-index ] bi
 | 
					            swap array-copy [ >>bitmap ] [ >>color-index ] bi
 | 
				
			||||||
            _ >>bit-count fill-image-slots
 | 
					            _ >>bit-count fill-image-slots
 | 
				
			||||||
 | 
					            t >>upside-down?
 | 
				
			||||||
    ] ;
 | 
					    ] ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: bgr>bitmap ( array height width -- bitmap )
 | 
					: bgr>bitmap ( array height width -- bitmap )
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -27,7 +27,7 @@ R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
 | 
				
			||||||
        { R32G32B32A32 [ 16 ] }
 | 
					        { R32G32B32A32 [ 16 ] }
 | 
				
			||||||
    } case ;
 | 
					    } case ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TUPLE: image dim component-order bitmap ;
 | 
					TUPLE: image dim component-order upside-down? bitmap ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: <image> ( -- image ) image new ; inline
 | 
					: <image> ( -- image ) image new ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					@ -82,11 +82,16 @@ M: ARGB normalize-component-order*
 | 
				
			||||||
M: ABGR normalize-component-order*
 | 
					M: ABGR normalize-component-order*
 | 
				
			||||||
    drop ARGB>RGBA 4 BGR>RGB ;
 | 
					    drop ARGB>RGBA 4 BGR>RGB ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
GENERIC: normalize-scan-line-order ( image -- image )
 | 
					: normalize-scan-line-order ( image -- image )
 | 
				
			||||||
 | 
					    dup upside-down?>> [
 | 
				
			||||||
M: image normalize-scan-line-order ;
 | 
					        dup dim>> first 4 * '[
 | 
				
			||||||
 | 
					            _ <groups> reverse concat
 | 
				
			||||||
 | 
					        ] change-bitmap
 | 
				
			||||||
 | 
					        f >>upside-down?
 | 
				
			||||||
 | 
					    ] when ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: normalize-image ( image -- image )
 | 
					: normalize-image ( image -- image )
 | 
				
			||||||
    [ >byte-array ] change-bitmap
 | 
					    [ >byte-array ] change-bitmap
 | 
				
			||||||
    normalize-component-order
 | 
					    normalize-component-order
 | 
				
			||||||
    normalize-scan-line-order ;
 | 
					    normalize-scan-line-order
 | 
				
			||||||
 | 
					    RGBA >>component-order ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -503,7 +503,7 @@ ERROR: unknown-component-order ifd ;
 | 
				
			||||||
: ifd>image ( ifd -- image )
 | 
					: ifd>image ( ifd -- image )
 | 
				
			||||||
    {
 | 
					    {
 | 
				
			||||||
        [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
 | 
					        [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
 | 
				
			||||||
        [ ifd-component-order ]
 | 
					        [ ifd-component-order f ]
 | 
				
			||||||
        [ bitmap>> ]
 | 
					        [ bitmap>> ]
 | 
				
			||||||
    } cleave tiff-image boa ;
 | 
					    } cleave tiff-image boa ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -1,30 +1,31 @@
 | 
				
			||||||
! Copyright (C) 2008 Doug Coleman, Joe Groff.
 | 
					! Copyright (C) 2008 Doug Coleman, Joe Groff.
 | 
				
			||||||
! See http://factorcode.org/license.txt for BSD license.
 | 
					! See http://factorcode.org/license.txt for BSD license.
 | 
				
			||||||
USING: accessors arrays byte-arrays kernel math namespaces
 | 
					USING: accessors arrays byte-arrays kernel math namespaces
 | 
				
			||||||
opengl.gl sequences math.vectors ui images.bitmap images.viewer
 | 
					opengl.gl sequences math.vectors ui images images.viewer
 | 
				
			||||||
models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 | 
					models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 | 
				
			||||||
IN: cap
 | 
					IN: cap
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: screenshot-array ( world -- byte-array )
 | 
					: screenshot-array ( world -- byte-array )
 | 
				
			||||||
    dim>> [ first 3 * 4 align ] [ second ] bi * <byte-array> ;
 | 
					    dim>> [ first 4 * ] [ second ] bi * <byte-array> ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: gl-screenshot ( gadget -- byte-array )
 | 
					: gl-screenshot ( gadget -- byte-array )
 | 
				
			||||||
 | 
					    [
 | 
				
			||||||
        [
 | 
					        [
 | 
				
			||||||
            GL_BACK glReadBuffer
 | 
					            GL_BACK glReadBuffer
 | 
				
			||||||
            GL_PACK_ALIGNMENT 4 glPixelStorei
 | 
					            GL_PACK_ALIGNMENT 4 glPixelStorei
 | 
				
			||||||
            0 0
 | 
					            0 0
 | 
				
			||||||
        ] dip
 | 
					        ] dip
 | 
				
			||||||
    [ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
 | 
					        dim>> first2 GL_RGBA GL_UNSIGNED_BYTE
 | 
				
			||||||
 | 
					    ]
 | 
				
			||||||
    [ screenshot-array ] bi
 | 
					    [ screenshot-array ] bi
 | 
				
			||||||
    [ glReadPixels ] keep ;
 | 
					    [ glReadPixels ] keep ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: screenshot ( window -- bitmap )
 | 
					: screenshot ( window -- bitmap )
 | 
				
			||||||
    [ gl-screenshot ]
 | 
					    [ <image> ] dip
 | 
				
			||||||
    [ dim>> first2 ] bi
 | 
					    [ gl-screenshot >>bitmap ] [ dim>> >>dim ] bi
 | 
				
			||||||
    bgr>bitmap ;
 | 
					    RGBA >>component-order
 | 
				
			||||||
 | 
					    t >>upside-down?
 | 
				
			||||||
: save-screenshot ( window path -- )
 | 
					    normalize-image ;
 | 
				
			||||||
    [ screenshot ] dip save-bitmap ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
: screenshot. ( window -- )
 | 
					: screenshot. ( window -- )
 | 
				
			||||||
    [ screenshot <image-gadget> ] [ title>> ] bi open-window ; 
 | 
					    [ screenshot <image-gadget> ] [ title>> ] bi open-window ; 
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue