Merge branch 'master' of git://factorcode.org/git/factor

basis/images/bitmap/bitmap-tests.factor

@@ -1,6 +1,6 @@
 USING: images.bitmap images.viewer io.encodings.binary
 io.files io.files.unique kernel tools.test images.loader
-literals sequences ;
+literals sequences checksums.md5 checksums ;
 IN: images.bitmap.tests
 
 CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
@@ -11,6 +11,11 @@ CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
 
 CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
 
+CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp"
+CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
+CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
+CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
+
 [ t ]
 [
     test-bitmap24
@@ -24,4 +29,23 @@ CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
     $ test-bitmap8
     $ test-bitmap24
     "vocab:ui/render/test/reference.bmp"
-} [ [ ] swap [ load-image drop ] curry unit-test ] each
+} [ [ ] swap [ load-image drop ] curry unit-test ] each
+
+
+: test-bitmap-save ( path -- ? )
+    [ md5 checksum-file ]
+    [ load-image ] bi
+    "bitmap-save-test" unique-file
+    [ save-bitmap ]
+    [ md5 checksum-file ] bi = ;
+
+[
+    t   
+] [
+    {
+        $ test-40
+        $ test-41
+        $ test-42
+        $ test-43
+    } [ test-bitmap-save ] all?
+] unit-test

basis/images/bitmap/bitmap.factor

@@ -37,14 +37,14 @@ M: bitmap-magic summary
 ERROR: bmp-not-supported n ;
 
 : reverse-lines ( byte-array width -- byte-array )
-    3 * <sliced-groups> <reversed> concat ; inline
+    <sliced-groups> <reversed> concat ; inline
 
 : raw-bitmap>seq ( loading-bitmap -- array )
     dup bit-count>>
     {
         { 32 [ color-index>> ] }
-        { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
-        { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
+        { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
+        { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
         [ bmp-not-supported ]
     } case >byte-array ;
 
@@ -81,30 +81,31 @@ ERROR: bmp-not-supported n ;
 : image-size ( loading-bitmap -- n )
     [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
 
+: bitmap-padding ( width -- n )
+    3 * 4 mod 4 swap - 4 mod ; inline
+
 :: fixup-color-index ( loading-bitmap -- loading-bitmap )
     loading-bitmap width>> :> width
     width 3 * :> width*3
-    loading-bitmap height>> abs :> height
-    loading-bitmap color-index>> length :> color-index-length
-    color-index-length height /i :> stride
-    color-index-length width*3 height * - height /i :> padding
+    loading-bitmap width>> bitmap-padding :> padding
+    loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
+    loading-bitmap
     padding 0 > [
-        loading-bitmap [
+        [
             stride <sliced-groups>
             [ width*3 head-slice ] map concat
         ] change-color-index
-    ] [
-        loading-bitmap
-    ] if ;
+    ] when ;
 
 : parse-bitmap ( loading-bitmap -- loading-bitmap )
     dup rgb-quads-length read >>rgb-quads
     dup color-index-length read >>color-index
     fixup-color-index ;
 
-: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
-    [ binary ] dip '[
-        _ parse-file-header parse-bitmap-header parse-bitmap
+: load-bitmap-data ( path -- loading-bitmap )
+    binary [
+        loading-bitmap new
+        parse-file-header parse-bitmap-header parse-bitmap
     ] with-file-reader ;
 
 ERROR: unknown-component-order bitmap ;
@@ -117,8 +118,7 @@ ERROR: unknown-component-order bitmap ;
         [ unknown-component-order ]
     } case ;
 
-: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
-    [ bitmap-image new ] dip
+: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
     {
         [ raw-bitmap>seq >>bitmap ]
         [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
@@ -127,20 +127,30 @@ ERROR: unknown-component-order bitmap ;
     } cleave ;
 
 M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
-    drop loading-bitmap new
-    load-bitmap-data
-    loading-bitmap>bitmap-image ;
+    swap load-bitmap-data loading-bitmap>bitmap-image ;
 
 PRIVATE>
 
-: bitmap>color-index ( bitmap-array -- byte-array )
-    4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
+: bitmap>color-index ( bitmap -- byte-array )
+    [
+        bitmap>>
+        4 <sliced-groups>
+        [ 3 head-slice <reversed> ] map
+        B{ } join
+    ] [
+        dim>> first dup bitmap-padding dup 0 > [
+            [ 3 * group ] dip '[ _ <byte-array> append ] map
+            B{ } join
+        ] [
+            2drop
+        ] if
+    ] bi ;
 
 : save-bitmap ( image path -- )
     binary [
         B{ CHAR: B CHAR: M } write
         [
-            bitmap>> bitmap>color-index length 14 + 40 + write4
+            bitmap>color-index length 14 + 40 + write4
             0 write4
             54 write4
             40 write4
@@ -159,7 +169,7 @@ PRIVATE>
                 [ drop 0 write4 ]
 
                 ! size-image
-                [ bitmap>> bitmap>color-index length write4 ]
+                [ bitmap>color-index length write4 ]
 
                 ! x-pels
                 [ drop 0 write4 ]
@@ -175,7 +185,9 @@ PRIVATE>
 
                 ! rgb-quads
                 [
-                    [ bitmap>> bitmap>color-index ] [ dim>> first ] bi
+                    [ bitmap>color-index ]
+                    [ dim>> first 3 * ]
+                    [ dim>> first bitmap-padding + ] tri
                     reverse-lines write
                 ]
             } cleave

basis/io/files/unique/unique-docs.factor

@@ -62,8 +62,8 @@ HELP: current-temporary-directory
 
 HELP: unique-file
 { $values
+     { "prefix" string }
      { "path" "a pathname string" }
-     { "path'" "a pathname string" }
 }
 { $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ;
 

basis/io/files/unique/unique.factor

@@ -64,7 +64,7 @@ PRIVATE>
     [ unique-directory ] dip
     '[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
 
-: unique-file ( path -- path' )
+: unique-file ( prefix -- path )
     "" make-unique-file ;
 
 {

basis/windows/uniscribe/uniscribe.factor

@@ -59,10 +59,10 @@ TUPLE: script-string font string metrics ssa size image disposed ;
         ssa>> ! ssa
         0 ! iX
         0 ! iY
-        0 ! uOptions
-        f ! prc
+        ETO_OPAQUE ! uOptions
     ]
-    [ selection-start/end ] bi
+    [ [ { 0 0 } ] dip size>> <RECT> ]
+    [ selection-start/end ] tri
     ! iMinSel
     ! iMaxSel
     FALSE ! fDisabled
@@ -108,7 +108,7 @@ M: script-string dispose*
 
 SYMBOL: cached-script-strings
 
-: cached-script-string ( string font -- script-string )
+: cached-script-string ( font string -- script-string )
     cached-script-strings get-global [ <script-string> ] 2cache ;
 
 [ <cache-assoc> cached-script-strings set-global ]