! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays
+math specialized-arrays.direct.uint byte-arrays fry
specialized-arrays.direct.ushort specialized-arrays.uint
specialized-arrays.ushort specialized-arrays.float ;
IN: images
GENERIC: load-image* ( path tuple -- image )
: add-dummy-alpha ( seq -- seq' )
- 3 <sliced-groups>
- [ 255 suffix ] map concat ;
+ 3 <groups> [ 255 suffix ] map concat ;
: normalize-floats ( byte-array -- byte-array )
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
+GENERIC: normalize-component-order* ( image component-order -- image )
+
: normalize-component-order ( image -- image )
- dup component-order>> '[ _ normalize-component-order* ] change-bitmap
- dup component-order>>
- {
- { RGBA [ ] }
- { R32G32B32A32 [
- [ normalize-floats ] change-bitmap
- ] }
- { R32G32B32 [
- [ normalize-floats add-dummy-alpha ] change-bitmap
- ] }
- { R16G16B16A16 [
- [ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap
- ] }
- { R16G16B16 [
- [
- byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha
- ] change-bitmap
- ] }
- { BGRA [
- [
- 4 <sliced-groups> dup [ 3 head-slice reverse-here ] each
- ] change-bitmap
- ] }
- { RGB [ [ add-dummy-alpha ] change-bitmap ] }
- { BGR [
- [
- 3 <sliced-groups>
- [ [ 3 head-slice reverse-here ] each ]
- [ [ 255 suffix ] map ] bi concat
- ] change-bitmap
- ] }
- } case
-- RGBA >>component-order ;
++ dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
+
+M: RGBA normalize-component-order* drop ;
+
+M: R32G32B32A32 normalize-component-order*
+ drop normalize-floats ;
+
+M: R32G32B32 normalize-component-order*
+ drop normalize-floats add-dummy-alpha ;
+
+: RGB16>8 ( bitmap -- bitmap' )
+ byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
+
+M: R16G16B16A16 normalize-component-order*
+ drop RGB16>8 ;
+
+M: R16G16B16 normalize-component-order*
+ drop RGB16>8 add-dummy-alpha ;
+
+: BGR>RGB ( bitmap bytes-per-pixel -- pixels )
+ <groups> [ 3 cut [ reverse ] dip append ] map B{ } join ; inline
+
+M: BGRA normalize-component-order*
+ drop 4 BGR>RGB ;
+
+M: RGB normalize-component-order*
+ drop add-dummy-alpha ;
+
+M: BGR normalize-component-order*
+ drop 3 BGR>RGB add-dummy-alpha ;
+
+: ARGB>RGBA ( bitmap -- bitmap' )
+ 4 <groups> [ unclip suffix ] map B{ } join ;
+
+M: ARGB normalize-component-order*
+ drop ARGB>RGBA ;
+
+M: ABGR normalize-component-order*
+ drop ARGB>RGBA 4 BGR>RGB ;
GENERIC: normalize-scan-line-order ( image -- image )
: normalize-image ( image -- image )
[ >byte-array ] change-bitmap
normalize-component-order
- normalize-scan-line-order ;
+ normalize-scan-line-order ;
{ $values { "n" "a starting index" } { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "i" "the index of the first match, or f" } { "elt" "the first matching element, or " { $link f } } }
{ $description "Applies the quotation to each element of the sequence in reverse order, until it outputs a true value or the start of the sequence is reached. If the quotation yields a true value for some sequence element, the word outputs the element index and the element itself. Otherwise, the word outputs an index of f and " { $link f } " as the element." } ;
+ HELP: map-find
+ { $values { "seq" sequence } { "quot" { $quotation "( elt -- result/f )" } } { "result" "the first non-false result of the quotation" } { "elt" "the first matching element, or " { $link f } } }
+ { $description "Applies the quotation to each element of the sequence, until the quotation outputs a true value. If the quotation ever yields a result which is not " { $link f } ", then the value is output, along with the element of the sequence which yielded this." } ;
+
HELP: any?
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the sequence contains an element satisfying the predicate, by applying the predicate to each element in turn until a true value is found. If the sequence is empty or if the end of the sequence is reached, outputs " { $link f } "." } ;
{ $side-effects "seq" } ;
HELP: replace-slice
-{ $values { "new" sequence } { "seq" "a mutable sequence" } { "from" "a non-negative integer" } { "to" "a non-negative integer" } }
+{ $values { "new" sequence } { "seq" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq'" sequence } }
{ $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." }
-{ $notes "If the " { $snippet "to - from" } " is equal to the length of " { $snippet "new" } ", the sequence remains the same size, and does not have to support resizing. However, if " { $snippet "to - from" } " is not equal to the length of " { $snippet "new" } ", the " { $link set-length } " word is called on " { $snippet "seq" } ", so fixed-size sequences should not be passed in this case." }
-{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
-{ $side-effects "seq" } ;
+{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } ;
{ push prefix suffix } related-words
{ $subsection unclip-last-slice }
{ $subsection cut-slice }
"A utility for words which use slices as iterators:"
-{ $subsection <flat-slice> } ;
+{ $subsection <flat-slice> }
+"Replacing slices with new elements:"
+{ $subsection replace-slice } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
{ $subsection map }
{ $subsection map-as }
{ $subsection map-index }
+ { $subsection map-reduce }
{ $subsection accumulate }
{ $subsection produce }
{ $subsection produce-as }
{ $subsection 2reduce }
{ $subsection 2map }
{ $subsection 2map-as }
+ { $subsection 2map-reduce }
{ $subsection 2all? } ;
ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators"
{ $subsection find }
{ $subsection find-from }
{ $subsection find-last }
- { $subsection find-last-from } ;
+ { $subsection find-last-from }
+ { $subsection map-find } ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
-{ $subsection replace-slice }
"Many operations have constructive and destructive variants:"
{ $table
{ "Constructive" "Destructive" }
USING: arrays kernel math namespaces sequences kernel.private
- sequences.private strings sbufs tools.test vectors
+ sequences.private strings sbufs tools.test vectors assocs
generic vocabs.loader ;
IN: sequences.tests
[ 5040 ] [ [ 1 2 3 4 5 6 7 ] 1 [ * ] reduce ] unit-test
-[ 5040 [ 1 1 2 6 24 120 720 ] ]
-[ [ 1 2 3 4 5 6 7 ] 1 [ * ] accumulate ] unit-test
+[ 5040 { 1 1 2 6 24 120 720 } ]
+[ { 1 2 3 4 5 6 7 } 1 [ * ] accumulate ] unit-test
[ f f ] [ [ ] [ ] find ] unit-test
[ 0 1 ] [ [ 1 ] [ ] find ] unit-test
[ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test
-[ V{ 1 2 "a" "b" 5 6 7 } ] [
- { "a" "b" } 2 4 V{ 1 2 3 4 5 6 7 } clone
- [ replace-slice ] keep
+[ { 1 2 "a" "b" 5 6 7 } ] [
+ { "a" "b" } 2 4 { 1 2 3 4 5 6 7 }
+ replace-slice
] unit-test
-[ V{ 1 2 "a" "b" 6 7 } ] [
- { "a" "b" } 2 5 V{ 1 2 3 4 5 6 7 } clone
- [ replace-slice ] keep
+[ { 1 2 "a" "b" 6 7 } ] [
+ { "a" "b" } 2 5 { 1 2 3 4 5 6 7 }
+ replace-slice
] unit-test
-[ V{ 1 2 "a" "b" 4 5 6 7 } ] [
- { "a" "b" } 2 3 V{ 1 2 3 4 5 6 7 } clone
- [ replace-slice ] keep
+[ { 1 2 "a" "b" 4 5 6 7 } ] [
+ { "a" "b" } 2 3 { 1 2 3 4 5 6 7 }
+ replace-slice
] unit-test
-[ V{ 1 2 3 4 5 6 7 "a" "b" } ] [
- { "a" "b" } 7 7 V{ 1 2 3 4 5 6 7 } clone
- [ replace-slice ] keep
+[ { 1 2 3 4 5 6 7 "a" "b" } ] [
+ { "a" "b" } 7 7 { 1 2 3 4 5 6 7 }
+ replace-slice
] unit-test
-[ V{ "a" 3 } ] [
- { "a" } 0 2 V{ 1 2 3 } clone [ replace-slice ] keep
+[ { "a" 3 } ] [
+ { "a" } 0 2 { 1 2 3 } replace-slice
] unit-test
[ { 1 4 9 } ] [ { 1 2 3 } clone dup [ sq ] change-each ] unit-test
[ 5 ] [ 1 >bignum "\u000001\u000005\u000007" nth-unsafe ] unit-test
[ SBUF" before&after" ] [
- "&" 6 11 SBUF" before and after" [ replace-slice ] keep
+ "&" 6 11 SBUF" before and after" replace-slice
] unit-test
[ 3 "a" ] [ { "a" "b" "c" "a" "d" } [ "a" = ] find-last ] unit-test
[ "asdf" iota ] must-fail
[ T{ iota { n 10 } } ] [ 10 iota ] unit-test
[ 0 ] [ 10 iota first ] unit-test
+
+ [ "hi" 3 ] [
+ { 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
+ ] unit-test
+
+ [ f f ] [
+ { 1 2 3 4 5 6 7 8 } [ H{ { 11 "hi" } } at ] map-find
+ ] unit-test
[ first3-unsafe ] [ 3 swap nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- )
- [ tuck [ nth-unsafe ] 2bi@ ]
- [ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline
+ [ [ nth-unsafe ] curry bi@ ]
+ [ [ set-nth-unsafe ] curry bi@ ] 3bi ; inline
: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline
{ seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq )
- [ from>> ] [ seq>> ] bi [ tuck [ + ] 2bi@ ] dip ; inline
+ [ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline
ERROR: slice-error from to seq reason ;
PRIVATE>
: subseq ( from to seq -- subseq )
- [ check-slice prepare-subseq (copy) ] [ like ] bi ;
+ [ check-slice prepare-subseq (copy) ] keep like ;
: head ( seq n -- headseq ) (head) subseq ;
[ (each) ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
- [ over ] dip [ nth-unsafe ] 2bi@ ; inline
+ [ nth-unsafe ] bi-curry@ bi ; inline
: (2each) ( seq1 seq2 quot -- n quot' )
[
] dip compose ; inline
: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
- [ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline
+ [ nth-unsafe ] tri-curry@ tri ; inline
: (3each) ( seq1 seq2 seq3 quot -- n quot' )
[
- [ [ length ] tri@ min min ] 3keep
- [ 3nth-unsafe ] 3curry
+ [ [ length ] tri@ min min ]
+ [ [ 3nth-unsafe ] 3curry ] 3bi
] dip compose ; inline
: finish-find ( i seq -- i elt )
[ 2drop f f ]
if ; inline
-: (interleave) ( n elt between quot -- )
- roll 0 = [ nip ] [ swapd 2slip ] if call ; inline
-
PRIVATE>
: each ( seq quot -- )
over map-into ; inline
: accumulate ( seq identity quot -- final newseq )
- swapd [ pick slip ] curry map ; inline
+ swapd [ [ call ] [ 2drop ] 3bi ] curry { } map-as ; inline
: 2each ( seq1 seq2 quot -- )
(2each) each-integer ; inline
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq )
- over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
-
-: interleave ( seq between quot -- )
- [ (interleave) ] 2curry [ [ length ] keep ] dip 2each ; inline
+ over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
: each-index ( seq quot -- )
prepare-index 2each ; inline
+: interleave ( seq between quot -- )
+ swap [ drop ] [ [ 2dip call ] 2curry ] 2bi
+ [ [ 0 = ] 2dip if ] 2curry
+ each-index ; inline
+
: map-index ( seq quot -- )
prepare-index 2map ; inline
[ over - ] 2dip move-backward
] if ;
-PRIVATE>
-
: open-slice ( shift from seq -- )
pick 0 = [
3drop
set-length
] if ;
+PRIVATE>
+
: delete-slice ( from to seq -- )
check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- )
[ dup 1+ ] dip delete-slice ;
-: replace-slice ( new from to seq -- )
- [ [ [ dup pick length + ] dip - over ] dip open-slice ] keep
- copy ;
+: snip ( from to seq -- head tail )
+ [ swap head ] [ swap tail ] bi-curry bi* ; inline
+
+: snip-slice ( from to seq -- head tail )
+ [ swap head-slice ] [ swap tail-slice ] bi-curry bi* ; inline
+
+: replace-slice ( new from to seq -- seq' )
+ snip-slice surround ;
: remove-nth ( n seq -- seq' )
- [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ;
+ [ [ { } ] dip dup 1+ ] dip replace-slice ;
: pop ( seq -- elt )
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
: exchange ( m n seq -- )
- pick over bounds-check 2drop 2dup bounds-check 2drop
- exchange-unsafe ;
+ [ nip bounds-check 2drop ]
+ [ bounds-check 3drop ]
+ [ exchange-unsafe ]
+ 3tri ;
: reverse-here ( seq -- )
- dup length dup 2/ [
- [ 2dup ] dip
- tuck - 1- rot exchange-unsafe
- ] each 2drop ;
+ [ length 2/ ] [ length ] [ ] tri
+ [ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq )
[
: join ( seq glue -- newseq )
[
- 2dup joined-length over new-resizable spin
- [ dup pick push-all ] [ pick push-all ] interleave drop
+ 2dup joined-length over new-resizable [
+ [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
+ interleave
+ ] keep
] keep like ;
: padding ( seq n elt quot -- newseq )
: drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch [ 2dup min-length ] unless*
- tuck [ tail-slice ] 2bi@ ;
+ [ tail-slice ] curry bi@ ;
: unclip ( seq -- rest first )
[ rest ] [ first-unsafe ] bi ;
[ [ 2unclip-slice ] dip [ call ] keep ] dip
compose 2reduce ; inline
+ : map-find ( seq quot -- result elt )
+ [ f ] 2dip
+ [ [ nip ] dip call dup ] curry find
+ [ [ drop f ] unless ] dip ; inline
+
: unclip-last-slice ( seq -- butlast-slice last )
[ but-last-slice ] [ peek ] bi ; inline
: <flat-slice> ( seq -- slice )
- dup slice? [ { } like ] when 0 over length rot <slice> ;
+ dup slice? [ { } like ] when
+ [ drop 0 ] [ length ] [ ] tri <slice> ;
inline
-: trim-head-slice ( seq quot -- slice )
- over [ [ not ] compose find drop ] dip swap
- [ tail-slice ] [ dup length tail-slice ] if* ; inline
+<PRIVATE
+: (trim-head) ( seq quot -- seq n )
+ over [ [ not ] compose find drop ] dip
+ [ length or ] keep swap ; inline
+
+: (trim-tail) ( seq quot -- seq n )
+ over [ [ not ] compose find-last drop ?1+ ] dip
+ swap ; inline
+
+PRIVATE>
+
+: trim-head-slice ( seq quot -- slice )
+ (trim-head) tail-slice ; inline
+
: trim-head ( seq quot -- newseq )
- over [ trim-head-slice ] dip like ; inline
+ (trim-head) tail ; inline
: trim-tail-slice ( seq quot -- slice )
- over [ [ not ] compose find-last drop ] dip swap
- [ 1+ head-slice ] [ 0 head-slice ] if* ; inline
+ (trim-tail) head-slice ; inline
: trim-tail ( seq quot -- newseq )
- over [ trim-tail-slice ] dip like ; inline
+ (trim-tail) head ; inline
: trim-slice ( seq quot -- slice )
[ trim-head-slice ] [ trim-tail-slice ] bi ; inline
: trim ( seq quot -- newseq )
- over [ trim-slice ] dip like ; inline
+ [ trim-slice ] [ drop ] 2bi like ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ;
: product ( seq -- n ) 1 [ * ] binary-reduce ;
-: infimum ( seq -- n ) dup first [ min ] reduce ;
+: infimum ( seq -- n ) [ ] [ min ] map-reduce ;
-: supremum ( seq -- n ) dup first [ max ] reduce ;
+: supremum ( seq -- n ) [ ] [ max ] map-reduce ;
-: sigma ( seq quot -- n ) [ 0 ] 2dip [ rot slip + ] curry each ; inline
+: sigma ( seq quot -- n )
+ [ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
M: image-gadget pref-dim*
image>> dim>> ;
- : draw-image ( tiff -- )
+ : draw-image ( image -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
[ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
[ bitmap>> ] bi glDrawPixels ;
M: image-gadget draw-gadget* ( gadget -- )
- origin get [ image>> draw-image ] with-translation ;
+ image>> draw-image ;
: <image-gadget> ( image -- gadget )
\ image-gadget new-gadget
projects / factor.git / commitdiff