PRIVATE>\r
\r
! for debug -- shows residual values\r
-: reverse-png-filter' ( lines -- filtered )\r
+: reverse-png-filter' ( lines -- byte-array )\r
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip\r
- concat [ 128 + 256 wrap ] map ;\r
+ concat [ 128 + ] B{ } map-as ;\r
\r
-: reverse-png-filter ( lines -- filtered )\r
+: reverse-png-filter ( lines -- byte-array )\r
dup first [ 0 ] replicate prefix\r
[ { 0 0 } prepend ] map\r
2 clump [\r
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line\r
- ] map concat ;\r
+ ] map B{ } concat-as ;\r
\r
: zlib-inflate ( bytes -- bytes )\r
bs:<lsb0-bit-reader>\r
--- /dev/null
+Doug Coleman
\ No newline at end of file
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays grouping sequences ;
+USING: accessors arrays combinators grouping kernel locals math
+math.matrices math.order multiline sequence-parser sequences
+tools.continuations ;
IN: compression.run-length
: run-length-uncompress ( byte-array -- byte-array' )
- 2 group [ first2 <array> ] map concat ;
+ 2 group [ first2 <array> ] map B{ } concat-as ;
+
+: 8hi-lo ( byte -- hi lo )
+ [ HEX: f0 bitand -4 shift ] [ HEX: f bitand ] bi ; inline
+
+:: run-length-uncompress-bitmap4 ( byte-array m n -- byte-array' )
+ byte-array <sequence-parser> :> sp
+ m 1 + n zero-matrix :> matrix
+ n 4 mod n + :> stride
+ 0 :> i!
+ 0 :> j!
+ f :> done?!
+ [
+ ! i j [ number>string ] bi@ " " glue .
+ sp next dup 0 = [
+ sp next dup HEX: 03 HEX: ff between? [
+ nip [ sp ] dip dup odd?
+ [ 1 + take-n but-last ] [ take-n ] if
+ [ j matrix i swap nth copy ] [ length j + j! ] bi
+ ] [
+ nip {
+ { 0 [ i 1 + i! 0 j! ] }
+ { 1 [ t done?! ] }
+ { 2 [ sp next j + j! sp next i + i! ] }
+ } case
+ ] if
+ ] [
+ [ sp next 8hi-lo 2array <repetition> concat ] [ head ] bi
+ [ j matrix i swap nth copy ] [ length j + j! ] bi
+ ] if
+
+ ! j stride >= [ i 1 + i! 0 j! ] when
+ j stride >= [ 0 j! ] when
+ done? not
+ ] loop
+ matrix B{ } concat-as ;
+
+:: run-length-uncompress-bitmap8 ( byte-array m n -- byte-array' )
+ byte-array <sequence-parser> :> sp
+ m 1 + n zero-matrix :> matrix
+ n 4 mod n + :> stride
+ 0 :> i!
+ 0 :> j!
+ f :> done?!
+ [
+ ! i j [ number>string ] bi@ " " glue .
+ sp next dup 0 = [
+ sp next dup HEX: 03 HEX: ff between? [
+ nip [ sp ] dip dup odd?
+ [ 1 + take-n but-last ] [ take-n ] if
+ [ j matrix i swap nth copy ] [ length j + j! ] bi
+ ] [
+ nip {
+ { 0 [ i 1 + i! 0 j! ] }
+ { 1 [ t done?! ] }
+ { 2 [ sp next j + j! sp next i + i! ] }
+ } case
+ ] if
+ ] [
+ sp next <array> [ j matrix i swap nth copy ] [ length j + j! ] bi
+ ] if
+
+ ! j stride >= [ i 1 + i! 0 j! ] when
+ j stride >= [ 0 j! ] when
+ done? not
+ ] loop
+ matrix B{ } concat-as ;
CONSTRUCTOR: default ( -- obj ) ;
[ 0 ] [ <default> a>> ] unit-test
+
+
+TUPLE: inherit1 a ;
+TUPLE: inherit2 < inherit1 a ;
+
+CONSTRUCTOR: inherit2 ( a -- obj ) ;
+
+[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs classes.tuple effects.parser fry
-generalizations generic.standard kernel lexer locals macros
-parser sequences slots vocabs words ;
+USING: accessors assocs classes classes.tuple effects.parser
+fry generalizations generic.standard kernel lexer locals macros
+parser sequences slots vocabs words arrays ;
IN: constructors
! An experiment
[ drop define-initializer-generic ]
[ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
+: all-slots-assoc ( class -- slots )
+ superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
+
MACRO:: slots>constructor ( class slots -- quot )
- class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
+ class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
+ class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
slots length
- params length
+ default-params length
'[
- _ narray slots swap zip
- params swap assoc-union
- values _ firstn class boa
+ _ narray slot-assoc swap zip
+ default-params swap assoc-union values _ firstn class boa
] ;
-:: define-constructor ( constructor-word class effect def -- )
+:: (define-constructor) ( constructor-word class effect def -- word quot )
constructor-word
class def define-initializer
- class effect in>> '[ _ _ slots>constructor ]
+ class effect in>> '[ _ _ slots>constructor ] ;
+
+:: define-constructor ( constructor-word class effect def -- )
+ constructor-word class effect def (define-constructor)
class lookup-initializer
'[ @ _ execute( obj -- obj ) ] effect define-declared ;
+:: define-auto-constructor ( constructor-word class effect def -- )
+ constructor-word class effect def (define-constructor)
+ class superclasses [ lookup-initializer ] map sift
+ '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
+
: scan-constructor ( -- class word )
scan-word [ name>> "<" ">" surround create-in ] keep ;
-SYNTAX: CONSTRUCTOR:
- scan-constructor
- complete-effect
- parse-definition
- define-constructor ;
+: parse-constructor ( -- class word effect def )
+ scan-constructor complete-effect parse-definition ;
+
+SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
+
+SYNTAX: AUTO-CONSTRUCTOR: parse-constructor define-auto-constructor ;
"initializers" create-vocab drop
"Cannot do next-object outside begin/end-scan" print drop ;
: undefined-symbol-error. ( obj -- )
- "The image refers to a library or symbol that was not found"
- " at load time" append print drop ;
+ "The image refers to a library or symbol that was not found at load time"
+ print drop ;
: stack-underflow. ( obj name -- )
write " stack underflow" print drop ;
drop "Not in a vocabulary; IN: form required" ;
M: no-word-error summary
- name>> "No word named ``" "'' found in current vocabulary search path" surround ;
+ name>>
+ "No word named ``"
+ "'' found in current vocabulary search path" surround ;
M: no-word-error error. summary print ;
M: ambiguous-use-error summary
- words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ;
+ words>> first name>>
+ "More than one vocabulary defines a word named ``" "''" surround ;
M: ambiguous-use-error error. summary print ;
{
{ [ os windows? ] [ "debugger.windows" require ] }
{ [ os unix? ] [ "debugger.unix" require ] }
-} cond
\ No newline at end of file
+} cond
{ 3 5 } [ 2 nweave ] must-infer-as\r
\r
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]\r
-[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
\ No newline at end of file
+[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test\r
+\r
+[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test\r
+\r
+[ [ 1 2 3 ] [ 1 2 3 ] ]\r
+[ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test\r
+\r
+[ 15 3 ] [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test\r
MACRO: npick ( n -- )
1- [ dup ] [ '[ _ dip swap ] ] repeat ;
+MACRO: nover ( n -- )
+ dup '[ _ 1 + npick ] n*quot ;
+
MACRO: ndup ( n -- )
dup '[ _ npick ] n*quot ;
MACRO: nwith ( n -- )
[ with ] n*quot ;
+MACRO: nbi ( n -- )
+ '[ [ _ nkeep ] dip call ] ;
+
MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ;
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
+MACRO: nbi-curry ( n -- )
+ [ bi-curry ] n*quot ;
+
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
USING: images.bitmap images.viewer io.encodings.binary
io.files io.files.unique kernel tools.test images.loader
-literals sequences checksums.md5 checksums
-images.normalization ;
+literals sequences checksums.md5 checksums ;
IN: images.bitmap.tests
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
: test-bitmap-save ( path -- ? )
[ md5 checksum-file ]
- [ load-image normalize-image ] bi
- "bitmap-save-test" unique-file
+ [ load-image ] bi
+ "bitmap-save-test" ".bmp" make-unique-file
[ save-bitmap ]
[ md5 checksum-file ] bi = ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators compression.run-length endian fry grouping images
-images.loader io io.binary io.encodings.binary io.files
-io.streams.limited kernel locals macros math math.bitwise
-math.functions namespaces sequences specialized-arrays.uint
-specialized-arrays.ushort strings summary io.encodings.8-bit
-io.encodings.string ;
+images.bitmap.loading images.bitmap.saving images.loader io
+io.binary io.encodings.8-bit io.encodings.binary
+io.encodings.string io.files io.streams.limited kernel locals
+macros math math.bitwise math.functions namespaces sequences
+specialized-arrays.uint specialized-arrays.ushort strings
+summary ;
QUALIFIED-WITH: bitstreams b
IN: images.bitmap
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
-: write2 ( n -- ) 2 >le write ;
-: write4 ( n -- ) 4 >le write ;
-
SINGLETON: bitmap-image
"bmp" bitmap-image register-image-class
-TUPLE: loading-bitmap
-magic size reserved1 reserved2 offset header-length width
-height planes bit-count compression size-image
-x-pels y-pels color-used color-important
-red-mask green-mask blue-mask alpha-mask
-cs-type end-points
-gamma-red gamma-green gamma-blue
-intent profile-data profile-size reserved3
-color-palette color-index bitfields ;
-
! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
<PRIVATE
-: os2-color-lookup ( loading-bitmap -- seq )
- [ color-index>> >array ]
- [ color-palette>> 3 <sliced-groups> ] bi
- '[ _ nth ] map concat ;
-
-: os2v2-color-lookup ( loading-bitmap -- seq )
+: color-lookup3 ( loading-bitmap -- seq )
[ color-index>> >array ]
[ color-palette>> 3 <sliced-groups> ] bi
'[ _ nth ] map concat ;
-: v3-color-lookup ( loading-bitmap -- seq )
+: color-lookup4 ( loading-bitmap -- seq )
[ color-index>> >array ]
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
'[ _ nth ] map concat ;
+! os2v1 is 3bytes each, all others are 3 + 1 unused
: color-lookup ( loading-bitmap -- seq )
- dup header-length>> {
- { 12 [ os2-color-lookup ] }
- { 64 [ os2v2-color-lookup ] }
- { 40 [ v3-color-lookup ] }
- ! { 108 [ v4-color-lookup ] }
- ! { 124 [ v5-color-lookup ] }
+ dup file-header>> header-length>> {
+ { 12 [ color-lookup3 ] }
+ { 64 [ color-lookup4 ] }
+ { 40 [ color-lookup4 ] }
+ { 108 [ color-lookup4 ] }
+ { 124 [ color-lookup4 ] }
} case ;
ERROR: bmp-not-supported n ;
] { } map-as B{ } concat-as ;
: bitmap>bytes ( loading-bitmap -- byte-array )
- dup bit-count>>
+ dup header>> bit-count>>
{
{ 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
} case >byte-array ;
: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
- dup bit-count>> {
+ dup header>> bit-count>> {
{ 16 [ dup color-palette>> 4 group [ le> ] map ] }
{ 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
} case reverse >>bitfields ;
: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
set-bitfield-widths
- dup bit-count>> {
+ dup header>> bit-count>> {
{ 16 [
dup bitfields>> '[
byte-array>ushort-array _ uncompress-bitfield
] change-color-index
] }
- { 32 [
- dup bitfields>> '[
- byte-array>uint-array _ uncompress-bitfield
- ] change-color-index
- ] }
+ { 32 [ ] }
[ unsupported-bitfield-widths ]
} case ;
ERROR: unsupported-bitmap-compression compression ;
-: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
- dup compression>> {
+GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
+ dup header>> uncompress-bitmap* ;
+
+M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+ drop ;
+
+: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
+ dupd '[
+ _ header>> [ width>> ] [ height>> ] bi
+ _ execute
+ ] change-color-index ; inline
+
+M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+ compression>> {
{ f [ ] }
{ 0 [ ] }
- { 1 [ [ run-length-uncompress ] change-color-index ] }
- { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
+ { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
+ { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
{ 3 [ uncompress-bitfield-widths ] }
{ 4 [ "jpeg" unsupported-bitmap-compression ] }
{ 5 [ "png" unsupported-bitmap-compression ] }
3 * 4 mod 4 swap - 4 mod ; inline
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
- uncompress-bitmap
- bitmap>bytes ;
-
-: parse-file-header ( loading-bitmap -- loading-bitmap )
- 2 read latin1 decode >>magic
- read4 >>size
- read2 >>reserved1
- read2 >>reserved2
- read4 >>offset ;
-
-: read-v3-header ( loading-bitmap -- loading-bitmap )
- read4 >>width
- read4 32 >signed >>height
- read2 >>planes
- read2 >>bit-count
- read4 >>compression
- read4 >>size-image
- read4 >>x-pels
- read4 >>y-pels
- read4 >>color-used
- read4 >>color-important ;
-
-: read-v4-header ( loading-bitmap -- loading-bitmap )
- read-v3-header
- read4 >>red-mask
- read4 >>green-mask
- read4 >>blue-mask
- read4 >>alpha-mask
- read4 >>cs-type
- read4 read4 read4 3array >>end-points
- read4 >>gamma-red
- read4 >>gamma-green
- read4 >>gamma-blue ;
-
-: read-v5-header ( loading-bitmap -- loading-bitmap )
- read-v4-header
- read4 >>intent
- read4 >>profile-data
- read4 >>profile-size
- read4 >>reserved3 ;
-
-: read-os2-header ( loading-bitmap -- loading-bitmap )
- read2 >>width
- read2 16 >signed >>height
- read2 >>planes
- read2 >>bit-count ;
-
-: read-os2v2-header ( loading-bitmap -- loading-bitmap )
- read4 >>width
- read4 32 >signed >>height
- read2 >>planes
- read2 >>bit-count ;
-
-ERROR: unknown-bitmap-header n ;
-
-: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
- read4 [ >>header-length ] keep
- {
- { 12 [ read-os2-header ] }
- { 64 [ read-os2v2-header ] }
- { 40 [ read-v3-header ] }
- { 108 [ read-v4-header ] }
- { 124 [ read-v5-header ] }
- [ unknown-bitmap-header ]
- } case ;
+ uncompress-bitmap bitmap>bytes ;
: color-palette-length ( loading-bitmap -- n )
+ file-header>>
[ offset>> 14 - ] [ header-length>> ] bi - ;
-: color-index-length ( loading-bitmap -- n )
+: color-index-length ( header -- n )
{
[ width>> ]
[ planes>> * ]
[ height>> abs * ]
} cleave ;
-: image-size ( loading-bitmap -- n )
- [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
-
-: parse-bitmap ( loading-bitmap -- loading-bitmap )
- dup color-palette-length read >>color-palette
- dup size-image>> dup 0 > [
- read >>color-index
- ] [
- drop dup color-index-length read >>color-index
- ] if ;
-
ERROR: unsupported-bitmap-file magic ;
-: load-bitmap ( path -- loading-bitmap )
- binary stream-throws <limited-file-reader> [
- loading-bitmap new
- parse-file-header dup magic>> {
- { "BM" [ parse-bitmap-header parse-bitmap ] }
- ! { "BA" [ parse-os2-bitmap-array ] }
- ! { "CI" [ parse-os2-color-icon ] }
- ! { "CP" [ parse-os2-color-pointer ] }
- ! { "IC" [ parse-os2-icon ] }
- ! { "PT" [ parse-os2-pointer ] }
- [ unsupported-bitmap-file ]
- } case
- ] with-input-stream ;
-
-ERROR: unknown-component-order bitmap ;
-
-: bitmap>component-order ( loading-bitmap -- object )
- bit-count>> {
- { 32 [ BGR ] }
- { 24 [ BGR ] }
- { 16 [ BGR ] }
- { 8 [ BGR ] }
- { 4 [ BGR ] }
- { 1 [ BGR ] }
- [ unknown-component-order ]
- } case ;
-
-M: bitmap-image load-image* ( path bitmap-image -- bitmap )
- drop load-bitmap
- [ image new ] dip
- {
- [ loading-bitmap>bytes >>bitmap ]
- [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
- [ height>> 0 < not >>upside-down? ]
- [ compression>> 3 = [ t >>upside-down? ] when ]
- [ bitmap>component-order >>component-order ]
- } cleave ;
-
PRIVATE>
: bitmap>color-index ( bitmap -- byte-array )
binary [
B{ CHAR: B CHAR: M } write
[
- bitmap>color-index length 14 + 40 + write4
+ bitmap>> length 14 + 40 + write4
0 write4
54 write4
40 write4
! compression
[ drop 0 write4 ]
- ! size-image
- [ bitmap>color-index length write4 ]
+ ! image-size
+ [ bitmap>> length write4 ]
! x-pels
[ drop 0 write4 ]
[ drop 0 write4 ]
! color-palette
- [
- [ bitmap>color-index ]
- [ dim>> first 3 * ]
- [ dim>> first bitmap-padding + ] tri
- reverse-lines write
- ]
+ [ bitmap>> write ]
} cleave
] bi
] with-file-writer ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators images images.bitmap
+images.bitmap.private io io.binary io.encodings.8-bit
+io.encodings.binary io.encodings.string io.streams.limited
+kernel math math.bitwise grouping sequences ;
+QUALIFIED-WITH: syntax S
+IN: images.bitmap.loading
+
+! http://www.fileformat.info/format/bmp/egff.htm
+! http://www.digicamsoft.com/bmp/bmp.html
+
+ERROR: unknown-component-order bitmap ;
+ERROR: unknown-bitmap-header n ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+TUPLE: loading-bitmap
+ file-header header
+ color-palette color-index bitfields ;
+
+TUPLE: file-header
+ { magic initial: "BM" }
+ { size }
+ { reserved1 initial: 0 }
+ { reserved2 initial: 0 }
+ { offset }
+ { header-length } ;
+
+TUPLE: v3-header
+ { width initial: 0 }
+ { height initial: 0 }
+ { planes initial: 0 }
+ { bit-count initial: 0 }
+ { compression initial: 0 }
+ { image-size initial: 0 }
+ { x-resolution initial: 0 }
+ { y-resolution initial: 0 }
+ { colors-used initial: 0 }
+ { colors-important initial: 0 } ;
+
+TUPLE: v4-header < v3-header
+ { red-mask initial: 0 }
+ { green-mask initial: 0 }
+ { blue-mask initial: 0 }
+ { alpha-mask initial: 0 }
+ { cs-type initial: 0 }
+ { end-points initial: 0 }
+ { gamma-red initial: 0 }
+ { gamma-green initial: 0 }
+ { gamma-blue initial: 0 } ;
+
+TUPLE: v5-header < v4-header
+ { intent initial: 0 }
+ { profile-data initial: 0 }
+ { profile-size initial: 0 }
+ { reserved3 initial: 0 } ;
+
+TUPLE: os2v1-header
+ { width initial: 0 }
+ { height initial: 0 }
+ { planes initial: 0 }
+ { bit-count initial: 0 } ;
+
+TUPLE: os2v2-header < os2v1-header
+ { compression initial: 0 }
+ { image-size initial: 0 }
+ { x-resolution initial: 0 }
+ { y-resolution initial: 0 }
+ { colors-used initial: 0 }
+ { colors-important initial: 0 }
+ { units initial: 0 }
+ { reserved initial: 0 }
+ { recording initial: 0 }
+ { rendering initial: 0 }
+ { size1 initial: 0 }
+ { size2 initial: 0 }
+ { color-encoding initial: 0 }
+ { identifier initial: 0 } ;
+
+UNION: v-header v3-header v4-header v5-header ;
+UNION: os2-header os2v1-header os2v2-header ;
+
+: parse-file-header ( -- file-header )
+ \ file-header new
+ 2 read latin1 decode >>magic
+ read4 >>size
+ read2 >>reserved1
+ read2 >>reserved2
+ read4 >>offset
+ read4 >>header-length ;
+
+: read-v3-header-data ( header -- header )
+ read4 >>width
+ read4 32 >signed >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>image-size
+ read4 >>x-resolution
+ read4 >>y-resolution
+ read4 >>colors-used
+ read4 >>colors-important ;
+
+: read-v3-header ( -- header )
+ \ v3-header new
+ read-v3-header-data ;
+
+: read-v4-header-data ( header -- header )
+ read4 >>red-mask
+ read4 >>green-mask
+ read4 >>blue-mask
+ read4 >>alpha-mask
+ read4 >>cs-type
+ read4 read4 read4 3array >>end-points
+ read4 >>gamma-red
+ read4 >>gamma-green
+ read4 >>gamma-blue ;
+
+: read-v4-header ( -- v4-header )
+ \ v4-header new
+ read-v3-header-data
+ read-v4-header-data ;
+
+: read-v5-header-data ( v5-header -- v5-header )
+ read4 >>intent
+ read4 >>profile-data
+ read4 >>profile-size
+ read4 >>reserved3 ;
+
+: read-v5-header ( -- loading-bitmap )
+ \ v5-header new
+ read-v3-header-data
+ read-v4-header-data
+ read-v5-header-data ;
+
+: read-os2v1-header ( -- os2v1-header )
+ \ os2v1-header new
+ read2 >>width
+ read2 16 >signed >>height
+ read2 >>planes
+ read2 >>bit-count ;
+
+: read-os2v2-header-data ( os2v2-header -- os2v2-header )
+ read4 >>width
+ read4 32 >signed >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>image-size
+ read4 >>x-resolution
+ read4 >>y-resolution
+ read4 >>colors-used
+ read4 >>colors-important
+ read2 >>units
+ read2 >>reserved
+ read2 >>recording
+ read2 >>rendering
+ read4 >>size1
+ read4 >>size2
+ read4 >>color-encoding
+ read4 >>identifier ;
+
+: read-os2v2-header ( -- os2v2-header )
+ \ os2v2-header new
+ read-os2v2-header-data ;
+
+: parse-header ( n -- header )
+ {
+ { 12 [ read-os2v1-header ] }
+ { 64 [ read-os2v2-header ] }
+ { 40 [ read-v3-header ] }
+ { 108 [ read-v4-header ] }
+ { 124 [ read-v5-header ] }
+ [ unknown-bitmap-header ]
+ } case ;
+
+: parse-color-palette ( loading-bitmap -- loading-bitmap )
+ dup color-palette-length read >>color-palette ;
+
+GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
+
+: parse-color-data ( loading-bitmap -- loading-bitmap )
+ dup header>> parse-color-data* ;
+
+M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
+ color-index-length read >>color-index ;
+
+M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
+ dup image-size>> [ 0 ] unless* dup 0 >
+ [ nip ] [ drop color-index-length ] if read >>color-index ;
+
+: alpha-used? ( loading-bitmap -- ? )
+ color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
+
+GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
+
+: bitmap>component-order ( loading-bitmap -- object )
+ dup header>> bitmap>component-order* ;
+
+: simple-bitmap>component-order ( loading-bitamp -- object )
+ header>> bit-count>> {
+ { 32 [ BGRX ] }
+ { 24 [ BGR ] }
+ { 16 [ BGR ] }
+ { 8 [ BGR ] }
+ { 4 [ BGR ] }
+ { 1 [ BGR ] }
+ [ unknown-component-order ]
+ } case ;
+
+: advanced-bitmap>component-order ( loading-bitmap -- object )
+ [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
+ { { 32 t } [ drop BGRA ] }
+ { { 32 f } [ drop BGRX ] }
+ [ drop simple-bitmap>component-order ]
+ } case ;
+
+M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
+M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
+
+ERROR: unsupported-bitmap-file magic ;
+
+: load-bitmap ( path -- loading-bitmap )
+ binary stream-throws <limited-file-reader> [
+ \ loading-bitmap new
+ parse-file-header [ >>file-header ] [ ] bi magic>> {
+ { "BM" [
+ dup file-header>> header-length>> parse-header >>header
+ parse-color-palette
+ parse-color-data
+ ] }
+ ! { "BA" [ parse-os2-bitmap-array ] }
+ ! { "CI" [ parse-os2-color-icon ] }
+ ! { "CP" [ parse-os2-color-pointer ] }
+ ! { "IC" [ parse-os2-icon ] }
+ ! { "PT" [ parse-os2-pointer ] }
+ [ unsupported-bitmap-file ]
+ } case
+ ] with-input-stream ;
+
+M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+ drop load-bitmap
+ [ image new ] dip
+ {
+ [ loading-bitmap>bytes >>bitmap ]
+ [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
+ [ header>> height>> 0 < not >>upside-down? ]
+ [ bitmap>component-order >>component-order ]
+ } cleave ;
SINGLETON: png-image
"png" png-image register-image-class
-TUPLE: loading-png < image chunks
-width height bit-depth color-type compression-method
-filter-method interlace-method uncompressed ;
+TUPLE: loading-png
+ chunks
+ width height bit-depth color-type compression-method
+ filter-method interlace-method uncompressed ;
CONSTRUCTOR: loading-png ( -- image )
V{ } clone >>chunks ;
ERROR: bad-checksum ;
-: read-png-chunks ( image -- image )
+: read-png-chunks ( loading-png -- loading-png )
<png-chunk>
4 read be> [ >>length ] [ 4 + ] bi
read dup crc32 checksum-bytes
4 read = [ bad-checksum ] unless
4 cut-slice
- [ ascii decode >>type ]
- [ B{ } like >>data ] bi*
+ [ ascii decode >>type ] [ B{ } like >>data ] bi*
[ over chunks>> push ]
[ type>> ] bi "IEND" =
[ read-png-chunks ] unless ;
-: find-chunk ( image string -- chunk )
+: find-chunk ( loading-png string -- chunk )
[ chunks>> ] dip '[ type>> _ = ] find nip ;
-: parse-ihdr-chunk ( image -- image )
+: parse-ihdr-chunk ( loading-png -- loading-png )
dup "IHDR" find-chunk data>> {
[ [ 0 4 ] dip subseq be> >>width ]
[ [ 4 8 ] dip subseq be> >>height ]
[ [ 12 ] dip nth >>interlace-method ]
} cleave ;
-: find-compressed-bytes ( image -- bytes )
+: find-compressed-bytes ( loading-png -- bytes )
chunks>> [ type>> "IDAT" = ] filter
[ data>> ] map concat ;
-: fill-image-data ( image -- image )
- dup [ width>> ] [ height>> ] bi 2array >>dim ;
-: zlib-data ( png-image -- bytes )
+: zlib-data ( loading-png -- bytes )
chunks>> [ type>> "IDAT" = ] find nip data>> ;
ERROR: unknown-color-type n ;
ERROR: unimplemented-color-type image ;
-: inflate-data ( image -- bytes )
+: inflate-data ( loading-png -- bytes )
zlib-data zlib-inflate ;
-: decode-greyscale ( image -- image )
+: decode-greyscale ( loading-png -- loading-png )
unimplemented-color-type ;
-: decode-truecolor ( image -- image )
- {
- [ inflate-data ]
- [ dim>> first 3 * 1 + group reverse-png-filter ]
- [ swap >byte-array >>bitmap drop ]
- [ RGB >>component-order drop ]
- [ ]
+: png-image-bytes ( loading-png -- byte-array )
+ [ inflate-data ] [ width>> 3 * 1 + ] bi group
+ reverse-png-filter ;
+
+: decode-truecolor ( loading-png -- loading-png )
+ [ <image> ] dip {
+ [ png-image-bytes >>bitmap ]
+ [ [ width>> ] [ height>> ] bi 2array >>dim ]
+ [ drop RGB >>component-order ]
} cleave ;
-: decode-indexed-color ( image -- image )
+: decode-indexed-color ( loading-png -- loading-png )
unimplemented-color-type ;
-: decode-greyscale-alpha ( image -- image )
+: decode-greyscale-alpha ( loading-png -- loading-png )
unimplemented-color-type ;
-: decode-truecolor-alpha ( image -- image )
+: decode-truecolor-alpha ( loading-png -- loading-png )
unimplemented-color-type ;
-: decode-png ( image -- image )
+: decode-png ( loading-png -- loading-png )
dup color-type>> {
{ 0 [ decode-greyscale ] }
{ 2 [ decode-truecolor ] }
read-png-header
read-png-chunks
parse-ihdr-chunk
- fill-image-data
decode-png
] with-input-stream ;
'[
_ group
[ _ group unclip [ v+ ] accumulate swap suffix concat ] map
- concat >byte-array
+ B{ } concat-as
] change-bitmap ;
: strips-predictor ( ifd -- ifd )
} case ;
: ifd>image ( ifd -- image )
- {
- [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
- [ ifd-component-order f ]
- [ bitmap>> ]
- } cleave image boa ;
+ [ <image> ] dip {
+ [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
+ [ ifd-component-order >>component-order ]
+ [ bitmap>> >>bitmap ]
+ } cleave ;
: tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ;
<byte-array> glue ;
: inet6-bytes ( seq -- bytes )
- [ 2 >be ] { } map-as concat >byte-array ;
+ [ 2 >be ] { } map-as B{ } concat-as ;
PRIVATE>
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.vectors
+USING: arrays fry kernel math math.order math.vectors
sequences sequences.private accessors columns ;
IN: math.matrices
! Matrices
: zero-matrix ( m n -- matrix )
- [ nip 0 <array> ] curry map ;
+ '[ _ 0 <array> ] replicate ;
: identity-matrix ( n -- matrix )
#! Make a nxn identity matrix.
gram-schmidt [ normalize ] map ;
: cross-zip ( seq1 seq2 -- seq1xseq2 )
- [ [ 2array ] with map ] curry map ;
\ No newline at end of file
+ [ [ 2array ] with map ] curry map ;
[ dup 1 = [ next-power-of-2 ] unless ] map
] unless ;
-: (tex-image) ( image bitmap -- )
+: tex-image ( image bitmap -- )
[
[ GL_TEXTURE_2D 0 GL_RGBA ] dip
[ dim>> adjust-texture-dim first2 0 ]
] dip
glTexImage2D ;
-: (tex-sub-image) ( image -- )
+: tex-sub-image ( image -- )
[ GL_TEXTURE_2D 0 0 0 ] dip
- [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
+ [ dim>> first2 ]
+ [ component-order>> component-order>format ]
+ [ bitmap>> ] tri
glTexSubImage2D ;
: init-texture ( -- )
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
non-power-of-2-textures? get
- [ dup bitmap>> (tex-image) ]
- [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
+ [ dup bitmap>> tex-image ]
+ [ [ f tex-image ] [ tex-sub-image ] bi ] if
] do-attribs
] keep ;
+USING: combinators kernel math parser sequences splitting ;
IN: porter-stemmer
-USING: kernel math parser sequences combinators splitting ;
: consonant? ( i str -- ? )
2dup nth dup "aeiou" member? [
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.streams.string kernel math math.parser
-namespaces sequences splitting grouping strings ascii
-byte-arrays byte-vectors ;
+USING: arrays ascii byte-arrays byte-vectors grouping io
+io.encodings.binary io.files io.streams.string kernel math
+math.parser namespaces sequences splitting strings ;
IN: tools.hexdump
<PRIVATE
: hexdump ( byte-array -- str )
[ hexdump. ] with-string-writer ;
+
+: hexdump-file ( path -- )
+ binary file-contents hexdump. ;
[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test
+
+[ { } ]
+[ { 1 2 } { } [ + ] 2map ] unit-test
+
+[ { 11 } ]
+[ { 1 2 } { 10 } [ + ] 2map ] unit-test
+
+[ { 11 22 } ]
+[ { 1 2 } { 10 20 } [ + ] 2map ] unit-test
+
+[ { } ]
+[ { 1 2 } { } { } [ + + ] 3map ] unit-test
+
+[ { 111 } ]
+[ { 1 2 } { 10 } { 100 200 } [ + + ] 3map ] unit-test
+
+[ { 111 222 } ]
+[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math sequences sequences.private ;
+USING: accessors arrays generalizations kernel math sequences
+sequences.private ;
IN: cursors
GENERIC: cursor-done? ( cursor -- ? )
[ [ call ] dip cursor-write ] 2curry ; inline
: cursor-map ( from to quot -- )
- swap cursor-map-quot cursor-each ; inline
+ swap cursor-map-quot cursor-each ; inline
: cursor-write-if ( obj quot to -- )
[ over [ call ] dip ] dip
: map ( seq quot -- ) [ cursor-map ] transform ; inline
: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
+
+: find-done2? ( cursor cursor quot -- ? )
+ 2over [ cursor-done? ] either?
+ [ 3drop t ] [ [ [ cursor-get-unsafe ] bi@ ] dip call ] if ; inline
+
+: cursor-until2 ( cursor cursor quot -- )
+ [ find-done2? not ]
+ [ drop [ cursor-advance ] bi@ ] bi-curry bi-curry bi-curry while ; inline
+
+: cursor-each2 ( cursor cursor quot -- )
+ [ f ] compose cursor-until2 ; inline
+
+: cursor-map2 ( from to quot -- )
+ swap cursor-map-quot cursor-each2 ; inline
+
+: iterate2 ( seq1 seq2 quot iterator -- )
+ [ [ >input ] bi@ ] 2dip call ; inline
+
+: transform2 ( seq1 seq2 quot transformer -- newseq )
+ [ over >output [ [ >input ] [ >input ] bi* ] dip ] 2dip
+ [ call ]
+ [ 2drop nip freeze ] 4 nbi ; inline
+
+: 2each ( seq1 seq2 quot -- ) [ cursor-each2 ] iterate2 ; inline
+: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
+
+: find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
+ 3 nover 3array [ cursor-done? ] any?
+ [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
+
+: cursor-until3 ( cursor cursor quot -- )
+ [ find-done3? not ]
+ [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
+
+: cursor-each3 ( cursor cursor quot -- )
+ [ f ] compose cursor-until3 ; inline
+
+: cursor-map3 ( from to quot -- )
+ swap cursor-map-quot cursor-each3 ; inline
+
+: iterate3 ( seq1 seq2 seq3 quot iterator -- )
+ [ [ >input ] tri@ ] 2dip call ; inline
+
+: transform3 ( seq1 seq2 seq3 quot transformer -- newseq )
+ [ pick >output [ [ >input ] [ >input ] [ >input ] tri* ] dip ] 2dip
+ [ call ]
+ [ 2drop 2nip freeze ] 5 nbi ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- ) [ cursor-each3 ] iterate3 ; inline
+: 3map ( seq1 seq2 seq3 quot -- ) [ cursor-map3 ] transform3 ; inline
+++ /dev/null
-Kobi Lurie
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Kobi Lurie, Doug Coleman.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors fry images.loader\r
-images.processing.rotation kernel literals math sequences\r
-tools.test images.processing.rotation.private ;\r
-IN: images.processing.rotation.tests\r
-\r
-: first-row ( seq^2 -- seq ) first ;\r
-: first-col ( seq^2 -- item ) harvest [ first ] map ;\r
-: last-row ( seq^2 -- item ) last ;\r
-: last-col ( seq^2 -- item ) harvest [ last ] map ;\r
-: end-of-first-row ( seq^2 -- item ) first-row last ;\r
-: first-of-first-row ( seq^2 -- item ) first-row first ;\r
-: end-of-last-row ( seq^2 -- item ) last-row last ;\r
-: first-of-last-row ( seq^2 -- item ) last-row first ;\r
-\r
-<<\r
-\r
-: clone-image ( image -- new-image )\r
- clone [ clone ] change-bitmap ;\r
-\r
->>\r
-\r
-CONSTANT: pasted-image\r
- $[\r
- "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"\r
- load-image clone-image\r
- ]\r
-\r
-CONSTANT: pasted-image90\r
- $[\r
- "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"\r
- load-image clone-image\r
- ]\r
-\r
-CONSTANT: lake-image\r
- $[\r
- "vocab:images/processing/rotation/test-bitmaps/lake.bmp"\r
- load-image preprocess\r
- ]\r
-\r
-[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test\r
-[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test\r
-[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test\r
-[ t ] [\r
- pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each =\r
-] unit-test\r
-\r
-[ t ] [\r
- pasted-image 90 rotate\r
- pasted-image90 = \r
-] unit-test\r
-\r
-[ t ] [\r
- "vocab:images/processing/rotation/test-bitmaps/small.bmp"\r
- load-image 90 rotate \r
- "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"\r
- load-image =\r
-] unit-test\r
- \r
-[ t ] [\r
- lake-image\r
- [ first-of-first-row ]\r
- [ 90 (rotate) end-of-first-row ] bi =\r
-] unit-test\r
-\r
-[ t ]\r
-[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test\r
-\r
-[ t ]\r
-[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test\r
-\r
-[ t ]\r
-[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test\r
-\r
-[ t ]\r
-[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test\r
+++ /dev/null
-! Copyright (C) 2009 Kobi Lurie.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators
-combinators.short-circuit fry grouping images images.bitmap
-images.loader images.normalization kernel locals math sequences ;
-IN: images.processing.rotation
-
-ERROR: unsupported-rotation degrees ;
-
-<PRIVATE
-
-: rotate-90 ( seq^3 -- seq^3 ) flip [ reverse ] map ;
-: rotate-180 ( seq^3 -- seq^3 ) reverse [ reverse ] map ;
-: rotate-270 ( seq^3 -- seq^3 ) flip reverse ;
-
-: (rotate) ( seq n -- seq' )
- {
- { 0 [ ] }
- { 90 [ rotate-90 ] }
- { 180 [ rotate-180 ] }
- { 270 [ rotate-270 ] }
- [ unsupported-rotation ]
- } case ;
-
-: rows-remove-pad ( byte-rows -- pixels' )
- [ dup length 4 mod head* ] map ;
-
-: row-length ( image -- n )
- [ bitmap>> length ] [ dim>> second ] bi /i ;
-
-: image>byte-rows ( image -- byte-rows )
- [ bitmap>> ] [ row-length ] bi group rows-remove-pad ;
-
-: (seperate-to-pixels) ( byte-rows image -- pixel-rows )
- component-order>> bytes-per-pixel '[ _ group ] map ;
-
-: image>pixel-rows ( image -- pixel-rows )
- [ image>byte-rows ] keep (seperate-to-pixels) ;
-
-: flatten-table ( seq^3 -- seq )
- [ concat ] map concat ;
-
-: preprocess ( image -- pixelrows )
- normalize-image image>pixel-rows ;
-
-: ?reverse-dimensions ( image n -- )
- { 270 90 } member? [ [ reverse ] change-dim ] when drop ;
-
-: normalize-degree ( n -- n' ) 360 rem ;
-
-: processing-effect ( image quot -- image' )
- '[ preprocess @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
-
-:: rotate' ( image n -- image )
- n normalize-degree :> n'
- image preprocess :> pixel-table
- image n' ?reverse-dimensions
- pixel-table n' (rotate) :> table-rotated
- image table-rotated flatten-table >>bitmap ;
-
-PRIVATE>
-
-: rotate ( image n -- image' )
- normalize-degree
- [ '[ _ (rotate) ] processing-effect ] [ ?reverse-dimensions ] 2bi ;
-
-: reflect-y-axis ( image -- image )
- [ [ reverse ] map ] processing-effect ;
-
-: reflect-x-axis ( image -- image )
- [ reverse ] processing-effect ;
-USING: byte-arrays combinators fry images kernel locals math
+USING: accessors arrays byte-arrays combinators
+combinators.short-circuit fry hints images kernel locals math
math.affine-transforms math.functions math.order
-math.polynomials math.vectors random random.mersenne-twister
-sequences sequences.product hints arrays sequences.private
-combinators.short-circuit math.private ;
+math.polynomials math.private math.vectors random
+random.mersenne-twister sequences sequences.private
+sequences.product ;
IN: noise
: <perlin-noise-table> ( -- table )
[ 255.0 * >fixnum ] B{ } map-as ;
: >image ( bytes dim -- image )
- swap [ L f ] dip image boa ;
+ image new
+ swap >>dim
+ swap >>bitmap
+ L >>component-order ;
:: perlin-noise-unsafe ( table point -- value )
point unit-cube :> cube
[ "abcd e \\\"f g" ]
[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
-[ "" ]
+[ f ]
[ "" <sequence-parser> take-rest ] unit-test
-[ "" ]
+[ f ]
[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
[ f ]
: advance* ( sequence-parser -- )
advance drop ; inline
+: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
+
: get+increment ( sequence-parser -- char/f )
[ current ] [ advance drop ] bi ; inline
2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
: take-rest ( sequence-parser -- sequence )
- [ take-rest-slice ] [ sequence>> like ] bi ;
+ [ take-rest-slice ] [ sequence>> like ] bi f like ;
: take-until-object ( sequence-parser obj -- sequence )
'[ current _ = ] take-until ;
:: take-n ( sequence-parser n -- seq/f )
n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
- f
+ sequence-parser take-rest
] [
sequence-parser n>> dup n + sequence-parser sequence>> subseq
sequence-parser [ n + ] change-n drop
-USING: accessors arrays byte-arrays combinators fry grouping
-images kernel math math.affine-transforms math.order
-math.vectors noise random sequences ;
+USING: accessors arrays byte-arrays combinators
+combinators.smart fry grouping images kernel math
+math.affine-transforms math.order math.vectors noise random
+sequences ;
IN: terrain.generation
CONSTANT: terrain-segment-size { 512 512 }
TUPLE: segment image ;
+: <terrain-image> ( bytes -- image )
+ <image>
+ swap >>bitmap
+ RGBA >>component-order
+ terrain-segment-size >>dim ;
+
: terrain-segment ( terrain at -- image )
- {
- [ big-noise-segment ]
- [ small-noise-segment ]
- [ tiny-noise-segment ]
- [ padding ]
- } 2cleave
- 4array flip concat >byte-array
- [ terrain-segment-size RGBA f ] dip image boa ;
+ [
+ {
+ [ big-noise-segment ]
+ [ small-noise-segment ]
+ [ tiny-noise-segment ]
+ [ padding ]
+ } 2cleave
+ ] output>array flip B{ } concat-as <terrain-image> ;
: 4max ( a b c d -- max )
max max max ; inline
--- /dev/null
+Kobi Lurie
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Kobi Lurie, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors fry images.loader\r
+images.processing.rotation kernel literals math sequences\r
+tools.test images.processing.rotation.private ;\r
+IN: images.processing.rotation.tests\r
+\r
+: first-row ( seq^2 -- seq ) first ;\r
+: first-col ( seq^2 -- item ) harvest [ first ] map ;\r
+: last-row ( seq^2 -- item ) last ;\r
+: last-col ( seq^2 -- item ) harvest [ last ] map ;\r
+: end-of-first-row ( seq^2 -- item ) first-row last ;\r
+: first-of-first-row ( seq^2 -- item ) first-row first ;\r
+: end-of-last-row ( seq^2 -- item ) last-row last ;\r
+: first-of-last-row ( seq^2 -- item ) last-row first ;\r
+\r
+<<\r
+\r
+: clone-image ( image -- new-image )\r
+ clone [ clone ] change-bitmap ;\r
+\r
+>>\r
+\r
+: pasted-image ( -- image )\r
+ "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"\r
+ load-image clone-image ;\r
+\r
+: pasted-image90 ( -- image )\r
+ "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"\r
+ load-image clone-image ;\r
+\r
+: lake-image ( -- image )\r
+ "vocab:images/processing/rotation/test-bitmaps/lake.bmp"\r
+ load-image clone-image image>pixel-rows ;\r
+\r
+[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test\r
+[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test\r
+[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test\r
+[ t ] [\r
+ pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each =\r
+] unit-test\r
+\r
+[ t ] [\r
+ pasted-image 90 rotate\r
+ pasted-image90 = \r
+] unit-test\r
+\r
+[ t ] [\r
+ "vocab:images/processing/rotation/test-bitmaps/small.bmp"\r
+ load-image 90 rotate \r
+ "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"\r
+ load-image =\r
+] unit-test\r
+ \r
+[ t ] [\r
+ lake-image\r
+ [ first-of-first-row ]\r
+ [ 90 (rotate) end-of-first-row ] bi =\r
+] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test\r
+\r
+[ t ]\r
+[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test\r
--- /dev/null
+! Copyright (C) 2009 Kobi Lurie.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators
+combinators.short-circuit fry grouping images images.bitmap
+images.loader images.normalization kernel locals math sequences ;
+IN: images.processing.rotation
+
+ERROR: unsupported-rotation degrees ;
+
+<PRIVATE
+
+: rotate-90 ( seq^3 -- seq^3 ) flip [ reverse ] map ;
+: rotate-180 ( seq^3 -- seq^3 ) reverse [ reverse ] map ;
+: rotate-270 ( seq^3 -- seq^3 ) flip reverse ;
+
+: (rotate) ( seq n -- seq' )
+ {
+ { 0 [ ] }
+ { 90 [ rotate-90 ] }
+ { 180 [ rotate-180 ] }
+ { 270 [ rotate-270 ] }
+ [ unsupported-rotation ]
+ } case ;
+
+: rows-remove-pad ( byte-rows -- pixels' )
+ [ dup length 4 mod head* ] map ;
+
+: row-length ( image -- n )
+ [ bitmap>> length ] [ dim>> second ] bi /i ;
+
+: image>byte-rows ( image -- byte-rows )
+ [ bitmap>> ] [ row-length ] bi group rows-remove-pad ;
+
+: (seperate-to-pixels) ( byte-rows image -- pixel-rows )
+ component-order>> bytes-per-pixel '[ _ group ] map ;
+
+: image>pixel-rows ( image -- pixel-rows )
+ [ image>byte-rows ] keep (seperate-to-pixels) ;
+
+: flatten-table ( seq^3 -- seq )
+ [ concat ] map concat ;
+
+: ?reverse-dimensions ( image n -- )
+ { 270 90 } member? [ [ reverse ] change-dim ] when drop ;
+
+: normalize-degree ( n -- n' ) 360 rem ;
+
+: processing-effect ( image quot -- image' )
+ '[ image>pixel-rows @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
+
+:: rotate' ( image n -- image )
+ n normalize-degree :> n'
+ image image>pixel-rows :> pixel-table
+ image n' ?reverse-dimensions
+ pixel-table n' (rotate) :> table-rotated
+ image table-rotated flatten-table >>bitmap ;
+
+PRIVATE>
+
+: rotate ( image n -- image' )
+ normalize-degree
+ [ '[ _ (rotate) ] processing-effect ] [ ?reverse-dimensions ] 2bi ;
+
+: reflect-y-axis ( image -- image )
+ [ [ reverse ] map ] processing-effect ;
+
+: reflect-x-axis ( image -- image )
+ [ reverse ] processing-effect ;
projects / factor.git / commitdiff
