} ;
HELP: convert-timezone
-{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
{ $examples
{ $example "USING: accessors calendar prettyprint ;"
} ;
HELP: >local-time
-{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"
} ;
HELP: >gmt
-{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $values { "timestamp" timestamp } { "timestamp'" timestamp } }
{ $description "Converts the " { $snippet "timestamp" } " to the GMT timezone." }
{ $examples
{ $example "USING: accessors calendar kernel prettyprint ;"
GENERIC: time- ( time1 time2 -- time3 )
-: convert-timezone ( timestamp duration -- timestamp )
+: convert-timezone ( timestamp duration -- timestamp' )
over gmt-offset>> over = [ drop ] [
[ over gmt-offset>> time- time+ ] keep >>gmt-offset
] if ;
-: >local-time ( timestamp -- timestamp )
+: >local-time ( timestamp -- timestamp' )
gmt-offset-duration convert-timezone ;
-: >gmt ( timestamp -- timestamp )
+: >gmt ( timestamp -- timestamp' )
instant convert-timezone ;
M: timestamp <=> ( ts1 ts2 -- n )
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data ascii
-assocs byte-arrays classes.struct classes.tuple.private
+assocs byte-arrays classes.struct classes.tuple.private classes.tuple
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
-tools.test parser lexer eval layouts ;
+tools.test parser lexer eval layouts generic.single classes ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
eval( -- value )
-] must-fail
+] [ error>> no-method? ] must-fail-with
! Subclassing a struct class should not be allowed
[
- "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
+ "USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
eval( -- )
-] must-fail
+] [ error>> bad-superclass? ] must-fail-with
+
+! Changing a superclass into a struct should reset the subclass
+TUPLE: will-become-struct ;
+
+TUPLE: a-subclass < will-become-struct ;
+
+[ f ] [ will-become-struct struct-class? ] unit-test
+
+[ will-become-struct ] [ a-subclass superclass ] unit-test
+
+[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
+
+[ t ] [ will-become-struct struct-class? ] unit-test
+
+[ tuple ] [ a-subclass superclass ] unit-test
! Remove c-type when struct class is forgotten
[ ] [
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
-M: struct-class valid-superclass? drop f ;
-
SLOT: fields
: struct-slots ( struct-class -- slots )
[ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
- [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
+ [ struct f define-tuple-class ] [ make-final ] bi ;
:: (define-struct-class) ( class slots offsets-quot -- )
slots empty? [ struct-must-have-slots ] when
+++ /dev/null
-unportable
! Copyright (C) 2005, 2006 Kevin Reid.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel namespaces cocoa cocoa.classes
-cocoa.subclassing debugger ;
+USING: alien.c-types assocs kernel namespaces cocoa
+cocoa.classes cocoa.runtime cocoa.subclassing debugger ;
IN: cocoa.callbacks
SYMBOL: callbacks
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
--- /dev/null
+USING: compiler.crossref fry kernel sequences tools.test vocabs words ;
+IN: compiler.crossref.tests
+
+! Dependencies of all words should always be satisfied unless we're
+! in the middle of recompiling something
+[ { } ] [
+ all-words dup [ subwords ] map concat append
+ H{ } clone '[ _ dependencies-satisfied? not ] filter
+] unit-test
--- /dev/null
+IN: compiler.tests.redefine22
+USING: kernel sequences compiler.units vocabs tools.test definitions ;
+
+TUPLE: ttt ;
+INSTANCE: ttt sequence
+M: ttt new-sequence 2drop ttt new ;
+
+: www-1 ( a -- b ) T{ ttt } new-sequence ;
+
+! This used to break with a compiler error in the above word
+[ ] [ [ \ ttt forget ] with-compilation-unit ] unit-test
--- /dev/null
+IN: compiler.tests.redefine23
+USING: classes.struct specialized-arrays alien.c-types sequences
+compiler.units vocabs tools.test ;
+
+STRUCT: my-struct { x int } ;
+SPECIALIZED-ARRAY: my-struct
+: my-word ( a -- b ) iota [ my-struct <struct-boa> ] my-struct-array{ } map-as ;
+
+[ ] [
+ [
+ "specialized-arrays.instances.compiler.tests.redefine23" forget-vocab
+ ] with-compilation-unit
+] unit-test
[ in-d>> #drop ]
bi prefix ;
-: record-predicate-folding ( #call -- )
- [ node-input-infos first class>> ]
+: >predicate-folding< ( #call -- value-info class result )
+ [ node-input-infos first ]
[ word>> "predicating" word-prop ]
- [ node-output-infos first literal>> ] tri
- [ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
+ [ node-output-infos first literal>> ] tri ;
+
+: record-predicate-folding ( #call -- )
+ >predicate-folding< pick literal?>>
+ [ [ literal>> ] 2dip depends-on-instance-predicate ]
+ [ [ class>> ] 2dip depends-on-class-predicate ]
+ if ;
: record-folding ( #call -- )
dup word>> predicate?
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
-classes.tuple.private kernel accessors math math.intervals namespaces
-sequences sequences.private words combinators memoize
-combinators.short-circuit byte-arrays strings arrays layouts
-cpu.architecture compiler.tree.propagation.copy ;
+classes.tuple.private classes.singleton kernel accessors math
+math.intervals namespaces sequences sequences.private words
+combinators memoize combinators.short-circuit byte-arrays
+strings arrays layouts cpu.architecture
+compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
UNION: fixed-length array byte-array string ;
+: literal-class ( obj -- class )
+ #! Handle forgotten tuples and singleton classes properly
+ dup singleton-class? [
+ class dup class? [
+ drop tuple
+ ] unless
+ ] unless ;
+
: init-literal-info ( info -- info )
empty-interval >>interval
- dup literal>> class >>class
+ dup literal>> literal-class >>class
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }
] final-info drop
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { hashtable } declare hashtable instance? ] final-classes
] unit-test
[ { assoc } declare hashtable instance? ] final-classes
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { string } declare string? ] final-classes
] unit-test
[ { fixnum } declare log2 ] final-classes
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { fixnum } declare log2 0 >= ] final-classes
] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators
recover ;
: predicate-output-infos/class ( info class -- info )
- [ class>> ] dip {
- { [ 2dup class<= ] [ t <literal-info> ] }
- { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
- [ object-info ]
- } cond 2nip ;
+ [ class>> ] dip compare-classes
+ dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
: predicate-output-infos ( info class -- info )
over literal?>>
HELP: lzw-read
{ $values
- { "lzw" lzw }
{ "lzw" lzw } { "n" integer }
}
{ $description "Read the next LZW code." } ;
HELP: reset-lzw-uncompress
{ $values
{ "lzw" lzw }
- { "lzw" lzw }
}
{ $description "Reset the LZW uncompressor state (either at initialization time or immediately after receiving a Clear Code). " } ;
mailbox-get\r
] unit-test\r
\r
-<mailbox> "m" set\r
-\r
-1 <count-down> "c" set\r
-1 <count-down> "d" set\r
-\r
-[\r
- "c" get await\r
- [ "m" get mailbox-get drop ]\r
- [ drop "d" get count-down ] recover\r
-] "Mailbox close test" spawn drop\r
-\r
-[ ] [ "c" get count-down ] unit-test\r
-[ ] [ "m" get dispose ] unit-test\r
-[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
-\r
-[ ] [ "m" get dispose ] unit-test\r
-\r
-<mailbox> "m" set\r
-\r
-1 <count-down> "c" set\r
-1 <count-down> "d" set\r
-\r
-[\r
- "c" get await\r
- "m" get wait-for-close\r
- "d" get count-down\r
-] "Mailbox close test" spawn drop\r
-\r
-[ ] [ "c" get count-down ] unit-test\r
-[ ] [ "m" get dispose ] unit-test\r
-[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
-\r
-[ ] [ "m" get dispose ] unit-test\r
-\r
[ { "foo" "bar" } ] [\r
<mailbox>\r
"foo" over mailbox-put\r
[\r
<mailbox> 1 seconds mailbox-get-timeout\r
] [ wait-timeout? ] must-fail-with\r
- \r
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: dlists deques threads sequences continuations\r
-destructors namespaces math quotations words kernel\r
-arrays assocs init system concurrency.conditions accessors\r
-debugger debugger.threads locals fry ;\r
+USING: dlists deques threads sequences continuations namespaces\r
+math quotations words kernel arrays assocs init system\r
+concurrency.conditions accessors debugger debugger.threads\r
+locals fry ;\r
IN: concurrency.mailboxes\r
\r
-TUPLE: mailbox < disposable threads data ;\r
-\r
-M: mailbox dispose* threads>> notify-all ;\r
+TUPLE: mailbox threads data ;\r
\r
: <mailbox> ( -- mailbox )\r
- mailbox new-disposable <dlist> >>threads <dlist> >>data ;\r
+ mailbox new\r
+ <dlist> >>threads\r
+ <dlist> >>data ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
data>> deque-empty? ;\r
[ threads>> ] dip "mailbox" wait ;\r
\r
:: block-unless-pred ( mailbox timeout pred: ( message -- ? ) -- )\r
- mailbox check-disposed\r
mailbox data>> pred dlist-any? [\r
mailbox timeout wait-for-mailbox\r
mailbox timeout pred block-unless-pred\r
] unless ; inline recursive\r
\r
: block-if-empty ( mailbox timeout -- mailbox )\r
- over check-disposed\r
over mailbox-empty? [\r
2dup wait-for-mailbox block-if-empty\r
] [\r
mailbox>> mailbox-empty? not ;\r
\r
ERROR: promise-already-fulfilled promise ;\r
+\r
: fulfill ( value promise -- )\r
dup promise-fulfilled? [ \r
promise-already-fulfilled\r
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
-unportable
compiler
+untested
-unportable
+untested
compiler
-unportable
+untested
compiler
+++ /dev/null
-unportable
-unportable
+untested
compiler
HELP: <select-by-slots-statement>
{ $values
{ "tuple" tuple } { "class" class }
- { "tuple" tuple } }
+ { "statement" tuple } }
{ $description "A database-specific hook for generating the SQL for a select statement." } ;
HELP: <update-tuple-statement>
{ $list
"Make a new tuple to represent your data"
{ "Map the Factor types to the database types with " { $link define-persistent } }
- { "Make a custom database combinator (see" { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
+ { "Make a custom database combinator (see " { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
{ "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } }
{ "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } }
} ;
HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
HOOK: <update-tuple-statement> db-connection ( class -- object )
HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
-HOOK: <select-by-slots-statement> db-connection ( tuple class -- tuple )
+HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
HOOK: <count-statement> db-connection ( query -- statement )
HOOK: query>statement db-connection ( query -- statement )
HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
drop "Not a tuple" ;
M: bad-superclass summary
- drop "Tuple classes can only inherit from other tuple classes" ;
+ drop "Tuple classes can only inherit from non-final tuple classes" ;
M: no-initial-value summary
drop "Initial value must be provided for slots specialized to this class" ;
+++ /dev/null
-unportable
} ;
HELP: dlist-filter
-{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist'" { $link dlist } } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
{ $side-effects { "dlist" } } ;
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
-: dlist-filter ( dlist quot -- dlist )
+: dlist-filter ( dlist quot -- dlist' )
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
M: dlist clone
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
USING: accessors arrays assocs generic.standard kernel
lexer locals.types namespaces parser quotations vocabs.parser
-words ;
+words classes.tuple ;
IN: functors.backend
DEFER: functor-words
: define* ( word def -- ) over set-word define ;
-: define-declared* ( word def effect -- ) pick set-word define-declared ;
+: define-declared* ( word def effect -- )
+ pick set-word define-declared ;
-: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+: define-simple-generic* ( word effect -- )
+ over set-word define-simple-generic ;
+: define-tuple-class* ( class superclass slots -- )
+ pick set-word define-tuple-class ;
-USING: classes.struct functors tools.test math words kernel
-multiline parser io.streams.string generic ;
+USING: classes.struct classes.tuple functors tools.test math
+words kernel multiline parser io.streams.string generic ;
QUALIFIED-WITH: alien.c-types c
IN: functors.tests
WHERE
-: WW ( a -- b ) \ W twice ; inline
+: WW ( a -- b ) \ W twice ;
;FUNCTOR
}
] [ a-struct struct-slots ] unit-test
+<<
+
+FUNCTOR: define-an-inline-word ( W -- )
+
+W DEFINES ${W}
+W-W DEFINES ${W}-${W}
+
+WHERE
+
+: W ( -- ) ; inline
+: W-W ( -- ) W W ;
+
+;FUNCTOR
+
+"an-inline-word" define-an-inline-word
+
+>>
+
+[ t ] [ \ an-inline-word inline? ] unit-test
+[ f ] [ \ an-inline-word-an-inline-word inline? ] unit-test
+
+<<
+
+FUNCTOR: define-a-final-class ( T W -- )
+
+T DEFINES-CLASS ${T}
+W DEFINES ${W}
+
+WHERE
+
+TUPLE: T ; final
+
+: W ( -- ) ;
+
+;FUNCTOR
+
+"a-final-tuple" "a-word" define-a-final-class
+
+>>
+
+[ t ] [ a-final-tuple final-class? ] unit-test
make suffix!
]
} case
- \ define-tuple-class suffix! ;
+ \ define-tuple-class* suffix! ;
+
+FUNCTOR-SYNTAX: final
+ [ word make-final ] append! ;
FUNCTOR-SYNTAX: SINGLETON:
scan-param suffix!
{
{ [ os windows? ] [ "game.input.xinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] }
- { [ os linux? ] [ "game.input.x11" require ] }
- { [ t ] [ ] }
+ { [ os linux? ] [ "game.input.linux" require ] }
+ [ ]
} cond
--- /dev/null
+Erik Charlebois
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax arrays kernel game.input namespaces
+classes bit-arrays sequences vectors x11 x11.xlib ;
+IN: game.input.linux
+
+SINGLETON: linux-game-input-backend
+
+linux-game-input-backend game-input-backend set-global
+
+M: linux-game-input-backend (open-game-input)
+ ;
+
+M: linux-game-input-backend (close-game-input)
+ ;
+
+M: linux-game-input-backend (reset-game-input)
+ ;
+
+M: linux-game-input-backend get-controllers
+ { } ;
+
+M: linux-game-input-backend product-string
+ drop "" ;
+
+M: linux-game-input-backend product-id
+ drop f ;
+
+M: linux-game-input-backend instance-id
+ drop f ;
+
+M: linux-game-input-backend read-controller
+ drop controller-state new ;
+
+M: linux-game-input-backend calibrate-controller
+ drop ;
+
+M: linux-game-input-backend vibrate-controller
+ 3drop ;
+
+CONSTANT: x>hid-bit-order {
+ 0 0 0 0 0 0 0 0
+ 0 41 30 31 32 33 34 35
+ 36 37 38 39 45 46 42 43
+ 20 26 8 21 23 28 24 12
+ 18 19 47 48 40 224 4 22
+ 7 9 10 11 13 14 15 51
+ 52 53 225 49 29 27 6 25
+ 5 17 16 54 55 56 229 85
+ 226 44 57 58 59 60 61 62
+ 63 64 65 66 67 83 71 95
+ 96 97 86 92 93 94 87 91
+ 90 89 99 0 0 0 68 69
+ 0 0 0 0 0 0 0 88
+ 228 84 70 0 0 74 82 75
+ 80 79 77 81 78 73 76 127
+ 129 128 102 103 0 72 0 0
+ 0 0 227 231 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0
+}
+
+: x-bits>hid-bits ( bit-array -- bit-array )
+ 256 iota [ 2array ] 2map [ first ] filter [ second ] map
+ x>hid-bit-order [ nth ] with map
+ ?{ } swap [ t swap pick set-nth ] each ;
+
+M: linux-game-input-backend read-keyboard
+ dpy get 256 <bit-array> [ XQueryKeymap drop ] keep
+ x-bits>hid-bits keyboard-state boa ;
+
+M: linux-game-input-backend read-mouse
+ 0 0 0 0 2 <vector> mouse-state boa ;
+
+M: linux-game-input-backend reset-mouse
+ ;
--- /dev/null
+Linux backend for game input.
+++ /dev/null
-USING: alien.c-types alien.syntax arrays bit-arrays game.input
-kernel namespaces sequences x11 x11.xlib ;
-IN: game.input.x11
-
-SINGLETON: x11-game-input-backend
-
-x11-game-input-backend game-input-backend set-global
-
-LIBRARY: xlib
-FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ;
-
-CONSTANT: x>hid-bit-order {
- 0 0 0 0 0 0 0 0
- 0 41 30 31 32 33 34 35
- 36 37 38 39 45 46 42 43
- 20 26 8 21 23 28 24 12
- 18 19 47 48 40 224 4 22
- 7 9 10 11 13 14 15 51
- 52 53 225 49 29 27 6 25
- 5 17 16 54 55 56 229 85
- 226 44 57 58 59 60 61 62
- 63 64 65 66 67 83 71 95
- 96 97 86 92 93 94 87 91
- 90 89 99 0 0 0 68 69
- 0 0 0 0 0 0 0 88
- 228 84 70 0 0 74 82 75
- 80 79 77 81 78 73 76 127
- 129 128 102 103 0 72 0 0
- 0 0 227 231 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0
-}
-
-M: x11-game-input-backend (open-game-input) ; ! assume X was already started for now
-M: x11-game-input-backend (close-game-input) ; ! let someone else stop X
-M: x11-game-input-backend (reset-game-input) ; ! nothing to reset at this point
-
-! No controller support yet--if this works, I shouldn't even need to define the other methods
-M: x11-game-input-backend get-controllers f ;
-
-
-: x-bits>hid-bits ( bit-array -- bit-array )
- 256 iota [ 2array ] 2map [ first ] filter [ second ] map
- x>hid-bit-order [ nth ] with map
- ?{ } swap [ t swap pick set-nth ] each ;
-
-M: x11-game-input-backend read-keyboard
- dpy get 256 <bit-array> [ XQueryKeymap drop ] keep
- x-bits>hid-bits keyboard-state boa ;
-
-M: x11-game-input-backend read-mouse
- 0 0 0 0 ?{ f f f } mouse-state boa ;
-
-M: x11-game-input-backend reset-mouse ;
\ No newline at end of file
: extract-values ( element -- seq )
\ $values swap elements dup empty? [
- first rest [ first ] map prune
+ first rest [ first ] map
] unless ;
: effect-values ( word -- seq )
"Examples" $heading print-element ;
: $example ( element -- )
- 1 cut* swap "\n" join dup <input> [
- input-style get format nl print-element
+ 1 cut* [ "\n" join ] bi@ over <input> [
+ [ print ] [ output-style get format ] bi*
] ($code) ;
: $unchecked-example ( element -- )
{ wrap-margin f }
} code-style set-global
-SYMBOL: input-style
-H{ { font-style bold } } input-style set-global
+SYMBOL: output-style
+H{
+ { font-style bold }
+ { foreground COLOR: DarkOrange4 }
+} output-style set-global
SYMBOL: url-style
H{
HELP: normalize-image
{ $values
{ "image" image }
- { "image" image }
+ { "image'" image }
}
{ $description "Converts the image to RGBA with ubyte-components. If the image is upside-down, it will be flipped right side up such that the 1st byte in the bitmap slot's byte array corresponds to the first color component of the pixel in the upper-left corner of the image." } ;
HELP: reorder-components
{ $values
{ "image" image } { "component-order" component-order }
- { "image" image }
+ { "image'" image }
}
{ $description "Convert the bitmap in " { $snippet "image" } " such that the pixel sample layout corresponds to " { $snippet "component-order" } ". If the destination layout cannot find a corresponding value from the source layout, the value " { $snippet "255" } " will be substituted for that byte." }
{ $warning "The image's " { $snippet "component-type" } " will be changed to " { $snippet "ubyte-components" } " if it is not already in that format."
M: ubyte-components normalize-component-type*
drop ;
-: normalize-scan-line-order ( image -- image )
+: normalize-scan-line-order ( image -- image' )
dup upside-down?>> [
dup dim>> first 4 * '[
_ <groups> reverse concat
PRIVATE>
-: reorder-components ( image component-order -- image )
+: reorder-components ( image component-order -- image' )
[
dup component-type>> '[ _ normalize-component-type* ] change-bitmap
dup component-order>>
] dip
validate-request [ (reorder-components) ] keep >>component-order ;
-: normalize-image ( image -- image )
+: normalize-image ( image -- image' )
[ >byte-array ] change-bitmap
RGBA reorder-components
normalize-scan-line-order ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel bit-arrays sequences assocs unix
-math namespaces accessors math.order locals unix.time fry
-io.ports io.backend.unix io.backend.unix.multiplexers ;
+USING: alien.c-types kernel bit-arrays sequences assocs math
+namespaces accessors math.order locals fry io.ports
+io.backend.unix io.backend.unix.multiplexers unix unix.ffi
+unix.time ;
IN: io.backend.unix.multiplexers.select
TUPLE: select-mx < mx read-fdset write-fdset ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable\r
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
[ inotify>> handle>> handle-fd ] [ wd>> ] bi
inotify_rm_watch io-error
] if
- ] bi ;
+ ]
+ [ call-next-method ]
+ tri ;
: ignore-flags? ( mask -- ? )
{
+++ /dev/null
-unportable
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.monitors
core-foundation.fsevents continuations kernel sequences
dup [ enqueue-notifications ] curry
path 1array 0 0 <event-stream> >>handle ;
-M: macosx-monitor dispose* handle>> dispose ;
+M: macosx-monitor dispose*
+ [ handle>> dispose ] [ call-next-method ] bi ;
macosx set-io-backend
+++ /dev/null
-unportable
continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint destructors io.timeouts
io.files.temp io.directories io.directories.hierarchy
-io.pathnames accessors ;
+io.pathnames accessors concurrency.promises ;
os { winnt linux macosx } member? [
[
[ [ t ] [ "m" get next-change drop ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
] with-monitors
+
+ ! Disposing a monitor should throw an error in any threads
+ ! waiting on notifications
+ [
+ [ ] [
+ <promise> "p" set
+ "monitor-test" temp-file t <monitor> "m" set
+ 10 seconds "m" get set-timeout
+ ] unit-test
+
+ [
+ [ "m" get next-change ] [ ] recover
+ "p" get fulfill
+ ] in-thread
+
+ [ ] [ 1 seconds sleep ] unit-test
+ [ ] [ "m" get dispose ] unit-test
+ [ t ] [ "p" get 10 seconds ?promise-timeout already-disposed? ] unit-test
+ ] with-monitors
] when
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend kernel continuations destructors namespaces
sequences assocs hashtables sorting arrays threads boxes
M: monitor set-timeout (>>timeout) ;
+<PRIVATE
+
+SYMBOL: monitor-disposed
+
+PRIVATE>
+
+M: monitor dispose*
+ [ monitor-disposed ] dip queue>> mailbox-put ;
+
: new-monitor ( path mailbox class -- monitor )
new-disposable
swap >>queue
TUPLE: file-change path changed monitor ;
: queue-change ( path changes monitor -- )
- 3dup and and
- [ [ file-change boa ] keep queue>> mailbox-put ] [ 3drop ] if ;
+ 3dup and and [
+ [ check-disposed ] keep
+ [ file-change boa ] keep
+ queue>> mailbox-put
+ ] [ 3drop ] if ;
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
<mailbox> (monitor) ;
: next-change ( monitor -- change )
- [ queue>> ] [ timeout ] bi mailbox-get-timeout ;
+ [ check-disposed ]
+ [
+ [ ] [ queue>> ] [ timeout ] tri mailbox-get-timeout
+ dup monitor-disposed eq? [ drop already-disposed ] [ nip ] if
+ ] bi ;
SYMBOL: +add-file+
SYMBOL: +remove-file+
: remove-child-monitor ( monitor -- )
monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
+SYMBOL: +stop+
+
M: recursive-monitor dispose*
- [ "stop" swap thread>> send-synchronous drop ]
- [ queue>> dispose ]
- bi ;
+ [ [ +stop+ ] dip thread>> send ] [ call-next-method ] bi ;
: stop-pump ( -- )
monitor tget children>> values dispose-each ;
: pump-step ( msg -- )
- [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
- monitor tget queue-change ;
+ monitor tget disposed>> [ drop ] [
+ [ [ monitor>> path>> ] [ path>> ] bi append-path ] [ changed>> ] bi
+ monitor tget queue-change
+ ] if ;
: child-added ( path monitor -- )
path>> prepend-path add-child-monitor ;
] with with each ;
: pump-loop ( -- )
- receive dup synchronous? [
- [ stop-pump t ] dip reply-synchronous
+ receive dup +stop+ eq? [
+ drop stop-pump
] [
[ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
pump-loop
] with-destructors ;
M: win32-monitor dispose
- port>> dispose ;
+ [ port>> dispose ] [ call-next-method ] bi ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
-USING: help.markup help.syntax kernel io system prettyprint continuations quotations ;
+USING: help.markup help.syntax kernel io system prettyprint
+continuations quotations vocabs.loader parser ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
-"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
+"The listener prints values of dynamic variables which are added to a watch list:"
{ $subsections visible-vars }
"To add or remove a single variable:"
{ $subsections
show-vars
hide-vars
}
-"Hiding all visible variables:"
+"Clearing the watch list:"
{ $subsections hide-all-vars } ;
HELP: only-use-vocabs
{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
-"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
+"The listener evaluates Factor expressions read from the input stream. Typically, you write Factor code in a text editor, load it from the listener by calling " { $link require } ", " { $link reload } " or " { $link run-file } ", and then test it from interactively."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
+"New words can also be defined in the listener:"
+{ $example
+ "USE: math.functions"
+ ": twice ( word -- ) [ execute ] [ execute ] bi ; inline"
+ "81 \\ sqrt twice ."
+ "3.0"
+}
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
-"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
+"The listener will display the current contents of the datastack after every line of input."
$nl
-"The listener will display the current contents of the datastack after every expression is evaluated. The listener can additionally watch dynamic variables:"
+"The listener can watch dynamic variables:"
{ $subsections "listener-watch" }
-"To start a nested listener:"
+"Nested listeners can be useful for testing code in other dynamic scopes. For example, when doing database maintanance using the " { $vocab-link "db.tuples" } " vocabulary, it can be useful to start a listener with a database connection:"
+{ $code
+ "USING: db db.sqlite listener ;"
+ "\"data.db\" <sqlite-db> [ listener ] with-db"
+}
+"Starting a nested listener:"
{ $subsections listener }
"To exit a listener, invoke the " { $link return } " word."
$nl
-"Multi-line quotations can be read independently of the rest of the listener:"
+"The listener's mechanism for reading multi-line expressions from the input stream can be called from user code:"
{ $subsections read-quot } ;
ABOUT: "listener"
{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "list" "the resulting list" } { "result" "a list" } }
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "result" "a list" } }
{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
{ $examples
{ $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
HELP: bitroll-32
{ $values
- { "n" integer } { "s" integer }
- { "n'" integer }
+ { "m" integer } { "s" integer }
+ { "n" integer }
}
-{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
+{ $description "Rolls the number " { $snippet "m" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
{ $examples
{ $example "USING: math.bitwise prettyprint ;"
"HEX: 1 10 bitroll-32 .h"
HELP: bitroll-64
{ $values
- { "n" integer } { "s" "a shift integer" }
- { "n'" integer }
+ { "m" integer } { "s" "a shift integer" }
+ { "n" integer }
}
-{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
+{ $description "Rolls the number " { $snippet "m" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
{ $examples
{ $example "USING: math.bitwise prettyprint ;"
"HEX: 1 10 bitroll-64 .h"
HELP: on-bits
{ $values
- { "n" integer }
{ "m" integer }
+ { "n" integer }
}
-{ $description "Returns an integer with " { $snippet "n" } " bits set." }
+{ $description "Returns an integer with " { $snippet "m" } " bits set." }
{ $examples
{ $example "USING: math.bitwise kernel prettyprint ;"
"6 on-bits .h"
HELP: shift-mod
{ $values
- { "n" integer } { "s" integer } { "w" integer }
+ { "m" integer } { "s" integer } { "w" integer }
{ "n" integer }
}
{ $description "Calls " { $link shift } " on " { $snippet "n" } " and " { $snippet "s" } ", wrapping the result to " { $snippet "w" } " bits." } ;
HELP: w*
{ $values
- { "int" integer } { "int" integer }
- { "int" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Multiplies two integers and wraps the result to 32 bits." }
{ $examples
HELP: w+
{ $values
- { "int" integer } { "int" integer }
- { "int" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Adds two integers and wraps the result to 32 bits." }
{ $examples
HELP: w-
{ $values
- { "int" integer } { "int" integer }
- { "int" integer }
+ { "x" integer } { "y" integer }
+ { "z" integer }
}
{ $description "Subtracts two integers and wraps the result to 32 bits." }
{ $examples
: wrap ( m n -- m' ) 1 - bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 2^ mask ; inline
-: on-bits ( n -- m ) 2^ 1 - ; inline
+: on-bits ( m -- n ) 2^ 1 - ; inline
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
-
-: shift-mod ( n s w -- n )
- [ shift ] dip 2^ wrap ; inline
+: >signed ( x n -- y ) 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
+: >odd ( m -- n ) 0 set-bit ; foldable
+: >even ( m -- n ) 0 clear-bit ; foldable
+: next-even ( m -- n ) >even 2 + ; foldable
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
+: shift-mod ( m s w -- n ) [ shift ] dip 2^ wrap ; inline
: bitroll ( x s w -- y )
[ wrap ] keep
[ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
-: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
+: bitroll-32 ( m s -- n ) 32 bitroll ; inline
-: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
+: bitroll-64 ( m s -- n ) 64 bitroll ; inline
! 32-bit arithmetic
-: w+ ( int int -- int ) + 32 bits ; inline
-: w- ( int int -- int ) - 32 bits ; inline
-: w* ( int int -- int ) * 32 bits ; inline
+: w+ ( x y -- z ) + 32 bits ; inline
+: w- ( x y -- z ) - 32 bits ; inline
+: w* ( x y -- z ) * 32 bits ; inline
! 64-bit arithmetic
-: W+ ( int int -- int ) + 64 bits ; inline
-: W- ( int int -- int ) - 64 bits ; inline
-: W* ( int int -- int ) * 64 bits ; inline
+: W+ ( x y -- z ) + 64 bits ; inline
+: W- ( x y -- z ) - 64 bits ; inline
+: W* ( x y -- z ) * 64 bits ; inline
! flags
MACRO: flags ( values -- )
[ >c-ptr ] [ byte-length ] bi <direct-uchar-array>
byte-array-bit-count ;
-: >signed ( x n -- y )
- 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
-
-: >odd ( n -- int ) 0 set-bit ; foldable
-
-: >even ( n -- int ) 0 clear-bit ; foldable
-
-: next-even ( m -- n ) >even 2 + ; foldable
-
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable
-
: even-parity? ( obj -- ? ) bit-count even? ;
: odd-parity? ( obj -- ? ) bit-count odd? ;
} ;
HELP: permutation
-{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
+{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq'" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1 -" } "." }
{ $examples
} ;
HELP: all-permutations
-{ $values { "seq" sequence } { "seq" sequence } }
+{ $values { "seq" sequence } { "seq'" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
} ;
HELP: combination
-{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
+{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq'" sequence } }
{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
{ $examples
} ;
HELP: all-combinations
-{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
+{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq'" sequence } }
{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
PRIVATE>
-: permutation ( n seq -- seq )
+: permutation ( n seq -- seq' )
[ permutation-indices ] keep nths ;
-: all-permutations ( seq -- seq )
+: all-permutations ( seq -- seq' )
[ length factorial iota ] keep
'[ _ permutation ] map ;
: map>assoc-combinations ( seq k quot exemplar -- )
[ combinations-quot ] dip map>assoc ; inline
-: combination ( m seq k -- seq )
+: combination ( m seq k -- seq' )
<combo> apply-combination ;
-: all-combinations ( seq k -- seq )
+: all-combinations ( seq k -- seq' )
[ ] combinations-quot map ;
: reduce-combinations ( seq k identity quot -- result )
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 } { 0 1 0 } p= ." "t" } } ;
HELP: ptrim
-{ $values { "p" "a polynomial" } { "p" "a polynomial" } }
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } }
{ $description "Trims excess zeros from a polynomial." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } ptrim ." "{ 0 1 }" } } ;
HELP: 2ptrim
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p'" "a polynomial" } { "q'" "a polynomial" } }
{ $description "Trims excess zeros from two polynomials." }
{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim [ . ] bi@" "{ 0 1 }\n{ 1 }" } } ;
{ $examples { $example "USING: math.polynomials prettyprint ;" "4 { 3 0 1 } n*p ." "{ 12 0 4 }" } } ;
HELP: pextend-conv
-{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
+{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p'" "a polynomial" } { "q'" "a polynomial" } }
{ $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." }
{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ;
: p= ( p q -- ? ) pextend = ;
-: ptrim ( p -- p )
+: ptrim ( p -- q )
dup length 1 = [ [ zero? ] trim-tail ] unless ;
-: 2ptrim ( p q -- p q ) [ ptrim ] bi@ ;
+: 2ptrim ( p q -- p' q' ) [ ptrim ] bi@ ;
: p+ ( p q -- r ) pextend v+ ;
: p- ( p q -- r ) pextend v- ;
: n*p ( n p -- n*p ) n*v ;
-: pextend-conv ( p q -- p q )
+: pextend-conv ( p q -- p' q' )
2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 0 0 1 } { 0 0 1 0 } q/ ." "{ 0 1 0 0 }" } } ;
HELP: q*n
-{ $values { "q" "a quaternion" } { "n" real } { "q" "a quaternion" } }
+{ $values { "q" "a quaternion" } { "n" real } { "r" "a quaternion" } }
{ $description "Multiplies each element of " { $snippet "q" } " by real value " { $snippet "n" } "." }
{ $notes "To multiply a quaternion with a complex value, use " { $link c>q } " " { $link q* } "." } ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2010 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel locals math math.functions
math.libm math.order math.vectors sequences ;
: q/ ( u v -- u/v )
qrecip q* ; inline
-: n*q ( q n -- q )
+: n*q ( q n -- r )
v*n ; inline
-: q*n ( q n -- q )
+: q*n ( q n -- r )
v*n ; inline
: n>q ( n -- q )
HELP: histogram!
{ $values
{ "hashtable" hashtable } { "seq" sequence }
- { "hashtable" hashtable }
}
{ $examples
{ $example "! Count the number of times the elements of two sequences appear."
HELP: sequence>assoc!
{ $values
{ "assoc" assoc } { "seq" sequence } { "quot" quotation }
- { "assoc" assoc }
}
{ $examples
{ $example "! Iterate over a sequence and add the counts to an existing assoc"
WHERE
-TUPLE: A < simd-128 ;
+TUPLE: A < simd-128 ; final
M: A new-underlying drop \ A boa ; inline
M: A simd-rep drop A-rep ; inline
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
HELP: gl-shader-info-log
-{ $values { "shader" "A " { $link gl-shader } " object" } { "shader" "a new " { $link gl-shader } } { "log" string } }
+{ $values { "shader" "A " { $link gl-shader } " object" } { "log" string } }
{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
HELP: gl-program
USING: help.markup help.syntax io kernel
-prettyprint.sections words ;
+prettyprint.sections words quotations ;
IN: prettyprint.config
ABOUT: "prettyprint-variables"
HELP: c-object-pointers?
{ $var-description "Toggles whether C objects such as structs and direct arrays only print their underlying address. If this flag isn't set, C objects will attempt to print their contents. If a C object points to invalid memory, it will display only its address regardless." } ;
+
+HELP: with-short-limits
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation in a new dynamic scope with prettyprinter limits set to produce a single line of output." } ;
+
+HELP: without-limits
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation in a new dynamic scope with prettyprinter limits set to produce unlimited output." } ;
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs io kernel math
-namespaces sequences strings vectors words
-continuations ;
+USING: kernel namespaces ;
IN: prettyprint.config
! Configuration
4 tab-size set-global
64 margin set-global
+15 nesting-limit set-global
+100 length-limit set-global
10 number-base set-global
+string-limit? on
+
+: with-short-limits ( quot -- )
+ [
+ 1 line-limit set
+ 15 length-limit set
+ 2 nesting-limit set
+ string-limit? on
+ boa-tuples? on
+ c-object-pointers? on
+ call
+ ] with-scope ; inline
+
+: without-limits ( quot -- )
+ [
+ nesting-limit off
+ length-limit off
+ line-limit off
+ string-limit? off
+ c-object-pointers? off
+ call
+ ] with-scope ; inline
boa-tuples?
c-object-pointers?
}
-"Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables."
-{
- $warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope."
- $nl
- "Some of the globals are safe to change, like the tab size and wrap margin. However setting limits globally could break code which uses the prettyprinter as a serialization mechanism."
-} ;
+"The default limits are meant to strike a balance between readability, and not producing too much output when large structures are given. There are two combinators that override the defaults:"
+{ $subsections with-short-limits without-limits }
+"That the " { $link short. } " and " { $link pprint-short } " words wrap calls to " { $link . } " and " { $link pprint } " in " { $link with-short-limits } ". Code that uses the prettyprinter for serialization should use " { $link without-limits } " to avoid producing unreadable output." ;
ARTICLE: "prettyprint-limitations" "Prettyprinter limitations"
"When using the prettyprinter as a serialization mechanism, keep the following points in mind:"
] [
[ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split
] unit-test
+
+TUPLE: final-tuple ; final
+
+[
+ {
+ "IN: prettyprint.tests"
+ "TUPLE: final-tuple ; final"
+ ""
+ }
+] [
+ [ \ final-tuple see ] with-string-writer "\n" split
+] unit-test
: unparse-use ( obj -- str ) [ pprint-use ] with-string-writer ;
: pprint-short ( obj -- )
- H{
- { line-limit 1 }
- { length-limit 15 }
- { nesting-limit 2 }
- { string-limit? t }
- { boa-tuples? t }
- } clone [ pprint ] bind ;
+ [ pprint ] with-short-limits ;
: unparse-short ( obj -- str )
[ pprint-short ] with-string-writer ;
HELP: randomize
{ $values
{ "seq" sequence }
- { "seq" sequence }
+ { "randomized" sequence }
}
{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
[ [ random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
-: randomize ( seq -- seq )
+: randomize ( seq -- randomized )
dup length randomize-n-last ;
ERROR: too-many-samples seq n ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
{ >roman >ROMAN roman> } related-words
HELP: roman+
-{ $values { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } }
{ $description "Adds two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman-
-{ $values { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } }
{ $description "Subtracts two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
{ roman+ roman- } related-words
HELP: roman*
-{ $values { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } }
{ $description "Multiplies two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman/i
-{ $values { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } }
{ $description "Computes the integer division of two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
} ;
HELP: roman/mod
-{ $values { "x" string } { "x" string } { "x" string } { "x" string } }
+{ $values { "x" string } { "y" string } { "z" string } { "w" string } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
{ $examples
{ $example "USING: kernel io roman ;"
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs effects fry generalizations
grouping kernel lexer macros math math.order math.vectors
-namespaces parser quotations sequences sequences.private
-splitting.monotonic stack-checker strings unicode.case words ;
+namespaces parser effects.parser quotations sequences
+sequences.private splitting.monotonic stack-checker strings
+unicode.case words ;
IN: roman
<PRIVATE
SYNTAX: ROMAN-OP:
scan-word [ name>> "roman" prepend create-in ] keep
1quotation '[ _ binary-roman-op ]
- dup infer define-declared ;
+ complete-effect define-declared ;
>>
-ROMAN-OP: +
-ROMAN-OP: -
-ROMAN-OP: *
-ROMAN-OP: /i
-ROMAN-OP: /mod
+ROMAN-OP: + ( x y -- z )
+ROMAN-OP: - ( x y -- z )
+ROMAN-OP: * ( x y -- z )
+ROMAN-OP: /i ( x y -- z )
+ROMAN-OP: /mod ( x y -- z w )
SYNTAX: ROMAN: scan roman> suffix! ;
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate classes.singleton
dup length 1 = [ first ] when
pprint-slot-name ;
+: tuple-declarations. ( class -- )
+ \ final declaration. ;
+
+: superclass. ( class -- )
+ superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
- dup pprint-word
- dup superclass tuple eq? [
- "<" text dup superclass pprint-word
- ] unless
- <block "slots" word-prop [ pprint-slot ] each block>
- pprint-; block> ;
+ {
+ [ pprint-word ]
+ [ superclass. ]
+ [ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
+ [ tuple-declarations. ]
+ } cleave
+ block> ;
M: word see-class* drop ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting binary-search fry math
math.order arrays classes combinators kernel functors math.functions
MIXIN: cord
TUPLE: generic-cord
- { head read-only } { tail read-only } ;
+ { head read-only } { tail read-only } ; final
INSTANCE: generic-cord cord
M: cord length
WHERE
TUPLE: T-cord
- { head T read-only } { tail T read-only } ;
+ { head T read-only } { tail T read-only } ; final
INSTANCE: T-cord cord
M: T cord-append
{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ;
HELP: deep-map!
-{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "obj" object } }
+{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } }
{ $description "Modifies each sub-node of an object in place, in preorder, and returns that object." }
{ $see-also map! } ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.parser
assocs byte-arrays classes compiler.units functors kernel lexer
M: bad-byte-array-length summary
drop "Byte array length doesn't divide type width" ;
+ERROR: not-a-byte-array alien ;
+
+M: not-a-byte-array summary
+ drop "Not a byte array" ;
+
: (underlying) ( n c-type -- array )
heap-size * (byte-array) ; inline
TUPLE: A
{ underlying c-ptr read-only }
-{ length array-capacity read-only } ;
+{ length array-capacity read-only } ; final
: <direct-A> ( alien len -- specialized-array ) A boa ; inline
[ \ T heap-size calloc ] keep <direct-A> ; inline
: byte-array>A ( byte-array -- specialized-array )
- >c-ptr dup length \ T heap-size /mod 0 =
- [ drop \ T bad-byte-array-length ] unless
- <direct-A> ; inline
+ >c-ptr dup byte-array? [
+ dup length \ T heap-size /mod 0 =
+ [ <direct-A> ]
+ [ drop \ T bad-byte-array-length ] if
+ ] [ not-a-byte-array ] if ; inline
M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors classes.algebra fry generic kernel math
-namespaces sequences words sets combinators.short-circuit ;
+USING: assocs accessors classes classes.algebra fry generic
+kernel math namespaces sequences words sets
+combinators.short-circuit classes.tuple ;
FROM: classes.tuple.private => tuple-layout ;
+FROM: assocs => change-at ;
IN: stack-checker.dependencies
! Words that the current quotation depends on
boa conditional-dependencies get
dup [ conjoin ] [ 2drop ] if ; inline
-TUPLE: depends-on-class<= class1 class2 ;
+TUPLE: depends-on-class-predicate class1 class2 result ;
-: depends-on-class<= ( class1 class2 -- )
- \ depends-on-class<= add-conditional-dependency ;
+: depends-on-class-predicate ( class1 class2 result -- )
+ \ depends-on-class-predicate add-conditional-dependency ;
-M: depends-on-class<= satisfied?
+M: depends-on-class-predicate satisfied?
{
- [ class1>> classoid? ]
- [ class2>> classoid? ]
- [ [ class1>> ] [ class2>> ] bi class<= ]
+ [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ]
+ [ [ [ class1>> ] [ class2>> ] bi compare-classes ] [ result>> ] bi eq? ]
} 1&& ;
-TUPLE: depends-on-classes-disjoint class1 class2 ;
+TUPLE: depends-on-instance-predicate object class result ;
-: depends-on-classes-disjoint ( class1 class2 -- )
- \ depends-on-classes-disjoint add-conditional-dependency ;
+: depends-on-instance-predicate ( object class result -- )
+ \ depends-on-instance-predicate add-conditional-dependency ;
-M: depends-on-classes-disjoint satisfied?
+M: depends-on-instance-predicate satisfied?
{
- [ class1>> classoid? ]
- [ class2>> classoid? ]
- [ [ class1>> ] [ class2>> ] bi classes-intersect? not ]
+ [ class>> classoid? ]
+ [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
} 1&& ;
TUPLE: depends-on-next-method class generic next-method ;
M: depends-on-flushable satisfied?
word>> flushable? ;
+TUPLE: depends-on-final class ;
+
+: depends-on-final ( word -- )
+ [ depends-on-conditionally ]
+ [ \ depends-on-final add-conditional-dependency ] bi ;
+
+M: depends-on-final satisfied?
+ class>> final-class? ;
+
: init-dependencies ( -- )
H{ } clone dependencies set
H{ } clone generic-dependencies set
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
: defs-to-crossref ( -- seq )
[
- all-words
+ all-words [ generic? not ] filter
all-articles [ >link ] map
source-files get keys [ <pathname> ] map
] append-outputs ;
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
: copy-resources ( manifest name dir -- )
append-path swap vocabs>> [ copy-vocab-resources ] with each ;
-ERROR: cant-deploy-library-file library ;
-<PRIVATE
+ERROR: can't-deploy-library-file library ;
+
: copy-library ( dir library -- )
dup find-library-file
- [ nip swap over file-name append-path copy-file ]
- [ cant-deploy-library-file ] if* ;
-PRIVATE>
+ [ swap over file-name append-path copy-file ]
+ [ can't-deploy-library-file ] ?if ;
: copy-libraries ( manifest name dir -- )
append-path swap libraries>> [ copy-library ] with each ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io.pathnames kernel parser prettyprint sequences
-splitting tools.deploy.config vocabs.loader vocabs.metadata ;
+USING: assocs io.pathnames kernel parser prettyprint
+prettyprint.config sequences splitting tools.deploy.config
+vocabs.loader vocabs.metadata ;
IN: tools.deploy.config.editor
: deploy-config-path ( vocab -- string )
parse-fresh [ first assoc-union ] unless-empty ;
: set-deploy-config ( assoc vocab -- )
- [ unparse-use string-lines ] dip
+ [ [ unparse-use ] without-limits string-lines ] dip
dup deploy-config-path set-vocab-file-contents ;
: set-deploy-flag ( value key vocab -- )
-USING: tools.test system io io.encodings.ascii io.pathnames\r
-io.files io.files.info io.files.temp kernel tools.deploy.config\r
-tools.deploy.config.editor tools.deploy.backend math sequences\r
-io.launcher arrays namespaces continuations layouts accessors\r
-urls math.parser io.directories tools.deploy.test ;\r
-IN: tools.deploy.tests\r
-\r
-[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
-\r
-[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
-\r
-[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
-\r
-[ "staging.math-threads-compiler-ui.image" ] [\r
- "hello-ui" deploy-config\r
- [ bootstrap-profile staging-image-name file-name ] bind\r
-] unit-test\r
-\r
-[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
-\r
-[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
-\r
-[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
-\r
-[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test\r
-\r
-[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test\r
-\r
-[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
-\r
-[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test\r
-\r
-os macosx? [\r
- [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
-] when\r
-\r
-[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test\r
-\r
-{\r
- "tools.deploy.test.1"\r
- "tools.deploy.test.2"\r
- "tools.deploy.test.3"\r
- "tools.deploy.test.4"\r
-} [\r
- [ ] swap [\r
- shake-and-bake\r
- run-temp-image\r
- ] curry unit-test\r
-] each\r
-\r
-USING: http.client http.server http.server.dispatchers\r
-http.server.responses http.server.static io.servers.connection ;\r
-\r
-SINGLETON: quit-responder\r
-\r
-M: quit-responder call-responder*\r
- 2drop stop-this-server "Goodbye" "text/html" <content> ;\r
-\r
-: add-quot-responder ( responder -- responder )\r
- quit-responder "quit" add-responder ;\r
-\r
-: test-httpd ( responder -- )\r
- [\r
- main-responder set\r
- <http-server>\r
- 0 >>insecure\r
- f >>secure\r
- dup start-server*\r
- sockets>> first addr>> port>>\r
- dup number>string "resource:temp/port-number" ascii set-file-contents\r
- ] with-scope\r
- "port" set ;\r
-\r
-[ ] [\r
- <dispatcher>\r
- add-quot-responder\r
- "vocab:http/test" <static> >>default\r
-\r
- test-httpd\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.5" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-: add-port ( url -- url' )\r
- >url clone "port" get >>port ;\r
-\r
-[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test\r
-\r
-{\r
- "tools.deploy.test.6"\r
- "tools.deploy.test.7"\r
- "tools.deploy.test.9"\r
- "tools.deploy.test.10"\r
- "tools.deploy.test.11"\r
- "tools.deploy.test.12"\r
-} [\r
- [ ] swap [\r
- shake-and-bake\r
- run-temp-image\r
- ] curry unit-test\r
-] each\r
-\r
-os windows? os macosx? or [\r
- [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test\r
-] when\r
-\r
-os macosx? [\r
- [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test\r
-] when\r
-\r
-[ { "a" "b" "c" } ] [\r
- "tools.deploy.test.15" shake-and-bake deploy-test-command\r
- { "a" "b" "c" } append\r
- ascii [ lines ] with-process-reader\r
- rest\r
-] unit-test\r
-\r
-[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test\r
-\r
-[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test\r
-\r
-[ t ] [\r
- "tools.deploy.test.18" shake-and-bake\r
- deploy-test-command ascii [ readln ] with-process-reader\r
- "test.image" temp-file =\r
-] unit-test\r
+USING: tools.test system io io.encodings.ascii io.pathnames
+io.files io.files.info io.files.temp kernel tools.deploy.config
+tools.deploy.config.editor tools.deploy.backend math sequences
+io.launcher arrays namespaces continuations layouts accessors
+urls math.parser io.directories tools.deploy.test ;
+IN: tools.deploy.tests
+
+[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
+
+[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
+
+[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
+
+[ "staging.math-threads-compiler-ui.image" ] [
+ "hello-ui" deploy-config
+ [ bootstrap-profile staging-image-name file-name ] bind
+] unit-test
+
+[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
+
+[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test
+
+[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test
+
+[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
+
+[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test
+
+os macosx? [
+ [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test
+] when
+
+[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test
+
+{
+ "tools.deploy.test.1"
+ "tools.deploy.test.2"
+ "tools.deploy.test.3"
+ "tools.deploy.test.4"
+} [
+ [ ] swap [
+ shake-and-bake
+ run-temp-image
+ ] curry unit-test
+] each
+
+USING: http.client http.server http.server.dispatchers
+http.server.responses http.server.static io.servers.connection ;
+
+SINGLETON: quit-responder
+
+M: quit-responder call-responder*
+ 2drop stop-this-server "Goodbye" "text/html" <content> ;
+
+: add-quot-responder ( responder -- responder )
+ quit-responder "quit" add-responder ;
+
+: test-httpd ( responder -- )
+ [
+ main-responder set
+ <http-server>
+ 0 >>insecure
+ f >>secure
+ dup start-server*
+ sockets>> first addr>> port>>
+ dup number>string "resource:temp/port-number" ascii set-file-contents
+ ] with-scope
+ "port" set ;
+
+[ ] [
+ <dispatcher>
+ add-quot-responder
+ "vocab:http/test" <static> >>default
+
+ test-httpd
+] unit-test
+
+[ ] [
+ "tools.deploy.test.5" shake-and-bake
+ run-temp-image
+] unit-test
+
+: add-port ( url -- url' )
+ >url clone "port" get >>port ;
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
+
+{
+ "tools.deploy.test.6"
+ "tools.deploy.test.7"
+ "tools.deploy.test.9"
+ "tools.deploy.test.10"
+ "tools.deploy.test.11"
+ "tools.deploy.test.12"
+} [
+ [ ] swap [
+ shake-and-bake
+ run-temp-image
+ ] curry unit-test
+] each
+
+os windows? os macosx? or [
+ [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
+] when
+
+os macosx? [
+ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test
+] when
+
+[ { "a" "b" "c" } ] [
+ "tools.deploy.test.15" shake-and-bake deploy-test-command
+ { "a" "b" "c" } append
+ ascii [ lines ] with-process-reader
+ rest
+] unit-test
+
+[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
+
+[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test
+
+[ t ] [
+ "tools.deploy.test.18" shake-and-bake
+ deploy-test-command ascii [ readln ] with-process-reader
+ "test.image" temp-file =
+] unit-test
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
-USING: accessors alien alien.c-types arrays classes.struct combinators\r
-io.backend kernel locals math sequences specialized-arrays\r
-tools.deploy.windows windows.kernel32 windows.types ;\r
-IN: tools.deploy.windows.ico\r
-\r
-<PRIVATE\r
-\r
-STRUCT: ico-header\r
- { Reserved WORD }\r
- { Type WORD }\r
- { ImageCount WORD } ;\r
-\r
-STRUCT: ico-directory-entry\r
- { Width BYTE }\r
- { Height BYTE }\r
- { Colors BYTE }\r
- { Reserved BYTE }\r
- { Planes WORD }\r
- { BitsPerPixel WORD }\r
- { ImageSize DWORD }\r
- { ImageOffset DWORD } ;\r
-SPECIALIZED-ARRAY: ico-directory-entry\r
-\r
-STRUCT: group-directory-entry\r
- { Width BYTE }\r
- { Height BYTE }\r
- { Colors BYTE }\r
- { Reserved BYTE }\r
- { Planes WORD }\r
- { BitsPerPixel WORD }\r
- { ImageSize DWORD }\r
- { ImageResourceID WORD } ;\r
-\r
-: ico>group-directory-entry ( ico i -- group )\r
- [ {\r
- [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]\r
- [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]\r
- } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline\r
-\r
-: ico-icon ( directory-entry bytes -- subbytes )\r
- [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline\r
-\r
-:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )\r
- bytes ico-header memory>struct :> header\r
-\r
- ico-header heap-size bytes <displaced-alien> \r
- header ImageCount>> <direct-ico-directory-entry-array> :> directory\r
-\r
- directory dup length iota [ ico>group-directory-entry ] { } 2map-as\r
- :> group-directory\r
- directory [ bytes ico-icon ] { } map-as :> icon-bytes\r
-\r
- header clone >c-ptr group-directory concat append\r
- icon-bytes ; inline\r
-\r
-PRIVATE>\r
-\r
-:: embed-icon-resource ( exe ico-bytes id -- )\r
- exe normalize-path 1 BeginUpdateResource :> hUpdate\r
- hUpdate [\r
- ico-bytes ico-group-and-icons :> ( group icons )\r
- hUpdate RT_GROUP_ICON id 0 group dup byte-length\r
- UpdateResource drop\r
-\r
- icons [| icon i |\r
- hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length\r
- UpdateResource drop\r
- ] each-index\r
-\r
- hUpdate 0 EndUpdateResource drop\r
- ] when ;\r
-\r
+USING: accessors alien alien.c-types arrays classes.struct combinators
+io.backend kernel locals math sequences specialized-arrays
+tools.deploy.windows windows.kernel32 windows.types ;
+IN: tools.deploy.windows.ico
+
+<PRIVATE
+
+STRUCT: ico-header
+ { Reserved WORD }
+ { Type WORD }
+ { ImageCount WORD } ;
+
+STRUCT: ico-directory-entry
+ { Width BYTE }
+ { Height BYTE }
+ { Colors BYTE }
+ { Reserved BYTE }
+ { Planes WORD }
+ { BitsPerPixel WORD }
+ { ImageSize DWORD }
+ { ImageOffset DWORD } ;
+SPECIALIZED-ARRAY: ico-directory-entry
+
+STRUCT: group-directory-entry
+ { Width BYTE }
+ { Height BYTE }
+ { Colors BYTE }
+ { Reserved BYTE }
+ { Planes WORD }
+ { BitsPerPixel WORD }
+ { ImageSize DWORD }
+ { ImageResourceID WORD } ;
+
+: ico>group-directory-entry ( ico i -- group )
+ [ {
+ [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
+ [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
+ } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
+
+: ico-icon ( directory-entry bytes -- subbytes )
+ [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
+
+:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
+ bytes ico-header memory>struct :> header
+
+ ico-header heap-size bytes <displaced-alien>
+ header ImageCount>> <direct-ico-directory-entry-array> :> directory
+
+ directory dup length iota [ ico>group-directory-entry ] { } 2map-as
+ :> group-directory
+ directory [ bytes ico-icon ] { } map-as :> icon-bytes
+
+ header clone >c-ptr group-directory concat append
+ icon-bytes ; inline
+
+PRIVATE>
+
+:: embed-icon-resource ( exe ico-bytes id -- )
+ exe normalize-path 1 BeginUpdateResource :> hUpdate
+ hUpdate [
+ ico-bytes ico-group-and-icons :> ( group icons )
+ hUpdate RT_GROUP_ICON id 0 group dup byte-length
+ UpdateResource drop
+
+ icons [| icon i |
+ hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
+ UpdateResource drop
+ ] each-index
+
+ hUpdate 0 EndUpdateResource drop
+ ] when ;
+
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! See http://factorcode.org/license.txt for BSD license.
USING: assocs io.files io.pathnames io.directories
io.encodings.utf8 hashtables kernel namespaces sequences
-vocabs.loader io combinators calendar accessors math.parser
-io.streams.string ui.tools.operations quotations strings arrays
-prettyprint words vocabs sorting sets classes math alien urls
-splitting ascii combinators.short-circuit alarms words.symbol
-system summary ;
+vocabs.loader vocabs.metadata io combinators calendar accessors
+math.parser io.streams.string ui.tools.operations quotations
+strings arrays prettyprint words vocabs sorting sets classes
+math alien urls splitting ascii combinators.short-circuit alarms
+words.symbol system summary ;
IN: tools.scaffold
SYMBOL: developer-name
ERROR: not-a-vocab-root string ;
ERROR: vocab-name-contains-separator path ;
ERROR: vocab-name-contains-dot path ;
-ERROR: no-vocab vocab ;
ERROR: bad-developer-name name ;
M: bad-developer-name summary
: check-root ( string -- string )
dup vocab-root? [ not-a-vocab-root ] unless ;
-: check-vocab ( vocab -- vocab )
- dup find-vocab-root [ no-vocab ] unless ;
-
: check-vocab-root/vocab ( vocab-root string -- vocab-root string )
[ check-root ] [ check-vocab-name ] bi* ;
+++ /dev/null
-unportable
HELP: TUPLE-ARRAY:
{ $syntax "TUPLE-ARRAY: class" }
+{ $values { "class" "a final tuple class" } }
{ $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ;
ARTICLE: "tuple-arrays" "Tuple arrays"
-"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
+"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of references to heap-allocated objects, a tuple array stores its elements as values."
$nl
-"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "."
+"Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
+$nl
+"Since value semantics are incompatible with inheritance, the base type of a tuple array must be declared " { $link POSTPONE: final } ". A best practice that is not enforced is to have all slots in the tuple declared " { $link read-only } "."
+$nl
+"Tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
$nl
-"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
{ $subsections POSTPONE: TUPLE-ARRAY: }
"An example:"
{ $example
"USE: tuple-arrays"
"IN: scratchpad"
- "TUPLE: point x y ;"
+ "TUPLE: point x y ; final"
"TUPLE-ARRAY: point"
"{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short."
"T{ point f 1 2 }"
USING: tuple-arrays sequences tools.test namespaces kernel
-math accessors ;
+math accessors classes.tuple eval ;
IN: tuple-arrays.tests
SYMBOL: mat
-TUPLE: foo bar ;
+TUPLE: foo bar ; final
C: <foo> foo
TUPLE-ARRAY: foo
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
-TUPLE: baz { bing integer } bong ;
+TUPLE: baz { bing integer } bong ; final
TUPLE-ARRAY: baz
[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
[ f ] [ 1 <baz-array> first bong>> ] unit-test
-TUPLE: broken x ;
+TUPLE: broken x ; final
: broken ( -- ) ;
TUPLE-ARRAY: broken
-[ 100 ] [ 100 <broken-array> length ] unit-test
\ No newline at end of file
+[ 100 ] [ 100 <broken-array> length ] unit-test
+
+! Can't define a tuple array for a non-tuple class
+[ "IN: tuple-arrays.tests USING: tuple-arrays words ; TUPLE-ARRAY: word" eval( -- ) ]
+[ error>> not-a-tuple? ]
+must-fail-with
+
+! Can't define a tuple array for a non-final class
+TUPLE: non-final x ;
+
+[ "IN: tuple-arrays.tests USE: tuple-arrays TUPLE-ARRAY: non-final" eval( -- ) ]
+[ error>> not-final? ]
+must-fail-with
\ No newline at end of file
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators.smart fry functors kernel
kernel.private macros sequences combinators sequences.private
-stack-checker parser math classes.tuple.private ;
+stack-checker parser math classes.tuple classes.tuple.private ;
FROM: inverse => undo ;
IN: tuple-arrays
+ERROR: not-final class ;
+
<PRIVATE
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
[ tuple-arity iota <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
+: check-final ( class -- )
+ {
+ { [ dup tuple-class? not ] [ not-a-tuple ] }
+ { [ dup final-class? not ] [ not-final ] }
+ [ drop ]
+ } cond ;
+
PRIVATE>
FUNCTOR: define-tuple-array ( CLASS -- )
WHERE
+CLASS check-final
+
TUPLE: CLASS-array
{ seq array read-only }
{ n array-capacity read-only }
ARTICLE: "typed" "Strongly-typed word definitions"
"The Factor compiler supports advanced compiler optimizations that take advantage of the type information it can glean from source code. The " { $vocab-link "typed" } " vocabulary provides syntax that allows words to provide checked type information about their inputs and outputs and improve the performance of compiled code."
+$nl
+"Parameters and return values of typed words where the type is declared to be a " { $link POSTPONE: final } " tuple class with all slots " { $link read-only } " are passed by value."
{ $subsections
POSTPONE: TYPED:
POSTPONE: TYPED::
+}
+"Defining typed words at run time:"
+{ $subsections
define-typed
+}
+"Errors:"
+{ $subsections
input-mismatch-error
output-mismatch-error
} ;
most-positive-fixnum neg 1 - 1quotation
[ most-positive-fixnum 1 fix+ ] unit-test
-TUPLE: tweedle-dee ;
-TUPLE: tweedle-dum ;
+TUPLE: tweedle-dee ; final
+TUPLE: tweedle-dum ; final
TYPED: dee ( x: tweedle-dee -- y )
drop \ tweedle-dee ;
TUPLE: unboxable
{ x fixnum read-only }
- { y fixnum read-only } ;
+ { y fixnum read-only } ; final
TUPLE: unboxable2
{ u unboxable read-only }
- { xy fixnum read-only } ;
+ { xy fixnum read-only } ; final
TYPED: unboxy ( in: unboxable -- out: unboxable2 )
dup [ x>> ] [ y>> ] bi - unboxable2 boa ;
TUPLE: unboxable
{ x fixnum read-only }
{ y fixnum read-only }
- { z float read-only } ;
+ { z float read-only } ; final
""" eval( -- )
"""
[ 1 ] [ no-inputs ] unit-test
TUPLE: unboxable3
- { x read-only } ;
+ { x read-only } ; final
TYPED: no-inputs-unboxable-output ( -- out: unboxable3 )
T{ unboxable3 } ;
[ T{ unboxable3 } ] [ no-inputs-unboxable-output ] unit-test
+[ f ] [ no-inputs-unboxable-output no-inputs-unboxable-output eq? ] unit-test
+
SYMBOL: buh
TYPED: no-outputs ( x: integer -- )
buh set ;
[ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
+
+[ f ] [
+ T{ unboxable3 } no-outputs-unboxable-input buh get
+ T{ unboxable3 } no-outputs-unboxable-input buh get
+ eq?
+] unit-test
+
+! Reported by littledan
+TUPLE: superclass { x read-only } ;
+TUPLE: subclass < superclass { y read-only } ; final
+
+TYPED: unbox-fail ( a: superclass -- ? ) subclass? ;
+
+[ t ] [ subclass new unbox-fail ] unit-test
+
+! If a final class becomes non-final, typed words need to be recompiled
+TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
+
+[ f ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
+
+[ ] [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
+
+[ t ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
{
[ all-slots empty? not ]
[ immutable-tuple-class? ]
+ [ final-class? ]
} 1&& ;
! typed inputs
: input-mismatch-quot ( word types -- quot )
[ input-mismatch-error ] 2curry ;
+: depends-on-unboxing ( class -- )
+ [ dup tuple-layout depends-on-tuple-layout ]
+ [ depends-on-final ]
+ bi ;
+
: (unboxer) ( type -- quot )
dup unboxable-tuple-class? [
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
all-slots [
[ name>> reader-word 1quotation ]
[ class>> (unboxer) ] bi compose
: (unboxed-types) ( type -- types )
dup unboxable-tuple-class?
[
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
all-slots [ class>> (unboxed-types) ] map concat
]
[ 1array ] if ;
: boxer ( type -- quot )
dup unboxable-tuple-class?
[
- dup dup tuple-layout depends-on-tuple-layout
+ dup depends-on-unboxing
[ all-slots [ class>> ] map make-boxer ]
[ [ boa ] curry ]
bi compose
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays ascii assocs colors
-classes.struct combinators io.encodings.ascii
-io.encodings.string io.encodings.utf8 kernel literals math
-namespaces sequences strings ui ui.backend ui.clipboards
-ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gestures ui.pixel-formats ui.pixel-formats.private
-ui.private x11 x11.clipboard x11.constants x11.events x11.glx
-x11.io x11.windows x11.xim x11.xlib environment command-line
-combinators.short-circuit ;
+USING: accessors alien.c-types ascii assocs classes.struct combinators
+combinators.short-circuit command-line environment io.encodings.ascii
+io.encodings.string io.encodings.utf8 kernel literals locals math
+namespaces sequences specialized-arrays.instances.alien.c-types.uchar
+strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
+ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
+x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
M: x11-ui-backend beep ( -- )
dpy get 100 XBell drop ;
+: black ( -- xcolor ) 0 0 0 0 0 0 XColor <struct-boa> ; inline
+
+M:: x11-ui-backend (grab-input) ( handle -- )
+ handle window>> :> wnd
+ dpy get :> dpy
+ dpy wnd uchar-array{ 0 0 0 0 0 0 0 0 } 8 8 XCreateBitmapFromData :> pixmap
+ dpy pixmap dup black dup 0 0 XCreatePixmapCursor :> cursor
+
+ dpy wnd 1 NoEventMask GrabModeAsync dup wnd cursor CurrentTime XGrabPointer drop
+
+ dpy cursor XFreeCursor drop
+ dpy pixmap XFreePixmap drop ;
+
+M: x11-ui-backend (ungrab-input)
+ drop dpy get CurrentTime XUngrabPointer drop ;
+
x11-ui-backend ui-backend set-global
[ "DISPLAY" os-env "ui.tools" "listener" ? ]
{ undo-action com-undo }
{ redo-action com-redo }
{ T{ key-down f f "DELETE" } delete-next-character }
- { T{ key-down f { S+ } "DELETE" } delete-next-character }
{ T{ key-down f f "BACKSPACE" } delete-previous-character }
{ T{ key-down f { S+ } "BACKSPACE" } delete-previous-character }
{ T{ key-down f { C+ } "DELETE" } delete-previous-word }
{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
HELP: window-resource
-{ $values { "resource" disposable } { "resource" disposable } }
+{ $values { "resource" disposable } }
{ $description "Marks " { $snippet "resource" } " to be destroyed with " { $link dispose } " when the window with the currently active OpenGL context (set by " { $link set-gl-context } ") is closed. " { $snippet "resource" } " is left unmodified at the top of the stack." } ;
HELP: flush-gl-context
bi*
] H{ } assoc-map-as
H{
+ { T{ key-down f { S+ } "DELETE" } [ \ cut-action send-action ] }
{ T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
{ T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
{ T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
+++ /dev/null
-unportable
+++ /dev/null
-unportable\r
$nl
"Interactors are created by calling " { $link <interactor> } "."
$nl
-"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
+"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link stream-read-quot } " generic words." } ;
ARTICLE: "ui-listener" "UI listener"
"The graphical listener adds input history and word and vocabulary completion. See " { $link "listener" } " for general information on the listener."
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.bsd.macosx ;
+USING: alien.syntax unix.ffi.bsd.macosx ;
IN: unix.utmpx.macosx
! empty
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data alien.syntax combinators
continuations io.encodings.string io.encodings.utf8 kernel
-sequences strings unix calendar system accessors unix.time
-calendar.unix vocabs.loader classes.struct ;
+sequences strings calendar system accessors unix unix.time
+unix.ffi calendar.unix vocabs.loader classes.struct ;
IN: unix.utmpx
CONSTANT: EMPTY 0
CONSTANT: SIGNATURE 10
CONSTANT: SHUTDOWN_TIME 11
+C-TYPE: utmpx
+
FUNCTION: void setutxent ( ) ;
FUNCTION: void endutxent ( ) ;
FUNCTION: utmpx* getutxent ( ) ;
-Slava Pestov
\ No newline at end of file
+Slava Pestov
+Joe Groff
\ No newline at end of file
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs io.encodings.utf8 io.files
-io.pathnames kernel make math.parser memoize sequences sets
-sorting summary vocabs vocabs.loader ;
+USING: accessors arrays assocs io.directories io.encodings.utf8
+io.files io.pathnames kernel make math.parser memoize sequences
+sets sorting summary vocabs vocabs.loader words system
+classes.algebra combinators.short-circuit fry continuations
+namespaces ;
IN: vocabs.metadata
+: check-vocab ( vocab -- vocab )
+ dup find-vocab-root [ no-vocab ] unless ;
+
MEMO: vocab-file-contents ( vocab name -- seq )
vocab-append-path dup
[ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
+: ?delete-file ( pathname -- ) '[ _ delete-file ] ignore-errors ;
+
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-append-path [
- utf8 set-file-lines
+ swap [ ?delete-file ] [ swap utf8 set-file-lines ] if-empty
\ vocab-file-contents reset-memoized
- ] [
- "The " swap vocab-name
- " vocabulary was not loaded from the file system"
- 3append throw
- ] ?if ;
+ ] [ vocab-name no-vocab ] ?if ;
: vocab-windows-icon-path ( vocab -- string )
vocab-dir "icon.ico" append-path ;
: add-vocab-tags ( tags vocab -- )
[ vocab-tags append prune ] keep set-vocab-tags ;
+: remove-vocab-tags ( tags vocab -- )
+ [ vocab-tags swap diff ] keep set-vocab-tags ;
+
: vocab-authors-path ( vocab -- string )
vocab-dir "authors.txt" append-path ;
: set-vocab-authors ( authors vocab -- )
dup vocab-authors-path set-vocab-file-contents ;
+: vocab-platforms-path ( vocab -- string )
+ vocab-dir "platforms.txt" append-path ;
+
+ERROR: bad-platform name ;
+
+: vocab-platforms ( vocab -- platforms )
+ dup vocab-platforms-path vocab-file-contents
+ [ dup "system" lookup [ ] [ bad-platform ] ?if ] map ;
+
+: set-vocab-platforms ( platforms vocab -- )
+ [ [ name>> ] map ] dip
+ dup vocab-platforms-path set-vocab-file-contents ;
+
+: supported-platform? ( platforms -- ? )
+ [ t ] [ [ os swap class<= ] any? ] if-empty ;
+
: unportable? ( vocab -- ? )
- vocab-tags "unportable" swap member? ;
+ {
+ [ vocab-tags "untested" swap member? ]
+ [ vocab-platforms supported-platform? not ]
+ } 1|| ;
+
+TUPLE: unsupported-platform vocab requires ;
+
+: unsupported-platform ( vocab requires -- )
+ \ unsupported-platform boa throw-continue ;
+
+M: unsupported-platform summary
+ drop "Current operating system not supported by this vocabulary" ;
+
+[
+ dup vocab-platforms dup supported-platform?
+ [ 2drop ] [ [ vocab-name ] dip unsupported-platform ] if
+] check-vocab-hook set-global
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
CONSTANT: D3DMULTISAMPLE_15_SAMPLES 15
CONSTANT: D3DMULTISAMPLE_16_SAMPLES 16
CONSTANT: D3DMULTISAMPLE_FORCE_DWORD HEX: 7fffffff
-
-:: MAKEFOURCC ( ch0 ch1 ch2 ch3 -- n )
- ch3 HEX: ff bitand 24 shift
- ch2 HEX: ff bitand 16 shift
- ch1 HEX: ff bitand 8 shift
- ch0 HEX: ff bitand bitor bitor bitor ; inline
TYPEDEF: int D3DFORMAT
CONSTANT: D3DFMT_UNKNOWN 0
CONSTANT: D3DFMT_Q8W8V8U8 63
CONSTANT: D3DFMT_V16U16 64
CONSTANT: D3DFMT_A2W10V10U10 67
-#! : D3DFMT_UYVY ( -- n ) 'U' 'Y' 'V' 'Y' MAKEFOURCC
-#! D3DFMT_R8G8_B8G8 = MAKEFOURCC('R', 'G', 'B', 'G'),
-#! D3DFMT_YUY2 = MAKEFOURCC('Y', 'U', 'Y', '2'),
-#! D3DFMT_G8R8_G8B8 = MAKEFOURCC('G', 'R', 'G', 'B'),
-#! D3DFMT_DXT1 = MAKEFOURCC('D', 'X', 'T', '1'),
-#! D3DFMT_DXT2 = MAKEFOURCC('D', 'X', 'T', '2'),
-#! D3DFMT_DXT3 = MAKEFOURCC('D', 'X', 'T', '3'),
-#! D3DFMT_DXT4 = MAKEFOURCC('D', 'X', 'T', '4'),
-#! D3DFMT_DXT5 = MAKEFOURCC('D', 'X', 'T', '5'),
+CONSTANT: D3DFMT_UYVY HEX: 55595659
+CONSTANT: D3DFMT_R8G8_B8G8 HEX: 52474247
+CONSTANT: D3DFMT_YUY2 HEX: 59555932
+CONSTANT: D3DFMT_G8R8_G8B8 HEX: 47524742
+CONSTANT: D3DFMT_DXT1 HEX: 44585431
+CONSTANT: D3DFMT_DXT2 HEX: 44585432
+CONSTANT: D3DFMT_DXT3 HEX: 44585433
+CONSTANT: D3DFMT_DXT4 HEX: 44585434
+CONSTANT: D3DFMT_DXT5 HEX: 44585435
CONSTANT: D3DFMT_D16_LOCKABLE 70
CONSTANT: D3DFMT_D32 71
CONSTANT: D3DFMT_D15S1 73
CONSTANT: D3DFMT_INDEX16 101
CONSTANT: D3DFMT_INDEX32 102
CONSTANT: D3DFMT_Q16W16V16U16 110
-#! D3DFMT_MULTI2_ARGB8 = MAKEFOURCC('M', 'E', 'T', '1'),
+CONSTANT: D3DFMT_MULTI2_ARGB8 HEX: 4d455431
CONSTANT: D3DFMT_R16F 111
CONSTANT: D3DFMT_G16R16F 112
CONSTANT: D3DFMT_A16B16G16R16F 113
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable\r
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable\r
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
+! 5.2 - Creating, Recoloring, and Freeing Cursors
+
+C-TYPE: XColor
+X-FUNCTION: Cursor XCreatePixmapCursor ( Display* display, Pixmap source, Pixmap mask, XColor* foreground_color, XColor* background_color, uint x, uint y ) ;
+X-FUNCTION: int XFreeCursor ( Display* display, Cursor cursor ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 6 - Color Management Functions
X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
+X-FUNCTION: int XGrabKeyboard ( Display* display, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode, Time time ) ;
X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
X-FUNCTION: Status XGetInputFocus ( Display* display,
{ colormap_size int }
{ bits_per_rgb int } ;
+! 16.9 Manipulating Bitmaps
+X-FUNCTION: Pixmap XCreateBitmapFromData (
+ Display* display,
+ Drawable d,
+ char* data,
+ uint width,
+ uint height ) ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Appendix D - Compatibility Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
HELP: post-rpc
{ $values { "rpc" "an XML-RPC input tuple" } { "url" "a URL" }
- { "rpc" "an XML-RPC output tuple" } }
+ { "rpc'" "an XML-RPC output tuple" } }
{ $description "posts an XML-RPC document to the specified URL, receives the response and parses it as XML-RPC, returning the tuple" } ;
ARTICLE: { "xml-rpc" "intro" } "XML-RPC"
PRIVATE>
-: post-rpc ( rpc url -- rpc )
+: post-rpc ( rpc url -- rpc' )
! This needs to do something in the event of an error
rpc-post-request http-request nip string>xml receive-rpc ;
{ $see-also first-child-tag } ;
HELP: first-child-tag
-{ $values { "tag" "an XML tag or document" } { "tag" tag } }
+{ $values { "tag" "an XML tag or document" } { "child" tag } }
{ $description "Returns the first child of the given tag that is a tag." }
{ $see-also children-tags } ;
: children-tags ( tag -- sequence )
children>> [ tag? ] filter ;
-: first-child-tag ( tag -- tag )
+: first-child-tag ( tag -- child )
children>> [ tag? ] find nip ;
: tag-named? ( name elem -- ? )
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
M: array resize resize-array ; inline
-
-: >array ( seq -- array ) { } clone-like ;
-
+M: array equal? over array? [ sequence= ] [ 2drop f ] if ;
M: object new-sequence drop 0 <array> ; inline
-
M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
-M: array equal?
- over array? [ sequence= ] [ 2drop f ] if ;
-
INSTANCE: array sequence
+: >array ( seq -- array ) { } clone-like ;
: 1array ( x -- array ) 1 swap <array> ; inline
-
: 2array ( x y -- array ) { } 2sequence ; inline
-
: 3array ( x y z -- array ) { } 3sequence ; inline
-
: 4array ( w x y z -- array ) { } 4sequence ; inline
PREDICATE: pair < array length 2 number= ;
HELP: assoc-like
{ $values { "assoc" assoc } { "exemplar" assoc } { "newassoc" "a new assoc" } }
-{ $contract "Creates a new assoc having the same entries as "{ $snippet "assoc" } " and the same type as " { $snippet "exemplar" } "." } ;
+{ $contract "Creates a new assoc having the same entries as " { $snippet "assoc" } " and the same type as " { $snippet "exemplar" } "." } ;
HELP: assoc-empty?
{ $values { "assoc" assoc } { "?" "a boolean" } }
{ $side-effects "assoc" } ;
HELP: 2cache
-{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
+{ $values { "key1" "a key" } { "key2" "a key" } { "assoc" assoc } { "quot" { $quotation "( key1 key2 -- value )" } } { "value" "a previously-retained or freshly-computed value" } }
{ $description "If a single key composed of the input keys is present in the assoc, outputs the associated value, otherwise calls the quotation to produce a value and stores the keys/value pair into the assoc. Returns the value stored in the assoc. Returns a value either looked up or newly stored in the assoc." }
{ $side-effects "assoc" } ;
HELP: assoc-map-as
{ $values
- { "assoc" assoc } { "quot" quotation } { "exemplar" assoc }
+ { "assoc" assoc } { "quot" { $quotation "( key value -- newkey newvalue )" } } { "exemplar" assoc }
{ "newassoc" assoc } }
{ $description "Applies the quotation to each entry in the input assoc and collects the results in a new assoc of the stame type as the exemplar." }
{ $examples { $example "USING: prettyprint assocs hashtables math ;" " H{ { 1 2 } { 3 4 } } [ sq ] { } assoc-map-as ." "{ { 1 4 } { 3 16 } }" } } ;
"SYMBOLS:"
"CONSTANT:"
"TUPLE:"
+ "final"
"SLOT:"
"T{"
"UNION:"
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
+
+SYMBOL: +incomparable+
+
+: compare-classes ( class1 class2 -- ? )
+ {
+ { [ 2dup class<= ] [ t ] }
+ { [ 2dup classes-intersect? not ] [ f ] }
+ [ +incomparable+ ]
+ } cond 2nip ;
: create-class-in ( string -- word )
current-vocab create
+ dup set-word
dup save-class-location
- dup create-predicate-word dup set-word save-location ;
+ dup create-predicate-word save-location ;
: CREATE-CLASS ( -- word )
scan create-class-in ;
"tuple-inheritance-example"
"tuple-inheritance-anti-example"
}
+"Declaring a tuple class final prohibits other classes from subclassing it:"
+{ $subsections POSTPONE: final }
{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." }
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;
+
+HELP: bad-superclass
+{ $error-description "Thrown if an attempt is made to subclass a class that is not a tuple class, or a tuple class declared " { $link POSTPONE: final } "." } ;
[ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
[ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test
+
+! Final classes
+TUPLE: final-superclass ;
+TUPLE: final-subclass < final-superclass ;
+
+[ final-superclass ] [ final-subclass superclass ] unit-test
+
+! Making the superclass final should change the superclass of the subclass
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
+
+[ tuple ] [ final-subclass superclass ] unit-test
+
+[ f ] [ \ final-subclass final-class? ] unit-test
+
+! Subclassing a final class should fail
+[ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ]
+[ error>> bad-superclass? ] must-fail-with
+
+! Making a final class non-final should work
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
+
+! Changing a superclass should not change the final status of a subclass
+[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
+
+[ t ] [ \ final-subclass final-class? ] unit-test
] [ 2drop f ] if
] [ 2drop f ] if ; inline
+GENERIC: final-class? ( class -- ? )
+
+M: tuple-class final-class? "final" word-prop ;
+
+M: builtin-class final-class? tuple eq? not ;
+
+M: class final-class? drop t ;
+
<PRIVATE
: tuple-predicate-quot/1 ( class -- quot )
[ [ "slots" word-prop ] dip = ]
bi-curry* bi and ;
-GENERIC: valid-superclass? ( class -- ? )
-
-M: tuple-class valid-superclass? drop t ;
-
-M: builtin-class valid-superclass? tuple eq? ;
-
-M: class valid-superclass? drop f ;
-
: check-superclass ( superclass -- )
- dup valid-superclass? [ bad-superclass ] unless drop ;
+ dup final-class? [ bad-superclass ] when drop ;
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
read-only suffix
] map ;
+: reset-final ( class -- )
+ dup final-class? [
+ [ f "final" set-word-prop ]
+ [ changed-conditionally ]
+ bi
+ ] [ drop ] if ;
+
PRIVATE>
: define-tuple-class ( class superclass slots -- )
over prepare-slots
(define-tuple-class) ;
+GENERIC: make-final ( class -- )
+
+M: tuple-class make-final
+ [ dup class-usage keys ?metaclass-changed ]
+ [ t "final" set-word-prop ]
+ bi ;
+
M: word (define-tuple-class)
define-new-tuple-class ;
M: tuple-class (define-tuple-class)
+ pick reset-final
3dup tuple-class-unchanged?
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
] with each
] [
[ call-next-method ]
- [ { "layout" "slots" "boa-check" "prototype" } reset-props ]
+ [ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ]
bi
] bi ;
hashtables sorting words sets math.order make ;
IN: combinators
+! Most of these combinators have compile-time expansions in
+! the optimizing compiler. See stack-checker.transforms and
+! compiler.tree.propagation.call-effect
+
<PRIVATE
: call-effect-unsafe ( quot effect -- ) drop call ;
PRIVATE>
-ERROR: wrong-values quot effect ;
+ERROR: wrong-values quot call-site ;
! We can't USE: effects here so we forward reference slots instead
SLOT: in
TUPLE: redefine-error def ;
: redefine-error ( definition -- )
- \ redefine-error boa
- { { "Continue" t } } throw-restarts drop ;
+ \ redefine-error boa throw-continue ;
<PRIVATE
throw-restarts
rethrow-restarts
}
+"A utility word using the above:"
+{ $subsections
+ throw-continue
+}
"The list of restarts from the most recently-thrown error is stored in a global variable:"
{ $subsections restarts }
-"To invoke restarts, see " { $link "debugger" } "." ;
+"To invoke restarts, use " { $link "debugger" } "." ;
ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;
-{ throw rethrow throw-restarts rethrow-restarts } related-words
+{ throw rethrow throw-restarts rethrow-restarts throw-continue } related-words
+
+HELP: throw-continue
+{ $values { "error" object } }
+{ $description "Throws a resumable error. If the user elects to continue execution, this word returns normally." } ;
HELP: compute-restarts
{ $values { "error" object } { "seq" "a sequence" } }
: rethrow-restarts ( error restarts -- restart )
[ <condition> rethrow ] callcc1 2nip ;
+: throw-continue ( error -- )
+ { { "Continue" t } } throw-restarts drop ;
+
TUPLE: restart name obj continuation ;
C: <restart> restart
HELP: (call-next-method)
{ $values { "method" method } }
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
-{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
+{ $notes
+ "The " { $link POSTPONE: call-next-method } " word parses into this word. The following are equivalent:"
+ { $code
+ "M: class generic call-next-method ;"
+ "M: class generic M\\ class generic (call-next-method) ;"
+ }
+} ;
HELP: no-next-method
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
{ $description "Prepends the " { $link current-directory } " to the pathname, resolves a " { $snippet "resource:" } " or " { $snippet "vocab:" } " prefix, if present (see " { $link "io.pathnames.special" } "). Also converts the path into a UNC path on Windows." }
{ $notes "High-level words, such as " { $link <file-reader> } " and " { $link delete-file } " call this word for you. It only needs to be called directly when passing pathnames to C functions or external processes. This is because Factor does not use the operating system's notion of a current directory, and instead maintains its own dynamically-scoped " { $link current-directory } " variable." }
-{ $notes "On Windows NT platforms, this word does prepends the Unicode path prefix." }
+{ $notes "On Windows NT platforms, this word prepends the Unicode path prefix." }
{ $examples
"For example, if you create a file named " { $snippet "data.txt" } " in the current directory, and wish to pass it to a process, you must normalize it:"
{ $code
{ $notes "This operation is efficient and does not copy the quotation." } ;
HELP: with
-{ $values { "param" object } { "obj" object } { "quot" { $quotation "( param elt -- ... )" } } { "obj" object } { "curry" curry } }
+{ $values { "param" object } { "obj" object } { "quot" { $quotation "( param elt -- ... )" } } { "curry" curry } }
{ $description "Partial application on the left. The following two lines are equivalent:"
{ $code "swap [ swap A ] curry B" }
{ $code "[ A ] with B" }
HELP: make
{ $values { "quot" quotation } { "exemplar" sequence } { "seq" "a new sequence" } }
-{ $description "Calls the quotation in a new " { $emphasis "dynamic scope" } ". The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." }
+{ $description "Calls the quotation in a new dynamic scope with the " { $link building } " variable bound to a new resizable mutable sequence. The quotation and any words it calls can execute the " { $link , } " and " { $link % } " words to accumulate elements. When the quotation returns, all accumulated elements are collected into a sequence with the same type as " { $snippet "exemplar" } "." }
{ $examples { $example "USING: make prettyprint ;" "[ 1 , 2 , 3 , ] { } make ." "{ 1 2 3 }" } } ;
HELP: ,
HELP: rem
{ $values { "x" rational } { "y" rational } { "z" rational } }
{ $description
- "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive."
+ "Computes the remainder of dividing " { $snippet "x" } " by " { $snippet "y" } ", with the remainder always positive or zero."
{ $list
"Given fixnums, always yields a fixnum."
"Given bignums, always yields a bignum."
{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-base
-{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } { "parsed" integer } }
+{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } }
{ $description "Reads an integer in a specific numerical base from the parser input." }
$parsing-note ;
] unit-test
[ t ] [
- "foo?" "parser.tests" lookup word eq?
+ "foo" "parser.tests" lookup word eq?
] unit-test
[ ] [
HELP: reduce-index
{ $values
- { "seq" sequence } { "identity" object } { "quot" quotation } }
+ { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt index -- result )" } } }
{ $description "Combines successive elements of the sequence and their indices binary operations, and outputs the final result. On the first iteration, the three inputs to the quotation are " { $snippet "identity" } ", the first element of the sequence, and its index, 0. On successive iterations, the first input is the result of the previous iteration, the second input is the corresponding element of the sequence, and the third is its index." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 50 90 } 0 [ + + ] reduce-index ."
} ;
HELP: accumulate!
-{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "seq" sequence } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs the original sequence of intermediate results, together with the final result."
$nl
"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
HELP: each-index
{ $values
- { "seq" sequence } { "quot" quotation } }
+ { "seq" sequence } { "quot" { $quotation "( elt index -- )" } } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack." }
-{ $examples { $example "USING: sequences prettyprint math ;"
-"{ 10 20 30 } [ + . ] each-index"
-"10\n21\n32"
+{ $examples { $example "USING: arrays sequences prettyprint ;"
+"{ 10 20 30 } [ 2array . ] each-index"
+"{ 10 0 }\n{ 20 1 }\n{ 30 2 }"
} } ;
HELP: map-index
{ $values
- { "seq" sequence } { "quot" quotation } { "newseq" sequence } }
+ { "seq" sequence } { "quot" { $quotation "( elt index -- result )" } } { "newseq" sequence } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." }
-{ $examples { $example "USING: sequences prettyprint math ;"
-"{ 10 20 30 } [ + ] map-index ."
-"{ 10 21 32 }"
+{ $examples { $example "USING: arrays sequences prettyprint ;"
+"{ 10 20 30 } [ 2array ] map-index ."
+"{ { 10 0 } { 20 1 } { 30 2 } }"
} } ;
HELP: change-nth
{ $side-effects "seq" } ;
HELP: map!
-{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } { "seq" "a mutable sequence" } }
+{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence. Returns the original sequence." }
{ $errors "Throws an error if the sequence is immutable, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ;
HELP: filter!
-{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a resizable mutable sequence" } }
+{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
{ $side-effects "seq" } ;
{ $side-effects "seq" } ;
HELP: remove!
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } { "elt" object } }
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } " and returns " { $snippet "seq" } "." }
{ $notes "This word uses equality comparison (" { $link = } ")." }
{ $side-effects "seq" } ;
HELP: remove-eq!
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } { "seq" "a resizable mutable sequence" } }
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except the given element." }
{ $notes "This word uses identity comparison (" { $link eq? } ")." }
{ $side-effects "seq" } ;
HELP: remove-nth!
-{ $values { "n" "a non-negative integer" } { "seq" "a resizable mutable sequence" } { "seq" "a resizable mutable sequence" } }
+{ $values { "n" "a non-negative integer" } { "seq" "a resizable mutable sequence" } }
{ $description "Removes the " { $snippet "n" } "th element from the sequence, shifting all other elements down and reducing its length by one." }
{ $side-effects "seq" } ;
} ;
HELP: suffix!
-{ $values { "seq" sequence } { "elt" object } { "seq" sequence } }
+{ $values { "seq" sequence } { "elt" object } }
{ $description "Modifiers a sequence in-place by adding " { $snippet "elt" } " to the end of " { $snippet "seq" } ". Outputs " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq" } "." }
{ $examples
} ;
HELP: append!
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq1" sequence } }
+{ $values { "seq1" sequence } { "seq2" sequence } }
{ $description "Modifiers " { $snippet "seq1" } " in-place by adding the elements from " { $snippet "seq2" } " to the end and outputs " { $snippet "seq1" } "." }
{ $examples
{ $example "USING: prettyprint sequences ;" "V{ 1 2 3 } { 4 5 6 } append! ." "V{ 1 2 3 4 5 6 }" }
HELP: selector
{ $values
- { "quot" "a predicate quotation" }
- { "quot" quotation } { "accum" vector } }
+ { "quot" { $quotation "( elt -- ? )" } }
+ { "selector" { $quotation "( elt -- )" } } { "accum" vector } }
{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the collector if the test yields true. The collector is left on the stack for convenience." }
{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
"10 iota [ even? ] selector [ each ] dip ."
HELP: replicate-as
{ $values
- { "len" integer } { "quot" quotation } { "exemplar" sequence }
+ { "len" integer } { "quot" { $quotation "( -- elt )" } } { "exemplar" sequence }
{ "newseq" sequence } }
{ $description "Calls the quotation " { $snippet "len" } " times, collecting results into a new sequence of the same type as the exemplar sequence." }
{ $examples
HELP: 2map-reduce
{ $values
- { "seq1" sequence } { "seq2" sequence } { "map-quot" quotation } { "reduce-quot" quotation }
+ { "seq1" sequence } { "seq2" sequence } { "map-quot" { $quotation "( elt1 elt2 -- intermediate )" } } { "reduce-quot" { $quotation "( prev intermediate -- result )" } }
{ "result" object } }
{ $description "Calls " { $snippet "map-quot" } " on each pair of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } " and combines the results using " { $snippet "reduce-quot" } " in the same manner as " { $link reduce } ", except that there is no identity element, and the sequence must have a length of at least 1." }
{ $errors "Throws an error if the sequence is empty." }
HELP: 2selector
{ $values
{ "quot" quotation }
- { "quot" quotation } { "accum1" vector } { "accum2" vector } }
+ { "selector" quotation } { "accum1" vector } { "accum2" vector } }
{ $description "Creates two new vectors to accumultate values based on a predicate. The first vector accumulates values for which the predicate yields true; the second for false." } ;
HELP: 2reverse-each
HELP: binary-reduce
{ $values
- { "seq" sequence } { "start" integer } { "quot" quotation }
+ { "seq" sequence } { "start" integer } { "quot" { $quotation "( elt1 elt2 -- newelt )" } }
{ "value" object } }
{ $description "Like " { $link reduce } ", but splits the sequence in half recursively until each sequence is small enough, and calls the quotation on these smaller sequences. If the quotation computes values that depend on the size of their input, such as bignum arithmetic, then this algorithm can be more efficient than using " { $link reduce } "." }
{ $examples "Computing factorial:"
HELP: follow
{ $values
- { "obj" object } { "quot" quotation }
+ { "obj" object } { "quot" { $quotation "( prev -- result/f )" } }
{ "seq" sequence } }
{ $description "Outputs a sequence containing the input object and all of the objects generated by successively feeding the result of the quotation called on the input object to the quotation recursuively. Objects yielded by the quotation are added to the output sequence until the quotation yields " { $link f } ", at which point the recursion terminates." }
{ $examples "Get random numbers until zero is reached:"
HELP: short
{ $values
- { "seq" sequence } { "n" integer }
- { "seq" sequence } { "n'" integer } }
+ { "seq" sequence } { "n" integer } { "n'" integer } }
{ $description "Returns the input sequence and its length or " { $snippet "n" } ", whichever is less." }
{ $examples { $example "USING: sequences kernel prettyprint ;"
"\"abcd\" 3 short [ . ] bi@"
: push-if ( elt quot accum -- )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
-: selector-for ( quot exemplar -- quot accum )
+: selector-for ( quot exemplar -- selector accum )
[ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline
-: selector ( quot -- quot accum )
+: selector ( quot -- selector accum )
V{ } selector-for ; inline
: filter-as ( seq quot exemplar -- subseq )
: push-either ( elt quot accum1 accum2 -- )
[ keep swap ] 2dip ? push ; inline
-: 2selector ( quot -- quot accum1 accum2 )
+: 2selector ( quot -- selector accum1 accum2 )
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq )
{ $code "TUPLE: person" "{ age integer initial: 0 }" "{ department string initial: \"Marketing\" }" "manager ;" }
} ;
+HELP: final
+{ $syntax "TUPLE: ... ; final" }
+{ $description "Declares the most recently defined word as a final tuple class which cannot be subclassed. Attempting to subclass a final class raises a " { $link bad-superclass } " error." } ;
+
HELP: initial:
{ $syntax "TUPLE: ... { slot initial: value } ... ;" }
{ $values { "slot" "a slot name" } { "value" "any literal" } }
parse-tuple-definition define-tuple-class
] define-core-syntax
+ "final" [
+ word make-final
+ ] define-core-syntax
+
"SLOT:" [
scan define-protocol-slot
] define-core-syntax
SYMBOL: blacklist
+! Defined by vocabs.metadata
+SYMBOL: check-vocab-hook
+
+check-vocab-hook [ [ drop ] ] initialize
+
<PRIVATE
: add-to-blacklist ( error vocab -- )
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
M: vocab-link (load-vocab)
- vocab-name create-vocab (load-vocab) ;
+ vocab-name (load-vocab) ;
M: string (load-vocab)
- create-vocab (load-vocab) ;
+ [ check-vocab-hook get call( vocab -- ) ]
+ [ create-vocab (load-vocab) ]
+ bi ;
PRIVATE>
<< global [ "count-me" inc ] bind >>
-: v-l-t-a-hello 4 ;
+: v-l-t-a-hello ( -- a ) 4 ;
-: byebye v-l-t-a-hello ;
+: byebye ( -- a ) v-l-t-a-hello ;
[ this is an error
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions tuple-arrays accessors fry sequences
prettyprint ;
IN: benchmark.tuple-arrays
-TUPLE: point { x float } { y float } { z float } ;
+TUPLE: point { x float } { y float } { z float } ; final
TUPLE-ARRAY: point
! Copyright (C) 2010 Erik Charlebois
! See http:// factorcode.org/license.txt for BSD license.
-USING: accessors chipmunk classes.struct game.loop game.worlds gpu
-gpu.util.wasd kernel literals locals math method-chains opengl.gl
-random sequences specialized-arrays
-specialized-arrays.instances.alien.c-types.void* ui.gadgets.worlds
+USING: accessors chipmunk classes.struct game.worlds kernel locals
+math method-chains opengl.gl random sequences specialized-arrays
+specialized-arrays.instances.alien.c-types.void* ui ui.gadgets.worlds
ui.pixel-formats ;
IN: chipmunk.demo
cpCircleShapeAlloc body 0.95 0 0 cpv cpCircleShapeInit cpCircleShape memory>struct
[ shape>> 0 >>e ] [ shape>> 0 >>u ] bi drop ;
-TUPLE: chipmunk-world < wasd-world
+TUPLE: chipmunk-world < game-world
space ;
AFTER: chipmunk-world tick-game-world
M:: chipmunk-world begin-game-world ( world -- )
cpInitChipmunk
- init-gpu
- world { -0.2 0.13 0.1 } 1.1 0.2 set-wasd-view drop
cpSpaceAlloc cpSpaceInit cpSpace memory>struct :> space
[ cpSpaceFreeChildren ]
[ cpSpaceFree ] bi ;
-M: chipmunk-world wasd-movement-speed drop 1/160. ;
-M: chipmunk-world wasd-near-plane drop 1/32. ;
-M: chipmunk-world wasd-far-plane drop 256.0 ;
-
-GAME: chipmunk-demo {
- { world-class chipmunk-world }
- { title "Chipmunk Physics Demo" }
- { pixel-format-attributes {
- windowed
- double-buffered
- T{ depth-bits { value 24 } }
- } }
- { grab-input? t }
- { use-game-input? t }
- { pref-dim { 640 480 } }
- { tick-interval-micros $[ 60 fps ] }
- } ;
+: chipmunk-demo ( -- )
+ [
+ f
+ T{ game-attributes
+ { world-class chipmunk-world }
+ { title "Chipmunk Physics Demo" }
+ { pixel-format-attributes
+ { windowed double-buffered }
+ }
+ { pref-dim { 640 480 } }
+ { tick-interval-micros 16666 }
+ }
+ clone
+ open-window
+ ] with-ui ;
+
-FFI bindings to the Chipmunk 2D physics library.
+Chipmunk 2D physics library binding
+++ /dev/null
-unportable
+++ /dev/null
-unportable
HELP: z-up { $class-description "Right-handed 3D coordinate system where Z is up." } ;
HELP: >y-up-axis!
-{ $values { "seq" sequence } { "from-axis" rh-up } { "seq" sequence } }
+{ $values { "seq" sequence } { "from-axis" rh-up } }
{ $description "Destructively swizzles the first three elements of the input sequence to a right-handed 3D coordinate system where Y is up and returns the modified sequence." } ;
HELP: source>seq
{ $description "Convert the mesh tag's vertices element to a pair for further lookup in " { $link collect-sources } ". " } ;
HELP: collect-sources
-{ $values { "sources" hashtable } { "vertices" pair } { "inputs" tag sequence } { "sources" sequence } }
+{ $values { "sources" hashtable } { "vertices" pair } { "inputs" tag sequence } { "seq" sequence } }
{ $description "Look up the sources for these " { $emphasis "input" } " elements and return a sequence of " { $link source } " tuples." } ;
HELP: group-indices
] x*
] bi 2array ;
-:: collect-sources ( sources vertices inputs -- sources )
+:: collect-sources ( sources vertices inputs -- seq )
inputs
[| input |
input "source" x@ rest vertices first =
{ $description "Convert a face line to a sequence of vertex attributes." } ;
HELP: push*
-{ $values { "elt" "an object" } { "seq" sequence } { "seq" sequence } }
+{ $values { "elt" "an object" } { "seq" sequence } }
{ $description "Push the value onto the sequence, keeping the sequence on the stack." } ;
HELP: push-current-model
"gpu.shaders"
"gpu.render"
}
-"The library is built on top of the OpenGL API, but it aims to be complete enough that raw OpenGL calls are never needed. OpenGL 2.0 with the vertex array object extension (" { $snippet "GL_APPLE_vertex_array_object" } " or " { $snippet "GL_ARB_vertex_array_object" } ") is required. Some features require later OpenGL versions or additional extensions; these requirements are documented alongside individual words. To make full use of the library, an OpenGL 3.1 or later implementation is recommended." ;
+"The library is built on top of the OpenGL API, but it aims to be complete enough that raw OpenGL calls are never needed. OpenGL 2.0 is required. Some features require later OpenGL versions or additional extensions; these requirements are documented alongside individual words. To make full use of the library, an OpenGL 3.1 or later implementation is recommended." ;
ABOUT: "gpu-summary"
VARIANT: gpu-api
opengl-2 opengl-3 ;
+SYMBOL: has-vertex-array-objects?
+
: set-gpu-api ( -- )
"2.0" require-gl-version
"3.0" { { "GL_ARB_vertex_array_object" "GL_APPLE_vertex_array_object" } }
- require-gl-version-or-extensions
+ has-gl-version-or-extensions? has-vertex-array-objects? set-global
"3.0" has-gl-version? opengl-3 opengl-2 ? gpu-api set-global ;
HOOK: init-gpu-api gpu-api ( -- )
<PRIVATE
-: bind-vertex-array ( vertex-array -- )
- handle>> glBindVertexArray ;
-
: bind-unnamed-output-attachments ( framebuffer attachments -- )
[ gl-attachment ] with map
dup length 1 =
TUPLE: render-set
{ primitive-mode primitive-mode read-only }
- { vertex-array vertex-array read-only }
+ { vertex-array vertex-array initial: T{ vertex-array-collection } read-only }
{ uniforms uniform-tuple read-only }
{ indexes vertex-indexes initial: T{ index-range } read-only }
{ instances ?integer initial: f read-only }
{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a vertex shader." } ;
HELP: vertex-array
-{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <multi-vertex-array> } " or " { $link <vertex-array*> } " words." } ;
+{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <multi-vertex-array> } " or " { $link <vertex-array*> } " words. The actual type of a vertex-array object is opaque, but the " { $link vertex-array-buffers } " word can be used to query a vertex array object for its component buffers." } ;
+
+HELP: vertex-array-buffers
+{ $values
+ { "vertex-array" vertex-array }
+ { "buffers" sequence }
+}
+{ $description "Returns a sequence containing all of the " { $link buffer } " objects that make up " { $snippet "vertex-array" } "." } ;
HELP: vertex-array-buffer
{ $values
{ "vertex-array" vertex-array }
{ "vertex-buffer" buffer }
}
-{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
+{ $description "Returns the first " { $link buffer } " object that makes up " { $snippet "vertex-array" } "." } ;
+
+{ vertex-array-buffer vertex-array-buffers } related-words
HELP: vertex-attribute
{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
{ $subsections
vertex-array
<multi-vertex-array>
- vertex-array
+ <vertex-array*>
+ <vertex-array>
POSTPONE: VERTEX-FORMAT:
} ;
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs byte-arrays classes.mixin classes.parser
classes.singleton classes.struct combinators combinators.short-circuit
-definitions destructors fry generic.parser gpu gpu.buffers hashtables
-images io.encodings.ascii io.files io.pathnames kernel lexer
-literals locals math math.parser memoize multiline namespaces
+definitions destructors fry generic.parser gpu gpu.buffers gpu.private
+gpu.state hashtables images io.encodings.ascii io.files io.pathnames
+kernel lexer literals locals math math.parser memoize multiline namespaces
opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
SYNTAX: VERTEX-STRUCT:
CREATE-CLASS scan-word define-vertex-struct ;
-TUPLE: vertex-array < gpu-object
+TUPLE: vertex-array-object < gpu-object
{ program-instance program-instance read-only }
{ vertex-buffers sequence read-only } ;
-M: vertex-array dispose
+TUPLE: vertex-array-collection
+ { vertex-formats sequence read-only }
+ { program-instance program-instance read-only } ;
+
+UNION: vertex-array
+ vertex-array-object vertex-array-collection ;
+
+M: vertex-array-object dispose
[ [ delete-vertex-array ] when* f ] change-handle drop ;
: ?>buffer-ptr ( buffer/ptr -- buffer-ptr )
: ?>buffer ( buffer/ptr -- buffer )
dup buffer? [ buffer>> ] unless ; inline
-:: <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
+<PRIVATE
+
+: normalize-vertex-formats ( vertex-formats -- vertex-formats' )
+ [ first2 [ ?>buffer-ptr ] dip 2array ] map ; inline
+
+: (bind-vertex-array) ( vertex-formats program-instance -- )
+ '[ _ swap first2 bind-vertex-format ] each ; inline
+
+: (reset-vertex-array) ( -- )
+ GL_MAX_VERTEX_ATTRIBS get-gl-int iota [ glDisableVertexAttribArray ] each ; inline
+
+:: <multi-vertex-array-object> ( vertex-formats program-instance -- vertex-array )
gen-vertex-array :> handle
handle glBindVertexArray
- vertex-formats [ program-instance swap first2 [ ?>buffer-ptr ] dip bind-vertex-format ] each
+ vertex-formats normalize-vertex-formats program-instance (bind-vertex-array)
+
handle program-instance vertex-formats [ first ?>buffer ] map
- vertex-array boa window-resource ; inline
+ vertex-array-object boa window-resource ; inline
-:: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
+: <multi-vertex-array-collection> ( vertex-formats program-instance -- vertex-array )
+ [ normalize-vertex-formats ] dip vertex-array-collection boa ; inline
+
+:: <vertex-array-object> ( vertex-buffer program-instance format -- vertex-array )
gen-vertex-array :> handle
handle glBindVertexArray
program-instance vertex-buffer ?>buffer-ptr format bind-vertex-format
handle program-instance vertex-buffer ?>buffer 1array
- vertex-array boa window-resource ; inline
+ vertex-array-object boa window-resource ; inline
+
+: <vertex-array-collection> ( vertex-buffer program-instance format -- vertex-array )
+ swap [ [ ?>buffer-ptr ] dip 2array 1array ] dip <multi-vertex-array-collection> ; inline
+
+PRIVATE>
+
+GENERIC: bind-vertex-array ( vertex-array -- )
+
+M: vertex-array-object bind-vertex-array
+ handle>> glBindVertexArray ; inline
+
+M: vertex-array-collection bind-vertex-array
+ (reset-vertex-array)
+ [ vertex-formats>> ] [ program-instance>> ] bi (bind-vertex-array) ; inline
+
+: <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
+ has-vertex-array-objects? get
+ [ <multi-vertex-array-object> ]
+ [ <multi-vertex-array-collection> ] if ; inline
+
+: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
+ has-vertex-array-objects? get
+ [ <vertex-array-object> ]
+ [ <vertex-array-collection> ] if ; inline
: <vertex-array> ( vertex-buffer program-instance -- vertex-array )
dup program>> vertex-formats>> first <vertex-array*> ; inline
-TYPED: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
- vertex-buffers>> first ;
+GENERIC: vertex-array-buffers ( vertex-array -- buffers )
+
+M: vertex-array-object vertex-array-buffers
+ vertex-buffers>> ; inline
+
+M: vertex-array-collection vertex-array-buffers
+ vertex-formats>> [ first buffer>> ] map ; inline
+
+: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
+ vertex-array-buffers first ; inline
TUPLE: compile-shader-error shader log ;
TUPLE: link-program-error program log ;
[ [ set-gpu-state* ] each ]
[ set-gpu-state* ] if ; inline
-<PRIVATE
-
: get-gl-bool ( enum -- value )
0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
: get-gl-int ( enum -- value )
: gl-enabled? ( enum -- ? )
glIsEnabled c-bool> ;
-PRIVATE>
-
TYPED: get-viewport-state ( -- viewport-state: viewport-state )
GL_VIEWPORT get-gl-rect <viewport-state> ;
"[let { 1 2 3 4 } :> myarr [infix myarr[4/2]*3 infix] ] ."
"9"
}
-"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
-{ $example
- "USING: arrays infix locals ;"
- ":: add-2nd-elements ( x y -- res )"
- " [infix x[1] + y[1] infix] ;"
- "{ 1 2 3 } { 0 1 2 3 } add-2nd-elements ."
- "3"
-}
;
ABOUT: "infix"
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-unportable
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax alien.data
classes.struct combinators io.ports io.streams.duplex
-system kernel math math.bitwise vocabs.loader unix io.serial
-io.serial.unix.termios io.backend.unix ;
+system kernel math math.bitwise vocabs.loader io.serial
+io.serial.unix.termios io.backend.unix unix unix.ffi ;
IN: io.serial.unix
<< {
+++ /dev/null
-unportable
--- /dev/null
+Erik Charlebois
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.libraries
+alien.syntax classes.struct combinators endian io.binary
+kernel locals math sequences specialized-arrays
+system unix.time unix.types ;
+FROM: alien.c-types => short ;
+IN: libusb
+
+<< "libusb" {
+ { [ os windows? ] [ "libusb-1.0.dll" ] }
+ { [ os macosx? ] [ "libusb-1.0.dylib" ] }
+ { [ os unix? ] [ "libusb-1.0.so" ] }
+ } cond "cdecl" add-library >>
+LIBRARY: libusb
+
+: libusb_cpu_to_le16 ( x -- y )
+ 2 >native-endian le> ; inline
+
+ALIAS: libusb_le16_to_cpu libusb_cpu_to_le16
+
+CONSTANT: LIBUSB_CLASS_PER_INTERFACE 0
+CONSTANT: LIBUSB_CLASS_AUDIO 1
+CONSTANT: LIBUSB_CLASS_COMM 2
+CONSTANT: LIBUSB_CLASS_HID 3
+CONSTANT: LIBUSB_CLASS_PRINTER 7
+CONSTANT: LIBUSB_CLASS_PTP 6
+CONSTANT: LIBUSB_CLASS_MASS_STORAGE 8
+CONSTANT: LIBUSB_CLASS_HUB 9
+CONSTANT: LIBUSB_CLASS_DATA 10
+CONSTANT: LIBUSB_CLASS_VENDOR_SPEC HEX: ff
+TYPEDEF: int libusb_class_code
+
+CONSTANT: LIBUSB_DT_DEVICE HEX: 01
+CONSTANT: LIBUSB_DT_CONFIG HEX: 02
+CONSTANT: LIBUSB_DT_STRING HEX: 03
+CONSTANT: LIBUSB_DT_INTERFACE HEX: 04
+CONSTANT: LIBUSB_DT_ENDPOINT HEX: 05
+CONSTANT: LIBUSB_DT_HID HEX: 21
+CONSTANT: LIBUSB_DT_REPORT HEX: 22
+CONSTANT: LIBUSB_DT_PHYSICAL HEX: 23
+CONSTANT: LIBUSB_DT_HUB HEX: 29
+TYPEDEF: int libusb_descriptor_type
+
+CONSTANT: LIBUSB_DT_DEVICE_SIZE 18
+CONSTANT: LIBUSB_DT_CONFIG_SIZE 9
+CONSTANT: LIBUSB_DT_INTERFACE_SIZE 9
+CONSTANT: LIBUSB_DT_ENDPOINT_SIZE 7
+CONSTANT: LIBUSB_DT_ENDPOINT_AUDIO_SIZE 9
+CONSTANT: LIBUSB_DT_HUB_NONVAR_SIZE 7
+
+CONSTANT: LIBUSB_ENDPOINT_ADDRESS_MASK HEX: 0f
+CONSTANT: LIBUSB_ENDPOINT_DIR_MASK HEX: 80
+
+CONSTANT: LIBUSB_ENDPOINT_IN HEX: 80
+CONSTANT: LIBUSB_ENDPOINT_OUT HEX: 00
+TYPEDEF: int libusb_endpoint_direction
+
+CONSTANT: LIBUSB_TRANSFER_TYPE_MASK HEX: 03
+
+CONSTANT: LIBUSB_TRANSFER_TYPE_CONTROL 0
+CONSTANT: LIBUSB_TRANSFER_TYPE_ISOCHRONOUS 1
+CONSTANT: LIBUSB_TRANSFER_TYPE_BULK 2
+CONSTANT: LIBUSB_TRANSFER_TYPE_INTERRUPT 3
+TYPEDEF: int libusb_transfer_type
+
+CONSTANT: LIBUSB_REQUEST_GET_STATUS HEX: 00
+CONSTANT: LIBUSB_REQUEST_CLEAR_FEATURE HEX: 01
+CONSTANT: LIBUSB_REQUEST_SET_FEATURE HEX: 03
+CONSTANT: LIBUSB_REQUEST_SET_ADDRESS HEX: 05
+CONSTANT: LIBUSB_REQUEST_GET_DESCRIPTOR HEX: 06
+CONSTANT: LIBUSB_REQUEST_SET_DESCRIPTOR HEX: 07
+CONSTANT: LIBUSB_REQUEST_GET_CONFIGURATION HEX: 08
+CONSTANT: LIBUSB_REQUEST_SET_CONFIGURATION HEX: 09
+CONSTANT: LIBUSB_REQUEST_GET_INTERFACE HEX: 0A
+CONSTANT: LIBUSB_REQUEST_SET_INTERFACE HEX: 0B
+CONSTANT: LIBUSB_REQUEST_SYNCH_FRAME HEX: 0C
+TYPEDEF: int libusb_standard_request
+
+CONSTANT: LIBUSB_REQUEST_TYPE_STANDARD HEX: 00
+CONSTANT: LIBUSB_REQUEST_TYPE_CLASS HEX: 20
+CONSTANT: LIBUSB_REQUEST_TYPE_VENDOR HEX: 40
+CONSTANT: LIBUSB_REQUEST_TYPE_RESERVED HEX: 60
+
+CONSTANT: LIBUSB_RECIPIENT_DEVICE HEX: 00
+CONSTANT: LIBUSB_RECIPIENT_INTERFACE HEX: 01
+CONSTANT: LIBUSB_RECIPIENT_ENDPOINT HEX: 02
+CONSTANT: LIBUSB_RECIPIENT_OTHER HEX: 03
+TYPEDEF: int libusb_request_recipient
+
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_MASK HEX: 0C
+
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_NONE 0
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_ASYNC 1
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_ADAPTIVE 2
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_SYNC 3
+TYPEDEF: int libusb_iso_sync_type
+
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_MASK HEX: 30
+
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_DATA 0
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_FEEDBACK 1
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_IMPLICIT 2
+TYPEDEF: int libusb_iso_usage_type
+
+STRUCT: libusb_device_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bcdUSB uint16_t }
+ { bDeviceClass uint8_t }
+ { bDeviceSubClass uint8_t }
+ { bDeviceProtocol uint8_t }
+ { bMaxPacketSize0 uint8_t }
+ { idVendor uint16_t }
+ { idProduct uint16_t }
+ { bcdDevice uint16_t }
+ { iManufacturer uint8_t }
+ { iProduct uint8_t }
+ { iSerialNumber uint8_t }
+ { bNumConfigurations uint8_t } ;
+
+STRUCT: libusb_endpoint_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bEndpointAddress uint8_t }
+ { bmAttributes uint8_t }
+ { wMaxPacketSize uint16_t }
+ { bInterval uint8_t }
+ { bRefresh uint8_t }
+ { bSynchAddress uint8_t }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_interface_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bInterfaceNumber uint8_t }
+ { bAlternateSetting uint8_t }
+ { bNumEndpoints uint8_t }
+ { bInterfaceClass uint8_t }
+ { bInterfaceSubClass uint8_t }
+ { bInterfaceProtocol uint8_t }
+ { iInterface uint8_t }
+ { endpoint libusb_endpoint_descriptor* }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_interface
+ { altsetting libusb_interface_descriptor* }
+ { num_altsetting int } ;
+
+STRUCT: libusb_config_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { wTotalLength uint16_t }
+ { bNumInterfaces uint8_t }
+ { bConfigurationValue uint8_t }
+ { iConfiguration uint8_t }
+ { bmAttributes uint8_t }
+ { MaxPower uint8_t }
+ { interface libusb_interface* }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_control_setup
+ { bmRequestType uint8_t }
+ { bRequest uint8_t }
+ { wValue uint16_t }
+ { wIndex uint16_t }
+ { wLength uint16_t } ;
+
+: LIBUSB_CONTROL_SETUP_SIZE ( -- x ) libusb_control_setup heap-size ; inline
+
+C-TYPE: libusb_context
+C-TYPE: libusb_device
+C-TYPE: libusb_device_handle
+
+CONSTANT: LIBUSB_SUCCESS 0
+CONSTANT: LIBUSB_ERROR_IO -1
+CONSTANT: LIBUSB_ERROR_INVALID_PARAM -2
+CONSTANT: LIBUSB_ERROR_ACCESS -3
+CONSTANT: LIBUSB_ERROR_NO_DEVICE -4
+CONSTANT: LIBUSB_ERROR_NOT_FOUND -5
+CONSTANT: LIBUSB_ERROR_BUSY -6
+CONSTANT: LIBUSB_ERROR_TIMEOUT -7
+CONSTANT: LIBUSB_ERROR_OVERFLOW -8
+CONSTANT: LIBUSB_ERROR_PIPE -9
+CONSTANT: LIBUSB_ERROR_INTERRUPTED -10
+CONSTANT: LIBUSB_ERROR_NO_MEM -11
+CONSTANT: LIBUSB_ERROR_NOT_SUPPORTED -12
+CONSTANT: LIBUSB_ERROR_OTHER -99
+TYPEDEF: int libusb_error
+
+C-ENUM:
+ LIBUSB_TRANSFER_COMPLETED
+ LIBUSB_TRANSFER_ERROR
+ LIBUSB_TRANSFER_TIMED_OUT
+ LIBUSB_TRANSFER_CANCELLED
+ LIBUSB_TRANSFER_STALL
+ LIBUSB_TRANSFER_NO_DEVICE
+ LIBUSB_TRANSFER_OVERFLOW ;
+TYPEDEF: int libusb_transfer_status
+
+CONSTANT: LIBUSB_TRANSFER_SHORT_NOT_OK 1
+CONSTANT: LIBUSB_TRANSFER_FREE_BUFFER 2
+CONSTANT: LIBUSB_TRANSFER_FREE_TRANSFER 4
+TYPEDEF: int libusb_transfer_flags
+
+STRUCT: libusb_iso_packet_descriptor
+ { length uint }
+ { actual_length uint }
+ { status libusb_transfer_status } ;
+SPECIALIZED-ARRAY: libusb_iso_packet_descriptor
+
+C-TYPE: libusb_transfer
+
+CALLBACK: void libusb_transfer_cb_fn ( libusb_transfer* transfer ) ;
+
+STRUCT: libusb_transfer
+ { dev_handle libusb_device_handle* }
+ { flags uint8_t }
+ { endpoint uchar }
+ { type uchar }
+ { timeout uint }
+ { status libusb_transfer_status }
+ { length int }
+ { actual_length int }
+ { callback libusb_transfer_cb_fn }
+ { user_data void* }
+ { buffer uchar* }
+ { num_iso_packets int }
+ { iso_packet_desc libusb_iso_packet_descriptor[0] } ;
+
+FUNCTION: int libusb_init ( libusb_context** ctx ) ;
+FUNCTION: void libusb_exit ( libusb_context* ctx ) ;
+FUNCTION: void libusb_set_debug ( libusb_context* ctx, int level ) ;
+
+FUNCTION: ssize_t libusb_get_device_list ( libusb_context* ctx, libusb_device*** list ) ;
+FUNCTION: void libusb_free_device_list ( libusb_device** list, int unref_devices ) ;
+FUNCTION: libusb_device* libusb_ref_device ( libusb_device* dev ) ;
+FUNCTION: void libusb_unref_device ( libusb_device* dev ) ;
+
+FUNCTION: int libusb_get_configuration ( libusb_device_handle* dev, int* config ) ;
+FUNCTION: int libusb_get_device_descriptor ( libusb_device* dev, libusb_device_descriptor* desc ) ;
+FUNCTION: int libusb_get_active_config_descriptor ( libusb_device* dev, libusb_config_descriptor** config ) ;
+FUNCTION: int libusb_get_config_descriptor ( libusb_device* dev, uint8_t config_index, libusb_config_descriptor** config ) ;
+FUNCTION: int libusb_get_config_descriptor_by_value ( libusb_device* dev, uint8_t bConfigurationValue, libusb_config_descriptor** config ) ;
+FUNCTION: void libusb_free_config_descriptor ( libusb_config_descriptor* config ) ;
+FUNCTION: uint8_t libusb_get_bus_number ( libusb_device* dev ) ;
+FUNCTION: uint8_t libusb_get_device_address ( libusb_device* dev ) ;
+FUNCTION: int libusb_get_max_packet_size ( libusb_device* dev, uchar endpoint ) ;
+
+FUNCTION: int libusb_open ( libusb_device* dev, libusb_device_handle** handle ) ;
+FUNCTION: void libusb_close ( libusb_device_handle* dev_handle ) ;
+FUNCTION: libusb_device* libusb_get_device ( libusb_device_handle* dev_handle ) ;
+
+FUNCTION: int libusb_set_configuration ( libusb_device_handle* dev, int configuration ) ;
+FUNCTION: int libusb_claim_interface ( libusb_device_handle* dev, int iface ) ;
+FUNCTION: int libusb_release_interface ( libusb_device_handle* dev, int iface ) ;
+
+FUNCTION: libusb_device_handle* libusb_open_device_with_vid_pid ( libusb_context* ctx, uint16_t vendor_id, uint16_t product_id ) ;
+
+FUNCTION: int libusb_set_interface_alt_setting ( libusb_device_handle* dev, int interface_number, int alternate_setting ) ;
+FUNCTION: int libusb_clear_halt ( libusb_device_handle* dev, uchar endpoint ) ;
+FUNCTION: int libusb_reset_device ( libusb_device_handle* dev ) ;
+
+FUNCTION: int libusb_kernel_driver_active ( libusb_device_handle* dev, int interface ) ;
+FUNCTION: int libusb_detach_kernel_driver ( libusb_device_handle* dev, int interface ) ;
+FUNCTION: int libusb_attach_kernel_driver ( libusb_device_handle* dev, int interface ) ;
+
+: libusb_control_transfer_get_data ( transfer -- data )
+ buffer>> LIBUSB_CONTROL_SETUP_SIZE swap <displaced-alien> ; inline
+
+: libusb_control_transfer_get_setup ( transfer -- setup )
+ buffer>> libusb_control_setup memory>struct ; inline
+
+:: libusb_fill_control_setup ( buffer bmRequestType bRequest wValue wIndex wLength -- )
+ buffer libusb_control_setup memory>struct
+ bmRequestType >>bmRequestType
+ bRequest >>bRequest
+ wValue libusb_cpu_to_le16 >>wValue
+ wIndex libusb_cpu_to_le16 >>wIndex
+ wLength libusb_cpu_to_le16 >>wLength drop ; inline
+
+FUNCTION: libusb_transfer* libusb_alloc_transfer ( int iso_packets ) ;
+FUNCTION: int libusb_submit_transfer ( libusb_transfer* transfer ) ;
+FUNCTION: int libusb_cancel_transfer ( libusb_transfer* transfer ) ;
+FUNCTION: void libusb_free_transfer ( libusb_transfer* transfer ) ;
+
+:: libusb_fill_control_transfer ( transfer dev_handle buffer callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ 0 >>endpoint
+ LIBUSB_TRANSFER_TYPE_CONTROL >>type
+ timeout >>timeout
+ buffer >>buffer
+ user_data >>user_data
+ callback >>callback
+
+ buffer [
+ libusb_control_setup memory>struct wLength>> LIBUSB_CONTROL_SETUP_SIZE +
+ ] [ 0 ] if* >>length drop ; inline
+
+:: libusb_fill_bulk_transfer ( transfer dev_handle endpoint buffer length callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_BULK >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+:: libusb_fill_interrupt_transfer ( transfer dev_handle endpoint buffer length callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_INTERRUPT >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+:: libusb_fill_iso_transfer ( transfer dev_handle endpoint buffer length num_iso_packets callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_ISOCHRONOUS >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ num_iso_packets >>num_iso_packets
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+: libusb_set_iso_packet_lengths ( transfer length -- )
+ [ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array>
+ ] dip [ >>length drop ] curry each ; inline
+
+:: libusb_get_iso_packet_buffer ( transfer packet -- data )
+ packet transfer num_iso_packets>> >=
+ [ f ]
+ [
+ transfer
+ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array> 0
+ [ length>> + ] reduce
+ transfer buffer>> <displaced-alien>
+ ] if ;
+
+:: libusb_get_iso_packet_buffer_simple ( transfer packet -- data )
+ packet transfer num_iso_packets>> >=
+ [ f ]
+ [
+ 0 transfer
+ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array> nth
+ length>> packet *
+ transfer buffer>> <displaced-alien>
+ ] if ;
+
+FUNCTION: int libusb_control_transfer ( libusb_device_handle* dev_handle,
+ uint8_t request_type, uint8_t request, uint16_t value, uint16_t index,
+ uchar* data, uint16_t length, uint timeout ) ;
+
+FUNCTION: int libusb_bulk_transfer ( libusb_device_handle* dev_handle,
+ uchar endpoint, uchar* data, int length,
+ int* actual_length, uint timeout ) ;
+
+FUNCTION: int libusb_interrupt_transfer ( libusb_device_handle* dev_handle,
+ uchar endpoint, uchar* data, int length,
+ int* actual_length, int timeout ) ;
+
+:: libusb_get_descriptor ( dev desc_type desc_index data length -- int )
+ dev LIBUSB_ENDPOINT_IN LIBUSB_REQUEST_GET_DESCRIPTOR
+ desc_type 8 shift desc_index bitor 0 data
+ length 1000 libusb_control_transfer ; inline
+
+:: libusb_get_string_descriptor ( dev desc_index langid data length -- int )
+ dev LIBUSB_ENDPOINT_IN LIBUSB_REQUEST_GET_DESCRIPTOR
+ LIBUSB_DT_STRING 8 shift desc_index bitor
+ langid data length 1000 libusb_control_transfer ; inline
+
+FUNCTION: int libusb_get_string_descriptor_ascii ( libusb_device_handle* dev,
+ uint8_t index,
+ uchar* data,
+ int length ) ;
+
+FUNCTION: int libusb_try_lock_events ( libusb_context* ctx ) ;
+FUNCTION: void libusb_lock_events ( libusb_context* ctx ) ;
+FUNCTION: void libusb_unlock_events ( libusb_context* ctx ) ;
+FUNCTION: int libusb_event_handling_ok ( libusb_context* ctx ) ;
+FUNCTION: int libusb_event_handler_active ( libusb_context* ctx ) ;
+FUNCTION: void libusb_lock_event_waiters ( libusb_context* ctx ) ;
+FUNCTION: void libusb_unlock_event_waiters ( libusb_context* ctx ) ;
+FUNCTION: int libusb_wait_for_event ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_handle_events_timeout ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_handle_events ( libusb_context* ctx ) ;
+FUNCTION: int libusb_handle_events_locked ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_get_next_timeout ( libusb_context* ctx, timeval* tv ) ;
+
+STRUCT: libusb_pollfd
+ { fd int }
+ { events short } ;
+
+CALLBACK: void libusb_pollfd_added_cb ( int fd, short events, void* user_data ) ;
+CALLBACK: void libusb_pollfd_removed_cb ( int fd, void* user_data ) ;
+
+FUNCTION: libusb_pollfd** libusb_get_pollfds ( libusb_context* ctx ) ;
+FUNCTION: void libusb_set_pollfd_notifiers ( libusb_context* ctx,
+ libusb_pollfd_added_cb added_cb,
+ libusb_pollfd_removed_cb removed_cb,
+ void* user_data ) ;
--- /dev/null
+Bindings to libusb
bindings
-unportable
+untested
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax math ;
+IN: math.splines
+
+HELP: <bezier-curve>
+{ $values
+ { "control-points" "sequence of control points same dimension" }
+ { "polynomials" "sequence of polynomials for each dimension" }
+}
+{ $description "Creates bezier curve polynomials for the given control points." } ;
+
+HELP: <catmull-rom-spline>
+{ $values
+ { "points" "points on the spline" } { "m0" "initial tangent vector" } { "mn" "final tangent vector" }
+ { "polynomials-sequence" "sequence of sequences of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points and generating tangents for C1 continuity." } ;
+
+HELP: <cubic-hermite-curve>
+{ $values
+ { "p0" "start point" } { "m0" "start tangent" } { "p1" "end point" } { "m1" "end tangent" }
+ { "polynomials" "sequence of polynomials" }
+}
+{ $description "Creates a sequence of polynomials (one per dimension) for the curve passing through " { $emphasis "p0" } " and " { $emphasis "p1" } "." } ;
+
+HELP: <cubic-hermite-spline>
+{ $values
+ { "point-tangent-pairs" "sequence of point and tangent pairs" }
+ { "polynomials-sequence" "sequence of sequences of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points with the given tangents." } ;
+
+HELP: <kochanek-bartels-curve>
+{ $values
+ { "points" "points on the spline" } { "m0" "start tangent" } { "mn" "end tangent" } { "tension" number } { "bias" number } { "continuity" number }
+ { "polynomials-sequence" "sequence of sequence of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points, generating tangents with the given tuning parameters." } ;
+
+ARTICLE: "math.splines" "Common parametric curves."
+"The curve creating functions create sequences of polynomials, one for each degree of the input points. The spline creating functions create sequences of these curve polynomial sequences. The " { $vocab-link "math.splines.viewer" } " vocabulary provides a gadget to evaluate the generated polynomials and view the results.";
+
+ABOUT: "math.splines"
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel locals math math.combinatorics
+math.polynomials opengl.gl sequences ui.gadgets ui.gadgets.panes
+ui.render arrays grouping math.vectors assocs
+ui.gestures ;
+IN: math.splines
+
+<PRIVATE
+:: bernstein-polynomial-ith ( n i -- p )
+ n i nCk { 0 1 } i p^ { 1 -1 } n i - p^ p* n*p ;
+
+:: hermite-polynomial ( p0 m0 p1 m1 -- poly )
+ p0
+ m0
+ -3 p0 * -2 m0 * + 3 p1 * + m1 neg +
+ 2 p0 * m0 + -2 p1 * + m1 +
+ 4array ;
+
+:: kochanek-bartels-coefficients ( tension bias continuity -- s1 d1 s2 d2 )
+ 1 tension -
+ [
+ 1 bias +
+ [ 1 continuity + * * 2 / ]
+ [ 1 continuity - * * 2 / ] 2bi
+ ]
+ [
+ 1 bias -
+ [ 1 continuity - * * 2 / ]
+ [ 1 continuity + * * 2 / ] 2bi
+ ] bi ;
+
+:: kochanek-bartels-tangents ( points m0 mn c1 c2 -- tangents )
+ points 3 clump [
+ first3 :> ( pi-1 pi pi+1 )
+ pi pi-1 v- c1 v*n
+ pi+1 pi v- c2 v*n v+
+ ] map
+ m0 prefix
+ mn suffix ;
+PRIVATE>
+
+:: <bezier-curve> ( control-points -- polynomials )
+ control-points
+ [ length 1 - ]
+ [ first length [ { 0 } ] replicate ]
+ bi :> ( n acc )
+
+ control-points [| pt i |
+ n i bernstein-polynomial-ith :> poly
+ pt [| v j |
+ j acc [ v poly n*p p+ ] change-nth
+ ] each-index
+ ] each-index
+ acc ;
+
+:: <cubic-hermite-curve> ( p0 m0 p1 m1 -- polynomials )
+ p0 length iota [
+ {
+ [ p0 nth ] [ m0 nth ]
+ [ p1 nth ] [ m1 nth ]
+ } cleave
+ hermite-polynomial
+ ] map ;
+
+<PRIVATE
+: (cubic-hermite-spline) ( point-in-out-triplets -- polynomials-sequence )
+ 2 clump [
+ first2 [ first2 ] [ [ first ] [ third ] bi ] bi* <cubic-hermite-curve>
+ ] map ;
+PRIVATE>
+
+: <cubic-hermite-spline> ( point-tangent-pairs -- polynomials-sequence )
+ 2 clump [ first2 [ first2 ] bi@ <cubic-hermite-curve> ] map ;
+
+:: <kochanek-bartels-curve> ( points m0 mn tension bias continuity -- polynomials-sequence )
+ tension bias continuity kochanek-bartels-coefficients :> ( s1 d1 s2 d2 )
+ points m0 mn
+ [ s1 s2 kochanek-bartels-tangents ]
+ [ d1 d2 kochanek-bartels-tangents ] 3bi :> ( in out )
+ points in out [ 3array ] 3map (cubic-hermite-spline) ;
+
+: <catmull-rom-spline> ( points m0 mn -- polynomials-sequence )
+ 0 0 0 <kochanek-bartels-curve> ;
--- /dev/null
+Common parametric curves
--- /dev/null
+Erik Charlebois
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: locals math.splines math.splines.viewer arrays ;
+IN: math.splines.testing
+
+: test1 ( -- )
+ {
+ { { 0 0 } { 0 200 } }
+ { { 100 50 } { 0 -200 } }
+ { { 300 300 } { 500 200 } }
+ { { 400 400 } { 300 0 } }
+ } <cubic-hermite-spline> { 50 100 } 4 spline. ;
+
+: test2 ( -- )
+ {
+ { 50 50 }
+ { 100 100 }
+ { 300 200 }
+ { 350 0 }
+ { 400 400 }
+ } { 0 100 } { 100 0 } <catmull-rom-spline> { 100 50 } 50 spline. ;
+
+:: test3 ( x y z -- )
+ {
+ { 100 50 }
+ { 200 350 }
+ { 300 50 }
+ } { 0 100 } { 0 -100 } x y z <kochanek-bartels-curve> { 50 50 } 1000 spline. ;
+
+: test4 ( -- )
+ {
+ { 0 5 }
+ { 0.5 3 }
+ { 10 10 }
+ { 12 4 }
+ { 15 5 }
+ } <bezier-curve> 1array { 100 100 } 100 spline. ;
+
+: test-splines ( -- )
+ test1 test2
+ 1 0 0 test3
+ -1 0 0 test3
+ 0 1 0 test3
+ 0 -1 0 test3
+ 0 0 1 test3
+ 0 0 -1 test3
+ test4 ;
+
+
--- /dev/null
+Erik Charlebois
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals math math.order math.polynomials
+math.splines opengl.gl sequences ui.gadgets ui.gadgets.panes ui.render
+arrays ;
+IN: math.splines.viewer
+
+<PRIVATE
+: eval-polynomials ( polynomials-seq n -- xy-sequence )
+ [
+ [ 1 + iota ] keep [
+ /f swap [ polyval ] with map
+ ] curry with map
+ ] curry map concat ;
+PRIVATE>
+
+TUPLE: spline-gadget < gadget polynomials steps spline-dim ;
+
+M: spline-gadget pref-dim* spline-dim>> ;
+
+M:: spline-gadget draw-gadget* ( gadget -- )
+ 0 0 0 glColor3f
+
+ gadget [ polynomials>> ] [ steps>> ] bi eval-polynomials :> pts
+
+ pts [ first ] [ max ] map-reduce :> x-max
+ pts [ first ] [ min ] map-reduce :> x-min
+ pts [ second ] [ max ] map-reduce :> y-max
+ pts [ second ] [ min ] map-reduce :> y-min
+
+ pts [
+ [ first x-min - x-max x-min - / gadget spline-dim>> first * ]
+ [ second y-min - y-max y-min - / gadget spline-dim>> second * ] bi 2array
+ ] map :> pts
+
+ GL_LINE_STRIP glBegin
+ pts [
+ first2 neg gadget spline-dim>> second + glVertex2f
+ ] each
+ glEnd ;
+
+:: <spline-gadget> ( polynomials dim steps -- gadget )
+ spline-gadget new
+ dim >>spline-dim
+ polynomials >>polynomials
+ steps >>steps ;
+
+: spline. ( curve dim steps -- )
+ <spline-gadget> gadget. ;
IN: math.transforms.fft
HELP: fft
-{ $values { "seq" sequence } { "seq" sequence } }
+{ $values { "seq" sequence } { "seq'" sequence } }
{ $description "Fast Fourier transform function." } ;
: omega ( n -- n' )
recip -2 pi i* * * exp ;
-: twiddle ( seq -- seq )
+: twiddle ( seq -- seq' )
dup length [ omega ] [ n^v ] bi v* ;
PRIVATE>
DEFER: fft
-: two ( seq -- seq )
+: two ( seq -- seq' )
fft 2 v/n dup append ;
<PRIVATE
-: even ( seq -- seq ) 2 group 0 <column> ;
-: odd ( seq -- seq ) 2 group 1 <column> ;
+: even ( seq -- seq' ) 2 group 0 <column> ;
+: odd ( seq -- seq' ) 2 group 1 <column> ;
-: (fft) ( seq -- seq )
+: (fft) ( seq -- seq' )
[ odd two twiddle ] [ even two ] bi v+ ;
PRIVATE>
-: fft ( seq -- seq )
+: fft ( seq -- seq' )
dup length 1 = [ (fft) ] unless ;
IN: math.transforms.haar
HELP: haar
-{ $values { "seq" sequence } { "seq" sequence } }
+{ $values { "seq" sequence } { "seq'" sequence } }
{ $description "Haar wavelet transform function." }
{ $notes "The sequence length should be a power of two." }
{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 7 1 6 6 3 -5 4 2 } haar ." "{ 3 2 -1 -2 3 0 4 1 }" } } ;
HELP: rev-haar
-{ $values { "seq" sequence } { "seq" sequence } }
+{ $values { "seq" sequence } { "seq'" sequence } }
{ $description "Reverse Haar wavelet transform function." }
{ $notes "The sequence length should be a power of two." }
{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 3 2 -1 -2 3 0 4 1 } rev-haar ." "{ 7 1 6 6 3 -5 4 2 }" } } ;
<PRIVATE
-: averages ( seq -- seq )
+: averages ( seq -- seq' )
[ mean ] map ;
: differences ( seq averages -- differences )
PRIVATE>
-: haar ( seq -- seq )
+: haar ( seq -- seq' )
dup length 1 <= [ haar-step haar prepend ] unless ;
-: rev-haar ( seq -- seq )
+: rev-haar ( seq -- seq' )
dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ;
HELP: pile-align
{ $values
{ "pile" pile } { "align" "a power of two" }
- { "pile" pile }
}
{ $description "Adjusts a " { $link pile } "'s internal state so that the next call to " { $link pile-alloc } " will return a pointer aligned to " { $snippet "align" } " bytes relative to the pile's initial offset." } ;
+++ /dev/null
-unportable
-
HELP: >upsert
{ $values
{ "mdb-update-msg" "a mdb-update-msg" }
- { "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" }
}
{ $description "Marks a mdb-update-msg as upsert operation"
"(inserts object identified by the update selector if it doesn't exist in the collection)" } ;
{ $values
{ "mdb-query-msg" "a query" }
{ "index-hint" "a hint to an index" }
- { "mdb-query-msg" "modified query object" }
}
{ $description "Annotates the query with a hint to an index. "
"For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } }
{ $values
{ "mdb-query-msg" "a query" }
{ "limit#" "number of objects that should be returned at most" }
- { "mdb-query-msg" "modified query object" }
}
{ $description "Limits the number of returned objects to limit#" }
{ $examples
{ $values
{ "mdb-query-msg" "a query message" }
{ "skip#" "number of objects to skip" }
- { "mdb-query-msg" "annotated query message" }
}
{ $description "annotates a query message with a number of objects to skip when returning the results" } ;
{ $values
{ "mdb-query-msg" "a query message" }
{ "sort-quot" "a quotation with sort specifiers" }
- { "mdb-query-msg" "annotated query message" }
}
{ $description "annotates the query message for sort specifiers" } ;
+++ /dev/null
-unportable
-USING: classes.struct cocoa cocoa.application cocoa.classes
-cocoa.enumeration cocoa.plists core-foundation.strings kernel ;
+USING: alien.c-types classes.struct cocoa cocoa.application
+cocoa.classes cocoa.enumeration cocoa.plists core-foundation
+core-foundation.strings kernel ;
IN: qtkit
STRUCT: QTTime
+++ /dev/null
-unportable
HELP: run-spider
{ $values
- { "spider" spider }
{ "spider" spider } }
{ $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
+++ /dev/null
-unportable
projects / factor.git / commitdiff