Merge branch 'master' into euler

extra/cap/cap.factor

@@ -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 ;
+
+
+

extra/graphics/bitmap/bitmap.factor

@@ -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