! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.accessors assocs byte-arrays combinators
-constructors destructors fry io io.binary io.encodings.binary
-io.streams.byte-array kernel locals macros math math.ranges
-multiline sequences sequences.private vectors byte-vectors
-combinators.short-circuit math.bitwise ;
+destructors fry io io.binary io.encodings.binary io.streams.byte-array
+kernel locals macros math math.ranges multiline sequences
+sequences.private vectors byte-vectors combinators.short-circuit
+math.bitwise ;
IN: bitstreams
TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
TUPLE: msb0-bit-reader < bit-reader ;
TUPLE: lsb0-bit-reader < bit-reader ;
-CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
-CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
+
+: <msb0-bit-reader> ( bytes -- bs )
+ msb0-bit-reader new swap >>bytes ; inline
+
+: <lsb0-bit-reader> ( bytes -- bs )
+ lsb0-bit-reader new swap >>bytes ; inline
TUPLE: msb0-bit-writer < bit-writer ;
TUPLE: lsb0-bit-writer < bit-writer ;
! Copyright (C) 2009 Marc Fauconneau.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays assocs constructors fry\r
+USING: accessors arrays assocs fry\r
hashtables io kernel locals math math.order math.parser\r
math.ranges multiline sequences ;\r
IN: compression.huffman\r
{ rtable }\r
{ bits/level } ;\r
\r
-CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )\r
+: <huffman-decoder> ( bs tdesc -- decoder )\r
+ huffman-decoder new\r
+ swap >>tdesc\r
+ swap >>bs\r
16 >>bits/level\r
[ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;\r
\r
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays
-byte-vectors combinators constructors fry grouping hashtables
+byte-vectors combinators fry grouping hashtables
compression.huffman images io.binary kernel locals
math math.bitwise math.order math.ranges multiline sequences
sorting ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit initializers math ;
-IN: constructors.tests
-
-TUPLE: stock-spread stock spread timestamp ;
-
-CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
- now >>timestamp ;
-
-SYMBOL: AAPL
-
-[ t ] [
- AAPL 1234 <stock-spread>
- {
- [ stock>> AAPL eq? ]
- [ spread>> 1234 = ]
- [ timestamp>> timestamp? ]
- } 1&&
-] unit-test
-
-TUPLE: ct1 a ;
-TUPLE: ct2 < ct1 b ;
-TUPLE: ct3 < ct2 c ;
-TUPLE: ct4 < ct3 d ;
-
-CONSTRUCTOR: ct1 ( a -- obj )
- [ 1 + ] change-a ;
-
-CONSTRUCTOR: ct2 ( a b -- obj )
- initialize-ct1
- [ 1 + ] change-a ;
-
-CONSTRUCTOR: ct3 ( a b c -- obj )
- initialize-ct1
- [ 1 + ] change-a ;
-
-CONSTRUCTOR: ct4 ( a b c d -- obj )
- initialize-ct3
- [ 1 + ] change-a ;
-
-[ 1001 ] [ 1000 <ct1> a>> ] unit-test
-[ 2 ] [ 0 0 <ct2> a>> ] unit-test
-[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
-[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
-
-
-TUPLE: rofl a b c ;
-CONSTRUCTOR: rofl ( b c a -- obj ) ;
-
-[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
-
-
-TUPLE: default { a integer initial: 0 } ;
-
-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
-
-
-TUPLE: inherit3 hp max-hp ;
-TUPLE: inherit4 < inherit3 ;
-TUPLE: inherit5 < inherit3 ;
-
-CONSTRUCTOR: inherit3 ( -- obj )
- dup max-hp>> >>hp ;
-
-BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
- 10 >>max-hp ;
-
-[ 10 ] [ <inherit4> hp>> ] unit-test
-
-FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
- 5 >>hp
- 10 >>max-hp ;
-
-[ 5 ] [ <inherit5> hp>> ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-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
-
-: initializer-name ( class -- word )
- name>> "initialize-" prepend ;
-
-: lookup-initializer ( class -- word/f )
- initializer-name "initializers" lookup ;
-
-: initializer-word ( class -- word )
- initializer-name
- "initializers" create-vocab create
- [ t "initializer" set-word-prop ] [ ] bi ;
-
-: define-initializer-generic ( name -- )
- initializer-word (( object -- object )) define-simple-generic ;
-
-: define-initializer ( class def -- )
- [ 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-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
- class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
- slots length
- default-params length
- '[
- _ narray slot-assoc swap zip
- default-params swap assoc-union values _ firstn class boa
- ] ;
-
-:: (define-constructor) ( constructor-word class effect def -- word quot )
- constructor-word
- class def define-initializer
- 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 reverse? -- )
- constructor-word class effect def (define-constructor)
- class superclasses [ lookup-initializer ] map sift
- reverse? [ reverse ] when
- '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
-
-: scan-constructor ( -- class word )
- scan-word [ name>> "<" ">" surround create-in ] keep ;
-
-: parse-constructor ( -- class word effect def )
- scan-constructor complete-effect parse-definition ;
-
-SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
-SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
-SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-
-"initializers" create-vocab drop
+++ /dev/null
-Utility to simplify tuple constructors
+++ /dev/null
-extensions
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
-constructors grouping compression.huffman images
+grouping compression.huffman images
images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
<PRIVATE
-CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
+: <jpeg-image> ( headers bitstream -- image )
+ jpeg-image new swap >>bitstream swap >>headers ;
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
APP JPG COM TEM RES ;
TUPLE: jpeg-chunk length type data ;
-CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
+: <jpeg-chunk> ( type length data -- jpeg-chunk )
+ jpeg-chunk new
+ swap >>data
+ swap >>length
+ swap >>type ;
TUPLE: jpeg-color-info
h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
-CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
+: <jpeg-color-info> ( h v quant-table -- jpeg-color-info )
+ jpeg-color-info new
+ swap >>quant-table
+ swap >>v
+ swap >>h ;
: jpeg> ( -- jpeg-image ) jpeg-image get ;
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: constructors kernel splitting unicode.case combinators
-accessors images io.pathnames namespaces assocs ;
+USING: kernel splitting unicode.case combinators accessors images
+io.pathnames namespaces assocs ;
IN: images.loader
ERROR: unknown-image-extension extension ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors constructors images io io.binary io.encodings.ascii
+USING: accessors images io io.binary io.encodings.ascii
io.encodings.binary io.encodings.string io.files io.files.info kernel
-sequences io.streams.limited fry combinators arrays math
-checksums checksums.crc32 compression.inflate grouping byte-arrays
-images.loader ;
+sequences io.streams.limited fry combinators arrays math checksums
+checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
IN: images.png
SINGLETON: png-image
width height bit-depth color-type compression-method
filter-method interlace-method uncompressed ;
-CONSTRUCTOR: loading-png ( -- image )
+: <loading-png> ( -- image )
+ loading-png new
V{ } clone >>chunks ;
TUPLE: png-chunk length type data ;
-CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
+: <png-chunk> ( -- png-chunk )
+ png-chunk new ; inline
CONSTANT: png-header
B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays classes combinators
-compression.lzw constructors endian fry grouping images io
+compression.lzw endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
SINGLETON: tiff-image
TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
-CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
+
+: <loading-tiff> ( -- tiff )
+ loading-tiff new V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next
processed-tags strips bitmap ;
-CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
+
+: <ifd> ( count ifd-entries next -- ifd )
+ ifd new
+ swap >>next
+ swap >>ifd-entries
+ swap >>count ;
TUPLE: ifd-entry tag type count offset/value ;
-CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
+
+: <ifd-entry> ( tag type count offset/value -- ifd-entry )
+ ifd-entry new
+ swap >>offset/value
+ swap >>count
+ swap >>type
+ swap >>tag ;
SINGLETONS: photometric-interpretation
photometric-interpretation-white-is-zero
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test constructors calendar kernel accessors
+combinators.short-circuit initializers math ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
+ now >>timestamp ;
+
+SYMBOL: AAPL
+
+[ t ] [
+ AAPL 1234 <stock-spread>
+ {
+ [ stock>> AAPL eq? ]
+ [ spread>> 1234 = ]
+ [ timestamp>> timestamp? ]
+ } 1&&
+] unit-test
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+CONSTRUCTOR: ct1 ( a -- obj )
+ [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct2 ( a b -- obj )
+ initialize-ct1
+ [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct3 ( a b c -- obj )
+ initialize-ct1
+ [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct4 ( a b c d -- obj )
+ initialize-ct3
+ [ 1 + ] change-a ;
+
+[ 1001 ] [ 1000 <ct1> a>> ] unit-test
+[ 2 ] [ 0 0 <ct2> a>> ] unit-test
+[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+
+
+TUPLE: rofl a b c ;
+CONSTRUCTOR: rofl ( b c a -- obj ) ;
+
+[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
+
+
+TUPLE: default { a integer initial: 0 } ;
+
+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
+
+
+TUPLE: inherit3 hp max-hp ;
+TUPLE: inherit4 < inherit3 ;
+TUPLE: inherit5 < inherit3 ;
+
+CONSTRUCTOR: inherit3 ( -- obj )
+ dup max-hp>> >>hp ;
+
+BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
+ 10 >>max-hp ;
+
+[ 10 ] [ <inherit4> hp>> ] unit-test
+
+FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
+ 5 >>hp
+ 10 >>max-hp ;
+
+[ 5 ] [ <inherit5> hp>> ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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
+
+: initializer-name ( class -- word )
+ name>> "initialize-" prepend ;
+
+: lookup-initializer ( class -- word/f )
+ initializer-name "initializers" lookup ;
+
+: initializer-word ( class -- word )
+ initializer-name
+ "initializers" create-vocab create
+ [ t "initializer" set-word-prop ] [ ] bi ;
+
+: define-initializer-generic ( name -- )
+ initializer-word (( object -- object )) define-simple-generic ;
+
+: define-initializer ( class def -- )
+ [ 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-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
+ class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
+ slots length
+ default-params length
+ '[
+ _ narray slot-assoc swap zip
+ default-params swap assoc-union values _ firstn class boa
+ ] ;
+
+:: (define-constructor) ( constructor-word class effect def -- word quot )
+ constructor-word
+ class def define-initializer
+ 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 reverse? -- )
+ constructor-word class effect def (define-constructor)
+ class superclasses [ lookup-initializer ] map sift
+ reverse? [ reverse ] when
+ '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
+
+: scan-constructor ( -- class word )
+ scan-word [ name>> "<" ">" surround create-in ] keep ;
+
+: parse-constructor ( -- class word effect def )
+ scan-constructor complete-effect parse-definition ;
+
+SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
+SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
+SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
+SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
+
+"initializers" create-vocab drop
--- /dev/null
+Utility to simplify tuple constructors
--- /dev/null
+extensions
projects / factor.git / commitdiff