Remove whitespace from end of lines.
Add a newline to the end of each file.
drop [ set-alien-cell ] ;
[ { c-string utf8 } c-string typedef ] with-compilation-unit
-
[ alien-unsigned-4 4 f byte-reverse 32 shift ]
[ 4 + alien-unsigned-4 4 f byte-reverse ] 2bi bitor
]
- ] dip [ [ 64 >signed ] compose ] when
+ ] dip [ [ 64 >signed ] compose ] when
>>getter drop
]
[ '[ [ [ _ _ byte-reverse ] 2dip ] prepose ] change-setter ] 3bi
SYNTAX: BE-PACKED-STRUCT:
parse-struct-definition
big-endian define-endian-packed-struct-class ;
-
M: macosx >deployed-library-path
file-name "@executable_path/../Frameworks" prepend-path ;
-
-USING: alien.c-types alien.prettyprint alien.syntax\r
-io.streams.string see tools.test prettyprint\r
-io.encodings.ascii ;\r
-IN: alien.prettyprint.tests\r
-\r
-CONSTANT: FOO 10\r
-\r
-FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;\r
-\r
-[ "USING: alien.c-types alien.syntax ;\r
-IN: alien.prettyprint.tests\r
-FUNCTION: int function_test\r
- ( float x, int[4][FOO] y, char* z, ushort* w ) ; inline\r
-" ] [\r
- [ \ function_test see ] with-string-writer\r
-] unit-test\r
-\r
-FUNCTION-ALIAS: function-test int function_test\r
- ( float x, int[4][FOO] y, char* z, ushort *w ) ;\r
-\r
-[ "USING: alien.c-types alien.syntax ;\r
-IN: alien.prettyprint.tests\r
-FUNCTION-ALIAS: function-test int function_test\r
- ( float x, int[4][FOO] y, char* z, ushort* w ) ; inline\r
-" ] [\r
- [ \ function-test see ] with-string-writer\r
-] unit-test\r
-\r
-TYPEDEF: c-string[ascii] string-typedef\r
-TYPEDEF: char[1][2][3] array-typedef\r
-\r
-[ "USING: alien.c-types alien.syntax ;\r
-IN: alien.prettyprint.tests\r
-TYPEDEF: c-string[ascii] string-typedef\r
-" ] [\r
- [ \ string-typedef see ] with-string-writer\r
-] unit-test\r
-\r
-[ "USING: alien.c-types alien.syntax ;\r
-IN: alien.prettyprint.tests\r
-TYPEDEF: char[1][2][3] array-typedef\r
-" ] [\r
- [ \ array-typedef see ] with-string-writer\r
-] unit-test\r
-\r
-C-TYPE: opaque-c-type\r
-\r
-[ "USING: alien.syntax ;\r
-IN: alien.prettyprint.tests\r
-C-TYPE: opaque-c-type\r
-" ] [\r
- [ \ opaque-c-type see ] with-string-writer\r
-] unit-test\r
-\r
-TYPEDEF: pointer: int pint\r
-\r
-[ "USING: alien.c-types alien.syntax ;\r
-IN: alien.prettyprint.tests\r
-TYPEDEF: int* pint\r
-" ] [\r
- [ \ pint see ] with-string-writer\r
-] unit-test\r
-\r
-[ "pointer: int" ] [ pointer: int unparse ] unit-test\r
-\r
-CALLBACK: void callback-test ( int x, float[4] y ) ;\r
-\r
-[ "USING: alien.c-types alien.syntax ;\r
-IN: alien.prettyprint.tests\r
-CALLBACK: void callback-test ( int x, float[4] y ) ;\r
-" ] [\r
- [ \ callback-test see ] with-string-writer\r
-] unit-test\r
+USING: alien.c-types alien.prettyprint alien.syntax
+io.streams.string see tools.test prettyprint
+io.encodings.ascii ;
+IN: alien.prettyprint.tests
+
+CONSTANT: FOO 10
+
+FUNCTION: int function_test ( float x, int[4][FOO] y, char* z, ushort *w ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+FUNCTION: int function_test
+ ( float x, int[4][FOO] y, char* z, ushort* w ) ; inline
+" ] [
+ [ \ function_test see ] with-string-writer
+] unit-test
+
+FUNCTION-ALIAS: function-test int function_test
+ ( float x, int[4][FOO] y, char* z, ushort *w ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+FUNCTION-ALIAS: function-test int function_test
+ ( float x, int[4][FOO] y, char* z, ushort* w ) ; inline
+" ] [
+ [ \ function-test see ] with-string-writer
+] unit-test
+
+TYPEDEF: c-string[ascii] string-typedef
+TYPEDEF: char[1][2][3] array-typedef
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+TYPEDEF: c-string[ascii] string-typedef
+" ] [
+ [ \ string-typedef see ] with-string-writer
+] unit-test
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+TYPEDEF: char[1][2][3] array-typedef
+" ] [
+ [ \ array-typedef see ] with-string-writer
+] unit-test
+
+C-TYPE: opaque-c-type
+
+[ "USING: alien.syntax ;
+IN: alien.prettyprint.tests
+C-TYPE: opaque-c-type
+" ] [
+ [ \ opaque-c-type see ] with-string-writer
+] unit-test
+
+TYPEDEF: pointer: int pint
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+TYPEDEF: int* pint
+" ] [
+ [ \ pint see ] with-string-writer
+] unit-test
+
+[ "pointer: int" ] [ pointer: int unparse ] unit-test
+
+CALLBACK: void callback-test ( int x, float[4] y ) ;
+
+[ "USING: alien.c-types alien.syntax ;
+IN: alien.prettyprint.tests
+CALLBACK: void callback-test ( int x, float[4] y ) ;
+" ] [
+ [ \ callback-test see ] with-string-writer
+] unit-test
[ def>> first first pprint-c-type ]
[ pprint-word ]
[
- <block "(" text
+ <block "(" text
[ def>> first second ] [ "callback-effect" word-prop in>> ] bi
pprint-function-args
")" text block>
-USING: help.markup help.syntax kernel strings ;\r
-IN: ascii\r
-\r
-HELP: blank?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for an ASCII whitespace character." } ;\r
-\r
-HELP: letter?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for a lowercase alphabet ASCII character." } ;\r
-\r
-HELP: LETTER?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for a uppercase alphabet ASCII character." } ;\r
-\r
-HELP: digit?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for an ASCII decimal digit character." } ;\r
-\r
-HELP: Letter?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;\r
-\r
-HELP: alpha?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for an alphanumeric ASCII character." } ;\r
-\r
-HELP: printable?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for a printable ASCII character." } ;\r
-\r
-HELP: control?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for an ASCII control character." } ;\r
-\r
-HELP: quotable?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;\r
-\r
-HELP: ascii?\r
-{ $values { "ch" "a character" } { "?" boolean } }\r
-{ $description "Tests for whether a number is an ASCII character." } ;\r
-\r
-HELP: ch>lower\r
-{ $values { "ch" "a character" } { "lower" "a character" } }\r
-{ $description "Converts an ASCII character to lower case." } ;\r
-\r
-HELP: ch>upper\r
-{ $values { "ch" "a character" } { "upper" "a character" } }\r
-{ $description "Converts an ASCII character to upper case." } ;\r
-\r
-HELP: >lower\r
-{ $values { "str" string } { "lower" string } }\r
-{ $description "Converts an ASCII string to lower case." } ;\r
-\r
-HELP: >upper\r
-{ $values { "str" string } { "upper" string } }\r
-{ $description "Converts an ASCII string to upper case." } ;\r
-\r
-HELP: >title\r
-{ $values { "str" string } { "title" string } }\r
-{ $description "Converts a string to title case." } ;\r
-\r
-HELP: >words\r
-{ $values { "str" string } { "words" "an array of slices" } }\r
-{ $description "Divides the string up into words." } ;\r
-\r
-HELP: capitalize\r
-{ $values { "str" string } { "str'" string } }\r
-{ $description "Capitalize all the words in a string." } ;\r
-\r
-ARTICLE: "ascii" "ASCII"\r
-"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."\r
-$nl\r
-"ASCII character classes:"\r
-{ $subsections\r
- blank?\r
- letter?\r
- LETTER?\r
- digit?\r
- printable?\r
- control?\r
- quotable?\r
- ascii?\r
-}\r
-"ASCII case conversion:"\r
-{ $subsections\r
- ch>lower\r
- ch>upper\r
- >lower\r
- >upper\r
- >title\r
-} ;\r
-\r
-ABOUT: "ascii"\r
+USING: help.markup help.syntax kernel strings ;
+IN: ascii
+
+HELP: blank?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for an ASCII whitespace character." } ;
+
+HELP: letter?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for a lowercase alphabet ASCII character." } ;
+
+HELP: LETTER?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for a uppercase alphabet ASCII character." } ;
+
+HELP: digit?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for an ASCII decimal digit character." } ;
+
+HELP: Letter?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ;
+
+HELP: alpha?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for an alphanumeric ASCII character." } ;
+
+HELP: printable?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for a printable ASCII character." } ;
+
+HELP: control?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for an ASCII control character." } ;
+
+HELP: quotable?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
+
+HELP: ascii?
+{ $values { "ch" "a character" } { "?" boolean } }
+{ $description "Tests for whether a number is an ASCII character." } ;
+
+HELP: ch>lower
+{ $values { "ch" "a character" } { "lower" "a character" } }
+{ $description "Converts an ASCII character to lower case." } ;
+
+HELP: ch>upper
+{ $values { "ch" "a character" } { "upper" "a character" } }
+{ $description "Converts an ASCII character to upper case." } ;
+
+HELP: >lower
+{ $values { "str" string } { "lower" string } }
+{ $description "Converts an ASCII string to lower case." } ;
+
+HELP: >upper
+{ $values { "str" string } { "upper" string } }
+{ $description "Converts an ASCII string to upper case." } ;
+
+HELP: >title
+{ $values { "str" string } { "title" string } }
+{ $description "Converts a string to title case." } ;
+
+HELP: >words
+{ $values { "str" string } { "words" "an array of slices" } }
+{ $description "Divides the string up into words." } ;
+
+HELP: capitalize
+{ $values { "str" string } { "str'" string } }
+{ $description "Capitalize all the words in a string." } ;
+
+ARTICLE: "ascii" "ASCII"
+"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
+$nl
+"ASCII character classes:"
+{ $subsections
+ blank?
+ letter?
+ LETTER?
+ digit?
+ printable?
+ control?
+ quotable?
+ ascii?
+}
+"ASCII case conversion:"
+{ $subsections
+ ch>lower
+ ch>upper
+ >lower
+ >upper
+ >title
+} ;
+
+ABOUT: "ascii"
-! Copyright (C) 2005, 2009 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: combinators.short-circuit hints kernel math math.order\r
-sequences strings ;\r
-IN: ascii\r
-\r
-: ascii? ( ch -- ? ) 0 127 between? ; inline\r
-: blank? ( ch -- ? ) " \t\n\r" member? ; inline\r
-: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline\r
-: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline\r
-: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline\r
-: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline\r
-: control? ( ch -- ? ) { [ 0 0x1F between? ] [ 0x7F = ] } 1|| ; inline\r
-: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline\r
-: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline\r
-: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline\r
-: ch>lower ( ch -- lower ) dup LETTER? [ 0x20 + ] when ; inline\r
-: >lower ( str -- lower ) [ ch>lower ] map ;\r
-: ch>upper ( ch -- upper ) dup letter? [ 0x20 - ] when ; inline\r
-: >upper ( str -- upper ) [ ch>upper ] map ;\r
-: >words ( str -- words )\r
- [ dup empty? not ] [\r
- dup [ blank? ] find drop\r
- [ [ 1 ] when-zero cut-slice swap ]\r
- [ f 0 rot [ length ] keep <slice> ] if*\r
- ] produce nip ;\r
-: capitalize ( str -- str' ) unclip [ >lower ] [ ch>upper ] bi* prefix ;\r
-: >title ( str -- title ) >words [ capitalize ] map concat ;\r
-\r
-HINTS: >lower string ;\r
-HINTS: >upper string ;\r
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit hints kernel math math.order
+sequences strings ;
+IN: ascii
+
+: ascii? ( ch -- ? ) 0 127 between? ; inline
+: blank? ( ch -- ? ) " \t\n\r" member? ; inline
+: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
+: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
+: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
+: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
+: control? ( ch -- ? ) { [ 0 0x1F between? ] [ 0x7F = ] } 1|| ; inline
+: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
+: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
+: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
+: ch>lower ( ch -- lower ) dup LETTER? [ 0x20 + ] when ; inline
+: >lower ( str -- lower ) [ ch>lower ] map ;
+: ch>upper ( ch -- upper ) dup letter? [ 0x20 - ] when ; inline
+: >upper ( str -- upper ) [ ch>upper ] map ;
+: >words ( str -- words )
+ [ dup empty? not ] [
+ dup [ blank? ] find drop
+ [ [ 1 ] when-zero cut-slice swap ]
+ [ f 0 rot [ length ] keep <slice> ] if*
+ ] produce nip ;
+: capitalize ( str -- str' ) unclip [ >lower ] [ ch>upper ] bi* prefix ;
+: >title ( str -- title ) >words [ capitalize ] map concat ;
+
+HINTS: >lower string ;
+HINTS: >upper string ;
! See http://factorcode.org/license.txt for BSD license.
USING: atk.ffi ;
IN: atk
-
-USING: help.markup help.syntax sequences ;\r
-IN: bit-vectors\r
-\r
-ARTICLE: "bit-vectors" "Bit vectors"\r
-"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."\r
-$nl\r
-"Bit vectors form a class:"\r
-{ $subsections\r
- bit-vector\r
- bit-vector?\r
-}\r
-"Creating bit vectors:"\r
-{ $subsections\r
- >bit-vector\r
- <bit-vector>\r
-}\r
-"Literal syntax:"\r
-{ $subsections POSTPONE: ?V{ }\r
-"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"\r
-{ $code "?V{ } clone" } ;\r
-\r
-ABOUT: "bit-vectors"\r
-\r
-HELP: bit-vector\r
-{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;\r
-\r
-HELP: <bit-vector>\r
-{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }\r
-{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;\r
-\r
-HELP: >bit-vector\r
-{ $values { "seq" sequence } { "vector" bit-vector } }\r
-{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;\r
-\r
-HELP: ?V{\r
-{ $syntax "?V{ elements... }" }\r
-{ $values { "elements" "a list of booleans" } }\r
-{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } \r
-{ $examples { $code "?V{ t f t }" } } ;\r
-\r
+USING: help.markup help.syntax sequences ;
+IN: bit-vectors
+
+ARTICLE: "bit-vectors" "Bit vectors"
+"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
+$nl
+"Bit vectors form a class:"
+{ $subsections
+ bit-vector
+ bit-vector?
+}
+"Creating bit vectors:"
+{ $subsections
+ >bit-vector
+ <bit-vector>
+}
+"Literal syntax:"
+{ $subsections POSTPONE: ?V{ }
+"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"
+{ $code "?V{ } clone" } ;
+
+ABOUT: "bit-vectors"
+
+HELP: bit-vector
+{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
+
+HELP: <bit-vector>
+{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
+{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
+
+HELP: >bit-vector
+{ $values { "seq" sequence } { "vector" bit-vector } }
+{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
+
+HELP: ?V{
+{ $syntax "?V{ elements... }" }
+{ $values { "elements" "a list of booleans" } }
+{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
+{ $examples { $code "?V{ t f t }" } } ;
+
-USING: tools.test bit-vectors vectors sequences kernel math ;\r
-IN: bit-vectors.tests\r
-\r
-[ 0 ] [ 123 <bit-vector> length ] unit-test\r
-\r
-: do-it ( seq -- )\r
- 1234 swap [ [ even? ] dip push ] curry each-integer ;\r
-\r
-[ t ] [\r
- 3 <bit-vector> dup do-it\r
- 3 <vector> dup do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ ?V{ } bit-vector? ] unit-test\r
+USING: tools.test bit-vectors vectors sequences kernel math ;
+IN: bit-vectors.tests
+
+[ 0 ] [ 123 <bit-vector> length ] unit-test
+
+: do-it ( seq -- )
+ 1234 swap [ [ even? ] dip push ] curry each-integer ;
+
+[ t ] [
+ 3 <bit-vector> dup do-it
+ 3 <vector> dup do-it sequence=
+] unit-test
+
+[ t ] [ ?V{ } bit-vector? ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable bit-arrays prettyprint.custom\r
-parser accessors vectors.functor classes.parser ;\r
-IN: bit-vectors\r
-\r
-<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>\r
-\r
-SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;\r
-\r
-M: bit-vector contract 2drop ;\r
-M: bit-vector >pprint-sequence ;\r
-M: bit-vector pprint-delims drop \ ?V{ \ } ;\r
-M: bit-vector pprint* pprint-object ;\r
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math sequences
+sequences.private growable bit-arrays prettyprint.custom
+parser accessors vectors.functor classes.parser ;
+IN: bit-vectors
+
+<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
+
+SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
+
+M: bit-vector contract 2drop ;
+M: bit-vector >pprint-sequence ;
+M: bit-vector pprint-delims drop \ ?V{ \ } ;
+M: bit-vector pprint* pprint-object ;
-USING: vocabs.loader vocabs kernel ;\r
-IN: bootstrap.handbook\r
-\r
-{ "bootstrap.handbook" "bootstrap.help" } "help.handbook" require-when\r
+USING: vocabs.loader vocabs kernel ;
+IN: bootstrap.handbook
+
+{ "bootstrap.handbook" "bootstrap.help" } "help.handbook" require-when
-USE: unicode
\ No newline at end of file
+USE: unicode
-USING: help.markup help.syntax kernel ;\r
-IN: boxes\r
-\r
-HELP: box\r
-{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ;\r
-\r
-HELP: <box>\r
-{ $values { "box" box } }\r
-{ $description "Creates a new empty box." } ;\r
-\r
-HELP: >box\r
-{ $values { "value" object } { "box" box } }\r
-{ $description "Stores a value into a box." }\r
-{ $errors "Throws an error if the box is full." } ;\r
-\r
-HELP: box>\r
-{ $values { "box" box } { "value" "the value of the box" } }\r
-{ $description "Removes a value from a box." }\r
-{ $errors "Throws an error if the box is empty." } ;\r
-\r
-HELP: ?box\r
-{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" boolean } }\r
-{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;\r
-\r
-ARTICLE: "boxes" "Boxes"\r
-"A " { $emphasis "box" } " is a container which can either be empty or hold a single value."\r
-{ $subsections box }\r
-"Creating an empty box:"\r
-{ $subsections <box> }\r
-"Storing a value and removing a value from a box:"\r
-{ $subsections\r
- >box\r
- box>\r
-}\r
-"Safely removing a value:"\r
-{ $subsections ?box }\r
-"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ;\r
-\r
-ABOUT: "boxes"\r
+USING: help.markup help.syntax kernel ;
+IN: boxes
+
+HELP: box
+{ $class-description "A data type holding a single value in the " { $snippet "value" } " slot. The " { $snippet "occupied" } " slot indicates if the value is set." } ;
+
+HELP: <box>
+{ $values { "box" box } }
+{ $description "Creates a new empty box." } ;
+
+HELP: >box
+{ $values { "value" object } { "box" box } }
+{ $description "Stores a value into a box." }
+{ $errors "Throws an error if the box is full." } ;
+
+HELP: box>
+{ $values { "box" box } { "value" "the value of the box" } }
+{ $description "Removes a value from a box." }
+{ $errors "Throws an error if the box is empty." } ;
+
+HELP: ?box
+{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" boolean } }
+{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;
+
+ARTICLE: "boxes" "Boxes"
+"A " { $emphasis "box" } " is a container which can either be empty or hold a single value."
+{ $subsections box }
+"Creating an empty box:"
+{ $subsections <box> }
+"Storing a value and removing a value from a box:"
+{ $subsections
+ >box
+ box>
+}
+"Safely removing a value:"
+{ $subsections ?box }
+"Testing if a box is full can be done by reading the " { $snippet "occupied" } " slot." ;
+
+ABOUT: "boxes"
-USING: boxes namespaces tools.test accessors ;\r
-IN: boxes.tests\r
-\r
-[ ] [ <box> "b" set ] unit-test\r
-\r
-[ ] [ 3 "b" get >box ] unit-test\r
-\r
-[ t ] [ "b" get occupied>> ] unit-test\r
-\r
-[ 4 "b" >box ] must-fail\r
-\r
-[ 3 ] [ "b" get box> ] unit-test\r
-\r
-[ f ] [ "b" get occupied>> ] unit-test\r
-\r
-[ "b" get box> ] must-fail\r
-\r
-[ f f ] [ "b" get ?box ] unit-test\r
-\r
-[ ] [ 12 "b" get >box ] unit-test\r
-\r
-[ 12 t ] [ "b" get ?box ] unit-test\r
-\r
-[ f ] [ "b" get occupied>> ] unit-test\r
+USING: boxes namespaces tools.test accessors ;
+IN: boxes.tests
+
+[ ] [ <box> "b" set ] unit-test
+
+[ ] [ 3 "b" get >box ] unit-test
+
+[ t ] [ "b" get occupied>> ] unit-test
+
+[ 4 "b" >box ] must-fail
+
+[ 3 ] [ "b" get box> ] unit-test
+
+[ f ] [ "b" get occupied>> ] unit-test
+
+[ "b" get box> ] must-fail
+
+[ f f ] [ "b" get ?box ] unit-test
+
+[ ] [ 12 "b" get >box ] unit-test
+
+[ 12 t ] [ "b" get ?box ] unit-test
+
+[ f ] [ "b" get occupied>> ] unit-test
-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors ;\r
-IN: boxes\r
-\r
-TUPLE: box value occupied ;\r
-\r
-: <box> ( -- box ) box new ;\r
-\r
-ERROR: box-full box ;\r
-\r
-: >box ( value box -- )\r
- dup occupied>>\r
- [ box-full ] [ t >>occupied value<< ] if ; inline\r
-\r
-ERROR: box-empty box ;\r
-\r
-: check-box ( box -- box )\r
- dup occupied>> [ box-empty ] unless ; inline\r
-\r
-<PRIVATE\r
-\r
-: box-unsafe> ( box -- value )\r
- [ f ] change-value f >>occupied drop ; inline\r
-\r
-PRIVATE>\r
-\r
-: box> ( box -- value )\r
- check-box box-unsafe> ; inline\r
-\r
-: ?box ( box -- value/f ? )\r
- dup occupied>> [ box-unsafe> t ] [ drop f f ] if ; inline\r
-\r
-: if-box? ( box quot -- )\r
- [ ?box ] dip [ drop ] if ; inline\r
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors ;
+IN: boxes
+
+TUPLE: box value occupied ;
+
+: <box> ( -- box ) box new ;
+
+ERROR: box-full box ;
+
+: >box ( value box -- )
+ dup occupied>>
+ [ box-full ] [ t >>occupied value<< ] if ; inline
+
+ERROR: box-empty box ;
+
+: check-box ( box -- box )
+ dup occupied>> [ box-empty ] unless ; inline
+
+<PRIVATE
+
+: box-unsafe> ( box -- value )
+ [ f ] change-value f >>occupied drop ; inline
+
+PRIVATE>
+
+: box> ( box -- value )
+ check-box box-unsafe> ; inline
+
+: ?box ( box -- value/f ? )
+ dup occupied>> [ box-unsafe> t ] [ drop f f ] if ; inline
+
+: if-box? ( box quot -- )
+ [ ?box ] dip [ drop ] if ; inline
-USING: cache tools.test accessors destructors kernel assocs\r
-namespaces ;\r
-IN: cache.tests\r
-\r
-TUPLE: mock-disposable < disposable n ;\r
-\r
-: <mock-disposable> ( n -- mock-disposable )\r
- mock-disposable new-disposable swap >>n ;\r
-\r
-M: mock-disposable dispose* drop ;\r
-\r
-[ ] [ <cache-assoc> "cache" set ] unit-test\r
-\r
-[ 0 ] [ "cache" get assoc-size ] unit-test\r
-\r
-[ ] [ "cache" get 2 >>max-age drop ] unit-test\r
-\r
-[ ] [ 1 <mock-disposable> dup "a" set 2 "cache" get set-at ] unit-test\r
-\r
-[ 1 ] [ "cache" get assoc-size ] unit-test\r
-\r
-[ ] [ "cache" get purge-cache ] unit-test\r
-\r
-[ ] [ 2 <mock-disposable> 3 "cache" get set-at ] unit-test\r
-\r
-[ 2 ] [ "cache" get assoc-size ] unit-test\r
-\r
-[ ] [ "cache" get purge-cache ] unit-test\r
-\r
-[ 1 ] [ "cache" get assoc-size ] unit-test\r
-\r
-[ ] [ 3 <mock-disposable> dup "b" set 4 "cache" get set-at ] unit-test\r
-\r
-[ 2 ] [ "cache" get assoc-size ] unit-test\r
-\r
-[ ] [ "cache" get purge-cache ] unit-test\r
-\r
-[ 1 ] [ "cache" get assoc-size ] unit-test\r
-\r
-[ f ] [ 2 "cache" get key? ] unit-test\r
-\r
-[ 3 ] [ 4 "cache" get at n>> ] unit-test\r
-\r
-[ t ] [ "a" get disposed>> ] unit-test\r
-\r
-[ f ] [ "b" get disposed>> ] unit-test\r
-\r
-[ ] [ "cache" get clear-assoc ] unit-test\r
-\r
-[ t ] [ "b" get disposed>> ] unit-test\r
+USING: cache tools.test accessors destructors kernel assocs
+namespaces ;
+IN: cache.tests
+
+TUPLE: mock-disposable < disposable n ;
+
+: <mock-disposable> ( n -- mock-disposable )
+ mock-disposable new-disposable swap >>n ;
+
+M: mock-disposable dispose* drop ;
+
+[ ] [ <cache-assoc> "cache" set ] unit-test
+
+[ 0 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ "cache" get 2 >>max-age drop ] unit-test
+
+[ ] [ 1 <mock-disposable> dup "a" set 2 "cache" get set-at ] unit-test
+
+[ 1 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ "cache" get purge-cache ] unit-test
+
+[ ] [ 2 <mock-disposable> 3 "cache" get set-at ] unit-test
+
+[ 2 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ "cache" get purge-cache ] unit-test
+
+[ 1 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ 3 <mock-disposable> dup "b" set 4 "cache" get set-at ] unit-test
+
+[ 2 ] [ "cache" get assoc-size ] unit-test
+
+[ ] [ "cache" get purge-cache ] unit-test
+
+[ 1 ] [ "cache" get assoc-size ] unit-test
+
+[ f ] [ 2 "cache" get key? ] unit-test
+
+[ 3 ] [ 4 "cache" get at n>> ] unit-test
+
+[ t ] [ "a" get disposed>> ] unit-test
+
+[ f ] [ "b" get disposed>> ] unit-test
+
+[ ] [ "cache" get clear-assoc ] unit-test
+
+[ t ] [ "b" get disposed>> ] unit-test
{ y double }
{ width double }
{ height double } ;
-
+
STRUCT: cairo_rectangle_list_t
{ status cairo_status_t }
{ rectangles cairo_rectangle_t* }
FUNCTION: cairo_font_type_t
cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
-FUNCTION: void*
+FUNCTION: void*
cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
FUNCTION: cairo_font_type_t
cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
-FUNCTION: void*
+FUNCTION: void*
cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
{ type cairo_path_data_type_t }
{ length int } ;
-UNION-STRUCT: cairo_path_data_t
+UNION-STRUCT: cairo_path_data_t
{ point cairo_path_data_t-point }
{ header cairo_path_data_t-header } ;
FUNCTION: cairo_status_t
cairo_status ( cairo_t* cr ) ;
-FUNCTION: c-string
+FUNCTION: c-string
cairo_status_to_string ( cairo_status_t status ) ;
! Surface manipulation
FUNCTION: cairo_status_t
cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
-FUNCTION: void*
+FUNCTION: void*
cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
PRIVATE>
-CONSTANT: month-names
+CONSTANT: month-names
{
"January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"
-! Copyright (C) 2008, 2010 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar namespaces models threads kernel init ;\r
-IN: calendar.model\r
-\r
-SYMBOL: time\r
-\r
-: (time-thread) ( -- )\r
- now time get set-model\r
- 1 seconds sleep (time-thread) ;\r
-\r
-: time-thread ( -- )\r
- [\r
- init-namespaces\r
- (time-thread)\r
- ] "Time model update" spawn drop ;\r
-\r
-[\r
- f <model> time set-global\r
- time-thread\r
-] "calendar.model" add-startup-hook\r
+! Copyright (C) 2008, 2010 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar namespaces models threads kernel init ;
+IN: calendar.model
+
+SYMBOL: time
+
+: (time-thread) ( -- )
+ now time get set-model
+ 1 seconds sleep (time-thread) ;
+
+: time-thread ( -- )
+ [
+ init-namespaces
+ (time-thread)
+ ] "Time model update" spawn drop ;
+
+[
+ f <model> time set-global
+ time-thread
+] "calendar.model" add-startup-hook
: (counter) ( channel n -- )
[ swap to ] 2keep 1 + (counter) ;
-
+
: counter ( channel -- )
- 2 (counter) ;
+ 2 (counter) ;
: counter-test ( -- n1 n2 n3 )
- <channel> dup [ counter ] curry "Counter" spawn drop
+ <channel> dup [ counter ] curry "Counter" spawn drop
[ from ] keep [ from ] keep from ;
: filter ( send prime recv -- )
#! filters out all those divisible by 'prime',
#! and sends to the 'recv' channel.
[
- from swap dupd mod zero? not [ swap to ] [ 2drop ] if
+ from swap dupd mod zero? not [ swap to ] [ 2drop ] if
] 3keep filter ;
:: (sieve) ( prime c -- )
[ newc p c filter ] "Filter" spawn drop
prime newc (sieve) ;
-: sieve ( prime -- )
+: sieve ( prime -- )
#! Send prime numbers to 'prime' channel
<channel> dup [ counter ] curry "Counter" spawn drop
(sieve) ;
: sieve-test ( -- seq )
<channel> dup [ sieve ] curry "Sieve" spawn drop
- V{ } clone swap
+ V{ } clone swap
[ from swap push ] 2keep
[ from swap push ] 2keep
[ from swap push ] 2keep
: unpublish ( id -- )
remote-channels delete-at ;
-
+
<PRIVATE
MATCH-VARS: ?from ?tag ?id ?value ;
: start-channel-node ( -- )
"remote-channels" get-remote-thread [
[ channel-thread t ] "Remote channels" spawn-server
- "remote-channels" register-remote-thread
+ "remote-channels" register-remote-thread
] unless ;
PRIVATE>
TUPLE: remote-channel node id ;
-C: <remote-channel> remote-channel
+C: <remote-channel> remote-channel
<PRIVATE
: send-message ( message remote-channel -- value )
- node>> "remote-channels" <remote-thread>
+ node>> "remote-channels" <remote-thread>
send-synchronous dup no-channel = [ no-channel throw ] when* ;
-
+
PRIVATE>
M: remote-channel to ( value remote-channel -- )
drop 2 <groups> [ le> ] map-sum
[ -16 shift ] [ 0xffff bitand ] bi +
[ -16 shift ] keep + bitnot 2 >le ;
-
CONSTANT: K-384
{
- 0x428a2f98d728ae22 0x7137449123ef65cd 0xb5c0fbcfec4d3b2f 0xe9b5dba58189dbbc
- 0x3956c25bf348b538 0x59f111f1b605d019 0x923f82a4af194f9b 0xab1c5ed5da6d8118
+ 0x428a2f98d728ae22 0x7137449123ef65cd 0xb5c0fbcfec4d3b2f 0xe9b5dba58189dbbc
+ 0x3956c25bf348b538 0x59f111f1b605d019 0x923f82a4af194f9b 0xab1c5ed5da6d8118
0xd807aa98a3030242 0x12835b0145706fbe 0x243185be4ee4b28c 0x550c7dc3d5ffb4e2
- 0x72be5d74f27b896f 0x80deb1fe3b1696b1 0x9bdc06a725c71235 0xc19bf174cf692694
- 0xe49b69c19ef14ad2 0xefbe4786384f25e3 0x0fc19dc68b8cd5b5 0x240ca1cc77ac9c65
- 0x2de92c6f592b0275 0x4a7484aa6ea6e483 0x5cb0a9dcbd41fbd4 0x76f988da831153b5
- 0x983e5152ee66dfab 0xa831c66d2db43210 0xb00327c898fb213f 0xbf597fc7beef0ee4
- 0xc6e00bf33da88fc2 0xd5a79147930aa725 0x06ca6351e003826f 0x142929670a0e6e70
- 0x27b70a8546d22ffc 0x2e1b21385c26c926 0x4d2c6dfc5ac42aed 0x53380d139d95b3df
- 0x650a73548baf63de 0x766a0abb3c77b2a8 0x81c2c92e47edaee6 0x92722c851482353b
- 0xa2bfe8a14cf10364 0xa81a664bbc423001 0xc24b8b70d0f89791 0xc76c51a30654be30
- 0xd192e819d6ef5218 0xd69906245565a910 0xf40e35855771202a 0x106aa07032bbd1b8
- 0x19a4c116b8d2d0c8 0x1e376c085141ab53 0x2748774cdf8eeb99 0x34b0bcb5e19b48a8
- 0x391c0cb3c5c95a63 0x4ed8aa4ae3418acb 0x5b9cca4f7763e373 0x682e6ff3d6b2b8a3
- 0x748f82ee5defb2fc 0x78a5636f43172f60 0x84c87814a1f0ab72 0x8cc702081a6439ec
- 0x90befffa23631e28 0xa4506cebde82bde9 0xbef9a3f7b2c67915 0xc67178f2e372532b
- 0xca273eceea26619c 0xd186b8c721c0c207 0xeada7dd6cde0eb1e 0xf57d4f7fee6ed178
- 0x06f067aa72176fba 0x0a637dc5a2c898a6 0x113f9804bef90dae 0x1b710b35131c471b
- 0x28db77f523047d84 0x32caab7b40c72493 0x3c9ebe0a15c9bebc 0x431d67c49c100d4c
+ 0x72be5d74f27b896f 0x80deb1fe3b1696b1 0x9bdc06a725c71235 0xc19bf174cf692694
+ 0xe49b69c19ef14ad2 0xefbe4786384f25e3 0x0fc19dc68b8cd5b5 0x240ca1cc77ac9c65
+ 0x2de92c6f592b0275 0x4a7484aa6ea6e483 0x5cb0a9dcbd41fbd4 0x76f988da831153b5
+ 0x983e5152ee66dfab 0xa831c66d2db43210 0xb00327c898fb213f 0xbf597fc7beef0ee4
+ 0xc6e00bf33da88fc2 0xd5a79147930aa725 0x06ca6351e003826f 0x142929670a0e6e70
+ 0x27b70a8546d22ffc 0x2e1b21385c26c926 0x4d2c6dfc5ac42aed 0x53380d139d95b3df
+ 0x650a73548baf63de 0x766a0abb3c77b2a8 0x81c2c92e47edaee6 0x92722c851482353b
+ 0xa2bfe8a14cf10364 0xa81a664bbc423001 0xc24b8b70d0f89791 0xc76c51a30654be30
+ 0xd192e819d6ef5218 0xd69906245565a910 0xf40e35855771202a 0x106aa07032bbd1b8
+ 0x19a4c116b8d2d0c8 0x1e376c085141ab53 0x2748774cdf8eeb99 0x34b0bcb5e19b48a8
+ 0x391c0cb3c5c95a63 0x4ed8aa4ae3418acb 0x5b9cca4f7763e373 0x682e6ff3d6b2b8a3
+ 0x748f82ee5defb2fc 0x78a5636f43172f60 0x84c87814a1f0ab72 0x8cc702081a6439ec
+ 0x90befffa23631e28 0xa4506cebde82bde9 0xbef9a3f7b2c67915 0xc67178f2e372532b
+ 0xca273eceea26619c 0xd186b8c721c0c207 0xeada7dd6cde0eb1e 0xf57d4f7fee6ed178
+ 0x06f067aa72176fba 0x0a637dc5a2c898a6 0x113f9804bef90dae 0x1b710b35131c471b
+ 0x28db77f523047d84 0x32caab7b40c72493 0x3c9ebe0a15c9bebc 0x431d67c49c100d4c
0x4cc5d4becb3e42b6 0x597f299cfc657e2a 0x5fcb6fab3ad6faec 0x6c44198c4a475817
}
FUNCTION: SEL method_getName ( Method method ) ;
-FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
-FUNCTION: void* method_getImplementation ( Method method ) ;
+FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
+FUNCTION: void* method_getImplementation ( Method method ) ;
FUNCTION: Class object_getClass ( id object ) ;
: output>array ( quot -- array )
{ } output>sequence ; inline
-
+
: cleave>array ( obj quots -- array )
'[ _ cleave ] output>array ; inline
output-stream get [ stream-flush ] when*
0 exit ;
-
SYMBOL: +unordered+
SYMBOLS:
- cc< cc<= cc= cc> cc>= cc<> cc<>=
+ cc< cc<= cc= cc> cc>= cc<> cc<>=
cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ;
SYMBOLS:
{ cc= cc/= }
{ cc<> cc/<> }
{ cc<>= cc/<>= }
- { cc/< cc< }
+ { cc/< cc< }
{ cc/<= cc<= }
{ cc/> cc> }
- { cc/>= cc>= }
- { cc/= cc= }
- { cc/<> cc<> }
+ { cc/>= cc>= }
+ { cc/= cc= }
+ { cc/<> cc<> }
{ cc/<>= cc<>= }
{ cc-o cc/o }
{ cc/o cc-o }
{ cc= cc= }
{ cc<> cc/= }
{ cc<>= t }
- { cc/< cc>= }
+ { cc/< cc>= }
{ cc/<= cc> }
{ cc/> cc<= }
- { cc/>= cc< }
- { cc/= cc/= }
- { cc/<> cc= }
+ { cc/>= cc< }
+ { cc/= cc/= }
+ { cc/<> cc= }
{ cc/<>= f }
} at ;
{ cc/<> { +eq+ +unordered+ } }
{ cc/<>= { +unordered+ } }
} at member-eq? ;
-
: narray-quot ( length -- quot )
[
[ , [ f <array> ] % ]
- [
+ [
dup iota [
- 1 - , [ swap [ set-array-nth ] keep ] %
] with each
M: ##xor-vector vector-not-src
dup src1>> vreg>insn ##fill-vector? [ src2>> ] [ src1>> ] if ;
-M: ##and-vector rewrite
+M: ##and-vector rewrite
{
{ [ dup src1>> vreg>insn vector-not? ] [
{
{ quot [ user-init-errors get-global values ] }
{ forget-quot [ user-init-errors get-global delete-at ] }
} define-error-type
-
-USING: tools.test compiler.units classes.mixin definitions\r
-kernel kernel.private ;\r
-IN: compiler.tests.redefine25\r
-\r
-MIXIN: empty-mixin\r
-\r
-: empty-mixin-test-1 ( a -- ? ) empty-mixin? ;\r
-\r
-TUPLE: a-superclass ;\r
-\r
-: empty-mixin-test-2 ( a -- ? ) { a-superclass } declare empty-mixin? ;\r
-\r
-TUPLE: empty-mixin-member < a-superclass ;\r
-\r
-[ f ] [ empty-mixin-member new empty-mixin? ] unit-test\r
-[ f ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test\r
-[ f ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test\r
-\r
-[ ] [\r
- [\r
- \ empty-mixin-member \ empty-mixin add-mixin-instance\r
- ] with-compilation-unit\r
-] unit-test\r
-\r
-[ t ] [ empty-mixin-member new empty-mixin? ] unit-test\r
-[ t ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test\r
-[ t ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test\r
-\r
-[ ] [\r
- [\r
- \ empty-mixin forget\r
- \ empty-mixin-member forget\r
- \ empty-mixin-test-1 forget\r
- \ empty-mixin-test-2 forget\r
- ] with-compilation-unit\r
-] unit-test\r
+USING: tools.test compiler.units classes.mixin definitions
+kernel kernel.private ;
+IN: compiler.tests.redefine25
+
+MIXIN: empty-mixin
+
+: empty-mixin-test-1 ( a -- ? ) empty-mixin? ;
+
+TUPLE: a-superclass ;
+
+: empty-mixin-test-2 ( a -- ? ) { a-superclass } declare empty-mixin? ;
+
+TUPLE: empty-mixin-member < a-superclass ;
+
+[ f ] [ empty-mixin-member new empty-mixin? ] unit-test
+[ f ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test
+[ f ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test
+
+[ ] [
+ [
+ \ empty-mixin-member \ empty-mixin add-mixin-instance
+ ] with-compilation-unit
+] unit-test
+
+[ t ] [ empty-mixin-member new empty-mixin? ] unit-test
+[ t ] [ empty-mixin-member new empty-mixin-test-1 ] unit-test
+[ t ] [ empty-mixin-member new empty-mixin-test-2 ] unit-test
+
+[ ] [
+ [
+ \ empty-mixin forget
+ \ empty-mixin-member forget
+ \ empty-mixin-test-1 forget
+ \ empty-mixin-test-2 forget
+ ] with-compilation-unit
+] unit-test
mark-live-values
compute-live-values
(remove-dead-code) ;
-
TUPLE: shuffle-node { effect effect } ;
M: shuffle-node pprint* effect>> effect>string text ;
-
+
: (shuffle-effect) ( in out #shuffle -- effect )
mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
compute-def-use
remove-dead-code
compute-def-use
- optimize-modular-arithmetic
+ optimize-modular-arithmetic
] with-scope ;
: inlined? ( quot seq/word -- ? )
dup word>> {
{ [ 2dup foldable-call? ] [ fold-call ] }
{ [ 2dup do-inlining ] [
- [ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
+ [ output-value-infos ] [ drop out-d>> ] 2bi refine-value-infos
] }
[
[ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
-! Copyright (C) 2009 Marc Fauconneau.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays assocs fry\r
-hashtables io kernel locals math math.order math.parser\r
-math.ranges multiline sequences bitstreams bit-arrays ;\r
-IN: compression.huffman\r
-\r
-QUALIFIED-WITH: bitstreams bs\r
-\r
-<PRIVATE\r
-\r
-TUPLE: huffman-code\r
- { value fixnum }\r
- { size fixnum }\r
- { code fixnum } ;\r
-\r
-: <huffman-code> ( -- huffman-code )\r
- 0 0 0 huffman-code boa ; inline\r
-\r
-: next-size ( huffman-code -- )\r
- [ 1 + ] change-size\r
- [ 2 * ] change-code drop ; inline\r
-\r
-: next-code ( huffman-code -- )\r
- [ 1 + ] change-code drop ; inline\r
-\r
-:: all-patterns ( huffman-code n -- seq )\r
- n log2 huffman-code size>> - :> free-bits\r
- free-bits 0 >\r
- [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]\r
- [ huffman-code code>> free-bits neg 2^ /i 1array ] if ;\r
-\r
-:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )\r
- <huffman-code> :> code\r
- tdesc\r
- [\r
- code next-size\r
- [ code value<< code clone quot call code next-code ] each\r
- ] each ; inline\r
-\r
-: update-reverse-table ( huffman-code n table -- )\r
- [ drop all-patterns ]\r
- [ nip '[ _ swap _ set-at ] each ] 3bi ;\r
-\r
-:: reverse-table ( tdesc n -- rtable )\r
- n f <array> <enum> :> table\r
- tdesc [ n table update-reverse-table ] huffman-each\r
- table seq>> ;\r
-\r
-PRIVATE>\r
-\r
-TUPLE: huffman-decoder\r
- { bs bit-reader }\r
- { tdesc array }\r
- { rtable array }\r
- { bits/level fixnum } ;\r
-\r
-: <huffman-decoder> ( bs tdesc -- huffman-decoder )\r
- huffman-decoder new\r
- swap >>tdesc\r
- swap >>bs\r
- 16 >>bits/level\r
- dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline\r
-\r
-: read1-huff ( huffman-decoder -- elt )\r
- 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi\r
- [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline\r
-\r
-: reverse-bits ( value bits -- value' )\r
- [ integer>bit-array ] dip\r
- f pad-tail reverse bit-array>integer ; inline\r
-\r
-: read1-huff2 ( huffman-decoder -- elt )\r
- 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi\r
- [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline\r
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs fry
+hashtables io kernel locals math math.order math.parser
+math.ranges multiline sequences bitstreams bit-arrays ;
+IN: compression.huffman
+
+QUALIFIED-WITH: bitstreams bs
+
+<PRIVATE
+
+TUPLE: huffman-code
+ { value fixnum }
+ { size fixnum }
+ { code fixnum } ;
+
+: <huffman-code> ( -- huffman-code )
+ 0 0 0 huffman-code boa ; inline
+
+: next-size ( huffman-code -- )
+ [ 1 + ] change-size
+ [ 2 * ] change-code drop ; inline
+
+: next-code ( huffman-code -- )
+ [ 1 + ] change-code drop ; inline
+
+:: all-patterns ( huffman-code n -- seq )
+ n log2 huffman-code size>> - :> free-bits
+ free-bits 0 >
+ [ free-bits 2^ iota [ huffman-code code>> free-bits 2^ * + ] map ]
+ [ huffman-code code>> free-bits neg 2^ /i 1array ] if ;
+
+:: huffman-each ( ... tdesc quot: ( ... huffman-code -- ... ) -- ... )
+ <huffman-code> :> code
+ tdesc
+ [
+ code next-size
+ [ code value<< code clone quot call code next-code ] each
+ ] each ; inline
+
+: update-reverse-table ( huffman-code n table -- )
+ [ drop all-patterns ]
+ [ nip '[ _ swap _ set-at ] each ] 3bi ;
+
+:: reverse-table ( tdesc n -- rtable )
+ n f <array> <enum> :> table
+ tdesc [ n table update-reverse-table ] huffman-each
+ table seq>> ;
+
+PRIVATE>
+
+TUPLE: huffman-decoder
+ { bs bit-reader }
+ { tdesc array }
+ { rtable array }
+ { bits/level fixnum } ;
+
+: <huffman-decoder> ( bs tdesc -- huffman-decoder )
+ huffman-decoder new
+ swap >>tdesc
+ swap >>bs
+ 16 >>bits/level
+ dup [ tdesc>> ] [ bits/level>> 2^ ] bi reverse-table >>rtable ; inline
+
+: read1-huff ( huffman-decoder -- elt )
+ 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi
+ [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
+
+: reverse-bits ( value bits -- value' )
+ [ integer>bit-array ] dip
+ f pad-tail reverse bit-array>integer ; inline
+
+: read1-huff2 ( huffman-decoder -- elt )
+ 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi
+ [ size>> swap bs>> bs:seek ] [ value>> ] bi ; inline
:: decode-huffman-tables ( bitstream -- tables )
5 bitstream bs:read 257 +
5 bitstream bs:read 1 +
- 4 bitstream bs:read 4 + clen-shuffle swap head
+ 4 bitstream bs:read 4 + clen-shuffle swap head
dup length [ 3 bitstream bs:read ] replicate
get-table
[ sp next 8hi-lo 2array <repetition> concat ] [ head ] bi
[ j matrix i swap nth copy ] [ length j + j! ] bi
] if
-
+
! j stride >= [ i 1 + i! 0 j! ] when
j stride >= [ 0 j! ] when
done? not
] [
sp next <array> [ j matrix i swap nth copy ] [ length j + j! ] bi
] if
-
+
! j stride >= [ i 1 + i! 0 j! ] when
j stride >= [ 0 j! ] when
done? not
size_t* result ) ;
FUNCTION: snappy_status snappy_validate_compressed_buffer ( char* compressed,
- size_t compressed_length ) ;
-
+ size_t compressed_length ) ;
over
dup length 0 size_t <ref>
[ snappy_uncompressed_length check-snappy ] keep
- size_t deref
+ size_t deref
n>outs
[ snappy_uncompress check-snappy ] 2keep drop >byte-array ;
-
-USING: help.markup help.syntax sequences ;\r
-IN: concurrency.combinators\r
-\r
-HELP: parallel-map\r
-{ $values { "seq" sequence } { "quot" { $quotation ( elt -- newelt ) } } { "newseq" sequence } }\r
-{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }\r
-{ $errors "Throws an error if one of the iterations throws an error." } ;\r
-\r
-HELP: 2parallel-map\r
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- newelt ) } } { "newseq" sequence } }\r
-{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }\r
-{ $errors "Throws an error if one of the iterations throws an error." } ;\r
-\r
-HELP: parallel-each\r
-{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ) } } }\r
-{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }\r
-{ $errors "Throws an error if one of the iterations throws an error." } ;\r
-\r
-HELP: 2parallel-each\r
-{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- ) } } }\r
-{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }\r
-{ $errors "Throws an error if one of the iterations throws an error." } ;\r
-\r
-HELP: parallel-filter\r
-{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ? ) } } { "newseq" sequence } }\r
-{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }\r
-{ $errors "Throws an error if one of the iterations throws an error." } ;\r
-\r
-ARTICLE: "concurrency.combinators" "Concurrent combinators"\r
-"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators."\r
-$nl\r
-"Concurrent sequence combinators:"\r
-{ $subsections\r
- parallel-each\r
- 2parallel-each\r
- parallel-map\r
- 2parallel-map\r
- parallel-filter\r
-}\r
-"Concurrent product sequence combinators:"\r
-{ $subsections\r
- parallel-product-each\r
- parallel-cartesian-each\r
- parallel-product-map\r
- parallel-cartesian-map\r
-}\r
-"Concurrent cleave combinators:"\r
-{ $subsections\r
- parallel-cleave\r
- parallel-spread\r
- parallel-napply\r
-}\r
-"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjunction with the above combinators to limit the maximum number of concurrent operations." ;\r
-\r
-ABOUT: "concurrency.combinators"\r
+USING: help.markup help.syntax sequences ;
+IN: concurrency.combinators
+
+HELP: parallel-map
+{ $values { "seq" sequence } { "quot" { $quotation ( elt -- newelt ) } } { "newseq" sequence } }
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
+{ $errors "Throws an error if one of the iterations throws an error." } ;
+
+HELP: 2parallel-map
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- newelt ) } } { "newseq" sequence } }
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
+{ $errors "Throws an error if one of the iterations throws an error." } ;
+
+HELP: parallel-each
+{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ) } } }
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
+{ $errors "Throws an error if one of the iterations throws an error." } ;
+
+HELP: 2parallel-each
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation ( elt1 elt2 -- ) } } }
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
+{ $errors "Throws an error if one of the iterations throws an error." } ;
+
+HELP: parallel-filter
+{ $values { "seq" sequence } { "quot" { $quotation ( elt -- ? ) } } { "newseq" sequence } }
+{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
+{ $errors "Throws an error if one of the iterations throws an error." } ;
+
+ARTICLE: "concurrency.combinators" "Concurrent combinators"
+"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of various combinators."
+$nl
+"Concurrent sequence combinators:"
+{ $subsections
+ parallel-each
+ 2parallel-each
+ parallel-map
+ 2parallel-map
+ parallel-filter
+}
+"Concurrent product sequence combinators:"
+{ $subsections
+ parallel-product-each
+ parallel-cartesian-each
+ parallel-product-map
+ parallel-cartesian-map
+}
+"Concurrent cleave combinators:"
+{ $subsections
+ parallel-cleave
+ parallel-spread
+ parallel-napply
+}
+"The " { $vocab-link "concurrency.semaphores" } " vocabulary can be used in conjunction with the above combinators to limit the maximum number of concurrent operations." ;
+
+ABOUT: "concurrency.combinators"
-USING: concurrency.combinators tools.test random kernel math \r
-concurrency.mailboxes threads sequences accessors arrays\r
-math.parser ;\r
-IN: concurrency.combinators.tests\r
-\r
-[ [ drop ] parallel-each ] must-infer\r
-{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as\r
-[ [ ] parallel-map ] must-infer\r
-{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as\r
-[ [ ] parallel-filter ] must-infer\r
-\r
-[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test\r
-\r
-[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test\r
-\r
-[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]\r
-[ error>> "Even" = ] must-fail-with\r
-\r
-[ V{ 0 3 6 9 } ]\r
-[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test\r
-\r
-[ 10 ]\r
-[\r
- V{ } clone\r
- 10 iota over [ push ] curry parallel-each\r
- length\r
-] unit-test\r
-\r
-[ { 10 20 30 } ] [\r
- { 1 4 3 } { 10 5 10 } [ * ] 2parallel-map\r
-] unit-test\r
-\r
-[ { -9 -1 -7 } ] [\r
- { 1 4 3 } { 10 5 10 } [ - ] 2parallel-map\r
-] unit-test\r
-\r
-[\r
- { 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each\r
-] must-fail\r
-\r
-[ 20 ]\r
-[\r
- V{ } clone\r
- 10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each\r
- length\r
-] unit-test\r
-\r
-[ { f } [ "OOPS" throw ] parallel-each ] must-fail\r
-\r
-[ "1a" "4b" "3c" ] [\r
- 2\r
- { [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave\r
- [ number>string ] 3 parallel-napply\r
- { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread\r
-] unit-test\r
-\r
-{ H{ { 0 4 } { 2 6 } { 4 8 } } } [\r
- H{ { 1 2 } { 3 4 } { 5 6 } } [\r
- [ 1 - ] [ 2 + ] bi*\r
- ] parallel-assoc-map\r
-] unit-test\r
+USING: concurrency.combinators tools.test random kernel math
+concurrency.mailboxes threads sequences accessors arrays
+math.parser ;
+IN: concurrency.combinators.tests
+
+[ [ drop ] parallel-each ] must-infer
+{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
+[ [ ] parallel-map ] must-infer
+{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as
+[ [ ] parallel-filter ] must-infer
+
+[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
+
+[ { 1 4 9 } ] [ { 1 2 3 } [ 1000000 random sleep sq ] parallel-map ] unit-test
+
+[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]
+[ error>> "Even" = ] must-fail-with
+
+[ V{ 0 3 6 9 } ]
+[ 10 iota [ 3 mod zero? ] parallel-filter ] unit-test
+
+[ 10 ]
+[
+ V{ } clone
+ 10 iota over [ push ] curry parallel-each
+ length
+] unit-test
+
+[ { 10 20 30 } ] [
+ { 1 4 3 } { 10 5 10 } [ * ] 2parallel-map
+] unit-test
+
+[ { -9 -1 -7 } ] [
+ { 1 4 3 } { 10 5 10 } [ - ] 2parallel-map
+] unit-test
+
+[
+ { 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each
+] must-fail
+
+[ 20 ]
+[
+ V{ } clone
+ 10 iota 10 iota pick [ [ push ] [ push ] bi ] curry 2parallel-each
+ length
+] unit-test
+
+[ { f } [ "OOPS" throw ] parallel-each ] must-fail
+
+[ "1a" "4b" "3c" ] [
+ 2
+ { [ 1 - ] [ sq ] [ 1 + ] } parallel-cleave
+ [ number>string ] 3 parallel-napply
+ { [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread
+] unit-test
+
+{ H{ { 0 4 } { 2 6 } { 4 8 } } } [
+ H{ { 1 2 } { 3 4 } { 5 6 } } [
+ [ 1 - ] [ 2 + ] bi*
+ ] parallel-assoc-map
+] unit-test
-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: deques threads kernel arrays sequences timers fry ;\r
-IN: concurrency.conditions\r
-\r
-: notify-1 ( deque -- )\r
- dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline\r
-\r
-: notify-all ( deque -- )\r
- [ resume-now ] slurp-deque ; inline\r
-\r
-: queue-timeout ( queue timeout -- timer )\r
- #! Add an timer which removes the current thread from the\r
- #! queue, and resumes it, passing it a value of t.\r
- [\r
- [ self swap push-front* ] keep '[\r
- _ _\r
- [ delete-node ] [ drop node-value ] 2bi\r
- t swap resume-with\r
- ]\r
- ] dip later ;\r
-\r
-ERROR: timed-out-error timer ;\r
-\r
-: queue ( queue -- )\r
- [ self ] dip push-front ; inline\r
-\r
-: wait ( queue timeout status -- )\r
- over [\r
- [ queue-timeout ] dip suspend\r
- [ timed-out-error ] [ stop-timer ] if\r
- ] [\r
- [ drop queue ] dip suspend drop\r
- ] if ; inline\r
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: deques threads kernel arrays sequences timers fry ;
+IN: concurrency.conditions
+
+: notify-1 ( deque -- )
+ dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline
+
+: notify-all ( deque -- )
+ [ resume-now ] slurp-deque ; inline
+
+: queue-timeout ( queue timeout -- timer )
+ #! Add an timer which removes the current thread from the
+ #! queue, and resumes it, passing it a value of t.
+ [
+ [ self swap push-front* ] keep '[
+ _ _
+ [ delete-node ] [ drop node-value ] 2bi
+ t swap resume-with
+ ]
+ ] dip later ;
+
+ERROR: timed-out-error timer ;
+
+: queue ( queue -- )
+ [ self ] dip push-front ; inline
+
+: wait ( queue timeout status -- )
+ over [
+ [ queue-timeout ] dip suspend
+ [ timed-out-error ] [ stop-timer ] if
+ ] [
+ [ drop queue ] dip suspend drop
+ ] if ; inline
-USING: help.markup help.syntax sequences ;\r
-IN: concurrency.count-downs\r
-\r
-HELP: <count-down>\r
-{ $values { "n" "a non-negative integer" } { "count-down" count-down } }\r
-{ $description "Creates a new count-down latch." } \r
-{ $errors "Throws an error if the count is lower than zero." } ;\r
-\r
-HELP: count-down\r
-{ $values { "count-down" count-down } }\r
-{ $description "Decrements a count-down latch. If it reaches zero, all threads blocking on " { $link await } " are notified." }\r
-{ $errors "Throws an error if an attempt is made to decrement the count lower than zero." } ;\r
-\r
-HELP: await\r
-{ $values { "count-down" count-down } }\r
-{ $description "Waits until the count-down value reaches zero." } ;\r
-\r
-ARTICLE: "concurrency.count-downs" "Count-down latches"\r
-"The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, which is a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero."\r
-{ $subsections\r
- <count-down>\r
- count-down\r
- await\r
-}\r
-"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ;\r
-\r
-ABOUT: "concurrency.count-downs"\r
+USING: help.markup help.syntax sequences ;
+IN: concurrency.count-downs
+
+HELP: <count-down>
+{ $values { "n" "a non-negative integer" } { "count-down" count-down } }
+{ $description "Creates a new count-down latch." }
+{ $errors "Throws an error if the count is lower than zero." } ;
+
+HELP: count-down
+{ $values { "count-down" count-down } }
+{ $description "Decrements a count-down latch. If it reaches zero, all threads blocking on " { $link await } " are notified." }
+{ $errors "Throws an error if an attempt is made to decrement the count lower than zero." } ;
+
+HELP: await
+{ $values { "count-down" count-down } }
+{ $description "Waits until the count-down value reaches zero." } ;
+
+ARTICLE: "concurrency.count-downs" "Count-down latches"
+"The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, which is a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero."
+{ $subsections
+ <count-down>
+ count-down
+ await
+}
+"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ;
+
+ABOUT: "concurrency.count-downs"
-USING: concurrency.count-downs threads kernel tools.test ;\r
-IN: concurrency.count-downs.tests`\r
-\r
-[ ] [ 0 <count-down> await ] unit-test\r
-\r
-[ 1 <count-down> dup count-down count-down ] must-fail\r
-\r
-[ ] [\r
- 1 <count-down>\r
- 3 <count-down>\r
- 2dup [ await count-down ] 2curry "Master" spawn drop\r
- dup [ count-down ] curry "Slave" spawn drop\r
- dup [ count-down ] curry "Slave" spawn drop\r
- dup [ count-down ] curry "Slave" spawn drop\r
- drop await\r
-] unit-test\r
+USING: concurrency.count-downs threads kernel tools.test ;
+IN: concurrency.count-downs.tests`
+
+[ ] [ 0 <count-down> await ] unit-test
+
+[ 1 <count-down> dup count-down count-down ] must-fail
+
+[ ] [
+ 1 <count-down>
+ 3 <count-down>
+ 2dup [ await count-down ] 2curry "Master" spawn drop
+ dup [ count-down ] curry "Slave" spawn drop
+ dup [ count-down ] curry "Slave" spawn drop
+ dup [ count-down ] curry "Slave" spawn drop
+ drop await
+] unit-test
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: dlists kernel math concurrency.promises\r
-concurrency.mailboxes accessors fry ;\r
-IN: concurrency.count-downs\r
-\r
-! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html\r
-\r
-TUPLE: count-down-tuple n promise ;\r
-\r
-: count-down-check ( count-down -- )\r
- dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;\r
-\r
-ERROR: invalid-count-down-count count ;\r
-\r
-: <count-down> ( n -- count-down )\r
- dup 0 < [ invalid-count-down-count ] when\r
- <promise> \ count-down-tuple boa\r
- dup count-down-check ;\r
-\r
-ERROR: count-down-already-done ;\r
-\r
-: count-down ( count-down -- )\r
- dup n>> dup zero?\r
- [ count-down-already-done ]\r
- [ 1 - >>n count-down-check ] if ;\r
-\r
-: await-timeout ( count-down timeout -- )\r
- [ promise>> ] dip ?promise-timeout ?linked t assert= ;\r
-\r
-: await ( count-down -- )\r
- f await-timeout ;\r
-\r
-: spawn-stage ( quot count-down -- )\r
- [ '[ @ _ count-down ] ] keep\r
- "Count down stage"\r
- swap promise>> mailbox>> spawn-linked-to drop ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: dlists kernel math concurrency.promises
+concurrency.mailboxes accessors fry ;
+IN: concurrency.count-downs
+
+! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
+
+TUPLE: count-down-tuple n promise ;
+
+: count-down-check ( count-down -- )
+ dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
+
+ERROR: invalid-count-down-count count ;
+
+: <count-down> ( n -- count-down )
+ dup 0 < [ invalid-count-down-count ] when
+ <promise> \ count-down-tuple boa
+ dup count-down-check ;
+
+ERROR: count-down-already-done ;
+
+: count-down ( count-down -- )
+ dup n>> dup zero?
+ [ count-down-already-done ]
+ [ 1 - >>n count-down-check ] if ;
+
+: await-timeout ( count-down timeout -- )
+ [ promise>> ] dip ?promise-timeout ?linked t assert= ;
+
+: await ( count-down -- )
+ f await-timeout ;
+
+: spawn-stage ( quot count-down -- )
+ [ '[ @ _ count-down ] ] keep
+ "Count down stage"
+ swap promise>> mailbox>> spawn-linked-to drop ;
-USING: help.markup help.syntax sequences kernel ;\r
-IN: concurrency.exchangers\r
-\r
-HELP: exchanger\r
-{ $class-description "The class of object exchange points." } ;\r
-\r
-HELP: <exchanger>\r
-{ $values { "exchanger" exchanger } }\r
-{ $description "Creates a new object exchange point." } ;\r
-\r
-HELP: exchange\r
-{ $values { "obj" object } { "exchanger" exchanger } { "newobj" object } }\r
-{ $description "Waits for another thread to call " { $link exchange } " on the same exchanger. The thread's call to " { $link exchange } " returns with " { $snippet "obj" } " on the stack, and the object passed to " { $link exchange } " by the other thread is left on the current's thread stack as " { $snippet "newobj" } "." } ;\r
-\r
-ARTICLE: "concurrency.exchangers" "Object exchange points"\r
-"The " { $vocab-link "concurrency.exchangers" } " vocabulary implements " { $emphasis "object exchange points" } ", which are rendezvous points where two threads can exchange objects."\r
-{ $subsections\r
- exchanger\r
- <exchanger>\r
- exchange\r
-}\r
-"One use-case is two threads, where one thread reads data into a buffer and another thread processes the data. The reader thread can begin by reading the data, then passing the buffer through an exchanger, then recursing. The processing thread can begin by creating an empty buffer, and exchanging it through the exchanger. It then processes the result and recurses."\r
-$nl\r
-"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ;\r
-\r
-ABOUT: "concurrency.exchangers"\r
+USING: help.markup help.syntax sequences kernel ;
+IN: concurrency.exchangers
+
+HELP: exchanger
+{ $class-description "The class of object exchange points." } ;
+
+HELP: <exchanger>
+{ $values { "exchanger" exchanger } }
+{ $description "Creates a new object exchange point." } ;
+
+HELP: exchange
+{ $values { "obj" object } { "exchanger" exchanger } { "newobj" object } }
+{ $description "Waits for another thread to call " { $link exchange } " on the same exchanger. The thread's call to " { $link exchange } " returns with " { $snippet "obj" } " on the stack, and the object passed to " { $link exchange } " by the other thread is left on the current's thread stack as " { $snippet "newobj" } "." } ;
+
+ARTICLE: "concurrency.exchangers" "Object exchange points"
+"The " { $vocab-link "concurrency.exchangers" } " vocabulary implements " { $emphasis "object exchange points" } ", which are rendezvous points where two threads can exchange objects."
+{ $subsections
+ exchanger
+ <exchanger>
+ exchange
+}
+"One use-case is two threads, where one thread reads data into a buffer and another thread processes the data. The reader thread can begin by reading the data, then passing the buffer through an exchanger, then recursing. The processing thread can begin by creating an empty buffer, and exchanging it through the exchanger. It then processes the result and recurses."
+$nl
+"The vocabulary was modelled after a similar feature in Java's " { $snippet "java.util.concurrent" } " library." ;
+
+ABOUT: "concurrency.exchangers"
-USING: tools.test concurrency.exchangers\r
-concurrency.count-downs concurrency.promises locals kernel\r
-threads ;\r
-FROM: sequences => 3append ;\r
-IN: concurrency.exchangers.tests\r
-\r
-:: exchanger-test ( -- string )\r
- <exchanger> :> ex\r
- 2 <count-down> :> c\r
- f :> v1!\r
- f :> v2!\r
- <promise> :> pr\r
-\r
- [\r
- c await\r
- v1 ", " v2 3append pr fulfill\r
- ] "Awaiter" spawn drop\r
-\r
- [\r
- "Goodbye world" ex exchange v1! c count-down\r
- ] "Exchanger 1" spawn drop\r
-\r
- [\r
- "Hello world" ex exchange v2! c count-down\r
- ] "Exchanger 2" spawn drop\r
-\r
- pr ?promise ;\r
-\r
-[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test\r
+USING: tools.test concurrency.exchangers
+concurrency.count-downs concurrency.promises locals kernel
+threads ;
+FROM: sequences => 3append ;
+IN: concurrency.exchangers.tests
+
+:: exchanger-test ( -- string )
+ <exchanger> :> ex
+ 2 <count-down> :> c
+ f :> v1!
+ f :> v2!
+ <promise> :> pr
+
+ [
+ c await
+ v1 ", " v2 3append pr fulfill
+ ] "Awaiter" spawn drop
+
+ [
+ "Goodbye world" ex exchange v1! c count-down
+ ] "Exchanger 1" spawn drop
+
+ [
+ "Hello world" ex exchange v2! c count-down
+ ] "Exchanger 2" spawn drop
+
+ pr ?promise ;
+
+[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test
-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel threads boxes accessors fry ;\r
-IN: concurrency.exchangers\r
-\r
-! Motivated by\r
-! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/Exchanger.html\r
-\r
-TUPLE: exchanger thread object ;\r
-\r
-: <exchanger> ( -- exchanger )\r
- <box> <box> exchanger boa ;\r
-\r
-: exchange ( obj exchanger -- newobj )\r
- dup thread>> occupied>> [\r
- dup object>> box>\r
- [ thread>> box> resume-with ] dip\r
- ] [\r
- [ object>> >box ] keep\r
- [ self ] dip thread>> >box\r
- "exchange" suspend\r
- ] if ;\r
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel threads boxes accessors fry ;
+IN: concurrency.exchangers
+
+! Motivated by
+! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/Exchanger.html
+
+TUPLE: exchanger thread object ;
+
+: <exchanger> ( -- exchanger )
+ <box> <box> exchanger boa ;
+
+: exchange ( obj exchanger -- newobj )
+ dup thread>> occupied>> [
+ dup object>> box>
+ [ thread>> box> resume-with ] dip
+ ] [
+ [ object>> >box ] keep
+ [ self ] dip thread>> >box
+ "exchange" suspend
+ ] if ;
-USING: tools.test concurrency.flags concurrency.combinators\r
-kernel threads locals accessors calendar ;\r
-IN: concurrency.flags.tests\r
-\r
-:: flag-test-1 ( -- val )\r
- <flag> :> f\r
- [ f raise-flag ] "Flag test" spawn drop\r
- f lower-flag\r
- f value>> ;\r
-\r
-[ f ] [ flag-test-1 ] unit-test\r
-\r
-:: flag-test-2 ( -- ? )\r
- <flag> :> f\r
- [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
- f lower-flag\r
- f value>> ;\r
-\r
-[ f ] [ flag-test-2 ] unit-test\r
-\r
-:: flag-test-3 ( -- val )\r
- <flag> :> f\r
- f raise-flag\r
- f value>> ;\r
-\r
-[ t ] [ flag-test-3 ] unit-test\r
-\r
-:: flag-test-4 ( -- val )\r
- <flag> :> f\r
- [ f raise-flag ] "Flag test" spawn drop\r
- f wait-for-flag\r
- f value>> ;\r
-\r
-[ t ] [ flag-test-4 ] unit-test\r
-\r
-:: flag-test-5 ( -- val )\r
- <flag> :> f\r
- [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
- f wait-for-flag\r
- f value>> ;\r
-\r
-[ t ] [ flag-test-5 ] unit-test\r
-\r
-[ ] [\r
- { 1 2 } <flag>\r
- [ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ]\r
- [ [ wait-for-flag drop ] curry parallel-each ] bi\r
-] unit-test\r
+USING: tools.test concurrency.flags concurrency.combinators
+kernel threads locals accessors calendar ;
+IN: concurrency.flags.tests
+
+:: flag-test-1 ( -- val )
+ <flag> :> f
+ [ f raise-flag ] "Flag test" spawn drop
+ f lower-flag
+ f value>> ;
+
+[ f ] [ flag-test-1 ] unit-test
+
+:: flag-test-2 ( -- ? )
+ <flag> :> f
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
+ f lower-flag
+ f value>> ;
+
+[ f ] [ flag-test-2 ] unit-test
+
+:: flag-test-3 ( -- val )
+ <flag> :> f
+ f raise-flag
+ f value>> ;
+
+[ t ] [ flag-test-3 ] unit-test
+
+:: flag-test-4 ( -- val )
+ <flag> :> f
+ [ f raise-flag ] "Flag test" spawn drop
+ f wait-for-flag
+ f value>> ;
+
+[ t ] [ flag-test-4 ] unit-test
+
+:: flag-test-5 ( -- val )
+ <flag> :> f
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
+ f wait-for-flag
+ f value>> ;
+
+[ t ] [ flag-test-5 ] unit-test
+
+[ ] [
+ { 1 2 } <flag>
+ [ [ 1 seconds sleep raise-flag ] curry "Flag test" spawn drop ]
+ [ [ wait-for-flag drop ] curry parallel-each ] bi
+] unit-test
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: concurrency.promises concurrency.messaging kernel arrays\r
-continuations help.markup help.syntax quotations calendar ;\r
-IN: concurrency.futures\r
-\r
-HELP: future\r
-{ $values { "quot" { $quotation ( -- value ) } } { "future" future } }\r
-{ $description "Creates a deferred computation."\r
-$nl\r
-"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ;\r
-\r
-HELP: ?future-timeout\r
-{ $values { "future" future } { "timeout" { $maybe duration } } { "value" object } }\r
-{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to the " { $snippet "timeout" } " before throwing an error." }\r
-{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ;\r
-\r
-HELP: ?future\r
-{ $values { "future" future } { "value" object } }\r
-{ $description "Waits for a deferred computation to complete, blocking indefinitely." }\r
-{ $errors "Throws an error if future quotation threw an error." } ;\r
-\r
-ARTICLE: "concurrency.futures" "Futures"\r
-"The " { $vocab-link "concurrency.futures" } " vocabulary implements " { $emphasis "futures" } ", which are deferred computations performed in a background thread. A thread may create a future, then proceed to perform other tasks, then later wait for the future to complete."\r
-{ $subsections\r
- future\r
- ?future\r
- ?future-timeout\r
-} ;\r
-\r
-ABOUT: "concurrency.futures"\r
+! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.promises concurrency.messaging kernel arrays
+continuations help.markup help.syntax quotations calendar ;
+IN: concurrency.futures
+
+HELP: future
+{ $values { "quot" { $quotation ( -- value ) } } { "future" future } }
+{ $description "Creates a deferred computation."
+$nl
+"The quotation begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the quotation is to partially apply the data, for example using " { $link curry } " or " { $link compose } "." } ;
+
+HELP: ?future-timeout
+{ $values { "future" future } { "timeout" { $maybe duration } } { "value" object } }
+{ $description "Waits for a deferred computation to complete, blocking indefinitely if " { $snippet "timeout" } " is " { $link f } ", otherwise waiting up to the " { $snippet "timeout" } " before throwing an error." }
+{ $errors "Throws an error if the timeout expires before the computation completes. Also throws an error if the future quotation threw an error." } ;
+
+HELP: ?future
+{ $values { "future" future } { "value" object } }
+{ $description "Waits for a deferred computation to complete, blocking indefinitely." }
+{ $errors "Throws an error if future quotation threw an error." } ;
+
+ARTICLE: "concurrency.futures" "Futures"
+"The " { $vocab-link "concurrency.futures" } " vocabulary implements " { $emphasis "futures" } ", which are deferred computations performed in a background thread. A thread may create a future, then proceed to perform other tasks, then later wait for the future to complete."
+{ $subsections
+ future
+ ?future
+ ?future-timeout
+} ;
+
+ABOUT: "concurrency.futures"
-USING: concurrency.futures kernel tools.test threads ;\r
-IN: concurrency.futures.tests\r
-\r
-[ 50 ] [\r
- [ 50 ] future ?future\r
-] unit-test\r
-\r
-[\r
- [ "this should propogate" throw ] future ?future \r
-] must-fail\r
-\r
-[ ] [\r
- [ "this should not propogate" throw ] future drop \r
-] unit-test\r
-\r
-! Race condition with futures\r
-[ 3 3 ] [\r
- [ 3 ] future\r
- dup ?future swap ?future\r
-] unit-test\r
-\r
-! Another race\r
-[ 3 ] [\r
- [ 3 yield ] future ?future\r
-] unit-test\r
+USING: concurrency.futures kernel tools.test threads ;
+IN: concurrency.futures.tests
+
+[ 50 ] [
+ [ 50 ] future ?future
+] unit-test
+
+[
+ [ "this should propogate" throw ] future ?future
+] must-fail
+
+[ ] [
+ [ "this should not propogate" throw ] future drop
+] unit-test
+
+! Race condition with futures
+[ 3 3 ] [
+ [ 3 ] future
+ dup ?future swap ?future
+] unit-test
+
+! Another race
+[ 3 ] [
+ [ 3 yield ] future ?future
+] unit-test
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: concurrency.promises concurrency.mailboxes kernel arrays\r
-continuations accessors fry ;\r
-IN: concurrency.futures\r
-\r
-: future ( quot -- future )\r
- <promise> [\r
- [ '[ @ _ fulfill ] "Future" ] keep\r
- mailbox>> spawn-linked-to drop\r
- ] keep ; inline\r
-\r
-: ?future-timeout ( future timeout -- value )\r
- ?promise-timeout ?linked ;\r
-\r
-: ?future ( future -- value )\r
- ?promise ?linked ;\r
+! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.promises concurrency.mailboxes kernel arrays
+continuations accessors fry ;
+IN: concurrency.futures
+
+: future ( quot -- future )
+ <promise> [
+ [ '[ @ _ fulfill ] "Future" ] keep
+ mailbox>> spawn-linked-to drop
+ ] keep ; inline
+
+: ?future-timeout ( future timeout -- value )
+ ?promise-timeout ?linked ;
+
+: ?future ( future -- value )
+ ?promise ?linked ;
-USING: help.markup help.syntax sequences kernel quotations\r
-calendar ;\r
-IN: concurrency.locks\r
-\r
-HELP: lock\r
-{ $class-description "The class of mutual exclusion locks." } ;\r
-\r
-HELP: <lock>\r
-{ $values { "lock" lock } }\r
-{ $description "Creates a non-reentrant lock." } ;\r
-\r
-HELP: <reentrant-lock>\r
-{ $values { "lock" lock } }\r
-{ $description "Creates a reentrant lock." } ;\r
-\r
-HELP: with-lock-timeout\r
-{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }\r
-{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." }\r
-{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;\r
-\r
-HELP: with-lock\r
-{ $values { "lock" lock } { "quot" quotation } }\r
-{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } ;\r
-\r
-ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks"\r
-"A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads."\r
-$nl\r
-"There are two varieties of locks: non-reentrant and reentrant. The latter may be acquired recursively by the same thread. Attempting to do so with the former will deadlock."\r
-{ $subsections\r
- lock\r
- <lock>\r
- <reentrant-lock>\r
- with-lock\r
- with-lock-timeout\r
-} ;\r
-\r
-HELP: rw-lock\r
-{ $class-description "The class of reader/writer locks." } ;\r
-\r
-HELP: with-read-lock-timeout\r
-{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }\r
-{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." }\r
-{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;\r
-\r
-HELP: with-read-lock\r
-{ $values { "lock" lock } { "quot" quotation } }\r
-{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ;\r
-\r
-HELP: with-write-lock-timeout\r
-{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }\r
-{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." }\r
-{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;\r
-\r
-HELP: with-write-lock\r
-{ $values { "lock" lock } { "quot" quotation } }\r
-{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } ;\r
-\r
-ARTICLE: "concurrency.locks.rw" "Read-write locks"\r
-"A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure."\r
-$nl\r
-"While this can be achieved with a simple " { $link "concurrency.locks.mutex" } ", performance will suffer, since in fact multiple threads can view the structure at the same time; serialization must only be enforced for writes."\r
-$nl\r
-"Read/write locks allow any number of threads to hold the read lock simultaneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks."\r
-$nl\r
-"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."\r
-{ $subsections\r
- rw-lock\r
- <rw-lock>\r
- with-read-lock\r
- with-write-lock\r
-}\r
-"Versions of the above that take a timeout duration:"\r
-{ $subsections\r
- with-read-lock-timeout\r
- with-write-lock-timeout\r
-} ;\r
-\r
-ARTICLE: "concurrency.locks" "Locks"\r
-"A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:"\r
-{ $subsections\r
- "concurrency.locks.mutex"\r
- "concurrency.locks.rw"\r
-} ;\r
-\r
-ABOUT: "concurrency.locks"\r
+USING: help.markup help.syntax sequences kernel quotations
+calendar ;
+IN: concurrency.locks
+
+HELP: lock
+{ $class-description "The class of mutual exclusion locks." } ;
+
+HELP: <lock>
+{ $values { "lock" lock } }
+{ $description "Creates a non-reentrant lock." } ;
+
+HELP: <reentrant-lock>
+{ $values { "lock" lock } }
+{ $description "Creates a reentrant lock." } ;
+
+HELP: with-lock-timeout
+{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
+{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." }
+{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
+
+HELP: with-lock
+{ $values { "lock" lock } { "quot" quotation } }
+{ $description "Calls the quotation, ensuring that only one thread executes with the lock held at a time. If another thread is holding the lock, blocks until the thread releases the lock." } ;
+
+ARTICLE: "concurrency.locks.mutex" "Mutual-exclusion locks"
+"A mutual-exclusion lock ensures that only one thread executes with the lock held at a time. They are used to protect critical sections so that certain operations appear to be atomic to other threads."
+$nl
+"There are two varieties of locks: non-reentrant and reentrant. The latter may be acquired recursively by the same thread. Attempting to do so with the former will deadlock."
+{ $subsections
+ lock
+ <lock>
+ <reentrant-lock>
+ with-lock
+ with-lock-timeout
+} ;
+
+HELP: rw-lock
+{ $class-description "The class of reader/writer locks." } ;
+
+HELP: with-read-lock-timeout
+{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
+{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." }
+{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
+
+HELP: with-read-lock
+{ $values { "lock" lock } { "quot" quotation } }
+{ $description "Calls the quotation, ensuring that no other thread is holding a write lock at the same time. If another thread is holding a write lock, blocks until the thread releases the lock." } ;
+
+HELP: with-write-lock-timeout
+{ $values { "lock" lock } { "timeout" { $maybe duration } } { "quot" quotation } }
+{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." }
+{ $errors "Throws an error if the lock could not be acquired before the timeout expires. A timeout value of " { $link f } " means the thread is willing to wait indefinitely." } ;
+
+HELP: with-write-lock
+{ $values { "lock" lock } { "quot" quotation } }
+{ $description "Calls the quotation, ensuring that no other thread is holding a read or write lock at the same time. If another thread is holding a read or write lock, blocks until the thread releases the lock." } ;
+
+ARTICLE: "concurrency.locks.rw" "Read-write locks"
+"A read-write lock encapsulates a common pattern in the implementation of concurrent data structures, where one wishes to ensure that a thread is able to see a consistent view of the structure for a period of time, during which no other thread modifies the structure."
+$nl
+"While this can be achieved with a simple " { $link "concurrency.locks.mutex" } ", performance will suffer, since in fact multiple threads can view the structure at the same time; serialization must only be enforced for writes."
+$nl
+"Read/write locks allow any number of threads to hold the read lock simultaneously, however attempting to acquire a write lock blocks until all other threads release read locks and write locks."
+$nl
+"Read/write locks are reentrant. A thread holding a write lock may acquire a read lock or a write lock without blocking. However a thread holding a read lock may not acquire a write lock recursively since that could break invariants assumed by the code executing with the read lock held."
+{ $subsections
+ rw-lock
+ <rw-lock>
+ with-read-lock
+ with-write-lock
+}
+"Versions of the above that take a timeout duration:"
+{ $subsections
+ with-read-lock-timeout
+ with-write-lock-timeout
+} ;
+
+ARTICLE: "concurrency.locks" "Locks"
+"A " { $emphasis "lock" } " is an object protecting a critical region of code, enforcing a particular mutual-exclusion policy. The " { $vocab-link "concurrency.locks" } " vocabulary implements two types of locks:"
+{ $subsections
+ "concurrency.locks.mutex"
+ "concurrency.locks.rw"
+} ;
+
+ABOUT: "concurrency.locks"
-USING: tools.test concurrency.locks concurrency.count-downs\r
-concurrency.messaging concurrency.mailboxes locals kernel\r
-threads sequences calendar accessors ;\r
-IN: concurrency.locks.tests\r
-\r
-:: lock-test-0 ( -- v )\r
- V{ } clone :> v\r
- 2 <count-down> :> c\r
-\r
- [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v ;\r
-\r
-:: lock-test-1 ( -- v )\r
- V{ } clone :> v\r
- <lock> :> l\r
- 2 <count-down> :> c\r
-\r
- [\r
- l [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- l [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v ;\r
-\r
-[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test\r
-[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test\r
-\r
-[ 3 ] [\r
- <reentrant-lock> dup [\r
- [\r
- 3\r
- ] with-lock\r
- ] with-lock\r
-] unit-test\r
-\r
-[ ] [ <rw-lock> drop ] unit-test\r
-\r
-[ ] [ <rw-lock> [ ] with-read-lock ] unit-test\r
-\r
-[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test\r
-\r
-[ ] [ <rw-lock> [ ] with-write-lock ] unit-test\r
-\r
-[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test\r
-\r
-[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test\r
-\r
-:: rw-lock-test-1 ( -- v )\r
- <rw-lock> :> l\r
- 1 <count-down> :> c\r
- 1 <count-down> :> c'\r
- 4 <count-down> :> c''\r
- V{ } clone :> v\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- yield\r
- 3 v push\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 4 v push\r
- 1 seconds sleep\r
- 5 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 2 v push\r
- c' count-down\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 4" spawn drop\r
-\r
- [\r
- c' await\r
- l [\r
- 6 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 5" spawn drop\r
-\r
- c'' await\r
- v ;\r
-\r
-[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test\r
-\r
-:: rw-lock-test-2 ( -- v )\r
- <rw-lock> :> l\r
- 1 <count-down> :> c\r
- 2 <count-down> :> c'\r
- V{ } clone :> v\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- 1 seconds sleep\r
- 2 v push\r
- ] with-write-lock\r
- c' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 3 v push\r
- ] with-read-lock\r
- c' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- c' await\r
- v ;\r
-\r
-[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test\r
-\r
-! Test lock timeouts\r
-:: lock-timeout-test ( -- v )\r
- <lock> :> l\r
-\r
- [\r
- l [ 1 seconds sleep ] with-lock\r
- ] "Lock holder" spawn drop\r
-\r
- [\r
- l 1/10 seconds [ ] with-lock-timeout\r
- ] "Lock timeout-er" spawn-linked drop\r
-\r
- receive ;\r
-\r
-[ lock-timeout-test ] [\r
- thread>> name>> "Lock timeout-er" =\r
-] must-fail-with\r
-\r
-[\r
- <rw-lock> dup [\r
- 1 seconds [ ] with-write-lock-timeout\r
- ] with-read-lock\r
-] must-fail\r
-\r
-[\r
- <rw-lock> dup [\r
- dup [\r
- 1 seconds [ ] with-write-lock-timeout\r
- ] with-read-lock\r
- ] with-write-lock\r
-] must-fail\r
-\r
-[ ] [\r
- <rw-lock> dup [\r
- dup [\r
- 1 seconds [ ] with-read-lock-timeout\r
- ] with-read-lock\r
- ] with-write-lock\r
-] unit-test\r
+USING: tools.test concurrency.locks concurrency.count-downs
+concurrency.messaging concurrency.mailboxes locals kernel
+threads sequences calendar accessors ;
+IN: concurrency.locks.tests
+
+:: lock-test-0 ( -- v )
+ V{ } clone :> v
+ 2 <count-down> :> c
+
+ [
+ yield
+ 1 v push
+ yield
+ 2 v push
+ c count-down
+ ] "Lock test 1" spawn drop
+
+ [
+ yield
+ 3 v push
+ yield
+ 4 v push
+ c count-down
+ ] "Lock test 2" spawn drop
+
+ c await
+ v ;
+
+:: lock-test-1 ( -- v )
+ V{ } clone :> v
+ <lock> :> l
+ 2 <count-down> :> c
+
+ [
+ l [
+ yield
+ 1 v push
+ yield
+ 2 v push
+ ] with-lock
+ c count-down
+ ] "Lock test 1" spawn drop
+
+ [
+ l [
+ yield
+ 3 v push
+ yield
+ 4 v push
+ ] with-lock
+ c count-down
+ ] "Lock test 2" spawn drop
+
+ c await
+ v ;
+
+[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test
+[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test
+
+[ 3 ] [
+ <reentrant-lock> dup [
+ [
+ 3
+ ] with-lock
+ ] with-lock
+] unit-test
+
+[ ] [ <rw-lock> drop ] unit-test
+
+[ ] [ <rw-lock> [ ] with-read-lock ] unit-test
+
+[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-read-lock ] unit-test
+
+[ ] [ <rw-lock> [ ] with-write-lock ] unit-test
+
+[ ] [ <rw-lock> dup [ [ ] with-write-lock ] with-write-lock ] unit-test
+
+[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
+
+:: rw-lock-test-1 ( -- v )
+ <rw-lock> :> l
+ 1 <count-down> :> c
+ 1 <count-down> :> c'
+ 4 <count-down> :> c''
+ V{ } clone :> v
+
+ [
+ l [
+ 1 v push
+ c count-down
+ yield
+ 3 v push
+ ] with-read-lock
+ c'' count-down
+ ] "R/W lock test 1" spawn drop
+
+ [
+ c await
+ l [
+ 4 v push
+ 1 seconds sleep
+ 5 v push
+ ] with-write-lock
+ c'' count-down
+ ] "R/W lock test 2" spawn drop
+
+ [
+ c await
+ l [
+ 2 v push
+ c' count-down
+ ] with-read-lock
+ c'' count-down
+ ] "R/W lock test 4" spawn drop
+
+ [
+ c' await
+ l [
+ 6 v push
+ ] with-write-lock
+ c'' count-down
+ ] "R/W lock test 5" spawn drop
+
+ c'' await
+ v ;
+
+[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
+
+:: rw-lock-test-2 ( -- v )
+ <rw-lock> :> l
+ 1 <count-down> :> c
+ 2 <count-down> :> c'
+ V{ } clone :> v
+
+ [
+ l [
+ 1 v push
+ c count-down
+ 1 seconds sleep
+ 2 v push
+ ] with-write-lock
+ c' count-down
+ ] "R/W lock test 1" spawn drop
+
+ [
+ c await
+ l [
+ 3 v push
+ ] with-read-lock
+ c' count-down
+ ] "R/W lock test 2" spawn drop
+
+ c' await
+ v ;
+
+[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
+
+! Test lock timeouts
+:: lock-timeout-test ( -- v )
+ <lock> :> l
+
+ [
+ l [ 1 seconds sleep ] with-lock
+ ] "Lock holder" spawn drop
+
+ [
+ l 1/10 seconds [ ] with-lock-timeout
+ ] "Lock timeout-er" spawn-linked drop
+
+ receive ;
+
+[ lock-timeout-test ] [
+ thread>> name>> "Lock timeout-er" =
+] must-fail-with
+
+[
+ <rw-lock> dup [
+ 1 seconds [ ] with-write-lock-timeout
+ ] with-read-lock
+] must-fail
+
+[
+ <rw-lock> dup [
+ dup [
+ 1 seconds [ ] with-write-lock-timeout
+ ] with-read-lock
+ ] with-write-lock
+] must-fail
+
+[ ] [
+ <rw-lock> dup [
+ dup [
+ 1 seconds [ ] with-read-lock-timeout
+ ] with-read-lock
+ ] with-write-lock
+] unit-test
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: deques dlists kernel threads continuations math\r
-concurrency.conditions combinators.short-circuit accessors\r
-locals ;\r
-IN: concurrency.locks\r
-\r
-! Simple critical sections\r
-TUPLE: lock threads owner reentrant? ;\r
-\r
-: <lock> ( -- lock )\r
- <dlist> f f lock boa ;\r
-\r
-: <reentrant-lock> ( -- lock )\r
- <dlist> f t lock boa ;\r
-\r
-<PRIVATE\r
-\r
-: acquire-lock ( lock timeout -- )\r
- over owner>>\r
- [ 2dup [ threads>> ] dip "lock" wait ] when drop\r
- self >>owner drop ;\r
-\r
-: release-lock ( lock -- )\r
- f >>owner\r
- threads>> notify-1 ;\r
-\r
-:: do-lock ( lock timeout quot acquire release -- )\r
- lock timeout acquire call\r
- quot lock release curry [ ] cleanup ; inline\r
-\r
-: (with-lock) ( lock timeout quot -- )\r
- [ acquire-lock ] [ release-lock ] do-lock ; inline\r
-\r
-PRIVATE>\r
-\r
-: with-lock-timeout ( lock timeout quot -- )\r
- pick reentrant?>> [\r
- pick owner>> self eq? [\r
- 2nip call\r
- ] [\r
- (with-lock)\r
- ] if\r
- ] [\r
- (with-lock)\r
- ] if ; inline\r
-\r
-: with-lock ( lock quot -- )\r
- f swap with-lock-timeout ; inline\r
-\r
-! Many-reader/single-writer locks\r
-TUPLE: rw-lock readers writers reader# writer ;\r
-\r
-: <rw-lock> ( -- lock )\r
- <dlist> <dlist> 0 f rw-lock boa ;\r
-\r
-<PRIVATE\r
-\r
-: add-reader ( lock -- )\r
- [ 1 + ] change-reader# drop ;\r
-\r
-: acquire-read-lock ( lock timeout -- )\r
- over writer>>\r
- [ 2dup [ readers>> ] dip "read lock" wait ] when drop\r
- add-reader ;\r
-\r
-: notify-writer ( lock -- )\r
- writers>> notify-1 ;\r
-\r
-: remove-reader ( lock -- )\r
- [ 1 - ] change-reader# drop ;\r
-\r
-: release-read-lock ( lock -- )\r
- dup remove-reader\r
- dup reader#>> zero? [ notify-writer ] [ drop ] if ;\r
-\r
-: acquire-write-lock ( lock timeout -- )\r
- over writer>> pick reader#>> 0 > or\r
- [ 2dup [ writers>> ] dip "write lock" wait ] when drop\r
- self >>writer drop ;\r
-\r
-: release-write-lock ( lock -- )\r
- f >>writer\r
- dup readers>> deque-empty?\r
- [ notify-writer ] [ readers>> notify-all ] if ;\r
-\r
-: reentrant-read-lock-ok? ( lock -- ? )\r
- #! If we already have a write lock, then we can grab a read\r
- #! lock too.\r
- writer>> self eq? ;\r
-\r
-: reentrant-write-lock-ok? ( lock -- ? )\r
- #! The only case where we have a writer and > 1 reader is\r
- #! write -> read re-entrancy, and in this case we prohibit\r
- #! a further write -> read -> write re-entrancy.\r
- { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;\r
-\r
-PRIVATE>\r
-\r
-: with-read-lock-timeout ( lock timeout quot -- )\r
- pick reentrant-read-lock-ok? [\r
- [ drop add-reader ] [ remove-reader ] do-lock\r
- ] [\r
- [ acquire-read-lock ] [ release-read-lock ] do-lock\r
- ] if ; inline\r
-\r
-: with-read-lock ( lock quot -- )\r
- f swap with-read-lock-timeout ; inline\r
-\r
-: with-write-lock-timeout ( lock timeout quot -- )\r
- pick reentrant-write-lock-ok? [ 2nip call ] [\r
- [ acquire-write-lock ] [ release-write-lock ] do-lock\r
- ] if ; inline\r
-\r
-: with-write-lock ( lock quot -- )\r
- f swap with-write-lock-timeout ; inline\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: deques dlists kernel threads continuations math
+concurrency.conditions combinators.short-circuit accessors
+locals ;
+IN: concurrency.locks
+
+! Simple critical sections
+TUPLE: lock threads owner reentrant? ;
+
+: <lock> ( -- lock )
+ <dlist> f f lock boa ;
+
+: <reentrant-lock> ( -- lock )
+ <dlist> f t lock boa ;
+
+<PRIVATE
+
+: acquire-lock ( lock timeout -- )
+ over owner>>
+ [ 2dup [ threads>> ] dip "lock" wait ] when drop
+ self >>owner drop ;
+
+: release-lock ( lock -- )
+ f >>owner
+ threads>> notify-1 ;
+
+:: do-lock ( lock timeout quot acquire release -- )
+ lock timeout acquire call
+ quot lock release curry [ ] cleanup ; inline
+
+: (with-lock) ( lock timeout quot -- )
+ [ acquire-lock ] [ release-lock ] do-lock ; inline
+
+PRIVATE>
+
+: with-lock-timeout ( lock timeout quot -- )
+ pick reentrant?>> [
+ pick owner>> self eq? [
+ 2nip call
+ ] [
+ (with-lock)
+ ] if
+ ] [
+ (with-lock)
+ ] if ; inline
+
+: with-lock ( lock quot -- )
+ f swap with-lock-timeout ; inline
+
+! Many-reader/single-writer locks
+TUPLE: rw-lock readers writers reader# writer ;
+
+: <rw-lock> ( -- lock )
+ <dlist> <dlist> 0 f rw-lock boa ;
+
+<PRIVATE
+
+: add-reader ( lock -- )
+ [ 1 + ] change-reader# drop ;
+
+: acquire-read-lock ( lock timeout -- )
+ over writer>>
+ [ 2dup [ readers>> ] dip "read lock" wait ] when drop
+ add-reader ;
+
+: notify-writer ( lock -- )
+ writers>> notify-1 ;
+
+: remove-reader ( lock -- )
+ [ 1 - ] change-reader# drop ;
+
+: release-read-lock ( lock -- )
+ dup remove-reader
+ dup reader#>> zero? [ notify-writer ] [ drop ] if ;
+
+: acquire-write-lock ( lock timeout -- )
+ over writer>> pick reader#>> 0 > or
+ [ 2dup [ writers>> ] dip "write lock" wait ] when drop
+ self >>writer drop ;
+
+: release-write-lock ( lock -- )
+ f >>writer
+ dup readers>> deque-empty?
+ [ notify-writer ] [ readers>> notify-all ] if ;
+
+: reentrant-read-lock-ok? ( lock -- ? )
+ #! If we already have a write lock, then we can grab a read
+ #! lock too.
+ writer>> self eq? ;
+
+: reentrant-write-lock-ok? ( lock -- ? )
+ #! The only case where we have a writer and > 1 reader is
+ #! write -> read re-entrancy, and in this case we prohibit
+ #! a further write -> read -> write re-entrancy.
+ { [ writer>> self eq? ] [ reader#>> zero? ] } 1&& ;
+
+PRIVATE>
+
+: with-read-lock-timeout ( lock timeout quot -- )
+ pick reentrant-read-lock-ok? [
+ [ drop add-reader ] [ remove-reader ] do-lock
+ ] [
+ [ acquire-read-lock ] [ release-read-lock ] do-lock
+ ] if ; inline
+
+: with-read-lock ( lock quot -- )
+ f swap with-read-lock-timeout ; inline
+
+: with-write-lock-timeout ( lock timeout quot -- )
+ pick reentrant-write-lock-ok? [ 2nip call ] [
+ [ acquire-write-lock ] [ release-write-lock ] do-lock
+ ] if ; inline
+
+: with-write-lock ( lock quot -- )
+ f swap with-write-lock-timeout ; inline
-USING: help.markup help.syntax kernel arrays calendar ;\r
-IN: concurrency.mailboxes\r
-\r
-HELP: <mailbox>\r
-{ $values { "mailbox" mailbox } }\r
-{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ;\r
-\r
-HELP: mailbox-empty?\r
-{ $values { "mailbox" mailbox }\r
- { "bool" boolean }\r
-}\r
-{ $description "Return true if the mailbox is empty." } ;\r
-\r
-HELP: mailbox-put\r
-{ $values { "obj" object }\r
- { "mailbox" mailbox }\r
-}\r
-{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;\r
-\r
-HELP: block-unless-pred\r
-{ $values\r
- { "mailbox" mailbox }\r
- { "timeout" { $maybe duration } }\r
- { "pred" { $quotation ( ... message -- ... ? ) } }\r
-}\r
-{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;\r
-\r
-HELP: block-if-empty\r
-{ $values { "mailbox" mailbox }\r
- { "timeout" { $maybe duration } }\r
-}\r
-{ $description "Block the thread if the mailbox is empty." } ;\r
-\r
-HELP: mailbox-get\r
-{ $values { "mailbox" mailbox } { "obj" object } }\r
-{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;\r
-\r
-HELP: mailbox-get-all\r
-{ $values { "mailbox" mailbox } { "array" array } }\r
-{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;\r
-\r
-HELP: while-mailbox-empty\r
-{ $values { "mailbox" mailbox }\r
- { "quot" { $quotation ( -- ) } }\r
-}\r
-{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;\r
-\r
-HELP: mailbox-get?\r
-{ $values { "mailbox" mailbox }\r
- { "pred" { $quotation ( obj -- ? ) } }\r
- { "obj" object }\r
-}\r
-{ $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;\r
-\r
-ARTICLE: "concurrency.mailboxes" "Mailboxes"\r
-"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."\r
-{ $subsections\r
- mailbox\r
- <mailbox>\r
-}\r
-"Removing the first element:"\r
-{ $subsections\r
- mailbox-get\r
- mailbox-get-timeout\r
-}\r
-"Removing the first element matching a predicate:"\r
-{ $subsections\r
- mailbox-get?\r
- mailbox-get-timeout?\r
-}\r
-"Emptying out a mailbox:"\r
-{ $subsections mailbox-get-all }\r
-"Adding an element:"\r
-{ $subsections mailbox-put }\r
-"Testing if a mailbox is empty:"\r
-{ $subsections\r
- mailbox-empty?\r
- while-mailbox-empty\r
-} ;\r
-\r
-ABOUT: "concurrency.mailboxes"\r
+USING: help.markup help.syntax kernel arrays calendar ;
+IN: concurrency.mailboxes
+
+HELP: <mailbox>
+{ $values { "mailbox" mailbox } }
+{ $description "A mailbox is an object that can be used for safe thread communication. Items can be put in the mailbox and retrieved in a FIFO order. If the mailbox is empty when a get operation is performed then the thread will block until another thread places something in the mailbox. If multiple threads are waiting on the same mailbox, only one of the waiting threads will be unblocked to thread the get operation." } ;
+
+HELP: mailbox-empty?
+{ $values { "mailbox" mailbox }
+ { "bool" boolean }
+}
+{ $description "Return true if the mailbox is empty." } ;
+
+HELP: mailbox-put
+{ $values { "obj" object }
+ { "mailbox" mailbox }
+}
+{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;
+
+HELP: block-unless-pred
+{ $values
+ { "mailbox" mailbox }
+ { "timeout" { $maybe duration } }
+ { "pred" { $quotation ( ... message -- ... ? ) } }
+}
+{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;
+
+HELP: block-if-empty
+{ $values { "mailbox" mailbox }
+ { "timeout" { $maybe duration } }
+}
+{ $description "Block the thread if the mailbox is empty." } ;
+
+HELP: mailbox-get
+{ $values { "mailbox" mailbox } { "obj" object } }
+{ $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } ;
+
+HELP: mailbox-get-all
+{ $values { "mailbox" mailbox } { "array" array } }
+{ $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } ;
+
+HELP: while-mailbox-empty
+{ $values { "mailbox" mailbox }
+ { "quot" { $quotation ( -- ) } }
+}
+{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;
+
+HELP: mailbox-get?
+{ $values { "mailbox" mailbox }
+ { "pred" { $quotation ( obj -- ? ) } }
+ { "obj" object }
+}
+{ $description "Get the first item in the mailbox which satisfies the predicate. When the predicate returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;
+
+ARTICLE: "concurrency.mailboxes" "Mailboxes"
+"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
+{ $subsections
+ mailbox
+ <mailbox>
+}
+"Removing the first element:"
+{ $subsections
+ mailbox-get
+ mailbox-get-timeout
+}
+"Removing the first element matching a predicate:"
+{ $subsections
+ mailbox-get?
+ mailbox-get-timeout?
+}
+"Emptying out a mailbox:"
+{ $subsections mailbox-get-all }
+"Adding an element:"
+{ $subsections mailbox-put }
+"Testing if a mailbox is empty:"
+{ $subsections
+ mailbox-empty?
+ while-mailbox-empty
+} ;
+
+ABOUT: "concurrency.mailboxes"
-! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel kernel.private threads concurrency.mailboxes\r
-continuations namespaces assocs accessors summary fry ;\r
-IN: concurrency.messaging\r
-\r
-GENERIC: send ( message thread -- )\r
-\r
-GENERIC: mailbox-of ( thread -- mailbox )\r
-\r
-M: thread mailbox-of\r
- dup mailbox>>\r
- [ { mailbox } declare ]\r
- [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline\r
-\r
-M: thread send ( message thread -- )\r
- mailbox-of mailbox-put ;\r
-\r
-: my-mailbox ( -- mailbox ) self mailbox-of ; inline\r
-\r
-: receive ( -- message )\r
- my-mailbox mailbox-get ?linked ;\r
-\r
-: receive-timeout ( timeout -- message )\r
- [ my-mailbox ] dip mailbox-get-timeout ?linked ;\r
-\r
-: receive-if ( pred -- message )\r
- [ my-mailbox ] dip mailbox-get? ?linked ; inline\r
-\r
-: receive-if-timeout ( timeout pred -- message )\r
- [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline\r
-\r
-: rethrow-linked ( error process supervisor -- )\r
- [ <linked-error> ] dip send ;\r
-\r
-: spawn-linked ( quot name -- thread )\r
- my-mailbox spawn-linked-to ;\r
-\r
-TUPLE: synchronous data sender tag ;\r
-\r
-: <synchronous> ( data -- sync )\r
- self synchronous counter synchronous boa ;\r
-\r
-TUPLE: reply data tag ;\r
-\r
-: <reply> ( data synchronous -- reply )\r
- tag>> \ reply boa ;\r
-\r
-: synchronous-reply? ( response synchronous -- ? )\r
- over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;\r
-\r
-ERROR: cannot-send-synchronous-to-self message thread ;\r
-\r
-M: cannot-send-synchronous-to-self summary\r
- drop "Cannot synchronous send to myself" ;\r
-\r
-: send-synchronous ( message thread -- reply )\r
- dup self eq? [\r
- cannot-send-synchronous-to-self\r
- ] [\r
- [ <synchronous> dup ] dip send\r
- '[ _ synchronous-reply? ] receive-if\r
- data>>\r
- ] if ;\r
-\r
-: reply-synchronous ( message synchronous -- )\r
- [ <reply> ] keep sender>> send ;\r
-\r
-: handle-synchronous ( quot -- )\r
- receive [\r
- data>> swap call\r
- ] keep reply-synchronous ; inline\r
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel kernel.private threads concurrency.mailboxes
+continuations namespaces assocs accessors summary fry ;
+IN: concurrency.messaging
+
+GENERIC: send ( message thread -- )
+
+GENERIC: mailbox-of ( thread -- mailbox )
+
+M: thread mailbox-of
+ dup mailbox>>
+ [ { mailbox } declare ]
+ [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
+
+M: thread send ( message thread -- )
+ mailbox-of mailbox-put ;
+
+: my-mailbox ( -- mailbox ) self mailbox-of ; inline
+
+: receive ( -- message )
+ my-mailbox mailbox-get ?linked ;
+
+: receive-timeout ( timeout -- message )
+ [ my-mailbox ] dip mailbox-get-timeout ?linked ;
+
+: receive-if ( pred -- message )
+ [ my-mailbox ] dip mailbox-get? ?linked ; inline
+
+: receive-if-timeout ( timeout pred -- message )
+ [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
+
+: rethrow-linked ( error process supervisor -- )
+ [ <linked-error> ] dip send ;
+
+: spawn-linked ( quot name -- thread )
+ my-mailbox spawn-linked-to ;
+
+TUPLE: synchronous data sender tag ;
+
+: <synchronous> ( data -- sync )
+ self synchronous counter synchronous boa ;
+
+TUPLE: reply data tag ;
+
+: <reply> ( data synchronous -- reply )
+ tag>> \ reply boa ;
+
+: synchronous-reply? ( response synchronous -- ? )
+ over reply? [ [ tag>> ] same? ] [ 2drop f ] if ;
+
+ERROR: cannot-send-synchronous-to-self message thread ;
+
+M: cannot-send-synchronous-to-self summary
+ drop "Cannot synchronous send to myself" ;
+
+: send-synchronous ( message thread -- reply )
+ dup self eq? [
+ cannot-send-synchronous-to-self
+ ] [
+ [ <synchronous> dup ] dip send
+ '[ _ synchronous-reply? ] receive-if
+ data>>
+ ] if ;
+
+: reply-synchronous ( message synchronous -- )
+ [ <reply> ] keep sender>> send ;
+
+: handle-synchronous ( quot -- )
+ receive [
+ data>> swap call
+ ] keep reply-synchronous ; inline
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar help.markup help.syntax kernel ;\r
-IN: concurrency.promises\r
-\r
-HELP: promise\r
-{ $class-description "The class of write-once promises." } ;\r
-\r
-HELP: <promise>\r
-{ $values { "promise" promise } }\r
-{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;\r
-\r
-HELP: promise-fulfilled?\r
-{ $values { "promise" promise } { "?" boolean } }\r
-{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;\r
-\r
-HELP: ?promise-timeout\r
-{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }\r
-{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to the " { $snippet "timeout" } " before throwing an error." }\r
-{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;\r
-\r
-HELP: ?promise\r
-{ $values { "promise" promise } { "result" object } }\r
-{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ;\r
-\r
-HELP: fulfill\r
-{ $values { "value" object } { "promise" promise } }\r
-{ $description "Fulfills a promise by writing a value to it. Any threads waiting for the value are notified." }\r
-{ $errors "Throws an error if the promise has already been fulfilled." } ;\r
-\r
-ARTICLE: "concurrency.promises" "Promises"\r
-"The " { $vocab-link "concurrency.promises" } " vocabulary implements " { $emphasis "promises" } ", which are thread-safe write-once variables. Once a promise is created, threads may block waiting for it to be " { $emphasis "fulfilled" } "; at some point in the future, another thread may provide a value at which point all waiting threads are notified."\r
-{ $subsections\r
- promise\r
- <promise>\r
- fulfill\r
- ?promise\r
- ?promise-timeout\r
-} ;\r
-\r
-ABOUT: "concurrency.promises"\r
+! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar help.markup help.syntax kernel ;
+IN: concurrency.promises
+
+HELP: promise
+{ $class-description "The class of write-once promises." } ;
+
+HELP: <promise>
+{ $values { "promise" promise } }
+{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;
+
+HELP: promise-fulfilled?
+{ $values { "promise" promise } { "?" boolean } }
+{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
+
+HELP: ?promise-timeout
+{ $values { "promise" promise } { "timeout" { $maybe duration } } { "result" object } }
+{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled. A timeout of " { $link f } " indicates that the thread may block indefinitely, otherwise it will wait up to the " { $snippet "timeout" } " before throwing an error." }
+{ $errors "Throws an error if the timeout expires before the promise has been fulfilled." } ;
+
+HELP: ?promise
+{ $values { "promise" promise } { "result" object } }
+{ $description "Waits for another thread to fulfill a promise, returning immediately if the promise has already been fulfilled." } ;
+
+HELP: fulfill
+{ $values { "value" object } { "promise" promise } }
+{ $description "Fulfills a promise by writing a value to it. Any threads waiting for the value are notified." }
+{ $errors "Throws an error if the promise has already been fulfilled." } ;
+
+ARTICLE: "concurrency.promises" "Promises"
+"The " { $vocab-link "concurrency.promises" } " vocabulary implements " { $emphasis "promises" } ", which are thread-safe write-once variables. Once a promise is created, threads may block waiting for it to be " { $emphasis "fulfilled" } "; at some point in the future, another thread may provide a value at which point all waiting threads are notified."
+{ $subsections
+ promise
+ <promise>
+ fulfill
+ ?promise
+ ?promise-timeout
+} ;
+
+ABOUT: "concurrency.promises"
-USING: vectors concurrency.promises kernel threads sequences\r
-tools.test ;\r
-IN: concurrency.promises.tests\r
-\r
-[ V{ 50 50 50 } ] [\r
- 0 <vector>\r
- <promise>\r
- [ ?promise swap push ] in-thread\r
- [ ?promise swap push ] in-thread\r
- [ ?promise swap push ] in-thread\r
- 50 swap fulfill\r
-] unit-test\r
+USING: vectors concurrency.promises kernel threads sequences
+tools.test ;
+IN: concurrency.promises.tests
+
+[ V{ 50 50 50 } ] [
+ 0 <vector>
+ <promise>
+ [ ?promise swap push ] in-thread
+ [ ?promise swap push ] in-thread
+ [ ?promise swap push ] in-thread
+ 50 swap fulfill
+] unit-test
ERROR: promise-already-fulfilled promise ;
: fulfill ( value promise -- )
- dup promise-fulfilled? [
+ dup promise-fulfilled? [
promise-already-fulfilled
] [
mailbox>> mailbox-put
-IN: concurrency.semaphores\r
-USING: help.markup help.syntax kernel quotations calendar ;\r
-\r
-HELP: semaphore\r
-{ $class-description "The class of counting semaphores. New instances can be created by calling " { $link <semaphore> } "." } ;\r
-\r
-HELP: <semaphore>\r
-{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }\r
-{ $description "Creates a counting semaphore with the specified initial count." } ;\r
-\r
-HELP: acquire-timeout\r
-{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } }\r
-{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }\r
-{ $errors "Throws an error if the timeout expires before the semaphore is released." } ;\r
-\r
-HELP: acquire\r
-{ $values { "semaphore" semaphore } }\r
-{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ;\r
-\r
-HELP: release\r
-{ $values { "semaphore" semaphore } }\r
-{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;\r
-\r
-HELP: with-semaphore-timeout\r
-{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } { "quot" quotation } }\r
-{ $description "Calls the quotation with the semaphore held." } ;\r
-\r
-HELP: with-semaphore\r
-{ $values { "semaphore" semaphore } { "quot" quotation } }\r
-{ $description "Calls the quotation with the semaphore held." } ;\r
-\r
-ARTICLE: "concurrency.semaphores.examples" "Semaphore examples"\r
-"A use-case would be a batch processing server which runs a large number of jobs which perform calculations but then need to fire off expensive external processes or perform heavy network I/O. While for most of the time, the threads can all run in parallel, it might be desired that the expensive operation is not run by more than 10 threads at once, to avoid thrashing swap space or saturating the network. This can be accomplished with a counting semaphore:"\r
-{ $code\r
- "SYMBOL: expensive-section"\r
- "requests"\r
- "10 <semaphore> '["\r
- " ..."\r
- " _ [ do-expensive-stuff ] with-semaphore"\r
- " ..."\r
- "] parallel-map"\r
-}\r
-"Here is a concrete example which fetches content from 5 different web sites, making no more than 3 requests at a time:"\r
-{ $code\r
- """USING: concurrency.combinators concurrency.semaphores\r
-fry http.client kernel urls ;\r
-\r
-{\r
- URL" http://www.apple.com"\r
- URL" http://www.google.com"\r
- URL" http://www.ibm.com"\r
- URL" http://www.hp.com"\r
- URL" http://www.oracle.com"\r
-}\r
-2 <semaphore> '[\r
- _ [ http-get nip ] with-semaphore\r
-] parallel-map"""\r
-} ;\r
-\r
-ARTICLE: "concurrency.semaphores" "Counting semaphores"\r
-"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $vocab-link "concurrency.locks" } ", since locks can be thought of as semaphores with an initial count of 1."\r
-{ $subsections "concurrency.semaphores.examples" }\r
-"Creating semaphores:"\r
-{ $subsections\r
- semaphore\r
- <semaphore>\r
-}\r
-"Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:"\r
-{ $subsections\r
- acquire\r
- acquire-timeout\r
- release\r
-}\r
-"Combinators which pair acquisition and release:"\r
-{ $subsections\r
- with-semaphore\r
- with-semaphore-timeout\r
-} ;\r
-\r
-ABOUT: "concurrency.semaphores"\r
+IN: concurrency.semaphores
+USING: help.markup help.syntax kernel quotations calendar ;
+
+HELP: semaphore
+{ $class-description "The class of counting semaphores. New instances can be created by calling " { $link <semaphore> } "." } ;
+
+HELP: <semaphore>
+{ $values { "n" "a non-negative integer" } { "semaphore" semaphore } }
+{ $description "Creates a counting semaphore with the specified initial count." } ;
+
+HELP: acquire-timeout
+{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } }
+{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, if the timeout is " { $link f } ", waits indefinitely for the semaphore to be released. If the timeout is not " { $link f } ", waits a certain period of time, and if the semaphore still has not been released, throws an error." }
+{ $errors "Throws an error if the timeout expires before the semaphore is released." } ;
+
+HELP: acquire
+{ $values { "semaphore" semaphore } }
+{ $description "If the semaphore has a non-zero count, decrements it and returns immediately. Otherwise, waits for it to be released." } ;
+
+HELP: release
+{ $values { "semaphore" semaphore } }
+{ $description "Increments a semaphore's count. If the count was previously zero, any threads waiting on the semaphore are woken up." } ;
+
+HELP: with-semaphore-timeout
+{ $values { "semaphore" semaphore } { "timeout" { $maybe duration } } { "quot" quotation } }
+{ $description "Calls the quotation with the semaphore held." } ;
+
+HELP: with-semaphore
+{ $values { "semaphore" semaphore } { "quot" quotation } }
+{ $description "Calls the quotation with the semaphore held." } ;
+
+ARTICLE: "concurrency.semaphores.examples" "Semaphore examples"
+"A use-case would be a batch processing server which runs a large number of jobs which perform calculations but then need to fire off expensive external processes or perform heavy network I/O. While for most of the time, the threads can all run in parallel, it might be desired that the expensive operation is not run by more than 10 threads at once, to avoid thrashing swap space or saturating the network. This can be accomplished with a counting semaphore:"
+{ $code
+ "SYMBOL: expensive-section"
+ "requests"
+ "10 <semaphore> '["
+ " ..."
+ " _ [ do-expensive-stuff ] with-semaphore"
+ " ..."
+ "] parallel-map"
+}
+"Here is a concrete example which fetches content from 5 different web sites, making no more than 3 requests at a time:"
+{ $code
+ """USING: concurrency.combinators concurrency.semaphores
+fry http.client kernel urls ;
+
+{
+ URL" http://www.apple.com"
+ URL" http://www.google.com"
+ URL" http://www.ibm.com"
+ URL" http://www.hp.com"
+ URL" http://www.oracle.com"
+}
+2 <semaphore> '[
+ _ [ http-get nip ] with-semaphore
+] parallel-map"""
+} ;
+
+ARTICLE: "concurrency.semaphores" "Counting semaphores"
+"Counting semaphores are used to ensure that no more than a fixed number of threads are executing in a critical section at a time; as such, they generalize " { $vocab-link "concurrency.locks" } ", since locks can be thought of as semaphores with an initial count of 1."
+{ $subsections "concurrency.semaphores.examples" }
+"Creating semaphores:"
+{ $subsections
+ semaphore
+ <semaphore>
+}
+"Unlike locks, where acquisition and release are always paired by a combinator, semaphores expose these operations directly and there is no requirement that they be performed in the same thread:"
+{ $subsections
+ acquire
+ acquire-timeout
+ release
+}
+"Combinators which pair acquisition and release:"
+{ $subsections
+ with-semaphore
+ with-semaphore-timeout
+} ;
+
+ABOUT: "concurrency.semaphores"
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: dlists kernel threads math concurrency.conditions\r
-continuations accessors summary locals fry ;\r
-IN: concurrency.semaphores\r
-\r
-TUPLE: semaphore count threads ;\r
-\r
-ERROR: negative-count-semaphore ;\r
-\r
-M: negative-count-semaphore summary\r
- drop "Cannot have semaphore with negative count" ;\r
-\r
-: <semaphore> ( n -- semaphore )\r
- dup 0 < [ negative-count-semaphore ] when\r
- <dlist> semaphore boa ;\r
-\r
-: wait-to-acquire ( semaphore timeout -- )\r
- [ threads>> ] dip "semaphore" wait ;\r
-\r
-: acquire-timeout ( semaphore timeout -- )\r
- over count>> zero?\r
- [ dupd wait-to-acquire ] [ drop ] if\r
- [ 1 - ] change-count drop ;\r
-\r
-: acquire ( semaphore -- )\r
- f acquire-timeout ;\r
-\r
-: release ( semaphore -- )\r
- [ 1 + ] change-count\r
- threads>> notify-1 ;\r
-\r
-:: with-semaphore-timeout ( semaphore timeout quot -- )\r
- semaphore timeout acquire-timeout\r
- quot [ semaphore release ] [ ] cleanup ; inline\r
-\r
-: with-semaphore ( semaphore quot -- )\r
- swap dup acquire '[ _ release ] [ ] cleanup ; inline\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: dlists kernel threads math concurrency.conditions
+continuations accessors summary locals fry ;
+IN: concurrency.semaphores
+
+TUPLE: semaphore count threads ;
+
+ERROR: negative-count-semaphore ;
+
+M: negative-count-semaphore summary
+ drop "Cannot have semaphore with negative count" ;
+
+: <semaphore> ( n -- semaphore )
+ dup 0 < [ negative-count-semaphore ] when
+ <dlist> semaphore boa ;
+
+: wait-to-acquire ( semaphore timeout -- )
+ [ threads>> ] dip "semaphore" wait ;
+
+: acquire-timeout ( semaphore timeout -- )
+ over count>> zero?
+ [ dupd wait-to-acquire ] [ drop ] if
+ [ 1 - ] change-count drop ;
+
+: acquire ( semaphore -- )
+ f acquire-timeout ;
+
+: release ( semaphore -- )
+ [ 1 + ] change-count
+ threads>> notify-1 ;
+
+:: with-semaphore-timeout ( semaphore timeout quot -- )
+ semaphore timeout acquire-timeout
+ quot [ semaphore release ] [ ] cleanup ; inline
+
+: with-semaphore ( semaphore quot -- )
+ swap dup acquire '[ _ release ] [ ] cleanup ; inline
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
DESTRUCTOR: CFRelease
-
CFAllocatorRef allocator,
CFFileDescriptorNativeDescriptor fd,
Boolean closeOnInvalidate,
- CFFileDescriptorCallBack callout,
+ CFFileDescriptorCallBack callout,
CFFileDescriptorContext* context
) ;
: CFType>description ( cf -- description )
CFGetTypeID [ CFCopyTypeIDDescription &CFRelease CF>string ] with-destructors ;
-SYNTAX: CFSTRING:
- scan-new-word scan-object
+SYNTAX: CFSTRING:
+ scan-new-word scan-object
[ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi
( -- alien ) define-declared ;
FUNCTION: CFAbsoluteTime CFRunLoopTimerGetNextFireDate (
CFRunLoopTimerRef timer
) ;
-
-
-USING: tools.test db kernel ;\r
-IN: db.tests\r
-\r
-{ 1 0 } [ [ drop ] query-each ] must-infer-as\r
-{ 1 1 } [ [ ] query-map ] must-infer-as\r
-{ 1 0 } [ [ ] with-db ] must-infer-as\r
+USING: tools.test db kernel ;
+IN: db.tests
+
+{ 1 0 } [ [ drop ] query-each ] must-infer-as
+{ 1 1 } [ [ ] query-map ] must-infer-as
+{ 1 0 } [ [ ] with-db ] must-infer-as
: dispose-statements ( assoc -- ) values dispose-each ;
-M: db-connection dispose ( db-connection -- )
+M: db-connection dispose ( db-connection -- )
dup db-connection [
[ dispose-statements H{ } clone ] change-insert-statements
[ dispose-statements H{ } clone ] change-update-statements
CONSTANT: InvalidOid 0
TYPEDEF: int ConnStatusType
-TYPEDEF: int ExecStatusType
+TYPEDEF: int ExecStatusType
TYPEDEF: int PostgresPollingStatusType
-TYPEDEF: int PGTransactionStatusType
-TYPEDEF: int PGVerbosity
+TYPEDEF: int PGTransactionStatusType
+TYPEDEF: int PGVerbosity
C-TYPE: PGconn
C-TYPE: PGresult
! Force the write buffer to be written (or at least try)
FUNCTION: int PQflush ( PGconn* conn ) ;
-!
+!
! * "Fast path" interface --- not really recommended for application
! * use
!
! really old printing routines
FUNCTION: void PQdisplayTuples ( PGresult* res,
- FILE* fp,
+ FILE* fp,
int fillAlign,
c-string fieldSep,
int printHeader,
int quiet ) ;
FUNCTION: void PQprintTuples ( PGresult* res,
- FILE* fout,
+ FILE* fout,
int printAttName,
- int terseOutput,
- int width ) ;
+ int terseOutput,
+ int width ) ;
! === in fe-lobj.c ===
! Large-object access routines
[ make-retryable ] when ;
: regenerate-params ( statement -- statement )
- dup
+ dup
[ bind-params>> ] [ in-params>> ] bi
[
dup generator-bind? [
drop
] if
] 2map >>bind-params ;
-
+
M: retryable execute-statement* ( statement type -- )
drop [ retries>> iota ] [
[
nip
[ query-results dispose t ]
- [ ]
+ [ ]
[ regenerate-params bind-statement* f ] cleanup
] curry
] bi attempt-all drop ;
over [
NULL = [ 2drop NULL NULL ] when
] [
- drop NULL
+ drop NULL
] if* (sqlite-bind-type) ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
-USING: accessors alien.syntax continuations debugger kernel\r
-namespaces tools.test ;\r
-IN: debugger.tests\r
-\r
-[ ] [ [ drop ] [ error. ] recover ] unit-test\r
-\r
-[ f ] [ { } vm-error? ] unit-test\r
-[ f ] [ { "A" "B" } vm-error? ] unit-test\r
-\r
-[ ] [\r
-T{ test-failure\r
- { error\r
- {\r
- "kernel-error"\r
- 10\r
- {\r
- B{\r
- 88 73 110 112 117 116 69 110 97 98 108 101 0\r
- }\r
- B{\r
- 88 73 110 112 117 116 69 110 97 98 108 101\r
- 64 56 0\r
- }\r
- B{\r
- 95 88 73 110 112 117 116 69 110 97 98 108\r
- 101 64 56 0\r
- }\r
- B{\r
- 64 88 73 110 112 117 116 69 110 97 98 108\r
- 101 64 56 0\r
- }\r
- }\r
- DLL" xinput1_3.dll"\r
- }\r
- }\r
- { asset { "Unit Test" [ ] [ dup ] } }\r
- { file "resource:basis/game/input/input-tests.factor" }\r
- { line# 6 }\r
- { continuation f }\r
-} error.\r
-] unit-test\r
-\r
-[ "foo" { 1 2 3 "foo" } ] [\r
- [ 1 2 3 "foo" throw ] [ ] recover error-continuation get data>>\r
-] unit-test\r
+USING: accessors alien.syntax continuations debugger kernel
+namespaces tools.test ;
+IN: debugger.tests
+
+[ ] [ [ drop ] [ error. ] recover ] unit-test
+
+[ f ] [ { } vm-error? ] unit-test
+[ f ] [ { "A" "B" } vm-error? ] unit-test
+
+[ ] [
+T{ test-failure
+ { error
+ {
+ "kernel-error"
+ 10
+ {
+ B{
+ 88 73 110 112 117 116 69 110 97 98 108 101 0
+ }
+ B{
+ 88 73 110 112 117 116 69 110 97 98 108 101
+ 64 56 0
+ }
+ B{
+ 95 88 73 110 112 117 116 69 110 97 98 108
+ 101 64 56 0
+ }
+ B{
+ 64 88 73 110 112 117 116 69 110 97 98 108
+ 101 64 56 0
+ }
+ }
+ DLL" xinput1_3.dll"
+ }
+ }
+ { asset { "Unit Test" [ ] [ dup ] } }
+ { file "resource:basis/game/input/input-tests.factor" }
+ { line# 6 }
+ { continuation f }
+} error.
+] unit-test
+
+[ "foo" { 1 2 3 "foo" } ] [
+ [ 1 2 3 "foo" throw ] [ ] recover error-continuation get data>>
+] unit-test
"Win32 error 0x" write
dup n>> 0xffff,ffff bitand >hex write ": " write
string>> write ;
-
TUPLE: broadcast < consultation ;
: <consultation> ( group class quot -- consultation )
- f consultation boa ;
+ f consultation boa ;
: <broadcast> ( group class quot -- consultation )
- [ check-broadcast-group ] 2dip f broadcast boa ;
+ [ check-broadcast-group ] 2dip f broadcast boa ;
: create-consult-method ( word consultation -- method )
[ class>> swap first create-method dup fake-definition ] keep
M: dlist >pprint-sequence dlist>sequence ;
M: dlist pprint-narrow? drop f ;
M: dlist pprint* pprint-object ;
-
atom-path get [ "atom" ?find-in-path ] unless* ,
number>string ":" glue ,
] { } make ;
-
: run-and-wait-for-editor ( command -- )
<process>
- swap >>command
+ swap >>command
editor-detached? >>detached
run-process
300 milliseconds sleep
[
editpadpro-path , number>string "/l" prepend , ,
] { } make ;
-
etexteditor-path ,
[ , ] [ "--line" , number>string , ] bi*
] { } make ;
-
'[
_ dup ?last ?last CHAR: \\ =
[ [ pop "|" rot 3append ] keep ] when
- push
+ push
] each
] keep ;
{ CHAR: | [ parse-table ] }
{ CHAR: _ [ parse-line ] }
{ CHAR: - [ parse-ul ] }
- { CHAR: # [ parse-ol ] }
+ { CHAR: # [ parse-ol ] }
{ CHAR: [ [ parse-code ] }
{ f [ rest-slice f ] }
[ drop unclip-slice make-paragraph ]
: convert-farkup ( string -- string' )
[ write-farkup ] with-string-writer ;
-
TUPLE: selection string start end color ;
-C: <selection> selection
\ No newline at end of file
+C: <selection> selection
-USING: help.markup help.syntax quotations kernel ;\r
-IN: fry\r
-\r
-HELP: _\r
-{ $description "Fry specifier. Inserts a literal value into the fried quotation." }\r
-{ $examples "See " { $link "fry.examples" } "." } ;\r
-\r
-HELP: @\r
-{ $description "Fry specifier. Splices a quotation into the fried quotation." }\r
-{ $examples "See " { $link "fry.examples" } "." } ;\r
-\r
-HELP: fry\r
-{ $values { "quot" quotation } { "quot'" quotation } }\r
-{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }\r
-{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"\r
- { $code "[ X ] fry call" "'[ X ]" }\r
-}\r
-{ $examples "See " { $link "fry.examples" } "." } ;\r
-\r
-HELP: '[\r
-{ $syntax "'[ code... ]" }\r
-{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }\r
-{ $examples "See " { $link "fry.examples" } "." } ;\r
-\r
-HELP: >r/r>-in-fry-error\r
-{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to retain stack manipulation primitives." } ;\r
-\r
-ARTICLE: "fry.examples" "Examples of fried quotations"\r
-"The easiest way to understand fried quotations is to look at some examples."\r
-$nl\r
-"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"\r
-{ $code "{ 10 20 30 } '[ . ] each" }\r
-"Occurrences of " { $link _ } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"\r
-{ $code \r
- "{ 10 20 30 } 5 '[ _ + ] map"\r
- "{ 10 20 30 } 5 [ + ] curry map"\r
- "{ 10 20 30 } [ 5 + ] map"\r
-}\r
-"Occurrences of " { $link _ } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"\r
-{ $code \r
- "{ 10 20 30 } 5 '[ 3 _ / ] map"\r
- "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"\r
- "{ 10 20 30 } [ 3 5 / ] map"\r
-}\r
-"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet "_ call" } ". The following four lines are equivalent:"\r
-{ $code \r
- "{ 10 20 30 } [ sq ] '[ @ . ] each"\r
- "{ 10 20 30 } [ sq ] [ call . ] curry each"\r
- "{ 10 20 30 } [ sq ] [ . ] compose each"\r
- "{ 10 20 30 } [ sq . ] each"\r
-}\r
-"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed, and the result is considerably more concise and readable than the version using " { $link curry } " and " { $link compose } " directly:"\r
-{ $code\r
- "{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map"\r
- "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry compose compose map"\r
- "{ 8 13 14 27 } [ even? dup 5 ? ] map"\r
-}\r
-"The following is a no-op:"\r
-{ $code "'[ @ ]" }\r
-"Here are some built-in combinators rewritten in terms of fried quotations:"\r
-{ $table\r
- { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }\r
- { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }\r
- { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
-} ;\r
-\r
-ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
-"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"\r
-{ $code\r
- "'[ [ _ key? ] all? ] filter"\r
- "[ [ key? ] curry all? ] curry filter"\r
-}\r
-"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"\r
-{ $code\r
- "'[ 3 _ + 4 _ / ]"\r
- "[| a b | 3 a + 4 b / ]"\r
-} ;\r
-\r
-ARTICLE: "fry" "Fried quotations"\r
-"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes” (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."\r
-$nl\r
-"Fried quotations are started by a special parsing word:"\r
-{ $subsections POSTPONE: '[ }\r
-"There are two types of fry specifiers; the first can hold a value, and the second “splices” a quotation, as if it were inserted without surrounding brackets:"\r
-{ $subsections\r
- _\r
- @\r
-}\r
-"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."\r
-{ $subsections\r
- "fry.examples"\r
- "fry.philosophy"\r
-}\r
-"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."\r
-$nl\r
-"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"\r
-{ $subsections fry }\r
-"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;\r
-\r
-ABOUT: "fry"\r
+USING: help.markup help.syntax quotations kernel ;
+IN: fry
+
+HELP: _
+{ $description "Fry specifier. Inserts a literal value into the fried quotation." }
+{ $examples "See " { $link "fry.examples" } "." } ;
+
+HELP: @
+{ $description "Fry specifier. Splices a quotation into the fried quotation." }
+{ $examples "See " { $link "fry.examples" } "." } ;
+
+HELP: fry
+{ $values { "quot" quotation } { "quot'" quotation } }
+{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }
+{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"
+ { $code "[ X ] fry call" "'[ X ]" }
+}
+{ $examples "See " { $link "fry.examples" } "." } ;
+
+HELP: '[
+{ $syntax "'[ code... ]" }
+{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
+{ $examples "See " { $link "fry.examples" } "." } ;
+
+HELP: >r/r>-in-fry-error
+{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to retain stack manipulation primitives." } ;
+
+ARTICLE: "fry.examples" "Examples of fried quotations"
+"The easiest way to understand fried quotations is to look at some examples."
+$nl
+"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
+{ $code "{ 10 20 30 } '[ . ] each" }
+"Occurrences of " { $link _ } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"
+{ $code
+ "{ 10 20 30 } 5 '[ _ + ] map"
+ "{ 10 20 30 } 5 [ + ] curry map"
+ "{ 10 20 30 } [ 5 + ] map"
+}
+"Occurrences of " { $link _ } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"
+{ $code
+ "{ 10 20 30 } 5 '[ 3 _ / ] map"
+ "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
+ "{ 10 20 30 } [ 3 5 / ] map"
+}
+"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet "_ call" } ". The following four lines are equivalent:"
+{ $code
+ "{ 10 20 30 } [ sq ] '[ @ . ] each"
+ "{ 10 20 30 } [ sq ] [ call . ] curry each"
+ "{ 10 20 30 } [ sq ] [ . ] compose each"
+ "{ 10 20 30 } [ sq . ] each"
+}
+"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed, and the result is considerably more concise and readable than the version using " { $link curry } " and " { $link compose } " directly:"
+{ $code
+ "{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map"
+ "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry compose compose map"
+ "{ 8 13 14 27 } [ even? dup 5 ? ] map"
+}
+"The following is a no-op:"
+{ $code "'[ @ ]" }
+"Here are some built-in combinators rewritten in terms of fried quotations:"
+{ $table
+ { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
+ { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
+ { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
+} ;
+
+ARTICLE: "fry.philosophy" "Fried quotation philosophy"
+"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } ". They can clean up code with lots of currying and composition, particularly when quotations are nested:"
+{ $code
+ "'[ [ _ key? ] all? ] filter"
+ "[ [ key? ] curry all? ] curry filter"
+}
+"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
+{ $code
+ "'[ 3 _ + 4 _ / ]"
+ "[| a b | 3 a + 4 b / ]"
+} ;
+
+ARTICLE: "fry" "Fried quotations"
+"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with “holes” (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
+$nl
+"Fried quotations are started by a special parsing word:"
+{ $subsections POSTPONE: '[ }
+"There are two types of fry specifiers; the first can hold a value, and the second “splices” a quotation, as if it were inserted without surrounding brackets:"
+{ $subsections
+ _
+ @
+}
+"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
+{ $subsections
+ "fry.examples"
+ "fry.philosophy"
+}
+"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
+$nl
+"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
+{ $subsections fry }
+"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
+
+ABOUT: "fry"
dup can-serve-file? [
<ftp-put> fulfill-client
] [
- drop
+ drop
<ftp-disconnect> fulfill-client
] if ;
-! Copyright (C) 2008, 2009 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors sequences kernel assocs combinators\r
-validators http hashtables namespaces fry continuations locals\r
-io arrays math boxes splitting urls\r
-xml.entities\r
-http.server\r
-http.server.responses\r
-furnace.utilities\r
-furnace.redirection\r
-furnace.conversations\r
-furnace.chloe-tags\r
-html.forms\r
-html.components\r
-html.templates.chloe\r
-html.templates.chloe.syntax\r
-html.templates.chloe.compiler ;\r
-IN: furnace.actions\r
-\r
-SYMBOL: rest\r
-\r
-TUPLE: action rest init authorize display validate submit ;\r
-\r
-: new-action ( class -- action )\r
- new [ ] >>init [ ] >>validate [ ] >>authorize ; inline\r
-\r
-: <action> ( -- action )\r
- action new-action ;\r
-\r
-: merge-forms ( form -- )\r
- [ form get ] dip\r
- [ [ errors>> ] bi@ append! drop ]\r
- [ [ values>> ] bi@ assoc-union! drop ]\r
- [ validation-failed>> >>validation-failed drop ]\r
- 2tri ;\r
-\r
-: set-nested-form ( form name -- )\r
- [\r
- merge-forms\r
- ] [\r
- unclip [ set-nested-form ] nest-form\r
- ] if-empty ;\r
-\r
-: restore-validation-errors ( -- )\r
- form cget [\r
- nested-forms cget set-nested-form\r
- ] when* ;\r
-\r
-: handle-get ( action -- response )\r
- '[\r
- _ dup display>> [\r
- {\r
- [ init>> call( -- ) ]\r
- [ authorize>> call( -- ) ]\r
- [ drop restore-validation-errors ]\r
- [ display>> call( -- response ) ]\r
- } cleave\r
- ] [ drop <400> ] if\r
- ] with-exit-continuation ;\r
-\r
-CONSTANT: revalidate-url-key "__u"\r
-\r
-: revalidate-url ( -- url/f )\r
- revalidate-url-key param\r
- dup [ >url ensure-port [ same-host? ] keep and ] when ;\r
-\r
-: validation-failed ( -- * )\r
- post-request? revalidate-url and [\r
- begin-conversation\r
- nested-forms-key param " " split harvest nested-forms cset\r
- form get form cset\r
- <continue-conversation>\r
- ] [ <400> ] if*\r
- exit-with ;\r
-\r
-: handle-post ( action -- response )\r
- '[\r
- _ dup submit>> [\r
- [ validate>> call( -- ) ]\r
- [ authorize>> call( -- ) ]\r
- [ submit>> call( -- response ) ]\r
- tri\r
- ] [ drop <400> ] if\r
- ] with-exit-continuation ;\r
-\r
-: handle-rest ( path action -- )\r
- rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;\r
-\r
-: init-action ( path action -- )\r
- begin-form\r
- handle-rest ;\r
-\r
-M: action call-responder* ( path action -- response )\r
- [ init-action ] keep\r
- request get method>> {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case ;\r
-\r
-M: action modify-form\r
- drop url get revalidate-url-key hidden-form-field ;\r
-\r
-: check-validation ( -- )\r
- validation-failed? [ validation-failed ] when ;\r
-\r
-: validate-params ( validators -- )\r
- params get swap validate-values check-validation ;\r
-\r
-: validate-integer-id ( -- )\r
- { { "id" [ v-number ] } } validate-params ;\r
-\r
-TUPLE: page-action < action template ;\r
-\r
-: <chloe-content> ( path -- response )\r
- resolve-template-path <chloe> <html-content> ;\r
-\r
-: <page-action> ( -- page )\r
- page-action new-action\r
- dup '[ _ template>> <chloe-content> ] >>display ;\r
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences kernel assocs combinators
+validators http hashtables namespaces fry continuations locals
+io arrays math boxes splitting urls
+xml.entities
+http.server
+http.server.responses
+furnace.utilities
+furnace.redirection
+furnace.conversations
+furnace.chloe-tags
+html.forms
+html.components
+html.templates.chloe
+html.templates.chloe.syntax
+html.templates.chloe.compiler ;
+IN: furnace.actions
+
+SYMBOL: rest
+
+TUPLE: action rest init authorize display validate submit ;
+
+: new-action ( class -- action )
+ new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
+
+: <action> ( -- action )
+ action new-action ;
+
+: merge-forms ( form -- )
+ [ form get ] dip
+ [ [ errors>> ] bi@ append! drop ]
+ [ [ values>> ] bi@ assoc-union! drop ]
+ [ validation-failed>> >>validation-failed drop ]
+ 2tri ;
+
+: set-nested-form ( form name -- )
+ [
+ merge-forms
+ ] [
+ unclip [ set-nested-form ] nest-form
+ ] if-empty ;
+
+: restore-validation-errors ( -- )
+ form cget [
+ nested-forms cget set-nested-form
+ ] when* ;
+
+: handle-get ( action -- response )
+ '[
+ _ dup display>> [
+ {
+ [ init>> call( -- ) ]
+ [ authorize>> call( -- ) ]
+ [ drop restore-validation-errors ]
+ [ display>> call( -- response ) ]
+ } cleave
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
+
+CONSTANT: revalidate-url-key "__u"
+
+: revalidate-url ( -- url/f )
+ revalidate-url-key param
+ dup [ >url ensure-port [ same-host? ] keep and ] when ;
+
+: validation-failed ( -- * )
+ post-request? revalidate-url and [
+ begin-conversation
+ nested-forms-key param " " split harvest nested-forms cset
+ form get form cset
+ <continue-conversation>
+ ] [ <400> ] if*
+ exit-with ;
+
+: handle-post ( action -- response )
+ '[
+ _ dup submit>> [
+ [ validate>> call( -- ) ]
+ [ authorize>> call( -- ) ]
+ [ submit>> call( -- response ) ]
+ tri
+ ] [ drop <400> ] if
+ ] with-exit-continuation ;
+
+: handle-rest ( path action -- )
+ rest>> dup [ [ "/" join ] dip set-param ] [ 2drop ] if ;
+
+: init-action ( path action -- )
+ begin-form
+ handle-rest ;
+
+M: action call-responder* ( path action -- response )
+ [ init-action ] keep
+ request get method>> {
+ { "GET" [ handle-get ] }
+ { "HEAD" [ handle-get ] }
+ { "POST" [ handle-post ] }
+ } case ;
+
+M: action modify-form
+ drop url get revalidate-url-key hidden-form-field ;
+
+: check-validation ( -- )
+ validation-failed? [ validation-failed ] when ;
+
+: validate-params ( validators -- )
+ params get swap validate-values check-validation ;
+
+: validate-integer-id ( -- )
+ { { "id" [ v-number ] } } validate-params ;
+
+TUPLE: page-action < action template ;
+
+: <chloe-content> ( path -- response )
+ resolve-template-path <chloe> <html-content> ;
+
+: <page-action> ( -- page )
+ page-action new-action
+ dup '[ _ template>> <chloe-content> ] >>display ;
-! Copyright (c) 2008, 2010 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs namespaces kernel sequences sets\r
-destructors combinators fry logging io.encodings.utf8\r
-io.encodings.string io.binary io.sockets.secure random checksums\r
-checksums.sha urls\r
-html.forms\r
-http.server\r
-http.server.filters\r
-http.server.dispatchers\r
-furnace.actions\r
-furnace.utilities\r
-furnace.redirection\r
-furnace.boilerplate\r
-furnace.auth.providers\r
-furnace.auth.providers.db ;\r
-FROM: assocs => change-at ;\r
-FROM: namespaces => set ;\r
-IN: furnace.auth\r
-\r
-SYMBOL: logged-in-user\r
-\r
-: logged-in? ( -- ? )\r
- logged-in-user get >boolean ;\r
-\r
-: username ( -- string/f )\r
- logged-in-user get dup [ username>> ] when ;\r
-\r
-GENERIC: init-user-profile ( responder -- )\r
-\r
-M: object init-user-profile drop ;\r
-\r
-M: dispatcher init-user-profile\r
- default>> init-user-profile ;\r
-\r
-M: filter-responder init-user-profile\r
- responder>> init-user-profile ;\r
-\r
-: current-profile ( -- assoc ) logged-in-user get profile>> ;\r
-\r
-: user-changed ( -- )\r
- logged-in-user get t >>changed? drop ;\r
-\r
-: uget ( key -- value )\r
- current-profile at ;\r
-\r
-: uset ( value key -- )\r
- current-profile set-at\r
- user-changed ;\r
-\r
-: uchange ( quot key -- )\r
- current-profile swap change-at\r
- user-changed ; inline\r
-\r
-SYMBOL: capabilities\r
-\r
-V{ } clone capabilities set-global\r
-\r
-: define-capability ( word -- ) capabilities get adjoin ;\r
-\r
-TUPLE: realm < dispatcher name users checksum secure ;\r
-\r
-GENERIC: login-required* ( description capabilities realm -- response )\r
-\r
-GENERIC: user-registered ( user realm -- response )\r
-\r
-M: object user-registered 2drop URL" $realm" <redirect> ;\r
-\r
-GENERIC: init-realm ( realm -- )\r
-\r
-GENERIC: logged-in-username ( realm -- username )\r
-\r
-: login-required ( description capabilities -- * )\r
- realm get login-required* exit-with ;\r
-\r
-: new-realm ( responder name class -- realm )\r
- new-dispatcher\r
- swap >>name\r
- swap >>default\r
- users-in-db >>users\r
- sha-256 >>checksum\r
- ssl-supported? >>secure ; inline\r
-\r
-: users ( -- provider )\r
- realm get users>> ;\r
-\r
-TUPLE: user-saver user ;\r
-\r
-C: <user-saver> user-saver\r
-\r
-M: user-saver dispose\r
- user>> dup changed?>> [ users update-user ] [ drop ] if ;\r
-\r
-: save-user-after ( user -- )\r
- <user-saver> &dispose drop ;\r
-\r
-: init-user ( user -- )\r
- [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;\r
-\r
-\ init-user DEBUG add-input-logging\r
-\r
-M: realm call-responder* ( path responder -- response )\r
- dup realm set\r
- logged-in? [\r
- dup init-realm\r
- dup logged-in-username\r
- dup [ users get-user ] when\r
- init-user\r
- ] unless\r
- call-next-method ;\r
-\r
-: encode-password ( string salt -- bytes )\r
- [ utf8 encode ] [ 4 >be ] bi* append\r
- realm get checksum>> checksum-bytes ;\r
-\r
-: >>encoded-password ( user string -- user )\r
- 32 random-bits [ encode-password ] keep\r
- [ >>password ] [ >>salt ] bi* ; inline\r
-\r
-: valid-login? ( password user -- ? )\r
- [ salt>> encode-password ] [ password>> ] bi = ;\r
-\r
-: check-login ( password username -- user/f )\r
- users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
-\r
-: if-secure-realm ( quot -- )\r
- realm get secure>> [ if-secure ] [ call ] if ; inline\r
-\r
-TUPLE: secure-realm-only < filter-responder ;\r
-\r
-C: <secure-realm-only> secure-realm-only\r
-\r
-M: secure-realm-only call-responder*\r
- '[ _ _ call-next-method ] if-secure-realm ;\r
-\r
-TUPLE: protected < filter-responder description capabilities ;\r
-\r
-: <protected> ( responder -- protected )\r
- protected new\r
- swap >>responder ;\r
-\r
-: have-capabilities? ( capabilities -- ? )\r
- realm get secure>> secure-connection? not and [ drop f ] [\r
- logged-in-user get {\r
- { [ dup not ] [ 2drop f ] }\r
- { [ dup deleted>> 1 = ] [ 2drop f ] }\r
- [ capabilities>> subset? ]\r
- } cond\r
- ] if ;\r
-\r
-M: protected call-responder* ( path responder -- response )\r
- dup protected set\r
- dup capabilities>> have-capabilities?\r
- [ call-next-method ] [\r
- [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*\r
- realm get login-required*\r
- ] if ;\r
-\r
-: <auth-boilerplate> ( responder -- responder' )\r
- <boilerplate> { realm "boilerplate" } >>template ;\r
-\r
-: password-mismatch ( -- * )\r
- "passwords do not match" validation-error\r
- validation-failed ;\r
-\r
-: same-password-twice ( -- )\r
- "new-password" value "verify-password" value =\r
- [ password-mismatch ] unless ;\r
-\r
-: user-exists ( -- * )\r
- "username taken" validation-error\r
- validation-failed ;\r
+! Copyright (c) 2008, 2010 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs namespaces kernel sequences sets
+destructors combinators fry logging io.encodings.utf8
+io.encodings.string io.binary io.sockets.secure random checksums
+checksums.sha urls
+html.forms
+http.server
+http.server.filters
+http.server.dispatchers
+furnace.actions
+furnace.utilities
+furnace.redirection
+furnace.boilerplate
+furnace.auth.providers
+furnace.auth.providers.db ;
+FROM: assocs => change-at ;
+FROM: namespaces => set ;
+IN: furnace.auth
+
+SYMBOL: logged-in-user
+
+: logged-in? ( -- ? )
+ logged-in-user get >boolean ;
+
+: username ( -- string/f )
+ logged-in-user get dup [ username>> ] when ;
+
+GENERIC: init-user-profile ( responder -- )
+
+M: object init-user-profile drop ;
+
+M: dispatcher init-user-profile
+ default>> init-user-profile ;
+
+M: filter-responder init-user-profile
+ responder>> init-user-profile ;
+
+: current-profile ( -- assoc ) logged-in-user get profile>> ;
+
+: user-changed ( -- )
+ logged-in-user get t >>changed? drop ;
+
+: uget ( key -- value )
+ current-profile at ;
+
+: uset ( value key -- )
+ current-profile set-at
+ user-changed ;
+
+: uchange ( quot key -- )
+ current-profile swap change-at
+ user-changed ; inline
+
+SYMBOL: capabilities
+
+V{ } clone capabilities set-global
+
+: define-capability ( word -- ) capabilities get adjoin ;
+
+TUPLE: realm < dispatcher name users checksum secure ;
+
+GENERIC: login-required* ( description capabilities realm -- response )
+
+GENERIC: user-registered ( user realm -- response )
+
+M: object user-registered 2drop URL" $realm" <redirect> ;
+
+GENERIC: init-realm ( realm -- )
+
+GENERIC: logged-in-username ( realm -- username )
+
+: login-required ( description capabilities -- * )
+ realm get login-required* exit-with ;
+
+: new-realm ( responder name class -- realm )
+ new-dispatcher
+ swap >>name
+ swap >>default
+ users-in-db >>users
+ sha-256 >>checksum
+ ssl-supported? >>secure ; inline
+
+: users ( -- provider )
+ realm get users>> ;
+
+TUPLE: user-saver user ;
+
+C: <user-saver> user-saver
+
+M: user-saver dispose
+ user>> dup changed?>> [ users update-user ] [ drop ] if ;
+
+: save-user-after ( user -- )
+ <user-saver> &dispose drop ;
+
+: init-user ( user -- )
+ [ [ logged-in-user set ] [ save-user-after ] bi ] when* ;
+
+\ init-user DEBUG add-input-logging
+
+M: realm call-responder* ( path responder -- response )
+ dup realm set
+ logged-in? [
+ dup init-realm
+ dup logged-in-username
+ dup [ users get-user ] when
+ init-user
+ ] unless
+ call-next-method ;
+
+: encode-password ( string salt -- bytes )
+ [ utf8 encode ] [ 4 >be ] bi* append
+ realm get checksum>> checksum-bytes ;
+
+: >>encoded-password ( user string -- user )
+ 32 random-bits [ encode-password ] keep
+ [ >>password ] [ >>salt ] bi* ; inline
+
+: valid-login? ( password user -- ? )
+ [ salt>> encode-password ] [ password>> ] bi = ;
+
+: check-login ( password username -- user/f )
+ users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
+
+: if-secure-realm ( quot -- )
+ realm get secure>> [ if-secure ] [ call ] if ; inline
+
+TUPLE: secure-realm-only < filter-responder ;
+
+C: <secure-realm-only> secure-realm-only
+
+M: secure-realm-only call-responder*
+ '[ _ _ call-next-method ] if-secure-realm ;
+
+TUPLE: protected < filter-responder description capabilities ;
+
+: <protected> ( responder -- protected )
+ protected new
+ swap >>responder ;
+
+: have-capabilities? ( capabilities -- ? )
+ realm get secure>> secure-connection? not and [ drop f ] [
+ logged-in-user get {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup deleted>> 1 = ] [ 2drop f ] }
+ [ capabilities>> subset? ]
+ } cond
+ ] if ;
+
+M: protected call-responder* ( path responder -- response )
+ dup protected set
+ dup capabilities>> have-capabilities?
+ [ call-next-method ] [
+ [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
+ realm get login-required*
+ ] if ;
+
+: <auth-boilerplate> ( responder -- responder' )
+ <boilerplate> { realm "boilerplate" } >>template ;
+
+: password-mismatch ( -- * )
+ "passwords do not match" validation-error
+ validation-failed ;
+
+: same-password-twice ( -- )
+ "new-password" value "verify-password" value =
+ [ password-mismatch ] unless ;
+
+: user-exists ( -- * )
+ "username taken" validation-error
+ validation-failed ;
-! Copyright (c) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel splitting base64 namespaces make strings\r
-http http.server.responses furnace.auth ;\r
-IN: furnace.auth.basic\r
-\r
-TUPLE: basic-auth-realm < realm ;\r
-\r
-: <basic-auth-realm> ( responder name -- realm )\r
- basic-auth-realm new-realm ;\r
-\r
-: parse-basic-auth ( header -- username/f password/f )\r
- dup [\r
- " " split1 swap "Basic" = [\r
- base64> >string ":" split1\r
- ] [ drop f f ] if\r
- ] [ drop f f ] if ;\r
-\r
-: <401> ( realm -- response )\r
- 401 "Invalid username or password" <trivial-response>\r
- [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;\r
-\r
-M: basic-auth-realm login-required* ( description capabilities realm -- response )\r
- 2nip name>> <401> ;\r
-\r
-M: basic-auth-realm logged-in-username ( realm -- uid )\r
- drop\r
- request get "authorization" header parse-basic-auth\r
- dup [ over check-login swap and ] [ 2drop f ] if ;\r
-\r
-M: basic-auth-realm init-realm drop ;\r
+! Copyright (c) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel splitting base64 namespaces make strings
+http http.server.responses furnace.auth ;
+IN: furnace.auth.basic
+
+TUPLE: basic-auth-realm < realm ;
+
+: <basic-auth-realm> ( responder name -- realm )
+ basic-auth-realm new-realm ;
+
+: parse-basic-auth ( header -- username/f password/f )
+ dup [
+ " " split1 swap "Basic" = [
+ base64> >string ":" split1
+ ] [ drop f f ] if
+ ] [ drop f f ] if ;
+
+: <401> ( realm -- response )
+ 401 "Invalid username or password" <trivial-response>
+ [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;
+
+M: basic-auth-realm login-required* ( description capabilities realm -- response )
+ 2nip name>> <401> ;
+
+M: basic-auth-realm logged-in-username ( realm -- uid )
+ drop
+ request get "authorization" header parse-basic-auth
+ dup [ over check-login swap and ] [ 2drop f ] if ;
+
+M: basic-auth-realm init-realm drop ;
drop
URL" $realm" end-aside
] >>submit ;
-
+
: allow-deactivation ( realm -- realm )
<deactivate-user-action> <protected>
"delete your profile" >>description
{ "realname" [ [ v-one-line ] v-optional ] }
{ "password" [ ] }
{ "new-password" [ [ v-password ] v-optional ] }
- { "verify-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
{ "email" [ [ v-email ] v-optional ] }
} validate-params
-! Copyright (c) 2008 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors namespaces sequences math.parser\r
-calendar checksums validators urls logging html.forms\r
-http http.server http.server.dispatchers\r
-furnace.auth\r
-furnace.asides\r
-furnace.actions\r
-furnace.sessions\r
-furnace.utilities\r
-furnace.redirection\r
-furnace.conversations\r
-furnace.auth.login.permits ;\r
-IN: furnace.auth.login\r
-\r
-SYMBOL: permit-id\r
-\r
-: permit-id-key ( realm -- string )\r
- hex-string "__p_" prepend ;\r
-\r
-: client-permit-id ( realm -- id/f )\r
- permit-id-key client-state dup [ string>number ] when ;\r
-\r
-TUPLE: login-realm < realm timeout domain ;\r
-\r
-M: login-realm init-realm\r
- name>> client-permit-id permit-id set ;\r
-\r
-M: login-realm logged-in-username\r
- drop permit-id get dup [ get-permit-uid ] when ;\r
-\r
-M: login-realm modify-form ( responder -- xml/f )\r
- drop permit-id get realm get name>> permit-id-key hidden-form-field ;\r
-\r
-: <permit-cookie> ( -- cookie )\r
- permit-id get realm get name>> permit-id-key <cookie>\r
- "$login-realm" resolve-base-path >>path\r
- realm get\r
- [ domain>> >>domain ]\r
- [ secure>> >>secure ]\r
- bi ;\r
-\r
-: put-permit-cookie ( response -- response' )\r
- <permit-cookie> put-cookie ;\r
-\r
-\ put-permit-cookie DEBUG add-input-logging\r
-\r
-: successful-login ( user -- response )\r
- [ username>> make-permit permit-id set ] [ init-user ] bi\r
- URL" $realm" end-aside\r
- put-permit-cookie ;\r
-\r
-\ successful-login DEBUG add-input-logging\r
-\r
-: logout ( -- response )\r
- permit-id get [ delete-permit ] when*\r
- URL" $realm" end-aside ;\r
-\r
-<PRIVATE\r
-\r
-SYMBOL: description\r
-SYMBOL: capabilities\r
-\r
-PRIVATE>\r
-\r
-CONSTANT: flashed-variables { description capabilities }\r
-\r
-: login-failed ( -- * )\r
- "invalid username or password" validation-error\r
- validation-failed ;\r
-\r
-: <login-action> ( -- action )\r
- <page-action>\r
- [\r
- description cget "description" set-value\r
- capabilities cget words>strings "capabilities" set-value\r
- ] >>init\r
-\r
- { login-realm "login" } >>template\r
-\r
- [\r
- {\r
- { "username" [ v-required ] }\r
- { "password" [ v-required ] }\r
- } validate-params\r
-\r
- "password" value\r
- "username" value check-login\r
- [ successful-login ] [ login-failed ] if*\r
- ] >>submit\r
- <auth-boilerplate>\r
- <secure-realm-only> ;\r
-\r
-: <logout-action> ( -- action )\r
- <action>\r
- [ logout ] >>submit ;\r
-\r
-M: login-realm login-required* ( description capabilities login -- response )\r
- begin-conversation\r
- [ description cset ] [ capabilities cset ] [ secure>> ] tri*\r
- [\r
- url get >secure-url begin-aside\r
- URL" $realm/login" >secure-url <continue-conversation>\r
- ] [\r
- url get begin-aside\r
- URL" $realm/login" <continue-conversation>\r
- ] if ;\r
-\r
-M: login-realm user-registered ( user realm -- response )\r
- drop successful-login ;\r
-\r
-: <login-realm> ( responder name -- realm )\r
- login-realm new-realm\r
- <login-action> "login" add-responder\r
- <logout-action> "logout" add-responder\r
- 20 minutes >>timeout ;\r
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces sequences math.parser
+calendar checksums validators urls logging html.forms
+http http.server http.server.dispatchers
+furnace.auth
+furnace.asides
+furnace.actions
+furnace.sessions
+furnace.utilities
+furnace.redirection
+furnace.conversations
+furnace.auth.login.permits ;
+IN: furnace.auth.login
+
+SYMBOL: permit-id
+
+: permit-id-key ( realm -- string )
+ hex-string "__p_" prepend ;
+
+: client-permit-id ( realm -- id/f )
+ permit-id-key client-state dup [ string>number ] when ;
+
+TUPLE: login-realm < realm timeout domain ;
+
+M: login-realm init-realm
+ name>> client-permit-id permit-id set ;
+
+M: login-realm logged-in-username
+ drop permit-id get dup [ get-permit-uid ] when ;
+
+M: login-realm modify-form ( responder -- xml/f )
+ drop permit-id get realm get name>> permit-id-key hidden-form-field ;
+
+: <permit-cookie> ( -- cookie )
+ permit-id get realm get name>> permit-id-key <cookie>
+ "$login-realm" resolve-base-path >>path
+ realm get
+ [ domain>> >>domain ]
+ [ secure>> >>secure ]
+ bi ;
+
+: put-permit-cookie ( response -- response' )
+ <permit-cookie> put-cookie ;
+
+\ put-permit-cookie DEBUG add-input-logging
+
+: successful-login ( user -- response )
+ [ username>> make-permit permit-id set ] [ init-user ] bi
+ URL" $realm" end-aside
+ put-permit-cookie ;
+
+\ successful-login DEBUG add-input-logging
+
+: logout ( -- response )
+ permit-id get [ delete-permit ] when*
+ URL" $realm" end-aside ;
+
+<PRIVATE
+
+SYMBOL: description
+SYMBOL: capabilities
+
+PRIVATE>
+
+CONSTANT: flashed-variables { description capabilities }
+
+: login-failed ( -- * )
+ "invalid username or password" validation-error
+ validation-failed ;
+
+: <login-action> ( -- action )
+ <page-action>
+ [
+ description cget "description" set-value
+ capabilities cget words>strings "capabilities" set-value
+ ] >>init
+
+ { login-realm "login" } >>template
+
+ [
+ {
+ { "username" [ v-required ] }
+ { "password" [ v-required ] }
+ } validate-params
+
+ "password" value
+ "username" value check-login
+ [ successful-login ] [ login-failed ] if*
+ ] >>submit
+ <auth-boilerplate>
+ <secure-realm-only> ;
+
+: <logout-action> ( -- action )
+ <action>
+ [ logout ] >>submit ;
+
+M: login-realm login-required* ( description capabilities login -- response )
+ begin-conversation
+ [ description cset ] [ capabilities cset ] [ secure>> ] tri*
+ [
+ url get >secure-url begin-aside
+ URL" $realm/login" >secure-url <continue-conversation>
+ ] [
+ url get begin-aside
+ URL" $realm/login" <continue-conversation>
+ ] if ;
+
+M: login-realm user-registered ( user realm -- response )
+ drop successful-login ;
+
+: <login-realm> ( responder name -- realm )
+ login-realm new-realm
+ <login-action> "login" add-responder
+ <logout-action> "logout" add-responder
+ 20 minutes >>timeout ;
swap >>uid
session get id>> >>session
[ touch-permit ] [ insert-tuple ] [ id>> ] tri ;
-
+
: delete-permit ( id -- )
permit new-server-state delete-tuples ;
-USING: furnace.actions furnace.auth furnace.auth.providers \r
-furnace.auth.providers.assoc furnace.auth.login\r
-tools.test namespaces accessors kernel ;\r
-IN: furnace.auth.providers.assoc.tests\r
-\r
-<action> "Test" <login-realm>\r
- <users-in-memory> >>users\r
-realm set\r
-\r
-[ t ] [\r
- "slava" <user>\r
- "foobar" >>encoded-password\r
- "slava@factorcode.org" >>email\r
- H{ } clone >>profile\r
- users new-user\r
- username>> "slava" =\r
-] unit-test\r
-\r
-[ f ] [\r
- "slava" <user>\r
- H{ } clone >>profile\r
- users new-user\r
-] unit-test\r
-\r
-[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
-[ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
-\r
-[ t ] [ "user" get >boolean ] unit-test\r
-\r
-[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
-\r
-[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
-[ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
+USING: furnace.actions furnace.auth furnace.auth.providers
+furnace.auth.providers.assoc furnace.auth.login
+tools.test namespaces accessors kernel ;
+IN: furnace.auth.providers.assoc.tests
+
+<action> "Test" <login-realm>
+ <users-in-memory> >>users
+realm set
+
+[ t ] [
+ "slava" <user>
+ "foobar" >>encoded-password
+ "slava@factorcode.org" >>email
+ H{ } clone >>profile
+ users new-user
+ username>> "slava" =
+] unit-test
+
+[ f ] [
+ "slava" <user>
+ H{ } clone >>profile
+ users new-user
+] unit-test
+
+[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
+
+[ ] [ "foobar" "slava" check-login "user" set ] unit-test
+
+[ t ] [ "user" get >boolean ] unit-test
+
+[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
+
+[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
+
+[ f ] [ "foobar" "slava" check-login >boolean ] unit-test
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs kernel furnace.auth.providers ;\r
-IN: furnace.auth.providers.assoc\r
-\r
-TUPLE: users-in-memory assoc ;\r
-\r
-: <users-in-memory> ( -- provider )\r
- H{ } clone users-in-memory boa ;\r
-\r
-M: users-in-memory get-user ( username provider -- user/f )\r
- assoc>> at ;\r
-\r
-M: users-in-memory update-user ( user provider -- ) 2drop ;\r
-\r
-M: users-in-memory new-user ( user provider -- user/f )\r
- [ dup username>> ] dip assoc>>\r
- 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel furnace.auth.providers ;
+IN: furnace.auth.providers.assoc
+
+TUPLE: users-in-memory assoc ;
+
+: <users-in-memory> ( -- provider )
+ H{ } clone users-in-memory boa ;
+
+M: users-in-memory get-user ( username provider -- user/f )
+ assoc>> at ;
+
+M: users-in-memory update-user ( user provider -- ) 2drop ;
+
+M: users-in-memory new-user ( user provider -- user/f )
+ [ dup username>> ] dip assoc>>
+ 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;
-USING: furnace.actions\r
-furnace.auth\r
-furnace.auth.login\r
-furnace.auth.providers\r
-furnace.auth.providers.db tools.test\r
-namespaces db db.sqlite db.tuples continuations\r
-io.files io.files.temp io.directories accessors kernel\r
-sequences system ;\r
-IN: furnace.auth.providers.db.tests\r
-\r
-<action> "test" <login-realm> realm set\r
-\r
-: auth-test-db-name ( -- string )\r
- cpu name>> "auth-test." ".db" surround ;\r
-\r
-[ auth-test-db-name temp-file delete-file ] ignore-errors\r
-\r
-auth-test-db-name temp-file <sqlite-db> [\r
-\r
- user ensure-table\r
-\r
- [ t ] [\r
- "slava" <user>\r
- "foobar" >>encoded-password\r
- "slava@factorcode.org" >>email\r
- H{ } clone >>profile\r
- users new-user\r
- username>> "slava" =\r
- ] unit-test\r
-\r
- [ f ] [\r
- "slava" <user>\r
- H{ } clone >>profile\r
- users new-user\r
- ] unit-test\r
-\r
- [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
- [ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
-\r
- [ t ] [ "user" get >boolean ] unit-test\r
-\r
- [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
-\r
- [ ] [ "user" get users update-user ] unit-test\r
-\r
- [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
- [ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
-] with-db\r
+USING: furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.auth.providers
+furnace.auth.providers.db tools.test
+namespaces db db.sqlite db.tuples continuations
+io.files io.files.temp io.directories accessors kernel
+sequences system ;
+IN: furnace.auth.providers.db.tests
+
+<action> "test" <login-realm> realm set
+
+: auth-test-db-name ( -- string )
+ cpu name>> "auth-test." ".db" surround ;
+
+[ auth-test-db-name temp-file delete-file ] ignore-errors
+
+auth-test-db-name temp-file <sqlite-db> [
+
+ user ensure-table
+
+ [ t ] [
+ "slava" <user>
+ "foobar" >>encoded-password
+ "slava@factorcode.org" >>email
+ H{ } clone >>profile
+ users new-user
+ username>> "slava" =
+ ] unit-test
+
+ [ f ] [
+ "slava" <user>
+ H{ } clone >>profile
+ users new-user
+ ] unit-test
+
+ [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
+
+ [ ] [ "foobar" "slava" check-login "user" set ] unit-test
+
+ [ t ] [ "user" get >boolean ] unit-test
+
+ [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
+
+ [ ] [ "user" get users update-user ] unit-test
+
+ [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
+
+ [ f ] [ "foobar" "slava" check-login >boolean ] unit-test
+] with-db
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: furnace.auth.providers kernel ;\r
-IN: furnace.auth.providers.null\r
-\r
-SINGLETON: no-users\r
-\r
-M: no-users get-user 2drop f ;\r
-\r
-M: no-users new-user 2drop f ;\r
-\r
-M: no-users update-user 2drop ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: furnace.auth.providers kernel ;
+IN: furnace.auth.providers.null
+
+SINGLETON: no-users
+
+M: no-users get-user 2drop f ;
+
+M: no-users new-user 2drop f ;
+
+M: no-users update-user 2drop ;
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors random math.parser locals\r
-sequences math ;\r
-IN: furnace.auth.providers\r
-\r
-TUPLE: user\r
-username realname\r
-password salt\r
-email ticket capabilities profile deleted changed? ;\r
-\r
-: <user> ( username -- user )\r
- user new\r
- swap >>username\r
- 0 >>deleted ;\r
-\r
-GENERIC: get-user ( username provider -- user/f )\r
-\r
-GENERIC: update-user ( user provider -- )\r
-\r
-GENERIC: new-user ( user provider -- user/f )\r
-\r
-! Password recovery support\r
-\r
-:: issue-ticket ( email username provider -- user/f )\r
- username provider get-user :> user\r
- user [\r
- user email>> length 0 > [\r
- user email>> email = [\r
- user\r
- 256 random-bits >hex >>ticket\r
- dup provider update-user\r
- ] [ f ] if\r
- ] [ f ] if\r
- ] [ f ] if ;\r
-\r
-:: claim-ticket ( ticket username provider -- user/f )\r
- username provider get-user :> user\r
- user [\r
- user ticket>> ticket = [\r
- user f >>ticket dup provider update-user\r
- ] [ f ] if\r
- ] [ f ] if ;\r
-\r
-! For configuration\r
-\r
-: add-user ( provider user -- provider )\r
- over new-user [ "User exists" throw ] when ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors random math.parser locals
+sequences math ;
+IN: furnace.auth.providers
+
+TUPLE: user
+username realname
+password salt
+email ticket capabilities profile deleted changed? ;
+
+: <user> ( username -- user )
+ user new
+ swap >>username
+ 0 >>deleted ;
+
+GENERIC: get-user ( username provider -- user/f )
+
+GENERIC: update-user ( user provider -- )
+
+GENERIC: new-user ( user provider -- user/f )
+
+! Password recovery support
+
+:: issue-ticket ( email username provider -- user/f )
+ username provider get-user :> user
+ user [
+ user email>> length 0 > [
+ user email>> email = [
+ user
+ 256 random-bits >hex >>ticket
+ dup provider update-user
+ ] [ f ] if
+ ] [ f ] if
+ ] [ f ] if ;
+
+:: claim-ticket ( ticket username provider -- user/f )
+ username provider get-user :> user
+ user [
+ user ticket>> ticket = [
+ user f >>ticket dup provider update-user
+ ] [ f ] if
+ ] [ f ] if ;
+
+! For configuration
+
+: add-user ( provider user -- provider )
+ over new-user [ "User exists" throw ] when ;
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors continuations namespaces destructors\r
-db db.private db.pools io.pools http.server http.server.filters ;\r
-IN: furnace.db\r
-\r
-TUPLE: db-persistence < filter-responder pool disposed ;\r
-\r
-: <db-persistence> ( responder db -- responder' )\r
- <db-pool> f db-persistence boa ;\r
-\r
-M: db-persistence call-responder*\r
- [\r
- pool>> [ acquire-connection ] keep\r
- [ return-connection-later ] [ drop db-connection set ] 2bi\r
- ]\r
- [ call-next-method ] bi ;\r
-\r
-M: db-persistence dispose* pool>> dispose ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors continuations namespaces destructors
+db db.private db.pools io.pools http.server http.server.filters ;
+IN: furnace.db
+
+TUPLE: db-persistence < filter-responder pool disposed ;
+
+: <db-persistence> ( responder db -- responder' )
+ <db-pool> f db-persistence boa ;
+
+M: db-persistence call-responder*
+ [
+ pool>> [ acquire-connection ] keep
+ [ return-connection-later ] [ drop db-connection set ] 2bi
+ ]
+ [ call-next-method ] bi ;
+
+M: db-persistence dispose* pool>> dispose ;
-USING: tools.test http furnace.sessions furnace.actions\r
-http.server http.server.responses math namespaces make kernel\r
-accessors io.sockets io.servers prettyprint\r
-io.streams.string io.files io.files.temp io.directories\r
-splitting destructors sequences db db.tuples db.sqlite\r
-continuations urls math.parser furnace furnace.utilities ;\r
-IN: furnace.sessions.tests\r
-\r
-: with-session ( session quot -- )\r
- [\r
- [ [ save-session-after ] [ session set ] bi ] dip call\r
- ] with-destructors ; inline\r
-\r
-TUPLE: foo ;\r
-\r
-C: <foo> foo\r
-\r
-M: foo init-session* drop 0 "x" sset ;\r
-\r
-M: foo call-responder*\r
- 2drop\r
- "x" [ 1 + ] schange\r
- "x" sget number>string <html-content> ;\r
-\r
-: url-responder-mock-test ( -- string )\r
- [\r
- <request>\r
- "GET" >>method\r
- dup url>>\r
- "id" get session-id-key set-query-param\r
- "/" >>path drop\r
- init-request\r
- { } sessions get call-responder\r
- [ write-response-body drop ] with-string-writer\r
- ] with-destructors ;\r
-\r
-: sessions-mock-test ( -- string )\r
- [\r
- <request>\r
- "GET" >>method\r
- "cookies" get >>cookies\r
- dup url>> "/" >>path drop\r
- init-request\r
- { } sessions get call-responder\r
- [ write-response-body drop ] with-string-writer\r
- ] with-destructors ;\r
-\r
-: <exiting-action> ( -- action )\r
- <action>\r
- [ [ ] <text-content> exit-with ] >>display ;\r
-\r
-[ "auth-test.db" temp-file delete-file ] ignore-errors\r
-\r
-"auth-test.db" temp-file <sqlite-db> [\r
-\r
- <request> "GET" >>method init-request\r
- session ensure-table\r
-\r
- "127.0.0.1" 1234 <inet4> remote-address set\r
-\r
- [ ] [\r
- <foo> <sessions>\r
- sessions set\r
- ] unit-test\r
-\r
- [\r
- [ ] [\r
- empty-session\r
- 123 >>id session set\r
- ] unit-test\r
-\r
- [ ] [ 3 "x" sset ] unit-test\r
-\r
- [ 9 ] [ "x" sget sq ] unit-test\r
-\r
- [ ] [ "x" [ 1 - ] schange ] unit-test\r
-\r
- [ 4 ] [ "x" sget sq ] unit-test\r
-\r
- [ t ] [ session get changed?>> ] unit-test\r
- ] with-scope\r
-\r
- [ t ] [\r
- begin-session id>>\r
- get-session session?\r
- ] unit-test\r
-\r
- [ { 5 0 } ] [\r
- [\r
- begin-session\r
- dup [ 5 "a" sset ] with-session\r
- dup [ "a" sget , ] with-session\r
- dup [ "x" sget , ] with-session\r
- drop\r
- ] { } make\r
- ] unit-test\r
-\r
- [ 0 ] [\r
- begin-session id>>\r
- get-session [ "x" sget ] with-session\r
- ] unit-test\r
-\r
- [ { 5 0 } ] [\r
- [\r
- begin-session id>>\r
- dup get-session [ 5 "a" sset ] with-session\r
- dup get-session [ "a" sget , ] with-session\r
- dup get-session [ "x" sget , ] with-session\r
- drop\r
- ] { } make\r
- ] unit-test\r
-\r
- [ ] [\r
- <foo> <sessions>\r
- sessions set\r
- ] unit-test\r
-\r
- [\r
- <request>\r
- "GET" >>method\r
- dup url>> "/" >>path drop\r
- request set\r
- { "etc" } sessions get call-responder response set\r
- [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
- response get\r
- ] with-destructors\r
- response set\r
-\r
- [ ] [ response get cookies>> "cookies" set ] unit-test\r
-\r
- [ "2" ] [ sessions-mock-test ] unit-test\r
- [ "3" ] [ sessions-mock-test ] unit-test\r
- [ "4" ] [ sessions-mock-test ] unit-test\r
-\r
- [\r
- [ ] [\r
- <request>\r
- "GET" >>method\r
- dup url>>\r
- "id" get session-id-key set-query-param\r
- "/" >>path drop\r
- request set\r
-\r
- [\r
- { } <exiting-action> <sessions>\r
- call-responder\r
- ] with-destructors response set\r
- ] unit-test\r
-\r
- [ "text/plain" ] [ response get content-type>> ] unit-test\r
-\r
- [ f ] [ response get cookies>> empty? ] unit-test\r
- ] with-scope\r
-] with-db\r
+USING: tools.test http furnace.sessions furnace.actions
+http.server http.server.responses math namespaces make kernel
+accessors io.sockets io.servers prettyprint
+io.streams.string io.files io.files.temp io.directories
+splitting destructors sequences db db.tuples db.sqlite
+continuations urls math.parser furnace furnace.utilities ;
+IN: furnace.sessions.tests
+
+: with-session ( session quot -- )
+ [
+ [ [ save-session-after ] [ session set ] bi ] dip call
+ ] with-destructors ; inline
+
+TUPLE: foo ;
+
+C: <foo> foo
+
+M: foo init-session* drop 0 "x" sset ;
+
+M: foo call-responder*
+ 2drop
+ "x" [ 1 + ] schange
+ "x" sget number>string <html-content> ;
+
+: url-responder-mock-test ( -- string )
+ [
+ <request>
+ "GET" >>method
+ dup url>>
+ "id" get session-id-key set-query-param
+ "/" >>path drop
+ init-request
+ { } sessions get call-responder
+ [ write-response-body drop ] with-string-writer
+ ] with-destructors ;
+
+: sessions-mock-test ( -- string )
+ [
+ <request>
+ "GET" >>method
+ "cookies" get >>cookies
+ dup url>> "/" >>path drop
+ init-request
+ { } sessions get call-responder
+ [ write-response-body drop ] with-string-writer
+ ] with-destructors ;
+
+: <exiting-action> ( -- action )
+ <action>
+ [ [ ] <text-content> exit-with ] >>display ;
+
+[ "auth-test.db" temp-file delete-file ] ignore-errors
+
+"auth-test.db" temp-file <sqlite-db> [
+
+ <request> "GET" >>method init-request
+ session ensure-table
+
+ "127.0.0.1" 1234 <inet4> remote-address set
+
+ [ ] [
+ <foo> <sessions>
+ sessions set
+ ] unit-test
+
+ [
+ [ ] [
+ empty-session
+ 123 >>id session set
+ ] unit-test
+
+ [ ] [ 3 "x" sset ] unit-test
+
+ [ 9 ] [ "x" sget sq ] unit-test
+
+ [ ] [ "x" [ 1 - ] schange ] unit-test
+
+ [ 4 ] [ "x" sget sq ] unit-test
+
+ [ t ] [ session get changed?>> ] unit-test
+ ] with-scope
+
+ [ t ] [
+ begin-session id>>
+ get-session session?
+ ] unit-test
+
+ [ { 5 0 } ] [
+ [
+ begin-session
+ dup [ 5 "a" sset ] with-session
+ dup [ "a" sget , ] with-session
+ dup [ "x" sget , ] with-session
+ drop
+ ] { } make
+ ] unit-test
+
+ [ 0 ] [
+ begin-session id>>
+ get-session [ "x" sget ] with-session
+ ] unit-test
+
+ [ { 5 0 } ] [
+ [
+ begin-session id>>
+ dup get-session [ 5 "a" sset ] with-session
+ dup get-session [ "a" sget , ] with-session
+ dup get-session [ "x" sget , ] with-session
+ drop
+ ] { } make
+ ] unit-test
+
+ [ ] [
+ <foo> <sessions>
+ sessions set
+ ] unit-test
+
+ [
+ <request>
+ "GET" >>method
+ dup url>> "/" >>path drop
+ request set
+ { "etc" } sessions get call-responder response set
+ [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
+ response get
+ ] with-destructors
+ response set
+
+ [ ] [ response get cookies>> "cookies" set ] unit-test
+
+ [ "2" ] [ sessions-mock-test ] unit-test
+ [ "3" ] [ sessions-mock-test ] unit-test
+ [ "4" ] [ sessions-mock-test ] unit-test
+
+ [
+ [ ] [
+ <request>
+ "GET" >>method
+ dup url>>
+ "id" get session-id-key set-query-param
+ "/" >>path drop
+ request set
+
+ [
+ { } <exiting-action> <sessions>
+ call-responder
+ ] with-destructors response set
+ ] unit-test
+
+ [ "text/plain" ] [ response get content-type>> ] unit-test
+
+ [ f ] [ response get cookies>> empty? ] unit-test
+ ] with-scope
+] with-db
M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
INSTANCE: keys-array sequence
-
M: linux 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 98 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 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 98 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
} ; inline
-
+
: x-bits>hid-bits ( bit-array -- bit-array )
256 iota zip [ first ] filter values
x>hid-bit-order [ nth ] curry map
256 <bit-array> swap [ t swap pick set-nth ] each ;
-
+
M: gtk-game-input-backend read-keyboard
get-dpy 256 <bit-array> [ XQueryKeymap drop ] keep
x-bits>hid-bits keyboard-state boa ;
swap 400 - >>dy
swap 400 - >>dx
0 >>scroll-dy 0 >>scroll-dx ;
-
+
M: gtk-game-input-backend reset-mouse
get-dpy dup XDefaultRootWindow dup
0 0 0 0 400 400 XWarpPointer drop ;
: record-controller ( controller-state value -- )
dup IOHIDValueGetElement {
- { [ dup button? ] [ record-button ] }
+ { [ dup button? ] [ record-button ] }
{ [ dup axis? ] [ {
{ [ dup x-axis? ] [ drop axis-value >>x drop ] }
{ [ dup y-axis? ] [ drop axis-value >>y drop ] }
+mouse-state+ get-global
0 >>dx
0 >>dy
- 0 >>scroll-dx
+ 0 >>scroll-dx
0 >>scroll-dy
drop ;
} cleave controller-state boa ;
: ?add-mouse-buttons ( device -- )
- button-count +mouse-state+ get-global buttons>>
+ button-count +mouse-state+ get-global buttons>>
2dup length >
[ set-length ] [ 2drop ] if ;
M: iokit-game-input-backend (close-game-input)
+hid-manager+ get-global [
- +hid-manager+ [
+ +hid-manager+ [
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerUnscheduleFromRunLoop
M: x11-game-input-backend product-string
drop "" ;
-
+
M: x11-game-input-backend product-id
drop f ;
-
+
M: x11-game-input-backend instance-id
drop f ;
-
+
M: x11-game-input-backend read-controller
drop controller-state new ;
-
+
M: x11-game-input-backend calibrate-controller
drop ;
-
+
M: x11-game-input-backend vibrate-controller
3drop ;
M: linux 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 98 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 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 98 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
} ; inline
-
+
: x-bits>hid-bits ( bit-array -- bit-array )
256 iota [ 2array ] { } 2map-as [ first ] filter values
x>hid-bit-order [ nth ] curry map
256 <bit-array> 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 ;
[ 4 ndrop ] 3dip ;
SYMBOL: mouse-reset?
-
+
M: x11-game-input-backend read-mouse
mouse-reset? get [ reset-mouse ] unless
query-pointer
swap 400 - >>dy
swap 400 - >>dx
0 >>scroll-dy 0 >>scroll-dx ;
-
+
M: x11-game-input-backend reset-mouse
dpy get dup XDefaultRootWindow dup
0 0 0 0 400 400 XWarpPointer drop t mouse-reset? set-global ;
! See http://factorcode.org/license.txt for BSD license.
USING: gdk.ffi ;
IN: gdk
-
! See http://factorcode.org/license.txt for BSD license.
USING: gdk.gl.ffi ;
IN: gdk.gl
-
! See http://factorcode.org/license.txt for BSD license.
USING: gdk.pixbuf.ffi ;
IN: gdk.pixbuf
-
-USING: help.syntax help.markup kernel sequences quotations\r
-math arrays combinators ;\r
-IN: generalizations\r
-\r
-HELP: nsum\r
-{ $values { "n" integer } }\r
-{ $description "Adds the top " { $snippet "n" } " stack values." } ;\r
-\r
-HELP: npick\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link dup } ", "\r
-{ $link over } " and " { $link pick } " that can work "\r
-"for any stack depth. The nth item down the stack will be copied and "\r
-"placed on the top of the stack."\r
-}\r
-{ $examples\r
- { $example\r
- "USING: kernel generalizations prettyprint"\r
- "sequences.generalizations ;"\r
- ""\r
- "1 2 3 4 4 npick 5 narray ."\r
- "{ 1 2 3 4 1 }"\r
- }\r
- "Some core words expressed in terms of " { $link npick } ":"\r
- { $table\r
- { { $link dup } { $snippet "1 npick" } }\r
- { { $link over } { $snippet "2 npick" } }\r
- { { $link pick } { $snippet "3 npick" } }\r
- }\r
-} ;\r
-\r
-HELP: ndup\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link dup } ", "\r
-{ $link 2dup } " and " { $link 3dup } " that can work "\r
-"for any number of items. The n topmost items on the stack will be copied and "\r
-"placed on the top of the stack."\r
-}\r
-{ $examples\r
- { $example\r
- "USING: prettyprint generalizations kernel"\r
- "sequences.generalizations ;"\r
- ""\r
- "1 2 3 4 4 ndup 8 narray ."\r
- "{ 1 2 3 4 1 2 3 4 }"\r
- }\r
- "Some core words expressed in terms of " { $link ndup } ":"\r
- { $table\r
- { { $link dup } { $snippet "1 ndup" } }\r
- { { $link 2dup } { $snippet "2 ndup" } }\r
- { { $link 3dup } { $snippet "3 ndup" } }\r
- }\r
-} ;\r
-\r
-HELP: dupn\r
-{ $values { "n" integer } }\r
-{ $description "Calls " { $link dup } " enough times that " { $snippet "n" } " references to the element at the top of the stack before " { $snippet "dupn" } " is called are on the top of the stack." }\r
-{ $notes { $snippet "2 dupn" } " is equivalent to " { $link dup } ". " { $snippet "1 dupn" } " is a no-op. " { $snippet "0 dupn" } " is equivalent to " { $link drop } "." } ;\r
-\r
-HELP: nnip\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link nip } " and " { $link 2nip }\r
-" that can work "\r
-"for any number of items."\r
-}\r
-{ $examples\r
- { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" }\r
- "Some core words expressed in terms of " { $link nnip } ":"\r
- { $table\r
- { { $link nip } { $snippet "1 nnip" } }\r
- { { $link 2nip } { $snippet "2 nnip" } }\r
- }\r
-} ;\r
-\r
-HELP: ndrop\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link drop }\r
-" that can work "\r
-"for any number of items."\r
-}\r
-{ $examples\r
- { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" }\r
- "Some core words expressed in terms of " { $link ndrop } ":"\r
- { $table\r
- { { $link drop } { $snippet "1 ndrop" } }\r
- { { $link 2drop } { $snippet "2 ndrop" } }\r
- { { $link 3drop } { $snippet "3 ndrop" } }\r
- }\r
-} ;\r
-\r
-HELP: nrot\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link rot } " that works for any "\r
-"number of items on the stack. "\r
-}\r
-{ $examples\r
- { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" }\r
- "Some core words expressed in terms of " { $link nrot } ":"\r
- { $table\r
- { { $link swap } { $snippet "2 nrot" } }\r
- { { $link rot } { $snippet "3 nrot" } }\r
- }\r
-} ;\r
-\r
-HELP: -nrot\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link -rot } " that works for any "\r
-"number of items on the stack. "\r
-}\r
-{ $examples\r
- { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" }\r
- "Some core words expressed in terms of " { $link -nrot } ":"\r
- { $table\r
- { { $link swap } { $snippet "2 -nrot" } }\r
- { { $link -rot } { $snippet "3 -nrot" } }\r
- }\r
-} ;\r
-\r
-HELP: ndip\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link dip } " that can work " \r
-"for any stack depth. The quotation will be called with a stack that "\r
-"has 'n' items removed first. The 'n' items are then put back on the "\r
-"stack. The quotation can consume and produce any number of items."\r
-} \r
-{ $examples\r
- { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" }\r
- { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" }\r
- "Some core words expressed in terms of " { $link ndip } ":"\r
- { $table\r
- { { $link dip } { $snippet "1 ndip" } }\r
- { { $link 2dip } { $snippet "2 ndip" } }\r
- { { $link 3dip } { $snippet "3 ndip" } }\r
- }\r
-} ;\r
-\r
-HELP: nkeep\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link keep } " that can work " \r
-"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "\r
-"saved, the quotation called, and the items restored."\r
-} \r
-{ $examples\r
- { $example\r
- "USING: generalizations kernel prettyprint"\r
- "sequences.generalizations ;"\r
- ""\r
- "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ."\r
- "{ 99 1 2 3 4 5 }"\r
- }\r
- "Some core words expressed in terms of " { $link nkeep } ":"\r
- { $table\r
- { { $link keep } { $snippet "1 nkeep" } }\r
- { { $link 2keep } { $snippet "2 nkeep" } }\r
- { { $link 3keep } { $snippet "3 nkeep" } }\r
- }\r
-} ;\r
-\r
-HELP: ncurry\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link curry } " that can work for any stack depth."\r
-} \r
-{ $examples\r
- "Some core words expressed in terms of " { $link ncurry } ":"\r
- { $table\r
- { { $link curry } { $snippet "1 ncurry" } }\r
- { { $link 2curry } { $snippet "2 ncurry" } }\r
- { { $link 3curry } { $snippet "3 ncurry" } }\r
- }\r
-} ;\r
-\r
-HELP: nwith\r
-{ $values { "n" integer } }\r
-{ $description "A generalization of " { $link with } " that can work for any stack depth."\r
-} \r
-{ $examples\r
- "Some core words expressed in terms of " { $link nwith } ":"\r
- { $table\r
- { { $link with } { $snippet "1 nwith" } }\r
- }\r
-} ;\r
-\r
-HELP: napply\r
-{ $values { "quot" quotation } { "n" integer } }\r
-{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."\r
-} \r
-{ $examples\r
- "Some core words expressed in terms of " { $link napply } ":"\r
- { $table\r
- { { $link call } { $snippet "1 napply" } }\r
- { { $link bi@ } { $snippet "2 napply" } }\r
- { { $link tri@ } { $snippet "3 napply" } }\r
- }\r
-} ;\r
-\r
-HELP: ncleave\r
-{ $values { "quots" "a sequence of quotations" } { "n" integer } }\r
-{ $description "A generalization of " { $link cleave } " and " { $link 2cleave } " that can work for any quotation arity."\r
-} \r
-{ $examples\r
- "Some core words expressed in terms of " { $link ncleave } ":"\r
- { $table\r
- { { $link cleave } { $snippet "1 ncleave" } }\r
- { { $link 2cleave } { $snippet "2 ncleave" } }\r
- }\r
-} ;\r
-\r
-HELP: nspread\r
-{ $values { "quots" "a sequence of quotations" } { "n" integer } }\r
-{ $description "A generalization of " { $link spread } " that can work for any quotation arity."\r
-} ;\r
-\r
-HELP: cleave*\r
-{ $values { "n" integer } }\r
-{ $description "Like " { $link cleave } ", but instead of taking a single array of quotations, cleaves using quotations taken from the top " { $snippet "n" } " elements of the datastack." }\r
-{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi" } " or " { $snippet "tri-curry@ tri" } " dataflow patterns." } ;\r
-\r
-HELP: spread*\r
-{ $values { "n" integer } }\r
-{ $description "Like " { $link spread } ", but instead of taking a single array of quotations, spreads using quotations taken from the top " { $snippet "n" } " elements of the datastack." }\r
-{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ;\r
-\r
-HELP: apply-curry\r
-{ $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }\r
-{ $description "Curries each of the top " { $snippet "n" } " items of the datastack onto " { $snippet "quot" } ", leaving " { $snippet "n" } " quotations on the datastack. A generalization of " { $link bi-curry@ } " and " { $link tri-curry@ } "." }\r
-{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry@ bi" } ", " { $snippet "tri-curry@ tri" } ", " { $snippet "bi-curry@ bi*" } ", and " { $snippet "tri-curry@ tri*" } "." } ;\r
-\r
-HELP: cleave-curry\r
-{ $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
-{ $description "Curries " { $snippet "a" } " onto the " { $snippet "n" } " quotations on the top of the datastack. A generalization of " { $link bi-curry } " and " { $link tri-curry } "." }\r
-{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry bi" } ", " { $snippet "tri-curry tri" } ", " { $snippet "bi-curry bi*" } ", and " { $snippet "tri-curry tri*" } "." } ;\r
-\r
-HELP: spread-curry\r
-{ $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }\r
-{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }\r
-{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;\r
-\r
-HELP: mnswap\r
-{ $values { "m" integer } { "n" integer } }\r
-{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }\r
-{ $examples\r
- "Some core words expressed in terms of " { $link mnswap } ":"\r
- { $table\r
- { { $link swap } { $snippet "1 1 mnswap" } }\r
- { { $link rot } { $snippet "2 1 mnswap" } }\r
- { { $link -rot } { $snippet "1 2 mnswap" } }\r
- }\r
-} ;\r
-\r
-HELP: nweave\r
-{ $values { "n" integer } }\r
-{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }\r
-{ $examples\r
- { $example\r
- "USING: arrays kernel generalizations prettyprint ;"\r
- "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."\r
- "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"\r
- }\r
-} ;\r
-\r
-HELP: n*quot\r
-{ $values\r
- { "n" integer } { "quot" quotation }\r
- { "quotquot" quotation }\r
-}\r
-{ $examples\r
- { $example "USING: generalizations prettyprint math ;"\r
- "3 [ + ] n*quot ."\r
- "[ + + + ]"\r
- }\r
-}\r
-{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ;\r
-\r
-ARTICLE: "shuffle-generalizations" "Generalized shuffle words"\r
-{ $subsections\r
- ndup\r
- dupn\r
- npick\r
- nrot\r
- -nrot\r
- nnip\r
- ndrop\r
- mnswap\r
- nweave\r
-} ;\r
-\r
-ARTICLE: "combinator-generalizations" "Generalized combinators"\r
-{ $subsections\r
- ndip\r
- nkeep\r
- napply\r
- ncleave\r
- nspread\r
- cleave*\r
- spread*\r
- apply-curry\r
- cleave-curry\r
- spread-curry\r
-} ;\r
-\r
-ARTICLE: "other-generalizations" "Additional generalizations"\r
-{ $subsections\r
- ncurry\r
- nwith\r
- nsum\r
-} ;\r
-\r
-ARTICLE: "generalizations" "Generalized shuffle words and combinators"\r
-"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "\r
-"macros where the arity of the input quotations depends on an "\r
-"input parameter."\r
-{ $subsections\r
- "shuffle-generalizations"\r
- "combinator-generalizations"\r
- "other-generalizations"\r
-}\r
-"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence operations." ;\r
-\r
-ABOUT: "generalizations"\r
+USING: help.syntax help.markup kernel sequences quotations
+math arrays combinators ;
+IN: generalizations
+
+HELP: nsum
+{ $values { "n" integer } }
+{ $description "Adds the top " { $snippet "n" } " stack values." } ;
+
+HELP: npick
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link dup } ", "
+{ $link over } " and " { $link pick } " that can work "
+"for any stack depth. The nth item down the stack will be copied and "
+"placed on the top of the stack."
+}
+{ $examples
+ { $example
+ "USING: kernel generalizations prettyprint"
+ "sequences.generalizations ;"
+ ""
+ "1 2 3 4 4 npick 5 narray ."
+ "{ 1 2 3 4 1 }"
+ }
+ "Some core words expressed in terms of " { $link npick } ":"
+ { $table
+ { { $link dup } { $snippet "1 npick" } }
+ { { $link over } { $snippet "2 npick" } }
+ { { $link pick } { $snippet "3 npick" } }
+ }
+} ;
+
+HELP: ndup
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link dup } ", "
+{ $link 2dup } " and " { $link 3dup } " that can work "
+"for any number of items. The n topmost items on the stack will be copied and "
+"placed on the top of the stack."
+}
+{ $examples
+ { $example
+ "USING: prettyprint generalizations kernel"
+ "sequences.generalizations ;"
+ ""
+ "1 2 3 4 4 ndup 8 narray ."
+ "{ 1 2 3 4 1 2 3 4 }"
+ }
+ "Some core words expressed in terms of " { $link ndup } ":"
+ { $table
+ { { $link dup } { $snippet "1 ndup" } }
+ { { $link 2dup } { $snippet "2 ndup" } }
+ { { $link 3dup } { $snippet "3 ndup" } }
+ }
+} ;
+
+HELP: dupn
+{ $values { "n" integer } }
+{ $description "Calls " { $link dup } " enough times that " { $snippet "n" } " references to the element at the top of the stack before " { $snippet "dupn" } " is called are on the top of the stack." }
+{ $notes { $snippet "2 dupn" } " is equivalent to " { $link dup } ". " { $snippet "1 dupn" } " is a no-op. " { $snippet "0 dupn" } " is equivalent to " { $link drop } "." } ;
+
+HELP: nnip
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link nip } " and " { $link 2nip }
+" that can work "
+"for any number of items."
+}
+{ $examples
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" }
+ "Some core words expressed in terms of " { $link nnip } ":"
+ { $table
+ { { $link nip } { $snippet "1 nnip" } }
+ { { $link 2nip } { $snippet "2 nnip" } }
+ }
+} ;
+
+HELP: ndrop
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link drop }
+" that can work "
+"for any number of items."
+}
+{ $examples
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" }
+ "Some core words expressed in terms of " { $link ndrop } ":"
+ { $table
+ { { $link drop } { $snippet "1 ndrop" } }
+ { { $link 2drop } { $snippet "2 ndrop" } }
+ { { $link 3drop } { $snippet "3 ndrop" } }
+ }
+} ;
+
+HELP: nrot
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link rot } " that works for any "
+"number of items on the stack. "
+}
+{ $examples
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" }
+ "Some core words expressed in terms of " { $link nrot } ":"
+ { $table
+ { { $link swap } { $snippet "2 nrot" } }
+ { { $link rot } { $snippet "3 nrot" } }
+ }
+} ;
+
+HELP: -nrot
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link -rot } " that works for any "
+"number of items on the stack. "
+}
+{ $examples
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" }
+ "Some core words expressed in terms of " { $link -nrot } ":"
+ { $table
+ { { $link swap } { $snippet "2 -nrot" } }
+ { { $link -rot } { $snippet "3 -nrot" } }
+ }
+} ;
+
+HELP: ndip
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link dip } " that can work "
+"for any stack depth. The quotation will be called with a stack that "
+"has 'n' items removed first. The 'n' items are then put back on the "
+"stack. The quotation can consume and produce any number of items."
+}
+{ $examples
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" }
+ { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" }
+ "Some core words expressed in terms of " { $link ndip } ":"
+ { $table
+ { { $link dip } { $snippet "1 ndip" } }
+ { { $link 2dip } { $snippet "2 ndip" } }
+ { { $link 3dip } { $snippet "3 ndip" } }
+ }
+} ;
+
+HELP: nkeep
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link keep } " that can work "
+"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
+"saved, the quotation called, and the items restored."
+}
+{ $examples
+ { $example
+ "USING: generalizations kernel prettyprint"
+ "sequences.generalizations ;"
+ ""
+ "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ."
+ "{ 99 1 2 3 4 5 }"
+ }
+ "Some core words expressed in terms of " { $link nkeep } ":"
+ { $table
+ { { $link keep } { $snippet "1 nkeep" } }
+ { { $link 2keep } { $snippet "2 nkeep" } }
+ { { $link 3keep } { $snippet "3 nkeep" } }
+ }
+} ;
+
+HELP: ncurry
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link curry } " that can work for any stack depth."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link ncurry } ":"
+ { $table
+ { { $link curry } { $snippet "1 ncurry" } }
+ { { $link 2curry } { $snippet "2 ncurry" } }
+ { { $link 3curry } { $snippet "3 ncurry" } }
+ }
+} ;
+
+HELP: nwith
+{ $values { "n" integer } }
+{ $description "A generalization of " { $link with } " that can work for any stack depth."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link nwith } ":"
+ { $table
+ { { $link with } { $snippet "1 nwith" } }
+ }
+} ;
+
+HELP: napply
+{ $values { "quot" quotation } { "n" integer } }
+{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link napply } ":"
+ { $table
+ { { $link call } { $snippet "1 napply" } }
+ { { $link bi@ } { $snippet "2 napply" } }
+ { { $link tri@ } { $snippet "3 napply" } }
+ }
+} ;
+
+HELP: ncleave
+{ $values { "quots" "a sequence of quotations" } { "n" integer } }
+{ $description "A generalization of " { $link cleave } " and " { $link 2cleave } " that can work for any quotation arity."
+}
+{ $examples
+ "Some core words expressed in terms of " { $link ncleave } ":"
+ { $table
+ { { $link cleave } { $snippet "1 ncleave" } }
+ { { $link 2cleave } { $snippet "2 ncleave" } }
+ }
+} ;
+
+HELP: nspread
+{ $values { "quots" "a sequence of quotations" } { "n" integer } }
+{ $description "A generalization of " { $link spread } " that can work for any quotation arity."
+} ;
+
+HELP: cleave*
+{ $values { "n" integer } }
+{ $description "Like " { $link cleave } ", but instead of taking a single array of quotations, cleaves using quotations taken from the top " { $snippet "n" } " elements of the datastack." }
+{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi" } " or " { $snippet "tri-curry@ tri" } " dataflow patterns." } ;
+
+HELP: spread*
+{ $values { "n" integer } }
+{ $description "Like " { $link spread } ", but instead of taking a single array of quotations, spreads using quotations taken from the top " { $snippet "n" } " elements of the datastack." }
+{ $notes "This word can be used with " { $link apply-curry } " to generalize the " { $snippet "bi-curry@ bi*" } " or " { $snippet "tri-curry@ tri*" } " dataflow patterns." } ;
+
+HELP: apply-curry
+{ $values { "a..." { $snippet "n" } " values on the datastack" } { "quot" quotation } { "n" integer } }
+{ $description "Curries each of the top " { $snippet "n" } " items of the datastack onto " { $snippet "quot" } ", leaving " { $snippet "n" } " quotations on the datastack. A generalization of " { $link bi-curry@ } " and " { $link tri-curry@ } "." }
+{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry@ bi" } ", " { $snippet "tri-curry@ tri" } ", " { $snippet "bi-curry@ bi*" } ", and " { $snippet "tri-curry@ tri*" } "." } ;
+
+HELP: cleave-curry
+{ $values { "a" object } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }
+{ $description "Curries " { $snippet "a" } " onto the " { $snippet "n" } " quotations on the top of the datastack. A generalization of " { $link bi-curry } " and " { $link tri-curry } "." }
+{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry bi" } ", " { $snippet "tri-curry tri" } ", " { $snippet "bi-curry bi*" } ", and " { $snippet "tri-curry tri*" } "." } ;
+
+HELP: spread-curry
+{ $values { "a..." { $snippet "n" } " objects on the datastack" } { "quot..." { $snippet "n" } " quotations on the datastack" } { "n" integer } }
+{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }
+{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;
+
+HELP: mnswap
+{ $values { "m" integer } { "n" integer } }
+{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
+{ $examples
+ "Some core words expressed in terms of " { $link mnswap } ":"
+ { $table
+ { { $link swap } { $snippet "1 1 mnswap" } }
+ { { $link rot } { $snippet "2 1 mnswap" } }
+ { { $link -rot } { $snippet "1 2 mnswap" } }
+ }
+} ;
+
+HELP: nweave
+{ $values { "n" integer } }
+{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }
+{ $examples
+ { $example
+ "USING: arrays kernel generalizations prettyprint ;"
+ "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."
+ "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"
+ }
+} ;
+
+HELP: n*quot
+{ $values
+ { "n" integer } { "quot" quotation }
+ { "quotquot" quotation }
+}
+{ $examples
+ { $example "USING: generalizations prettyprint math ;"
+ "3 [ + ] n*quot ."
+ "[ + + + ]"
+ }
+}
+{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ;
+
+ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
+{ $subsections
+ ndup
+ dupn
+ npick
+ nrot
+ -nrot
+ nnip
+ ndrop
+ mnswap
+ nweave
+} ;
+
+ARTICLE: "combinator-generalizations" "Generalized combinators"
+{ $subsections
+ ndip
+ nkeep
+ napply
+ ncleave
+ nspread
+ cleave*
+ spread*
+ apply-curry
+ cleave-curry
+ spread-curry
+} ;
+
+ARTICLE: "other-generalizations" "Additional generalizations"
+{ $subsections
+ ncurry
+ nwith
+ nsum
+} ;
+
+ARTICLE: "generalizations" "Generalized shuffle words and combinators"
+"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
+"macros where the arity of the input quotations depends on an "
+"input parameter."
+{ $subsections
+ "shuffle-generalizations"
+ "combinator-generalizations"
+ "other-generalizations"
+}
+"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence operations." ;
+
+ABOUT: "generalizations"
MACRO: cleave* ( n -- )
[ [ ] ]
- [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
+ [ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
if-zero ;
: napply ( quot n -- )
! See http://factorcode.org/license.txt for BSD license.
USING: gio.ffi ;
IN: gio
-
! See http://factorcode.org/license.txt for BSD license.
USING: glib.ffi ;
IN: glib
-
! See http://factorcode.org/license.txt for BSD license.
USING: gmodule.ffi ;
IN: gmodule
-
user-data-parameter suffix parameter-names&types
]
} cleave make-callback-type define-inline ;
-
+
: def-signals ( signals type -- )
[ def-signal ] curry each ;
: def-ffi-repository ( repository -- )
namespace>> def-namespace ;
-
[ "value" attr >>value ]
[ child-type-tag xml>type >>type ]
} cleave ;
-
+
: load-type ( type xml -- type )
{
[ "name" attr >>name ]
[ child-type-tag xml>type >>type ]
[ "transfer-ownership" attr >>transfer-ownership ]
} cleave ;
-
+
: load-callable ( callable xml -- callable )
[ "return-value" tag-named xml>return >>return ]
[
! See http://factorcode.org/license.txt for BSD license.
USING: gobject.ffi ;
IN: gobject
-
! See http://factorcode.org/license.txt for BSD license.
USING: gtk.gl.ffi ;
IN: gtk.gl
-
! See http://factorcode.org/license.txt for BSD license.
USING: gtk.ffi ;
IN: gtk
-
-USING: hash-sets.identity kernel literals sets tools.test ;\r
-IN: hash-sets.identity.tests\r
-\r
-CONSTANT: the-real-slim-shady "marshall mathers"\r
-\r
-CONSTANT: will\r
- IHS{\r
- $ the-real-slim-shady\r
- "marshall mathers"\r
- }\r
-\r
-: please-stand-up ( set obj -- ? )\r
- swap in? ;\r
-\r
-[ t ] [ will the-real-slim-shady please-stand-up ] unit-test\r
-[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test\r
-\r
-[ 2 ] [ will cardinality ] unit-test\r
-[ { "marshall mathers" } ] [\r
- the-real-slim-shady will clone\r
- [ delete ] [ members ] bi\r
-] unit-test\r
-\r
-CONSTANT: same-as-it-ever-was "same as it ever was"\r
-\r
-{ IHS{ $ same-as-it-ever-was } }\r
-[ HS{ $ same-as-it-ever-was } IHS{ } set-like ] unit-test\r
+USING: hash-sets.identity kernel literals sets tools.test ;
+IN: hash-sets.identity.tests
+
+CONSTANT: the-real-slim-shady "marshall mathers"
+
+CONSTANT: will
+ IHS{
+ $ the-real-slim-shady
+ "marshall mathers"
+ }
+
+: please-stand-up ( set obj -- ? )
+ swap in? ;
+
+[ t ] [ will the-real-slim-shady please-stand-up ] unit-test
+[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test
+
+[ 2 ] [ will cardinality ] unit-test
+[ { "marshall mathers" } ] [
+ the-real-slim-shady will clone
+ [ delete ] [ members ] bi
+] unit-test
+
+CONSTANT: same-as-it-ever-was "same as it ever was"
+
+{ IHS{ $ same-as-it-ever-was } }
+[ HS{ $ same-as-it-ever-was } IHS{ } set-like ] unit-test
-! Copyright (C) 2013 John Benediktsson.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors hash-sets hash-sets.wrapped kernel parser\r
-sequences sets sets.private vocabs.loader ;\r
-IN: hash-sets.identity\r
-\r
-TUPLE: identity-wrapper < wrapped-key identity-hashcode ;\r
-\r
-: <identity-wrapper> ( wrapped-key -- identity-wrapper )\r
- dup identity-hashcode identity-wrapper boa ; inline\r
-\r
-M: identity-wrapper equal?\r
- over identity-wrapper?\r
- [ [ underlying>> ] bi@ eq? ]\r
- [ 2drop f ] if ; inline\r
-\r
-M: identity-wrapper hashcode* nip identity-hashcode>> ; inline\r
-\r
-TUPLE: identity-hash-set < wrapped-hash-set ;\r
-\r
-: <identity-hash-set> ( n -- ihash-set )\r
- <hash-set> identity-hash-set boa ; inline\r
-\r
-M: identity-hash-set wrap-key drop <identity-wrapper> ;\r
-\r
-M: identity-hash-set clone\r
- underlying>> clone identity-hash-set boa ; inline\r
-\r
-: >identity-hash-set ( members -- ihash-set )\r
- [ <identity-wrapper> ] map >hash-set identity-hash-set boa ; inline\r
-\r
-M: identity-hash-set set-like\r
- drop dup identity-hash-set? [ ?members >identity-hash-set ] unless ; inline\r
-\r
-SYNTAX: IHS{ \ } [ >identity-hash-set ] parse-literal ;\r
-\r
-{ "hash-sets.identity" "prettyprint" } "hash-sets.identity.prettyprint" require-when\r
+! Copyright (C) 2013 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors hash-sets hash-sets.wrapped kernel parser
+sequences sets sets.private vocabs.loader ;
+IN: hash-sets.identity
+
+TUPLE: identity-wrapper < wrapped-key identity-hashcode ;
+
+: <identity-wrapper> ( wrapped-key -- identity-wrapper )
+ dup identity-hashcode identity-wrapper boa ; inline
+
+M: identity-wrapper equal?
+ over identity-wrapper?
+ [ [ underlying>> ] bi@ eq? ]
+ [ 2drop f ] if ; inline
+
+M: identity-wrapper hashcode* nip identity-hashcode>> ; inline
+
+TUPLE: identity-hash-set < wrapped-hash-set ;
+
+: <identity-hash-set> ( n -- ihash-set )
+ <hash-set> identity-hash-set boa ; inline
+
+M: identity-hash-set wrap-key drop <identity-wrapper> ;
+
+M: identity-hash-set clone
+ underlying>> clone identity-hash-set boa ; inline
+
+: >identity-hash-set ( members -- ihash-set )
+ [ <identity-wrapper> ] map >hash-set identity-hash-set boa ; inline
+
+M: identity-hash-set set-like
+ drop dup identity-hash-set? [ ?members >identity-hash-set ] unless ; inline
+
+SYNTAX: IHS{ \ } [ >identity-hash-set ] parse-literal ;
+
+{ "hash-sets.identity" "prettyprint" } "hash-sets.identity.prettyprint" require-when
-! Copyright (C) 2013 John Benediktsson.\r
-! See http://factorcode.org/license.txt for BSD license\r
-\r
-USING: hash-sets.identity kernel prettyprint.custom ;\r
-\r
-IN: hash-sets.identity.prettyprint\r
-\r
-M: identity-hash-set pprint-delims drop \ IHS{ \ } ;\r
+! Copyright (C) 2013 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license
+
+USING: hash-sets.identity kernel prettyprint.custom ;
+
+IN: hash-sets.identity.prettyprint
+
+M: identity-hash-set pprint-delims drop \ IHS{ \ } ;
M: wrapped-hash-set pprint*
nesting-limit inc
[ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
-
-
-! (c)2010 Joe Groff bsd license\r
-USING: assocs hashtables.identity kernel literals tools.test ;\r
-IN: hashtables.identity.tests\r
-\r
-CONSTANT: the-real-slim-shady "marshall mathers"\r
-\r
-CONSTANT: will\r
- IH{\r
- { $ the-real-slim-shady t }\r
- { "marshall mathers" f }\r
- }\r
-\r
-: please-stand-up ( assoc key -- value )\r
- of ;\r
-\r
-[ t ] [ will the-real-slim-shady please-stand-up ] unit-test\r
-[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test\r
-\r
-[ 2 ] [ will assoc-size ] unit-test\r
-[ { { "marshall mathers" f } } ] [\r
- the-real-slim-shady will clone\r
- [ delete-at ] [ >alist ] bi\r
-] unit-test\r
-[ t ] [\r
- t the-real-slim-shady identity-associate\r
- t the-real-slim-shady identity-associate =\r
-] unit-test\r
-[ f ] [\r
- t the-real-slim-shady identity-associate\r
- t "marshall mathers" identity-associate =\r
-] unit-test\r
-\r
-CONSTANT: same-as-it-ever-was "same as it ever was"\r
-\r
-{ IH{ { $ same-as-it-ever-was $ same-as-it-ever-was } } }\r
-[ H{ { $ same-as-it-ever-was $ same-as-it-ever-was } } IH{ } assoc-like ] unit-test\r
+! (c)2010 Joe Groff bsd license
+USING: assocs hashtables.identity kernel literals tools.test ;
+IN: hashtables.identity.tests
+
+CONSTANT: the-real-slim-shady "marshall mathers"
+
+CONSTANT: will
+ IH{
+ { $ the-real-slim-shady t }
+ { "marshall mathers" f }
+ }
+
+: please-stand-up ( assoc key -- value )
+ of ;
+
+[ t ] [ will the-real-slim-shady please-stand-up ] unit-test
+[ t ] [ will clone the-real-slim-shady please-stand-up ] unit-test
+
+[ 2 ] [ will assoc-size ] unit-test
+[ { { "marshall mathers" f } } ] [
+ the-real-slim-shady will clone
+ [ delete-at ] [ >alist ] bi
+] unit-test
+[ t ] [
+ t the-real-slim-shady identity-associate
+ t the-real-slim-shady identity-associate =
+] unit-test
+[ f ] [
+ t the-real-slim-shady identity-associate
+ t "marshall mathers" identity-associate =
+] unit-test
+
+CONSTANT: same-as-it-ever-was "same as it ever was"
+
+{ IH{ { $ same-as-it-ever-was $ same-as-it-ever-was } } }
+[ H{ { $ same-as-it-ever-was $ same-as-it-ever-was } } IH{ } assoc-like ] unit-test
-! (c)2010 Joe Groff bsd license\r
-USING: accessors assocs hashtables hashtables.wrapped kernel\r
-parser vocabs.loader ;\r
-IN: hashtables.identity\r
-\r
-TUPLE: identity-wrapper < wrapped-key identity-hashcode ;\r
-\r
-: <identity-wrapper> ( wrapped-key -- identity-wrapper )\r
- dup identity-hashcode identity-wrapper boa ; inline\r
-\r
-M: identity-wrapper equal?\r
- over identity-wrapper?\r
- [ [ underlying>> ] bi@ eq? ]\r
- [ 2drop f ] if ; inline\r
-\r
-M: identity-wrapper hashcode* nip identity-hashcode>> ; inline\r
-\r
-TUPLE: identity-hashtable < wrapped-hashtable ;\r
-\r
-: <identity-hashtable> ( n -- ihashtable )\r
- <hashtable> identity-hashtable boa ; inline\r
-\r
-M: identity-hashtable wrap-key drop <identity-wrapper> ;\r
-\r
-M: identity-hashtable clone\r
- underlying>> clone identity-hashtable boa ; inline\r
-\r
-: identity-associate ( value key -- ihashtable )\r
- 2 <identity-hashtable> [ set-at ] keep ; inline\r
-\r
-: >identity-hashtable ( assoc -- ihashtable )\r
- [ assoc-size <identity-hashtable> ] keep assoc-union! ;\r
-\r
-M: identity-hashtable assoc-like\r
- drop dup identity-hashtable? [ >identity-hashtable ] unless ; inline\r
-\r
-M: identity-hashtable new-assoc drop <identity-hashtable> ;\r
-\r
-SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;\r
-\r
-{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when\r
-{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when\r
+! (c)2010 Joe Groff bsd license
+USING: accessors assocs hashtables hashtables.wrapped kernel
+parser vocabs.loader ;
+IN: hashtables.identity
+
+TUPLE: identity-wrapper < wrapped-key identity-hashcode ;
+
+: <identity-wrapper> ( wrapped-key -- identity-wrapper )
+ dup identity-hashcode identity-wrapper boa ; inline
+
+M: identity-wrapper equal?
+ over identity-wrapper?
+ [ [ underlying>> ] bi@ eq? ]
+ [ 2drop f ] if ; inline
+
+M: identity-wrapper hashcode* nip identity-hashcode>> ; inline
+
+TUPLE: identity-hashtable < wrapped-hashtable ;
+
+: <identity-hashtable> ( n -- ihashtable )
+ <hashtable> identity-hashtable boa ; inline
+
+M: identity-hashtable wrap-key drop <identity-wrapper> ;
+
+M: identity-hashtable clone
+ underlying>> clone identity-hashtable boa ; inline
+
+: identity-associate ( value key -- ihashtable )
+ 2 <identity-hashtable> [ set-at ] keep ; inline
+
+: >identity-hashtable ( assoc -- ihashtable )
+ [ assoc-size <identity-hashtable> ] keep assoc-union! ;
+
+M: identity-hashtable assoc-like
+ drop dup identity-hashtable? [ >identity-hashtable ] unless ; inline
+
+M: identity-hashtable new-assoc drop <identity-hashtable> ;
+
+SYNTAX: IH{ \ } [ >identity-hashtable ] parse-literal ;
+
+{ "hashtables.identity" "prettyprint" } "hashtables.identity.prettyprint" require-when
+{ "hashtables.identity" "mirrors" } "hashtables.identity.mirrors" require-when
-USING: hashtables.identity mirrors ;\r
-IN: hashtables.identity.mirrors\r
-\r
-M: identity-hashtable make-mirror ;\r
+USING: hashtables.identity mirrors ;
+IN: hashtables.identity.mirrors
+
+M: identity-hashtable make-mirror ;
-! Copyright (C) 2010-2011 Joe Groff\r
-! See http://factorcode.org/license.txt for BSD license\r
-\r
-USING: hashtables.identity kernel prettyprint.custom ;\r
-\r
-IN: hashtables.identity.prettyprint\r
-\r
-M: identity-hashtable pprint-delims drop \ IH{ \ } ;\r
+! Copyright (C) 2010-2011 Joe Groff
+! See http://factorcode.org/license.txt for BSD license
+
+USING: hashtables.identity kernel prettyprint.custom ;
+
+IN: hashtables.identity.prettyprint
+
+M: identity-hashtable pprint-delims drop \ IH{ \ } ;
M: wrapped-hashtable pprint*
nesting-limit inc
[ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
-
-
: prev-article ( article -- prev ) -1 prev/next-article ;
-: next-article ( article -- next ) 1 prev/next-article ;
\ No newline at end of file
+: next-article ( article -- next ) 1 prev/next-article ;
{ { "vocabulary " { $strong "or" } " vocab" } { "a named set of words. See " { $link "vocabularies" } } }
{ "vocabulary specifier" { "a " { $link vocab } ", " { $link vocab-link } " or a string naming a vocabulary" } }
{ "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } }
-}
+}
{ $heading "Documentation conventions" }
"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article."
$nl
USE: io.buffers
-ARTICLE: "collections" "Collections"
+ARTICLE: "collections" "Collections"
{ $heading "Sequences" }
{ $subsections
"sequences"
M: word article-title
dup [ parsing-word? ] [ symbol? ] bi or [
- name>>
+ name>>
] [
[ unparse ]
[ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
url-encode swap [XML <a href=<->><-></a> XML] ;
: simple-image ( url -- xml )
- url-encode [XML <img src=<-> /> XML] ;
\ No newline at end of file
+ url-encode [XML <img src=<-> /> XML] ;
: parse-content-type ( content-type -- type encoding )
";" split1
- parse-content-type-attributes "charset" of
+ parse-content-type-attributes "charset" of
[ dup mime-type-encoding encoding>name ] unless* ;
] seq* [ "" concat-as ] action ;
: 'full-request' ( -- parser )
- [
+ [
'space' ,
'http-method' ,
'space' ,
-! Copyright (C) 2007, 2009 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: namespaces kernel assocs io.files io.streams.duplex\r
-combinators arrays io.launcher io.encodings io.encodings.binary io\r
-http.server.static http.server http accessors sequences strings\r
-math.parser fry urls urls.encoding calendar make ;\r
-IN: http.server.cgi\r
-\r
-: cgi-variables ( script-path -- assoc )\r
- #! This needs some work.\r
- [\r
- "CGI/1.0" "GATEWAY_INTERFACE" ,,\r
- "HTTP/" request get version>> append "SERVER_PROTOCOL" ,,\r
- "Factor" "SERVER_SOFTWARE" ,,\r
-\r
- [ "PATH_TRANSLATED" ,, ] [ "SCRIPT_FILENAME" ,, ] bi\r
-\r
- url get path>> "SCRIPT_NAME" ,,\r
-\r
- url get host>> "SERVER_NAME" ,,\r
- url get port>> number>string "SERVER_PORT" ,,\r
- "" "PATH_INFO" ,,\r
- "" "REMOTE_HOST" ,,\r
- "" "REMOTE_ADDR" ,,\r
- "" "AUTH_TYPE" ,,\r
- "" "REMOTE_USER" ,,\r
- "" "REMOTE_IDENT" ,,\r
-\r
- request get method>> "REQUEST_METHOD" ,,\r
- url get query>> assoc>query "QUERY_STRING" ,,\r
- request get "cookie" header "HTTP_COOKIE" ,,\r
-\r
- request get "user-agent" header "HTTP_USER_AGENT" ,,\r
- request get "accept" header "HTTP_ACCEPT" ,,\r
-\r
- post-request? [\r
- request get post-data>> data>>\r
- [ "CONTENT_TYPE" ,, ]\r
- [ length number>string "CONTENT_LENGTH" ,, ]\r
- bi\r
- ] when\r
- ] H{ } make ;\r
-\r
-: <cgi-process> ( name -- desc )\r
- <process>\r
- over 1array >>command\r
- swap cgi-variables >>environment\r
- 1 minutes >>timeout ;\r
-\r
-: serve-cgi ( name -- response )\r
- <raw-response>\r
- 200 >>code\r
- "CGI output follows" >>message\r
- swap '[\r
- binary encode-output\r
- output-stream get _ <cgi-process> binary <process-stream> [\r
- post-request? [ request get post-data>> data>> write flush ] when\r
- '[ _ stream-write ] each-block\r
- ] with-stream\r
- ] >>body ;\r
-\r
-SLOT: special\r
-\r
-: enable-cgi ( responder -- responder )\r
- [ serve-cgi ] "application/x-cgi-script"\r
- pick special>> set-at ;\r
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs io.files io.streams.duplex
+combinators arrays io.launcher io.encodings io.encodings.binary io
+http.server.static http.server http accessors sequences strings
+math.parser fry urls urls.encoding calendar make ;
+IN: http.server.cgi
+
+: cgi-variables ( script-path -- assoc )
+ #! This needs some work.
+ [
+ "CGI/1.0" "GATEWAY_INTERFACE" ,,
+ "HTTP/" request get version>> append "SERVER_PROTOCOL" ,,
+ "Factor" "SERVER_SOFTWARE" ,,
+
+ [ "PATH_TRANSLATED" ,, ] [ "SCRIPT_FILENAME" ,, ] bi
+
+ url get path>> "SCRIPT_NAME" ,,
+
+ url get host>> "SERVER_NAME" ,,
+ url get port>> number>string "SERVER_PORT" ,,
+ "" "PATH_INFO" ,,
+ "" "REMOTE_HOST" ,,
+ "" "REMOTE_ADDR" ,,
+ "" "AUTH_TYPE" ,,
+ "" "REMOTE_USER" ,,
+ "" "REMOTE_IDENT" ,,
+
+ request get method>> "REQUEST_METHOD" ,,
+ url get query>> assoc>query "QUERY_STRING" ,,
+ request get "cookie" header "HTTP_COOKIE" ,,
+
+ request get "user-agent" header "HTTP_USER_AGENT" ,,
+ request get "accept" header "HTTP_ACCEPT" ,,
+
+ post-request? [
+ request get post-data>> data>>
+ [ "CONTENT_TYPE" ,, ]
+ [ length number>string "CONTENT_LENGTH" ,, ]
+ bi
+ ] when
+ ] H{ } make ;
+
+: <cgi-process> ( name -- desc )
+ <process>
+ over 1array >>command
+ swap cgi-variables >>environment
+ 1 minutes >>timeout ;
+
+: serve-cgi ( name -- response )
+ <raw-response>
+ 200 >>code
+ "CGI output follows" >>message
+ swap '[
+ binary encode-output
+ output-stream get _ <cgi-process> binary <process-stream> [
+ post-request? [ request get post-data>> data>> write flush ] when
+ '[ _ stream-write ] each-block
+ ] with-stream
+ ] >>body ;
+
+SLOT: special
+
+: enable-cgi ( responder -- responder )
+ [ serve-cgi ] "application/x-cgi-script"
+ pick special>> set-at ;
-! Copyright (C) 2004, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar kernel math math.order math.parser namespaces\r
-parser sequences strings assocs hashtables debugger mime.types\r
-sorting logging calendar.format accessors splitting io io.files\r
-io.files.info io.directories io.pathnames io.encodings.binary\r
-fry xml.entities destructors urls html xml.syntax\r
-html.templates.fhtml http http.server http.server.responses\r
-http.server.redirection xml.writer ;\r
-FROM: sets => adjoin ;\r
-IN: http.server.static\r
-\r
-TUPLE: file-responder root hook special index-names allow-listings ;\r
-\r
-: modified-since ( request -- date )\r
- "if-modified-since" header ";" split1 drop\r
- dup [ rfc822>timestamp ] when ;\r
-\r
-: modified-since? ( filename -- ? )\r
- request get modified-since dup\r
- [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;\r
-\r
-: <file-responder> ( root hook -- responder )\r
- file-responder new\r
- swap >>hook\r
- swap >>root\r
- H{ } clone >>special\r
- V{ "index.html" } >>index-names ;\r
-\r
-: (serve-static) ( path mime-type -- response )\r
- [\r
- [ binary <file-reader> &dispose ] dip <content>\r
- binary >>content-encoding\r
- ]\r
- [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi\r
- [ "content-length" set-header ]\r
- [ "last-modified" set-header ] bi* ;\r
-\r
-: <static> ( root -- responder )\r
- [ (serve-static) ] <file-responder> ;\r
-\r
-: serve-static ( filename mime-type -- response )\r
- over modified-since?\r
- [ file-responder get hook>> call( filename mime-type -- response ) ]\r
- [ 2drop <304> ]\r
- if ;\r
-\r
-: serving-path ( filename -- filename )\r
- [ file-responder get root>> trim-tail-separators ] dip\r
- [ "/" swap trim-head-separators 3append ] unless-empty ;\r
-\r
-: serve-file ( filename -- response )\r
- dup mime-type\r
- dup file-responder get special>> at\r
- [ call( filename -- response ) ] [ serve-static ] ?if ;\r
-\r
-\ serve-file NOTICE add-input-logging\r
-\r
-: file>html ( name -- xml )\r
- dup link-info directory? [ "/" append ] when\r
- dup [XML <li><a href=<->><-></a></li> XML] ;\r
-\r
-: directory>html ( path -- xml )\r
- [ file-name ]\r
- [ drop f ]\r
- [\r
- [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi\r
- [XML <h1><-></h1> <ul><-></ul> XML]\r
- ] tri\r
- simple-page ;\r
-\r
-: list-directory ( directory -- response )\r
- file-responder get allow-listings>> [\r
- directory>html <html-content>\r
- ] [\r
- drop <403>\r
- ] if ;\r
-\r
-: find-index ( filename -- path )\r
- file-responder get index-names>>\r
- [ append-path dup exists? [ drop f ] unless ] with map-find\r
- drop ;\r
-\r
-: serve-directory ( filename -- response )\r
- url get path>> "/" tail? [\r
- dup\r
- find-index [ serve-file ] [ list-directory ] ?if\r
- ] [\r
- drop\r
- url get clone [ "/" append ] change-path <permanent-redirect>\r
- ] if ;\r
-\r
-: serve-object ( filename -- response )\r
- serving-path dup exists?\r
- [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]\r
- [ drop <404> ]\r
- if ;\r
-\r
-M: file-responder call-responder* ( path responder -- response )\r
- file-responder set\r
- ".." over member?\r
- [ drop <400> ] [ "/" join serve-object ] if ;\r
-\r
-: add-index ( name responder -- )\r
- index-names>> adjoin ;\r
-\r
-: serve-fhtml ( path -- response )\r
- <fhtml> <html-content> ;\r
-\r
-: enable-fhtml ( responder -- responder )\r
- [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at\r
- "index.fhtml" over add-index ;\r
+! Copyright (C) 2004, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar kernel math math.order math.parser namespaces
+parser sequences strings assocs hashtables debugger mime.types
+sorting logging calendar.format accessors splitting io io.files
+io.files.info io.directories io.pathnames io.encodings.binary
+fry xml.entities destructors urls html xml.syntax
+html.templates.fhtml http http.server http.server.responses
+http.server.redirection xml.writer ;
+FROM: sets => adjoin ;
+IN: http.server.static
+
+TUPLE: file-responder root hook special index-names allow-listings ;
+
+: modified-since ( request -- date )
+ "if-modified-since" header ";" split1 drop
+ dup [ rfc822>timestamp ] when ;
+
+: modified-since? ( filename -- ? )
+ request get modified-since dup
+ [ [ file-info modified>> ] dip after? ] [ 2drop t ] if ;
+
+: <file-responder> ( root hook -- responder )
+ file-responder new
+ swap >>hook
+ swap >>root
+ H{ } clone >>special
+ V{ "index.html" } >>index-names ;
+
+: (serve-static) ( path mime-type -- response )
+ [
+ [ binary <file-reader> &dispose ] dip <content>
+ binary >>content-encoding
+ ]
+ [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
+ [ "content-length" set-header ]
+ [ "last-modified" set-header ] bi* ;
+
+: <static> ( root -- responder )
+ [ (serve-static) ] <file-responder> ;
+
+: serve-static ( filename mime-type -- response )
+ over modified-since?
+ [ file-responder get hook>> call( filename mime-type -- response ) ]
+ [ 2drop <304> ]
+ if ;
+
+: serving-path ( filename -- filename )
+ [ file-responder get root>> trim-tail-separators ] dip
+ [ "/" swap trim-head-separators 3append ] unless-empty ;
+
+: serve-file ( filename -- response )
+ dup mime-type
+ dup file-responder get special>> at
+ [ call( filename -- response ) ] [ serve-static ] ?if ;
+
+\ serve-file NOTICE add-input-logging
+
+: file>html ( name -- xml )
+ dup link-info directory? [ "/" append ] when
+ dup [XML <li><a href=<->><-></a></li> XML] ;
+
+: directory>html ( path -- xml )
+ [ file-name ]
+ [ drop f ]
+ [
+ [ file-name ] [ [ [ file>html ] map ] with-directory-files ] bi
+ [XML <h1><-></h1> <ul><-></ul> XML]
+ ] tri
+ simple-page ;
+
+: list-directory ( directory -- response )
+ file-responder get allow-listings>> [
+ directory>html <html-content>
+ ] [
+ drop <403>
+ ] if ;
+
+: find-index ( filename -- path )
+ file-responder get index-names>>
+ [ append-path dup exists? [ drop f ] unless ] with map-find
+ drop ;
+
+: serve-directory ( filename -- response )
+ url get path>> "/" tail? [
+ dup
+ find-index [ serve-file ] [ list-directory ] ?if
+ ] [
+ drop
+ url get clone [ "/" append ] change-path <permanent-redirect>
+ ] if ;
+
+: serve-object ( filename -- response )
+ serving-path dup exists?
+ [ dup file-info directory? [ serve-directory ] [ serve-file ] if ]
+ [ drop <404> ]
+ if ;
+
+M: file-responder call-responder* ( path responder -- response )
+ file-responder set
+ ".." over member?
+ [ drop <400> ] [ "/" join serve-object ] if ;
+
+: add-index ( name responder -- )
+ index-names>> adjoin ;
+
+: serve-fhtml ( path -- response )
+ <fhtml> <html-content> ;
+
+: enable-fhtml ( responder -- responder )
+ [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
+ "index.fhtml" over add-index ;
-! (c)2010 Joe Groff bsd license\r
-USING: accessors alien alien.c-types alien.data alien.enums alien.strings\r
-assocs byte-arrays classes.struct destructors grouping images images.loader\r
-io kernel locals math mime.types namespaces sequences specialized-arrays\r
-windows.com windows.gdiplus windows.streams windows.types ;\r
-FROM: system => os windows? ;\r
-IN: images.loader.gdiplus\r
-\r
-SPECIALIZED-ARRAY: ImageCodecInfo\r
-\r
-SINGLETON: gdi+-image\r
-\r
-os windows? [\r
- { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" }\r
- [ gdi+-image register-image-class ] each\r
-] when\r
-\r
-<PRIVATE\r
-\r
-: <GpRect> ( x y w h -- rect )\r
- GpRect <struct-boa> ; inline\r
-\r
-: stream>gdi+-bitmap ( stream -- bitmap )\r
- stream>IStream &com-release\r
- { void* } [ GdipCreateBitmapFromStream check-gdi+-status ]\r
- with-out-parameters &GdipFree ;\r
-\r
-: gdi+-bitmap-width ( bitmap -- w )\r
- { UINT } [ GdipGetImageWidth check-gdi+-status ]\r
- with-out-parameters ;\r
-\r
-: gdi+-bitmap-height ( bitmap -- h )\r
- { UINT } [ GdipGetImageHeight check-gdi+-status ]\r
- with-out-parameters ;\r
-\r
-: gdi+-lock-bitmap ( bitmap rect mode format -- data )\r
- { BitmapData } [ GdipBitmapLockBits check-gdi+-status ]\r
- with-out-parameters ;\r
-\r
-:: gdi+-bitmap>data ( bitmap -- w h pixels )\r
- bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h )\r
- bitmap 0 0 w h <GpRect> ImageLockModeRead enum>number\r
- PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data\r
- bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri\r
- memory>byte-array :> pixels\r
- bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status\r
- w h pixels ;\r
-\r
-:: data>image ( w h pixels -- image )\r
- image new\r
- { w h } >>dim\r
- pixels >>bitmap\r
- BGRA >>component-order\r
- ubyte-components >>component-type\r
- f >>upside-down? ;\r
-\r
-! Only one pixel format supported, but I can't find images in the\r
-! wild, loaded using gdi+, in which the format is different.\r
-ERROR: unsupported-pixel-format component-order ;\r
-\r
-: check-pixel-format ( image -- )\r
- component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ;\r
-\r
-: image>gdi+-bitmap ( image -- bitmap )\r
- dup check-pixel-format\r
- [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri\r
- { void* } [\r
- GdipCreateBitmapFromScan0 check-gdi+-status\r
- ] with-out-parameters &GdipFree ;\r
-\r
-: image-encoders-size ( -- num size )\r
- { UINT UINT } [\r
- GdipGetImageEncodersSize check-gdi+-status\r
- ] with-out-parameters ;\r
-\r
-: image-encoders ( -- codec-infos )\r
- image-encoders-size dup <byte-array> 3dup\r
- GdipGetImageEncoders check-gdi+-status\r
- nip swap ImageCodecInfo <c-direct-array> ;\r
-\r
-: extension>mime-type ( extension -- mime-type )\r
- ! Crashes if you let this mime through on my machine.\r
- dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ;\r
-\r
-: mime-type>clsid ( mime-type -- clsid )\r
- image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ;\r
-\r
-: startup-gdi+ ( -- )\r
- start-gdi+ &stop-gdi+ drop ;\r
-\r
-: write-image-to-stream ( image stream extension -- )\r
- [ image>gdi+-bitmap ]\r
- [ stream>IStream &com-release ]\r
- [ extension>mime-type mime-type>clsid ] tri*\r
- f GdipSaveImageToStream check-gdi+-status ;\r
-\r
-PRIVATE>\r
-\r
-M: gdi+-image stream>image*\r
- drop startup-gdi+\r
- stream>gdi+-bitmap\r
- gdi+-bitmap>data\r
- data>image ;\r
-\r
-M: gdi+-image image>stream ( image extension class -- )\r
- drop startup-gdi+ output-stream get swap write-image-to-stream ;\r
+! (c)2010 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.data alien.enums alien.strings
+assocs byte-arrays classes.struct destructors grouping images images.loader
+io kernel locals math mime.types namespaces sequences specialized-arrays
+windows.com windows.gdiplus windows.streams windows.types ;
+FROM: system => os windows? ;
+IN: images.loader.gdiplus
+
+SPECIALIZED-ARRAY: ImageCodecInfo
+
+SINGLETON: gdi+-image
+
+os windows? [
+ { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" }
+ [ gdi+-image register-image-class ] each
+] when
+
+<PRIVATE
+
+: <GpRect> ( x y w h -- rect )
+ GpRect <struct-boa> ; inline
+
+: stream>gdi+-bitmap ( stream -- bitmap )
+ stream>IStream &com-release
+ { void* } [ GdipCreateBitmapFromStream check-gdi+-status ]
+ with-out-parameters &GdipFree ;
+
+: gdi+-bitmap-width ( bitmap -- w )
+ { UINT } [ GdipGetImageWidth check-gdi+-status ]
+ with-out-parameters ;
+
+: gdi+-bitmap-height ( bitmap -- h )
+ { UINT } [ GdipGetImageHeight check-gdi+-status ]
+ with-out-parameters ;
+
+: gdi+-lock-bitmap ( bitmap rect mode format -- data )
+ { BitmapData } [ GdipBitmapLockBits check-gdi+-status ]
+ with-out-parameters ;
+
+:: gdi+-bitmap>data ( bitmap -- w h pixels )
+ bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h )
+ bitmap 0 0 w h <GpRect> ImageLockModeRead enum>number
+ PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data
+ bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri
+ memory>byte-array :> pixels
+ bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status
+ w h pixels ;
+
+:: data>image ( w h pixels -- image )
+ image new
+ { w h } >>dim
+ pixels >>bitmap
+ BGRA >>component-order
+ ubyte-components >>component-type
+ f >>upside-down? ;
+
+! Only one pixel format supported, but I can't find images in the
+! wild, loaded using gdi+, in which the format is different.
+ERROR: unsupported-pixel-format component-order ;
+
+: check-pixel-format ( image -- )
+ component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ;
+
+: image>gdi+-bitmap ( image -- bitmap )
+ dup check-pixel-format
+ [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri
+ { void* } [
+ GdipCreateBitmapFromScan0 check-gdi+-status
+ ] with-out-parameters &GdipFree ;
+
+: image-encoders-size ( -- num size )
+ { UINT UINT } [
+ GdipGetImageEncodersSize check-gdi+-status
+ ] with-out-parameters ;
+
+: image-encoders ( -- codec-infos )
+ image-encoders-size dup <byte-array> 3dup
+ GdipGetImageEncoders check-gdi+-status
+ nip swap ImageCodecInfo <c-direct-array> ;
+
+: extension>mime-type ( extension -- mime-type )
+ ! Crashes if you let this mime through on my machine.
+ dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ;
+
+: mime-type>clsid ( mime-type -- clsid )
+ image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ;
+
+: startup-gdi+ ( -- )
+ start-gdi+ &stop-gdi+ drop ;
+
+: write-image-to-stream ( image stream extension -- )
+ [ image>gdi+-bitmap ]
+ [ stream>IStream &com-release ]
+ [ extension>mime-type mime-type>clsid ] tri*
+ f GdipSaveImageToStream check-gdi+-status ;
+
+PRIVATE>
+
+M: gdi+-image stream>image*
+ drop startup-gdi+
+ stream>gdi+-bitmap
+ gdi+-bitmap>data
+ data>image ;
+
+M: gdi+-image image>stream ( image extension class -- )
+ drop startup-gdi+ output-stream get swap write-image-to-stream ;
[ >byte-array ] change-bitmap
RGBA reorder-components
normalize-scan-line-order ;
-
-! Copyright (C) 2009 Marc Fauconneau.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays byte-arrays combinators grouping images\r
-kernel locals math math.order\r
-math.ranges math.vectors sequences sequences.deep fry ;\r
-IN: images.processing\r
-\r
-: coord-matrix ( dim -- m )\r
- [ iota ] map first2 cartesian-product ;\r
-\r
-: map^2 ( m quot -- m' ) '[ _ map ] map ; inline\r
-: each^2 ( m quot -- m' ) '[ _ each ] each ; inline\r
-\r
-: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ;\r
- \r
-: matrix>image ( m -- image )\r
- <image> over matrix-dim >>dim\r
- swap flip flatten\r
- [ 128 * 128 + 0 255 clamp >fixnum ] map\r
- >byte-array >>bitmap L >>component-order ubyte-components >>component-type ;\r
-\r
-:: matrix-zoom ( m f -- m' )\r
- m matrix-dim f v*n coord-matrix\r
- [ [ f /i ] map first2 swap m nth nth ] map^2 ;\r
-\r
-:: image-offset ( x,y image -- xy )\r
- image dim>> first\r
- x,y second * x,y first + ;\r
- \r
-:: draw-grey ( value x,y image -- )\r
- x,y image image-offset 3 * { 0 1 2 }\r
- [\r
- + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth\r
- ] with each ;\r
-\r
-:: draw-color ( value x,y color-id image -- )\r
- x,y image image-offset 3 * color-id + value >fixnum\r
- swap image bitmap>> set-nth ;\r
-\r
-! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ;\r
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators grouping images
+kernel locals math math.order
+math.ranges math.vectors sequences sequences.deep fry ;
+IN: images.processing
+
+: coord-matrix ( dim -- m )
+ [ iota ] map first2 cartesian-product ;
+
+: map^2 ( m quot -- m' ) '[ _ map ] map ; inline
+: each^2 ( m quot -- m' ) '[ _ each ] each ; inline
+
+: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ;
+
+: matrix>image ( m -- image )
+ <image> over matrix-dim >>dim
+ swap flip flatten
+ [ 128 * 128 + 0 255 clamp >fixnum ] map
+ >byte-array >>bitmap L >>component-order ubyte-components >>component-type ;
+
+:: matrix-zoom ( m f -- m' )
+ m matrix-dim f v*n coord-matrix
+ [ [ f /i ] map first2 swap m nth nth ] map^2 ;
+
+:: image-offset ( x,y image -- xy )
+ image dim>> first
+ x,y second * x,y first + ;
+
+:: draw-grey ( value x,y image -- )
+ x,y image image-offset 3 * { 0 1 2 }
+ [
+ + value 128 + >fixnum 0 255 clamp swap image bitmap>> set-nth
+ ] with each ;
+
+:: draw-color ( value x,y color-id image -- )
+ x,y image image-offset 3 * color-id + value >fixnum
+ swap image bitmap>> set-nth ;
+
+! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ;
-! Copyright (C) 2008, 2009 Daniel Ehrenberg.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: assocs help.markup help.syntax kernel sequences ;\r
-IN: interval-maps\r
-\r
-HELP: interval-at*\r
-{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } { "?" "whether the key is present" } }\r
-{ $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ;\r
-\r
-HELP: interval-at\r
-{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } }\r
-{ $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ;\r
-\r
-HELP: interval-key?\r
-{ $values { "key" object } { "map" interval-map } { "?" boolean } }\r
-{ $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ;\r
-\r
-HELP: <interval-map>\r
-{ $values { "specification" assoc } { "map" interval-map } }\r
-{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;\r
-\r
-HELP: interval-values\r
-{ $values { "map" interval-map } { "values" sequence } }\r
-{ $description "Constructs a list of all of the values that interval map keys are associated with. This list may contain duplicates." } ;\r
-\r
-HELP: coalesce\r
-{ $values { "alist" "an association list with integer keys" } { "specification" { "array of the format used by " { $link <interval-map> } } } }\r
-{ $description "Finds ranges used in the given alist, coalescing them into a single range." } ;\r
-\r
-ARTICLE: "interval-maps" "Interval maps"\r
-"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."\r
-$nl\r
-"The following operations are used to query interval maps:"\r
-{ $subsections\r
- interval-at*\r
- interval-at\r
- interval-key?\r
- interval-values\r
-}\r
-"Use the following to construct interval maps"\r
-{ $subsections\r
- <interval-map>\r
- coalesce\r
-} ;\r
-\r
-ABOUT: "interval-maps"\r
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel sequences ;
+IN: interval-maps
+
+HELP: interval-at*
+{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } { "?" "whether the key is present" } }
+{ $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ;
+
+HELP: interval-at
+{ $values { "key" object } { "map" interval-map } { "value" "the value for the key, or f" } }
+{ $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ;
+
+HELP: interval-key?
+{ $values { "key" object } { "map" interval-map } { "?" boolean } }
+{ $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ;
+
+HELP: <interval-map>
+{ $values { "specification" assoc } { "map" interval-map } }
+{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;
+
+HELP: interval-values
+{ $values { "map" interval-map } { "values" sequence } }
+{ $description "Constructs a list of all of the values that interval map keys are associated with. This list may contain duplicates." } ;
+
+HELP: coalesce
+{ $values { "alist" "an association list with integer keys" } { "specification" { "array of the format used by " { $link <interval-map> } } } }
+{ $description "Finds ranges used in the given alist, coalescing them into a single range." } ;
+
+ARTICLE: "interval-maps" "Interval maps"
+"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
+$nl
+"The following operations are used to query interval maps:"
+{ $subsections
+ interval-at*
+ interval-at
+ interval-key?
+ interval-values
+}
+"Use the following to construct interval maps"
+{ $subsections
+ <interval-map>
+ coalesce
+} ;
+
+ABOUT: "interval-maps"
-USING: kernel namespaces interval-maps tools.test ;\r
-IN: interval-maps.test\r
-\r
-SYMBOL: test\r
-\r
-[ ] [ { { { 4 8 } 3 } { 1 2 } } <interval-map> test set ] unit-test\r
-[ 3 ] [ 5 test get interval-at ] unit-test\r
-[ 3 ] [ 8 test get interval-at ] unit-test\r
-[ 3 ] [ 4 test get interval-at ] unit-test\r
-[ f ] [ 9 test get interval-at ] unit-test\r
-[ 2 ] [ 1 test get interval-at ] unit-test\r
-[ f ] [ 2 test get interval-at ] unit-test\r
-[ f ] [ 0 test get interval-at ] unit-test\r
-\r
-[ { { { 1 4 } 3 } { { 4 8 } 6 } } <interval-map> ] must-fail\r
-\r
-[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]\r
-[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test\r
+USING: kernel namespaces interval-maps tools.test ;
+IN: interval-maps.test
+
+SYMBOL: test
+
+[ ] [ { { { 4 8 } 3 } { 1 2 } } <interval-map> test set ] unit-test
+[ 3 ] [ 5 test get interval-at ] unit-test
+[ 3 ] [ 8 test get interval-at ] unit-test
+[ 3 ] [ 4 test get interval-at ] unit-test
+[ f ] [ 9 test get interval-at ] unit-test
+[ 2 ] [ 1 test get interval-at ] unit-test
+[ f ] [ 2 test get interval-at ] unit-test
+[ f ] [ 0 test get interval-at ] unit-test
+
+[ { { { 1 4 } 3 } { { 4 8 } 6 } } <interval-map> ] must-fail
+
+[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
+[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test
-! Copyright (C) 2008 Daniel Ehrenberg.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays assocs binary-search grouping kernel\r
-locals make math math.order sequences sequences.private sorting ;\r
-IN: interval-maps\r
-\r
-TUPLE: interval-map { array array read-only } ;\r
-\r
-<PRIVATE\r
-\r
-ALIAS: start first-unsafe\r
-ALIAS: end second-unsafe\r
-ALIAS: value third-unsafe\r
-\r
-: find-interval ( key interval-map -- interval-node )\r
- array>> [ start <=> ] with search nip ; inline\r
-\r
-: interval-contains? ( key interval-node -- ? )\r
- first2-unsafe between? ; inline\r
-\r
-: all-intervals ( sequence -- intervals )\r
- [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;\r
-\r
-: disjoint? ( node1 node2 -- ? )\r
- [ end ] [ start ] bi* < ;\r
-\r
-: ensure-disjoint ( intervals -- intervals )\r
- dup [ disjoint? ] monotonic?\r
- [ "Intervals are not disjoint" throw ] unless ;\r
-\r
-: >intervals ( specification -- intervals )\r
- [ suffix ] { } assoc>map concat 3 group ;\r
-\r
-ERROR: not-an-interval-map obj ;\r
-\r
-: check-interval-map ( map -- map )\r
- dup interval-map? [ not-an-interval-map ] unless ; inline\r
-\r
-PRIVATE>\r
-\r
-: interval-at* ( key map -- value ? )\r
- check-interval-map\r
- [ drop ] [ find-interval ] 2bi\r
- [ nip ] [ interval-contains? ] 2bi\r
- [ value t ] [ drop f f ] if ; inline\r
-\r
-: interval-at ( key map -- value ) interval-at* drop ; inline\r
-\r
-: interval-key? ( key map -- ? ) interval-at* nip ; inline\r
-\r
-: interval-values ( map -- values )\r
- check-interval-map array>> [ value ] map ;\r
-\r
-: <interval-map> ( specification -- map )\r
- all-intervals [ first-unsafe second-unsafe ] sort-with\r
- >intervals ensure-disjoint interval-map boa ;\r
-\r
-: <interval-set> ( specification -- map )\r
- dup zip <interval-map> ;\r
-\r
-:: coalesce ( alist -- specification )\r
- ! Only works with integer keys, because they're discrete\r
- ! Makes 2array keys\r
- [\r
- alist sort-keys unclip swap [ first2 dupd ] dip\r
- [| oldkey oldval key val | ! Underneath is start\r
- oldkey 1 + key =\r
- oldval val = and\r
- [ oldkey 2array oldval 2array , key ] unless\r
- key val\r
- ] assoc-each [ 2array ] bi@ ,\r
- ] { } make ;\r
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs binary-search grouping kernel
+locals make math math.order sequences sequences.private sorting ;
+IN: interval-maps
+
+TUPLE: interval-map { array array read-only } ;
+
+<PRIVATE
+
+ALIAS: start first-unsafe
+ALIAS: end second-unsafe
+ALIAS: value third-unsafe
+
+: find-interval ( key interval-map -- interval-node )
+ array>> [ start <=> ] with search nip ; inline
+
+: interval-contains? ( key interval-node -- ? )
+ first2-unsafe between? ; inline
+
+: all-intervals ( sequence -- intervals )
+ [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ;
+
+: disjoint? ( node1 node2 -- ? )
+ [ end ] [ start ] bi* < ;
+
+: ensure-disjoint ( intervals -- intervals )
+ dup [ disjoint? ] monotonic?
+ [ "Intervals are not disjoint" throw ] unless ;
+
+: >intervals ( specification -- intervals )
+ [ suffix ] { } assoc>map concat 3 group ;
+
+ERROR: not-an-interval-map obj ;
+
+: check-interval-map ( map -- map )
+ dup interval-map? [ not-an-interval-map ] unless ; inline
+
+PRIVATE>
+
+: interval-at* ( key map -- value ? )
+ check-interval-map
+ [ drop ] [ find-interval ] 2bi
+ [ nip ] [ interval-contains? ] 2bi
+ [ value t ] [ drop f f ] if ; inline
+
+: interval-at ( key map -- value ) interval-at* drop ; inline
+
+: interval-key? ( key map -- ? ) interval-at* nip ; inline
+
+: interval-values ( map -- values )
+ check-interval-map array>> [ value ] map ;
+
+: <interval-map> ( specification -- map )
+ all-intervals [ first-unsafe second-unsafe ] sort-with
+ >intervals ensure-disjoint interval-map boa ;
+
+: <interval-set> ( specification -- map )
+ dup zip <interval-map> ;
+
+:: coalesce ( alist -- specification )
+ ! Only works with integer keys, because they're discrete
+ ! Makes 2array keys
+ [
+ alist sort-keys unclip swap [ first2 dupd ] dip
+ [| oldkey oldval key val | ! Underneath is start
+ oldkey 1 + key =
+ oldval val = and
+ [ oldkey 2array oldval 2array , key ] unless
+ key val
+ ] assoc-each [ 2array ] bi@ ,
+ ] { } make ;
if ;
: fold ( quot -- folded-quot )
- [ { } [ fold-word ] reduce % ] [ ] make ;
+ [ { } [ fold-word ] reduce % ] [ ] make ;
ERROR: no-recursive-inverse ;
{ [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with any? not
- ] } 1&& ;
+ ] } 1&& ;
: flatten ( quot -- expanded )
[
over name>> "." = [ nip ] [ swap prefix ] if
]
] [ drop '[ _ FindClose win32-error=0/f ] ] 2bi [ ] cleanup ;
-
IN: io.encodings.8-bit.latin4
8-BIT: latin4 ISO_8859-4:1988 8859-4
-
IN: io.encodings.8-bit.latin6
8-BIT: latin6 ISO-8859-10 8859-10
-
EUC: big5 "vocab:io/encodings/big5/CP950.TXT"
big5 "Big5" register-encoding
-
[let
H{ } clone :> mapping V{ } clone :> ranges
[
- dup contained? [
+ dup contained? [
dup name>> main>> {
{ "range" [ ranges add-range ] }
{ "a" [ mapping add-mapping ] }
USE: io.encodings.euc
IN: io.encodings.johab
-EUC: johab "vocab:io/encodings/johab/johab.txt"
-
+EUC: johab "vocab:io/encodings/johab/johab.txt"
-IN: io.monitors\r
-USING: concurrency.mailboxes destructors help.markup help.syntax\r
-kernel quotations ;\r
-\r
-HELP: with-monitors\r
-{ $values { "quot" quotation } }\r
-{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }\r
-{ $errors "Throws an error if the platform does not support file system change monitors." } ;\r
-\r
-HELP: <monitor>\r
-{ $values { "path" "a pathname string" } { "recursive?" boolean } { "monitor" "a new monitor" } }\r
-{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }\r
-{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
-\r
-HELP: (monitor)\r
-{ $values { "path" "a pathname string" } { "recursive?" boolean } { "mailbox" mailbox } { "monitor" "a new monitor" } }\r
-{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }\r
-{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
-\r
-HELP: file-change\r
-{ $class-description "A change notification output by " { $link next-change } ". The " { $snippet "path" } " slot holds a pathname string. The " { $snippet "changed" } " slots holds a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;\r
-\r
-HELP: next-change\r
-{ $values { "monitor" "a monitor" } { "change" file-change } }\r
-{ $contract "Waits for file system changes and outputs a change descriptor for the first changed file." }\r
-{ $errors "Throws an error if the monitor is closed from another thread." } ;\r
-\r
-HELP: with-monitor\r
-{ $values { "path" "a pathname string" } { "recursive?" boolean } { "quot" { $quotation ( monitor -- ) } } }\r
-{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }\r
-{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
-\r
-HELP: +add-file+\r
-{ $description "Indicates that a file has been added to its parent directory." } ;\r
-\r
-HELP: +remove-file+\r
-{ $description "Indicates that a file has been removed from its parent directory." } ;\r
-\r
-HELP: +modify-file+\r
-{ $description "Indicates that a file's contents have changed." } ;\r
-\r
-HELP: +rename-file-old+\r
-{ $description "Indicates that a file has been renamed, and this is the old name." } ;\r
-\r
-HELP: +rename-file-new+\r
-{ $description "Indicates that a file has been renamed, and this is the new name." } ;\r
-\r
-HELP: +rename-file+\r
-{ $description "Indicates that a file has been renamed." } ;\r
-\r
-ARTICLE: "io.monitors.descriptors" "File system change descriptors"\r
-"The " { $link next-change } " word outputs instances of a class:"\r
-{ $subsections file-change }\r
-"The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:"\r
-{ $subsections\r
- +add-file+\r
- +remove-file+\r
- +modify-file+\r
- +rename-file-old+\r
- +rename-file-new+\r
- +rename-file+\r
-} ;\r
-\r
-ARTICLE: "io.monitors.platforms" "Monitors on different platforms"\r
-"Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."\r
-$nl\r
-"If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below."\r
-{ $heading "Mac OS X" }\r
-"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."\r
-$nl\r
-{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."\r
-$nl\r
-"The " { $snippet "changed" } " slot of the " { $link file-change } " word tuple always contains " { $link +modify-file+ } " and the " { $snippet "path" } " slot is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."\r
-$nl\r
-"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."\r
-{ $heading "Windows" }\r
-"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."\r
-$nl\r
-"Both recursive and non-recursive monitors are directly supported by the operating system."\r
-$nl\r
-"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."\r
-{ $heading "Linux" }\r
-"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."\r
-$nl\r
-"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."\r
-$nl\r
-"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."\r
-$nl\r
-"Both directories and files may be monitored. Unlike Mac OS X and Windows, changes to the immediate directory being monitored (permissions, modification time, and so on) are reported."\r
-;\r
-\r
-ARTICLE: "io.monitors" "File system change monitors"\r
-"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."\r
-$nl\r
-"Monitoring operations must be wrapped in a combinator:"\r
-{ $subsections with-monitors }\r
-"Creating a file system change monitor and listening for changes:"\r
-{ $subsections\r
- <monitor>\r
- next-change\r
-}\r
-"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"\r
-{ $subsections\r
- (monitor)\r
- "io.monitors.descriptors"\r
- "io.monitors.platforms"\r
-}\r
-"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"\r
-{ $subsections with-monitor }\r
-"Monitors support the " { $link "io.timeouts" } "."\r
-$nl\r
-"An example which watches a directory for changes:"\r
-{ $code\r
- "USE: io.monitors"\r
- ""\r
- ": watch-loop ( monitor -- )"\r
- " dup next-change path>> print flush watch-loop ;"\r
- ""\r
- ": watch-directory ( path -- )"\r
- " [ t [ watch-loop ] with-monitor ] with-monitors ;"\r
-} ;\r
-\r
-ABOUT: "io.monitors"\r
+IN: io.monitors
+USING: concurrency.mailboxes destructors help.markup help.syntax
+kernel quotations ;
+
+HELP: with-monitors
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }
+{ $errors "Throws an error if the platform does not support file system change monitors." } ;
+
+HELP: <monitor>
+{ $values { "path" "a pathname string" } { "recursive?" boolean } { "monitor" "a new monitor" } }
+{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
+
+HELP: (monitor)
+{ $values { "path" "a pathname string" } { "recursive?" boolean } { "mailbox" mailbox } { "monitor" "a new monitor" } }
+{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
+
+HELP: file-change
+{ $class-description "A change notification output by " { $link next-change } ". The " { $snippet "path" } " slot holds a pathname string. The " { $snippet "changed" } " slots holds a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
+
+HELP: next-change
+{ $values { "monitor" "a monitor" } { "change" file-change } }
+{ $contract "Waits for file system changes and outputs a change descriptor for the first changed file." }
+{ $errors "Throws an error if the monitor is closed from another thread." } ;
+
+HELP: with-monitor
+{ $values { "path" "a pathname string" } { "recursive?" boolean } { "quot" { $quotation ( monitor -- ) } } }
+{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
+
+HELP: +add-file+
+{ $description "Indicates that a file has been added to its parent directory." } ;
+
+HELP: +remove-file+
+{ $description "Indicates that a file has been removed from its parent directory." } ;
+
+HELP: +modify-file+
+{ $description "Indicates that a file's contents have changed." } ;
+
+HELP: +rename-file-old+
+{ $description "Indicates that a file has been renamed, and this is the old name." } ;
+
+HELP: +rename-file-new+
+{ $description "Indicates that a file has been renamed, and this is the new name." } ;
+
+HELP: +rename-file+
+{ $description "Indicates that a file has been renamed." } ;
+
+ARTICLE: "io.monitors.descriptors" "File system change descriptors"
+"The " { $link next-change } " word outputs instances of a class:"
+{ $subsections file-change }
+"The " { $slot "changed" } " slot holds a sequence which may contain any of the following symbols:"
+{ $subsections
+ +add-file+
+ +remove-file+
+ +modify-file+
+ +rename-file-old+
+ +rename-file-new+
+ +rename-file+
+} ;
+
+ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
+"Whether the " { $slot "path" } " slot of a " { $link file-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is unspecified, and may even vary on the same platform. User code should not assume either case."
+$nl
+"If the immediate path being monitored was changed, then " { $snippet "path" } " will equal " { $snippet "\"\"" } "; however this condition is not reported on all platforms. See below."
+{ $heading "Mac OS X" }
+"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."
+$nl
+{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
+$nl
+"The " { $snippet "changed" } " slot of the " { $link file-change } " word tuple always contains " { $link +modify-file+ } " and the " { $snippet "path" } " slot is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
+$nl
+"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."
+{ $heading "Windows" }
+"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."
+$nl
+"Both recursive and non-recursive monitors are directly supported by the operating system."
+$nl
+"Only directories may be monitored, not individual files. Changes to the directory itself (permissions, modification time, and so on) are not reported; only changes to children are reported."
+{ $heading "Linux" }
+"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."
+$nl
+"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."
+$nl
+"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."
+$nl
+"Both directories and files may be monitored. Unlike Mac OS X and Windows, changes to the immediate directory being monitored (permissions, modification time, and so on) are reported."
+;
+
+ARTICLE: "io.monitors" "File system change monitors"
+"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."
+$nl
+"Monitoring operations must be wrapped in a combinator:"
+{ $subsections with-monitors }
+"Creating a file system change monitor and listening for changes:"
+{ $subsections
+ <monitor>
+ next-change
+}
+"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"
+{ $subsections
+ (monitor)
+ "io.monitors.descriptors"
+ "io.monitors.platforms"
+}
+"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"
+{ $subsections with-monitor }
+"Monitors support the " { $link "io.timeouts" } "."
+$nl
+"An example which watches a directory for changes:"
+{ $code
+ "USE: io.monitors"
+ ""
+ ": watch-loop ( monitor -- )"
+ " dup next-change path>> print flush watch-loop ;"
+ ""
+ ": watch-directory ( path -- )"
+ " [ t [ watch-loop ] with-monitor ] with-monitors ;"
+} ;
+
+ABOUT: "io.monitors"
: insecure-addr ( -- addrspec )
server-addrs [ secure? ] reject random ;
-
+
: server. ( threaded-server -- )
[ [ "=== " write name>> ] [ ] bi write-object nl ]
[ servers>> [ addr>> present print ] each ] bi ;
: get-servers-named ( string -- sequence )
[ all-servers ] dip '[ name>> _ = ] filter ;
-
+
: servers. ( -- )
all-servers [ server. ] each ;
! Linux seems to use the same port-space for ipv4 and ipv6.
M: linux resolve-localhost { T{ ipv4 f "0.0.0.0" } } ;
-
-! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors alien alien.c-types alien.data classes.struct\r
-combinators destructors io.backend io.files.windows io.ports\r
-io.sockets io.sockets.icmp io.sockets.private kernel libc locals\r
-math sequences system windows.errors windows.handles\r
-windows.kernel32 windows.types windows.winsock ;\r
-FROM: namespaces => get ;\r
-IN: io.sockets.windows\r
-\r
-: set-socket-option ( handle level opt -- )\r
- [ handle>> ] 2dip 1 int <ref> dup byte-length setsockopt socket-error ;\r
-\r
-: set-ioctl-socket ( handle cmd arg -- )\r
- [ handle>> ] 2dip ulong <ref> ioctlsocket socket-error ;\r
-\r
-M: windows addrinfo-error-string ( n -- string )\r
- n>win32-error-string ;\r
-\r
-M: windows sockaddr-of-family ( alien af -- addrspec )\r
- {\r
- { AF_INET [ sockaddr-in memory>struct ] }\r
- { AF_INET6 [ sockaddr-in6 memory>struct ] }\r
- [ 2drop f ]\r
- } case ;\r
-\r
-M: windows addrspec-of-family ( af -- addrspec )\r
- {\r
- { AF_INET [ T{ ipv4 } ] }\r
- { AF_INET6 [ T{ ipv6 } ] }\r
- [ drop f ]\r
- } case ;\r
-\r
-HOOK: WSASocket-flags io-backend ( -- DWORD )\r
-\r
-TUPLE: win32-socket < win32-file ;\r
-\r
-: <win32-socket> ( handle -- win32-socket )\r
- win32-socket new-win32-handle ;\r
-\r
-M: win32-socket dispose* ( stream -- )\r
- handle>> closesocket socket-error* ;\r
-\r
-: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;\r
-\r
-: opened-socket ( handle -- win32-socket )\r
- <win32-socket> |dispose add-completion ;\r
-\r
-: open-socket ( addrspec type -- win32-socket )\r
- [ drop protocol-family ] [ swap protocol ] 2bi\r
- f 0 WSASocket-flags WSASocket\r
- dup socket-error\r
- opened-socket ;\r
-\r
-M: object (get-local-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size int <ref>\r
- [ getsockname socket-error ] 2keep drop ;\r
-\r
-M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size int <ref>\r
- [ getpeername socket-error ] 2keep drop ;\r
-\r
-: bind-socket ( win32-socket sockaddr len -- )\r
- [ handle>> ] 2dip bind socket-error ;\r
-\r
-M: object ((client)) ( addrspec -- handle )\r
- [ SOCK_STREAM open-socket ] keep\r
- [\r
- bind-local-address get\r
- [ nip make-sockaddr/size ]\r
- [ unspecific-sockaddr/size ] if* bind-socket\r
- ] [ drop ] 2bi ;\r
-\r
-: server-socket ( addrspec type -- fd )\r
- [ open-socket ] [ drop ] 2bi\r
- [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
-\r
-! http://support.microsoft.com/kb/127144\r
-! NOTE: Possibly tweak this because of SYN flood attacks\r
-: listen-backlog ( -- n ) 0x7fffffff ; inline\r
-\r
-M: object (server) ( addrspec -- handle )\r
- [\r
- SOCK_STREAM server-socket\r
- dup handle>> listen-backlog listen winsock-return-check\r
- ] with-destructors ;\r
-\r
-M: windows (datagram) ( addrspec -- handle )\r
- [ SOCK_DGRAM server-socket ] with-destructors ;\r
-\r
-M: windows (raw) ( addrspec -- handle )\r
- [ SOCK_RAW server-socket ] with-destructors ;\r
-\r
-M: windows (broadcast) ( datagram -- datagram )\r
- dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ;\r
-\r
-: malloc-int ( n -- alien )\r
- int <ref> malloc-byte-array ; inline\r
-\r
-M: windows WSASocket-flags ( -- DWORD )\r
- WSA_FLAG_OVERLAPPED ; inline\r
-\r
-: get-ConnectEx-ptr ( socket -- void* )\r
- SIO_GET_EXTENSION_FUNCTION_POINTER\r
- WSAID_CONNECTEX\r
- GUID heap-size\r
- { void* }\r
- [\r
- void* heap-size\r
- 0 DWORD <ref>\r
- f\r
- f\r
- WSAIoctl SOCKET_ERROR = [\r
- maybe-winsock-exception throw\r
- ] when\r
- ] with-out-parameters ;\r
-\r
-TUPLE: ConnectEx-args port\r
- s name namelen lpSendBuffer dwSendDataLength\r
- lpdwBytesSent lpOverlapped ptr ;\r
-\r
-: wait-for-socket ( args -- count )\r
- [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline\r
-\r
-: <ConnectEx-args> ( sockaddr size -- ConnectEx )\r
- ConnectEx-args new\r
- swap >>namelen\r
- swap >>name\r
- f >>lpSendBuffer\r
- 0 >>dwSendDataLength\r
- f >>lpdwBytesSent\r
- (make-overlapped) >>lpOverlapped ; inline\r
-\r
-: call-ConnectEx ( ConnectEx -- )\r
- {\r
- [ s>> ]\r
- [ name>> ]\r
- [ namelen>> ]\r
- [ lpSendBuffer>> ]\r
- [ dwSendDataLength>> ]\r
- [ lpdwBytesSent>> ]\r
- [ lpOverlapped>> ]\r
- [ ptr>> ]\r
- } cleave\r
- int\r
- { SOCKET void* int PVOID DWORD LPDWORD void* }\r
- stdcall alien-indirect drop\r
- winsock-error ; inline\r
-\r
-M: object establish-connection ( client-out remote -- )\r
- make-sockaddr/size <ConnectEx-args>\r
- swap >>port\r
- dup port>> handle>> handle>> >>s\r
- dup s>> get-ConnectEx-ptr >>ptr\r
- dup call-ConnectEx\r
- wait-for-socket drop ;\r
-\r
-TUPLE: AcceptEx-args port\r
- sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength\r
- dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;\r
-\r
-: init-accept-buffer ( addr AcceptEx -- )\r
- swap sockaddr-size 16 +\r
- [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi\r
- dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer\r
- drop ; inline\r
-\r
-: <AcceptEx-args> ( server addr -- AcceptEx )\r
- AcceptEx-args new\r
- 2dup init-accept-buffer\r
- swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket\r
- over handle>> handle>> >>sListenSocket\r
- swap >>port\r
- 0 >>dwReceiveDataLength\r
- f >>lpdwBytesReceived\r
- (make-overlapped) >>lpOverlapped ; inline\r
-\r
-! AcceptEx return value is useless\r
-: call-AcceptEx ( AcceptEx -- )\r
- {\r
- [ sListenSocket>> ]\r
- [ sAcceptSocket>> ]\r
- [ lpOutputBuffer>> ]\r
- [ dwReceiveDataLength>> ]\r
- [ dwLocalAddressLength>> ]\r
- [ dwRemoteAddressLength>> ]\r
- [ lpdwBytesReceived>> ]\r
- [ lpOverlapped>> ]\r
- } cleave AcceptEx drop winsock-error ; inline\r
-\r
-: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
- f void* <ref> 0 int <ref> f void* <ref>\r
- [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;\r
-\r
-: extract-remote-address ( AcceptEx -- sockaddr )\r
- [\r
- {\r
- [ lpOutputBuffer>> ]\r
- [ dwReceiveDataLength>> ]\r
- [ dwLocalAddressLength>> ]\r
- [ dwRemoteAddressLength>> ]\r
- } cleave\r
- (extract-remote-address)\r
- ] [ port>> addr>> protocol-family ] bi\r
- sockaddr-of-family ; inline\r
-\r
-M: object (accept) ( server addr -- handle sockaddr )\r
- [\r
- <AcceptEx-args>\r
- {\r
- [ call-AcceptEx ]\r
- [ wait-for-socket drop ]\r
- [ sAcceptSocket>> <win32-socket> ]\r
- [ extract-remote-address ]\r
- } cleave\r
- ] with-destructors ;\r
-\r
-TUPLE: WSARecvFrom-args port\r
- s lpBuffers dwBufferCount lpNumberOfBytesRecvd\r
- lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;\r
-\r
-:: make-receive-buffer ( n buf -- buf' WSABUF )\r
- buf >c-ptr pinned-alien?\r
- [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf'\r
- buf'\r
- WSABUF malloc-struct &free\r
- n >>len\r
- buf' >>buf ; inline\r
-\r
-:: <WSARecvFrom-args> ( n buf datagram -- buf buf' WSARecvFrom )\r
- n buf make-receive-buffer :> ( buf' wsaBuf )\r
- buf buf'\r
- WSARecvFrom-args new\r
- datagram >>port\r
- datagram handle>> handle>> >>s\r
- datagram addr>> sockaddr-size\r
- [ malloc &free >>lpFrom ]\r
- [ malloc-int &free >>lpFromLen ] bi\r
- wsaBuf >>lpBuffers\r
- 1 >>dwBufferCount\r
- 0 malloc-int &free >>lpFlags\r
- 0 malloc-int &free >>lpNumberOfBytesRecvd\r
- (make-overlapped) >>lpOverlapped ; inline\r
-\r
-: call-WSARecvFrom ( WSARecvFrom -- )\r
- {\r
- [ s>> ]\r
- [ lpBuffers>> ]\r
- [ dwBufferCount>> ]\r
- [ lpNumberOfBytesRecvd>> ]\r
- [ lpFlags>> ]\r
- [ lpFrom>> ]\r
- [ lpFromLen>> ]\r
- [ lpOverlapped>> ]\r
- [ lpCompletionRoutine>> ]\r
- } cleave WSARecvFrom socket-error* ; inline\r
-\r
-:: finalize-buf ( buf buf' count -- )\r
- buf buf' eq? [ buf buf' count memcpy ] unless ; inline\r
-\r
-:: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr )\r
- buf buf' count finalize-buf\r
- count wsaRecvFrom\r
- [ port>> addr>> empty-sockaddr dup ]\r
- [ lpFrom>> ]\r
- [ lpFromLen>> int deref ]\r
- tri memcpy ; inline\r
-\r
-M: windows (receive-unsafe) ( n buf datagram -- count addrspec )\r
- [\r
- <WSARecvFrom-args>\r
- [ call-WSARecvFrom ]\r
- [ wait-for-socket ]\r
- [ parse-WSARecvFrom ]\r
- tri\r
- ] with-destructors ;\r
-\r
-TUPLE: WSASendTo-args port\r
- s lpBuffers dwBufferCount lpNumberOfBytesSent\r
- dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;\r
-\r
-: make-send-buffer ( packet -- WSABUF )\r
- [ WSABUF malloc-struct &free ] dip\r
- [ malloc-byte-array &free >>buf ]\r
- [ length >>len ] bi ; inline\r
-\r
-: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )\r
- WSASendTo-args new\r
- swap >>port\r
- dup port>> handle>> handle>> >>s\r
- swap make-sockaddr/size\r
- [ malloc-byte-array &free ] dip\r
- [ >>lpTo ] [ >>iToLen ] bi*\r
- swap make-send-buffer >>lpBuffers\r
- 1 >>dwBufferCount\r
- 0 >>dwFlags\r
- 0 uint <ref> >>lpNumberOfBytesSent\r
- (make-overlapped) >>lpOverlapped ; inline\r
-\r
-: call-WSASendTo ( WSASendTo -- )\r
- {\r
- [ s>> ]\r
- [ lpBuffers>> ]\r
- [ dwBufferCount>> ]\r
- [ lpNumberOfBytesSent>> ]\r
- [ dwFlags>> ]\r
- [ lpTo>> ]\r
- [ iToLen>> ]\r
- [ lpOverlapped>> ]\r
- [ lpCompletionRoutine>> ]\r
- } cleave WSASendTo socket-error* ; inline\r
-\r
-M: windows (send) ( packet addrspec datagram -- )\r
- [\r
- <WSASendTo-args>\r
- [ call-WSASendTo ]\r
- [ wait-for-socket drop ]\r
- bi\r
- ] with-destructors ;\r
+! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.data classes.struct
+combinators destructors io.backend io.files.windows io.ports
+io.sockets io.sockets.icmp io.sockets.private kernel libc locals
+math sequences system windows.errors windows.handles
+windows.kernel32 windows.types windows.winsock ;
+FROM: namespaces => get ;
+IN: io.sockets.windows
+
+: set-socket-option ( handle level opt -- )
+ [ handle>> ] 2dip 1 int <ref> dup byte-length setsockopt socket-error ;
+
+: set-ioctl-socket ( handle cmd arg -- )
+ [ handle>> ] 2dip ulong <ref> ioctlsocket socket-error ;
+
+M: windows addrinfo-error-string ( n -- string )
+ n>win32-error-string ;
+
+M: windows sockaddr-of-family ( alien af -- addrspec )
+ {
+ { AF_INET [ sockaddr-in memory>struct ] }
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }
+ [ 2drop f ]
+ } case ;
+
+M: windows addrspec-of-family ( af -- addrspec )
+ {
+ { AF_INET [ T{ ipv4 } ] }
+ { AF_INET6 [ T{ ipv6 } ] }
+ [ drop f ]
+ } case ;
+
+HOOK: WSASocket-flags io-backend ( -- DWORD )
+
+TUPLE: win32-socket < win32-file ;
+
+: <win32-socket> ( handle -- win32-socket )
+ win32-socket new-win32-handle ;
+
+M: win32-socket dispose* ( stream -- )
+ handle>> closesocket socket-error* ;
+
+: unspecific-sockaddr/size ( addrspec -- sockaddr len )
+ [ empty-sockaddr/size ] [ protocol-family ] bi pick family<< ;
+
+: opened-socket ( handle -- win32-socket )
+ <win32-socket> |dispose add-completion ;
+
+: open-socket ( addrspec type -- win32-socket )
+ [ drop protocol-family ] [ swap protocol ] 2bi
+ f 0 WSASocket-flags WSASocket
+ dup socket-error
+ opened-socket ;
+
+M: object (get-local-address) ( socket addrspec -- sockaddr )
+ [ handle>> ] dip empty-sockaddr/size int <ref>
+ [ getsockname socket-error ] 2keep drop ;
+
+M: object (get-remote-address) ( socket addrspec -- sockaddr )
+ [ handle>> ] dip empty-sockaddr/size int <ref>
+ [ getpeername socket-error ] 2keep drop ;
+
+: bind-socket ( win32-socket sockaddr len -- )
+ [ handle>> ] 2dip bind socket-error ;
+
+M: object ((client)) ( addrspec -- handle )
+ [ SOCK_STREAM open-socket ] keep
+ [
+ bind-local-address get
+ [ nip make-sockaddr/size ]
+ [ unspecific-sockaddr/size ] if* bind-socket
+ ] [ drop ] 2bi ;
+
+: server-socket ( addrspec type -- fd )
+ [ open-socket ] [ drop ] 2bi
+ [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;
+
+! http://support.microsoft.com/kb/127144
+! NOTE: Possibly tweak this because of SYN flood attacks
+: listen-backlog ( -- n ) 0x7fffffff ; inline
+
+M: object (server) ( addrspec -- handle )
+ [
+ SOCK_STREAM server-socket
+ dup handle>> listen-backlog listen winsock-return-check
+ ] with-destructors ;
+
+M: windows (datagram) ( addrspec -- handle )
+ [ SOCK_DGRAM server-socket ] with-destructors ;
+
+M: windows (raw) ( addrspec -- handle )
+ [ SOCK_RAW server-socket ] with-destructors ;
+
+M: windows (broadcast) ( datagram -- datagram )
+ dup handle>> SOL_SOCKET SO_BROADCAST set-socket-option ;
+
+: malloc-int ( n -- alien )
+ int <ref> malloc-byte-array ; inline
+
+M: windows WSASocket-flags ( -- DWORD )
+ WSA_FLAG_OVERLAPPED ; inline
+
+: get-ConnectEx-ptr ( socket -- void* )
+ SIO_GET_EXTENSION_FUNCTION_POINTER
+ WSAID_CONNECTEX
+ GUID heap-size
+ { void* }
+ [
+ void* heap-size
+ 0 DWORD <ref>
+ f
+ f
+ WSAIoctl SOCKET_ERROR = [
+ maybe-winsock-exception throw
+ ] when
+ ] with-out-parameters ;
+
+TUPLE: ConnectEx-args port
+ s name namelen lpSendBuffer dwSendDataLength
+ lpdwBytesSent lpOverlapped ptr ;
+
+: wait-for-socket ( args -- count )
+ [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
+
+: <ConnectEx-args> ( sockaddr size -- ConnectEx )
+ ConnectEx-args new
+ swap >>namelen
+ swap >>name
+ f >>lpSendBuffer
+ 0 >>dwSendDataLength
+ f >>lpdwBytesSent
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-ConnectEx ( ConnectEx -- )
+ {
+ [ s>> ]
+ [ name>> ]
+ [ namelen>> ]
+ [ lpSendBuffer>> ]
+ [ dwSendDataLength>> ]
+ [ lpdwBytesSent>> ]
+ [ lpOverlapped>> ]
+ [ ptr>> ]
+ } cleave
+ int
+ { SOCKET void* int PVOID DWORD LPDWORD void* }
+ stdcall alien-indirect drop
+ winsock-error ; inline
+
+M: object establish-connection ( client-out remote -- )
+ make-sockaddr/size <ConnectEx-args>
+ swap >>port
+ dup port>> handle>> handle>> >>s
+ dup s>> get-ConnectEx-ptr >>ptr
+ dup call-ConnectEx
+ wait-for-socket drop ;
+
+TUPLE: AcceptEx-args port
+ sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
+ dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
+
+: init-accept-buffer ( addr AcceptEx -- )
+ swap sockaddr-size 16 +
+ [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
+ dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
+ drop ; inline
+
+: <AcceptEx-args> ( server addr -- AcceptEx )
+ AcceptEx-args new
+ 2dup init-accept-buffer
+ swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
+ over handle>> handle>> >>sListenSocket
+ swap >>port
+ 0 >>dwReceiveDataLength
+ f >>lpdwBytesReceived
+ (make-overlapped) >>lpOverlapped ; inline
+
+! AcceptEx return value is useless
+: call-AcceptEx ( AcceptEx -- )
+ {
+ [ sListenSocket>> ]
+ [ sAcceptSocket>> ]
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ [ lpdwBytesReceived>> ]
+ [ lpOverlapped>> ]
+ } cleave AcceptEx drop winsock-error ; inline
+
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
+ f void* <ref> 0 int <ref> f void* <ref>
+ [ 0 int <ref> GetAcceptExSockaddrs ] keep void* deref ;
+
+: extract-remote-address ( AcceptEx -- sockaddr )
+ [
+ {
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ } cleave
+ (extract-remote-address)
+ ] [ port>> addr>> protocol-family ] bi
+ sockaddr-of-family ; inline
+
+M: object (accept) ( server addr -- handle sockaddr )
+ [
+ <AcceptEx-args>
+ {
+ [ call-AcceptEx ]
+ [ wait-for-socket drop ]
+ [ sAcceptSocket>> <win32-socket> ]
+ [ extract-remote-address ]
+ } cleave
+ ] with-destructors ;
+
+TUPLE: WSARecvFrom-args port
+ s lpBuffers dwBufferCount lpNumberOfBytesRecvd
+ lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
+
+:: make-receive-buffer ( n buf -- buf' WSABUF )
+ buf >c-ptr pinned-alien?
+ [ buf ] [ n malloc &free [ buf n memcpy ] keep ] if :> buf'
+ buf'
+ WSABUF malloc-struct &free
+ n >>len
+ buf' >>buf ; inline
+
+:: <WSARecvFrom-args> ( n buf datagram -- buf buf' WSARecvFrom )
+ n buf make-receive-buffer :> ( buf' wsaBuf )
+ buf buf'
+ WSARecvFrom-args new
+ datagram >>port
+ datagram handle>> handle>> >>s
+ datagram addr>> sockaddr-size
+ [ malloc &free >>lpFrom ]
+ [ malloc-int &free >>lpFromLen ] bi
+ wsaBuf >>lpBuffers
+ 1 >>dwBufferCount
+ 0 malloc-int &free >>lpFlags
+ 0 malloc-int &free >>lpNumberOfBytesRecvd
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-WSARecvFrom ( WSARecvFrom -- )
+ {
+ [ s>> ]
+ [ lpBuffers>> ]
+ [ dwBufferCount>> ]
+ [ lpNumberOfBytesRecvd>> ]
+ [ lpFlags>> ]
+ [ lpFrom>> ]
+ [ lpFromLen>> ]
+ [ lpOverlapped>> ]
+ [ lpCompletionRoutine>> ]
+ } cleave WSARecvFrom socket-error* ; inline
+
+:: finalize-buf ( buf buf' count -- )
+ buf buf' eq? [ buf buf' count memcpy ] unless ; inline
+
+:: parse-WSARecvFrom ( buf buf' count wsaRecvFrom -- count sockaddr )
+ buf buf' count finalize-buf
+ count wsaRecvFrom
+ [ port>> addr>> empty-sockaddr dup ]
+ [ lpFrom>> ]
+ [ lpFromLen>> int deref ]
+ tri memcpy ; inline
+
+M: windows (receive-unsafe) ( n buf datagram -- count addrspec )
+ [
+ <WSARecvFrom-args>
+ [ call-WSARecvFrom ]
+ [ wait-for-socket ]
+ [ parse-WSARecvFrom ]
+ tri
+ ] with-destructors ;
+
+TUPLE: WSASendTo-args port
+ s lpBuffers dwBufferCount lpNumberOfBytesSent
+ dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
+
+: make-send-buffer ( packet -- WSABUF )
+ [ WSABUF malloc-struct &free ] dip
+ [ malloc-byte-array &free >>buf ]
+ [ length >>len ] bi ; inline
+
+: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
+ WSASendTo-args new
+ swap >>port
+ dup port>> handle>> handle>> >>s
+ swap make-sockaddr/size
+ [ malloc-byte-array &free ] dip
+ [ >>lpTo ] [ >>iToLen ] bi*
+ swap make-send-buffer >>lpBuffers
+ 1 >>dwBufferCount
+ 0 >>dwFlags
+ 0 uint <ref> >>lpNumberOfBytesSent
+ (make-overlapped) >>lpOverlapped ; inline
+
+: call-WSASendTo ( WSASendTo -- )
+ {
+ [ s>> ]
+ [ lpBuffers>> ]
+ [ dwBufferCount>> ]
+ [ lpNumberOfBytesSent>> ]
+ [ dwFlags>> ]
+ [ lpTo>> ]
+ [ iToLen>> ]
+ [ lpOverlapped>> ]
+ [ lpCompletionRoutine>> ]
+ } cleave WSASendTo socket-error* ; inline
+
+M: windows (send) ( packet addrspec datagram -- )
+ [
+ <WSASendTo-args>
+ [ call-WSASendTo ]
+ [ wait-for-socket drop ]
+ bi
+ ] with-destructors ;
{ [ os macosx? ] [ "io.standard-paths.macosx" ] }
{ [ os unix? ] [ "io.standard-paths.unix" ] }
} cond require
-
M: windows find-in-path*
[ "PATH" os-env ";" split ] dip
'[ _ append-path exists? ] find nip ;
-
PRIVATE>
M: limited-stream stream-read1
- 1 swap
+ 1 swap
[ nip stream-read1 ] maybe-read ;
M: limited-stream stream-read-unsafe
-IN: io.timeouts\r
-USING: help.markup help.syntax math kernel calendar ;\r
-\r
-HELP: timeout\r
-{ $values { "obj" object } { "dt/f" { $maybe duration } } }\r
-{ $contract "Outputs an object's timeout." } ;\r
-\r
-HELP: set-timeout\r
-{ $values { "dt/f" { $maybe duration } } { "obj" object } }\r
-{ $contract "Sets an object's timeout." }\r
-{ $examples "Waits five seconds for a process that sleeps for ten seconds:"\r
- { $unchecked-example\r
- "USING: calendar io.launcher io.timeouts kernel ;"\r
- "\"sleep 10\" >process 5 seconds over set-timeout run-process"\r
- "Process was killed as a result of a call to"\r
- "kill-process, or a timeout"\r
- }\r
-} ;\r
-\r
-HELP: cancel-operation\r
-{ $values { "obj" object } }\r
-{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;\r
-\r
-HELP: with-timeout\r
-{ $values { "obj" object } { "quot" { $quotation ( obj -- ) } } }\r
-{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ;\r
-\r
-ARTICLE: "io.timeouts" "I/O timeout protocol"\r
-"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."\r
-{ $subsections\r
- timeout\r
- set-timeout\r
-}\r
-"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."\r
-{ $subsections cancel-operation }\r
-"A combinator to be used in operations which can time out:"\r
-{ $subsections with-timeout }\r
-{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;\r
-\r
-ABOUT: "io.timeouts"\r
+IN: io.timeouts
+USING: help.markup help.syntax math kernel calendar ;
+
+HELP: timeout
+{ $values { "obj" object } { "dt/f" { $maybe duration } } }
+{ $contract "Outputs an object's timeout." } ;
+
+HELP: set-timeout
+{ $values { "dt/f" { $maybe duration } } { "obj" object } }
+{ $contract "Sets an object's timeout." }
+{ $examples "Waits five seconds for a process that sleeps for ten seconds:"
+ { $unchecked-example
+ "USING: calendar io.launcher io.timeouts kernel ;"
+ "\"sleep 10\" >process 5 seconds over set-timeout run-process"
+ "Process was killed as a result of a call to"
+ "kill-process, or a timeout"
+ }
+} ;
+
+HELP: cancel-operation
+{ $values { "obj" object } }
+{ $contract "Handles a timeout, usually by waking up all threads waiting on the object." } ;
+
+HELP: with-timeout
+{ $values { "obj" object } { "quot" { $quotation ( obj -- ) } } }
+{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link cancel-operation } " is called on the object." } ;
+
+ARTICLE: "io.timeouts" "I/O timeout protocol"
+"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
+{ $subsections
+ timeout
+ set-timeout
+}
+"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
+{ $subsections cancel-operation }
+"A combinator to be used in operations which can time out:"
+{ $subsections with-timeout }
+{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;
+
+ABOUT: "io.timeouts"
-! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors fry io io.encodings io.streams.null kernel\r
-namespaces timers ;\r
-IN: io.timeouts\r
-\r
-GENERIC: timeout ( obj -- dt/f )\r
-GENERIC: set-timeout ( dt/f obj -- )\r
-\r
-M: decoder set-timeout stream>> set-timeout ;\r
-\r
-M: encoder set-timeout stream>> set-timeout ;\r
-\r
-GENERIC: cancel-operation ( obj -- )\r
-\r
-: queue-timeout ( obj timeout -- timer )\r
- [ '[ _ cancel-operation ] ] dip later ;\r
-\r
-: with-timeout* ( obj timeout quot -- )\r
- 2over queue-timeout [ nip call ] dip stop-timer ;\r
- inline\r
-\r
-: with-timeout ( obj quot -- )\r
- over timeout [ [ dup timeout ] dip with-timeout* ] [ call ] if ;\r
- inline\r
-\r
-: timeouts ( dt -- )\r
- [ input-stream get set-timeout ]\r
- [ output-stream get set-timeout ] bi ;\r
-\r
-M: null-stream set-timeout 2drop ;\r
+! Copyright (C) 2008 Slava Pestov, Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry io io.encodings io.streams.null kernel
+namespaces timers ;
+IN: io.timeouts
+
+GENERIC: timeout ( obj -- dt/f )
+GENERIC: set-timeout ( dt/f obj -- )
+
+M: decoder set-timeout stream>> set-timeout ;
+
+M: encoder set-timeout stream>> set-timeout ;
+
+GENERIC: cancel-operation ( obj -- )
+
+: queue-timeout ( obj timeout -- timer )
+ [ '[ _ cancel-operation ] ] dip later ;
+
+: with-timeout* ( obj timeout quot -- )
+ 2over queue-timeout [ nip call ] dip stop-timer ;
+ inline
+
+: with-timeout ( obj quot -- )
+ over timeout [ [ dup timeout ] dip with-timeout* ] [ call ] if ;
+ inline
+
+: timeouts ( dt -- )
+ [ input-stream get set-timeout ]
+ [ output-stream get set-timeout ] bi ;
+
+M: null-stream set-timeout 2drop ;
CONSTANT: kIOKitBuildVersionKey "IOKitBuildVersion"
CONSTANT: kIOKitDiagnosticsKey "IOKitDiagnostics"
-
+
CONSTANT: kIORegistryPlanesKey "IORegistryPlanes"
CONSTANT: kIOCatalogueKey "IOCatalogue"
CONSTANT: kIOBusBadgeKey "IOBusBadge"
CONSTANT: kIODeviceIconKey "IODeviceIcon"
-CONSTANT: kIOPlatformSerialNumberKey "IOPlatformSerialNumber"
+CONSTANT: kIOPlatformSerialNumberKey "IOPlatformSerialNumber"
-CONSTANT: kIOPlatformUUIDKey "IOPlatformUUID"
+CONSTANT: kIOPlatformUUIDKey "IOPlatformUUID"
CONSTANT: kIONVRAMDeletePropertyKey "IONVRAM-DELETE-PROPERTY"
CONSTANT: kIODTNVRAMPanicInfoKey "aapl,panic-info"
-CONSTANT: kIOBootDeviceKey "IOBootDevice"
-CONSTANT: kIOBootDevicePathKey "IOBootDevicePath"
-CONSTANT: kIOBootDeviceSizeKey "IOBootDeviceSize"
+CONSTANT: kIOBootDeviceKey "IOBootDevice"
+CONSTANT: kIOBootDevicePathKey "IOBootDevicePath"
+CONSTANT: kIOBootDeviceSizeKey "IOBootDeviceSize"
CONSTANT: kOSBuildVersionKey "OS Build Version"
: io-objects-from-iterator ( i -- array )
io-objects-from-iterator* [ release-io-object ] dip ;
-
+
: properties-from-io-object ( o -- o nsdictionary )
dup f void* <ref> [
kCFAllocatorDefault kNilOptions
IORegistryEntryCreateCFProperties mach-error
]
keep void* deref ;
-
-USING: help.syntax help.markup sequences ;\r
-IN: lcs\r
-\r
-HELP: levenshtein\r
-{ $values { "old" sequence } { "new" sequence } { "n" "the Levenshtein distance" } }\r
-{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;\r
-\r
-HELP: lcs\r
-{ $values { "seq1" sequence } { "seq2" sequence } { "lcs" "a longest common subsequence" } }\r
-{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ;\r
-\r
-HELP: lcs-diff\r
-{ $values { "old" sequence } { "new" sequence } { "diff" "an edit script" } }\r
-{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ;\r
-\r
-HELP: retain\r
-{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ;\r
-\r
-HELP: delete\r
-{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ;\r
-\r
-HELP: insert\r
-{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ;\r
-\r
-ARTICLE: "lcs" "LCS, diffing and distance"\r
-"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences."\r
-{ $subsections\r
- lcs\r
- lcs-diff\r
- levenshtein\r
-}\r
-"The " { $link lcs-diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot."\r
-{ $subsections\r
- insert\r
- delete\r
- retain\r
-} ;\r
-\r
-ABOUT: "lcs"\r
+USING: help.syntax help.markup sequences ;
+IN: lcs
+
+HELP: levenshtein
+{ $values { "old" sequence } { "new" sequence } { "n" "the Levenshtein distance" } }
+{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;
+
+HELP: lcs
+{ $values { "seq1" sequence } { "seq2" sequence } { "lcs" "a longest common subsequence" } }
+{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ;
+
+HELP: lcs-diff
+{ $values { "old" sequence } { "new" sequence } { "diff" "an edit script" } }
+{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ;
+
+HELP: retain
+{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ;
+
+HELP: delete
+{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ;
+
+HELP: insert
+{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ;
+
+ARTICLE: "lcs" "LCS, diffing and distance"
+"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences."
+{ $subsections
+ lcs
+ lcs-diff
+ levenshtein
+}
+"The " { $link lcs-diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot."
+{ $subsections
+ insert
+ delete
+ retain
+} ;
+
+ABOUT: "lcs"
-USING: accessors arrays combinators combinators.short-circuit\r
-kernel locals make math math.order sequences sequences.private\r
-typed ;\r
-IN: lcs\r
-\r
-<PRIVATE\r
-\r
-: levenshtein-step ( insert delete change same? -- next )\r
- [ [ 1 + ] bi@ ] 2dip [ 1 + ] unless min min ;\r
-\r
-: lcs-step ( insert delete change same? -- next )\r
- 1 -1/0. ? + max max ; ! -1/0. is -inf (float)\r
-\r
-TYPED:: loop-step ( i j matrix: array old new step -- )\r
- i j 1 + matrix nth-unsafe nth-unsafe ! insertion\r
- i 1 + j matrix nth-unsafe nth-unsafe ! deletion\r
- i j matrix nth-unsafe nth-unsafe ! replace/retain\r
- i old nth-unsafe j new nth-unsafe = ! same?\r
- step call\r
- i 1 + j 1 + matrix nth-unsafe set-nth-unsafe ; inline\r
-\r
-: lcs-initialize ( |str1| |str2| -- matrix )\r
- iota [ drop 0 <array> ] with map ;\r
-\r
-: levenshtein-initialize ( |str1| |str2| -- matrix )\r
- [ iota ] bi@ [ [ + ] curry map ] with map ;\r
-\r
-:: run-lcs ( old new init step -- matrix )\r
- old length 1 + new length 1 + init call :> matrix\r
- old length iota [| i |\r
- new length iota [| j |\r
- i j matrix old new step loop-step\r
- ] each\r
- ] each matrix ; inline\r
-\r
-PRIVATE>\r
-\r
-: levenshtein ( old new -- n )\r
- [ levenshtein-initialize ] [ levenshtein-step ]\r
- run-lcs last last ;\r
-\r
-TUPLE: retain item ;\r
-TUPLE: delete item ;\r
-TUPLE: insert item ;\r
-\r
-<PRIVATE\r
-\r
-TUPLE: trace-state old new table i j ;\r
-\r
-: old-nth ( state -- elt )\r
- [ i>> 1 - ] [ old>> ] bi nth-unsafe ;\r
-\r
-: new-nth ( state -- elt )\r
- [ j>> 1 - ] [ new>> ] bi nth-unsafe ;\r
-\r
-: top-beats-side? ( state -- ? )\r
- [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth-unsafe nth-unsafe ]\r
- [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth-unsafe nth-unsafe ] bi > ;\r
-\r
-: retained? ( state -- ? )\r
- {\r
- [ i>> 0 > ] [ j>> 0 > ]\r
- [ [ old-nth ] [ new-nth ] bi = ]\r
- } 1&& ;\r
-\r
-: do-retain ( state -- state )\r
- dup old-nth retain boa ,\r
- [ 1 - ] change-i [ 1 - ] change-j ;\r
-\r
-: inserted? ( state -- ? )\r
- {\r
- [ j>> 0 > ]\r
- [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]\r
- } 1&& ;\r
-\r
-: do-insert ( state -- state )\r
- dup new-nth insert boa , [ 1 - ] change-j ;\r
-\r
-: deleted? ( state -- ? )\r
- {\r
- [ i>> 0 > ]\r
- [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]\r
- } 1&& ;\r
-\r
-: do-delete ( state -- state )\r
- dup old-nth delete boa , [ 1 - ] change-i ;\r
-\r
-: (trace-diff) ( state -- )\r
- {\r
- { [ dup retained? ] [ do-retain (trace-diff) ] }\r
- { [ dup inserted? ] [ do-insert (trace-diff) ] }\r
- { [ dup deleted? ] [ do-delete (trace-diff) ] }\r
- [ drop ] ! i=j=0\r
- } cond ;\r
-\r
-: trace-diff ( old new table -- diff )\r
- [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa\r
- [ (trace-diff) ] { } make reverse! ;\r
-\r
-PRIVATE>\r
-\r
-: lcs-diff ( old new -- diff )\r
- 2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;\r
-\r
-: lcs ( seq1 seq2 -- lcs )\r
- [ lcs-diff [ retain? ] filter ] keep [ item>> ] swap map-as ;\r
+USING: accessors arrays combinators combinators.short-circuit
+kernel locals make math math.order sequences sequences.private
+typed ;
+IN: lcs
+
+<PRIVATE
+
+: levenshtein-step ( insert delete change same? -- next )
+ [ [ 1 + ] bi@ ] 2dip [ 1 + ] unless min min ;
+
+: lcs-step ( insert delete change same? -- next )
+ 1 -1/0. ? + max max ; ! -1/0. is -inf (float)
+
+TYPED:: loop-step ( i j matrix: array old new step -- )
+ i j 1 + matrix nth-unsafe nth-unsafe ! insertion
+ i 1 + j matrix nth-unsafe nth-unsafe ! deletion
+ i j matrix nth-unsafe nth-unsafe ! replace/retain
+ i old nth-unsafe j new nth-unsafe = ! same?
+ step call
+ i 1 + j 1 + matrix nth-unsafe set-nth-unsafe ; inline
+
+: lcs-initialize ( |str1| |str2| -- matrix )
+ iota [ drop 0 <array> ] with map ;
+
+: levenshtein-initialize ( |str1| |str2| -- matrix )
+ [ iota ] bi@ [ [ + ] curry map ] with map ;
+
+:: run-lcs ( old new init step -- matrix )
+ old length 1 + new length 1 + init call :> matrix
+ old length iota [| i |
+ new length iota [| j |
+ i j matrix old new step loop-step
+ ] each
+ ] each matrix ; inline
+
+PRIVATE>
+
+: levenshtein ( old new -- n )
+ [ levenshtein-initialize ] [ levenshtein-step ]
+ run-lcs last last ;
+
+TUPLE: retain item ;
+TUPLE: delete item ;
+TUPLE: insert item ;
+
+<PRIVATE
+
+TUPLE: trace-state old new table i j ;
+
+: old-nth ( state -- elt )
+ [ i>> 1 - ] [ old>> ] bi nth-unsafe ;
+
+: new-nth ( state -- elt )
+ [ j>> 1 - ] [ new>> ] bi nth-unsafe ;
+
+: top-beats-side? ( state -- ? )
+ [ [ i>> ] [ j>> 1 - ] [ table>> ] tri nth-unsafe nth-unsafe ]
+ [ [ i>> 1 - ] [ j>> ] [ table>> ] tri nth-unsafe nth-unsafe ] bi > ;
+
+: retained? ( state -- ? )
+ {
+ [ i>> 0 > ] [ j>> 0 > ]
+ [ [ old-nth ] [ new-nth ] bi = ]
+ } 1&& ;
+
+: do-retain ( state -- state )
+ dup old-nth retain boa ,
+ [ 1 - ] change-i [ 1 - ] change-j ;
+
+: inserted? ( state -- ? )
+ {
+ [ j>> 0 > ]
+ [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
+ } 1&& ;
+
+: do-insert ( state -- state )
+ dup new-nth insert boa , [ 1 - ] change-j ;
+
+: deleted? ( state -- ? )
+ {
+ [ i>> 0 > ]
+ [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]
+ } 1&& ;
+
+: do-delete ( state -- state )
+ dup old-nth delete boa , [ 1 - ] change-i ;
+
+: (trace-diff) ( state -- )
+ {
+ { [ dup retained? ] [ do-retain (trace-diff) ] }
+ { [ dup inserted? ] [ do-insert (trace-diff) ] }
+ { [ dup deleted? ] [ do-delete (trace-diff) ] }
+ [ drop ] ! i=j=0
+ } cond ;
+
+: trace-diff ( old new table -- diff )
+ [ ] [ first length 1 - ] [ length 1 - ] tri trace-state boa
+ [ (trace-diff) ] { } make reverse! ;
+
+PRIVATE>
+
+: lcs-diff ( old new -- diff )
+ 2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
+
+: lcs ( seq1 seq2 -- lcs )
+ [ lcs-diff [ retain? ] filter ] keep [ item>> ] swap map-as ;
GENERIC# prompt. 1 ( stream prompt -- )
: prompt ( -- str )
- manifest get current-vocab>> [ name>> "IN: " prepend ] [ "" ] if*
+ manifest get current-vocab>> [ name>> "IN: " prepend ] [ "" ] if*
auto-use? get [ " auto-use" append ] when ;
M: object prompt.
-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel sequences namespaces words assocs logging sorting\r
-prettyprint io io.styles io.files io.encodings.utf8\r
-strings combinators accessors arrays math\r
-logging.server logging.parser calendar.format ;\r
-IN: logging.analysis\r
-\r
-SYMBOL: word-names\r
-SYMBOL: errors\r
-SYMBOL: word-histogram\r
-SYMBOL: message-histogram\r
-\r
-: analyze-entry ( entry -- )\r
- dup level>> { ERROR CRITICAL } member-eq? [ dup errors get push ] when\r
- dup word-name>> word-histogram get inc-at\r
- dup word-name>> word-names get member? [\r
- dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array\r
- message-histogram get inc-at\r
- ] when\r
- drop ;\r
-\r
-: recent-histogram ( assoc n -- alist )\r
- [ sort-values <reversed> ] dip short head ;\r
-\r
-: analyze-entries ( entries word-names -- errors word-histogram message-histogram )\r
- [\r
- word-names set\r
- V{ } clone errors set\r
- H{ } clone word-histogram set\r
- H{ } clone message-histogram set\r
-\r
- [ analyze-entry ] each\r
-\r
- errors get\r
- word-histogram get 10 recent-histogram\r
- message-histogram get 10 recent-histogram\r
- ] with-scope ;\r
-\r
-: histogram. ( assoc quot -- )\r
- standard-table-style [\r
- [\r
- [ swapd with-cell pprint-cell ] with-row\r
- ] curry assoc-each\r
- ] tabular-output ; inline\r
-\r
-: 10-most-recent ( errors -- errors )\r
- 10 tail* "Only showing 10 most recent errors" print nl ;\r
-\r
-: errors. ( errors -- )\r
- dup length 10 >= [ 10-most-recent ] when\r
- log-entries. ;\r
-\r
-: analysis. ( errors word-histogram message-histogram -- )\r
- nl "==== FREQUENT MESSAGES:" print nl\r
- "Total: " write dup values sum . nl\r
- [\r
- [ first name>> write bl ]\r
- [ second write ": " write ]\r
- [ third "\n" join write ]\r
- tri\r
- ] histogram.\r
- nl nl\r
- "==== FREQUENT WORDS:" print nl\r
- [ write ] histogram.\r
- nl nl\r
- "==== ERRORS:" print nl\r
- errors. ;\r
-\r
-: analyze-log ( lines word-names -- )\r
- [ parse-log ] dip analyze-entries analysis. ;\r
-\r
-: analyze-log-file ( service word-names -- )\r
- [ parse-log-file ] dip analyze-entries analysis. ;\r
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences namespaces words assocs logging sorting
+prettyprint io io.styles io.files io.encodings.utf8
+strings combinators accessors arrays math
+logging.server logging.parser calendar.format ;
+IN: logging.analysis
+
+SYMBOL: word-names
+SYMBOL: errors
+SYMBOL: word-histogram
+SYMBOL: message-histogram
+
+: analyze-entry ( entry -- )
+ dup level>> { ERROR CRITICAL } member-eq? [ dup errors get push ] when
+ dup word-name>> word-histogram get inc-at
+ dup word-name>> word-names get member? [
+ dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array
+ message-histogram get inc-at
+ ] when
+ drop ;
+
+: recent-histogram ( assoc n -- alist )
+ [ sort-values <reversed> ] dip short head ;
+
+: analyze-entries ( entries word-names -- errors word-histogram message-histogram )
+ [
+ word-names set
+ V{ } clone errors set
+ H{ } clone word-histogram set
+ H{ } clone message-histogram set
+
+ [ analyze-entry ] each
+
+ errors get
+ word-histogram get 10 recent-histogram
+ message-histogram get 10 recent-histogram
+ ] with-scope ;
+
+: histogram. ( assoc quot -- )
+ standard-table-style [
+ [
+ [ swapd with-cell pprint-cell ] with-row
+ ] curry assoc-each
+ ] tabular-output ; inline
+
+: 10-most-recent ( errors -- errors )
+ 10 tail* "Only showing 10 most recent errors" print nl ;
+
+: errors. ( errors -- )
+ dup length 10 >= [ 10-most-recent ] when
+ log-entries. ;
+
+: analysis. ( errors word-histogram message-histogram -- )
+ nl "==== FREQUENT MESSAGES:" print nl
+ "Total: " write dup values sum . nl
+ [
+ [ first name>> write bl ]
+ [ second write ": " write ]
+ [ third "\n" join write ]
+ tri
+ ] histogram.
+ nl nl
+ "==== FREQUENT WORDS:" print nl
+ [ write ] histogram.
+ nl nl
+ "==== ERRORS:" print nl
+ errors. ;
+
+: analyze-log ( lines word-names -- )
+ [ parse-log ] dip analyze-entries analysis. ;
+
+: analyze-log-file ( service word-names -- )
+ [ parse-log-file ] dip analyze-entries analysis. ;
-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: logging.analysis logging.server logging smtp kernel\r
-io.files io.streams.string namespaces make timers assocs\r
-io.encodings.utf8 accessors calendar sequences locals ;\r
-QUALIFIED: io.sockets\r
-IN: logging.insomniac\r
-\r
-SYMBOL: insomniac-sender\r
-SYMBOL: insomniac-recipients\r
-\r
-: email-subject ( service -- string )\r
- [\r
- "Log analysis for " % % " on " % io.sockets:host-name %\r
- ] "" make ;\r
-\r
-:: (email-log-report) ( service word-names -- )\r
- <email>\r
- [ service word-names analyze-log-file ] with-string-writer >>body\r
- insomniac-recipients get >>to\r
- insomniac-sender get >>from\r
- service email-subject >>subject\r
- send-email ;\r
-\r
-\ (email-log-report) NOTICE add-error-logging\r
-\r
-: email-log-report ( service word-names -- )\r
- "logging.insomniac" [ (email-log-report) ] with-logging ;\r
-\r
-: schedule-insomniac ( service word-names -- )\r
- [ email-log-report rotate-logs ] 2curry\r
- 1 days every drop ;\r
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: logging.analysis logging.server logging smtp kernel
+io.files io.streams.string namespaces make timers assocs
+io.encodings.utf8 accessors calendar sequences locals ;
+QUALIFIED: io.sockets
+IN: logging.insomniac
+
+SYMBOL: insomniac-sender
+SYMBOL: insomniac-recipients
+
+: email-subject ( service -- string )
+ [
+ "Log analysis for " % % " on " % io.sockets:host-name %
+ ] "" make ;
+
+:: (email-log-report) ( service word-names -- )
+ <email>
+ [ service word-names analyze-log-file ] with-string-writer >>body
+ insomniac-recipients get >>to
+ insomniac-sender get >>from
+ service email-subject >>subject
+ send-email ;
+
+\ (email-log-report) NOTICE add-error-logging
+
+: email-log-report ( service word-names -- )
+ "logging.insomniac" [ (email-log-report) ] with-logging ;
+
+: schedule-insomniac ( service word-names -- )
+ [ email-log-report rotate-logs ] 2curry
+ 1 days every drop ;
-! Copyright (C) 2003, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: logging.server sequences namespaces concurrency.messaging\r
-words kernel arrays shuffle tools.annotations\r
-prettyprint.config prettyprint debugger io.streams.string\r
-splitting continuations effects generalizations parser strings\r
-quotations fry accessors math assocs math.order\r
-sequences.generalizations ;\r
-IN: logging\r
-\r
-SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;\r
-\r
-SYMBOL: log-level\r
-\r
-log-level [ DEBUG ] initialize\r
-\r
-: log-levels ( -- assoc )\r
- H{\r
- { DEBUG 0 }\r
- { NOTICE 10 }\r
- { WARNING 20 }\r
- { ERROR 30 }\r
- { CRITICAL 40 }\r
- } ; inline\r
-\r
-ERROR: undefined-log-level ;\r
-\r
-: log-level<=> ( log-level log-level -- <=> )\r
- [ log-levels at* [ undefined-log-level ] unless ] compare ;\r
-\r
-: log? ( log-level -- ? )\r
- log-level get log-level<=> +lt+ = not ;\r
-\r
-: send-to-log-server ( array string -- )\r
- prefix "log-server" get send ;\r
-\r
-SYMBOL: log-service\r
-\r
-ERROR: bad-log-message-parameters msg word level ;\r
-\r
-: check-log-message ( msg word level -- msg word level )\r
- 3dup [ string? ] [ word? ] [ word? ] tri* and and\r
- [ bad-log-message-parameters ] unless ; inline\r
-\r
-: log-message ( msg word level -- )\r
- check-log-message\r
- log-service get\r
- 2dup [ log? ] [ ] bi* and [\r
- [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip\r
- 4array "log-message" send-to-log-server\r
- ] [\r
- 4drop\r
- ] if ;\r
-\r
-: rotate-logs ( -- )\r
- { } "rotate-logs" send-to-log-server ;\r
-\r
-: close-logs ( -- )\r
- { } "close-logs" send-to-log-server ;\r
-\r
-: with-logging ( service quot -- )\r
- [ log-service ] dip with-variable ; inline\r
-\r
-! Aspect-oriented programming idioms\r
-\r
-<PRIVATE\r
-\r
-: stack>message ( obj -- inputs>message )\r
- dup array? [ dup length 1 = [ first ] when ] when\r
- dup string? [\r
- [\r
- boa-tuples? on\r
- string-limit? off\r
- 1 line-limit set\r
- 3 nesting-limit set\r
- 0 margin set\r
- unparse\r
- ] with-scope\r
- ] unless ;\r
-\r
-PRIVATE>\r
-\r
-: (define-logging) ( word level quot -- )\r
- [ dup ] 2dip 2curry annotate ; inline\r
-\r
-: call-logging-quot ( quot word level -- quot' )\r
- [ "called" ] 2dip [ log-message ] 3curry prepose ;\r
-\r
-: add-logging ( word level -- )\r
- [ call-logging-quot ] (define-logging) ;\r
-\r
-: log-stack ( n word level -- )\r
- log-service get [\r
- [ [ ndup ] keep narray stack>message ] 2dip log-message\r
- ] [\r
- 3drop\r
- ] if ; inline\r
-\r
-: input# ( word -- n ) stack-effect in>> length ;\r
-\r
-: input-logging-quot ( quot word level -- quot' )\r
- rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ;\r
-\r
-: add-input-logging ( word level -- )\r
- [ input-logging-quot ] (define-logging) ;\r
-\r
-: output# ( word -- n ) stack-effect out>> length ;\r
-\r
-: output-logging-quot ( quot word level -- quot' )\r
- [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ;\r
-\r
-: add-output-logging ( word level -- )\r
- [ output-logging-quot ] (define-logging) ;\r
-\r
-: (log-error) ( object word level -- )\r
- log-service get [\r
- [ [ print-error ] with-string-writer ] 2dip log-message\r
- ] [\r
- 2drop rethrow\r
- ] if ;\r
-\r
-: log-error ( error word -- ) ERROR (log-error) ;\r
-\r
-: log-critical ( error word -- ) CRITICAL (log-error) ;\r
-\r
-: stack-balancer ( effect -- quot )\r
- [ in>> length [ ndrop ] curry ]\r
- [ out>> length f <repetition> >quotation ]\r
- bi append ;\r
-\r
-: error-logging-quot ( quot word -- quot' )\r
- dup stack-effect stack-balancer\r
- '[ _ [ _ log-error @ ] recover ] ;\r
-\r
-: add-error-logging ( word level -- )\r
- [ [ input-logging-quot ] 2keep drop error-logging-quot ]\r
- (define-logging) ;\r
-\r
-SYNTAX: LOG:\r
- #! Syntax: name level\r
- scan-new-word dup scan-word\r
- '[ 1array stack>message _ _ log-message ]\r
- ( message -- ) define-declared ;\r
-\r
-USE: vocabs\r
-\r
-"logging.parser" require\r
-"logging.analysis" require\r
+! Copyright (C) 2003, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: logging.server sequences namespaces concurrency.messaging
+words kernel arrays shuffle tools.annotations
+prettyprint.config prettyprint debugger io.streams.string
+splitting continuations effects generalizations parser strings
+quotations fry accessors math assocs math.order
+sequences.generalizations ;
+IN: logging
+
+SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;
+
+SYMBOL: log-level
+
+log-level [ DEBUG ] initialize
+
+: log-levels ( -- assoc )
+ H{
+ { DEBUG 0 }
+ { NOTICE 10 }
+ { WARNING 20 }
+ { ERROR 30 }
+ { CRITICAL 40 }
+ } ; inline
+
+ERROR: undefined-log-level ;
+
+: log-level<=> ( log-level log-level -- <=> )
+ [ log-levels at* [ undefined-log-level ] unless ] compare ;
+
+: log? ( log-level -- ? )
+ log-level get log-level<=> +lt+ = not ;
+
+: send-to-log-server ( array string -- )
+ prefix "log-server" get send ;
+
+SYMBOL: log-service
+
+ERROR: bad-log-message-parameters msg word level ;
+
+: check-log-message ( msg word level -- msg word level )
+ 3dup [ string? ] [ word? ] [ word? ] tri* and and
+ [ bad-log-message-parameters ] unless ; inline
+
+: log-message ( msg word level -- )
+ check-log-message
+ log-service get
+ 2dup [ log? ] [ ] bi* and [
+ [ [ string-lines ] [ name>> ] [ name>> ] tri* ] dip
+ 4array "log-message" send-to-log-server
+ ] [
+ 4drop
+ ] if ;
+
+: rotate-logs ( -- )
+ { } "rotate-logs" send-to-log-server ;
+
+: close-logs ( -- )
+ { } "close-logs" send-to-log-server ;
+
+: with-logging ( service quot -- )
+ [ log-service ] dip with-variable ; inline
+
+! Aspect-oriented programming idioms
+
+<PRIVATE
+
+: stack>message ( obj -- inputs>message )
+ dup array? [ dup length 1 = [ first ] when ] when
+ dup string? [
+ [
+ boa-tuples? on
+ string-limit? off
+ 1 line-limit set
+ 3 nesting-limit set
+ 0 margin set
+ unparse
+ ] with-scope
+ ] unless ;
+
+PRIVATE>
+
+: (define-logging) ( word level quot -- )
+ [ dup ] 2dip 2curry annotate ; inline
+
+: call-logging-quot ( quot word level -- quot' )
+ [ "called" ] 2dip [ log-message ] 3curry prepose ;
+
+: add-logging ( word level -- )
+ [ call-logging-quot ] (define-logging) ;
+
+: log-stack ( n word level -- )
+ log-service get [
+ [ [ ndup ] keep narray stack>message ] 2dip log-message
+ ] [
+ 3drop
+ ] if ; inline
+
+: input# ( word -- n ) stack-effect in>> length ;
+
+: input-logging-quot ( quot word level -- quot' )
+ rot [ [ input# ] keep ] 2dip '[ _ _ _ log-stack @ ] ;
+
+: add-input-logging ( word level -- )
+ [ input-logging-quot ] (define-logging) ;
+
+: output# ( word -- n ) stack-effect out>> length ;
+
+: output-logging-quot ( quot word level -- quot' )
+ [ [ output# ] keep ] dip '[ @ _ _ _ log-stack ] ;
+
+: add-output-logging ( word level -- )
+ [ output-logging-quot ] (define-logging) ;
+
+: (log-error) ( object word level -- )
+ log-service get [
+ [ [ print-error ] with-string-writer ] 2dip log-message
+ ] [
+ 2drop rethrow
+ ] if ;
+
+: log-error ( error word -- ) ERROR (log-error) ;
+
+: log-critical ( error word -- ) CRITICAL (log-error) ;
+
+: stack-balancer ( effect -- quot )
+ [ in>> length [ ndrop ] curry ]
+ [ out>> length f <repetition> >quotation ]
+ bi append ;
+
+: error-logging-quot ( quot word -- quot' )
+ dup stack-effect stack-balancer
+ '[ _ [ _ log-error @ ] recover ] ;
+
+: add-error-logging ( word level -- )
+ [ [ input-logging-quot ] 2keep drop error-logging-quot ]
+ (define-logging) ;
+
+SYNTAX: LOG:
+ #! Syntax: name level
+ scan-new-word dup scan-word
+ '[ 1array stack>message _ _ log-message ]
+ ( message -- ) define-declared ;
+
+USE: vocabs
+
+"logging.parser" require
+"logging.analysis" require
-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors peg peg.parsers memoize kernel sequences\r
-logging arrays words strings vectors io io.files\r
-io.encodings.utf8 namespaces make combinators logging.server\r
-calendar calendar.format assocs prettyprint ;\r
-IN: logging.parser\r
-\r
-TUPLE: log-entry date level word-name message ;\r
-\r
-: string-of ( quot -- parser )\r
- satisfy repeat0 [ >string ] action ; inline\r
-\r
-SYMBOL: multiline\r
-\r
-: 'date' ( -- parser )\r
- [ "]" member? not ] string-of [\r
- dup multiline-header =\r
- [ drop multiline ] [ rfc3339>timestamp ] if\r
- ] action\r
- "[" "]" surrounded-by ;\r
-\r
-: 'log-level' ( -- parser )\r
- log-levels keys [\r
- [ name>> token ] keep [ nip ] curry action\r
- ] map choice ;\r
-\r
-: 'word-name' ( -- parser )\r
- [ " :" member? not ] string-of ;\r
-\r
-SYMBOL: malformed\r
-\r
-: 'malformed-line' ( -- parser )\r
- [ drop t ] string-of\r
- [ log-entry new swap >>message malformed >>level ] action ;\r
-\r
-: 'log-message' ( -- parser )\r
- [ drop t ] string-of\r
- [ 1vector ] action ;\r
-\r
-: 'log-line' ( -- parser )\r
- [\r
- 'date' ,\r
- " " token hide ,\r
- 'log-level' ,\r
- " " token hide ,\r
- 'word-name' ,\r
- ": " token hide ,\r
- 'log-message' ,\r
- ] seq* [ first4 log-entry boa ] action\r
- 'malformed-line' 2choice ;\r
-\r
-PEG: parse-log-line ( string -- entry ) 'log-line' ;\r
-\r
-: malformed? ( line -- ? )\r
- level>> malformed eq? ;\r
-\r
-: multiline? ( line -- ? )\r
- level>> multiline eq? ;\r
-\r
-: malformed-line ( line -- )\r
- "Warning: malformed log line:" print\r
- message>> print ;\r
-\r
-: add-multiline ( line -- )\r
- building get empty? [\r
- "Warning: log begins with multiline entry" print drop\r
- ] [\r
- message>> first building get last message>> push\r
- ] if ;\r
-\r
-: parse-log ( lines -- entries )\r
- [\r
- [\r
- parse-log-line {\r
- { [ dup malformed? ] [ malformed-line ] }\r
- { [ dup multiline? ] [ add-multiline ] }\r
- [ , ]\r
- } cond\r
- ] each\r
- ] { } make ;\r
-\r
-: parse-log-file ( service -- entries )\r
- log-path 1 log# dup exists?\r
- [ utf8 file-lines parse-log ] [ drop f ] if ;\r
-\r
-GENERIC: log-timestamp. ( date -- )\r
-\r
-M: timestamp log-timestamp. (timestamp>string) ;\r
-M: word log-timestamp. drop "multiline" write ;\r
-\r
-: log-entry. ( entry -- )\r
- "====== " write\r
- {\r
- [ date>> log-timestamp. bl ]\r
- [ level>> pprint bl ]\r
- [ word-name>> write nl ]\r
- [ message>> "\n" join print ]\r
- } cleave ;\r
-\r
-: log-entries. ( errors -- )\r
- [ log-entry. ] each ;\r
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors peg peg.parsers memoize kernel sequences
+logging arrays words strings vectors io io.files
+io.encodings.utf8 namespaces make combinators logging.server
+calendar calendar.format assocs prettyprint ;
+IN: logging.parser
+
+TUPLE: log-entry date level word-name message ;
+
+: string-of ( quot -- parser )
+ satisfy repeat0 [ >string ] action ; inline
+
+SYMBOL: multiline
+
+: 'date' ( -- parser )
+ [ "]" member? not ] string-of [
+ dup multiline-header =
+ [ drop multiline ] [ rfc3339>timestamp ] if
+ ] action
+ "[" "]" surrounded-by ;
+
+: 'log-level' ( -- parser )
+ log-levels keys [
+ [ name>> token ] keep [ nip ] curry action
+ ] map choice ;
+
+: 'word-name' ( -- parser )
+ [ " :" member? not ] string-of ;
+
+SYMBOL: malformed
+
+: 'malformed-line' ( -- parser )
+ [ drop t ] string-of
+ [ log-entry new swap >>message malformed >>level ] action ;
+
+: 'log-message' ( -- parser )
+ [ drop t ] string-of
+ [ 1vector ] action ;
+
+: 'log-line' ( -- parser )
+ [
+ 'date' ,
+ " " token hide ,
+ 'log-level' ,
+ " " token hide ,
+ 'word-name' ,
+ ": " token hide ,
+ 'log-message' ,
+ ] seq* [ first4 log-entry boa ] action
+ 'malformed-line' 2choice ;
+
+PEG: parse-log-line ( string -- entry ) 'log-line' ;
+
+: malformed? ( line -- ? )
+ level>> malformed eq? ;
+
+: multiline? ( line -- ? )
+ level>> multiline eq? ;
+
+: malformed-line ( line -- )
+ "Warning: malformed log line:" print
+ message>> print ;
+
+: add-multiline ( line -- )
+ building get empty? [
+ "Warning: log begins with multiline entry" print drop
+ ] [
+ message>> first building get last message>> push
+ ] if ;
+
+: parse-log ( lines -- entries )
+ [
+ [
+ parse-log-line {
+ { [ dup malformed? ] [ malformed-line ] }
+ { [ dup multiline? ] [ add-multiline ] }
+ [ , ]
+ } cond
+ ] each
+ ] { } make ;
+
+: parse-log-file ( service -- entries )
+ log-path 1 log# dup exists?
+ [ utf8 file-lines parse-log ] [ drop f ] if ;
+
+GENERIC: log-timestamp. ( date -- )
+
+M: timestamp log-timestamp. (timestamp>string) ;
+M: word log-timestamp. drop "multiline" write ;
+
+: log-entry. ( entry -- )
+ "====== " write
+ {
+ [ date>> log-timestamp. bl ]
+ [ level>> pprint bl ]
+ [ word-name>> write nl ]
+ [ message>> "\n" join print ]
+ } cleave ;
+
+: log-entries. ( errors -- )
+ [ log-entry. ] each ;
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: assocs calendar calendar.format combinators\r
-concurrency.messaging continuations debugger destructors init io\r
-io.directories io.encodings.utf8 io.files io.pathnames kernel\r
-locals math math.parser math.ranges namespaces sequences\r
-strings threads ;\r
-IN: logging.server\r
-\r
-: log-root ( -- string )\r
- \ log-root get-global [ "logs" resource-path ] unless* ;\r
-\r
-: log-path ( service -- path )\r
- log-root prepend-path ;\r
-\r
-: log# ( path n -- path' )\r
- number>string ".log" append append-path ;\r
-\r
-SYMBOL: log-files\r
-\r
-: open-log-stream ( service -- stream )\r
- log-path\r
- [ make-directories ]\r
- [ 1 log# utf8 <file-appender> ] bi ;\r
-\r
-: log-stream ( service -- stream )\r
- log-files get [ open-log-stream ] cache ;\r
-\r
-: close-log-streams ( -- )\r
- log-files get [ values dispose-each ] [ clear-assoc ] bi ;\r
-\r
-:: with-log-root ( path quot -- )\r
- [ close-log-streams path \ log-root set-global quot call ]\r
- \ log-root get-global\r
- [ \ log-root set-global close-log-streams ] curry\r
- [ ] cleanup ; inline\r
-\r
-: timestamp-header. ( -- )\r
- "[" write now (timestamp>rfc3339) "] " write ;\r
-\r
-: multiline-header ( -- str ) 20 CHAR: - <string> ; foldable\r
-\r
-: multiline-header. ( -- )\r
- "[" write multiline-header write "] " write ;\r
-\r
-:: write-message ( msg word-name level -- )\r
- msg harvest [\r
- timestamp-header.\r
- [ multiline-header. ]\r
- [ level write bl word-name write ": " write print ]\r
- interleave\r
- ] unless-empty ;\r
-\r
-: (log-message) ( msg -- )\r
- #! msg: { msg word-name level service }\r
- first4 log-stream [ write-message flush ] with-output-stream* ;\r
-\r
-: try-dispose ( obj -- )\r
- [ dispose ] curry [ error. ] recover ;\r
-\r
-: close-log ( service -- )\r
- log-files get delete-at*\r
- [ try-dispose ] [ drop ] if ;\r
-\r
-: (close-logs) ( -- )\r
- log-files get\r
- [ values [ try-dispose ] each ] [ clear-assoc ] bi ;\r
-\r
-CONSTANT: keep-logs 10\r
-\r
-: ?delete-file ( path -- )\r
- dup exists? [ delete-file ] [ drop ] if ;\r
-\r
-: delete-oldest ( service -- )\r
- keep-logs log# ?delete-file ;\r
-\r
-: ?move-file ( old new -- )\r
- over exists? [ move-file ] [ 2drop ] if ;\r
-\r
-: advance-log ( path n -- )\r
- [ 1 - log# ] 2keep log# ?move-file ;\r
-\r
-: rotate-log ( service -- )\r
- [ close-log ]\r
- [\r
- log-path\r
- [ delete-oldest ]\r
- [ keep-logs 1 [a,b] [ advance-log ] with each ] bi\r
- ] bi ;\r
-\r
-: (rotate-logs) ( -- )\r
- (close-logs)\r
- log-root directory-files [ rotate-log ] each ;\r
-\r
-: log-server-loop ( -- )\r
- receive unclip {\r
- { "log-message" [ (log-message) ] }\r
- { "rotate-logs" [ drop (rotate-logs) ] }\r
- { "close-logs" [ drop (close-logs) ] }\r
- } case log-server-loop ;\r
-\r
-: log-server ( -- )\r
- [\r
- init-namespaces\r
- [ log-server-loop ]\r
- [ error. (close-logs) ]\r
- recover t\r
- ]\r
- "Log server" spawn-server\r
- "log-server" set-global ;\r
-\r
-[\r
- H{ } clone log-files set-global\r
- log-server\r
-] "logging" add-startup-hook\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs calendar calendar.format combinators
+concurrency.messaging continuations debugger destructors init io
+io.directories io.encodings.utf8 io.files io.pathnames kernel
+locals math math.parser math.ranges namespaces sequences
+strings threads ;
+IN: logging.server
+
+: log-root ( -- string )
+ \ log-root get-global [ "logs" resource-path ] unless* ;
+
+: log-path ( service -- path )
+ log-root prepend-path ;
+
+: log# ( path n -- path' )
+ number>string ".log" append append-path ;
+
+SYMBOL: log-files
+
+: open-log-stream ( service -- stream )
+ log-path
+ [ make-directories ]
+ [ 1 log# utf8 <file-appender> ] bi ;
+
+: log-stream ( service -- stream )
+ log-files get [ open-log-stream ] cache ;
+
+: close-log-streams ( -- )
+ log-files get [ values dispose-each ] [ clear-assoc ] bi ;
+
+:: with-log-root ( path quot -- )
+ [ close-log-streams path \ log-root set-global quot call ]
+ \ log-root get-global
+ [ \ log-root set-global close-log-streams ] curry
+ [ ] cleanup ; inline
+
+: timestamp-header. ( -- )
+ "[" write now (timestamp>rfc3339) "] " write ;
+
+: multiline-header ( -- str ) 20 CHAR: - <string> ; foldable
+
+: multiline-header. ( -- )
+ "[" write multiline-header write "] " write ;
+
+:: write-message ( msg word-name level -- )
+ msg harvest [
+ timestamp-header.
+ [ multiline-header. ]
+ [ level write bl word-name write ": " write print ]
+ interleave
+ ] unless-empty ;
+
+: (log-message) ( msg -- )
+ #! msg: { msg word-name level service }
+ first4 log-stream [ write-message flush ] with-output-stream* ;
+
+: try-dispose ( obj -- )
+ [ dispose ] curry [ error. ] recover ;
+
+: close-log ( service -- )
+ log-files get delete-at*
+ [ try-dispose ] [ drop ] if ;
+
+: (close-logs) ( -- )
+ log-files get
+ [ values [ try-dispose ] each ] [ clear-assoc ] bi ;
+
+CONSTANT: keep-logs 10
+
+: ?delete-file ( path -- )
+ dup exists? [ delete-file ] [ drop ] if ;
+
+: delete-oldest ( service -- )
+ keep-logs log# ?delete-file ;
+
+: ?move-file ( old new -- )
+ over exists? [ move-file ] [ 2drop ] if ;
+
+: advance-log ( path n -- )
+ [ 1 - log# ] 2keep log# ?move-file ;
+
+: rotate-log ( service -- )
+ [ close-log ]
+ [
+ log-path
+ [ delete-oldest ]
+ [ keep-logs 1 [a,b] [ advance-log ] with each ] bi
+ ] bi ;
+
+: (rotate-logs) ( -- )
+ (close-logs)
+ log-root directory-files [ rotate-log ] each ;
+
+: log-server-loop ( -- )
+ receive unclip {
+ { "log-message" [ (log-message) ] }
+ { "rotate-logs" [ drop (rotate-logs) ] }
+ { "close-logs" [ drop (close-logs) ] }
+ } case log-server-loop ;
+
+: log-server ( -- )
+ [
+ init-namespaces
+ [ log-server-loop ]
+ [ error. (close-logs) ]
+ recover t
+ ]
+ "Log server" spawn-server
+ "log-server" set-global ;
+
+[
+ H{ } clone log-files set-global
+ log-server
+] "logging" add-startup-hook
{ [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
[ "CPU architecture unsupported by math.floats.env" throw ]
} cond >>
-
{ +denormal-flush+ [ vmx-denormal-mode-bits bitor ] }
} case
] curry change-vscr ; inline
-
dup zero? [
dup 0x7c00 >= [ 13 shift 0x7f800000 bitor ] [
13 shift
- 112 23 shift +
+ 112 23 shift +
] if
] unless
] bi bitor bits>float ;
[ rest [ \ * swap \ + [ ] 3sequence ] map ]
[ first \ drop swap [ ] 2sequence ] bi
prefix \ cleave [ ] 2sequence ;
-
} case
] each ;
-: lower-median-index ( seq -- n )
+: lower-median-index ( seq -- n )
[ midpoint@ ]
[ length odd? [ 1 - ] unless ] bi ;
:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
to-size from-size /i log2 :> steps
from-element to-element from-type to-type steps check-vunpack
- from-type to-type [[vunpack]] ;
+ from-type to-type [[vunpack]] ;
PRIVATE>
from-type new [ simd-element-type ] [ byte-length ] bi :> ( from-element from-length )
to-type new [ simd-element-type ] [ byte-length ] bi :> ( to-element to-length )
from-element heap-size :> from-size
- to-element heap-size :> to-size
+ to-element heap-size :> to-size
from-length to-length = [ from-type to-type bad-vconvert ] unless
{ [ from-size to-size = ] [ [vconvert] ] }
{ [ from-size to-size > ] [ [vpack] ] }
} cond ;
-
-USING: math.vectors.simd math.vectors.simd.cords tools.test ;\r
-IN: math.vectors.simd.cords.tests\r
-\r
-[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test\r
+USING: math.vectors.simd math.vectors.simd.cords tools.test ;
+IN: math.vectors.simd.cords.tests
+
+[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test
IN: memoize.syntax
SYNTAX: MEMO[ parse-quotation dup infer memoize-quot suffix! ;
-
: mime-type-encoding ( mime-type -- encoding )
"text/" head? utf8 binary ? ;
-
-USING: help.syntax help.markup kernel math classes classes.tuple\r
-calendar models ;\r
-IN: models.arrow\r
-\r
-HELP: arrow\r
-{ $class-description "Arrow model values are computed by applying a quotation to the value of another model. Arrows are automatically updated when the underlying model changes. Arrows are constructed by " { $link <arrow> } "." }\r
-{ $examples\r
- "The following code displays a label showing the result of applying " { $link sq } " to the value 5:"\r
- { $code\r
- "USING: models ui.gadgets.labels ui.gadgets.panes ;"\r
- "5 <model> [ sq ] <arrow> [ number>string ] <arrow>"\r
- "<label-control> gadget."\r
- }\r
- "An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36."\r
-} ;\r
-\r
-HELP: <arrow>\r
-{ $values { "model" model } { "quot" { $quotation ( obj -- newobj ) } } { "arrow" "a new " { $link arrow } } }\r
-{ $description "Creates a new instance of " { $link arrow } ". The value of the new arrow model is computed by applying the quotation to the value." }\r
-{ $examples "See the example in the documentation for " { $link arrow } "." } ;\r
-\r
-ARTICLE: "models.arrow" "Arrow models"\r
-"Arrow model values are computed by applying a quotation to the value of another model."\r
-{ $subsections\r
- arrow\r
- <arrow>\r
-} ;\r
-\r
-ABOUT: "models.arrow"\r
+USING: help.syntax help.markup kernel math classes classes.tuple
+calendar models ;
+IN: models.arrow
+
+HELP: arrow
+{ $class-description "Arrow model values are computed by applying a quotation to the value of another model. Arrows are automatically updated when the underlying model changes. Arrows are constructed by " { $link <arrow> } "." }
+{ $examples
+ "The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
+ { $code
+ "USING: models ui.gadgets.labels ui.gadgets.panes ;"
+ "5 <model> [ sq ] <arrow> [ number>string ] <arrow>"
+ "<label-control> gadget."
+ }
+ "An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36."
+} ;
+
+HELP: <arrow>
+{ $values { "model" model } { "quot" { $quotation ( obj -- newobj ) } } { "arrow" "a new " { $link arrow } } }
+{ $description "Creates a new instance of " { $link arrow } ". The value of the new arrow model is computed by applying the quotation to the value." }
+{ $examples "See the example in the documentation for " { $link arrow } "." } ;
+
+ARTICLE: "models.arrow" "Arrow models"
+"Arrow model values are computed by applying a quotation to the value of another model."
+{ $subsections
+ arrow
+ <arrow>
+} ;
+
+ABOUT: "models.arrow"
-USING: arrays generic kernel math models namespaces sequences assocs\r
-tools.test models.arrow accessors ;\r
-IN: models.arrow.tests\r
-\r
-3 <model> "x" set\r
-"x" get [ 2 * ] <arrow> dup "z" set\r
-[ 1 + ] <arrow> "y" set\r
-[ ] [ "y" get activate-model ] unit-test\r
-[ t ] [ "z" get "x" get connections>> member-eq? ] unit-test\r
-[ 7 ] [ "y" get value>> ] unit-test\r
-[ ] [ 4 "x" get set-model ] unit-test\r
-[ 9 ] [ "y" get value>> ] unit-test\r
-[ ] [ "y" get deactivate-model ] unit-test\r
-[ f ] [ "z" get "x" get connections>> member-eq? ] unit-test\r
-\r
-3 <model> "x" set\r
-"x" get [ sq ] <arrow> "y" set\r
-\r
-4 "x" get set-model\r
-\r
-"y" get activate-model\r
-[ 16 ] [ "y" get value>> ] unit-test\r
-"y" get deactivate-model\r
+USING: arrays generic kernel math models namespaces sequences assocs
+tools.test models.arrow accessors ;
+IN: models.arrow.tests
+
+3 <model> "x" set
+"x" get [ 2 * ] <arrow> dup "z" set
+[ 1 + ] <arrow> "y" set
+[ ] [ "y" get activate-model ] unit-test
+[ t ] [ "z" get "x" get connections>> member-eq? ] unit-test
+[ 7 ] [ "y" get value>> ] unit-test
+[ ] [ 4 "x" get set-model ] unit-test
+[ 9 ] [ "y" get value>> ] unit-test
+[ ] [ "y" get deactivate-model ] unit-test
+[ f ] [ "z" get "x" get connections>> member-eq? ] unit-test
+
+3 <model> "x" set
+"x" get [ sq ] <arrow> "y" set
+
+4 "x" get set-model
+
+"y" get activate-model
+[ 16 ] [ "y" get value>> ] unit-test
+"y" get deactivate-model
-! Copyright (C) 2008, 2009 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel models sequences ;\r
-IN: models.arrow\r
-\r
-TUPLE: arrow < model quot ;\r
-\r
-: <arrow> ( model quot -- arrow )\r
- f arrow new-model\r
- swap >>quot\r
- [ add-dependency ] keep ;\r
-\r
-M: arrow model-changed\r
- [ [ value>> ] [ quot>> ] bi* call( old -- new ) ]\r
- [ set-model ] bi ;\r
-\r
-M: arrow model-activated\r
- [ dependencies>> ] keep [ model-changed ] curry each ;\r
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel models sequences ;
+IN: models.arrow
+
+TUPLE: arrow < model quot ;
+
+: <arrow> ( model quot -- arrow )
+ f arrow new-model
+ swap >>quot
+ [ add-dependency ] keep ;
+
+M: arrow model-changed
+ [ [ value>> ] [ quot>> ] bi* call( old -- new ) ]
+ [ set-model ] bi ;
+
+M: arrow model-activated
+ [ dependencies>> ] keep [ model-changed ] curry each ;
MACRO: <smart-arrow> ( quot -- quot' )
[ inputs dup ] keep
- '[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
\ No newline at end of file
+ '[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
-USING: help.syntax help.markup kernel math classes classes.tuple\r
-calendar models ;\r
-IN: models.delay\r
-\r
-HELP: delay\r
-{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link <delay> } "." }\r
-{ $examples\r
- "The following code displays a sliders and a label which is updated half a second after the slider stops changing:"\r
- { $code\r
- "USING: models models.delay models.arrow models.range"\r
- "ui ui.gadgets ui.gadgets.labels ui.gadgets.sliders"\r
- "ui.gadgets.panes math.parser calendar ;"\r
- ""\r
- "<pile>"\r
- "0 10 0 100 1 <range>"\r
- "[ horizontal <slider> add-gadget ]"\r
- "["\r
- " 1/2 seconds <delay>"\r
- " [ unparse ] <arrow>"\r
- " <label-control> add-gadget"\r
- "] bi"\r
- "\"Test\" open-window"\r
- }\r
-} ;\r
-\r
-HELP: <delay>\r
-{ $values { "model" model } { "timeout" duration } { "delay" delay } }\r
-{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }\r
-{ $examples "See the example in the documentation for " { $link delay } "." } ;\r
-\r
-ARTICLE: "models-delay" "Delay models"\r
-"Delay models are used to implement delayed updating of gadgets in response to user input."\r
-{ $subsections\r
- delay\r
- <delay>\r
-} ;\r
-\r
-ABOUT: "models-delay"\r
+USING: help.syntax help.markup kernel math classes classes.tuple
+calendar models ;
+IN: models.delay
+
+HELP: delay
+{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link <delay> } "." }
+{ $examples
+ "The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
+ { $code
+ "USING: models models.delay models.arrow models.range"
+ "ui ui.gadgets ui.gadgets.labels ui.gadgets.sliders"
+ "ui.gadgets.panes math.parser calendar ;"
+ ""
+ "<pile>"
+ "0 10 0 100 1 <range>"
+ "[ horizontal <slider> add-gadget ]"
+ "["
+ " 1/2 seconds <delay>"
+ " [ unparse ] <arrow>"
+ " <label-control> add-gadget"
+ "] bi"
+ "\"Test\" open-window"
+ }
+} ;
+
+HELP: <delay>
+{ $values { "model" model } { "timeout" duration } { "delay" delay } }
+{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
+{ $examples "See the example in the documentation for " { $link delay } "." } ;
+
+ARTICLE: "models-delay" "Delay models"
+"Delay models are used to implement delayed updating of gadgets in response to user input."
+{ $subsections
+ delay
+ <delay>
+} ;
+
+ABOUT: "models-delay"
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors fry kernel models timers ;\r
-IN: models.delay\r
-\r
-TUPLE: delay < model model timeout timer ;\r
-\r
-: update-delay-model ( delay -- )\r
- [ model>> value>> ] keep set-model ;\r
-\r
-: <delay> ( model timeout -- delay )\r
- f delay new-model\r
- swap >>timeout\r
- over >>model\r
- [ add-dependency ] keep ;\r
-\r
-: stop-delay ( delay -- )\r
- timer>> [ stop-timer ] when* ;\r
-\r
-: start-delay ( delay -- )\r
- [ '[ _ f >>timer update-delay-model ] ]\r
- [ timeout>> later ]\r
- [ timer<< ] tri ;\r
-\r
-M: delay model-changed nip dup stop-delay start-delay ;\r
-\r
-M: delay model-activated update-delay-model ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry kernel models timers ;
+IN: models.delay
+
+TUPLE: delay < model model timeout timer ;
+
+: update-delay-model ( delay -- )
+ [ model>> value>> ] keep set-model ;
+
+: <delay> ( model timeout -- delay )
+ f delay new-model
+ swap >>timeout
+ over >>model
+ [ add-dependency ] keep ;
+
+: stop-delay ( delay -- )
+ timer>> [ stop-timer ] when* ;
+
+: start-delay ( delay -- )
+ [ '[ _ f >>timer update-delay-model ] ]
+ [ timeout>> later ]
+ [ timer<< ] tri ;
+
+M: delay model-changed nip dup stop-delay start-delay ;
+
+M: delay model-activated update-delay-model ;
-USING: arrays generic kernel math models namespaces sequences assocs\r
-tools.test models.mapping accessors make ;\r
-IN: models.mapping.tests\r
-\r
-! Test mapping\r
-[ ] [\r
- [\r
- 1 <model> "one" ,,\r
- 2 <model> "two" ,,\r
- ] H{ } make\r
- <mapping> "m" set\r
-] unit-test\r
-\r
-[ ] [ "m" get activate-model ] unit-test\r
-\r
-[ H{ { "one" 1 } { "two" 2 } } ] [\r
- "m" get value>>\r
-] unit-test\r
-\r
-[ ] [\r
- H{ { "one" 3 } { "two" 4 } } \r
- "m" get set-model\r
-] unit-test\r
-\r
-[ H{ { "one" 3 } { "two" 4 } } ] [\r
- "m" get value>>\r
-] unit-test\r
-\r
-[ H{ { "one" 5 } { "two" 4 } } ] [\r
- 5 "one" "m" get assoc>> at set-model\r
- "m" get value>>\r
-] unit-test\r
-\r
-[ ] [ "m" get deactivate-model ] unit-test\r
+USING: arrays generic kernel math models namespaces sequences assocs
+tools.test models.mapping accessors make ;
+IN: models.mapping.tests
+
+! Test mapping
+[ ] [
+ [
+ 1 <model> "one" ,,
+ 2 <model> "two" ,,
+ ] H{ } make
+ <mapping> "m" set
+] unit-test
+
+[ ] [ "m" get activate-model ] unit-test
+
+[ H{ { "one" 1 } { "two" 2 } } ] [
+ "m" get value>>
+] unit-test
+
+[ ] [
+ H{ { "one" 3 } { "two" 4 } }
+ "m" get set-model
+] unit-test
+
+[ H{ { "one" 3 } { "two" 4 } } ] [
+ "m" get value>>
+] unit-test
+
+[ H{ { "one" 5 } { "two" 4 } } ] [
+ 5 "one" "m" get assoc>> at set-model
+ "m" get value>>
+] unit-test
+
+[ ] [ "m" get deactivate-model ] unit-test
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors models kernel assocs ;\r
-IN: models.mapping\r
-\r
-TUPLE: mapping < model assoc ;\r
-\r
-: <mapping> ( models -- mapping )\r
- f mapping new-model\r
- over values >>dependencies\r
- swap >>assoc ;\r
-\r
-M: mapping model-changed\r
- nip [ assoc>> [ value>> ] assoc-map ] keep set-model ;\r
-\r
-M: mapping model-activated\r
- dup model-changed ;\r
-\r
-M: mapping update-model\r
- [ value>> ] [ assoc>> ] bi\r
- [ swapd at set-model ] curry assoc-each ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors models kernel assocs ;
+IN: models.mapping
+
+TUPLE: mapping < model assoc ;
+
+: <mapping> ( models -- mapping )
+ f mapping new-model
+ over values >>dependencies
+ swap >>assoc ;
+
+M: mapping model-changed
+ nip [ assoc>> [ value>> ] assoc-map ] keep set-model ;
+
+M: mapping model-activated
+ dup model-changed ;
+
+M: mapping update-model
+ [ value>> ] [ assoc>> ] bi
+ [ swapd at set-model ] curry assoc-each ;
: pop-model ( model -- value )
[ pop ] change-model* ;
-
-USING: help.syntax help.markup kernel math classes classes.tuple\r
-calendar models ;\r
-IN: models.product\r
-\r
-HELP: product\r
-{ $class-description "Product model values are computed by collecting the values from a sequence of underlying models into a new sequence. Product models are automatically updated when underlying models change. Product models are constructed by " { $link <product> } "."\r
-$nl\r
-"A product model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }\r
-{ $examples\r
- "The following code displays a pair of sliders, and an updating label showing their current values:"\r
- { $code\r
- "USING: models models.product models.range ui.gadgets"\r
- "ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes"\r
- "ui.gadgets.sliders ;"\r
- ""\r
- ": <funny-model> ( -- model ) 0 10 0 100 1 <range> ;"\r
- ": <funny-slider> ( model -- slider ) horizontal <slider> ;"\r
- ""\r
- "<funny-model> <funny-model> 2array"\r
- "[ <pile> [ horizontal <slider> add-gadget ] reduce gadget. ]"\r
- "[ <product> [ unparse ] <arrow> <label-control> gadget. ]"\r
- "bi"\r
- }\r
-} ;\r
-\r
-HELP: <product>\r
-{ $values { "models" "a sequence of models" } { "product" "a new " { $link product } } }\r
-{ $description "Creates a new instance of " { $link product } ". The value of the new product model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." }\r
-{ $examples "See the example in the documentation for " { $link product } "." } ;\r
-\r
-ARTICLE: "models.product" "Product models"\r
-"Product model values are computed by collecting the values from a sequence of underlying models into a new sequence."\r
-{ $subsections\r
- product\r
- <product>\r
-} ;\r
-\r
-ABOUT: "models.product"\r
+USING: help.syntax help.markup kernel math classes classes.tuple
+calendar models ;
+IN: models.product
+
+HELP: product
+{ $class-description "Product model values are computed by collecting the values from a sequence of underlying models into a new sequence. Product models are automatically updated when underlying models change. Product models are constructed by " { $link <product> } "."
+$nl
+"A product model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }
+{ $examples
+ "The following code displays a pair of sliders, and an updating label showing their current values:"
+ { $code
+ "USING: models models.product models.range ui.gadgets"
+ "ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes"
+ "ui.gadgets.sliders ;"
+ ""
+ ": <funny-model> ( -- model ) 0 10 0 100 1 <range> ;"
+ ": <funny-slider> ( model -- slider ) horizontal <slider> ;"
+ ""
+ "<funny-model> <funny-model> 2array"
+ "[ <pile> [ horizontal <slider> add-gadget ] reduce gadget. ]"
+ "[ <product> [ unparse ] <arrow> <label-control> gadget. ]"
+ "bi"
+ }
+} ;
+
+HELP: <product>
+{ $values { "models" "a sequence of models" } { "product" "a new " { $link product } } }
+{ $description "Creates a new instance of " { $link product } ". The value of the new product model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." }
+{ $examples "See the example in the documentation for " { $link product } "." } ;
+
+ARTICLE: "models.product" "Product models"
+"Product model values are computed by collecting the values from a sequence of underlying models into a new sequence."
+{ $subsections
+ product
+ <product>
+} ;
+
+ABOUT: "models.product"
-USING: arrays generic kernel math models namespaces sequences assocs\r
-tools.test models.product accessors locals ;\r
-IN: models.product.tests\r
-\r
-[ ] [\r
- 1 <model> "a" set\r
- 2 <model> "b" set\r
- "a" get "b" get 2array <product> "c" set\r
-] unit-test\r
-\r
-[ ] [ "c" get activate-model ] unit-test\r
-\r
-[ { 1 2 } ] [ "c" get value>> ] unit-test\r
-\r
-[ ] [ 3 "b" get set-model ] unit-test\r
-\r
-[ { 1 3 } ] [ "c" get value>> ] unit-test\r
-\r
-[ ] [ { 4 5 } "c" get set-model ] unit-test\r
-\r
-[ { 4 5 } ] [ "c" get value>> ] unit-test\r
-\r
-[ ] [ "c" get deactivate-model ] unit-test\r
-\r
-TUPLE: an-observer { i integer } ;\r
-\r
-M: an-observer model-changed nip [ 1 + ] change-i drop ;\r
-\r
-[ 1 0 ] [\r
- [let\r
- 1 <model> :> m1\r
- 2 <model> :> m2\r
- { m1 m2 } <product> :> c\r
- an-observer new :> o1\r
- an-observer new :> o2\r
- \r
- o1 m1 add-connection\r
- o2 m2 add-connection\r
-\r
- c activate-model\r
- \r
- "OH HAI" m1 set-model\r
- o1 i>>\r
- o2 i>>\r
- ]\r
-] unit-test\r
+USING: arrays generic kernel math models namespaces sequences assocs
+tools.test models.product accessors locals ;
+IN: models.product.tests
+
+[ ] [
+ 1 <model> "a" set
+ 2 <model> "b" set
+ "a" get "b" get 2array <product> "c" set
+] unit-test
+
+[ ] [ "c" get activate-model ] unit-test
+
+[ { 1 2 } ] [ "c" get value>> ] unit-test
+
+[ ] [ 3 "b" get set-model ] unit-test
+
+[ { 1 3 } ] [ "c" get value>> ] unit-test
+
+[ ] [ { 4 5 } "c" get set-model ] unit-test
+
+[ { 4 5 } ] [ "c" get value>> ] unit-test
+
+[ ] [ "c" get deactivate-model ] unit-test
+
+TUPLE: an-observer { i integer } ;
+
+M: an-observer model-changed nip [ 1 + ] change-i drop ;
+
+[ 1 0 ] [
+ [let
+ 1 <model> :> m1
+ 2 <model> :> m2
+ { m1 m2 } <product> :> c
+ an-observer new :> o1
+ an-observer new :> o2
+
+ o1 m1 add-connection
+ o2 m2 add-connection
+
+ c activate-model
+
+ "OH HAI" m1 set-model
+ o1 i>>
+ o2 i>>
+ ]
+] unit-test
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel models sequences ;\r
-IN: models.product\r
-\r
-TUPLE: product < model ;\r
-\r
-: new-product ( models class -- product )\r
- f swap new-model\r
- swap clone >>dependencies ; inline\r
-\r
-: <product> ( models -- product )\r
- product new-product ;\r
-\r
-: product-value ( model quot -- seq )\r
- [ dependencies>> ] dip map ; inline\r
-\r
-: set-product-value ( seq model quot -- )\r
- [ dependencies>> ] dip 2each ; inline\r
-\r
-M: product model-changed\r
- nip\r
- dup [ value>> ] product-value >>value\r
- notify-connections ;\r
-\r
-M: product model-activated dup model-changed ;\r
-\r
-M: product update-model\r
- [ value>> ] keep [ set-model ] set-product-value ;\r
-\r
-M: product range-value\r
- [ range-value ] product-value ;\r
-\r
-M: product range-page-value\r
- [ range-page-value ] product-value ;\r
-\r
-M: product range-min-value\r
- [ range-min-value ] product-value ;\r
-\r
-M: product range-max-value\r
- [ range-max-value ] product-value ;\r
-\r
-M: product range-max-value*\r
- [ range-max-value* ] product-value ;\r
-\r
-M: product set-range-value\r
- [ clamp-value ] keep\r
- [ set-range-value ] set-product-value ;\r
-\r
-M: product set-range-page-value\r
- [ set-range-page-value ] set-product-value ;\r
-\r
-M: product set-range-min-value\r
- [ set-range-min-value ] set-product-value ;\r
-\r
-M: product set-range-max-value\r
- [ set-range-max-value ] set-product-value ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel models sequences ;
+IN: models.product
+
+TUPLE: product < model ;
+
+: new-product ( models class -- product )
+ f swap new-model
+ swap clone >>dependencies ; inline
+
+: <product> ( models -- product )
+ product new-product ;
+
+: product-value ( model quot -- seq )
+ [ dependencies>> ] dip map ; inline
+
+: set-product-value ( seq model quot -- )
+ [ dependencies>> ] dip 2each ; inline
+
+M: product model-changed
+ nip
+ dup [ value>> ] product-value >>value
+ notify-connections ;
+
+M: product model-activated dup model-changed ;
+
+M: product update-model
+ [ value>> ] keep [ set-model ] set-product-value ;
+
+M: product range-value
+ [ range-value ] product-value ;
+
+M: product range-page-value
+ [ range-page-value ] product-value ;
+
+M: product range-min-value
+ [ range-min-value ] product-value ;
+
+M: product range-max-value
+ [ range-max-value ] product-value ;
+
+M: product range-max-value*
+ [ range-max-value* ] product-value ;
+
+M: product set-range-value
+ [ clamp-value ] keep
+ [ set-range-value ] set-product-value ;
+
+M: product set-range-page-value
+ [ set-range-page-value ] set-product-value ;
+
+M: product set-range-min-value
+ [ set-range-min-value ] set-product-value ;
+
+M: product set-range-max-value
+ [ set-range-max-value ] set-product-value ;
-USING: help.syntax help.markup kernel math classes classes.tuple\r
-calendar models ;\r
-IN: models.range\r
-\r
-HELP: range\r
-{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link <range> } "." }\r
-{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;\r
-\r
-HELP: <range>\r
-{ $values { "value" real } { "page" real } { "min" real } { "max" real } { "step" real } { "range" range } }\r
-{ $description "Creates a new " { $link range } " model." } ;\r
-\r
-HELP: range-model\r
-{ $values { "range" range } { "model" model } }\r
-{ $description "Outputs a model holding a range model's current value." }\r
-{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;\r
-\r
-HELP: range-min\r
-{ $values { "range" range } { "model" model } }\r
-{ $description "Outputs a model holding a range model's minimum value." }\r
-{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;\r
-\r
-HELP: range-max\r
-{ $values { "range" range } { "model" model } }\r
-{ $description "Outputs a model holding a range model's maximum value." }\r
-{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;\r
-\r
-HELP: range-page\r
-{ $values { "range" range } { "model" model } }\r
-{ $description "Outputs a model holding a range model's page size." }\r
-{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;\r
-\r
-HELP: move-by\r
-{ $values { "amount" real } { "range" range } }\r
-{ $description "Adds a number to a range model's current value." }\r
-{ $side-effects "range" } ;\r
-\r
-HELP: move-by-page\r
-{ $values { "amount" real } { "range" range } }\r
-{ $description "Adds a multiple of the page size to a range model's current value." }\r
-{ $side-effects "range" } ;\r
-\r
-ARTICLE: "models-range" "Range models"\r
-"Range models ensure their value is a real number within a fixed range."\r
-{ $subsections\r
- range\r
- <range>\r
-}\r
-"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range."\r
-{ $subsections "range-model-protocol" } ;\r
-\r
-ARTICLE: "range-model-protocol" "Range model protocol"\r
-"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too."\r
-{ $subsections\r
- range-value\r
- range-page-value\r
- range-min-value\r
- range-max-value\r
- range-max-value*\r
- set-range-value\r
- set-range-page-value\r
- set-range-min-value \r
- set-range-max-value \r
-} ;\r
-\r
-ABOUT: "models-range"\r
+USING: help.syntax help.markup kernel math classes classes.tuple
+calendar models ;
+IN: models.range
+
+HELP: range
+{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link <range> } "." }
+{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;
+
+HELP: <range>
+{ $values { "value" real } { "page" real } { "min" real } { "max" real } { "step" real } { "range" range } }
+{ $description "Creates a new " { $link range } " model." } ;
+
+HELP: range-model
+{ $values { "range" range } { "model" model } }
+{ $description "Outputs a model holding a range model's current value." }
+{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
+
+HELP: range-min
+{ $values { "range" range } { "model" model } }
+{ $description "Outputs a model holding a range model's minimum value." }
+{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
+
+HELP: range-max
+{ $values { "range" range } { "model" model } }
+{ $description "Outputs a model holding a range model's maximum value." }
+{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
+
+HELP: range-page
+{ $values { "range" range } { "model" model } }
+{ $description "Outputs a model holding a range model's page size." }
+{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
+
+HELP: move-by
+{ $values { "amount" real } { "range" range } }
+{ $description "Adds a number to a range model's current value." }
+{ $side-effects "range" } ;
+
+HELP: move-by-page
+{ $values { "amount" real } { "range" range } }
+{ $description "Adds a multiple of the page size to a range model's current value." }
+{ $side-effects "range" } ;
+
+ARTICLE: "models-range" "Range models"
+"Range models ensure their value is a real number within a fixed range."
+{ $subsections
+ range
+ <range>
+}
+"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range."
+{ $subsections "range-model-protocol" } ;
+
+ARTICLE: "range-model-protocol" "Range model protocol"
+"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too."
+{ $subsections
+ range-value
+ range-page-value
+ range-min-value
+ range-max-value
+ range-max-value*
+ set-range-value
+ set-range-page-value
+ set-range-min-value
+ set-range-max-value
+} ;
+
+ABOUT: "models-range"
-IN: models.range.tests\r
-USING: arrays generic kernel math models namespaces sequences assocs\r
-tools.test models.range ;\r
-\r
-! Test <range> \r
-: setup-range ( -- range ) 0 0 0 255 1 <range> ;\r
-: setup-stepped-range ( -- range ) 0 0 0 255 2 <range> ;\r
-\r
-! clamp-value should not go past range ends\r
-[ 0 ] [ -10 setup-range clamp-value ] unit-test\r
-[ 255 ] [ 2000 setup-range clamp-value ] unit-test\r
-[ 14 ] [ 14 setup-range clamp-value ] unit-test\r
-\r
-! step-value\r
-[ 14 ] [ 15 setup-stepped-range step-value ] unit-test\r
-\r
-! range min/max/page values should be correct\r
-[ 0 ] [ setup-range range-page-value ] unit-test\r
-[ 0 ] [ setup-range range-min-value ] unit-test\r
-[ 255 ] [ setup-range range-max-value ] unit-test\r
-\r
-! should be able to set the value within the range and get back\r
-[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test\r
-[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test\r
-[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test\r
-\r
-! should be able to change the range min/max/page value\r
-[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test\r
-[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test\r
-[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test\r
-\r
-! should be able to move by positive and negative values\r
-[ 30 ] [ setup-range 30 over move-by range-value ] unit-test\r
-[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test\r
-\r
-! should be able to move by a page of 10\r
-[ 10 ] [ \r
- setup-range 10 over set-range-page-value \r
- 1 over move-by-page range-value \r
-] unit-test\r
+IN: models.range.tests
+USING: arrays generic kernel math models namespaces sequences assocs
+tools.test models.range ;
+
+! Test <range>
+: setup-range ( -- range ) 0 0 0 255 1 <range> ;
+: setup-stepped-range ( -- range ) 0 0 0 255 2 <range> ;
+
+! clamp-value should not go past range ends
+[ 0 ] [ -10 setup-range clamp-value ] unit-test
+[ 255 ] [ 2000 setup-range clamp-value ] unit-test
+[ 14 ] [ 14 setup-range clamp-value ] unit-test
+
+! step-value
+[ 14 ] [ 15 setup-stepped-range step-value ] unit-test
+
+! range min/max/page values should be correct
+[ 0 ] [ setup-range range-page-value ] unit-test
+[ 0 ] [ setup-range range-min-value ] unit-test
+[ 255 ] [ setup-range range-max-value ] unit-test
+
+! should be able to set the value within the range and get back
+[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
+[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
+[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
+
+! should be able to change the range min/max/page value
+[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
+[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
+[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
+
+! should be able to move by positive and negative values
+[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
+[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
+
+! should be able to move by a page of 10
+[ 10 ] [
+ setup-range 10 over set-range-page-value
+ 1 over move-by-page range-value
+] unit-test
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel models arrays sequences math math.order\r
-models.product generalizations sequences.generalizations\r
-math.functions ;\r
-FROM: models.product => product ;\r
-IN: models.range\r
-\r
-TUPLE: range < product ;\r
-\r
-: <range> ( value page min max step -- range )\r
- 5 narray [ <model> ] map range new-product ;\r
-\r
-: range-model ( range -- model ) dependencies>> first ;\r
-: range-page ( range -- model ) dependencies>> second ;\r
-: range-min ( range -- model ) dependencies>> third ;\r
-: range-max ( range -- model ) dependencies>> fourth ;\r
-: range-step ( range -- model ) dependencies>> 4 swap nth ;\r
-\r
-: step-value ( value range -- value' )\r
- range-step value>> floor-to ;\r
-\r
-M: range range-value\r
- [ range-model value>> ] [ clamp-value ] [ step-value ] tri ;\r
-\r
-M: range range-page-value range-page value>> ;\r
-\r
-M: range range-min-value range-min value>> ;\r
-\r
-M: range range-max-value range-max value>> ;\r
-\r
-M: range range-max-value*\r
- [ range-max-value ] [ range-page-value ] bi [-] ;\r
-\r
-M: range set-range-value\r
- [ clamp-value ] [ range-model ] bi set-model ;\r
-\r
-M: range set-range-page-value range-page set-model ;\r
-\r
-M: range set-range-min-value range-min set-model ;\r
-\r
-M: range set-range-max-value range-max set-model ;\r
-\r
-: move-by ( amount range -- )\r
- [ range-value + ] keep set-range-value ;\r
-\r
-: move-by-page ( amount range -- )\r
- [ range-page-value * ] keep move-by ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel models arrays sequences math math.order
+models.product generalizations sequences.generalizations
+math.functions ;
+FROM: models.product => product ;
+IN: models.range
+
+TUPLE: range < product ;
+
+: <range> ( value page min max step -- range )
+ 5 narray [ <model> ] map range new-product ;
+
+: range-model ( range -- model ) dependencies>> first ;
+: range-page ( range -- model ) dependencies>> second ;
+: range-min ( range -- model ) dependencies>> third ;
+: range-max ( range -- model ) dependencies>> fourth ;
+: range-step ( range -- model ) dependencies>> 4 swap nth ;
+
+: step-value ( value range -- value' )
+ range-step value>> floor-to ;
+
+M: range range-value
+ [ range-model value>> ] [ clamp-value ] [ step-value ] tri ;
+
+M: range range-page-value range-page value>> ;
+
+M: range range-min-value range-min value>> ;
+
+M: range range-max-value range-max value>> ;
+
+M: range range-max-value*
+ [ range-max-value ] [ range-page-value ] bi [-] ;
+
+M: range set-range-value
+ [ clamp-value ] [ range-model ] bi set-model ;
+
+M: range set-range-page-value range-page set-model ;
+
+M: range set-range-min-value range-min set-model ;
+
+M: range set-range-max-value range-max set-model ;
+
+: move-by ( amount range -- )
+ [ range-value + ] keep set-range-value ;
+
+: move-by-page ( amount range -- )
+ [ range-page-value * ] keep move-by ;
IN: models.sort
: <sort> ( values sort -- model )
- [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline
\ No newline at end of file
+ [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline
SYNTAX: GB
\ gl-break suffix! ;
-
dup GL_FRAMEBUFFER_COMPLETE = f rot ? ;
: framebuffer-error ( status -- * )
- {
+ {
{ GL_FRAMEBUFFER_COMPLETE [ "framebuffer complete" ] }
{ GL_FRAMEBUFFER_UNSUPPORTED [ "framebuffer configuration unsupported" ] }
{ GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT [ "framebuffer incomplete (incomplete attachment)" ] }
[ GL_DRAW_FRAMEBUFFER swap glBindFramebuffer ]
[ GL_READ_FRAMEBUFFER swap glBindFramebuffer ] bi*
] dip
- [
+ [
GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer
GL_READ_FRAMEBUFFER 0 glBindFramebuffer
] [ ] cleanup ; inline
0 +gl-function-counter+ set-global ;
: reset-gl-function-pointers ( -- )
100 <hashtable> +gl-function-pointers+ set-global ;
-
+
[ reset-gl-function-pointers ] "opengl.gl" add-startup-hook
reset-gl-function-pointers
reset-gl-function-number-counter
FUNCTION: void glEnable ( GLenum cap ) ;
FUNCTION: void glDisable ( GLenum cap ) ;
FUNCTION: GLboolean glIsEnabled ( GLenum cap ) ;
-
+
FUNCTION: void glEnableClientState ( GLenum cap ) ;
FUNCTION: void glDisableClientState ( GLenum cap ) ;
FUNCTION: void glGetBooleanv ( GLenum pname, GLboolean* params ) ;
FUNCTION: void glAccum ( GLenum op, GLfloat value ) ;
FUNCTION: void glMatrixMode ( GLenum mode ) ;
-FUNCTION: void glOrtho ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top,
+FUNCTION: void glOrtho ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top,
GLdouble near_val, GLdouble far_val ) ;
-FUNCTION: void glFrustum ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top,
+FUNCTION: void glFrustum ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top,
GLdouble near_val, GLdouble far_val ) ;
FUNCTION: void glViewport ( GLint x, GLint y, GLsizei width, GLsizei height ) ;
FUNCTION: void glPushMatrix ( ) ;
FUNCTION: void glGetPixelMapuiv ( GLenum map, GLuint* values ) ;
FUNCTION: void glGetPixelMapusv ( GLenum map, GLushort* values ) ;
-FUNCTION: void glBitmap ( GLsizei width, GLsizei height, GLfloat xorig, GLfloat yorig,
+FUNCTION: void glBitmap ( GLsizei width, GLsizei height, GLfloat xorig, GLfloat yorig,
GLfloat xmove, GLfloat ymove, GLubyte* bitmap ) ;
-FUNCTION: void glReadPixels ( GLint x, GLint y, GLsizei width, GLsizei height,
+FUNCTION: void glReadPixels ( GLint x, GLint y, GLsizei width, GLsizei height,
GLenum format, GLenum type, GLvoid* pixels ) ;
-FUNCTION: void glDrawPixels ( GLsizei width, GLsizei height, GLenum format,
+FUNCTION: void glDrawPixels ( GLsizei width, GLsizei height, GLenum format,
GLenum type, GLvoid* pixels ) ;
FUNCTION: void glCopyPixels ( GLint x, GLint y, GLsizei width, GLsizei height, GLenum type ) ;
FUNCTION: void glGetTexParameterfv ( GLenum target, GLenum pname, GLfloat* params ) ;
FUNCTION: void glGetTexParameteriv ( GLenum target, GLenum pname, GLint* params ) ;
-FUNCTION: void glGetTexLevelParameterfv ( GLenum target, GLint level,
+FUNCTION: void glGetTexLevelParameterfv ( GLenum target, GLint level,
GLenum pname, GLfloat* params ) ;
FUNCTION: void glGetTexLevelParameteriv ( GLenum target, GLint level,
GLenum pname, GLint* params ) ;
FUNCTION: void glTexImage1D ( GLenum target, GLint level, GLint internalFormat, GLsizei width,
GLint border, GLenum format, GLenum type, GLvoid* pixels ) ;
-FUNCTION: void glTexImage2D ( GLenum target, GLint level, GLint internalFormat,
- GLsizei width, GLsizei height, GLint border,
+FUNCTION: void glTexImage2D ( GLenum target, GLint level, GLint internalFormat,
+ GLsizei width, GLsizei height, GLint border,
GLenum format, GLenum type, GLvoid* pixels ) ;
-FUNCTION: void glGetTexImage ( GLenum target, GLint level, GLenum format,
+FUNCTION: void glGetTexImage ( GLenum target, GLint level, GLenum format,
GLenum type, GLvoid* pixels ) ;
GLenum format, GLenum type, GLvoid* pixels ) ;
FUNCTION: void glTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset,
- GLsizei width, GLsizei height, GLenum format,
+ GLsizei width, GLsizei height, GLenum format,
GLenum type, GLvoid* pixels ) ;
-FUNCTION: void glCopyTexImage1D ( GLenum target, GLint level, GLenum internalformat,
+FUNCTION: void glCopyTexImage1D ( GLenum target, GLint level, GLenum internalformat,
GLint x, GLint y, GLsizei width, GLint border ) ;
-FUNCTION: void glCopyTexImage2D ( GLenum target, GLint level, GLenum internalformat,
+FUNCTION: void glCopyTexImage2D ( GLenum target, GLint level, GLenum internalformat,
GLint x, GLint y,
GLsizei width, GLsizei height, GLint border ) ;
-FUNCTION: void glCopyTexSubImage1D ( GLenum target, GLint level, GLint xoffset,
+FUNCTION: void glCopyTexSubImage1D ( GLenum target, GLint level, GLint xoffset,
GLint x, GLint y, GLsizei width ) ;
FUNCTION: void glCopyTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset,
GL-FUNCTION: void glFramebufferTexture2D { glFramebufferTexture2DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
GL-FUNCTION: void glFramebufferTexture3D { glFramebufferTexture3DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ;
GL-FUNCTION: void glFramebufferTextureLayer { glFramebufferTextureLayerEXT }
- ( GLenum target, GLenum attachment,
+ ( GLenum target, GLenum attachment,
GLuint texture, GLint level, GLint layer ) ;
GL-FUNCTION: void glGenFramebuffers { glGenFramebuffersEXT } ( GLsizei n, GLuint* framebuffers ) ;
GL-FUNCTION: void glGenRenderbuffers { glGenRenderbuffersEXT } ( GLsizei n, GLuint* renderbuffers ) ;
GL-FUNCTION: void glTransformFeedbackVaryings { glTransformFeedbackVaryingsEXT } ( GLuint program, GLsizei count,
GLstring* varyings, GLenum bufferMode ) ;
GL-FUNCTION: void glGetTransformFeedbackVarying { glGetTransformFeedbackVaryingEXT } ( GLuint program, GLuint index,
- GLsizei bufSize, GLsizei* length,
+ GLsizei bufSize, GLsizei* length,
GLsizei* size, GLenum* type, GLstring name ) ;
GL-FUNCTION: void glClearBufferiv { } ( GLenum buffer, GLint drawbuffer, GLint* value ) ;
CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT 0x8C71
CONSTANT: GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT 0x8C72
CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT 0x8C73
-
ascii string>alien gdk_gl_get_proc_address ; inline
: gl-function-calling-convention ( -- str ) cdecl ; inline
-
! Programs
: (gl-program) ( shaders quot: ( gl-program -- ) -- program )
- glCreateProgram
+ glCreateProgram
[
[ swap [ glAttachShader ] with each ]
[ swap call ] bi-curry bi*
: <gl-program> ( shaders -- program )
[ drop ] (gl-program) ;
-
+
: (gl-program?) ( object -- ? )
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
[ <vertex-shader> check-gl-shader ]
[ <fragment-shader> check-gl-shader ] bi*
2array <gl-program> check-gl-program ;
-
: packed-length ( str -- n )
[ ch>packed-length ] map-sum ;
-
+
: pack-native ( seq str -- seq )
'[ _ _ pack ] with-native-endian ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: pango.cairo.ffi ;
IN: pango.cairo
-
! See http://factorcode.org/license.txt for BSD license.
USING: pango.ffi ;
IN: pango
-
suffix! \ call suffix! reset-tokenizer ;
SYNTAX: EBNF:
- reset-tokenizer scan-new-word dup ";EBNF" parse-multiline-string
+ reset-tokenizer scan-new-word dup ";EBNF" parse-multiline-string
ebnf>quot swapd
( input -- ast ) define-declared "ebnf-parser" set-word-prop
reset-tokenizer ;
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax kernel quotations strings words ;\r
-IN: peg\r
-\r
-HELP: parse\r
-{ $values\r
- { "input" string }\r
- { "parser" parser }\r
- { "ast" object }\r
-}\r
-{ $description\r
- "Given the input string, parse it using the given parser. The result is the abstract "\r
- "syntax tree returned by the parser." }\r
-{ $see-also compile } ;\r
-\r
-HELP: compile\r
-{ $values\r
- { "parser" parser }\r
- { "word" word }\r
-}\r
-{ $description\r
- "Compile the parser to a word. The word will have stack effect ( -- ast )."\r
-}\r
-{ $see-also parse } ;\r
-\r
-HELP: token\r
-{ $values\r
- { "string" string }\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that matches the given string." } ;\r
-\r
-HELP: satisfy\r
-{ $values\r
- { "quot" quotation }\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that calls the quotation on the first character of the input string, "\r
- "succeeding if that quotation returns true. The AST is the character from the string." } ;\r
-\r
-HELP: range\r
-{ $values\r
- { "min" "a character" }\r
- { "max" "a character" }\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that matches a single character that lies within the range of characters given, inclusive." }\r
-{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ;\r
-\r
-HELP: seq\r
-{ $values\r
- { "seq" "a sequence of parsers" }\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "\r
- "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "\r
- "the individual parsers." } ;\r
-\r
-HELP: choice\r
-{ $values\r
- { "seq" "a sequence of parsers" }\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "\r
- "The resulting AST is that produced by the successful parser." } ;\r
-\r
-HELP: repeat0\r
-{ $values\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "\r
- "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "\r
- "parsed." } ;\r
-\r
-HELP: repeat1\r
-{ $values\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "\r
- "an array of the AST produced by the 'p1' parser." } ;\r
-\r
-HELP: optional\r
-{ $values\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "\r
- "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;\r
-\r
-HELP: semantic\r
-{ $values\r
- { "parser" parser }\r
- { "quot" { $quotation ( object -- ? ) } }\r
-}\r
-{ $description\r
- "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "\r
- "the AST produced by 'p1' on the stack returns true." }\r
-{ $examples\r
- { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse ." "67" }\r
-} ;\r
-\r
-HELP: ensure\r
-{ $values\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "\r
- "AST and does not move the location in the input string. This can be used for lookahead and "\r
- "disambiguation, along with the " { $link ensure-not } " word." }\r
-{ $examples { $code "\"0\" token ensure octal-parser" } } ;\r
-\r
-HELP: ensure-not\r
-{ $values\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "\r
- "AST and does not move the location in the input string. This can be used for lookahead and "\r
- "disambiguation, along with the " { $link ensure } " word." }\r
-{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;\r
-\r
-HELP: action\r
-{ $values\r
- { "parser" parser }\r
- { "quot" { $quotation ( ast -- ast ) } }\r
-}\r
-{ $description\r
- "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "\r
- "from that parse. The result of the quotation is then used as the final AST. This can be used "\r
- "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "\r
- "the default AST. If the quotation returns " { $link fail } " then the parser fails." }\r
-{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;\r
-\r
-HELP: sp\r
-{ $values\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that calls the original parser 'p1' after stripping any whitespace "\r
- " from the left of the input string." } ;\r
-\r
-HELP: hide\r
-{ $values\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Returns a parser that succeeds if the original parser succeeds, but does not "\r
- "put any result in the AST. Useful for ignoring 'syntax' in the AST." }\r
-{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;\r
-\r
-HELP: delay\r
-{ $values\r
- { "quot" quotation }\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Delays the construction of a parser until it is actually required to parse. This "\r
- "allows for calling a parser that results in a recursive call to itself. The quotation "\r
- "should return the constructed parser and is called the first time the parser is run. "\r
- "The compiled result is memoized for future runs. See " { $link box } " for a word "\r
- "that calls the quotation at compile time." } ;\r
-\r
-HELP: box\r
-{ $values\r
- { "quot" quotation }\r
- { "parser" parser }\r
-}\r
-{ $description\r
- "Delays the construction of a parser until the parser is compiled. The quotation "\r
- "should return the constructed parser and is called when the parser is compiled. "\r
- "The compiled result is memoized for future runs. See " { $link delay } " for a word "\r
- "that calls the quotation at runtime." } ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations strings words ;
+IN: peg
+
+HELP: parse
+{ $values
+ { "input" string }
+ { "parser" parser }
+ { "ast" object }
+}
+{ $description
+ "Given the input string, parse it using the given parser. The result is the abstract "
+ "syntax tree returned by the parser." }
+{ $see-also compile } ;
+
+HELP: compile
+{ $values
+ { "parser" parser }
+ { "word" word }
+}
+{ $description
+ "Compile the parser to a word. The word will have stack effect ( -- ast )."
+}
+{ $see-also parse } ;
+
+HELP: token
+{ $values
+ { "string" string }
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that matches the given string." } ;
+
+HELP: satisfy
+{ $values
+ { "quot" quotation }
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that calls the quotation on the first character of the input string, "
+ "succeeding if that quotation returns true. The AST is the character from the string." } ;
+
+HELP: range
+{ $values
+ { "min" "a character" }
+ { "max" "a character" }
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that matches a single character that lies within the range of characters given, inclusive." }
+{ $examples { $code ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } } ;
+
+HELP: seq
+{ $values
+ { "seq" "a sequence of parsers" }
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "
+ "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
+ "the individual parsers." } ;
+
+HELP: choice
+{ $values
+ { "seq" "a sequence of parsers" }
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "
+ "The resulting AST is that produced by the successful parser." } ;
+
+HELP: repeat0
+{ $values
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
+ "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
+ "parsed." } ;
+
+HELP: repeat1
+{ $values
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "
+ "an array of the AST produced by the 'p1' parser." } ;
+
+HELP: optional
+{ $values
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
+ "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
+
+HELP: semantic
+{ $values
+ { "parser" parser }
+ { "quot" { $quotation ( object -- ? ) } }
+}
+{ $description
+ "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "
+ "the AST produced by 'p1' on the stack returns true." }
+{ $examples
+ { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse ." "67" }
+} ;
+
+HELP: ensure
+{ $values
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
+ "AST and does not move the location in the input string. This can be used for lookahead and "
+ "disambiguation, along with the " { $link ensure-not } " word." }
+{ $examples { $code "\"0\" token ensure octal-parser" } } ;
+
+HELP: ensure-not
+{ $values
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
+ "AST and does not move the location in the input string. This can be used for lookahead and "
+ "disambiguation, along with the " { $link ensure } " word." }
+{ $code "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
+
+HELP: action
+{ $values
+ { "parser" parser }
+ { "quot" { $quotation ( ast -- ast ) } }
+}
+{ $description
+ "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
+ "from that parse. The result of the quotation is then used as the final AST. This can be used "
+ "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
+ "the default AST. If the quotation returns " { $link fail } " then the parser fails." }
+{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
+
+HELP: sp
+{ $values
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that calls the original parser 'p1' after stripping any whitespace "
+ " from the left of the input string." } ;
+
+HELP: hide
+{ $values
+ { "parser" parser }
+}
+{ $description
+ "Returns a parser that succeeds if the original parser succeeds, but does not "
+ "put any result in the AST. Useful for ignoring 'syntax' in the AST." }
+{ $code "\"[\" token hide number \"]\" token hide 3array seq" } ;
+
+HELP: delay
+{ $values
+ { "quot" quotation }
+ { "parser" parser }
+}
+{ $description
+ "Delays the construction of a parser until it is actually required to parse. This "
+ "allows for calling a parser that results in a recursive call to itself. The quotation "
+ "should return the constructed parser and is called the first time the parser is run. "
+ "The compiled result is memoized for future runs. See " { $link box } " for a word "
+ "that calls the quotation at compile time." } ;
+
+HELP: box
+{ $values
+ { "quot" quotation }
+ { "parser" parser }
+}
+{ $description
+ "Delays the construction of a parser until the parser is compiled. The quotation "
+ "should return the constructed parser and is called when the parser is compiled. "
+ "The compiled result is memoized for future runs. See " { $link delay } " for a word "
+ "that calls the quotation at runtime." } ;
<singleton-heap> <persistent-heap> <branch>
] if ;
-M: empty-heap sift-down
+M: empty-heap sift-down
over singleton-heap? [ singleton-sift-down ] [ <branch> ] if ;
:: reroot-left ( value prio left right -- heap )
: char>quoted ( ch -- str )
dup printable? [ 1string ] [
assure-small >hex >upper
- 2 CHAR: 0 pad-head
+ 2 CHAR: 0 pad-head
CHAR: = prefix
] if ;
[
default-mersenne-twister random-generator set-global
] "bootstrap.random" add-startup-hook
-
swap >>provider
initialize-crypto-context ; inline
-M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes )
+M: windows-crypto-context random-bytes* ( n windows-crypto-context -- bytes )
handle>> swap [ ] [ <byte-array> ] bi
[ CryptGenRandom win32-error=0/f ] keep ;
! input table is state => class
>alist dup table>questions make-condition ;
-: condition-map ( condition quot: ( obj -- obj' ) -- new-condition )
+: condition-map ( condition quot: ( obj -- obj' ) -- new-condition )
over condition? [
[ [ question>> ] [ yes>> ] [ no>> ] tri ] dip
'[ _ condition-map ] bi@ <condition>
dup transitions>> keys [ gensym ] H{ } map>assoc
[ transitions-at ]
[ values ]
- bi swap ;
+ bi swap ;
: dfa>main-word ( dfa -- word )
states>words [ states>code ] keep start-state>> ;
:: class-partitions ( classes -- assoc )
classes [ integer? ] partition :> ( integers classes )
-
+
classes powerset-partition classes integers add-integers
[ [ partition>class ] keep 2array ] map [ first ] filter
integers [ classes singleton-partition ] map append ;
[ [ drop tagged-epsilon? ] assoc-filter ] bi
assoc-union H{ } assoc-like ; inline
-: disambiguate ( nfa -- nfa )
+: disambiguate ( nfa -- nfa )
expand-ors [
dup new-transitions '[
[
_ swap '[ _ get-transitions ] assoc-map
- [ nip empty? ] assoc-reject
+ [ nip empty? ] assoc-reject
] preserving-epsilon
] assoc-map
] change-transitions ;
HS{ -2 } clone >>final-states ;
: adjoin-dfa ( transition-table -- start end )
- unify-final-state renumber-states box-transitions
+ unify-final-state renumber-states box-transitions
[ start-state>> ]
[ final-states>> members first ]
[ nfa-table get [ transitions>> ] bi@ swap assoc-union! drop ] tri ;
dup cased-range? [
[ from>> ] [ to>> ] bi
[ [ ch>lower ] bi@ <range-class> ]
- [ [ ch>upper ] bi@ <range-class> ] 2bi
+ [ [ ch>upper ] bi@ <range-class> ] 2bi
2array <or-class>
] when
] when ;
: string>options ( string -- options )
"-" split1 parse-options ;
-
+
: options>string ( options -- string )
[ on>> ] [ off>> ] bi
[ [ option>ch ] map ] bi@
[ raw>> dup find-regexp-syntax swap % swap % % ]
[ options>> options>string % ] bi
] "" make
- ] keep present-text ;
\ No newline at end of file
+ ] keep present-text ;
[ seeing-word ]
[ definer. ]
[ pprint-word ]
- [ stack-effect. ]
+ [ stack-effect. ]
} cleave ;
M: word synopsis* word-synopsis ;
: unrolled-map-index ( seq len quot: ( x i -- newx ) -- newseq )
[ dup length iota ] 2dip unrolled-2map ; inline
-
dup 0x7e <= [
0x80 bitor write1
] [
- dup log2 8 /i 1 +
+ dup log2 8 /i 1 +
dup 0x7f >= [
0xff write1
dup serialize-cell
{
[ dup "DATA" = ]
[
- data-mode on
+ data-mode on
"354 Enter message, ending with \".\" on a line by itself\r\n"
write flush t
]
M: specialized-array pprint*
[ pprint-object ] [ pprint-direct-array ] pprint-c-object ;
-
word effect variables branches n declare-effect-d
] when*
] each-index ;
-
: prefix<=> ( begin seq -- <=> )
[ <=> ] [ swap head? ] 2bi [ drop +eq+ ] when ;
-
+
: find-index ( begin suffix-array -- index/f )
[ prefix<=> ] with search drop ;
-! Copyright (C) 2008 Marc Fauconneau.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel arrays math accessors sequences math.vectors\r
-math.order sorting binary-search sets assocs fry suffix-arrays ;\r
-IN: suffix-arrays.words\r
-\r
-! to search on word names\r
-\r
-: new-word-sa ( words -- sa )\r
- [ name>> ] map >suffix-array ;\r
-\r
-: name>word-map ( words -- map )\r
- dup [ name>> V{ } clone ] H{ } map>assoc\r
- [ '[ dup name>> _ at push ] each ] keep ;\r
-\r
-: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ;\r
-\r
-! usage example :\r
-! clear all-words 100 head dup name>word-map "test" rot new-word-sa query .\r
+! Copyright (C) 2008 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays math accessors sequences math.vectors
+math.order sorting binary-search sets assocs fry suffix-arrays ;
+IN: suffix-arrays.words
+
+! to search on word names
+
+: new-word-sa ( words -- sa )
+ [ name>> ] map >suffix-array ;
+
+: name>word-map ( words -- map )
+ dup [ name>> V{ } clone ] H{ } map>assoc
+ [ '[ dup name>> _ at push ] each ] keep ;
+
+: query-word-sa ( map begin sa -- matches ) query '[ _ at ] map concat ;
+
+! usage example :
+! clear all-words 100 head dup name>word-map "test" rot new-word-sa query .
vocabs ;
IN: system-info
-HOOK: os-version os ( -- version )
+HOOK: os-version os ( -- version )
HOOK: cpus os ( -- n )
HOOK: cpu-mhz os ( -- n )
HOOK: memory-load os ( -- n )
M: windows os-version ( -- obj )
os-version-struct [ dwMajorVersion>> ] [ dwMinorVersion>> ] bi 2array ;
-
+
: windows-build# ( -- n )
os-version-struct dwBuildNumber>> ;
MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep uint <ref>
GetComputerName win32-error=0/f alien>native-string ;
-
+
: username ( -- string )
UNLEN 1 +
[ <byte-array> dup ] keep uint <ref>
-USING: help.markup help.syntax calendar quotations system ;\r
-IN: timers\r
-\r
-HELP: timer\r
-{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ;\r
-\r
-HELP: start-timer\r
-{ $values { "timer" timer } }\r
-{ $description "Starts a timer." } ;\r
-\r
-HELP: restart-timer\r
-{ $values { "timer" timer } }\r
-{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ;\r
-\r
-HELP: stop-timer\r
-{ $values { "timer" timer } }\r
-{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ;\r
-\r
-HELP: every\r
-{ $values\r
- { "quot" quotation } { "interval-duration" duration }\r
- { "timer" timer } }\r
-{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." }\r
-{ $examples\r
- { $code\r
- "USING: timers io calendar ;"\r
- """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- }\r
-} ;\r
-\r
-HELP: later\r
-{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } }\r
-{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." }\r
-{ $examples\r
- { $code\r
- "USING: timers io calendar ;"\r
- """[ "Break's over!" print flush ] 15 minutes later drop"""\r
- }\r
-} ;\r
-\r
-HELP: delayed-every\r
-{ $values\r
- { "quot" quotation } { "duration" duration }\r
- { "timer" timer } }\r
-{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." }\r
-{ $examples\r
- { $code\r
- "USING: timers io calendar ;"\r
- """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
- }\r
-} ;\r
-\r
-ARTICLE: "timers" "Timers"\r
-"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Timers run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Timers use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl\r
-"The timer class:"\r
-{ $subsections timer }\r
-"Create a timer before starting it:"\r
-{ $subsections <timer> }\r
-"Starting a timer:"\r
-{ $subsections start-timer restart-timer }\r
-"Stopping a timer:"\r
-{ $subsections stop-timer }\r
-\r
-"A recurring timer without an initial delay:"\r
-{ $subsections every }\r
-"A one-time timer with an initial delay:"\r
-{ $subsections later }\r
-"A recurring timer with an initial delay:"\r
-{ $subsections delayed-every } ;\r
-\r
-ABOUT: "timers"\r
+USING: help.markup help.syntax calendar quotations system ;
+IN: timers
+
+HELP: timer
+{ $class-description "A timer. Can be passed to " { $link stop-timer } "." } ;
+
+HELP: start-timer
+{ $values { "timer" timer } }
+{ $description "Starts a timer." } ;
+
+HELP: restart-timer
+{ $values { "timer" timer } }
+{ $description "Starts or restarts a timer. Restarting a timer causes the a sleep of initial delay nanoseconds before looping. An timer's parameters may be modified and restarted with this word." } ;
+
+HELP: stop-timer
+{ $values { "timer" timer } }
+{ $description "Prevents a timer from calling its quotation again. Has no effect on timers that are not currently running." } ;
+
+HELP: every
+{ $values
+ { "quot" quotation } { "interval-duration" duration }
+ { "timer" timer } }
+{ $description "Creates a timer that calls the quotation repeatedly, using " { $snippet "duration" } " as the frequency. The first call of " { $snippet "quot" } " will happen immediately. If the quotation throws an exception, the timer will stop." }
+{ $examples
+ { $code
+ "USING: timers io calendar ;"
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""
+ }
+} ;
+
+HELP: later
+{ $values { "quot" quotation } { "delay-duration" duration } { "timer" timer } }
+{ $description "Sleeps for " { $snippet "duration" } " and then calls a " { $snippet "quot" } ". The user may cancel the timer before " { $snippet "quot" } " runs. This timer is not repeated." }
+{ $examples
+ { $code
+ "USING: timers io calendar ;"
+ """[ "Break's over!" print flush ] 15 minutes later drop"""
+ }
+} ;
+
+HELP: delayed-every
+{ $values
+ { "quot" quotation } { "duration" duration }
+ { "timer" timer } }
+{ $description "Creates a timer that calls " { $snippet "quot" } " repeatedly, waiting " { $snippet "duration" } " before calling " { $snippet "quot" } " the first time and then waiting " { $snippet "duration" } " between further calls. If the quotation throws an exception, the timer will stop." }
+{ $examples
+ { $code
+ "USING: timers io calendar ;"
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""
+ }
+} ;
+
+ARTICLE: "timers" "Timers"
+"The " { $vocab-link "timers" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks. Timers run in a single green thread per timer and consist of a quotation, a delay duration, and an interval duration. After starting a timer, the timer thread sleeps for the delay duration and calls the quotation. Then it waits out the interval duration and calls the quotation again until something stops the timer. If a recurring timer's quotation would be scheduled to run again before the previous quotation has finished processing, the timer will be run again immediately afterwards. This may result in the timer falling behind indefinitely, in which case the it will run as often as possible while still allowing other green threads to run. Recurring timers that execute 'on time' or 'catch up' will always be scheduled for an exact multiple of the interval from the original starting time to prevent the timer from drifting over time. Timers use " { $link nano-count } " as the timing primitive, so they will continue to work across system clock changes." $nl
+"The timer class:"
+{ $subsections timer }
+"Create a timer before starting it:"
+{ $subsections <timer> }
+"Starting a timer:"
+{ $subsections start-timer restart-timer }
+"Stopping a timer:"
+{ $subsections stop-timer }
+
+"A recurring timer without an initial delay:"
+{ $subsections every }
+"A one-time timer with an initial delay:"
+{ $subsections later }
+"A recurring timer with an initial delay:"
+{ $subsections delayed-every } ;
+
+ABOUT: "timers"
-USING: timers timers.private calendar concurrency.count-downs\r
-concurrency.promises fry kernel math math.order sequences\r
-threads tools.test tools.time ;\r
-IN: timers.tests\r
-\r
-[ ] [\r
- 1 <count-down>\r
- { f } clone 2dup\r
- [ first stop-timer count-down ] 2curry 1 seconds later\r
- swap set-first\r
- await\r
-] unit-test\r
-\r
-[ ] [\r
- self [ resume ] curry instant later drop\r
- "test" suspend drop\r
-] unit-test\r
-\r
-[ t ] [\r
- [\r
- <promise>\r
- [ '[ t _ fulfill ] 2 seconds later drop ]\r
- [ 5 seconds ?promise-timeout drop ] bi\r
- ] benchmark 1,500,000,000 2,500,000,000 between?\r
-] unit-test\r
-\r
-[ { 3 } ] [\r
- { 3 } dup\r
- '[ 4 _ set-first ] 2 seconds later\r
- 1/2 seconds sleep\r
- stop-timer\r
-] unit-test\r
-\r
-[ { 1 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later\r
- [ stop-timer ] [ start-timer ] bi\r
- 4 seconds sleep\r
-] unit-test\r
-\r
-[ { 0 } ] [\r
- { 0 }\r
- dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later\r
- 2 seconds sleep stop-timer\r
- 1/2 seconds sleep\r
-] unit-test\r
-\r
-[ { 0 } ] [\r
- { 0 }\r
- dup '[ 1 _ set-first ] 300 milliseconds later\r
- 150 milliseconds sleep\r
- [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi\r
-] unit-test\r
-\r
-[ { 1 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later\r
- 100 milliseconds sleep restart-timer 300 milliseconds sleep\r
-] unit-test\r
-\r
-[ { 4 } ] [\r
- { 0 }\r
- dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds\r
- <timer> dup start-timer\r
- 700 milliseconds sleep dup restart-timer\r
- 700 milliseconds sleep stop-timer 500 milliseconds sleep\r
-] unit-test\r
+USING: timers timers.private calendar concurrency.count-downs
+concurrency.promises fry kernel math math.order sequences
+threads tools.test tools.time ;
+IN: timers.tests
+
+[ ] [
+ 1 <count-down>
+ { f } clone 2dup
+ [ first stop-timer count-down ] 2curry 1 seconds later
+ swap set-first
+ await
+] unit-test
+
+[ ] [
+ self [ resume ] curry instant later drop
+ "test" suspend drop
+] unit-test
+
+[ t ] [
+ [
+ <promise>
+ [ '[ t _ fulfill ] 2 seconds later drop ]
+ [ 5 seconds ?promise-timeout drop ] bi
+ ] benchmark 1,500,000,000 2,500,000,000 between?
+] unit-test
+
+[ { 3 } ] [
+ { 3 } dup
+ '[ 4 _ set-first ] 2 seconds later
+ 1/2 seconds sleep
+ stop-timer
+] unit-test
+
+[ { 1 } ] [
+ { 0 }
+ dup '[ 0 _ [ 1 + ] change-nth ] 3 seconds later
+ [ stop-timer ] [ start-timer ] bi
+ 4 seconds sleep
+] unit-test
+
+[ { 0 } ] [
+ { 0 }
+ dup '[ 3 seconds sleep 1 _ set-first ] 1 seconds later
+ 2 seconds sleep stop-timer
+ 1/2 seconds sleep
+] unit-test
+
+[ { 0 } ] [
+ { 0 }
+ dup '[ 1 _ set-first ] 300 milliseconds later
+ 150 milliseconds sleep
+ [ restart-timer ] [ 200 milliseconds sleep stop-timer ] bi
+] unit-test
+
+[ { 1 } ] [
+ { 0 }
+ dup '[ 0 _ [ 1 + ] change-nth ] 200 milliseconds later
+ 100 milliseconds sleep restart-timer 300 milliseconds sleep
+] unit-test
+
+[ { 4 } ] [
+ { 0 }
+ dup '[ 0 _ [ 1 + ] change-nth ] 300 milliseconds 300 milliseconds
+ <timer> dup start-timer
+ 700 milliseconds sleep dup restart-timer
+ 700 milliseconds sleep stop-timer 500 milliseconds sleep
+] unit-test
TUPLE: timer
{ quot callable initial: [ ] }
- start-nanos
+ start-nanos
delay-nanos
interval-nanos
iteration-start-nanos
[
2dup length = [ nip [ break ] append ] [
2dup nth \ break = [ nip ] [
- swap 1 + cut [ break ] glue
+ swap 1 + cut [ break ] glue
] if
] if
] change-frame ;
M: string remove-coverage
[ remove-coverage ] each-word ;
-M: word add-coverage
+M: word add-coverage
H{ } clone [ "coverage" set-word-prop ] 2keep
'[
\ coverage-state new [ _ set-at ] 2keep
: deploy ( vocab -- )
dup find-vocab-root [ check-vocab-main deploy* ] [ no-vocab ] if ;
-: deploy-image-only ( vocab image -- )
+: deploy-image-only ( vocab image -- )
[ vm ] 2dip
swap dup deploy-config make-deploy-image drop ;
os windows?
"tools.deploy.libraries.windows"
"tools.deploy.libraries.unix" ? require
-
{ "/lib" "/usr/lib" "/usr/local/lib" "/opt/local/lib" "resource:" }
[ prepend-path ?exists ] with map-find drop
] if ;
-
alien>native-string
] [ FreeLibrary drop ] bi
] [ f ] if* ;
-
"writing"
} %
] when
-
+
strip-prettyprint? [
{
"delimiter"
"word-style"
} %
] when
-
+
deploy-c-types? get [
{ "c-type" "struct-slots" "struct-align" } %
] unless
[ path>> >deployed-library-path ] [ abi>> ] bi make-library
] change-at
] each
-
+
[
"deploy-libraries" "alien.libraries" lookup-word forget
"deploy-library" "alien.libraries" lookup-word forget
-IN: tools.deploy.test.1\r
-USING: threads ;\r
-\r
-: deploy-test-1 ( -- ) 1000000 sleep ;\r
-\r
-MAIN: deploy-test-1\r
+IN: tools.deploy.test.1
+USING: threads ;
+
+: deploy-test-1 ( -- ) 1000000 sleep ;
+
+MAIN: deploy-test-1
: main ( -- ) C{ 0 1 } pprint ;
-MAIN: main
\ No newline at end of file
+MAIN: main
: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval( -- ) ;
-MAIN: foo
\ No newline at end of file
+MAIN: foo
: foo ( -- ) 1 2 \ + execute-test 4 [ * ] call-test number>string print ;
-MAIN: foo
\ No newline at end of file
+MAIN: foo
: main ( -- ) "x.z" regexp-test "X" "Y" ? print ;
-MAIN: main
\ No newline at end of file
+MAIN: main
: db-deploy-test ( -- )
"test.db" temp-file <sqlite-db> [
person recreate-table
-
+
person new
"Stephen Hawking" >>name
timestamp new 8 >>day 0 >>month 1942 >>year >>birthday
-IN: tools.deploy.test.2\r
-USING: calendar calendar.format ;\r
-\r
-: deploy-test-2 ( -- ) now (timestamp>string) ;\r
-\r
-MAIN: deploy-test-2\r
+IN: tools.deploy.test.2
+USING: calendar calendar.format ;
+
+: deploy-test-2 ( -- ) now (timestamp>string) ;
+
+MAIN: deploy-test-2
-IN: tools.deploy.test.3\r
-USING: io.encodings.ascii io.encodings.string system kernel ;\r
-\r
-: deploy-test-3 ( -- )\r
- "xyzthg" ascii encode drop ;\r
-\r
-MAIN: deploy-test-3\r
+IN: tools.deploy.test.3
+USING: io.encodings.ascii io.encodings.string system kernel ;
+
+: deploy-test-3 ( -- )
+ "xyzthg" ascii encode drop ;
+
+MAIN: deploy-test-3
hUpdate 0 EndUpdateResource drop
] when ;
-
-IN: tools.deploy.windows.tests\r
-USING: io.files.temp tools.deploy.windows tools.test sequences ;\r
-\r
-[ t ] [\r
- "foo" "test-copy-files" temp-file create-exe-dir\r
- ".exe" tail?\r
-] unit-test\r
+IN: tools.deploy.windows.tests
+USING: io.files.temp tools.deploy.windows tools.test sequences ;
+
+[ t ] [
+ "foo" "test-copy-files" temp-file create-exe-dir
+ ".exe" tail?
+] unit-test
[ drop namespace make-deploy-image-executable ]
[ nip "" [ copy-resources ] [ copy-libraries ] 3bi ]
[ nip open-in-explorer ]
- } 2cleave
+ } 2cleave
] with-variables
] with-directory ;
[ [ check-deprecations ] each ]
[ drop initialize-deprecation-notes ] if ;
-[ \ deprecation-observer add-definition-observer ]
+[ \ deprecation-observer add-definition-observer ]
"tools.deprecation" add-startup-hook
initialize-deprecation-notes
-IN: tools.disassembler\r
-USING: help.markup help.syntax sequences.private ;\r
-\r
-HELP: disassemble\r
-{ $values { "obj" "a word or a pair of addresses" } }\r
-{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." }\r
-{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ;\r
-\r
-ARTICLE: "tools.disassembler" "Disassembling words"\r
-"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC."\r
-$nl\r
-"See also " { $vocab-link "compiler.tree.debugger" } " and " { $vocab-link "compiler.cfg.debugger" } "."\r
-$nl\r
-{ $subsections disassemble } ;\r
-\r
-ABOUT: "tools.disassembler"\r
+IN: tools.disassembler
+USING: help.markup help.syntax sequences.private ;
+
+HELP: disassemble
+{ $values { "obj" "a word or a pair of addresses" } }
+{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." }
+{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ;
+
+ARTICLE: "tools.disassembler" "Disassembling words"
+"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC."
+$nl
+"See also " { $vocab-link "compiler.tree.debugger" } " and " { $vocab-link "compiler.cfg.debugger" } "."
+$nl
+{ $subsections disassemble } ;
+
+ABOUT: "tools.disassembler"
-IN: tools.disassembler.tests\r
-USING: kernel fry vocabs tools.disassembler tools.test sequences ;\r
-\r
-"math" vocab-words [\r
- [ { } ] dip '[ _ disassemble ] unit-test\r
-] each\r
+IN: tools.disassembler.tests
+USING: kernel fry vocabs tools.disassembler tools.test sequences ;
+
+"math" vocab-words [
+ [ { } ] dip '[ _ disassemble ] unit-test
+] each
PRIVATE>
-M: byte-array disassemble
+M: byte-array disassemble
[
[ malloc-byte-array &free alien-address dup ]
[ length + ] bi
[ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline
-: list-files ( listing-tool -- array )
+: list-files ( listing-tool -- array )
dup list-slow? [ list-files-slow ] [ list-files-fast ] if ; inline
HOOK: (directory.) os ( path -- lines )
-! Copyright (C) 2008, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs io io.styles kernel math.order\r
-math.parser prettyprint sequences sorting system threads ;\r
-IN: tools.threads\r
-\r
-: thread. ( thread -- )\r
- dup id>> pprint-cell\r
- dup name>> [\r
- over write-object\r
- ] with-cell\r
- dup state>> [\r
- [ dup self eq? "running" "yield" ? ] unless*\r
- write\r
- ] with-cell\r
- [\r
- sleep-entry>> [\r
- key>> nano-count [-] number>string write\r
- " nanos" write\r
- ] when*\r
- ] with-cell ;\r
-\r
-: threads. ( -- )\r
- standard-table-style [\r
- [\r
- { "ID:" "Name:" "Waiting on:" "Remaining sleep:" }\r
- [ [ write ] with-cell ] each\r
- ] with-row\r
-\r
- threads sort-keys values [\r
- [ thread. ] with-row\r
- ] each\r
- ] tabular-output nl ;\r
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs io io.styles kernel math.order
+math.parser prettyprint sequences sorting system threads ;
+IN: tools.threads
+
+: thread. ( thread -- )
+ dup id>> pprint-cell
+ dup name>> [
+ over write-object
+ ] with-cell
+ dup state>> [
+ [ dup self eq? "running" "yield" ? ] unless*
+ write
+ ] with-cell
+ [
+ sleep-entry>> [
+ key>> nano-count [-] number>string write
+ " nanos" write
+ ] when*
+ ] with-cell ;
+
+: threads. ( -- )
+ standard-table-style [
+ [
+ { "ID:" "Name:" "Waiting on:" "Remaining sleep:" }
+ [ [ write ] with-cell ] each
+ ] with-row
+
+ threads sort-keys values [
+ [ thread. ] with-row
+ ] each
+ ] tabular-output nl ;
send-synchronous drop
p ?promise
- variables>> walker-continuation of
+ variables>> walker-continuation of
value>> data>> ;
} case f
] handle-synchronous
] while ;
-
+
: walker-loop ( -- )
+running+ set-status
[ status +stopped+ eq? ] [
: typed-set-global ( value name type -- )
[ set-global ] (typed-set) ; inline
-
: exit-fullscreen ( world -- )
handle>>
- [ view>> f -> exitFullScreenModeWithOptions: ]
+ [ view>> f -> exitFullScreenModeWithOptions: ]
[ [ window>> ] [ view>> ] bi -> makeFirstResponder: drop ] bi ;
M: cocoa-ui-backend (set-fullscreen) ( world ? -- )
M: cocoa-ui-backend ui-backend-available?
running.app? ;
-
HOOK: with-event-loop io-backend ( quot -- )
-M: object with-event-loop call( -- ) ;
\ No newline at end of file
+M: object with-event-loop call( -- ) ;
:: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
ascent [
- cap-height 2 / :> mid-line
+ cap-height 2 / :> mid-line
graphics-height 2 /
[ ascent mid-line - max mid-line + floor >integer ]
[ descent mid-line + max mid-line - ceiling >integer ] bi
convert-command-name >title ;
M: word command-name ( word -- str )
- name>>
+ name>>
"com-" ?head drop "." ?tail drop
dup first Letter? [ rest ] unless
(command-name) ;
-! Copyright (C) 2006, 2011 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors continuations debugger io io.streams.string\r
-kernel namespaces prettyprint ui ui.gadgets.worlds ;\r
-IN: ui.debugger\r
-\r
-: error-alert ( error -- )\r
- [ "Error" ] dip [ print-error ] with-string-writer\r
- system-alert ;\r
-\r
-! ( error -- )\r
-[ error-alert ] ui-error-hook set-global\r
-\r
-! ( error -- )\r
-[\r
- ui-running? [ dup error-alert ] [ dup print-error ] if die\r
-] callback-error-hook set-global\r
-\r
-M: world-error error.\r
- "An error occurred while drawing the world " write\r
- dup world>> pprint-short "." print\r
- "This world has been deactivated to prevent cascading errors." print\r
- error>> error. ;\r
+! Copyright (C) 2006, 2011 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations debugger io io.streams.string
+kernel namespaces prettyprint ui ui.gadgets.worlds ;
+IN: ui.debugger
+
+: error-alert ( error -- )
+ [ "Error" ] dip [ print-error ] with-string-writer
+ system-alert ;
+
+! ( error -- )
+[ error-alert ] ui-error-hook set-global
+
+! ( error -- )
+[
+ ui-running? [ dup error-alert ] [ dup print-error ] if die
+] callback-error-hook set-global
+
+M: world-error error.
+ "An error occurred while drawing the world " write
+ dup world>> pprint-short "." print
+ "This world has been deactivated to prevent cascading errors." print
+ error>> error. ;
-IN: ui.gadgets.canvas.tests\r
-USING: ui.gadgets.canvas tools.test kernel ;\r
-\r
-{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as\r
+IN: ui.gadgets.canvas.tests
+USING: ui.gadgets.canvas tools.test kernel ;
+
+{ 1 0 } [ [ drop ] draw-canvas ] must-infer-as
[ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ;
-: delete-previous-character ( editor -- )
+: delete-previous-character ( editor -- )
char-elt editor-backspace ;
-: delete-next-character ( editor -- )
+: delete-next-character ( editor -- )
char-elt editor-delete ;
-: delete-previous-word ( editor -- )
+: delete-previous-word ( editor -- )
word-elt editor-backspace ;
-: delete-next-word ( editor -- )
+: delete-next-word ( editor -- )
word-elt editor-delete ;
-: delete-to-start-of-line ( editor -- )
+: delete-to-start-of-line ( editor -- )
one-line-elt editor-backspace ;
-: delete-to-end-of-line ( editor -- )
+: delete-to-end-of-line ( editor -- )
one-line-elt editor-delete ;
: delete-to-start-of-document ( editor -- )
[ dup select-word ] unless
gadget-selection ;
-: select-previous-character ( editor -- )
+: select-previous-character ( editor -- )
char-elt editor-select-prev ;
-: select-next-character ( editor -- )
+: select-next-character ( editor -- )
char-elt editor-select-next ;
-: select-previous-word ( editor -- )
+: select-previous-word ( editor -- )
word-elt editor-select-prev ;
-: select-next-word ( editor -- )
+: select-next-word ( editor -- )
word-elt editor-select-next ;
-: select-start-of-line ( editor -- )
+: select-start-of-line ( editor -- )
one-line-elt editor-select-prev ;
-: select-end-of-line ( editor -- )
+: select-end-of-line ( editor -- )
one-line-elt editor-select-next ;
-: select-start-of-document ( editor -- )
+: select-start-of-document ( editor -- )
doc-elt editor-select-prev ;
-: select-end-of-document ( editor -- )
+: select-end-of-document ( editor -- )
doc-elt editor-select-next ;
editor "selection" f {
'[ _ write ] make-pane <scroller>
{ 450 100 } >>pref-dim
<wrapper> ;
-
IN: ui.gadgets.prettyprint
! Don't print gadgets with RECT: syntax
-M: gadget pprint* pprint-tuple ;
\ No newline at end of file
+M: gadget pprint* pprint-tuple ;
[ call-next-method ] [
dup follows>>
[ update-scroller ] [ >>follows drop ] 2bi
- ] bi ;
+ ] bi ;
M: scroller focusable-child*
viewport>> ;
[ <down-button> f track-add ]
[ drop <gadget> { 1 1 } >>dim f track-add ]
} cleave ;
-
<source-editor> >>text
dup text>> <scroller> 1 track-add
dup revert ;
-
+
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
M: slot-editor focusable-child* text>> ;
f >>grab-input?
dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if
] [ drop ] if ;
-
+
: show-status ( string/f gadget -- )
dup find-world dup [
dup status>> [
] if ;
M: image-pen pen-pref-dim nip image>> image-dim ;
-
GENERIC: pen-pref-dim ( gadget pen -- dim )
-M: object pen-pref-dim 2drop { 0 0 } ;
\ No newline at end of file
+M: object pen-pref-dim 2drop { 0 0 } ;
(gl-rect) ;
M: solid pen-background
- nip color>> dup alpha>> 1 number= [ drop transparent ] unless ;
\ No newline at end of file
+ nip color>> dup alpha>> 1 number= [ drop transparent ] unless ;
M: tile-pen pen-background nip background>> ;
-M: tile-pen pen-foreground nip foreground>> ;
\ No newline at end of file
+M: tile-pen pen-foreground nip foreground>> ;
-! Copyright (C) 2009, 2010 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs cache kernel math math.vectors sequences\r
-fonts namespaces ui.text ui.text.private windows.uniscribe ;\r
-IN: ui.text.uniscribe\r
-\r
-SINGLETON: uniscribe-renderer\r
-\r
-M: uniscribe-renderer string-dim\r
- [ " " string-dim { 0 1 } v* ]\r
- [ cached-script-string size>> ] if-empty ;\r
-\r
-M: uniscribe-renderer flush-layout-cache\r
- cached-script-strings get-global purge-cache ;\r
-\r
-M: uniscribe-renderer string>image ( font string -- image loc )\r
- cached-script-string script-string>image { 0 0 } ;\r
-\r
-M: uniscribe-renderer x>offset ( x font string -- n )\r
- [ 2drop 0 ] [\r
- cached-script-string x>line-offset 0 = [ 1 + ] unless\r
- ] if-empty ;\r
-\r
-M: uniscribe-renderer offset>x ( n font string -- x )\r
- [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;\r
-\r
-M: uniscribe-renderer font-metrics ( font -- metrics )\r
- " " cached-script-string metrics>> clone f >>width ;\r
-\r
-M: uniscribe-renderer line-metrics ( font string -- metrics )\r
- [ " " line-metrics clone 0 >>width ]\r
- [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]\r
- if-empty ;\r
-\r
-uniscribe-renderer font-renderer set-global\r
+! Copyright (C) 2009, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs cache kernel math math.vectors sequences
+fonts namespaces ui.text ui.text.private windows.uniscribe ;
+IN: ui.text.uniscribe
+
+SINGLETON: uniscribe-renderer
+
+M: uniscribe-renderer string-dim
+ [ " " string-dim { 0 1 } v* ]
+ [ cached-script-string size>> ] if-empty ;
+
+M: uniscribe-renderer flush-layout-cache
+ cached-script-strings get-global purge-cache ;
+
+M: uniscribe-renderer string>image ( font string -- image loc )
+ cached-script-string script-string>image { 0 0 } ;
+
+M: uniscribe-renderer x>offset ( x font string -- n )
+ [ 2drop 0 ] [
+ cached-script-string x>line-offset 0 = [ 1 + ] unless
+ ] if-empty ;
+
+M: uniscribe-renderer offset>x ( n font string -- x )
+ [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;
+
+M: uniscribe-renderer font-metrics ( font -- metrics )
+ " " cached-script-string metrics>> clone f >>width ;
+
+M: uniscribe-renderer line-metrics ( font string -- metrics )
+ [ " " line-metrics clone 0 >>width ]
+ [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]
+ if-empty ;
+
+uniscribe-renderer font-renderer set-global
: add-history ( history -- )
dup forward>> delete-all
- dup back>> (add-history) ;
\ No newline at end of file
+ dup back>> (add-history) ;
dup <toolbar> { 10 10 } >>gap add-gadget
deploy-settings-theme
dup com-revert ;
-
+
: deploy-tool ( vocab -- )
vocab-name
[ <deploy-gadget> { 10 10 } <border> ]
:: <error-list-gadget> ( model -- gadget )
vertical \ error-list-gadget new-track
<error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
- dup visible-errors>> model <error-model> >>model
+ dup visible-errors>> model <error-model> >>model
f <model> >>source-file
f <model> >>error
dup <source-file-table> >>source-file-table
[ caret-loc ] [ drop caret-dim { 0 1 } v+ ] 2bi <rect> ;
: show-listener-popup ( interactor element popup -- )
- [ [ drop ] [ relevant-rect ] 2bi ] dip swap show-popup ;
\ No newline at end of file
+ [ [ drop ] [ relevant-rect ] 2bi ] dip swap show-popup ;
-IN: ui.tools.walker\r
-USING: help.markup help.syntax ui.commands ui.operations\r
-ui.render tools.walker sequences tools.continuations ;\r
-\r
-ARTICLE: "ui-walker-step" "Stepping through code"\r
-"If the current position points to a word, the various stepping commands behave as follows:"\r
-{ $list\r
- { { $link com-step } " executes the word and moves the current position one word further." }\r
- { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }\r
- { { $link com-out } " executes until the end of the current quotation." }\r
-}\r
-"If the current position points to a literal, the various stepping commands behave as follows:"\r
-{ $list\r
- { { $link com-step } " pushes the literal on the data stack." }\r
- { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." }\r
- { { $link com-out } " executes until the end of the current quotation." }\r
-}\r
-"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:"\r
-{ $code "{ 10 20 30 } [ 3 + . ] each" }\r
-"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"\r
-{ $code "[ break 3 + . ]" }\r
-"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit."\r
-$nl\r
-"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;\r
-\r
-ARTICLE: "ui-walker" "UI walker"\r
-"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
-$nl\r
-"Walkers are instances of " { $link walker-gadget } "."\r
-{ $subsections\r
- "ui-walker-step"\r
- "breakpoints"\r
-}\r
-{ $command-map walker-gadget "toolbar" }\r
-{ $command-map walker-gadget "multitouch" } ;\r
-\r
-ABOUT: "ui-walker"\r
+IN: ui.tools.walker
+USING: help.markup help.syntax ui.commands ui.operations
+ui.render tools.walker sequences tools.continuations ;
+
+ARTICLE: "ui-walker-step" "Stepping through code"
+"If the current position points to a word, the various stepping commands behave as follows:"
+{ $list
+ { { $link com-step } " executes the word and moves the current position one word further." }
+ { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }
+ { { $link com-out } " executes until the end of the current quotation." }
+}
+"If the current position points to a literal, the various stepping commands behave as follows:"
+{ $list
+ { { $link com-step } " pushes the literal on the data stack." }
+ { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." }
+ { { $link com-out } " executes until the end of the current quotation." }
+}
+"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:"
+{ $code "{ 10 20 30 } [ 3 + . ] each" }
+"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"
+{ $code "[ break 3 + . ]" }
+"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit."
+$nl
+"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;
+
+ARTICLE: "ui-walker" "UI walker"
+"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."
+$nl
+"Walkers are instances of " { $link walker-gadget } "."
+{ $subsections
+ "ui-walker-step"
+ "breakpoints"
+}
+{ $command-map walker-gadget "toolbar" }
+{ $command-map walker-gadget "multitouch" } ;
+
+ABOUT: "ui-walker"
add-toolbar
dup status>> self <thread-status> f track-add
dup traceback>> 1 track-add ;
-
+
: walker-help ( -- ) "ui-walker" com-browse ;
\ walker-help H{ { +nullary+ t } } define-command
-USING: io io.files splitting grouping unicode.collation\r
-sequences kernel io.encodings.utf8 math.parser math.order\r
-tools.test assocs words ;\r
-IN: unicode.collation.tests\r
-\r
-: parse-test ( -- strings )\r
- "vocab:unicode/collation/CollationTest_SHIFTED.txt"\r
- utf8 file-lines 5 tail\r
- [ ";" split1 drop " " split [ hex> ] "" map-as ] map ;\r
-\r
-: test-two ( str1 str2 -- )\r
- [ +lt+ ] -rot [ string<=> ] 2curry unit-test ;\r
-\r
-: test-equality ( str1 str2 -- ? ? ? ? )\r
- { primary= secondary= tertiary= quaternary= }\r
- [ execute( a b -- ? ) ] 2with map\r
- first4 ;\r
-\r
-[ f f f f ] [ "hello" "hi" test-equality ] unit-test\r
-[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test\r
-[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test\r
-[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test\r
-[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test\r
-[ { "good bye" "goodbye" "hello" "HELLO" } ]\r
-[ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ]\r
-unit-test\r
-\r
-parse-test 2 <clumps>\r
-[ test-two ] assoc-each\r
+USING: io io.files splitting grouping unicode.collation
+sequences kernel io.encodings.utf8 math.parser math.order
+tools.test assocs words ;
+IN: unicode.collation.tests
+
+: parse-test ( -- strings )
+ "vocab:unicode/collation/CollationTest_SHIFTED.txt"
+ utf8 file-lines 5 tail
+ [ ";" split1 drop " " split [ hex> ] "" map-as ] map ;
+
+: test-two ( str1 str2 -- )
+ [ +lt+ ] -rot [ string<=> ] 2curry unit-test ;
+
+: test-equality ( str1 str2 -- ? ? ? ? )
+ { primary= secondary= tertiary= quaternary= }
+ [ execute( a b -- ? ) ] 2with map
+ first4 ;
+
+[ f f f f ] [ "hello" "hi" test-equality ] unit-test
+[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test
+[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test
+[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test
+[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test
+[ { "good bye" "goodbye" "hello" "HELLO" } ]
+[ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ]
+unit-test
+
+parse-test 2 <clumps>
+[ test-two ] assoc-each
-! Copyright (C) 2008 Daniel Ehrenberg.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: sequences io.files io.encodings.ascii kernel splitting\r
-accessors math.parser ascii io assocs strings math namespaces make\r
-sorting combinators math.order arrays unicode.normalize unicode.data\r
-locals macros sequences.deep words unicode.breaks quotations\r
-combinators.short-circuit simple-flat-file ;\r
-IN: unicode.collation\r
-\r
-<PRIVATE\r
-SYMBOL: ducet\r
-\r
-TUPLE: weight primary secondary tertiary ignorable? ;\r
-\r
-: parse-weight ( string -- weight )\r
- "]" split but-last [\r
- weight new swap rest unclip CHAR: * = swapd >>ignorable?\r
- swap "." split first3 [ hex> ] tri@\r
- [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*\r
- ] map ;\r
-\r
-: parse-keys ( string -- chars )\r
- " " split [ hex> ] "" map-as ;\r
-\r
-: parse-ducet ( file -- ducet )\r
- data [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;\r
-\r
-"vocab:unicode/collation/allkeys.txt" parse-ducet ducet set-global\r
-\r
-! Fix up table for long contractions\r
-: help-one ( assoc key -- )\r
- ! Need to be more general? Not for DUCET, apparently\r
- 2 head 2dup swap key? [ 2drop ] [\r
- [ [ 1string of ] with { } map-as concat ]\r
- [ swap set-at ] 2bi\r
- ] if ;\r
-\r
-: insert-helpers ( assoc -- )\r
- dup keys [ length 3 >= ] filter\r
- [ help-one ] with each ;\r
-\r
-ducet get-global insert-helpers\r
-\r
-: base ( char -- base )\r
- {\r
- { [ dup 0x3400 0x4DB5 between? ] [ drop 0xFB80 ] } ! Extension A\r
- { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B\r
- { [ dup 0x4E00 0x9FC3 between? ] [ drop 0xFB40 ] } ! CJK\r
- [ drop 0xFBC0 ] ! Other\r
- } cond ;\r
-\r
-: AAAA ( char -- weight )\r
- [ base ] [ -15 shift ] bi + 0x20 2 f weight boa ;\r
-\r
-: BBBB ( char -- weight )\r
- 0x7FFF bitand 0x8000 bitor 0 0 f weight boa ;\r
-\r
-: illegal? ( char -- ? )\r
- { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;\r
-\r
-: derive-weight ( char -- weights )\r
- first dup illegal?\r
- [ drop { } ]\r
- [ [ AAAA ] [ BBBB ] bi 2array ] if ;\r
-\r
-: building-last ( -- char )\r
- building get empty? [ 0 ] [ building get last last ] if ;\r
-\r
-: blocked? ( char -- ? )\r
- combining-class dup { 0 f } member?\r
- [ drop building-last non-starter? ]\r
- [ building-last combining-class = ] if ;\r
-\r
-: possible-bases ( -- slice-of-building )\r
- building get dup [ first non-starter? not ] find-last\r
- drop [ 0 ] unless* tail-slice ;\r
-\r
-:: ?combine ( char slice i -- ? )\r
- i slice nth char suffix :> str\r
- str ducet get-global key? dup\r
- [ str i slice set-nth ] when ;\r
-\r
-: add ( char -- )\r
- dup blocked? [ 1string , ] [\r
- dup possible-bases dup length iota\r
- [ ?combine ] 2with any?\r
- [ drop ] [ 1string , ] if\r
- ] if ;\r
-\r
-: string>graphemes ( string -- graphemes )\r
- [ [ add ] each ] { } make ;\r
-\r
-: graphemes>weights ( graphemes -- weights )\r
- [\r
- dup weight? [ 1array ] ! From tailoring\r
- [ dup ducet get-global at [ ] [ derive-weight ] ?if ] if\r
- ] { } map-as concat ;\r
-\r
-: append-weights ( weights quot -- )\r
- [ [ ignorable?>> ] reject ] dip\r
- map [ zero? ] reject % 0 , ; inline\r
-\r
-: variable-weight ( weight -- )\r
- dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if , ;\r
-\r
-: weights>bytes ( weights -- byte-array )\r
- [\r
- {\r
- [ [ primary>> ] append-weights ]\r
- [ [ secondary>> ] append-weights ]\r
- [ [ tertiary>> ] append-weights ]\r
- [ [ variable-weight ] each ]\r
- } cleave\r
- ] { } make ;\r
-PRIVATE>\r
-\r
-: completely-ignorable? ( weight -- ? )\r
- [ primary>> ] [ secondary>> ] [ tertiary>> ] tri\r
- [ zero? ] tri@ and and ;\r
-\r
-: filter-ignorable ( weights -- weights' )\r
- f swap [\r
- [ nip ] [ primary>> zero? and ] 2bi\r
- [ swap ignorable?>> or ]\r
- [ swap completely-ignorable? or not ] 2bi\r
- ] filter nip ;\r
-\r
-: collation-key ( string -- key )\r
- nfd string>graphemes graphemes>weights\r
- filter-ignorable weights>bytes ;\r
-\r
-<PRIVATE\r
-: insensitive= ( str1 str2 levels-removed -- ? )\r
- [\r
- [ collation-key ] dip\r
- [ [ 0 = not ] trim-tail but-last ] times\r
- ] curry same? ;\r
-PRIVATE>\r
-\r
-: primary= ( str1 str2 -- ? )\r
- 3 insensitive= ;\r
-\r
-: secondary= ( str1 str2 -- ? )\r
- 2 insensitive= ;\r
-\r
-: tertiary= ( str1 str2 -- ? )\r
- 1 insensitive= ;\r
-\r
-: quaternary= ( str1 str2 -- ? )\r
- 0 insensitive= ;\r
-\r
-: w/collation-key ( str -- {str,key} )\r
- [ collation-key ] keep 2array ;\r
-\r
-: sort-strings ( strings -- sorted )\r
- [ w/collation-key ] map natural-sort values ;\r
-\r
-: string<=> ( str1 str2 -- <=> )\r
- [ w/collation-key ] compare ;\r
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences io.files io.encodings.ascii kernel splitting
+accessors math.parser ascii io assocs strings math namespaces make
+sorting combinators math.order arrays unicode.normalize unicode.data
+locals macros sequences.deep words unicode.breaks quotations
+combinators.short-circuit simple-flat-file ;
+IN: unicode.collation
+
+<PRIVATE
+SYMBOL: ducet
+
+TUPLE: weight primary secondary tertiary ignorable? ;
+
+: parse-weight ( string -- weight )
+ "]" split but-last [
+ weight new swap rest unclip CHAR: * = swapd >>ignorable?
+ swap "." split first3 [ hex> ] tri@
+ [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*
+ ] map ;
+
+: parse-keys ( string -- chars )
+ " " split [ hex> ] "" map-as ;
+
+: parse-ducet ( file -- ducet )
+ data [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;
+
+"vocab:unicode/collation/allkeys.txt" parse-ducet ducet set-global
+
+! Fix up table for long contractions
+: help-one ( assoc key -- )
+ ! Need to be more general? Not for DUCET, apparently
+ 2 head 2dup swap key? [ 2drop ] [
+ [ [ 1string of ] with { } map-as concat ]
+ [ swap set-at ] 2bi
+ ] if ;
+
+: insert-helpers ( assoc -- )
+ dup keys [ length 3 >= ] filter
+ [ help-one ] with each ;
+
+ducet get-global insert-helpers
+
+: base ( char -- base )
+ {
+ { [ dup 0x3400 0x4DB5 between? ] [ drop 0xFB80 ] } ! Extension A
+ { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B
+ { [ dup 0x4E00 0x9FC3 between? ] [ drop 0xFB40 ] } ! CJK
+ [ drop 0xFBC0 ] ! Other
+ } cond ;
+
+: AAAA ( char -- weight )
+ [ base ] [ -15 shift ] bi + 0x20 2 f weight boa ;
+
+: BBBB ( char -- weight )
+ 0x7FFF bitand 0x8000 bitor 0 0 f weight boa ;
+
+: illegal? ( char -- ? )
+ { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;
+
+: derive-weight ( char -- weights )
+ first dup illegal?
+ [ drop { } ]
+ [ [ AAAA ] [ BBBB ] bi 2array ] if ;
+
+: building-last ( -- char )
+ building get empty? [ 0 ] [ building get last last ] if ;
+
+: blocked? ( char -- ? )
+ combining-class dup { 0 f } member?
+ [ drop building-last non-starter? ]
+ [ building-last combining-class = ] if ;
+
+: possible-bases ( -- slice-of-building )
+ building get dup [ first non-starter? not ] find-last
+ drop [ 0 ] unless* tail-slice ;
+
+:: ?combine ( char slice i -- ? )
+ i slice nth char suffix :> str
+ str ducet get-global key? dup
+ [ str i slice set-nth ] when ;
+
+: add ( char -- )
+ dup blocked? [ 1string , ] [
+ dup possible-bases dup length iota
+ [ ?combine ] 2with any?
+ [ drop ] [ 1string , ] if
+ ] if ;
+
+: string>graphemes ( string -- graphemes )
+ [ [ add ] each ] { } make ;
+
+: graphemes>weights ( graphemes -- weights )
+ [
+ dup weight? [ 1array ] ! From tailoring
+ [ dup ducet get-global at [ ] [ derive-weight ] ?if ] if
+ ] { } map-as concat ;
+
+: append-weights ( weights quot -- )
+ [ [ ignorable?>> ] reject ] dip
+ map [ zero? ] reject % 0 , ; inline
+
+: variable-weight ( weight -- )
+ dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if , ;
+
+: weights>bytes ( weights -- byte-array )
+ [
+ {
+ [ [ primary>> ] append-weights ]
+ [ [ secondary>> ] append-weights ]
+ [ [ tertiary>> ] append-weights ]
+ [ [ variable-weight ] each ]
+ } cleave
+ ] { } make ;
+PRIVATE>
+
+: completely-ignorable? ( weight -- ? )
+ [ primary>> ] [ secondary>> ] [ tertiary>> ] tri
+ [ zero? ] tri@ and and ;
+
+: filter-ignorable ( weights -- weights' )
+ f swap [
+ [ nip ] [ primary>> zero? and ] 2bi
+ [ swap ignorable?>> or ]
+ [ swap completely-ignorable? or not ] 2bi
+ ] filter nip ;
+
+: collation-key ( string -- key )
+ nfd string>graphemes graphemes>weights
+ filter-ignorable weights>bytes ;
+
+<PRIVATE
+: insensitive= ( str1 str2 levels-removed -- ? )
+ [
+ [ collation-key ] dip
+ [ [ 0 = not ] trim-tail but-last ] times
+ ] curry same? ;
+PRIVATE>
+
+: primary= ( str1 str2 -- ? )
+ 3 insensitive= ;
+
+: secondary= ( str1 str2 -- ? )
+ 2 insensitive= ;
+
+: tertiary= ( str1 str2 -- ? )
+ 1 insensitive= ;
+
+: quaternary= ( str1 str2 -- ? )
+ 0 insensitive= ;
+
+: w/collation-key ( str -- {str,key} )
+ [ collation-key ] keep 2array ;
+
+: sort-strings ( strings -- sorted )
+ [ w/collation-key ] map natural-sort values ;
+
+: string<=> ( str1 str2 -- <=> )
+ [ w/collation-key ] compare ;
-! Copyright (C) 2009 Daniel Ehrenberg\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.syntax help.markup strings ;\r
-IN: unicode.script\r
-\r
-ABOUT: "unicode.script"\r
-\r
-ARTICLE: "unicode.script" "Unicode script properties"\r
-"The unicode standard gives every character a script. Note that this is different from a language, and that it is non-trivial to detect language from a string. To get the script of a character, use"\r
-{ $subsections script-of } ;\r
-\r
-HELP: script-of\r
-{ $values { "char" "a code point" } { "script" string } }\r
-{ $description "Finds the script of the given Unicode code point, represented as a string." } ;\r
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup strings ;
+IN: unicode.script
+
+ABOUT: "unicode.script"
+
+ARTICLE: "unicode.script" "Unicode script properties"
+"The unicode standard gives every character a script. Note that this is different from a language, and that it is non-trivial to detect language from a string. To get the script of a character, use"
+{ $subsections script-of } ;
+
+HELP: script-of
+{ $values { "char" "a code point" } { "script" string } }
+{ $description "Finds the script of the given Unicode code point, represented as a string." } ;
-USING: unicode.script tools.test ;\r
-\r
-[ "Latin" ] [ CHAR: a script-of ] unit-test\r
-[ "Common" ] [ 0 script-of ] unit-test\r
+USING: unicode.script tools.test ;
+
+[ "Latin" ] [ CHAR: a script-of ] unit-test
+[ "Common" ] [ 0 script-of ] unit-test
] if* ;
PRIVATE>
-
+
GENERIC: user-groups ( string/id -- seq )
M: string user-groups ( string -- seq )
- (user-groups) ;
+ (user-groups) ;
M: integer user-groups ( id -- seq )
user-name (user-groups) ;
-
+
: all-groups ( -- seq )
[ unix.ffi:getgrent dup ] [ group-struct>group ] produce nip
endgrent ;
[ unix.ffi:setegid ] unix-system-call drop ; inline
PRIVATE>
-
+
M: integer set-real-group ( id -- )
(set-real-group) ;
M: string set-real-group ( string -- )
?group-id (set-real-group) ;
-M: integer set-effective-group ( id -- )
+M: integer set-effective-group ( id -- )
(set-effective-group) ;
M: string set-effective-group ( string -- )
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.c-types alien.syntax math math.bitwise classes.struct\r
-literals ;\r
-IN: unix.linux.inotify\r
-\r
-STRUCT: inotify-event\r
- { wd int }\r
- { mask uint }\r
- { cookie uint }\r
- { len uint }\r
- { name char[0] } ;\r
-\r
-CONSTANT: IN_ACCESS 0x1 ! File was accessed\r
-CONSTANT: IN_MODIFY 0x2 ! File was modified\r
-CONSTANT: IN_ATTRIB 0x4 ! Metadata changed\r
-CONSTANT: IN_CLOSE_WRITE 0x8 ! Writtable file was closed\r
-CONSTANT: IN_CLOSE_NOWRITE 0x10 ! Unwrittable file closed\r
-CONSTANT: IN_OPEN 0x20 ! File was opened\r
-CONSTANT: IN_MOVED_FROM 0x40 ! File was moved from X\r
-CONSTANT: IN_MOVED_TO 0x80 ! File was moved to Y\r
-CONSTANT: IN_CREATE 0x100 ! Subfile was created\r
-CONSTANT: IN_DELETE 0x200 ! Subfile was deleted\r
-CONSTANT: IN_DELETE_SELF 0x400 ! Self was deleted\r
-CONSTANT: IN_MOVE_SELF 0x800 ! Self was moved\r
-\r
-CONSTANT: IN_UNMOUNT 0x2000 ! Backing fs was unmounted\r
-CONSTANT: IN_Q_OVERFLOW 0x4000 ! Event queued overflowed\r
-CONSTANT: IN_IGNORED 0x8000 ! File was ignored\r
-\r
-CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE }\r
-CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO }\r
-\r
-CONSTANT: IN_ONLYDIR 0x1000000 ! only watch the path if it is a directory\r
-CONSTANT: IN_DONT_FOLLOW 0x2000000 ! don't follow a sym link\r
-CONSTANT: IN_MASK_ADD 0x20000000 ! add to the mask of an already existing watch\r
-CONSTANT: IN_ISDIR 0x40000000 ! event occurred against dir\r
-CONSTANT: IN_ONESHOT 0x80000000 ! only send event once\r
-\r
-CONSTANT: IN_CHANGE_EVENTS \r
- flags{\r
- IN_MODIFY IN_ATTRIB IN_MOVED_FROM\r
- IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
- IN_MOVE_SELF\r
- }\r
-\r
-CONSTANT: IN_ALL_EVENTS\r
- flags{\r
- IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE\r
- IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM\r
- IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
- IN_MOVE_SELF\r
- }\r
-\r
-FUNCTION: int inotify_init ( ) ;\r
-FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ;\r
-FUNCTION: int inotify_rm_watch ( int fd, uint wd ) ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax math math.bitwise classes.struct
+literals ;
+IN: unix.linux.inotify
+
+STRUCT: inotify-event
+ { wd int }
+ { mask uint }
+ { cookie uint }
+ { len uint }
+ { name char[0] } ;
+
+CONSTANT: IN_ACCESS 0x1 ! File was accessed
+CONSTANT: IN_MODIFY 0x2 ! File was modified
+CONSTANT: IN_ATTRIB 0x4 ! Metadata changed
+CONSTANT: IN_CLOSE_WRITE 0x8 ! Writtable file was closed
+CONSTANT: IN_CLOSE_NOWRITE 0x10 ! Unwrittable file closed
+CONSTANT: IN_OPEN 0x20 ! File was opened
+CONSTANT: IN_MOVED_FROM 0x40 ! File was moved from X
+CONSTANT: IN_MOVED_TO 0x80 ! File was moved to Y
+CONSTANT: IN_CREATE 0x100 ! Subfile was created
+CONSTANT: IN_DELETE 0x200 ! Subfile was deleted
+CONSTANT: IN_DELETE_SELF 0x400 ! Self was deleted
+CONSTANT: IN_MOVE_SELF 0x800 ! Self was moved
+
+CONSTANT: IN_UNMOUNT 0x2000 ! Backing fs was unmounted
+CONSTANT: IN_Q_OVERFLOW 0x4000 ! Event queued overflowed
+CONSTANT: IN_IGNORED 0x8000 ! File was ignored
+
+CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE }
+CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO }
+
+CONSTANT: IN_ONLYDIR 0x1000000 ! only watch the path if it is a directory
+CONSTANT: IN_DONT_FOLLOW 0x2000000 ! don't follow a sym link
+CONSTANT: IN_MASK_ADD 0x20000000 ! add to the mask of an already existing watch
+CONSTANT: IN_ISDIR 0x40000000 ! event occurred against dir
+CONSTANT: IN_ONESHOT 0x80000000 ! only send event once
+
+CONSTANT: IN_CHANGE_EVENTS
+ flags{
+ IN_MODIFY IN_ATTRIB IN_MOVED_FROM
+ IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
+ IN_MOVE_SELF
+ }
+
+CONSTANT: IN_ALL_EVENTS
+ flags{
+ IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE
+ IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM
+ IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
+ IN_MOVE_SELF
+ }
+
+FUNCTION: int inotify_init ( ) ;
+FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ;
+FUNCTION: int inotify_rm_watch ( int fd, uint wd ) ;
TYPEDEF: ulong __uword_type
TYPEDEF: long __slongword_type
TYPEDEF: uint __u32_type
-TYPEDEF: int __s32_type
+TYPEDEF: int __s32_type
TYPEDEF: __uquad_type dev_t
TYPEDEF: __ulongword_type ino_t
?user-id (set-real-user) ;
M: integer set-effective-user ( id -- )
- (set-effective-user) ;
+ (set-effective-user) ;
M: string set-effective-user ( string -- )
?user-id (set-effective-user) ;
[ ut_tv>> timeval>unix-time >>timestamp ]
[ ut_host>> __UT_HOSTSIZE memory>string >>host ]
} cleave ;
-
: v-mode ( str -- str )
dup mode-names member? [
- "not a valid syntax mode" throw
+ "not a valid syntax mode" throw
] unless ;
: luhn? ( str -- ? )
-USING: help.markup help.syntax strings vocabs.loader\r
-sequences vocabs ;\r
-IN: vocabs.hierarchy\r
-\r
-ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools"\r
-"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not. A prefix is the first part of a vocabulary name."\r
-$nl\r
-"Loading vocabulary hierarchies:"\r
-{ $subsections\r
- load\r
- load-all\r
- load-root\r
- load-from-root\r
-}\r
-"Getting all vocabularies from disk:"\r
-{ $subsections\r
- all-disk-vocabs-by-root\r
- all-disk-vocabs-recursive\r
-}\r
-"Getting all vocabularies from disk whose names which match a string prefix:"\r
-{ $subsections\r
- disk-vocabs-for-prefix\r
- disk-vocabs-recursive-for-prefix\r
-}\r
-"Words for modifying output:"\r
-{ $subsections\r
- no-roots\r
- no-prefixes\r
- filter-vocabs\r
-}\r
-"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"\r
-{ $subsections\r
- all-tags\r
- all-authors\r
-} ;\r
-\r
-ABOUT: "vocabs.hierarchy"\r
-\r
-HELP: load\r
-{ $values { "prefix" string } }\r
-{ $description "Load all vocabularies that match the provided prefix." }\r
-{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ;\r
-\r
-HELP: load-all\r
-{ $description "Load all vocabularies in the source tree." } ;\r
-\r
-HELP: load-from-root\r
-{ $values\r
- { "root" "a vocaulary root" } { "prefix" string }\r
-}\r
-{ $description "Attempts to load all of the vocabularies with a certain prefix from a vocabulary root." } ;\r
-\r
-HELP: load-root\r
-{ $values\r
- { "root" "a vocabulary root" }\r
-}\r
-{ $description "Attempts to load all of the vocabularies in a vocabulary root." } ;\r
+USING: help.markup help.syntax strings vocabs.loader
+sequences vocabs ;
+IN: vocabs.hierarchy
+
+ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools"
+"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not. A prefix is the first part of a vocabulary name."
+$nl
+"Loading vocabulary hierarchies:"
+{ $subsections
+ load
+ load-all
+ load-root
+ load-from-root
+}
+"Getting all vocabularies from disk:"
+{ $subsections
+ all-disk-vocabs-by-root
+ all-disk-vocabs-recursive
+}
+"Getting all vocabularies from disk whose names which match a string prefix:"
+{ $subsections
+ disk-vocabs-for-prefix
+ disk-vocabs-recursive-for-prefix
+}
+"Words for modifying output:"
+{ $subsections
+ no-roots
+ no-prefixes
+ filter-vocabs
+}
+"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"
+{ $subsections
+ all-tags
+ all-authors
+} ;
+
+ABOUT: "vocabs.hierarchy"
+
+HELP: load
+{ $values { "prefix" string } }
+{ $description "Load all vocabularies that match the provided prefix." }
+{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ;
+
+HELP: load-all
+{ $description "Load all vocabularies in the source tree." } ;
+
+HELP: load-from-root
+{ $values
+ { "root" "a vocaulary root" } { "prefix" string }
+}
+{ $description "Attempts to load all of the vocabularies with a certain prefix from a vocabulary root." } ;
+
+HELP: load-root
+{ $values
+ { "root" "a vocabulary root" }
+}
+{ $description "Attempts to load all of the vocabularies in a vocabulary root." } ;
-! Copyright (C) 2007, 2009 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays assocs combinators.short-circuit fry\r
-io.directories io.files io.files.types io.pathnames kernel make\r
-memoize namespaces sequences sorting splitting vocabs sets\r
-vocabs.loader vocabs.metadata vocabs.errors ;\r
-IN: vocabs.hierarchy\r
-\r
-TUPLE: vocab-prefix name ;\r
-\r
-C: <vocab-prefix> vocab-prefix\r
-\r
-M: vocab-prefix vocab-name name>> ;\r
-\r
-<PRIVATE\r
-\r
-: visible-dirs ( seq -- seq' )\r
- [\r
- {\r
- [ type>> +directory+ = ]\r
- [ name>> "." head? not ]\r
- } 1&&\r
- ] filter ;\r
-\r
-: vocab-subdirs ( dir -- dirs )\r
- directory-entries visible-dirs [ name>> ] map! natural-sort ;\r
-\r
-: vocab-dir? ( root name -- ? )\r
- over\r
- [ ".factor" append-vocab-dir append-path exists? ]\r
- [ 2drop f ]\r
- if ;\r
-\r
-ERROR: vocab-root-required root ;\r
-\r
-: ensure-vocab-root ( root -- root )\r
- dup vocab-roots get member? [ vocab-root-required ] unless ;\r
-\r
-: ensure-vocab-root/prefix ( root prefix -- root prefix )\r
- [ ensure-vocab-root ] [ check-vocab-name ] bi* ;\r
-\r
-: (disk-vocab-children) ( root prefix -- vocabs )\r
- check-vocab-name\r
- [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
- [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]\r
- [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]\r
- 2tri ;\r
-\r
-: ((disk-vocabs-recursive)) ( root prefix -- )\r
- dupd vocab-name (disk-vocab-children) [ % ] keep\r
- [ ((disk-vocabs-recursive)) ] with each ;\r
-\r
-: (disk-vocabs-recursive) ( root prefix -- seq )\r
- [ ensure-vocab-root ] dip\r
- [ ((disk-vocabs-recursive)) ] { } make ;\r
-\r
-: no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;\r
-\r
-: one-level-only? ( name prefix -- ? )\r
- ?head [ "." split1 nip not ] [ drop f ] if ;\r
-\r
-: unrooted-disk-vocabs ( prefix -- seq )\r
- [ loaded-vocab-names no-rooted ] dip\r
- dup empty? [ CHAR: . suffix ] unless\r
- '[ vocab-name _ one-level-only? ] filter ;\r
-\r
-: unrooted-disk-vocabs-recursive ( prefix -- seq )\r
- loaded-child-vocab-names no-rooted ;\r
-\r
-PRIVATE>\r
-\r
-: no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;\r
-\r
-: convert-prefixes ( seq -- seq' )\r
- [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;\r
-\r
-: remove-redundant-prefixes ( seq -- seq' )\r
- #! Hack.\r
- [ vocab-prefix? ] partition\r
- [\r
- [ vocab-name ] map fast-set\r
- '[ name>> _ in? ] reject\r
- convert-prefixes\r
- ] keep\r
- append ;\r
-\r
-: no-roots ( assoc -- seq ) values concat ;\r
-\r
-: filter-vocabs ( assoc -- seq )\r
- no-roots no-prefixes members ;\r
-\r
-: disk-vocabs-for-prefix ( prefix -- assoc )\r
- [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ]\r
- [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ]\r
- bi suffix ;\r
-\r
-: all-disk-vocabs-by-root ( -- assoc )\r
- "" disk-vocabs-for-prefix ;\r
-\r
-: disk-vocabs-recursive-for-prefix ( prefix -- assoc )\r
- [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ]\r
- [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]\r
- bi suffix ;\r
-\r
-MEMO: all-disk-vocabs-recursive ( -- assoc )\r
- "" disk-vocabs-recursive-for-prefix ;\r
-\r
-: all-disk-vocab-names ( -- seq )\r
- all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ;\r
-\r
-: disk-child-vocab-names ( prefix -- seq )\r
- disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ;\r
-\r
-<PRIVATE\r
-\r
-: collect-vocabs ( quot -- seq )\r
- [ all-disk-vocabs-recursive filter-vocabs ] dip\r
- gather natural-sort ; inline\r
-\r
-: maybe-include-root/prefix ( root prefix -- vocab-link/f )\r
- over [\r
- [ find-vocab-root = ] keep swap\r
- ] [\r
- nip dup find-vocab-root\r
- ] if [ >vocab-link ] [ drop f ] if ;\r
-\r
-PRIVATE>\r
-\r
-: disk-vocabs-in-root/prefix ( root prefix -- seq )\r
- [ (disk-vocabs-recursive) ]\r
- [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;\r
-\r
-: disk-vocabs-in-root ( root -- seq )\r
- "" disk-vocabs-in-root/prefix ;\r
-\r
-: (load-from-root) ( root prefix -- failures )\r
- disk-vocabs-in-root/prefix\r
- [ don't-load? ] reject no-prefixes\r
- require-all ;\r
-\r
-: load-from-root ( root prefix -- )\r
- (load-from-root) load-failures. ;\r
-\r
-: load-root ( root -- )\r
- "" load-from-root ;\r
-\r
-: (load) ( prefix -- failures )\r
- [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ;\r
-\r
-: load ( prefix -- )\r
- (load) load-failures. ;\r
-\r
-: load-all ( -- )\r
- "" load ;\r
-\r
-MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
-\r
-MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators.short-circuit fry
+io.directories io.files io.files.types io.pathnames kernel make
+memoize namespaces sequences sorting splitting vocabs sets
+vocabs.loader vocabs.metadata vocabs.errors ;
+IN: vocabs.hierarchy
+
+TUPLE: vocab-prefix name ;
+
+C: <vocab-prefix> vocab-prefix
+
+M: vocab-prefix vocab-name name>> ;
+
+<PRIVATE
+
+: visible-dirs ( seq -- seq' )
+ [
+ {
+ [ type>> +directory+ = ]
+ [ name>> "." head? not ]
+ } 1&&
+ ] filter ;
+
+: vocab-subdirs ( dir -- dirs )
+ directory-entries visible-dirs [ name>> ] map! natural-sort ;
+
+: vocab-dir? ( root name -- ? )
+ over
+ [ ".factor" append-vocab-dir append-path exists? ]
+ [ 2drop f ]
+ if ;
+
+ERROR: vocab-root-required root ;
+
+: ensure-vocab-root ( root -- root )
+ dup vocab-roots get member? [ vocab-root-required ] unless ;
+
+: ensure-vocab-root/prefix ( root prefix -- root prefix )
+ [ ensure-vocab-root ] [ check-vocab-name ] bi* ;
+
+: (disk-vocab-children) ( root prefix -- vocabs )
+ check-vocab-name
+ [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
+ [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]
+ [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]
+ 2tri ;
+
+: ((disk-vocabs-recursive)) ( root prefix -- )
+ dupd vocab-name (disk-vocab-children) [ % ] keep
+ [ ((disk-vocabs-recursive)) ] with each ;
+
+: (disk-vocabs-recursive) ( root prefix -- seq )
+ [ ensure-vocab-root ] dip
+ [ ((disk-vocabs-recursive)) ] { } make ;
+
+: no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;
+
+: one-level-only? ( name prefix -- ? )
+ ?head [ "." split1 nip not ] [ drop f ] if ;
+
+: unrooted-disk-vocabs ( prefix -- seq )
+ [ loaded-vocab-names no-rooted ] dip
+ dup empty? [ CHAR: . suffix ] unless
+ '[ vocab-name _ one-level-only? ] filter ;
+
+: unrooted-disk-vocabs-recursive ( prefix -- seq )
+ loaded-child-vocab-names no-rooted ;
+
+PRIVATE>
+
+: no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;
+
+: convert-prefixes ( seq -- seq' )
+ [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
+
+: remove-redundant-prefixes ( seq -- seq' )
+ #! Hack.
+ [ vocab-prefix? ] partition
+ [
+ [ vocab-name ] map fast-set
+ '[ name>> _ in? ] reject
+ convert-prefixes
+ ] keep
+ append ;
+
+: no-roots ( assoc -- seq ) values concat ;
+
+: filter-vocabs ( assoc -- seq )
+ no-roots no-prefixes members ;
+
+: disk-vocabs-for-prefix ( prefix -- assoc )
+ [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ]
+ [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ]
+ bi suffix ;
+
+: all-disk-vocabs-by-root ( -- assoc )
+ "" disk-vocabs-for-prefix ;
+
+: disk-vocabs-recursive-for-prefix ( prefix -- assoc )
+ [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ]
+ [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]
+ bi suffix ;
+
+MEMO: all-disk-vocabs-recursive ( -- assoc )
+ "" disk-vocabs-recursive-for-prefix ;
+
+: all-disk-vocab-names ( -- seq )
+ all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ;
+
+: disk-child-vocab-names ( prefix -- seq )
+ disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ;
+
+<PRIVATE
+
+: collect-vocabs ( quot -- seq )
+ [ all-disk-vocabs-recursive filter-vocabs ] dip
+ gather natural-sort ; inline
+
+: maybe-include-root/prefix ( root prefix -- vocab-link/f )
+ over [
+ [ find-vocab-root = ] keep swap
+ ] [
+ nip dup find-vocab-root
+ ] if [ >vocab-link ] [ drop f ] if ;
+
+PRIVATE>
+
+: disk-vocabs-in-root/prefix ( root prefix -- seq )
+ [ (disk-vocabs-recursive) ]
+ [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;
+
+: disk-vocabs-in-root ( root -- seq )
+ "" disk-vocabs-in-root/prefix ;
+
+: (load-from-root) ( root prefix -- failures )
+ disk-vocabs-in-root/prefix
+ [ don't-load? ] reject no-prefixes
+ require-all ;
+
+: load-from-root ( root prefix -- )
+ (load-from-root) load-failures. ;
+
+: load-root ( root -- )
+ "" load-from-root ;
+
+: (load) ( prefix -- failures )
+ [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ;
+
+: load ( prefix -- )
+ (load) load-failures. ;
+
+: load-all ( -- )
+ "" load ;
+
+MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
+
+MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;
TokenMandatoryPolicy
TokenLogonSid
MaxTokenInfoClass ;
-
+
TYPEDEF: TOKEN_INFORMATION_CLASS* PTOKEN_INFORMATION_CLASS
TYPEDEF: uint ALG_ID
! : WmiSetSingleItemW ;
! : Wow64Win32ApiEntry ;
! : WriteEncryptedFileRaw ;
-
-
-USING: help.markup help.syntax io kernel math quotations\r
-multiline destructors ;\r
-IN: windows.com\r
-\r
-HELP: com-query-interface\r
-{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }\r
-{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be released using " { $link com-release } " when it is no longer needed." } ;\r
-\r
-HELP: com-add-ref\r
-{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
-{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ;\r
-\r
-HELP: com-release\r
-{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
-{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;\r
-\r
-HELP: &com-release\r
-{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
-{ $description "Marks the given COM interface for unconditional release via " { $link com-release } " at the end of the enclosing " { $link with-destructors } " scope." } ;\r
-\r
-HELP: |com-release\r
-{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
-{ $description "Marks the given COM interface for release via " { $link com-release } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;\r
-\r
-{ com-release &com-release |com-release } related-words\r
-\r
+USING: help.markup help.syntax io kernel math quotations
+multiline destructors ;
+IN: windows.com
+
+HELP: com-query-interface
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }
+{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be released using " { $link com-release } " when it is no longer needed." } ;
+
+HELP: com-add-ref
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "A small wrapper around " { $link IUnknown::AddRef } ". Increments the reference count on " { $snippet "interface" } ", keeping it on the stack. The reference count must be decremented with " { $link com-release } " when the reference is no longer held." } ;
+
+HELP: com-release
+{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "A small wrapper around " { $link IUnknown::Release } ". Decrements the reference count on " { $snippet "interface" } ", releasing the underlying object if the reference count has reached zero." } ;
+
+HELP: &com-release
+{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "Marks the given COM interface for unconditional release via " { $link com-release } " at the end of the enclosing " { $link with-destructors } " scope." } ;
+
+HELP: |com-release
+{ $values { "alien" "pointer to a COM interface implementing " { $snippet "IUnknown" } } }
+{ $description "Marks the given COM interface for release via " { $link com-release } " in the event of an error at the end of the enclosing " { $link with-destructors } " scope." } ;
+
+{ com-release &com-release |com-release } related-words
+
over [ com-release ] curry [ ] cleanup ; inline
DESTRUCTOR: com-release
-
-
-USING: help.markup help.syntax io kernel math quotations\r
-alien windows.com windows.com.syntax continuations\r
-destructors ;\r
-IN: windows.com.wrapper\r
-\r
-HELP: <com-wrapper>\r
-{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } }\r
-{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }\r
-{ $code """\r
-COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}\r
- HRESULT returnOK ( )\r
- HRESULT returnError ( ) ;\r
-\r
-COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}\r
- int getX ( )\r
- void setX ( int newX ) ;\r
-\r
-COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}\r
- int xPlus ( int y )\r
- int xMulAdd ( int mul, int add ) ;\r
-\r
-{\r
- { "IInherited" {\r
- [ drop S_OK ] ! ISimple::returnOK\r
- [ drop E_FAIL ] ! ISimple::returnError\r
- [ x>> ] ! IInherited::getX\r
- [ >>x drop ] ! IInherited::setX\r
- } }\r
- { "IUnrelated" {\r
- [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus\r
- [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd\r
- } }\r
-} <com-wrapper>""" } ;\r
-\r
-HELP: com-wrap\r
-{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } }\r
-{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ;\r
-\r
-HELP: com-wrapper\r
-{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link <com-wrapper> } " constructor and applied to a Factor object using " { $link com-wrap } ". When no longer needed, release the com-wrapper's internally allocated data with " { $link dispose } "." } ;\r
+USING: help.markup help.syntax io kernel math quotations
+alien windows.com windows.com.syntax continuations
+destructors ;
+IN: windows.com.wrapper
+
+HELP: <com-wrapper>
+{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } }
+{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }
+{ $code """
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+ HRESULT returnOK ( )
+ HRESULT returnError ( ) ;
+
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
+ int getX ( )
+ void setX ( int newX ) ;
+
+COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
+ int xPlus ( int y )
+ int xMulAdd ( int mul, int add ) ;
+
+{
+ { "IInherited" {
+ [ drop S_OK ] ! ISimple::returnOK
+ [ drop E_FAIL ] ! ISimple::returnError
+ [ x>> ] ! IInherited::getX
+ [ >>x drop ] ! IInherited::setX
+ } }
+ { "IUnrelated" {
+ [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
+ [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd
+ } }
+} <com-wrapper>""" } ;
+
+HELP: com-wrap
+{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } }
+{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ;
+
+HELP: com-wrapper
+{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link <com-wrapper> } " constructor and applied to a Factor object using " { $link com-wrap } ". When no longer needed, release the com-wrapper's internally allocated data with " { $link dispose } "." } ;
[ drop f ] suffix ;
: (make-query-interface) ( interfaces -- quot )
- (query-interface-cases)
+ (query-interface-cases)
'[
swap _ case
[
[ (make-add-ref) ]
[ (make-release) ] tri
3array ;
-
+
: (thunk) ( n -- quot )
dup 0 =
[ drop [ ] ]
FUNCTION: BOOL SetupConfigureWmiFromInfSectionA ( HINF InfHandle, PCSTR SectionName, DWORD Flags ) ;
FUNCTION: BOOL SetupConfigureWmiFromInfSectionW ( HINF InfHandle, PCWSTR SectionName, DWORD Flags ) ;
ALIAS: SetupConfigureWmiFromInfSection SetupConfigureWmiFromInfSectionW
-
{ debugLevel D2D1_DEBUG_LEVEL } ;
C-TYPE: ID2D1Factory
-C-TYPE: ID2D1BitmapRenderTarget
+C-TYPE: ID2D1BitmapRenderTarget
COM-INTERFACE: ID2D1Resource IUnknown {2cd90691-12e2-11dc-9fed-001143a055f9}
void GetFactory ( ID2D1Factory** factory ) ;
FUNCTION: BOOL D2D1InvertMatrix (
D2D1_MATRIX_3X2_F* matrix ) ;
-
IN: windows.directx.d2dbasetypes
STRUCT: D3DCOLORVALUE
- { r FLOAT }
+ { r FLOAT }
{ g FLOAT }
{ b FLOAT }
{ a FLOAT } ;
{ MipSlice UINT }
{ FirstArraySlice UINT }
{ ArraySize UINT } ;
-
+
STRUCT: D3D10_TEX2DMS_ARRAY_RTV
{ FirstArraySlice UINT }
{ ArraySize UINT } ;
CONSTANT: D3D10_SHADER_DEBUG_SCOPE_FORLOOP 2
CONSTANT: D3D10_SHADER_DEBUG_SCOPE_STRUCT 3
CONSTANT: D3D10_SHADER_DEBUG_SCOPE_FUNC_PARAMS 4
-CONSTANT: D3D10_SHADER_DEBUG_SCOPE_STATEBLOCK 5
+CONSTANT: D3D10_SHADER_DEBUG_SCOPE_STATEBLOCK 5
CONSTANT: D3D10_SHADER_DEBUG_SCOPE_NAMESPACE 6
CONSTANT: D3D10_SHADER_DEBUG_SCOPE_ANNOTATION 7
CONSTANT: D3D10_SHADER_DEBUG_SCOPE_FORCE_DWORD 0x7fffffff
HRESULT GetSampler ( UINT Index, ID3D10SamplerState** ppSampler )
HRESULT GetBackingStore ( UINT Index, D3D10_SAMPLER_DESC* pSamplerDesc ) ;
TYPEDEF: ID3D10EffectSamplerVariable* LPD3D10EFFECTSAMPLERVARIABLE
-
+
STRUCT: D3D10_PASS_DESC
{ Name LPCSTR }
{ Annotations UINT }
UINT Flags,
UINT SDKVersion,
DXGI_SWAP_CHAIN_DESC* pSwapChainDesc,
- IDXGISwapChain** ppSwapChain,
+ IDXGISwapChain** ppSwapChain,
ID3D10Device** ppDevice ) ;
FUNCTION: HRESULT D3D10CreateBlob ( SIZE_T NumBytes, LPD3D10BLOB* ppBuffer ) ;
HRESULT GetSurfaceLevel ( UINT Level, IDirect3DSurface9** ppSurfaceLevel )
HRESULT LockRect ( UINT Level, D3DLOCKED_RECT* pLockedRect, RECT* pRect, DWORD Flags )
HRESULT UnlockRect ( UINT Level ) ;
-
+
TYPEDEF: IDirect3DTexture9* LPDIRECT3DTEXTURE9
TYPEDEF: IDirect3DTexture9* PDIRECT3DTEXTURE9
{ BufferAlignmentStart UINT }
{ BlockAlignmentSize UINT }
{ ProtectedMemorySize ULONGLONG } ;
-
+
CONSTANT: D3DCPCAPS_SOFTWARE 0x00000001
CONSTANT: D3DCPCAPS_HARDWARE 0x00000002
CONSTANT: D3DCPCAPS_PROTECTIONALWAYSON 0x00000004
CONSTANT: D3DPRASTERCAPS_COLORPERSPECTIVE 0x00400000
CONSTANT: D3DPRASTERCAPS_SCISSORTEST 0x01000000
CONSTANT: D3DPRASTERCAPS_SLOPESCALEDEPTHBIAS 0x02000000
-CONSTANT: D3DPRASTERCAPS_DEPTHBIAS 0x04000000
+CONSTANT: D3DPRASTERCAPS_DEPTHBIAS 0x04000000
CONSTANT: D3DPRASTERCAPS_MULTISAMPLE_TOGGLE 0x08000000
CONSTANT: D3DPCMPCAPS_NEVER 0x00000001
CONSTANT: D3DSPC_LT 4
CONSTANT: D3DSPC_NE 5
CONSTANT: D3DSPC_LE 6
-CONSTANT: D3DSPC_RESERVED1 7
+CONSTANT: D3DSPC_RESERVED1 7
CONSTANT: D3DSHADER_COMPARISON_SHIFT D3DSP_OPCODESPECIFICCONTROL_SHIFT
: D3DSHADER_COMPARISON_MASK ( -- n ) 7 D3DSHADER_COMPARISON_SHIFT shift ; inline
CONSTANT: D3DMULTISAMPLE_15_SAMPLES 15
CONSTANT: D3DMULTISAMPLE_16_SAMPLES 16
CONSTANT: D3DMULTISAMPLE_FORCE_DWORD 0x7fffffff
-
+
TYPEDEF: int D3DFORMAT
CONSTANT: D3DFMT_UNKNOWN 0
CONSTANT: D3DFMT_R8G8B8 20
CONSTANT: D3DDISPLAYROTATION_IDENTITY 1
CONSTANT: D3DDISPLAYROTATION_90 2
CONSTANT: D3DDISPLAYROTATION_180 3
-CONSTANT: D3DDISPLAYROTATION_270 4
+CONSTANT: D3DDISPLAYROTATION_270 4
CONSTANT: D3D9_RESOURCE_PRIORITY_MINIMUM 0x28000000
CONSTANT: D3D9_RESOURCE_PRIORITY_LOW 0x50000000
LPD3DBLOB* ppDisassembly ) ;
FUNCTION: HRESULT D3DDisassemble10Effect (
- ID3D10Effect* pEffect,
+ ID3D10Effect* pEffect,
UINT Flags,
LPD3DBLOB* ppDisassembly ) ;
SIZE_T BytecodeLength,
UINT uStripFlags,
LPD3DBLOB* ppStrippedBlob ) ;
-
ALIAS: D3DX10CompileFromFile D3DX10CompileFromFileW
-FUNCTION: HRESULT D3DX10CompileFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10CompileFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CompileFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10CompileFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
ALIAS: D3DX10CompileFromResource D3DX10CompileFromResourceW
-FUNCTION: HRESULT D3DX10CompileFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataLen, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
+FUNCTION: HRESULT D3DX10CompileFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataLen, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CreateEffectFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
- ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
+FUNCTION: HRESULT D3DX10CreateEffectFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+ ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CreateEffectFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines,
- ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
+FUNCTION: HRESULT D3DX10CreateEffectFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+ ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CreateEffectFromMemory ( LPCVOID pData, SIZE_T DataLength, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
- ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
+FUNCTION: HRESULT D3DX10CreateEffectFromMemory ( LPCVOID pData, SIZE_T DataLength, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+ ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CreateEffectFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
- ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
+FUNCTION: HRESULT D3DX10CreateEffectFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+ ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CreateEffectFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
- ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
+FUNCTION: HRESULT D3DX10CreateEffectFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+ ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
ID3D10EffectPool* pEffectPool, ID3DX10ThreadPump* pPump, ID3D10Effect** ppEffect, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
ALIAS: D3DX10CreateEffectFromFile D3DX10CreateEffectFromFileW
ALIAS: D3DX10CreateEffectFromResource D3DX10CreateEffectFromResourceW
-FUNCTION: HRESULT D3DX10CreateEffectPoolFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
- ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump,
+FUNCTION: HRESULT D3DX10CreateEffectPoolFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+ ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump,
ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CreateEffectPoolFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines,
- ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump,
+FUNCTION: HRESULT D3DX10CreateEffectPoolFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+ ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice, ID3DX10ThreadPump* pPump,
ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CreateEffectPoolFromMemory ( LPCVOID pData, SIZE_T DataLength, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10CreateEffectPoolFromMemory ( LPCVOID pData, SIZE_T DataLength, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
ID3DX10ThreadPump* pPump, ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10CreateEffectPoolFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10CreateEffectPoolFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
ID3DX10ThreadPump* pPump, ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
-
-FUNCTION: HRESULT D3DX10CreateEffectPoolFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+
+FUNCTION: HRESULT D3DX10CreateEffectPoolFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
ID3D10Include* pInclude, LPCSTR pProfile, UINT HLSLFlags, UINT FXFlags, ID3D10Device* pDevice,
ID3DX10ThreadPump* pPump, ID3D10EffectPool** ppEffectPool, ID3D10Blob** ppErrors, HRESULT* pHResult ) ;
ALIAS: D3DX10CreateEffectPoolFromFile D3DX10CreateEffectPoolFromFileW
ALIAS: D3DX10CreateEffectPoolFromResource D3DX10CreateEffectPoolFromResourceW
-FUNCTION: HRESULT D3DX10PreprocessShaderFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10PreprocessShaderFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10PreprocessShaderFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10PreprocessShaderFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10PreprocessShaderFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataSize, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10PreprocessShaderFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataSize, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10PreprocessShaderFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10PreprocessShaderFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX10PreprocessShaderFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX10PreprocessShaderFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX10ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
ALIAS: D3DX10PreprocessShaderFromFile D3DX10PreprocessShaderFromFileW
ALIAS: D3DX10PreprocessShaderFromResource D3DX10PreprocessShaderFromResourceW
-FUNCTION: HRESULT D3DX10CreateAsyncCompilerProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
+FUNCTION: HRESULT D3DX10CreateAsyncCompilerProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2,
ID3D10Blob** ppCompiledShader, ID3D10Blob** ppErrorBuffer, ID3DX10DataProcessor** ppProcessor ) ;
-FUNCTION: HRESULT D3DX10CreateAsyncEffectCreateProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
+FUNCTION: HRESULT D3DX10CreateAsyncEffectCreateProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
LPCSTR pProfile, UINT Flags, UINT FXFlags, ID3D10Device* pDevice,
ID3D10EffectPool* pPool, ID3D10Blob** ppErrorBuffer, ID3DX10DataProcessor** ppProcessor ) ;
-FUNCTION: HRESULT D3DX10CreateAsyncEffectPoolCreateProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
+FUNCTION: HRESULT D3DX10CreateAsyncEffectPoolCreateProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
LPCSTR pProfile, UINT Flags, UINT FXFlags, ID3D10Device* pDevice,
ID3D10Blob** ppErrorBuffer, ID3DX10DataProcessor** ppProcessor ) ;
-FUNCTION: HRESULT D3DX10CreateAsyncShaderPreprocessProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
+FUNCTION: HRESULT D3DX10CreateAsyncShaderPreprocessProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorBuffer, ID3DX10DataProcessor** ppProcessor ) ;
FUNCTION: HRESULT D3DX10CreateAsyncFileLoaderW ( LPCWSTR pFileName, ID3DX10DataLoader** ppDataLoader ) ;
LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
ALIAS: D3DX11CompileFromFile D3DX11CompileFromFileW
-FUNCTION: HRESULT D3DX11CompileFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX11CompileFromResourceA ( HMODULE hSrcModule, LPCSTR pSrcResource, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX11CompileFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX11CompileFromResourceW ( HMODULE hSrcModule, LPCWSTR pSrcResource, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
ALIAS: D3DX11CompileFromResource D3DX11CompileFromResourceW
-FUNCTION: HRESULT D3DX11CompileFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataLen, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
+FUNCTION: HRESULT D3DX11CompileFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataLen, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShader, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX11PreprocessShaderFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX11PreprocessShaderFromFileA ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX11PreprocessShaderFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX11PreprocessShaderFromFileW ( LPCWSTR pFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX11PreprocessShaderFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataSize, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX11PreprocessShaderFromMemory ( LPCSTR pSrcData, SIZE_T SrcDataSize, LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX11PreprocessShaderFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX11PreprocessShaderFromResourceA ( HMODULE hModule, LPCSTR pResourceName, LPCSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
-FUNCTION: HRESULT D3DX11PreprocessShaderFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
+FUNCTION: HRESULT D3DX11PreprocessShaderFromResourceW ( HMODULE hModule, LPCWSTR pResourceName, LPCWSTR pSrcFileName, D3D10_SHADER_MACRO* pDefines,
LPD3D10INCLUDE pInclude, ID3DX11ThreadPump* pPump, ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorMsgs, HRESULT* pHResult ) ;
ALIAS: D3DX11PreprocessShaderFromFile D3DX11PreprocessShaderFromFileW
ALIAS: D3DX11PreprocessShaderFromResource D3DX11PreprocessShaderFromResourceW
-FUNCTION: HRESULT D3DX11CreateAsyncCompilerProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
+FUNCTION: HRESULT D3DX11CreateAsyncCompilerProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
LPCSTR pFunctionName, LPCSTR pProfile, UINT Flags1, UINT Flags2,
ID3D10Blob** ppCompiledShader, ID3D10Blob** ppErrorBuffer, ID3DX11DataProcessor** ppProcessor ) ;
-FUNCTION: HRESULT D3DX11CreateAsyncShaderPreprocessProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
+FUNCTION: HRESULT D3DX11CreateAsyncShaderPreprocessProcessor ( LPCSTR pFileName, D3D10_SHADER_MACRO* pDefines, LPD3D10INCLUDE pInclude,
ID3D10Blob** ppShaderText, ID3D10Blob** ppErrorBuffer, ID3DX11DataProcessor** ppProcessor ) ;
FUNCTION: HRESULT D3DX11CreateAsyncFileLoaderW ( LPCWSTR pFileName, ID3DX11DataLoader** ppDataLoader ) ;
FLOAT* pROut,
FLOAT* pGOut,
FLOAT* pBOut ) ;
-
LPD3DXFRAME pFrameRoot,
LPD3DXANIMATIONCONTROLLER pAnimController
) ;
-
+
FUNCTION: UINT
D3DXFrameNumNamedMatrices
(
D3DXFRAME* pFrameRoot
) ;
-
+
FUNCTION: HRESULT
D3DXFrameCalculateBoundingSphere
(
CONSTANT: D3DX_SDK_VERSION 42
FUNCTION: BOOL D3DXCheckVersion ( UINT D3DSdkVersion, UINT D3DXSdkVersion ) ;
-FUNCTION: BOOL D3DXDebugMute ( BOOL Mute ) ;
+FUNCTION: BOOL D3DXDebugMute ( BOOL Mute ) ;
FUNCTION: UINT D3DXGetDriverLevel ( LPDIRECT3DDEVICE9 pDevice ) ;
C-TYPE: ID3DXBuffer
HRESULT OnResetDevice ( ) ;
FUNCTION: HRESULT
- D3DXCreateSprite (
- LPDIRECT3DDEVICE9 pDevice,
+ D3DXCreateSprite (
+ LPDIRECT3DDEVICE9 pDevice,
LPD3DXSPRITE* ppSprite ) ;
STRUCT: D3DXFONT_DESCA
FUNCTION: HRESULT
D3DXCreateFontA (
- LPDIRECT3DDEVICE9 pDevice,
+ LPDIRECT3DDEVICE9 pDevice,
INT Height,
UINT Width,
UINT Weight,
FUNCTION: HRESULT
D3DXCreateFontW (
- LPDIRECT3DDEVICE9 pDevice,
+ LPDIRECT3DDEVICE9 pDevice,
INT Height,
UINT Width,
UINT Weight,
ALIAS: D3DXCreateFont D3DXCreateFontW
FUNCTION: HRESULT
- D3DXCreateFontIndirectA (
- LPDIRECT3DDEVICE9 pDevice,
- D3DXFONT_DESCA* pDesc,
+ D3DXCreateFontIndirectA (
+ LPDIRECT3DDEVICE9 pDevice,
+ D3DXFONT_DESCA* pDesc,
LPD3DXFONT* ppFont ) ;
FUNCTION: HRESULT
- D3DXCreateFontIndirectW (
- LPDIRECT3DDEVICE9 pDevice,
- D3DXFONT_DESCW* pDesc,
+ D3DXCreateFontIndirectW (
+ LPDIRECT3DDEVICE9 pDevice,
+ D3DXFONT_DESCW* pDesc,
LPD3DXFONT* ppFont ) ;
ALIAS: D3DXCreateFontIndirect D3DXCreateFontIndirectW
HRESULT Begin ( )
HRESULT Draw ( D3DXVECTOR2* pVertexList, DWORD dwVertexListCount, D3DCOLOR Color )
HRESULT DrawTransform ( D3DXVECTOR3* pVertexList,
- DWORD dwVertexListCount, D3DXMATRIX* pTransform,
+ DWORD dwVertexListCount, D3DXMATRIX* pTransform,
D3DCOLOR Color )
HRESULT SetPattern ( DWORD dwPattern )
DWORD GetPattern ( )
LPCSTR pSrcFile,
D3DXMACRO* pDefines,
LPD3DXINCLUDE pInclude,
- LPCSTR pSkipConstants,
+ LPCSTR pSkipConstants,
DWORD Flags,
LPD3DXEFFECTPOOL pPool,
LPD3DXEFFECT* ppEffect,
LPCWSTR pSrcFile,
D3DXMACRO* pDefines,
LPD3DXINCLUDE pInclude,
- LPCSTR pSkipConstants,
+ LPCSTR pSkipConstants,
DWORD Flags,
LPD3DXEFFECTPOOL pPool,
LPD3DXEFFECT* ppEffect,
LPCSTR pSrcResource,
D3DXMACRO* pDefines,
LPD3DXINCLUDE pInclude,
- LPCSTR pSkipConstants,
+ LPCSTR pSkipConstants,
DWORD Flags,
LPD3DXEFFECTPOOL pPool,
LPD3DXEFFECT* ppEffect,
LPCWSTR pSrcResource,
D3DXMACRO* pDefines,
LPD3DXINCLUDE pInclude,
- LPCSTR pSkipConstants,
+ LPCSTR pSkipConstants,
DWORD Flags,
LPD3DXEFFECTPOOL pPool,
LPD3DXEFFECT* ppEffect,
UINT SrcDataLen,
D3DXMACRO* pDefines,
LPD3DXINCLUDE pInclude,
- LPCSTR pSkipConstants,
+ LPCSTR pSkipConstants,
DWORD Flags,
LPD3DXEFFECTPOOL pPool,
LPD3DXEFFECT* ppEffect,
LPD3DXEFFECTCOMPILER* ppCompiler,
LPD3DXBUFFER* ppParseErrors ) ;
-FUNCTION: HRESULT
+FUNCTION: HRESULT
D3DXDisassembleEffect (
- LPD3DXEFFECT pEffect,
- BOOL EnableColorCode,
+ LPD3DXEFFECT pEffect,
+ BOOL EnableColorCode,
LPD3DXBUFFER* ppDisassembly ) ;
-
FUNCTION: HRESULT D3DXSHProjectCubeMap
( UINT uOrder, LPDIRECT3DCUBETEXTURE9 pCubeMap,
FLOAT* ROut, FLOAT* GOut, FLOAT* BOut ) ;
-
DWORD NumBones,
D3DXBONECOMBINATION* pBoneCombinationTable,
LPD3DXSKININFO* ppSkinInfo ) ;
-
+
FUNCTION: HRESULT
D3DXTessellateNPatches (
LPD3DXMESH pMeshIn,
DWORD Wrap,
DWORD* pAdjacency ) ;
-C-TYPE: D3DXUVATLASCB
-TYPEDEF: D3DXUVATLASCB* LPD3DXUVATLASCB
+C-TYPE: D3DXUVATLASCB
+TYPEDEF: D3DXUVATLASCB* LPD3DXUVATLASCB
FUNCTION: HRESULT D3DXUVAtlasCreate (
LPD3DXMESH pMesh,
LPVOID pUserContext,
DWORD dwOptions,
LPD3DXBUFFER pFacePartitioning ) ;
-
+
TYPEDEF: void* LPD3DXIMTSIGNALCALLBACK
FUNCTION: HRESULT D3DXComputeIMTFromPerVertexSignal (
C-TYPE: D3DXPRTCOMPBUFFER
TYPEDEF: D3DXPRTCOMPBUFFER* LPD3DXPRTCOMPBUFFER
-
+
FUNCTION: HRESULT
D3DXLoadPRTCompBufferFromFileA (
LPCSTR pFilename,
UINT* pVertDataLength,
UINT* pSCClusterList,
D3DXSHPRTSPLITMESHCLUSTERDATA* pSCData ) ;
-
FUNCTION: HRESULT
D3DXDisassembleShader (
- DWORD* pShader,
- BOOL EnableColorCode,
- LPCSTR pComments,
+ DWORD* pShader,
+ BOOL EnableColorCode,
+ LPCSTR pComments,
LPD3DXBUFFER* ppDisassembly ) ;
FUNCTION: LPCSTR
DWORD FourCC,
LPCVOID* ppData,
UINT* pSizeInBytes ) ;
-
+
FUNCTION: UINT
D3DXGetShaderSize (
DWORD* pFunction ) ;
FUNCTION: HRESULT
D3DXCreateTextureShader (
- DWORD* pFunction,
+ DWORD* pFunction,
LPD3DXTEXTURESHADER* ppTextureShader ) ;
-
-FUNCTION: HRESULT
+
+FUNCTION: HRESULT
D3DXPreprocessShaderFromFileA (
LPCSTR pSrcFile,
D3DXMACRO* pDefines,
LPD3DXINCLUDE pInclude,
LPD3DXBUFFER* ppShaderText,
LPD3DXBUFFER* ppErrorMsgs ) ;
-
-FUNCTION: HRESULT
+
+FUNCTION: HRESULT
D3DXPreprocessShaderFromFileW (
LPCWSTR pSrcFile,
D3DXMACRO* pDefines,
ALIAS: D3DXPreprocessShaderFromFile D3DXPreprocessShaderFromFileW
-FUNCTION: HRESULT
+FUNCTION: HRESULT
D3DXPreprocessShaderFromResourceA (
HMODULE hSrcModule,
LPCSTR pSrcResource,
LPD3DXBUFFER* ppShaderText,
LPD3DXBUFFER* ppErrorMsgs ) ;
-FUNCTION: HRESULT
+FUNCTION: HRESULT
D3DXPreprocessShaderFromResourceW (
HMODULE hSrcModule,
LPCWSTR pSrcResource,
ALIAS: D3DXPreprocessShaderFromResource D3DXPreprocessShaderFromResourceW
-FUNCTION: HRESULT
+FUNCTION: HRESULT
D3DXPreprocessShader (
LPCSTR pSrcData,
UINT SrcDataSize,
{ Name DWORD }
{ TypeInfo DWORD } ;
TYPEDEF: D3DXSHADER_STRUCTMEMBERINFO* LPD3DXSHADER_STRUCTMEMBERINFO
-
LIBRARY: d3dx9
-TYPEDEF: void* LPGLYPHMETRICSFLOAT
+TYPEDEF: void* LPGLYPHMETRICSFLOAT
-FUNCTION: HRESULT
+FUNCTION: HRESULT
D3DXCreatePolygon (
LPDIRECT3DDEVICE9 pDevice,
- FLOAT Length,
- UINT Sides,
+ FLOAT Length,
+ UINT Sides,
LPD3DXMESH* ppMesh,
LPD3DXBUFFER* ppAdjacency ) ;
-FUNCTION: HRESULT
+FUNCTION: HRESULT
D3DXCreateBox (
- LPDIRECT3DDEVICE9 pDevice,
+ LPDIRECT3DDEVICE9 pDevice,
FLOAT Width,
FLOAT Height,
FLOAT Depth,
LPD3DXMESH* ppMesh,
LPD3DXBUFFER* ppAdjacency ) ;
-FUNCTION: HRESULT
+FUNCTION: HRESULT
D3DXCreateCylinder (
LPDIRECT3DDEVICE9 pDevice,
- FLOAT Radius1,
- FLOAT Radius2,
- FLOAT Length,
- UINT Slices,
- UINT Stacks,
+ FLOAT Radius1,
+ FLOAT Radius2,
+ FLOAT Length,
+ UINT Slices,
+ UINT Stacks,
LPD3DXMESH* ppMesh,
LPD3DXBUFFER* ppAdjacency ) ;
FUNCTION: HRESULT
D3DXCreateSphere (
- LPDIRECT3DDEVICE9 pDevice,
- FLOAT Radius,
- UINT Slices,
+ LPDIRECT3DDEVICE9 pDevice,
+ FLOAT Radius,
+ UINT Slices,
UINT Stacks,
LPD3DXMESH* ppMesh,
LPD3DXBUFFER* ppAdjacency ) ;
D3DXCreateTorus (
LPDIRECT3DDEVICE9 pDevice,
FLOAT InnerRadius,
- FLOAT OuterRadius,
+ FLOAT OuterRadius,
UINT Sides,
- UINT Rings,
+ UINT Rings,
LPD3DXMESH* ppMesh,
LPD3DXBUFFER* ppAdjacency ) ;
DWORD Filter,
D3DCOLOR ColorKey,
D3DXIMAGE_INFO* pSrcInfo ) ;
-
+
ALIAS: D3DXLoadSurfaceFromFile D3DXLoadSurfaceFromFileW
FUNCTION: HRESULT
RECT* pSrcRect,
DWORD Filter,
D3DCOLOR ColorKey ) ;
-
+
FUNCTION: HRESULT
D3DXLoadSurfaceFromMemory (
LPDIRECT3DSURFACE9 pDestSurface,
DWORD Filter,
D3DCOLOR ColorKey,
D3DXIMAGE_INFO* pSrcInfo ) ;
-
+
FUNCTION: HRESULT
D3DXLoadVolumeFromFileW (
LPDIRECT3DVOLUME9 pDestVolume,
D3DBOX* pSrcBox,
DWORD Filter,
D3DCOLOR ColorKey ) ;
-
+
FUNCTION: HRESULT
D3DXLoadVolumeFromMemory (
LPDIRECT3DVOLUME9 pDestVolume,
} [ [ rgodf>> free ] uninitialize ] each ;
PRIVATE>
-
HRESULT GetImageInfo ( LPDIDEVICEIMAGEINFOHEADERW lpdiDeviceImageInfoHeader ) ;
CALLBACK: BOOL LPDIENUMDEVICESBYSEMANTICSCBW (
- LPCDIDEVICEINSTANCEW lpddi,
+ LPCDIDEVICEINSTANCEW lpddi,
IDirectInputDevice8W* lpdid,
DWORD dwFlags,
DWORD dwRemaining,
FUNCTION: HRESULT DirectInput8Create ( HINSTANCE hinst, DWORD dwVersion, REFIID riidtlf, LPVOID* ppvOut, LPUNKNOWN punkOuter ) ;
CONSTANT: DIRECTINPUT_VERSION 0x0800
-
+
CONSTANT: DI8DEVCLASS_ALL 0
CONSTANT: DI8DEVCLASS_DEVICE 1
CONSTANT: DI8DEVCLASS_POINTER 2
CONSTANT: DIEDFL_INCLUDEALIASES 0x00010000
CONSTANT: DIEDFL_INCLUDEPHANTOMS 0x00020000
CONSTANT: DIEDFL_INCLUDEHIDDEN 0x00040000
-
+
CONSTANT: DIENUM_STOP 0
CONSTANT: DIENUM_CONTINUE 1
CONSTANT: DIDF_RELAXIS 2
CONSTANT: DIDFT_ALL 0x00000000
-
+
CONSTANT: DIDFT_RELAXIS 0x00000001
CONSTANT: DIDFT_ABSAXIS 0x00000002
CONSTANT: DIDFT_AXIS 0x00000003
-
+
CONSTANT: DIDFT_PSHBUTTON 0x00000004
CONSTANT: DIDFT_TGLBUTTON 0x00000008
CONSTANT: DIDFT_BUTTON 0x0000000C
-
+
CONSTANT: DIDFT_POV 0x00000010
CONSTANT: DIDFT_COLLECTION 0x00000040
CONSTANT: DIDFT_NODATA 0x00000080
-
+
CONSTANT: DIDFT_ANYINSTANCE 0x00FFFF00
ALIAS: DIDFT_INSTANCEMASK DIDFT_ANYINSTANCE
: DIDFT_MAKEINSTANCE ( n -- instance ) 8 shift ; inline
CONSTANT: DIPH_BYOFFSET 1
CONSTANT: DIPH_BYID 2
CONSTANT: DIPH_BYUSAGE 3
-
+
: DIMAKEUSAGEDWORD ( UsagePage Usage -- DWORD ) 16 shift bitor ; inline
: DIPROP_BUFFERSIZE ( -- alien ) 1 <alien> ; inline
CONSTANT: DIPROPAXISMODE_ABS 0
CONSTANT: DIPROPAXISMODE_REL 1
-
+
: DIPROP_GRANULARITY ( -- alien ) 3 <alien> ; inline
: DIPROP_RANGE ( -- alien ) 4 <alien> ; inline
: DIPROP_DEADZONE ( -- alien ) 5 <alien> ; inline
{ "d3d10" "d3d10.dll" stdcall }
{ "d3d10_1" "d3d10_1.dll" stdcall }
{ "d3d11" "d3d11.dll" stdcall }
- { "d3dcompiler" "d3dcompiler_42.dll" stdcall }
+ { "d3dcompiler" "d3dcompiler_42.dll" stdcall }
{ "d3dcsx" "d3dcsx_42.dll" stdcall }
{ "d3dx9" "d3dx9_42.dll" stdcall }
{ "d3dx10" "d3dx10_42.dll" stdcall }
{ isTrimmed BOOL } ;
STRUCT: DWRITE_CLUSTER_METRICS
- { width FLOAT }
+ { width FLOAT }
{ length USHORT }
{ data USHORT } ;
HRESULT Read ( LPVOID x, DWORD y, LPDWORD z ) ;
CONSTANT: DXFILE_OK 0
-
+
CONSTANT: DXFILEERR_BADOBJECT 0x88760352
CONSTANT: DXFILEERR_BADVALUE 0x88760353
CONSTANT: DXFILEERR_BADTYPE 0x88760354
HRESULT GetDC ( BOOL Discard, HDC* phdc )
HRESULT ReleaseDC ( RECT* pDirtyRect ) ;
-C-TYPE: IDXGIOutput
+C-TYPE: IDXGIOutput
COM-INTERFACE: IDXGIAdapter IDXGIObject {2411e7e1-12ac-4ccf-bd14-9798e8534dc0}
HRESULT EnumOutputs ( UINT Output, IDXGIOutput** ppOutput )
HRESULT GetDesc ( DXGI_ADAPTER_DESC* pDesc )
HRESULT SetMatrixCoefficients ( UINT32 uSrcChannelCount, UINT32 uDstChannelCount, float* pMatrixCoefficients )
HRESULT GetProperties ( LPXACT_WAVE_INSTANCE_PROPERTIES pProperties ) ;
-: XACT_FLAG_CUE_STOP_RELEASE ( -- z ) XACT_FLAG_STOP_RELEASE ; inline
-: XACT_FLAG_CUE_STOP_IMMEDIATE ( -- z ) XACT_FLAG_STOP_IMMEDIATE ; inline
+: XACT_FLAG_CUE_STOP_RELEASE ( -- z ) XACT_FLAG_STOP_RELEASE ; inline
+: XACT_FLAG_CUE_STOP_IMMEDIATE ( -- z ) XACT_FLAG_STOP_IMMEDIATE ; inline
-: XACT_CUESTATE_CREATED ( -- z ) XACT_STATE_CREATED ; inline
-: XACT_CUESTATE_PREPARING ( -- z ) XACT_STATE_PREPARING ; inline
-: XACT_CUESTATE_PREPARED ( -- z ) XACT_STATE_PREPARED ; inline
-: XACT_CUESTATE_PLAYING ( -- z ) XACT_STATE_PLAYING ; inline
-: XACT_CUESTATE_STOPPING ( -- z ) XACT_STATE_STOPPING ; inline
-: XACT_CUESTATE_STOPPED ( -- z ) XACT_STATE_STOPPED ; inline
-: XACT_CUESTATE_PAUSED ( -- z ) XACT_STATE_PAUSED ; inline
+: XACT_CUESTATE_CREATED ( -- z ) XACT_STATE_CREATED ; inline
+: XACT_CUESTATE_PREPARING ( -- z ) XACT_STATE_PREPARING ; inline
+: XACT_CUESTATE_PREPARED ( -- z ) XACT_STATE_PREPARED ; inline
+: XACT_CUESTATE_PLAYING ( -- z ) XACT_STATE_PLAYING ; inline
+: XACT_CUESTATE_STOPPING ( -- z ) XACT_STATE_STOPPING ; inline
+: XACT_CUESTATE_STOPPED ( -- z ) XACT_STATE_STOPPED ; inline
+: XACT_CUESTATE_PAUSED ( -- z ) XACT_STATE_PAUSED ; inline
COM-INTERFACE: IXACT3Cue f {00000000-0000-0000-0000-000000000000}
HRESULT Play ( )
HRESULT SetOutputVoices ( XAUDIO2_VOICE_SENDS* pSendList )
HRESULT SetOutputVoiceMatrix ( IXAudio2Voice* pDestinationVoice, UINT32 SourceChannels, UINT32 DestinationChannels, float* pLevelMatrix ) ;
-: XACT_FLAG_ENGINE_CREATE_MANAGEDATA ( -- z ) XACT_FLAG_MANAGEDATA ; inline
-: XACT_FLAG_ENGINE_STOP_IMMEDIATE ( -- z ) XACT_FLAG_STOP_IMMEDIATE ; inline
+: XACT_FLAG_ENGINE_CREATE_MANAGEDATA ( -- z ) XACT_FLAG_MANAGEDATA ; inline
+: XACT_FLAG_ENGINE_STOP_IMMEDIATE ( -- z ) XACT_FLAG_STOP_IMMEDIATE ; inline
STRUCT: WAVEBANKREGION
{ dwOffset DWORD }
CONSTANT: XACTENGINE_E_AUDITION_MISSINGWAVE 0x8AC70107
CONSTANT: XACTENGINE_E_AUDITION_CREATEDIRECTORYFAILED 0x8AC70108
CONSTANT: XACTENGINE_E_AUDITION_INVALIDSESSION 0x8AC70109
-
CONSTANT: XAPO_FLAG_INPLACE_SUPPORTED 0x00000010
-STRUCT: XAPO_REGISTRATION_PROPERTIES
+STRUCT: XAPO_REGISTRATION_PROPERTIES
{ clsid GUID }
{ FriendlyName WCHAR[256] }
{ CopyrightInfo WCHAR[256] }
COM-INTERFACE: IXAPOParameters IUnknown {A90BC001-E897-E897-55E4-9E4700000001}
void SetParameters ( void* pParameters, UINT32 ParameterByteSize )
void GetParameters ( void* pParameters, UINT32 ParameterByteSize ) ;
-
-
COM-INTERFACE: IXAudio2SubmixVoice IXAudio2Voice {00000000-0000-0000-0000-000000000000} ;
COM-INTERFACE: IXAudio2MasteringVoice IXAudio2Voice {00000000-0000-0000-0000-000000000000} ;
-
+
COM-INTERFACE: IXAudio2EngineCallback f {00000000-0000-0000-0000-000000000000}
void OnProcessingPassStart ( )
void OnProcessingPassEnd ( )
CONSTANT: SYSPAL_ERROR 0
CONSTANT: SYSPAL_STATIC 1
CONSTANT: SYSPAL_NOSTATIC 2
-CONSTANT: SYSPAL_NOSTATIC256 3
+CONSTANT: SYSPAL_NOSTATIC256 3
CONSTANT: TA_BASELINE 24
CONSTANT: TA_BOTTOM 8
CONSTANT: TA_TOP 0
CONSTANT: TT_POLYGON_TYPE 24
CONSTANT: TT_PRIM_LINE 1
CONSTANT: TT_PRIM_QSPLINE 2
-CONSTANT: TT_PRIM_CSPLINE 3
+CONSTANT: TT_PRIM_CSPLINE 3
CONSTANT: FONTMAPPER_MAX 10
CONSTANT: ENHMETA_STOCK_OBJECT 0x80000000
CONSTANT: WGL_FONT_LINES 0
{ oldColor GpColor }
{ newColor GpColor } ;
-C-TYPE: GpGraphics
-C-TYPE: GpPen
-C-TYPE: GpBrush
-C-TYPE: GpHatch
-C-TYPE: GpSolidFill
-C-TYPE: GpPath
-C-TYPE: GpMatrix
-C-TYPE: GpPathIterator
-C-TYPE: GpCustomLineCap
-C-TYPE: GpAdjustableArrowCap
-C-TYPE: GpImage
-C-TYPE: GpMetafile
-C-TYPE: GpImageAttributes
-C-TYPE: GpCachedBitmap
-C-TYPE: GpBitmap
-C-TYPE: GpPathGradient
-C-TYPE: GpLineGradient
-C-TYPE: GpTexture
-C-TYPE: GpFont
-C-TYPE: GpFontCollection
-C-TYPE: GpFontFamily
-C-TYPE: GpStringFormat
-C-TYPE: GpRegion
-C-TYPE: CGpEffect
+C-TYPE: GpGraphics
+C-TYPE: GpPen
+C-TYPE: GpBrush
+C-TYPE: GpHatch
+C-TYPE: GpSolidFill
+C-TYPE: GpPath
+C-TYPE: GpMatrix
+C-TYPE: GpPathIterator
+C-TYPE: GpCustomLineCap
+C-TYPE: GpAdjustableArrowCap
+C-TYPE: GpImage
+C-TYPE: GpMetafile
+C-TYPE: GpImageAttributes
+C-TYPE: GpCachedBitmap
+C-TYPE: GpBitmap
+C-TYPE: GpPathGradient
+C-TYPE: GpLineGradient
+C-TYPE: GpTexture
+C-TYPE: GpFont
+C-TYPE: GpFontCollection
+C-TYPE: GpFontFamily
+C-TYPE: GpStringFormat
+C-TYPE: GpRegion
+C-TYPE: CGpEffect
! dummy out other windows types we don't care to define yet
C-TYPE: LOGFONTA
FUNCTION: GpStatus GdipBitmapApplyEffect ( GpBitmap* x, CGpEffect* x, RECT* x, BOOL x, VOID** x, INT* x ) ;
FUNCTION: GpStatus GdipBitmapCreateApplyEffect ( GpBitmap** x, INT x, CGpEffect* x, RECT* x, RECT* x, GpBitmap** x, BOOL x, VOID** x, INT* x ) ;
FUNCTION: GpStatus GdipBitmapGetPixel ( GpBitmap* x, INT x, INT x, ARGB* x ) ;
-FUNCTION: GpStatus GdipBitmapLockBits ( GpBitmap* x, GpRect* x, UINT x,
+FUNCTION: GpStatus GdipBitmapLockBits ( GpBitmap* x, GpRect* x, UINT x,
PixelFormat x, BitmapData* x ) ;
FUNCTION: GpStatus GdipBitmapSetPixel ( GpBitmap* x, INT x, INT x, ARGB x ) ;
FUNCTION: GpStatus GdipBitmapSetResolution ( GpBitmap* x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipCreateBitmapFromHBITMAP ( HBITMAP x, HPALETTE x, GpBitmap** x ) ;
FUNCTION: GpStatus GdipCreateBitmapFromHICON ( HICON x, GpBitmap** x ) ;
FUNCTION: GpStatus GdipCreateBitmapFromResource ( HINSTANCE x, WCHAR* x, GpBitmap** x ) ;
-FUNCTION: GpStatus GdipCreateBitmapFromScan0 ( INT x, INT x, INT x, PixelFormat x, BYTE* x,
+FUNCTION: GpStatus GdipCreateBitmapFromScan0 ( INT x, INT x, INT x, PixelFormat x, BYTE* x,
GpBitmap** x ) ;
FUNCTION: GpStatus GdipCreateBitmapFromStream ( IStream* x, GpBitmap** x ) ;
FUNCTION: GpStatus GdipCreateBitmapFromStreamICM ( IStream* x, GpBitmap** x ) ;
FUNCTION: GpStatus GdipGetBrushType ( GpBrush* x, GpBrushType* x ) ;
-FUNCTION: GpStatus GdipCreateCachedBitmap ( GpBitmap* x, GpGraphics* x,
+FUNCTION: GpStatus GdipCreateCachedBitmap ( GpBitmap* x, GpGraphics* x,
GpCachedBitmap** x ) ;
FUNCTION: GpStatus GdipDeleteCachedBitmap ( GpCachedBitmap* x ) ;
FUNCTION: GpStatus GdipDrawCachedBitmap ( GpGraphics* x, GpCachedBitmap* x, INT x, INT x ) ;
FUNCTION: GpStatus GdipCloneCustomLineCap ( GpCustomLineCap* x, GpCustomLineCap** x ) ;
-FUNCTION: GpStatus GdipCreateCustomLineCap ( GpPath* x, GpPath* x, GpLineCap x, REAL x,
+FUNCTION: GpStatus GdipCreateCustomLineCap ( GpPath* x, GpPath* x, GpLineCap x, REAL x,
GpCustomLineCap** x ) ;
FUNCTION: GpStatus GdipDeleteCustomLineCap ( GpCustomLineCap* x ) ;
FUNCTION: GpStatus GdipGetCustomLineCapBaseCap ( GpCustomLineCap* x, GpLineCap* x ) ;
FUNCTION: GpStatus GdipSetCustomLineCapBaseCap ( GpCustomLineCap* x, GpLineCap x ) ;
FUNCTION: GpStatus GdipGetCustomLineCapBaseInset ( GpCustomLineCap* x, REAL* x ) ;
FUNCTION: GpStatus GdipSetCustomLineCapBaseInset ( GpCustomLineCap* x, REAL x ) ;
-FUNCTION: GpStatus GdipSetCustomLineCapStrokeCaps ( GpCustomLineCap* x, GpLineCap x,
+FUNCTION: GpStatus GdipSetCustomLineCapStrokeCaps ( GpCustomLineCap* x, GpLineCap x,
GpLineCap x ) ;
FUNCTION: GpStatus GdipGetCustomLineCapStrokeJoin ( GpCustomLineCap* x, GpLineJoin* x ) ;
FUNCTION: GpStatus GdipSetCustomLineCapStrokeJoin ( GpCustomLineCap* x, GpLineJoin x ) ;
FUNCTION: GpStatus GdipSetCustomLineCapWidthScale ( GpCustomLineCap* x, REAL x ) ;
FUNCTION: GpStatus GdipCloneFont ( GpFont* x, GpFont** x ) ;
-FUNCTION: GpStatus GdipCreateFont ( GpFontFamily* x, REAL x, INT x, GpUnit x,
+FUNCTION: GpStatus GdipCreateFont ( GpFontFamily* x, REAL x, INT x, GpUnit x,
GpFont** x ) ;
FUNCTION: GpStatus GdipCreateFontFromDC ( HDC x, GpFont** x ) ;
FUNCTION: GpStatus GdipCreateFontFromLogfontA ( HDC x, LOGFONTA* x, GpFont** x ) ;
FUNCTION: GpStatus GdipGetFontUnit ( GpFont* x, GpUnit* x ) ;
FUNCTION: GpStatus GdipGetFontSize ( GpFont* x, REAL* x ) ;
FUNCTION: GpStatus GdipGetFontStyle ( GpFont* x, INT* x ) ;
-FUNCTION: GpStatus GdipGetFontHeight ( GpFont* x, GpGraphics* x,
+FUNCTION: GpStatus GdipGetFontHeight ( GpFont* x, GpGraphics* x,
REAL* x ) ;
FUNCTION: GpStatus GdipGetFontHeightGivenDPI ( GpFont* x, REAL x, REAL* x ) ;
FUNCTION: GpStatus GdipNewPrivateFontCollection ( GpFontCollection** x ) ;
FUNCTION: GpStatus GdipDeletePrivateFontCollection ( GpFontCollection** x ) ;
FUNCTION: GpStatus GdipPrivateAddFontFile ( GpFontCollection* x, WCHAR* x ) ;
-FUNCTION: GpStatus GdipPrivateAddMemoryFont ( GpFontCollection* x,
+FUNCTION: GpStatus GdipPrivateAddMemoryFont ( GpFontCollection* x,
void* x, INT x ) ;
FUNCTION: GpStatus GdipGetFontCollectionFamilyCount ( GpFontCollection* x, INT* x ) ;
-FUNCTION: GpStatus GdipGetFontCollectionFamilyList ( GpFontCollection* x, INT x,
+FUNCTION: GpStatus GdipGetFontCollectionFamilyList ( GpFontCollection* x, INT x,
GpFontFamily** x, INT* x ) ;
FUNCTION: GpStatus GdipCloneFontFamily ( GpFontFamily* x, GpFontFamily** x ) ;
-FUNCTION: GpStatus GdipCreateFontFamilyFromName ( WCHAR* x,
+FUNCTION: GpStatus GdipCreateFontFamilyFromName ( WCHAR* x,
GpFontCollection* x, GpFontFamily** x ) ;
FUNCTION: GpStatus GdipDeleteFontFamily ( GpFontFamily* x ) ;
FUNCTION: GpStatus GdipGetFamilyName ( GpFontFamily* x, WCHAR* x, LANGID x ) ;
FUNCTION: GpStatus GdipDrawCurve2I ( GpGraphics* x, GpPen* x, GpPoint* x, INT x, REAL x ) ;
FUNCTION: GpStatus GdipDrawCurve3 ( GpGraphics* x, GpPen* x, GpPointF* x, INT x, INT x, INT x, REAL x ) ;
FUNCTION: GpStatus GdipDrawCurve3I ( GpGraphics* x, GpPen* x, GpPoint* x, INT x, INT x, INT x, REAL x ) ;
-FUNCTION: GpStatus GdipDrawDriverString ( GpGraphics* x, UINT16* x, INT x,
+FUNCTION: GpStatus GdipDrawDriverString ( GpGraphics* x, UINT16* x, INT x,
GpFont* x, GpBrush* x, GpPointF* x, INT x, GpMatrix* x ) ;
FUNCTION: GpStatus GdipDrawEllipse ( GpGraphics* x, GpPen* x, REAL x, REAL x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipDrawEllipseI ( GpGraphics* x, GpPen* x, INT x, INT x, INT x, INT x ) ;
FUNCTION: GpStatus GdipDrawImagePointRectI ( GpGraphics* x, GpImage* x, INT x, INT x, INT x, INT x, INT x, INT x, GpUnit x ) ;
FUNCTION: GpStatus GdipDrawImagePoints ( GpGraphics* x, GpImage* x, GpPointF* x, INT x ) ;
FUNCTION: GpStatus GdipDrawImagePointsI ( GpGraphics* x, GpImage* x, GpPoint* x, INT x ) ;
-FUNCTION: GpStatus GdipDrawImagePointsRect ( GpGraphics* x, GpImage* x,
- GpPointF* x, INT x, REAL x, REAL x, REAL x, REAL x, GpUnit x,
+FUNCTION: GpStatus GdipDrawImagePointsRect ( GpGraphics* x, GpImage* x,
+ GpPointF* x, INT x, REAL x, REAL x, REAL x, REAL x, GpUnit x,
GpImageAttributes* x, DrawImageAbort x, VOID* x ) ;
-FUNCTION: GpStatus GdipDrawImagePointsRectI ( GpGraphics* x, GpImage* x,
- GpPoint* x, INT x, INT x, INT x, INT x, INT x, GpUnit x,
+FUNCTION: GpStatus GdipDrawImagePointsRectI ( GpGraphics* x, GpImage* x,
+ GpPoint* x, INT x, INT x, INT x, INT x, INT x, GpUnit x,
GpImageAttributes* x, DrawImageAbort x, VOID* x ) ;
FUNCTION: GpStatus GdipDrawImageRect ( GpGraphics* x, GpImage* x, REAL x, REAL x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipDrawImageRectI ( GpGraphics* x, GpImage* x, INT x, INT x, INT x, INT x ) ;
-FUNCTION: GpStatus GdipDrawImageRectRect ( GpGraphics* x, GpImage* x, REAL x, REAL x, REAL x,
- REAL x, REAL x, REAL x, REAL x, REAL x, GpUnit x, GpImageAttributes* x, DrawImageAbort x,
+FUNCTION: GpStatus GdipDrawImageRectRect ( GpGraphics* x, GpImage* x, REAL x, REAL x, REAL x,
+ REAL x, REAL x, REAL x, REAL x, REAL x, GpUnit x, GpImageAttributes* x, DrawImageAbort x,
VOID* x ) ;
-FUNCTION: GpStatus GdipDrawImageRectRectI ( GpGraphics* x, GpImage* x, INT x, INT x, INT x,
- INT x, INT x, INT x, INT x, INT x, GpUnit x, GpImageAttributes* x, DrawImageAbort x,
+FUNCTION: GpStatus GdipDrawImageRectRectI ( GpGraphics* x, GpImage* x, INT x, INT x, INT x,
+ INT x, INT x, INT x, INT x, INT x, GpUnit x, GpImageAttributes* x, DrawImageAbort x,
VOID* x ) ;
FUNCTION: GpStatus GdipDrawLine ( GpGraphics* x, GpPen* x, REAL x, REAL x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipDrawLineI ( GpGraphics* x, GpPen* x, INT x, INT x, INT x, INT x ) ;
FUNCTION: GpStatus GdipDrawRectangleI ( GpGraphics* x, GpPen* x, INT x, INT x, INT x, INT x ) ;
FUNCTION: GpStatus GdipDrawRectangles ( GpGraphics* x, GpPen* x, GpRectF* x, INT x ) ;
FUNCTION: GpStatus GdipDrawRectanglesI ( GpGraphics* x, GpPen* x, GpRect* x, INT x ) ;
-FUNCTION: GpStatus GdipDrawString ( GpGraphics* x, WCHAR* x, INT x,
- GpFont* x, GpRectF* x, GpStringFormat* x,
+FUNCTION: GpStatus GdipDrawString ( GpGraphics* x, WCHAR* x, INT x,
+ GpFont* x, GpRectF* x, GpStringFormat* x,
GpBrush* x ) ;
-FUNCTION: GpStatus GdipFillClosedCurve2 ( GpGraphics* x, GpBrush* x, GpPointF* x, INT x,
+FUNCTION: GpStatus GdipFillClosedCurve2 ( GpGraphics* x, GpBrush* x, GpPointF* x, INT x,
REAL x, GpFillMode x ) ;
-FUNCTION: GpStatus GdipFillClosedCurve2I ( GpGraphics* x, GpBrush* x, GpPoint* x, INT x,
+FUNCTION: GpStatus GdipFillClosedCurve2I ( GpGraphics* x, GpBrush* x, GpPoint* x, INT x,
REAL x, GpFillMode x ) ;
FUNCTION: GpStatus GdipFillEllipse ( GpGraphics* x, GpBrush* x, REAL x, REAL x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipFillEllipseI ( GpGraphics* x, GpBrush* x, INT x, INT x, INT x, INT x ) ;
FUNCTION: GpStatus GdipFillPath ( GpGraphics* x, GpBrush* x, GpPath* x ) ;
FUNCTION: GpStatus GdipFillPie ( GpGraphics* x, GpBrush* x, REAL x, REAL x, REAL x, REAL x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipFillPieI ( GpGraphics* x, GpBrush* x, INT x, INT x, INT x, INT x, REAL x, REAL x ) ;
-FUNCTION: GpStatus GdipFillPolygon ( GpGraphics* x, GpBrush* x, GpPointF* x,
+FUNCTION: GpStatus GdipFillPolygon ( GpGraphics* x, GpBrush* x, GpPointF* x,
INT x, GpFillMode x ) ;
-FUNCTION: GpStatus GdipFillPolygonI ( GpGraphics* x, GpBrush* x, GpPoint* x,
+FUNCTION: GpStatus GdipFillPolygonI ( GpGraphics* x, GpBrush* x, GpPoint* x,
INT x, GpFillMode x ) ;
FUNCTION: GpStatus GdipFillPolygon2 ( GpGraphics* x, GpBrush* x, GpPointF* x, INT x ) ;
FUNCTION: GpStatus GdipFillPolygon2I ( GpGraphics* x, GpBrush* x, GpPoint* x, INT x ) ;
FUNCTION: GpStatus GdipIsVisiblePointI ( GpGraphics* x, INT x, INT x, BOOL* x ) ;
FUNCTION: GpStatus GdipIsVisibleRect ( GpGraphics* x, REAL x, REAL x, REAL x, REAL x, BOOL* x ) ;
FUNCTION: GpStatus GdipIsVisibleRectI ( GpGraphics* x, INT x, INT x, INT x, INT x, BOOL* x ) ;
-FUNCTION: GpStatus GdipMeasureCharacterRanges ( GpGraphics* x, WCHAR* x,
- INT x, GpFont* x, GpRectF* x, GpStringFormat* x, INT x,
+FUNCTION: GpStatus GdipMeasureCharacterRanges ( GpGraphics* x, WCHAR* x,
+ INT x, GpFont* x, GpRectF* x, GpStringFormat* x, INT x,
GpRegion** x ) ;
-FUNCTION: GpStatus GdipMeasureDriverString ( GpGraphics* x, UINT16* x, INT x,
+FUNCTION: GpStatus GdipMeasureDriverString ( GpGraphics* x, UINT16* x, INT x,
GpFont* x, GpPointF* x, INT x, GpMatrix* x, GpRectF* x ) ;
-FUNCTION: GpStatus GdipMeasureString ( GpGraphics* x, WCHAR* x, INT x,
+FUNCTION: GpStatus GdipMeasureString ( GpGraphics* x, WCHAR* x, INT x,
GpFont* x, GpRectF* x, GpStringFormat* x, GpRectF* x, INT* x, INT* x ) ;
FUNCTION: GpStatus GdipMultiplyWorldTransform ( GpGraphics* x, GpMatrix* x, GpMatrixOrder x ) ;
-FUNCTION: GpStatus GdipRecordMetafileFileName ( WCHAR* x, HDC x, EmfType x,
+FUNCTION: GpStatus GdipRecordMetafileFileName ( WCHAR* x, HDC x, EmfType x,
GpRectF* x, MetafileFrameUnit x, WCHAR* x, GpMetafile** x ) ;
-FUNCTION: GpStatus GdipRecordMetafileFileNameI ( WCHAR* x, HDC x, EmfType x,
+FUNCTION: GpStatus GdipRecordMetafileFileNameI ( WCHAR* x, HDC x, EmfType x,
GpRect* x, MetafileFrameUnit x, WCHAR* x, GpMetafile** x ) ;
-FUNCTION: GpStatus GdipRecordMetafileI ( HDC x, EmfType x, GpRect* x,
+FUNCTION: GpStatus GdipRecordMetafileI ( HDC x, EmfType x, GpRect* x,
MetafileFrameUnit x, WCHAR* x, GpMetafile** x ) ;
FUNCTION: GpStatus GdipReleaseDC ( GpGraphics* x, HDC x ) ;
FUNCTION: GpStatus GdipResetClip ( GpGraphics* x ) ;
FUNCTION: GpStatus GdipSetTextContrast ( GpGraphics* x, UINT x ) ;
FUNCTION: GpStatus GdipSetTextRenderingHint ( GpGraphics* x, TextRenderingHint x ) ;
FUNCTION: GpStatus GdipSetWorldTransform ( GpGraphics* x, GpMatrix* x ) ;
-FUNCTION: GpStatus GdipTransformPoints ( GpGraphics* x, GpCoordinateSpace x, GpCoordinateSpace x,
+FUNCTION: GpStatus GdipTransformPoints ( GpGraphics* x, GpCoordinateSpace x, GpCoordinateSpace x,
GpPointF* x, INT x ) ;
-FUNCTION: GpStatus GdipTransformPointsI ( GpGraphics* x, GpCoordinateSpace x, GpCoordinateSpace x,
+FUNCTION: GpStatus GdipTransformPointsI ( GpGraphics* x, GpCoordinateSpace x, GpCoordinateSpace x,
GpPoint* x, INT x ) ;
FUNCTION: GpStatus GdipTranslateClip ( GpGraphics* x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipTranslateClipI ( GpGraphics* x, INT x, INT x ) ;
FUNCTION: GpStatus GdipClosePathFigure ( GpPath* x ) ;
FUNCTION: GpStatus GdipClosePathFigures ( GpPath* x ) ;
FUNCTION: GpStatus GdipCreatePath ( GpFillMode x, GpPath** x ) ;
-FUNCTION: GpStatus GdipCreatePath2 ( GpPointF* x, BYTE* x, INT x,
+FUNCTION: GpStatus GdipCreatePath2 ( GpPointF* x, BYTE* x, INT x,
GpFillMode x, GpPath** x ) ;
FUNCTION: GpStatus GdipCreatePath2I ( GpPoint* x, BYTE* x, INT x, GpFillMode x, GpPath** x ) ;
FUNCTION: GpStatus GdipDeletePath ( GpPath* x ) ;
FUNCTION: GpStatus GdipFlattenPath ( GpPath* x, GpMatrix* x, REAL x ) ;
-FUNCTION: GpStatus GdipIsOutlineVisiblePathPoint ( GpPath* x, REAL x, REAL x, GpPen* x,
+FUNCTION: GpStatus GdipIsOutlineVisiblePathPoint ( GpPath* x, REAL x, REAL x, GpPen* x,
GpGraphics* x, BOOL* x ) ;
-FUNCTION: GpStatus GdipIsOutlineVisiblePathPointI ( GpPath* x, INT x, INT x, GpPen* x,
+FUNCTION: GpStatus GdipIsOutlineVisiblePathPointI ( GpPath* x, INT x, INT x, GpPen* x,
GpGraphics* x, BOOL* x ) ;
FUNCTION: GpStatus GdipIsVisiblePathPoint ( GpPath* x, REAL x, REAL x, GpGraphics* x, BOOL* x ) ;
FUNCTION: GpStatus GdipIsVisiblePathPointI ( GpPath* x, INT x, INT x, GpGraphics* x, BOOL* x ) ;
FUNCTION: GpStatus GdipSetPathMarker ( GpPath* x ) ;
FUNCTION: GpStatus GdipStartPathFigure ( GpPath* x ) ;
FUNCTION: GpStatus GdipTransformPath ( GpPath* x, GpMatrix* x ) ;
-FUNCTION: GpStatus GdipWarpPath ( GpPath* x, GpMatrix* x, GpPointF* x, INT x, REAL x,
+FUNCTION: GpStatus GdipWarpPath ( GpPath* x, GpMatrix* x, GpPointF* x, INT x, REAL x,
REAL x, REAL x, REAL x, WarpMode x, REAL x ) ;
FUNCTION: GpStatus GdipWidenPath ( GpPath* x, GpPen* x, GpMatrix* x, REAL x ) ;
FUNCTION: GpStatus GdipLoadImageFromStreamICM ( IStream* x, GpImage** x ) ;
FUNCTION: GpStatus GdipRemovePropertyItem ( GpImage* x, PROPID x ) ;
FUNCTION: GpStatus GdipSaveImageToFile ( GpImage* x, WCHAR* x, CLSID* x, EncoderParameters* x ) ;
-FUNCTION: GpStatus GdipSaveImageToStream ( GpImage* x, IStream* x,
+FUNCTION: GpStatus GdipSaveImageToStream ( GpImage* x, IStream* x,
CLSID* x, EncoderParameters* x ) ;
FUNCTION: GpStatus GdipSetImagePalette ( GpImage* x, ColorPalette* x ) ;
FUNCTION: GpStatus GdipSetPropertyItem ( GpImage* x, PropertyItem* x ) ;
FUNCTION: GpStatus GdipCreateImageAttributes ( GpImageAttributes** x ) ;
FUNCTION: GpStatus GdipDisposeImageAttributes ( GpImageAttributes* x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesCachedBackground ( GpImageAttributes* x,
+FUNCTION: GpStatus GdipSetImageAttributesCachedBackground ( GpImageAttributes* x,
BOOL x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesColorKeys ( GpImageAttributes* x,
+FUNCTION: GpStatus GdipSetImageAttributesColorKeys ( GpImageAttributes* x,
ColorAdjustType x, BOOL x, ARGB x, ARGB x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesColorMatrix ( GpImageAttributes* x,
- ColorAdjustType x, BOOL x, ColorMatrix* x, ColorMatrix* x,
+FUNCTION: GpStatus GdipSetImageAttributesColorMatrix ( GpImageAttributes* x,
+ ColorAdjustType x, BOOL x, ColorMatrix* x, ColorMatrix* x,
ColorMatrixFlags x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesGamma ( GpImageAttributes* x,
+FUNCTION: GpStatus GdipSetImageAttributesGamma ( GpImageAttributes* x,
ColorAdjustType x, BOOL x, REAL x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesNoOp ( GpImageAttributes* x,
+FUNCTION: GpStatus GdipSetImageAttributesNoOp ( GpImageAttributes* x,
ColorAdjustType x, BOOL x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesOutputChannel ( GpImageAttributes* x,
+FUNCTION: GpStatus GdipSetImageAttributesOutputChannel ( GpImageAttributes* x,
ColorAdjustType x, BOOL x, ColorChannelFlags x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesOutputChannelColorProfile (
+FUNCTION: GpStatus GdipSetImageAttributesOutputChannelColorProfile (
GpImageAttributes* x, ColorAdjustType x, BOOL x, WCHAR* x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesRemapTable ( GpImageAttributes* x,
+FUNCTION: GpStatus GdipSetImageAttributesRemapTable ( GpImageAttributes* x,
ColorAdjustType x, BOOL x, UINT x, ColorMap* x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesThreshold ( GpImageAttributes* x,
+FUNCTION: GpStatus GdipSetImageAttributesThreshold ( GpImageAttributes* x,
ColorAdjustType x, BOOL x, REAL x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesToIdentity ( GpImageAttributes* x,
+FUNCTION: GpStatus GdipSetImageAttributesToIdentity ( GpImageAttributes* x,
ColorAdjustType x ) ;
-FUNCTION: GpStatus GdipSetImageAttributesWrapMode ( GpImageAttributes* x, GpWrapMode x,
+FUNCTION: GpStatus GdipSetImageAttributesWrapMode ( GpImageAttributes* x, GpWrapMode x,
ARGB x, BOOL x ) ;
-FUNCTION: GpStatus GdipCreateLineBrush ( GpPointF* x, GpPointF* x,
+FUNCTION: GpStatus GdipCreateLineBrush ( GpPointF* x, GpPointF* x,
ARGB x, ARGB x, GpWrapMode x, GpLineGradient** x ) ;
-FUNCTION: GpStatus GdipCreateLineBrushI ( GpPoint* x, GpPoint* x,
+FUNCTION: GpStatus GdipCreateLineBrushI ( GpPoint* x, GpPoint* x,
ARGB x, ARGB x, GpWrapMode x, GpLineGradient** x ) ;
-FUNCTION: GpStatus GdipCreateLineBrushFromRect ( GpRectF* x, ARGB x, ARGB x,
+FUNCTION: GpStatus GdipCreateLineBrushFromRect ( GpRectF* x, ARGB x, ARGB x,
LinearGradientMode x, GpWrapMode x, GpLineGradient** x ) ;
-FUNCTION: GpStatus GdipCreateLineBrushFromRectI ( GpRect* x, ARGB x, ARGB x,
+FUNCTION: GpStatus GdipCreateLineBrushFromRectI ( GpRect* x, ARGB x, ARGB x,
LinearGradientMode x, GpWrapMode x, GpLineGradient** x ) ;
-FUNCTION: GpStatus GdipCreateLineBrushFromRectWithAngle ( GpRectF* x,
+FUNCTION: GpStatus GdipCreateLineBrushFromRectWithAngle ( GpRectF* x,
ARGB x, ARGB x, REAL x, BOOL x, GpWrapMode x, GpLineGradient** x ) ;
-FUNCTION: GpStatus GdipCreateLineBrushFromRectWithAngleI ( GpRect* x,
+FUNCTION: GpStatus GdipCreateLineBrushFromRectWithAngleI ( GpRect* x,
ARGB x, ARGB x, REAL x, BOOL x, GpWrapMode x, GpLineGradient** x ) ;
FUNCTION: GpStatus GdipGetLineColors ( GpLineGradient* x, ARGB* x ) ;
FUNCTION: GpStatus GdipGetLineGammaCorrection ( GpLineGradient* x, BOOL* x ) ;
FUNCTION: GpStatus GdipGetLineRect ( GpLineGradient* x, GpRectF* x ) ;
FUNCTION: GpStatus GdipGetLineRectI ( GpLineGradient* x, GpRect* x ) ;
FUNCTION: GpStatus GdipGetLineWrapMode ( GpLineGradient* x, GpWrapMode* x ) ;
-FUNCTION: GpStatus GdipSetLineBlend ( GpLineGradient* x, REAL* x,
+FUNCTION: GpStatus GdipSetLineBlend ( GpLineGradient* x, REAL* x,
REAL* x, INT x ) ;
FUNCTION: GpStatus GdipGetLineBlend ( GpLineGradient* x, REAL* x, REAL* x, INT x ) ;
FUNCTION: GpStatus GdipGetLineBlendCount ( GpLineGradient* x, INT* x ) ;
-FUNCTION: GpStatus GdipSetLinePresetBlend ( GpLineGradient* x, ARGB* x,
+FUNCTION: GpStatus GdipSetLinePresetBlend ( GpLineGradient* x, ARGB* x,
REAL* x, INT x ) ;
FUNCTION: GpStatus GdipGetLinePresetBlend ( GpLineGradient* x, ARGB* x, REAL* x, INT x ) ;
FUNCTION: GpStatus GdipGetLinePresetBlendCount ( GpLineGradient* x, INT* x ) ;
FUNCTION: GpStatus GdipResetLineTransform ( GpLineGradient* x ) ;
FUNCTION: GpStatus GdipRotateLineTransform ( GpLineGradient* x, REAL x, GpMatrixOrder x ) ;
-FUNCTION: GpStatus GdipScaleLineTransform ( GpLineGradient* x, REAL x, REAL x,
+FUNCTION: GpStatus GdipScaleLineTransform ( GpLineGradient* x, REAL x, REAL x,
GpMatrixOrder x ) ;
FUNCTION: GpStatus GdipSetLineColors ( GpLineGradient* x, ARGB x, ARGB x ) ;
FUNCTION: GpStatus GdipSetLineGammaCorrection ( GpLineGradient* x, BOOL x ) ;
FUNCTION: GpStatus GdipSetLineTransform ( GpLineGradient* x, GpMatrix* x ) ;
FUNCTION: GpStatus GdipSetLineLinearBlend ( GpLineGradient* x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipSetLineWrapMode ( GpLineGradient* x, GpWrapMode x ) ;
-FUNCTION: GpStatus GdipTranslateLineTransform ( GpLineGradient* x, REAL x, REAL x,
+FUNCTION: GpStatus GdipTranslateLineTransform ( GpLineGradient* x, REAL x, REAL x,
GpMatrixOrder x ) ;
FUNCTION: GpStatus GdipVectorTransformMatrixPointsI ( GpMatrix* x, GpPoint* x, INT x ) ;
-FUNCTION: GpStatus GdipConvertToEmfPlus ( GpGraphics* x, GpMetafile* x, INT* x,
+FUNCTION: GpStatus GdipConvertToEmfPlus ( GpGraphics* x, GpMetafile* x, INT* x,
EmfType x, WCHAR* x, GpMetafile** x ) ;
FUNCTION: GpStatus GdipConvertToEmfPlusToFile ( GpGraphics* x, GpMetafile* x, INT* x, WCHAR* x, EmfType x, WCHAR* x, GpMetafile** x ) ;
FUNCTION: GpStatus GdipConvertToEmfPlusToStream ( GpGraphics* x, GpMetafile* x, INT* x, IStream* x, EmfType x, WCHAR* x, GpMetafile** x ) ;
FUNCTION: GpStatus GdipCreateMetafileFromEmf ( HENHMETAFILE x, BOOL x, GpMetafile** x ) ;
-FUNCTION: GpStatus GdipCreateMetafileFromWmf ( HMETAFILE x, BOOL x,
+FUNCTION: GpStatus GdipCreateMetafileFromWmf ( HMETAFILE x, BOOL x,
WmfPlaceableFileHeader* x, GpMetafile** x ) ;
-FUNCTION: GpStatus GdipCreateMetafileFromWmfFile ( WCHAR* x, WmfPlaceableFileHeader* x,
+FUNCTION: GpStatus GdipCreateMetafileFromWmfFile ( WCHAR* x, WmfPlaceableFileHeader* x,
GpMetafile** x ) ;
FUNCTION: GpStatus GdipCreateMetafileFromFile ( WCHAR* x, GpMetafile** x ) ;
FUNCTION: GpStatus GdipCreateMetafileFromStream ( IStream* x, GpMetafile** x ) ;
FUNCTION: GpStatus GdipCreatePathGradient ( GpPointF* x, INT x, GpWrapMode x, GpPathGradient** x ) ;
FUNCTION: GpStatus GdipCreatePathGradientI ( GpPoint* x, INT x, GpWrapMode x, GpPathGradient** x ) ;
-FUNCTION: GpStatus GdipCreatePathGradientFromPath ( GpPath* x,
+FUNCTION: GpStatus GdipCreatePathGradientFromPath ( GpPath* x,
GpPathGradient** x ) ;
FUNCTION: GpStatus GdipGetPathGradientBlend ( GpPathGradient* x, REAL* x, REAL* x, INT x ) ;
FUNCTION: GpStatus GdipGetPathGradientBlendCount ( GpPathGradient* x, INT* x ) ;
FUNCTION: GpStatus GdipGetPathGradientFocusScales ( GpPathGradient* x, REAL* x, REAL* x ) ;
FUNCTION: GpStatus GdipGetPathGradientGammaCorrection ( GpPathGradient* x, BOOL* x ) ;
FUNCTION: GpStatus GdipGetPathGradientPointCount ( GpPathGradient* x, INT* x ) ;
-FUNCTION: GpStatus GdipSetPathGradientPresetBlend ( GpPathGradient* x,
+FUNCTION: GpStatus GdipSetPathGradientPresetBlend ( GpPathGradient* x,
ARGB* x, REAL* x, INT x ) ;
FUNCTION: GpStatus GdipGetPathGradientRect ( GpPathGradient* x, GpRectF* x ) ;
FUNCTION: GpStatus GdipGetPathGradientRectI ( GpPathGradient* x, GpRect* x ) ;
-FUNCTION: GpStatus GdipGetPathGradientSurroundColorsWithCount ( GpPathGradient* x,
+FUNCTION: GpStatus GdipGetPathGradientSurroundColorsWithCount ( GpPathGradient* x,
ARGB* x, INT* x ) ;
FUNCTION: GpStatus GdipGetPathGradientWrapMode ( GpPathGradient* x, GpWrapMode* x ) ;
FUNCTION: GpStatus GdipSetPathGradientBlend ( GpPathGradient* x, REAL* x, REAL* x, INT x ) ;
FUNCTION: GpStatus GdipSetPathGradientFocusScales ( GpPathGradient* x, REAL x, REAL x ) ;
FUNCTION: GpStatus GdipSetPathGradientGammaCorrection ( GpPathGradient* x, BOOL x ) ;
FUNCTION: GpStatus GdipSetPathGradientSigmaBlend ( GpPathGradient* x, REAL x, REAL x ) ;
-FUNCTION: GpStatus GdipSetPathGradientSurroundColorsWithCount ( GpPathGradient* x,
+FUNCTION: GpStatus GdipSetPathGradientSurroundColorsWithCount ( GpPathGradient* x,
ARGB* x, INT* x ) ;
FUNCTION: GpStatus GdipSetPathGradientWrapMode ( GpPathGradient* x, GpWrapMode x ) ;
FUNCTION: GpStatus GdipGetPathGradientSurroundColorCount ( GpPathGradient* x, INT* x ) ;
FUNCTION: GpStatus GdipCreatePathIter ( GpPathIterator** x, GpPath* x ) ;
FUNCTION: GpStatus GdipDeletePathIter ( GpPathIterator* x ) ;
-FUNCTION: GpStatus GdipPathIterCopyData ( GpPathIterator* x, INT* x, GpPointF* x, BYTE* x,
+FUNCTION: GpStatus GdipPathIterCopyData ( GpPathIterator* x, INT* x, GpPointF* x, BYTE* x,
INT x, INT x ) ;
FUNCTION: GpStatus GdipPathIterGetCount ( GpPathIterator* x, INT* x ) ;
FUNCTION: GpStatus GdipPathIterGetSubpathCount ( GpPathIterator* x, INT* x ) ;
FUNCTION: GpStatus GdipCreateStringFormat ( INT x, LANGID x, GpStringFormat** x ) ;
FUNCTION: GpStatus GdipDeleteStringFormat ( GpStringFormat* x ) ;
FUNCTION: GpStatus GdipGetStringFormatAlign ( GpStringFormat* x, StringAlignment* x ) ;
-FUNCTION: GpStatus GdipGetStringFormatDigitSubstitution ( GpStringFormat* x, LANGID* x,
+FUNCTION: GpStatus GdipGetStringFormatDigitSubstitution ( GpStringFormat* x, LANGID* x,
StringDigitSubstitute* x ) ;
FUNCTION: GpStatus GdipGetStringFormatFlags ( GpStringFormat* x, INT* x ) ;
FUNCTION: GpStatus GdipGetStringFormatHotkeyPrefix ( GpStringFormat* x, INT* x ) ;
FUNCTION: GpStatus GdipGetStringFormatLineAlign ( GpStringFormat* x, StringAlignment* x ) ;
-FUNCTION: GpStatus GdipGetStringFormatMeasurableCharacterRangeCount (
+FUNCTION: GpStatus GdipGetStringFormatMeasurableCharacterRangeCount (
GpStringFormat* x, INT* x ) ;
FUNCTION: GpStatus GdipGetStringFormatTabStopCount ( GpStringFormat* x, INT* x ) ;
FUNCTION: GpStatus GdipGetStringFormatTabStops ( GpStringFormat* x, INT x, REAL* x, REAL* x ) ;
FUNCTION: GpStatus GdipSetStringFormatDigitSubstitution ( GpStringFormat* x, LANGID x, StringDigitSubstitute x ) ;
FUNCTION: GpStatus GdipSetStringFormatHotkeyPrefix ( GpStringFormat* x, INT x ) ;
FUNCTION: GpStatus GdipSetStringFormatLineAlign ( GpStringFormat* x, StringAlignment x ) ;
-FUNCTION: GpStatus GdipSetStringFormatMeasurableCharacterRanges (
+FUNCTION: GpStatus GdipSetStringFormatMeasurableCharacterRanges (
GpStringFormat* x, INT x, CharacterRange* x ) ;
FUNCTION: GpStatus GdipSetStringFormatTabStops ( GpStringFormat* x, REAL x, INT x, REAL* x ) ;
FUNCTION: GpStatus GdipSetStringFormatTrimming ( GpStringFormat* x, StringTrimming x ) ;
FUNCTION: GpStatus GdipCreateTexture ( GpImage* x, GpWrapMode x, GpTexture** x ) ;
FUNCTION: GpStatus GdipCreateTexture2 ( GpImage* x, GpWrapMode x, REAL x, REAL x, REAL x, REAL x, GpTexture** x ) ;
FUNCTION: GpStatus GdipCreateTexture2I ( GpImage* x, GpWrapMode x, INT x, INT x, INT x, INT x, GpTexture** x ) ;
-FUNCTION: GpStatus GdipCreateTextureIA ( GpImage* x, GpImageAttributes* x,
+FUNCTION: GpStatus GdipCreateTextureIA ( GpImage* x, GpImageAttributes* x,
REAL x, REAL x, REAL x, REAL x, GpTexture** x ) ;
-FUNCTION: GpStatus GdipCreateTextureIAI ( GpImage* x, GpImageAttributes* x,
+FUNCTION: GpStatus GdipCreateTextureIAI ( GpImage* x, GpImageAttributes* x,
INT x, INT x, INT x, INT x, GpTexture** x ) ;
FUNCTION: GpStatus GdipGetTextureTransform ( GpTexture* x, GpMatrix* x ) ;
FUNCTION: GpStatus GdipGetTextureWrapMode ( GpTexture* x, GpWrapMode* x ) ;
-FUNCTION: GpStatus GdipMultiplyTextureTransform ( GpTexture* x,
+FUNCTION: GpStatus GdipMultiplyTextureTransform ( GpTexture* x,
GpMatrix* x, GpMatrixOrder x ) ;
FUNCTION: GpStatus GdipResetTextureTransform ( GpTexture* x ) ;
FUNCTION: GpStatus GdipRotateTextureTransform ( GpTexture* x, REAL x, GpMatrixOrder x ) ;
FUNCTION: GpStatus GdipScaleTextureTransform ( GpTexture* x, REAL x, REAL x, GpMatrixOrder x ) ;
FUNCTION: GpStatus GdipSetTextureTransform ( GpTexture* x, GpMatrix* x ) ;
FUNCTION: GpStatus GdipSetTextureWrapMode ( GpTexture* x, GpWrapMode x ) ;
-FUNCTION: GpStatus GdipTranslateTextureTransform ( GpTexture* x, REAL x, REAL x,
+FUNCTION: GpStatus GdipTranslateTextureTransform ( GpTexture* x, REAL x, REAL x,
GpMatrixOrder x ) ;
{ IpAddress IP_ADDRESS_STRING }
{ IpMask IP_MASK_STRING }
{ Context DWORD } ;
-
+
TYPEDEF: IP_ADDR_STRING* PIP_ADDR_STRING
STRUCT: FIXED_INFO
IpDadStateDuplicate,
IpDadStateDeprecated,
IpDadStatePreferred ;
-
+
ENUM: IP_PREFIX_ORIGIN
IpPrefixOriginOther,
IpPrefixOriginManual,
IpPrefixOriginDhcp,
IpPrefixOriginRouterAdvertisement,
{ IpPrefixOriginUnchanged 16 } ;
-
+
ENUM: IP_SUFFIX_ORIGIN
IpSuffixOriginOther
IpSuffixOriginManual,
IpSuffixOriginLinkLayerAddress,
IpSuffixOriginRandom,
{ IpSuffixOriginUnchanged 16 } ;
-
+
ENUM: IF_OPER_STATUS
{ IfOperStatusUp 1 }
IfOperStatusDown,
NET_IF_CONNECTION_PASSIVE,
NET_IF_CONNECTION_DEMAND,
NET_IF_CONNECTION_MAXIMUM ;
-
-
+
+
ENUM: TUNNEL_TYPE
TUNNEL_TYPE_NONE,
TUNNEL_TYPE_OTHER,
TUNNEL_TYPE_DIRECT,
- TUNNEL_TYPE_6TO4,
+ TUNNEL_TYPE_6TO4,
TUNNEL_TYPE_ISATAP,
TUNNEL_TYPE_TEREDO,
TUNNEL_TYPE_IPHTTPS ;
-
-
+
+
STRUCT: SOCKET_ADDRESS
{ lpSockaddr LPSOCKADDR }
{ iSockaddrLength INT } ;
-
+
ERROR: unknown-sockaddr-length sockaddr length ;
-
+
: SOCKET_ADDRESS>sockaddr ( obj -- sockaddr )
dup iSockaddrLength>> {
{ 16 [ lpSockaddr>> sockaddr-in memory>struct ] }
{ 28 [ lpSockaddr>> sockaddr-in6 memory>struct ] }
[ unknown-sockaddr-length ]
} case ;
-
+
TYPEDEF: SOCKET_ADDRESS* PSOCKET_ADDRESS
-
+
STRUCT: IP_ADAPTER_INFO
{ Next IP_ADAPTER_INFO* }
{ ComboIndex DWORD }
STRUCT: LengthIndex
{ Length ULONG }
{ IfIndex DWORD } ;
-
+
TYPEDEF: LengthIndex LengthFlags
UNION-STRUCT: AlignmentLenIndex
{ Alignment ULONGLONG }
{ LenIndex LengthIndex } ;
-
+
UNION-STRUCT: AlignmentLenFlags
{ Alignment ULONGLONG }
{ LenFlags LengthFlags } ;
UNION-STRUCT: NET_LUID
{ Value ULONG64 }
{ Info ResNetIf } ;
-
+
TYPEDEF: NET_LUID* PNET_LUID
TYPEDEF: NET_LUID IF_LUID
{ PreferredLifetime ULONG }
{ LeaseLifeTime ULONG }
{ OnLinkPrefixLength UINT8 } ;
-
+
TYPEDEF: IP_ADAPTER_UNICAST_ADDRESS* PIP_ADAPTER_UNICAST_ADDRESS
DEFER: IP_ADAPTER_ANYCAST_ADDRESS
{ Header AlignmentLenFlags }
{ Next IP_ADAPTER_ANYCAST_ADDRESS* }
{ Address SOCKET_ADDRESS } ;
-
+
TYPEDEF: IP_ADAPTER_ANYCAST_ADDRESS* PIP_ADAPTER_ANYCAST_ADDRESS
{ Header AlignmentLenFlags }
{ Next IP_ADAPTER_MULTICAST_ADDRESS* }
{ Address SOCKET_ADDRESS } ;
-
+
TYPEDEF: IP_ADAPTER_MULTICAST_ADDRESS* PIP_ADAPTER_MULTICAST_ADDRESS
{ Header AlignmentLenFlags }
{ Next IP_ADAPTER_DNS_SERVER_ADDRESS* }
{ Address SOCKET_ADDRESS } ;
-
+
TYPEDEF: IP_ADAPTER_DNS_SERVER_ADDRESS* PIP_ADAPTER_DNS_SERVER_ADDRESS
{ Header AlignmentLenFlags }
{ Next IP_ADAPTER_WINS_SERVER_ADDRESS* }
{ Address SOCKET_ADDRESS } ;
-
+
TYPEDEF: IP_ADAPTER_WINS_SERVER_ADDRESS* PIP_ADAPTER_WINS_SERVER_ADDRESS
TYPEDEF: IP_ADAPTER_WINS_SERVER_ADDRESS* PIP_ADAPTER_WINS_SERVER_ADDRESS_LH
{ Header AlignmentLenFlags }
{ Next IP_ADAPTER_GATEWAY_ADDRESS* }
{ Address SOCKET_ADDRESS } ;
-
+
TYPEDEF: IP_ADAPTER_GATEWAY_ADDRESS* PIP_ADAPTER_GATEWAY_ADDRESS
TYPEDEF: IP_ADAPTER_GATEWAY_ADDRESS* PIP_ADAPTER_GATEWAY_ADDRESS_LH
{ Next IP_ADAPTER_PREFIX* }
{ Address SOCKET_ADDRESS }
{ PrefixLength ULONG } ;
-
+
TYPEDEF: IP_ADAPTER_PREFIX* PIP_ADAPTER_PREFIX
STRUCT: IP_ADAPTER_DNS_SUFFIX
{ Next IP_ADAPTER_DNS_SUFFIX* }
{ String WCHAR[MAX_DNS_SUFFIX_STRING_LENGTH] } ;
-
+
TYPEDEF: IP_ADAPTER_DNS_SUFFIX* PIP_ADAPTER_DNS_SUFFIX
{ s_b2 uchar }
{ s_b3 uchar }
{ s_b4 uchar } ;
-
+
STRUCT: S_un_w
{ s_w1 ushort }
{ s_w2 ushort } ;
{ S_un_b S_un_b }
{ S_un_w S_un_w }
{ S_addr ulong } ;
-
+
UNION-STRUCT: S_un
{ S_un_b S_un_b }
{ S_un_w S_un_w }
{ S_addr ulong } ;
-
+
STRUCT: IP_ADAPTER_INDEX_MAP
{ Index ULONG }
{ Name WCHAR[MAX_ADAPTER_NAME] } ;
FUNCTION: DWORD GetAdaptersInfo (
PIP_ADAPTER_INFO pAdapterInfo,
PULONG pOutBufLen ) ;
-
+
FUNCTION: DWORD GetNetworkParams ( PFIXED_INFO pFixedInfo, PULONG pOutBufLen ) ;
: get-fixed-info ( -- FIXED_INFO )
FIXED_INFO <struct> dup byte-length ulong <ref>
[ GetNetworkParams n>win32-error-check ] 2keep drop ;
-
+
: dns-server-ips ( -- sequence )
get-fixed-info DnsServerList>> [
[
[ Next>> ] bi dup
] loop drop
] { } make ;
-
+
! second struct starts at 720h
[ [ PhysicalAddress>> ] [ PhysicalAddressLength>> ] bi head ]
} cleave>array
] interfaces-map ;
-
+
: interface-ips ( -- seq )
[
{
CONSTANT: OPEN_EXISTING 3
CONSTANT: OPEN_ALWAYS 4
CONSTANT: TRUNCATE_EXISTING 5
-
+
CONSTANT: FILE_LIST_DIRECTORY 0x00000001
CONSTANT: FILE_READ_DAT 0x00000001
CONSTANT: FILE_ADD_FILE 0x00000002
LPVOID lpStartAddress,
LPVOID lpParameter,
DWORD dwCreationFlags,
- LPDWORD lpThreadId ) ;
+ LPDWORD lpThreadId ) ;
! FUNCTION: CreateSemaphoreA
! FUNCTION: CreateSemaphoreW
! FUNCTION: CreateSocketHandle
: HDM_SETBITMAPMARGIN ( -- n ) HDM_FIRST 20 + ; inline
: HDM_GETBITMAPMARGIN ( -- n ) HDM_FIRST 21 + ; inline
CONSTANT: HDM_SETUNICODEFORMAT CCM_SETUNICODEFORMAT
-CONSTANT: HDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
+CONSTANT: HDM_GETUNICODEFORMAT CCM_GETUNICODEFORMAT
: HDM_SETFILTERCHANGETIMEOUT ( -- n ) HDM_FIRST 22 + ; inline
: HDM_EDITFILTER ( -- n ) HDM_FIRST 23 + ; inline
: HDM_CLEARFILTER ( -- n ) HDM_FIRST 24 + ; inline
PVOID ProcessInformation,
ULONG ProcessInformationLength,
PULONG ReturnLength
-) ;
\ No newline at end of file
+) ;
-IN: windows.offscreen.tests\r
-USING: windows.offscreen effects tools.test kernel images ;\r
-\r
-{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as\r
-[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test\r
+IN: windows.offscreen.tests
+USING: windows.offscreen effects tools.test kernel images ;
+
+{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as
+[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test
[ hkey quot call ]
[ hkey close-key ]
[ ] cleanup ; inline
-
+
:: with-create-registry-key ( key subkey quot -- )
key subkey create-key :> hkey
[ hkey quot call ]
f ! 0 BYTE <ref> dup :> data
f ! 0 BYTE <ref> dup :> buffer
RegEnumKeyEx dup ERROR_SUCCESS = [
-
+
] [
] if
] map ;
[ 0 ] 3dip
RegSetValueEx dup ERROR_SUCCESS = [
drop
- ] [
+ ] [
"omg" throw
] if ;
: windows-performance-data ( -- byte-array )
HKEY_PERFORMANCE_DATA "Global" f f
21 2^ <byte-array> reg-query-value-ex ;
-
+
: read-registry ( key subkey -- registry-info )
KEY_READ [ reg-query-info-key ] with-open-registry-key ;
: program-files-common-x86 ( -- str )
CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;
-
+
CONSTANT: SHCONTF_FOLDERS 32
CONSTANT: SHCONTF_NONFOLDERS 64
-USING: accessors alien.c-types alien.data classes.struct\r
-combinators continuations io kernel libc literals locals\r
-sequences specialized-arrays windows.com memoize\r
-windows.com.wrapper windows.kernel32 windows.ole32\r
-windows.types ;\r
-IN: windows.streams\r
-\r
-SPECIALIZED-ARRAY: uchar\r
-\r
-<PRIVATE\r
-\r
-: with-hresult ( quot: ( -- result ) -- result )\r
- [ drop E_FAIL ] recover ; inline\r
-\r
-:: IStream-read ( stream pv cb out-read -- hresult )\r
- [\r
- cb stream stream-read :> buf\r
- buf length :> bytes\r
- pv buf bytes memcpy\r
- out-read [ bytes out-read 0 ULONG set-alien-value ] when\r
-\r
- cb bytes = [ S_OK ] [ S_FALSE ] if\r
- ] with-hresult ; inline\r
-\r
-:: IStream-write ( stream pv cb out-written -- hresult )\r
- [\r
- pv cb uchar <c-direct-array> stream stream-write\r
- out-written [ cb out-written 0 ULONG set-alien-value ] when\r
- S_OK\r
- ] with-hresult ; inline\r
-\r
-: origin>seek-type ( origin -- seek-type )\r
- {\r
- { $ STREAM_SEEK_SET [ seek-absolute ] }\r
- { $ STREAM_SEEK_CUR [ seek-relative ] }\r
- { $ STREAM_SEEK_END [ seek-end ] }\r
- } case ;\r
-\r
-:: IStream-seek ( stream move origin new-position -- hresult )\r
- [\r
- move origin origin>seek-type stream stream-seek\r
- new-position [\r
- stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value\r
- ] when\r
- S_OK\r
- ] with-hresult ; inline\r
-\r
-:: IStream-set-size ( stream new-size -- hresult )\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )\r
- [\r
- cb stream stream-read :> buf\r
- buf length :> bytes\r
- out-read [ bytes out-read 0 ULONG set-alien-value ] when\r
-\r
- other-stream buf bytes out-written IStream::Write\r
- ] with-hresult ; inline\r
-\r
-:: IStream-commit ( stream flags -- hresult )\r
- stream stream-flush S_OK ;\r
-\r
-:: IStream-revert ( stream -- hresult )\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-:: IStream-lock-region ( stream offset cb lock-type -- hresult )\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-:: IStream-unlock-region ( stream offset cb lock-type -- hresult )\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-:: stream-size ( stream -- size )\r
- stream stream-tell :> old-pos\r
- 0 seek-end stream stream-seek\r
- stream stream-tell :> size\r
- old-pos seek-absolute stream stream-seek\r
- size ;\r
-\r
-:: IStream-stat ( stream out-stat stat-flag -- hresult )\r
- [\r
- out-stat\r
- f >>pwcsName\r
- STGTY_STREAM >>type\r
- stream stream-size >>cbSize\r
- FILETIME <struct> >>mtime\r
- FILETIME <struct> >>ctime\r
- FILETIME <struct> >>atime\r
- STGM_READWRITE >>grfMode\r
- 0 >>grfLocksSupported\r
- GUID_NULL >>clsid\r
- 0 >>grfStateBits\r
- 0 >>reserved\r
- drop\r
- S_OK\r
- ] with-hresult ;\r
-\r
-:: IStream-clone ( stream out-clone-stream -- hresult )\r
- f out-clone-stream 0 void* set-alien-value\r
- STG_E_INVALIDFUNCTION ;\r
-\r
-CONSTANT: stream-wrapper\r
- $[\r
- {\r
- { IStream {\r
- [ IStream-read ]\r
- [ IStream-write ]\r
- [ IStream-seek ]\r
- [ IStream-set-size ]\r
- [ IStream-copy-to ]\r
- [ IStream-commit ]\r
- [ IStream-revert ]\r
- [ IStream-lock-region ]\r
- [ IStream-unlock-region ]\r
- [ IStream-stat ]\r
- [ IStream-clone ]\r
- } }\r
- } <com-wrapper>\r
- ]\r
-\r
-PRIVATE>\r
-\r
-: stream>IStream ( stream -- IStream )\r
- stream-wrapper com-wrap ;\r
+USING: accessors alien.c-types alien.data classes.struct
+combinators continuations io kernel libc literals locals
+sequences specialized-arrays windows.com memoize
+windows.com.wrapper windows.kernel32 windows.ole32
+windows.types ;
+IN: windows.streams
+
+SPECIALIZED-ARRAY: uchar
+
+<PRIVATE
+
+: with-hresult ( quot: ( -- result ) -- result )
+ [ drop E_FAIL ] recover ; inline
+
+:: IStream-read ( stream pv cb out-read -- hresult )
+ [
+ cb stream stream-read :> buf
+ buf length :> bytes
+ pv buf bytes memcpy
+ out-read [ bytes out-read 0 ULONG set-alien-value ] when
+
+ cb bytes = [ S_OK ] [ S_FALSE ] if
+ ] with-hresult ; inline
+
+:: IStream-write ( stream pv cb out-written -- hresult )
+ [
+ pv cb uchar <c-direct-array> stream stream-write
+ out-written [ cb out-written 0 ULONG set-alien-value ] when
+ S_OK
+ ] with-hresult ; inline
+
+: origin>seek-type ( origin -- seek-type )
+ {
+ { $ STREAM_SEEK_SET [ seek-absolute ] }
+ { $ STREAM_SEEK_CUR [ seek-relative ] }
+ { $ STREAM_SEEK_END [ seek-end ] }
+ } case ;
+
+:: IStream-seek ( stream move origin new-position -- hresult )
+ [
+ move origin origin>seek-type stream stream-seek
+ new-position [
+ stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value
+ ] when
+ S_OK
+ ] with-hresult ; inline
+
+:: IStream-set-size ( stream new-size -- hresult )
+ STG_E_INVALIDFUNCTION ;
+
+:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )
+ [
+ cb stream stream-read :> buf
+ buf length :> bytes
+ out-read [ bytes out-read 0 ULONG set-alien-value ] when
+
+ other-stream buf bytes out-written IStream::Write
+ ] with-hresult ; inline
+
+:: IStream-commit ( stream flags -- hresult )
+ stream stream-flush S_OK ;
+
+:: IStream-revert ( stream -- hresult )
+ STG_E_INVALIDFUNCTION ;
+
+:: IStream-lock-region ( stream offset cb lock-type -- hresult )
+ STG_E_INVALIDFUNCTION ;
+
+:: IStream-unlock-region ( stream offset cb lock-type -- hresult )
+ STG_E_INVALIDFUNCTION ;
+
+:: stream-size ( stream -- size )
+ stream stream-tell :> old-pos
+ 0 seek-end stream stream-seek
+ stream stream-tell :> size
+ old-pos seek-absolute stream stream-seek
+ size ;
+
+:: IStream-stat ( stream out-stat stat-flag -- hresult )
+ [
+ out-stat
+ f >>pwcsName
+ STGTY_STREAM >>type
+ stream stream-size >>cbSize
+ FILETIME <struct> >>mtime
+ FILETIME <struct> >>ctime
+ FILETIME <struct> >>atime
+ STGM_READWRITE >>grfMode
+ 0 >>grfLocksSupported
+ GUID_NULL >>clsid
+ 0 >>grfStateBits
+ 0 >>reserved
+ drop
+ S_OK
+ ] with-hresult ;
+
+:: IStream-clone ( stream out-clone-stream -- hresult )
+ f out-clone-stream 0 void* set-alien-value
+ STG_E_INVALIDFUNCTION ;
+
+CONSTANT: stream-wrapper
+ $[
+ {
+ { IStream {
+ [ IStream-read ]
+ [ IStream-write ]
+ [ IStream-seek ]
+ [ IStream-set-size ]
+ [ IStream-copy-to ]
+ [ IStream-commit ]
+ [ IStream-revert ]
+ [ IStream-lock-region ]
+ [ IStream-unlock-region ]
+ [ IStream-stat ]
+ [ IStream-clone ]
+ } }
+ } <com-wrapper>
+ ]
+
+PRIVATE>
+
+: stream>IStream ( stream -- IStream )
+ stream-wrapper com-wrap ;
STRUCT: POINT
{ x LONG }
- { y LONG } ;
+ { y LONG } ;
STRUCT: SIZE
{ cx LONG }
CONSTANT: WS_EX_OVERLAPPEDWINDOW
flags{ WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE }
-CONSTANT: WS_EX_PALETTEWINDOW
+CONSTANT: WS_EX_PALETTEWINDOW
flags{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST }
CONSTANT: CS_VREDRAW 0x0001
! : PM_QS_SENDMESSAGE (QS_SENDMESSAGE << 16) ;
-!
+!
! Standard Cursor IDs
!
CONSTANT: IDC_ARROW 32512
! -1 is Simple beep
FUNCTION: BOOL MessageBeep ( UINT uType ) ;
-FUNCTION: int MessageBoxA (
+FUNCTION: int MessageBoxA (
HWND hWnd,
LPCSTR lpText,
LPCSTR lpCaption,
! FUNCTION: SetInternalWindowPos
! FUNCTION: SetKeyboardState
! type is ignored
-FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
+FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
: SetLastError ( errcode -- ) 0 SetLastErrorEx ; inline
! FUNCTION: SetLayeredWindowAttributes
! FUNCTION: SetLogonNotifyWindow
: open-command ( path -- )
"open \"%s\" type mpegvideo alias MediaFile" sprintf f 0 f
mciSendString check-mci-error ;
-
+
: play-command ( -- )
"play MediaFile" f 0 f mciSendString check-mci-error ;
: close-command ( -- )
- "close MediaFile" f 0 f mciSendString check-mci-error ;
\ No newline at end of file
+ "close MediaFile" f 0 f mciSendString check-mci-error ;
: wrap-words ( words line-max line-ideal -- lines )
[ words>elements ] 2dip wrap [ concat ] map! ;
-
CONSTANT: NotifyWhileGrabbed 3
CONSTANT: NotifyHint 1 ! for MotionNotify events
-
+
! Notify detail
CONSTANT: NotifyAncestor 0
HOOK: awaken-event-loop io-backend ( -- )
-M: object awaken-event-loop ;
\ No newline at end of file
+M: object awaken-event-loop ;
: XI_RawButtonPressMask ( -- n ) XI_RawButtonPress 2^ ; inline
: XI_RawButtonReleaseMask ( -- n ) XI_RawButtonRelease 2^ ; inline
: XI_RawMotionMask ( -- n ) XI_RawMotion 2^ ; inline
-
uchar** data ) ;
X-FUNCTION: void XIFreeDeviceInfo ( XIDeviceInfo* info ) ;
-
} case ;
: xi2-available? ( -- ? ) dpy get (xi2-available?) ; inline
-
CONSTANT: XA_WM_TRANSIENT_FOR 68
CONSTANT: XA_LAST_PREDEFINED 68
-
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! The rest of the stuff is not from the book.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
X-FUNCTION: void XDestroyIC ( XIC ic ) ;
X-FUNCTION: void XSetICFocus ( XIC ic ) ;
-
+
X-FUNCTION: void XUnsetICFocus ( XIC ic ) ;
X-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
! uncategorized xlib bindings
X-FUNCTION: int XQueryKeymap ( Display* display, char[32] keys_return ) ;
-
{ 0xFE [ skip-utf16be-bom ] }
[ drop utf8 decode-stream check f ]
} case ;
-
take-decl-contents <attlist-decl> ;
: take-notation-decl ( -- notation-decl )
- take-decl-contents <notation-decl> ;
+ take-decl-contents <notation-decl> ;
UNION: dtd-acceptable
directive comment instruction ;
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
} diff
- [ extra-attrs ] unless-empty ;
+ [ extra-attrs ] unless-empty ;
: good-version ( version -- version )
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
M: tag [undo-xml] ( tag -- quot: ( tag -- ) )
{
[ name>> main>> '[ name>> main>> _ =/fail ] ]
- [ attrs>> undo-attrs ]
+ [ attrs>> undo-attrs ]
[ children>> [undo-xml] '[ children>> @ ] ]
} cleave '[ _ _ _ tri ] ;
-! Copyright (C) 2005, 2009 Daniel Ehrenberg\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: hashtables kernel math namespaces sequences strings\r
-assocs combinators io io.streams.string accessors\r
-xml.data wrap.strings xml.entities unicode.categories fry ;\r
-IN: xml.writer\r
-\r
-SYMBOL: sensitive-tags\r
-SYMBOL: indenter\r
-" " indenter set-global\r
-\r
-<PRIVATE\r
-\r
-SYMBOL: xml-pprint?\r
-SYMBOL: indentation\r
-\r
-: sensitive? ( tag -- ? )\r
- sensitive-tags get swap '[ _ names-match? ] any? ;\r
-\r
-: indent-string ( -- string )\r
- xml-pprint? get\r
- [ indentation get indenter get <repetition> "" concat-as ]\r
- [ "" ] if ;\r
-\r
-: ?indent ( -- )\r
- xml-pprint? get [ nl indent-string write ] when ;\r
-\r
-: indent ( -- )\r
- xml-pprint? get [ 1 indentation +@ ] when ;\r
-\r
-: unindent ( -- )\r
- xml-pprint? get [ -1 indentation +@ ] when ;\r
-\r
-: ?filter-children ( children -- no-whitespace )\r
- xml-pprint? get [\r
- [ dup string? [ [ blank? ] trim ] when ] map\r
- [ "" = ] reject\r
- ] when ;\r
-\r
-PRIVATE>\r
-\r
-: name>string ( name -- string )\r
- [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;\r
-\r
-: print-name ( name -- )\r
- name>string write ;\r
-\r
-<PRIVATE\r
-\r
-: write-quoted ( string -- )\r
- CHAR: " write1 write CHAR: " write1 ;\r
-\r
-: print-attrs ( assoc -- )\r
- [\r
- [ bl print-name "=" write ]\r
- [ escape-quoted-string write-quoted ] bi*\r
- ] assoc-each ;\r
-\r
-PRIVATE>\r
-\r
-GENERIC: write-xml ( xml -- )\r
-\r
-<PRIVATE\r
-\r
-M: string write-xml\r
- escape-string xml-pprint? get [\r
- dup [ blank? ] all?\r
- [ drop "" ]\r
- [ nl 80 indent-string wrap-indented-string ] if\r
- ] when write ;\r
-\r
-: write-tag ( tag -- )\r
- ?indent CHAR: < write1\r
- dup print-name attrs>> print-attrs ;\r
-\r
-: write-start-tag ( tag -- )\r
- write-tag ">" write ;\r
-\r
-M: contained-tag write-xml\r
- write-tag "/>" write ;\r
-\r
-: write-children ( tag -- )\r
- indent children>> ?filter-children\r
- [ write-xml ] each unindent ;\r
-\r
-: write-end-tag ( tag -- )\r
- ?indent "</" write print-name CHAR: > write1 ;\r
-\r
-M: open-tag write-xml\r
- xml-pprint? get [\r
- {\r
- [ write-start-tag ]\r
- [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
- [ write-children ]\r
- [ write-end-tag ]\r
- } cleave\r
- ] dip xml-pprint? set ;\r
-\r
-M: unescaped write-xml\r
- string>> write ;\r
-\r
-M: comment write-xml\r
- "<!--" write text>> write "-->" write ;\r
-\r
-: write-decl ( decl name quot: ( decl -- slot ) -- )\r
- "<!" write swap write bl\r
- [ name>> write bl ]\r
- swap '[ @ write ">" write ] bi ; inline\r
-\r
-M: element-decl write-xml\r
- "ELEMENT" [ content-spec>> ] write-decl ;\r
-\r
-M: attlist-decl write-xml\r
- "ATTLIST" [ att-defs>> ] write-decl ;\r
-\r
-M: notation-decl write-xml\r
- "NOTATION" [ id>> ] write-decl ;\r
-\r
-M: entity-decl write-xml\r
- "<!ENTITY " write\r
- [ pe?>> [ " % " write ] when ]\r
- [ name>> write " \"" write ] [\r
- def>> f xml-pprint?\r
- [ write-xml ] with-variable\r
- "\">" write\r
- ] tri ;\r
-\r
-M: system-id write-xml\r
- "SYSTEM" write bl system-literal>> write-quoted ;\r
-\r
-M: public-id write-xml\r
- "PUBLIC" write bl\r
- [ pubid-literal>> write-quoted bl ]\r
- [ system-literal>> write-quoted ] bi ;\r
-\r
-: write-internal-subset ( dtd -- )\r
- [\r
- "[" write indent\r
- directives>> [ ?indent write-xml ] each\r
- unindent ?indent "]" write\r
- ] when* ;\r
-\r
-M: doctype-decl write-xml\r
- ?indent "<!DOCTYPE " write\r
- [ name>> write bl ]\r
- [ external-id>> [ write-xml bl ] when* ]\r
- [ internal-subset>> write-internal-subset ">" write ] tri ;\r
-\r
-M: directive write-xml\r
- "<!" write text>> write CHAR: > write1 nl ;\r
-\r
-M: instruction write-xml\r
- "<?" write text>> write "?>" write ;\r
-\r
-M: number write-xml\r
- "Numbers are not allowed in XML" throw ;\r
-\r
-M: sequence write-xml\r
- [ write-xml ] each ;\r
-\r
-M: prolog write-xml\r
- "<?xml version=" write\r
- [ version>> write-quoted ]\r
- [ drop " encoding=\"UTF-8\"" write ]\r
- [ standalone>> [ " standalone=\"yes\"" write ] when ] tri\r
- "?>" write ;\r
-\r
-M: xml write-xml\r
- {\r
- [ prolog>> write-xml ]\r
- [ before>> write-xml ]\r
- [ body>> write-xml ]\r
- [ after>> write-xml ]\r
- } cleave ;\r
-\r
-PRIVATE>\r
-\r
-: xml>string ( xml -- string )\r
- [ write-xml ] with-string-writer ;\r
-\r
-: pprint-xml ( xml -- )\r
- [\r
- sensitive-tags [ [ assure-name ] map ] change\r
- 0 indentation set\r
- xml-pprint? on\r
- write-xml\r
- ] with-scope ;\r
-\r
-: pprint-xml>string ( xml -- string )\r
- [ pprint-xml ] with-string-writer ;\r
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: hashtables kernel math namespaces sequences strings
+assocs combinators io io.streams.string accessors
+xml.data wrap.strings xml.entities unicode.categories fry ;
+IN: xml.writer
+
+SYMBOL: sensitive-tags
+SYMBOL: indenter
+" " indenter set-global
+
+<PRIVATE
+
+SYMBOL: xml-pprint?
+SYMBOL: indentation
+
+: sensitive? ( tag -- ? )
+ sensitive-tags get swap '[ _ names-match? ] any? ;
+
+: indent-string ( -- string )
+ xml-pprint? get
+ [ indentation get indenter get <repetition> "" concat-as ]
+ [ "" ] if ;
+
+: ?indent ( -- )
+ xml-pprint? get [ nl indent-string write ] when ;
+
+: indent ( -- )
+ xml-pprint? get [ 1 indentation +@ ] when ;
+
+: unindent ( -- )
+ xml-pprint? get [ -1 indentation +@ ] when ;
+
+: ?filter-children ( children -- no-whitespace )
+ xml-pprint? get [
+ [ dup string? [ [ blank? ] trim ] when ] map
+ [ "" = ] reject
+ ] when ;
+
+PRIVATE>
+
+: name>string ( name -- string )
+ [ main>> ] [ space>> ] bi [ ":" rot 3append ] unless-empty ;
+
+: print-name ( name -- )
+ name>string write ;
+
+<PRIVATE
+
+: write-quoted ( string -- )
+ CHAR: " write1 write CHAR: " write1 ;
+
+: print-attrs ( assoc -- )
+ [
+ [ bl print-name "=" write ]
+ [ escape-quoted-string write-quoted ] bi*
+ ] assoc-each ;
+
+PRIVATE>
+
+GENERIC: write-xml ( xml -- )
+
+<PRIVATE
+
+M: string write-xml
+ escape-string xml-pprint? get [
+ dup [ blank? ] all?
+ [ drop "" ]
+ [ nl 80 indent-string wrap-indented-string ] if
+ ] when write ;
+
+: write-tag ( tag -- )
+ ?indent CHAR: < write1
+ dup print-name attrs>> print-attrs ;
+
+: write-start-tag ( tag -- )
+ write-tag ">" write ;
+
+M: contained-tag write-xml
+ write-tag "/>" write ;
+
+: write-children ( tag -- )
+ indent children>> ?filter-children
+ [ write-xml ] each unindent ;
+
+: write-end-tag ( tag -- )
+ ?indent "</" write print-name CHAR: > write1 ;
+
+M: open-tag write-xml
+ xml-pprint? get [
+ {
+ [ write-start-tag ]
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]
+ [ write-children ]
+ [ write-end-tag ]
+ } cleave
+ ] dip xml-pprint? set ;
+
+M: unescaped write-xml
+ string>> write ;
+
+M: comment write-xml
+ "<!--" write text>> write "-->" write ;
+
+: write-decl ( decl name quot: ( decl -- slot ) -- )
+ "<!" write swap write bl
+ [ name>> write bl ]
+ swap '[ @ write ">" write ] bi ; inline
+
+M: element-decl write-xml
+ "ELEMENT" [ content-spec>> ] write-decl ;
+
+M: attlist-decl write-xml
+ "ATTLIST" [ att-defs>> ] write-decl ;
+
+M: notation-decl write-xml
+ "NOTATION" [ id>> ] write-decl ;
+
+M: entity-decl write-xml
+ "<!ENTITY " write
+ [ pe?>> [ " % " write ] when ]
+ [ name>> write " \"" write ] [
+ def>> f xml-pprint?
+ [ write-xml ] with-variable
+ "\">" write
+ ] tri ;
+
+M: system-id write-xml
+ "SYSTEM" write bl system-literal>> write-quoted ;
+
+M: public-id write-xml
+ "PUBLIC" write bl
+ [ pubid-literal>> write-quoted bl ]
+ [ system-literal>> write-quoted ] bi ;
+
+: write-internal-subset ( dtd -- )
+ [
+ "[" write indent
+ directives>> [ ?indent write-xml ] each
+ unindent ?indent "]" write
+ ] when* ;
+
+M: doctype-decl write-xml
+ ?indent "<!DOCTYPE " write
+ [ name>> write bl ]
+ [ external-id>> [ write-xml bl ] when* ]
+ [ internal-subset>> write-internal-subset ">" write ] tri ;
+
+M: directive write-xml
+ "<!" write text>> write CHAR: > write1 nl ;
+
+M: instruction write-xml
+ "<?" write text>> write "?>" write ;
+
+M: number write-xml
+ "Numbers are not allowed in XML" throw ;
+
+M: sequence write-xml
+ [ write-xml ] each ;
+
+M: prolog write-xml
+ "<?xml version=" write
+ [ version>> write-quoted ]
+ [ drop " encoding=\"UTF-8\"" write ]
+ [ standalone>> [ " standalone=\"yes\"" write ] when ] tri
+ "?>" write ;
+
+M: xml write-xml
+ {
+ [ prolog>> write-xml ]
+ [ before>> write-xml ]
+ [ body>> write-xml ]
+ [ after>> write-xml ]
+ } cleave ;
+
+PRIVATE>
+
+: xml>string ( xml -- string )
+ [ write-xml ] with-string-writer ;
+
+: pprint-xml ( xml -- )
+ [
+ sensitive-tags [ [ assure-name ] map ] change
+ 0 indentation set
+ xml-pprint? on
+ write-xml
+ ] with-scope ;
+
+: pprint-xml>string ( xml -- string )
+ [ pprint-xml ] with-string-writer ;
-! Copyright (C) 2005, 2009 Daniel Ehrenberg\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax xml.data io strings byte-arrays ;\r
-IN: xml\r
-\r
-HELP: string>xml\r
-{ $values { "string" string } { "xml" xml } }\r
-{ $description "Converts a string into an " { $link xml }\r
- " tree for further processing." } ;\r
-\r
-HELP: read-xml\r
-{ $values { "stream" "an input stream" } { "xml" xml } }\r
-{ $description "Exhausts the given stream, reading an XML document from it. A binary stream, one without encoding, should be used as input, and the encoding is automatically detected." } ;\r
-\r
-HELP: file>xml\r
-{ $values { "filename" string } { "xml" xml } }\r
-{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ;\r
-\r
-HELP: bytes>xml\r
-{ $values { "byte-array" byte-array } { "xml" xml } }\r
-{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ;\r
-\r
-{ string>xml read-xml file>xml bytes>xml } related-words\r
-\r
-HELP: read-xml-chunk\r
-{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }\r
-{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag. The encoding is not automatically detected, and a stream with an encoding (ie. one which returns strings from " { $link read } ") should be used as input." }\r
-{ $see-also read-xml } ;\r
-\r
-HELP: each-element\r
-{ $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } }\r
-{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly. The encoding of the stream is automatically detected, so a binary input stream should be used." }\r
-{ $see-also read-xml } ;\r
-\r
-HELP: pull-xml\r
-{ $class-description "Represents the state of a pull-parser for XML. Has one slot, " { $snippet "scope" } ", which is a namespace which contains all relevant state information." }\r
-{ $see-also <pull-xml> pull-event pull-elem } ;\r
-\r
-HELP: <pull-xml>\r
-{ $values { "pull-xml" pull-xml } }\r
-{ $description "Creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." }\r
-{ $see-also pull-xml pull-elem pull-event } ;\r
-\r
-HELP: pull-elem\r
-{ $values { "pull" "an XML pull parser" } { "xml-elem/f" "an XML tag, string, or f" } }\r
-{ $description "Gets the next XML element from the given XML pull parser. Returns f upon exhaustion." }\r
-{ $see-also pull-xml <pull-xml> pull-event } ;\r
-\r
-HELP: pull-event\r
-{ $values { "pull" "an XML pull parser" } { "xml-event/f" "an XML tag event, string, or f" } }\r
-{ $description "Gets the next XML event from the given XML pull parser. Returns f upon exhaustion." }\r
-{ $see-also pull-xml <pull-xml> pull-elem } ;\r
-\r
-HELP: read-dtd\r
-{ $values { "stream" "an input stream" } { "dtd" dtd } }\r
-{ $description "Exhausts a stream, producing a " { $link dtd } " from the contents." } ;\r
-\r
-HELP: file>dtd\r
-{ $values { "filename" string } { "dtd" dtd } }\r
-{ $description "Reads a file in UTF-8, converting it into an XML " { $link dtd } "." } ;\r
-\r
-HELP: string>dtd\r
-{ $values { "string" string } { "dtd" dtd } }\r
-{ $description "Interprets a string as an XML " { $link dtd } "." } ;\r
-\r
-{ read-dtd file>dtd string>dtd } related-words\r
-\r
-ARTICLE: { "xml" "reading" } "Reading XML"\r
-"The following words are used to read something into an XML document"\r
-{ $subsections\r
- read-xml\r
- read-xml-chunk\r
- string>xml\r
- string>xml-chunk\r
- file>xml\r
- bytes>xml\r
-}\r
-"To read a DTD:"\r
-{ $subsections\r
- read-dtd\r
- file>dtd\r
- string>dtd\r
-} ;\r
-\r
-ARTICLE: { "xml" "events" } "Event-based XML parsing"\r
- "In addition to DOM-style parsing based around " { $link read-xml } ", the XML module also provides SAX-style event-based parsing. This uses much of the same data structures as normal XML, with the exception of the classes " { $link xml } " and " { $link tag } " and as such, the article " { $vocab-link "xml.data" } " may be useful in learning how to process documents in this way. Other useful words are:"\r
-{ $subsections\r
- each-element\r
- opener\r
- closer\r
- contained\r
-}\r
-"There is also pull-based parsing to augment the push-parsing of SAX. This is probably easier to use and more logical. It uses the same parsing objects as the above style of parsing, except string elements are always in arrays, for example { \"\" }. Relevant pull-parsing words are:"\r
-{ $subsections\r
- <pull-xml>\r
- pull-xml\r
- pull-event\r
- pull-elem\r
-} ;\r
-\r
-ARTICLE: { "xml" "namespaces" } "Working with XML namespaces"\r
-"The Factor XML parser implements XML namespaces, and provides convenient utilities for working with them. Anywhere in the public API that a name is accepted as an argument, either a string or an XML name is accepted. If a string is used, it is coerced into a name by giving it a null namespace. Names are stored as " { $link name } " tuples, which have slots for the namespace prefix and namespace URL as well as the main part of the tag name." $nl\r
-"To make it easier to create XML names, the parsing word " { $snippet "XML-NS:" } " is provided in the " { $vocab-link "xml.syntax" } " vocabulary." $nl\r
-"When parsing XML, names are automatically augmented with the appropriate namespace URL when the information is available. This does not take into account any XML schema which might allow for such prefixes to be omitted. When generating XML to be written, keep in mind that the XML writer knows only about the literal prefixes and ignores the URLs. It is your job to make sure that they match up correctly, and that there is the appropriate " { $snippet "xmlns" } " declaration." ;\r
-\r
-ARTICLE: "xml" "XML parser"\r
-"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa. The parser checks for well-formedness but is not validating. There is only partial support for processing DTDs."\r
-{ $subsections\r
- { "xml" "reading" }\r
- { "xml" "events" }\r
- { "xml" "namespaces" }\r
-}\r
-{ $vocab-subsection "Writing XML" "xml.writer" }\r
-{ $vocab-subsection "XML parsing errors" "xml.errors" }\r
-{ $vocab-subsection "XML entities" "xml.entities" }\r
-{ $vocab-subsection "XML data types" "xml.data" }\r
-{ $vocab-subsection "Utilities for traversing XML" "xml.traversal" }\r
-{ $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ;\r
-\r
-ABOUT: "xml"\r
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax xml.data io strings byte-arrays ;
+IN: xml
+
+HELP: string>xml
+{ $values { "string" string } { "xml" xml } }
+{ $description "Converts a string into an " { $link xml }
+ " tree for further processing." } ;
+
+HELP: read-xml
+{ $values { "stream" "an input stream" } { "xml" xml } }
+{ $description "Exhausts the given stream, reading an XML document from it. A binary stream, one without encoding, should be used as input, and the encoding is automatically detected." } ;
+
+HELP: file>xml
+{ $values { "filename" string } { "xml" xml } }
+{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ;
+
+HELP: bytes>xml
+{ $values { "byte-array" byte-array } { "xml" xml } }
+{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ;
+
+{ string>xml read-xml file>xml bytes>xml } related-words
+
+HELP: read-xml-chunk
+{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
+{ $description "Rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag. The encoding is not automatically detected, and a stream with an encoding (ie. one which returns strings from " { $link read } ") should be used as input." }
+{ $see-also read-xml } ;
+
+HELP: each-element
+{ $values { "stream" "an input stream" } { "quot" "a quotation ( xml-elem -- )" } }
+{ $description "Parses the XML document, and whenever an event is encountered (a tag piece, comment, parsing instruction, directive or string element), the quotation is called with that event on the stack. The quotation has all responsibility to deal with the event properly. The encoding of the stream is automatically detected, so a binary input stream should be used." }
+{ $see-also read-xml } ;
+
+HELP: pull-xml
+{ $class-description "Represents the state of a pull-parser for XML. Has one slot, " { $snippet "scope" } ", which is a namespace which contains all relevant state information." }
+{ $see-also <pull-xml> pull-event pull-elem } ;
+
+HELP: <pull-xml>
+{ $values { "pull-xml" pull-xml } }
+{ $description "Creates an XML pull-based parser which reads from " { $link input-stream } ", executing all initial XML commands to set up the parser." }
+{ $see-also pull-xml pull-elem pull-event } ;
+
+HELP: pull-elem
+{ $values { "pull" "an XML pull parser" } { "xml-elem/f" "an XML tag, string, or f" } }
+{ $description "Gets the next XML element from the given XML pull parser. Returns f upon exhaustion." }
+{ $see-also pull-xml <pull-xml> pull-event } ;
+
+HELP: pull-event
+{ $values { "pull" "an XML pull parser" } { "xml-event/f" "an XML tag event, string, or f" } }
+{ $description "Gets the next XML event from the given XML pull parser. Returns f upon exhaustion." }
+{ $see-also pull-xml <pull-xml> pull-elem } ;
+
+HELP: read-dtd
+{ $values { "stream" "an input stream" } { "dtd" dtd } }
+{ $description "Exhausts a stream, producing a " { $link dtd } " from the contents." } ;
+
+HELP: file>dtd
+{ $values { "filename" string } { "dtd" dtd } }
+{ $description "Reads a file in UTF-8, converting it into an XML " { $link dtd } "." } ;
+
+HELP: string>dtd
+{ $values { "string" string } { "dtd" dtd } }
+{ $description "Interprets a string as an XML " { $link dtd } "." } ;
+
+{ read-dtd file>dtd string>dtd } related-words
+
+ARTICLE: { "xml" "reading" } "Reading XML"
+"The following words are used to read something into an XML document"
+{ $subsections
+ read-xml
+ read-xml-chunk
+ string>xml
+ string>xml-chunk
+ file>xml
+ bytes>xml
+}
+"To read a DTD:"
+{ $subsections
+ read-dtd
+ file>dtd
+ string>dtd
+} ;
+
+ARTICLE: { "xml" "events" } "Event-based XML parsing"
+ "In addition to DOM-style parsing based around " { $link read-xml } ", the XML module also provides SAX-style event-based parsing. This uses much of the same data structures as normal XML, with the exception of the classes " { $link xml } " and " { $link tag } " and as such, the article " { $vocab-link "xml.data" } " may be useful in learning how to process documents in this way. Other useful words are:"
+{ $subsections
+ each-element
+ opener
+ closer
+ contained
+}
+"There is also pull-based parsing to augment the push-parsing of SAX. This is probably easier to use and more logical. It uses the same parsing objects as the above style of parsing, except string elements are always in arrays, for example { \"\" }. Relevant pull-parsing words are:"
+{ $subsections
+ <pull-xml>
+ pull-xml
+ pull-event
+ pull-elem
+} ;
+
+ARTICLE: { "xml" "namespaces" } "Working with XML namespaces"
+"The Factor XML parser implements XML namespaces, and provides convenient utilities for working with them. Anywhere in the public API that a name is accepted as an argument, either a string or an XML name is accepted. If a string is used, it is coerced into a name by giving it a null namespace. Names are stored as " { $link name } " tuples, which have slots for the namespace prefix and namespace URL as well as the main part of the tag name." $nl
+"To make it easier to create XML names, the parsing word " { $snippet "XML-NS:" } " is provided in the " { $vocab-link "xml.syntax" } " vocabulary." $nl
+"When parsing XML, names are automatically augmented with the appropriate namespace URL when the information is available. This does not take into account any XML schema which might allow for such prefixes to be omitted. When generating XML to be written, keep in mind that the XML writer knows only about the literal prefixes and ignores the URLs. It is your job to make sure that they match up correctly, and that there is the appropriate " { $snippet "xmlns" } " declaration." ;
+
+ARTICLE: "xml" "XML parser"
+"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa. The parser checks for well-formedness but is not validating. There is only partial support for processing DTDs."
+{ $subsections
+ { "xml" "reading" }
+ { "xml" "events" }
+ { "xml" "namespaces" }
+}
+{ $vocab-subsection "Writing XML" "xml.writer" }
+{ $vocab-subsection "XML parsing errors" "xml.errors" }
+{ $vocab-subsection "XML entities" "xml.entities" }
+{ $vocab-subsection "XML data types" "xml.data" }
+{ $vocab-subsection "Utilities for traversing XML" "xml.traversal" }
+{ $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ;
+
+ABOUT: "xml"
: no-post-tags ( post -- post/* )
! this does *not* affect the contents of the stack
- dup [ tag? ] any? [ multitags ] when ;
+ dup [ tag? ] any? [ multitags ] when ;
: assure-tags ( seq -- seq )
! this does *not* affect the contents of the stack
-! Copyright (C) 2007, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: io io.files io.pathnames io.encodings.utf8 namespaces\r
-http.server http.server.responses http.server.static http\r
-xmode.code2html kernel sequences accessors fry ;\r
-IN: xmode.code2html.responder\r
-\r
-: <sources> ( root -- responder )\r
- [\r
- drop\r
- dup '[\r
- _ utf8 [\r
- _ file-name input-stream get htmlize-stream\r
- ] with-file-reader\r
- ] <html-content>\r
- ] <file-responder> ;\r
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files io.pathnames io.encodings.utf8 namespaces
+http.server http.server.responses http.server.static http
+xmode.code2html kernel sequences accessors fry ;
+IN: xmode.code2html.responder
+
+: <sources> ( root -- responder )
+ [
+ drop
+ dup '[
+ _ utf8 [
+ _ file-name input-stream get htmlize-stream
+ ] with-file-reader
+ ] <html-content>
+ ] <file-responder> ;
-USING: byte-arrays kernel math sequences sequences.private\r
-tools.test ;\r
-IN: byte-arrays.tests\r
-\r
-[ 6 B{ 1 2 3 } ] [\r
- 6 B{ 1 2 3 } resize-byte-array\r
- [ length ] [ 3 head ] bi\r
-] unit-test\r
-\r
-[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test\r
-\r
-[ -10 B{ } resize-byte-array ] must-fail\r
-\r
-[ B{ 123 } ] [ 123 1byte-array ] unit-test\r
-\r
-[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test\r
-\r
-[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test\r
-\r
-[ 1.5 B{ 1 2 3 } nth-unsafe ] must-fail\r
-[ 0 1.5 B{ 1 2 3 } set-nth-unsafe ] must-fail\r
+USING: byte-arrays kernel math sequences sequences.private
+tools.test ;
+IN: byte-arrays.tests
+
+[ 6 B{ 1 2 3 } ] [
+ 6 B{ 1 2 3 } resize-byte-array
+ [ length ] [ 3 head ] bi
+] unit-test
+
+[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
+
+[ -10 B{ } resize-byte-array ] must-fail
+
+[ B{ 123 } ] [ 123 1byte-array ] unit-test
+
+[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test
+
+[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test
+
+[ 1.5 B{ 1 2 3 } nth-unsafe ] must-fail
+[ 0 1.5 B{ 1 2 3 } set-nth-unsafe ] must-fail
-USING: help.markup help.syntax sequences ;\r
-IN: byte-vectors\r
-\r
-ARTICLE: "byte-vectors" "Byte vectors"\r
-"The " { $vocab-link "byte-vectors" } " vocabulary implements resizable mutable sequence of unsigned bytes. Byte vectors implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them."\r
-$nl\r
-"Byte vectors form a class:"\r
-{ $subsections\r
- byte-vector\r
- byte-vector?\r
-}\r
-"Creating byte vectors:"\r
-{ $subsections\r
- >byte-vector\r
- <byte-vector>\r
-}\r
-"Literal syntax:"\r
-{ $subsections POSTPONE: BV{ }\r
-"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
-{ $code "BV{ } clone" } ;\r
-\r
-ABOUT: "byte-vectors"\r
-\r
-HELP: byte-vector\r
-{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
-\r
-HELP: <byte-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
-\r
-HELP: >byte-vector\r
-{ $values { "seq" sequence } { "byte-vector" byte-vector } }\r
-{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
-\r
-HELP: BV{\r
-{ $syntax "BV{ elements... }" }\r
-{ $values { "elements" "a list of bytes" } }\r
-{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
-{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
+USING: help.markup help.syntax sequences ;
+IN: byte-vectors
+
+ARTICLE: "byte-vectors" "Byte vectors"
+"The " { $vocab-link "byte-vectors" } " vocabulary implements resizable mutable sequence of unsigned bytes. Byte vectors implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them."
+$nl
+"Byte vectors form a class:"
+{ $subsections
+ byte-vector
+ byte-vector?
+}
+"Creating byte vectors:"
+{ $subsections
+ >byte-vector
+ <byte-vector>
+}
+"Literal syntax:"
+{ $subsections POSTPONE: BV{ }
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"
+{ $code "BV{ } clone" } ;
+
+ABOUT: "byte-vectors"
+
+HELP: byte-vector
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;
+
+HELP: <byte-vector>
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;
+
+HELP: >byte-vector
+{ $values { "seq" sequence } { "byte-vector" byte-vector } }
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;
+
+HELP: BV{
+{ $syntax "BV{ elements... }" }
+{ $values { "elements" "a list of bytes" } }
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." }
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;
-USING: tools.test byte-vectors vectors sequences kernel\r
-prettyprint math ;\r
-IN: byte-vectors.tests\r
-\r
-[ 0 ] [ 123 <byte-vector> length ] unit-test\r
-\r
-: do-it ( seq -- seq )\r
- 123 [ suffix! ] each-integer ;\r
-\r
-[ t ] [\r
- 3 <byte-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ BV{ } byte-vector? ] unit-test\r
-\r
-[ "BV{ }" ] [ BV{ } unparse ] unit-test\r
+USING: tools.test byte-vectors vectors sequences kernel
+prettyprint math ;
+IN: byte-vectors.tests
+
+[ 0 ] [ 123 <byte-vector> length ] unit-test
+
+: do-it ( seq -- seq )
+ 123 [ suffix! ] each-integer ;
+
+[ t ] [
+ 3 <byte-vector> do-it
+ 3 <vector> do-it sequence=
+] unit-test
+
+[ t ] [ BV{ } byte-vector? ] unit-test
+
+[ "BV{ }" ] [ BV{ } unparse ] unit-test
-USING: classes classes.private help.markup help.syntax kernel\r
-math sequences ;\r
-IN: classes.algebra\r
-\r
-ARTICLE: "class-operations" "Class operations"\r
-"Set-theoretic operations on classes:"\r
-{ $subsections\r
- class=\r
- class<\r
- class<=\r
- class-and\r
- class-or\r
- classes-intersect?\r
- flatten-class\r
-} ;\r
-\r
-ARTICLE: "class-linearization" "Class linearization"\r
-"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:"\r
-{ $list\r
- "If a generic word defines a method on a mixin class A and another on class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both."\r
- { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." }\r
-}\r
-"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:"\r
-{ $list\r
- "Built-in classes and tuple classes"\r
- "Predicate classes"\r
- "Union classes"\r
- "Mixin classes"\r
-}\r
-"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class."\r
-$nl\r
-"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used."\r
-$nl\r
-"Operations:"\r
-{ $subsections\r
- class<\r
- sort-classes\r
- smallest-class\r
-}\r
-"Metaclass order:"\r
-{ $subsections rank-class } ;\r
-\r
-HELP: flatten-class\r
-{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }\r
-{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;\r
-\r
-HELP: class<=\r
-{ $values { "first" "a class" } { "second" "a class" } { "?" boolean } }\r
-{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }\r
-{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 <= class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;\r
-\r
-HELP: sort-classes\r
-{ $values { "seq" "a sequence of class" } { "newseq" "a new sequence of classes" } }\r
-{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;\r
-\r
-HELP: class-or\r
-{ $values { "first" class } { "second" class } { "class" class } }\r
-{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;\r
-\r
-HELP: class-and\r
-{ $values { "first" class } { "second" class } { "class" class } }\r
-{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;\r
-\r
-HELP: classes-intersect?\r
-{ $values { "first" class } { "second" class } { "?" boolean } }\r
-{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;\r
-\r
-HELP: smallest-class\r
-{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } }\r
-{ $description "Outputs a minimum class from the given sequence." } ;\r
+USING: classes classes.private help.markup help.syntax kernel
+math sequences ;
+IN: classes.algebra
+
+ARTICLE: "class-operations" "Class operations"
+"Set-theoretic operations on classes:"
+{ $subsections
+ class=
+ class<
+ class<=
+ class-and
+ class-or
+ classes-intersect?
+ flatten-class
+} ;
+
+ARTICLE: "class-linearization" "Class linearization"
+"Classes have an intrinsic partial order; given two classes A and B, we either have that A is a subset of B, B is a subset of A, A and B are equal as sets, or they are incomparable. The last two situations present difficulties for method dispatch:"
+{ $list
+ "If a generic word defines a method on a mixin class A and another on class B, and B is the only instance of A, there is an ambiguity because A and B are equal as sets; any object that is an instance of one is an instance of both."
+ { "If a generic word defines methods on two union classes which are incomparable but not disjoint, for example " { $link sequence } " and " { $link number } ", there is an ambiguity because the generic word may be called on an object that is an instance of both unions." }
+}
+"The first ambiguity is resolved with a tie-breaker that compares metaclasses. The intrinsic meta-class order, from most-specific to least-specific:"
+{ $list
+ "Built-in classes and tuple classes"
+ "Predicate classes"
+ "Union classes"
+ "Mixin classes"
+}
+"This means that in the above example, the generic word with methods on a mixin and its sole instance will always call the method for the sole instance, since it is more specific than a mixin class."
+$nl
+"The second problem is resolved with another tie-breaker. When performing the topological sort of classes, if there are multiple candidates at any given step of the sort, lexicographical order on the class name is used."
+$nl
+"Operations:"
+{ $subsections
+ class<
+ sort-classes
+ smallest-class
+}
+"Metaclass order:"
+{ $subsections rank-class } ;
+
+HELP: flatten-class
+{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
+{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
+
+HELP: class<=
+{ $values { "first" "a class" } { "second" "a class" } { "?" boolean } }
+{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
+{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 <= class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
+
+HELP: sort-classes
+{ $values { "seq" "a sequence of class" } { "newseq" "a new sequence of classes" } }
+{ $description "Outputs a linear sort of a sequence of classes. Larger classes come before their subclasses." } ;
+
+HELP: class-or
+{ $values { "first" class } { "second" class } { "class" class } }
+{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
+
+HELP: class-and
+{ $values { "first" class } { "second" class } { "class" class } }
+{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
+
+HELP: classes-intersect?
+{ $values { "first" class } { "second" class } { "?" boolean } }
+{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
+
+HELP: smallest-class
+{ $values { "classes" "a sequence of class words" } { "class/f" { $maybe class } } }
+{ $description "Outputs a minimum class from the given sequence." } ;
M: pathname absolute-path string>> absolute-path ;
M: pathname <=> [ string>> ] compare ;
-
-USING: layouts math tools.test ;\r
-IN: system.tests\r
-\r
-[ t ] [ cell integer? ] unit-test\r
-[ t ] [ bootstrap-cell integer? ] unit-test\r
-\r
-! Smoke test\r
-[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test\r
-\r
-[ t ] [ most-negative-fixnum fixnum? ] unit-test\r
-[ t ] [ most-positive-fixnum fixnum? ] unit-test\r
+USING: layouts math tools.test ;
+IN: system.tests
+
+[ t ] [ cell integer? ] unit-test
+[ t ] [ bootstrap-cell integer? ] unit-test
+
+! Smoke test
+[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test
+
+[ t ] [ most-negative-fixnum fixnum? ] unit-test
+[ t ] [ most-positive-fixnum fixnum? ] unit-test
[ iter-length>> * >fixnum ]
[ bytes>> ]
[ count>> ]
- [ c-type>> ]
+ [ c-type>> ]
} cleave <displaced-direct-array> ; inline
INSTANCE: data-map-param immutable-sequence
: [>param] ( type -- quot )
c-type-count over c-type-name?
- [ [>c-type-param] ] [ [>object-param] ] if ;
+ [ [>c-type-param] ] [ [>object-param] ] if ;
MACRO: >param ( in -- quot: ( array -- param ) )
[>param] ;
: [alloc-param] ( type -- quot )
c-type-count over c-type-name?
- [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
+ [ [alloc-c-type-param] ] [ [alloc-object-param] ] if ;
MACRO: alloc-param ( out -- quot: ( len -- param ) )
[alloc-param] ;
SYNTAX: data-map!(
parse-data-map-effect \ data-map! suffix! ;
-
: lowercase-name-with-underscore ( name -- name' )
>lower "_" append ;
: lowercase-name-with-extra-underscore ( name -- name' )
- >lower CHAR: _ over member?
+ >lower CHAR: _ over member?
[ "__" append ] [ "_" append ] if ;
HOOK: fortran-c-abi fortran-abi ( -- abi )
GENERIC: (<fortran-result>) ( type -- quot )
-M: fortran-type (<fortran-result>)
+M: fortran-type (<fortran-result>)
(fortran-type>c-type) \ heap-size \ <byte-array> [ ] 3sequence ;
M: character-type (<fortran-result>)
: [fortran-args>c-args] ( parameters -- quot )
[ [ ] ] [
[ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
- [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
+ [ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
\ ncleave [ ] 3sequence
] if-empty ;
-:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
+:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
return parameters fortran-sig>c-sig :> ( c-return c-parameters )
function fortran-name>symbol-name :> c-function
- [args>args]
+ [args>args]
c-return library c-function c-parameters \ alien-invoke
5 [ ] nsequence
c-parameters length \ nkeep
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [
- c:void swap
+ c:void swap
[ added-c-args ] [ (fortran-type>c-type) <pointer> ] bi prefix
] if ;
return library function parameters return [ c:void ] unless* parse-arglist
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
-SYNTAX: SUBROUTINE:
+SYNTAX: SUBROUTINE:
f current-library get scan-token ";" parse-tokens
[ "()" subseq? ] reject define-fortran-function ;
scan-token
[ current-library set ]
[ set-fortran-abi ] bi ;
-
alien-address release-alien-handle ; inline
DESTRUCTOR: release-alien-handle-ptr
-
annotation-tags [ define-annotation ] each
>>
-
{ "universal"
H{
{ "primitive"
- H{
+ H{
{ 1 "boolean" }
{ 2 "integer" }
{ 4 "string" }
: set-content-length ( -- )
read1
- dup 127 <= [
+ dup 127 <= [
127 bitand read be>
] unless elements get contentlength<< ;
elements get tagclass>> of
elements get encoding>> of
elements get tag>>
- of [
+ of [
elements get objtype<<
] when*
] each ;
}
}
{ "constructed"
- H{
+ H{
{ 0 "array" } ! BindRequest
{ 1 "array" } ! BindResponse
{ 2 "array" } ! UnbindRequest
: verify-aiff ( chunk -- )
{
[ FORM-MAGIC id= ]
- [ form-chunk memory>struct form-type>> 4 memory>byte-array AIFF-MAGIC id= ]
+ [ form-chunk memory>struct form-type>> 4 memory>byte-array AIFF-MAGIC id= ]
} 1&&
[ invalid-audio-file ] unless ;
{ { 2 16 } [ drop AL_FORMAT_STEREO16 ] }
[ drop format-unsupported-by-openal ]
} case ;
-
: check-chunk ( chunk id class -- ? )
heap-size [ id= ] [ [ length ] dip >= ] bi-curry* bi and ; inline
-
: update-audio-clip ( audio-clip -- )
[ update-source ] [
- dup al-source>> AL_SOURCE_STATE get-source-param AL_STOPPED =
+ dup al-source>> AL_SOURCE_STATE get-source-param AL_STOPPED =
[ dispose ] [ (update-audio-clip) ] if
] bi ;
: play-static-audio-clip ( audio-engine source audio loop? -- audio-clip/f )
<static-audio-clip> dup [ play-clip ] when* ;
-: play-streaming-audio-clip ( audio-engine source generator buffer-count -- audio-clip/f )
+: play-streaming-audio-clip ( audio-engine source generator buffer-count -- audio-clip/f )
<streaming-audio-clip> dup [ play-clip ] when* ;
: pause-clip ( audio-clip -- )
[ update-listener ]
[ clips>> clone [ update-audio-clip ] each ]
} cleave ;
-
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: assocs combinators continuations fry kernel macros math\r
-namespaces quotations sequences summary ;\r
-\r
-IN: backtrack\r
-\r
-SYMBOL: failure\r
-\r
-ERROR: amb-failure ;\r
-\r
-M: amb-failure summary drop "Backtracking failure" ;\r
-\r
-: fail ( -- )\r
- failure get [ continue ] [ amb-failure ] if* ;\r
-\r
-: must-be-true ( ? -- )\r
- [ fail ] unless ;\r
-\r
-MACRO: checkpoint ( quot -- quot' )\r
- '[\r
- failure get _ '[\r
- '[ failure set _ continue ] callcc0\r
- _ failure set @\r
- ] callcc0\r
- ] ;\r
-\r
-: number-from ( from -- from+n )\r
- [ 1 + number-from ] checkpoint ;\r
-\r
-<PRIVATE\r
-\r
-: preserve ( quot var -- ) [ get [ call ] dip ] keep set ; inline\r
-\r
-: amb-preserve ( quot -- ) failure preserve ; inline\r
-\r
-: unsafe-number-from-to ( to from -- to from+n )\r
- 2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;\r
-\r
-: number-from-to ( to from -- to from+n )\r
- 2dup < [ fail ] when unsafe-number-from-to ;\r
-\r
-: amb-integer ( seq -- int )\r
- length 1 - 0 number-from-to nip ;\r
-\r
-MACRO: unsafe-amb ( seq -- quot )\r
- dup length 1 = [\r
- first 1quotation\r
- ] [\r
- unclip swap '[ _ [ drop _ unsafe-amb ] checkpoint ]\r
- ] if ;\r
-\r
-PRIVATE> \r
-\r
-: amb-lazy ( seq -- elt )\r
- [ amb-integer ] [ nth ] bi ;\r
-\r
-: amb ( seq -- elt )\r
- [ fail f ] [ unsafe-amb ] if-empty ; inline\r
-\r
-MACRO: amb-execute ( seq -- quot )\r
- [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi\r
- '[ _ 0 unsafe-number-from-to nip _ case ] ;\r
-\r
-: if-amb ( true false -- ? )\r
- [\r
- [ { t f } amb ]\r
- [ '[ @ must-be-true t ] ]\r
- [ '[ @ f ] ]\r
- tri* if\r
- ] amb-preserve ; inline\r
-\r
-: cut-amb ( -- )\r
- f failure set ;\r
-\r
-: amb-all ( quot -- )\r
- [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline\r
-\r
-: bag-of ( quot -- seq )\r
- V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline\r
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: assocs combinators continuations fry kernel macros math
+namespaces quotations sequences summary ;
+
+IN: backtrack
+
+SYMBOL: failure
+
+ERROR: amb-failure ;
+
+M: amb-failure summary drop "Backtracking failure" ;
+
+: fail ( -- )
+ failure get [ continue ] [ amb-failure ] if* ;
+
+: must-be-true ( ? -- )
+ [ fail ] unless ;
+
+MACRO: checkpoint ( quot -- quot' )
+ '[
+ failure get _ '[
+ '[ failure set _ continue ] callcc0
+ _ failure set @
+ ] callcc0
+ ] ;
+
+: number-from ( from -- from+n )
+ [ 1 + number-from ] checkpoint ;
+
+<PRIVATE
+
+: preserve ( quot var -- ) [ get [ call ] dip ] keep set ; inline
+
+: amb-preserve ( quot -- ) failure preserve ; inline
+
+: unsafe-number-from-to ( to from -- to from+n )
+ 2dup = [ [ 1 + unsafe-number-from-to ] checkpoint ] unless ;
+
+: number-from-to ( to from -- to from+n )
+ 2dup < [ fail ] when unsafe-number-from-to ;
+
+: amb-integer ( seq -- int )
+ length 1 - 0 number-from-to nip ;
+
+MACRO: unsafe-amb ( seq -- quot )
+ dup length 1 = [
+ first 1quotation
+ ] [
+ unclip swap '[ _ [ drop _ unsafe-amb ] checkpoint ]
+ ] if ;
+
+PRIVATE>
+
+: amb-lazy ( seq -- elt )
+ [ amb-integer ] [ nth ] bi ;
+
+: amb ( seq -- elt )
+ [ fail f ] [ unsafe-amb ] if-empty ; inline
+
+MACRO: amb-execute ( seq -- quot )
+ [ length 1 - ] [ <enum> [ 1quotation ] assoc-map ] bi
+ '[ _ 0 unsafe-number-from-to nip _ case ] ;
+
+: if-amb ( true false -- ? )
+ [
+ [ { t f } amb ]
+ [ '[ @ must-be-true t ] ]
+ [ '[ @ f ] ]
+ tri* if
+ ] amb-preserve ; inline
+
+: cut-amb ( -- )
+ f failure set ;
+
+: amb-all ( quot -- )
+ [ { t f } amb [ call fail ] [ drop ] if ] amb-preserve ; inline
+
+: bag-of ( quot -- seq )
+ V{ } clone [ '[ @ _ push ] amb-all ] keep ; inline
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.syntax help.markup cpu.8080.emulator ;\r
-IN: balloon-bomber\r
-\r
-HELP: run-balloon\r
-{ $description \r
-"Run the Balloon Bomber emulator in a new window." $nl\r
-{ $link rom-root } " must be set to the directory containing the "\r
-"location of the Balloon Bomber ROM files. See " \r
-{ $link { "balloon-bomber" "balloon-bomber" } } " for details."\r
-} ;\r
-\r
-ARTICLE: { "balloon-bomber" "balloon-bomber" } "Balloon Bomber Emulator"\r
-"Provides an emulation of the original 8080 Arcade Game 'Balloon Bomber'." $nl\r
-"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/ballbomb" } "." $nl\r
-"To play the game you need the ROM files for the arcade game. They should "\r
-"be placed in a directory called 'ballbomb' in the location specified by "\r
-"the variable " { $link rom-root } ". The specific files needed are:"\r
-{ $list\r
- "ballbomb/tn01"\r
- "ballbomb/tn02"\r
- "ballbomb/tn03"\r
- "ballbomb/tn04"\r
- "ballbomb/tn05-1"\r
-}\r
-"These are the same ROM files as used by MAME. To run the game use the " \r
-{ $link run-balloon } " word." $nl\r
-"Keys:" \r
-{ $table\r
- { "Backspace" "Insert Coin" }\r
- { "1" "1 Player" }\r
- { "2" "2 Player" }\r
- { "Left" "Move Left" }\r
- { "Right" "Move Right" }\r
- { "Up" "Fire" }\r
-}\r
-"If you save the Factor image while a game is running, when you restart "\r
-"the image the game continues where it left off." ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup cpu.8080.emulator ;
+IN: balloon-bomber
+
+HELP: run-balloon
+{ $description
+"Run the Balloon Bomber emulator in a new window." $nl
+{ $link rom-root } " must be set to the directory containing the "
+"location of the Balloon Bomber ROM files. See "
+{ $link { "balloon-bomber" "balloon-bomber" } } " for details."
+} ;
+
+ARTICLE: { "balloon-bomber" "balloon-bomber" } "Balloon Bomber Emulator"
+"Provides an emulation of the original 8080 Arcade Game 'Balloon Bomber'." $nl
+"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/ballbomb" } "." $nl
+"To play the game you need the ROM files for the arcade game. They should "
+"be placed in a directory called 'ballbomb' in the location specified by "
+"the variable " { $link rom-root } ". The specific files needed are:"
+{ $list
+ "ballbomb/tn01"
+ "ballbomb/tn02"
+ "ballbomb/tn03"
+ "ballbomb/tn04"
+ "ballbomb/tn05-1"
+}
+"These are the same ROM files as used by MAME. To run the game use the "
+{ $link run-balloon } " word." $nl
+"Keys:"
+{ $table
+ { "Backspace" "Insert Coin" }
+ { "1" "1 Player" }
+ { "2" "2 Player" }
+ { "Left" "Move Left" }
+ { "Right" "Move Right" }
+ { "Up" "Fire" }
+}
+"If you save the Factor image while a game is running, when you restart "
+"the image the game continues where it left off." ;
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-! Balloon Bomber: http://www.mameworld.net/maws/romset/ballbomb\r
-!\r
-USING: kernel space-invaders ui ;\r
-IN: balloon-bomber\r
-\r
-TUPLE: balloon-bomber < space-invaders ;\r
-\r
-: <balloon-bomber> ( -- cpu )\r
- balloon-bomber new cpu-init ;\r
-\r
-CONSTANT: rom-info {\r
- { 0x0000 "ballbomb/tn01" }\r
- { 0x0800 "ballbomb/tn02" }\r
- { 0x1000 "ballbomb/tn03" }\r
- { 0x1800 "ballbomb/tn04" }\r
- { 0x4000 "ballbomb/tn05-1" }\r
-}\r
-\r
-: run-balloon ( -- )\r
- [\r
- "Ballon Bomber" <balloon-bomber> rom-info run-rom\r
- ] with-ui ;\r
-\r
-MAIN: run-balloon\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Balloon Bomber: http://www.mameworld.net/maws/romset/ballbomb
+!
+USING: kernel space-invaders ui ;
+IN: balloon-bomber
+
+TUPLE: balloon-bomber < space-invaders ;
+
+: <balloon-bomber> ( -- cpu )
+ balloon-bomber new cpu-init ;
+
+CONSTANT: rom-info {
+ { 0x0000 "ballbomb/tn01" }
+ { 0x0800 "ballbomb/tn02" }
+ { 0x1000 "ballbomb/tn03" }
+ { 0x1800 "ballbomb/tn04" }
+ { 0x4000 "ballbomb/tn05-1" }
+}
+
+: run-balloon ( -- )
+ [
+ "Ballon Bomber" <balloon-bomber> rom-info run-rom
+ ] with-ui ;
+
+MAIN: run-balloon
-USING: classes classes.tuple kernel sequences vocabs math ;\r
-IN: benchmark.dispatch5\r
-\r
-MIXIN: g\r
-\r
-TUPLE: x1 ;\r
-INSTANCE: x1 g\r
-TUPLE: x2 ;\r
-INSTANCE: x2 g\r
-TUPLE: x3 ;\r
-INSTANCE: x3 g\r
-TUPLE: x4 ;\r
-INSTANCE: x4 g\r
-TUPLE: x5 ;\r
-INSTANCE: x5 g\r
-TUPLE: x6 ;\r
-INSTANCE: x6 g\r
-TUPLE: x7 ;\r
-INSTANCE: x7 g\r
-TUPLE: x8 ;\r
-INSTANCE: x8 g\r
-TUPLE: x9 ;\r
-INSTANCE: x9 g\r
-TUPLE: x10 ;\r
-INSTANCE: x10 g\r
-TUPLE: x11 ;\r
-INSTANCE: x11 g\r
-TUPLE: x12 ;\r
-INSTANCE: x12 g\r
-TUPLE: x13 ;\r
-INSTANCE: x13 g\r
-TUPLE: x14 ;\r
-INSTANCE: x14 g\r
-TUPLE: x15 ;\r
-INSTANCE: x15 g\r
-TUPLE: x16 ;\r
-INSTANCE: x16 g\r
-TUPLE: x17 ;\r
-INSTANCE: x17 g\r
-TUPLE: x18 ;\r
-INSTANCE: x18 g\r
-TUPLE: x19 ;\r
-INSTANCE: x19 g\r
-TUPLE: x20 ;\r
-INSTANCE: x20 g\r
-TUPLE: x21 ;\r
-INSTANCE: x21 g\r
-TUPLE: x22 ;\r
-INSTANCE: x22 g\r
-TUPLE: x23 ;\r
-INSTANCE: x23 g\r
-TUPLE: x24 ;\r
-INSTANCE: x24 g\r
-TUPLE: x25 ;\r
-INSTANCE: x25 g\r
-TUPLE: x26 ;\r
-INSTANCE: x26 g\r
-TUPLE: x27 ;\r
-INSTANCE: x27 g\r
-TUPLE: x28 ;\r
-INSTANCE: x28 g\r
-TUPLE: x29 ;\r
-INSTANCE: x29 g\r
-TUPLE: x30 ;\r
-INSTANCE: x30 g\r
-\r
-: my-classes ( -- seq )\r
- "benchmark.dispatch5" vocab-words [ tuple-class? ] filter ;\r
-\r
-: a-bunch-of-objects ( -- seq )\r
- my-classes [ new ] map ;\r
-\r
-: dispatch5-benchmark ( -- )\r
- 1000000 a-bunch-of-objects\r
- [ f [ g? or ] reduce drop ] curry times ;\r
-\r
-MAIN: dispatch5-benchmark\r
+USING: classes classes.tuple kernel sequences vocabs math ;
+IN: benchmark.dispatch5
+
+MIXIN: g
+
+TUPLE: x1 ;
+INSTANCE: x1 g
+TUPLE: x2 ;
+INSTANCE: x2 g
+TUPLE: x3 ;
+INSTANCE: x3 g
+TUPLE: x4 ;
+INSTANCE: x4 g
+TUPLE: x5 ;
+INSTANCE: x5 g
+TUPLE: x6 ;
+INSTANCE: x6 g
+TUPLE: x7 ;
+INSTANCE: x7 g
+TUPLE: x8 ;
+INSTANCE: x8 g
+TUPLE: x9 ;
+INSTANCE: x9 g
+TUPLE: x10 ;
+INSTANCE: x10 g
+TUPLE: x11 ;
+INSTANCE: x11 g
+TUPLE: x12 ;
+INSTANCE: x12 g
+TUPLE: x13 ;
+INSTANCE: x13 g
+TUPLE: x14 ;
+INSTANCE: x14 g
+TUPLE: x15 ;
+INSTANCE: x15 g
+TUPLE: x16 ;
+INSTANCE: x16 g
+TUPLE: x17 ;
+INSTANCE: x17 g
+TUPLE: x18 ;
+INSTANCE: x18 g
+TUPLE: x19 ;
+INSTANCE: x19 g
+TUPLE: x20 ;
+INSTANCE: x20 g
+TUPLE: x21 ;
+INSTANCE: x21 g
+TUPLE: x22 ;
+INSTANCE: x22 g
+TUPLE: x23 ;
+INSTANCE: x23 g
+TUPLE: x24 ;
+INSTANCE: x24 g
+TUPLE: x25 ;
+INSTANCE: x25 g
+TUPLE: x26 ;
+INSTANCE: x26 g
+TUPLE: x27 ;
+INSTANCE: x27 g
+TUPLE: x28 ;
+INSTANCE: x28 g
+TUPLE: x29 ;
+INSTANCE: x29 g
+TUPLE: x30 ;
+INSTANCE: x30 g
+
+: my-classes ( -- seq )
+ "benchmark.dispatch5" vocab-words [ tuple-class? ] filter ;
+
+: a-bunch-of-objects ( -- seq )
+ my-classes [ new ] map ;
+
+: dispatch5-benchmark ( -- )
+ 1000000 a-bunch-of-objects
+ [ f [ g? or ] reduce drop ] curry times ;
+
+MAIN: dispatch5-benchmark
-USING: math kernel alien alien.c-types ;\r
-IN: benchmark.fib6\r
-\r
-: fib ( x -- y )\r
- int { int } cdecl [\r
- dup 1 <= [ drop 1 ] [\r
- 1 - dup fib swap 1 - fib +\r
- ] if\r
- ] alien-callback\r
- int { int } cdecl alien-indirect ;\r
-\r
-: fib6-benchmark ( -- ) 32 fib drop ;\r
-\r
-MAIN: fib6-benchmark\r
+USING: math kernel alien alien.c-types ;
+IN: benchmark.fib6
+
+: fib ( x -- y )
+ int { int } cdecl [
+ dup 1 <= [ drop 1 ] [
+ 1 - dup fib swap 1 - fib +
+ ] if
+ ] alien-callback
+ int { int } cdecl alien-indirect ;
+
+: fib6-benchmark ( -- ) 32 fib drop ;
+
+MAIN: fib6-benchmark
IN: benchmark.mandel.params
-CONSTANT: max-color 360
-CONSTANT: zoom-fact 0.8
-CONSTANT: width 640
-CONSTANT: height 480
-CONSTANT: max-iterations 40
-CONSTANT: center -0.65
+CONSTANT: max-color 360
+CONSTANT: zoom-fact 0.8
+CONSTANT: width 640
+CONSTANT: height 480
+CONSTANT: max-iterations 40
+CONSTANT: center -0.65
: <sun> ( -- body )
double-4{ 0 0 0 0 } double-4{ 0 0 0 0 } 1 <body> ;
-
+
: offset-momentum ( body offset -- body )
vneg solar-mass v/n >>velocity ; inline
: <sun> ( -- body )
double-array{ 0 0 0 } double-array{ 0 0 0 } 1 <body> ;
-
+
: offset-momentum ( body offset -- body )
vneg solar-mass v/n >>velocity ; inline
print ; inline
: nsieve-bits-main ( n -- )
- [ 2^ 10000 * nsieve-bits. ]
+ [ 2^ 10000 * nsieve-bits. ]
[ 1 - 2^ 10000 * nsieve-bits. ]
[ 2 - 2^ 10000 * nsieve-bits. ]
tri ;
-IN: benchmark.reverse-complement.tests\r
-USING: benchmark.reverse-complement checksums checksums.md5 io.files\r
-io.files.temp kernel tools.test ;\r
-\r
-[ "c071aa7e007a9770b2fb4304f55a17e5" ] [\r
- "resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt"\r
- "reverse-complement-test-out.txt" temp-file\r
- [ reverse-complement ] keep md5 checksum-file hex-string\r
-] unit-test\r
+IN: benchmark.reverse-complement.tests
+USING: benchmark.reverse-complement checksums checksums.md5 io.files
+io.files.temp kernel tools.test ;
+
+[ "c071aa7e007a9770b2fb4304f55a17e5" ] [
+ "resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
+ "reverse-complement-test-out.txt" temp-file
+ [ reverse-complement ] keep md5 checksum-file hex-string
+] unit-test
] times ;
: send-messages ( messages target -- )
- [ dup iota ] dip [ send ] curry each [ receive drop ] times ;
+ [ dup iota ] dip [ send ] curry each [ receive drop ] times ;
: destroy-ring ( target -- )
done swap send [ done eq? ] receive-if drop ;
: ring-bench ( messages processes -- )
- create-ring [ send-messages ] keep destroy-ring ;
+ create-ring [ send-messages ] keep destroy-ring ;
: ring-benchmark ( -- )
1000 1000 ring-bench ;
: eval-A-times-u ( n u -- seq )
[ (eval-A-times-u) ] inner-loop ; inline
-
+
:: eval4-A' ( i j -- n )
j i 4 * 0 + eval-A
j i 4 * 1 + eval-A
20,000 [ outer-loop ] [ loop-max get-global assert= ] bi ;
MAIN: timers-benchmark
-
bitcoin-server >>host
bitcoin-port >>port ;
-:: payload ( method params -- data )
+:: payload ( method params -- data )
"text/plain" <post-data>
binary >>content-encoding
H{
: basic-auth ( -- string )
bitcoin-user bitcoin-password ":" glue >base64 >string
- "Basic " prepend ;
+ "Basic " prepend ;
: bitcoin-request ( method params -- request )
- payload bitcoin-url <post-request>
+ payload bitcoin-url <post-request>
basic-auth "Authorization" set-header
dup post-data>> data>> length "Content-Length" set-header
http-request nip >string json> "result" of ;
#! requires patched bitcoind
:: list-transactions ( count include-generated -- seq )
"listtransactions" { count include-generated } bitcoin-request ;
-
<pile> { 2 2 } >>gap 1.0 >>fill
boids-gadget simulation-panel
- add-gadget
+ add-gadget
boids-gadget behaviours>>
[ behavior-panel add-gadget ] each
MAIN-WINDOW: boids { { title "Boids" } }
create-gadgets
>>gadgets ;
-
CONSTANT: T_Binary_UUID 0x3
CONSTANT: T_Binary_MD5 0x5
CONSTANT: T_Binary_Custom 0x80
-
read-int32 [ f ] [ drop read-elements t ] if-zero ; inline recursive
: bson-binary-read ( -- binary )
- read-int32 read-byte
+ read-int32 read-byte
{
{ T_Binary_Default [ read ] }
{ T_Binary_Bytes_Deprecated [ drop read-int32 read ] }
[ element-data-read ] dip state get set-at ; inline recursive
TYPED: (element-read) ( type: integer -- cont?: boolean )
- dup T_EOO >
+ dup T_EOO >
[ read-cstring (read-object) t ]
[ drop f ] if ; inline recursive
: write-oid-field ( assoc -- )
[ MDB_OID_FIELD dup ] dip at
- [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
+ [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
[ drop ] if* ; inline
: skip-field? ( name value -- name value boolean )
TYPED: write-assoc ( assoc: hashtables -- )
'[ _ [ write-oid-field ] [
- [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+ [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
] bi write-eoo
] with-length-prefix ; inline recursive
[ T_Binary_Custom write1 write ] bi ; inline
: write-string-length ( string -- )
- [ length>> 1 + ]
+ [ length>> 1 + ]
[ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline
TYPED: write-string ( string: string -- )
[ dup integer? ]
[ T_Integer write-header write-int32 ]
} {
- [ dup boolean? ]
+ [ dup boolean? ]
[ T_Boolean write-header write-boolean ]
} {
[ dup real? ]
M: bunny-cel-shaded dispose
program>> delete-gl-program ;
-
M: bunny-fixed-pipeline dispose
drop ;
-
coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD),
coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD),
coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD);
-
+
vec3 normal1 = normal_sample(coord1),
normal2 = normal_sample(coord2),
normal3 = normal_sample(coord3),
depth_sample(coord2),
depth_sample(coord3),
depth_sample(coord4));
-
+
vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
-
+
if (are_depths_border(ratios1) || are_depths_border(ratios2)) {
return 1.0;
} else {
dot(normal2, normal4),
dot(normal3, normal4)
);
-
+
return normal_border;
}
}
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ t >>processing-disabled? drop ]
- [ drop ] if ;
+ [ drop ] if ;
: handle-endif ( preprocessor-state sequence-parser -- )
drop [ 1 - ] change-ifdef-nesting drop ;
[ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
: preprocess-lines ( preprocessor-state -- )
- readln
+ readln
[ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
[ drop ] if* ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs calendar fry kernel locals parser
+USING: accessors assocs calendar fry kernel locals parser
sequences vocabs words memoize ;
IN: calendar.holidays
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs calendar calendar.holidays
calendar.holidays.private combinators combinators.short-circuit
-fry kernel lexer math namespaces parser sequences
+fry kernel lexer math namespaces parser sequences
vocabs words ;
IN: calendar.holidays.us
normalize-image ;
: screenshot. ( window -- )
- [ screenshot <image-gadget> ] [ title>> ] bi open-window ;
+ [ screenshot <image-gadget> ] [ title>> ] bi open-window ;
: <cgi-simple-form> ( -- assoc )
<cgi-form> [ first ] assoc-map ;
-
-
: chicago-talk ( -- ) chicago-slides slides-window ;
-MAIN: chicago-talk
\ No newline at end of file
+MAIN: chicago-talk
] when
] each
] each
-
+
space cpBodyAlloc NAN: 0 dup cpBodyInit cpSpaceAddBody :> body
body -1000 -10 cpv >>p drop
body 400 0 cpv >>v drop
FUNCTION: cpFloat cpMomentForCircle ( cpFloat m, cpFloat r1, cpFloat r2, cpVect offset ) ;
FUNCTION: cpFloat cpMomentForSegment ( cpFloat m, cpVect a, cpVect b ) ;
FUNCTION: cpFloat cpMomentForPoly ( cpFloat m, int numVerts, cpVect* verts, cpVect offset ) ;
-
[ name>> "changed?" = [ '[ _ [ t >>changed? drop ] bi ] ] unless ] bi ;
PRIVATE>
-
! See http://factorcode.org/license.txt for BSD license.
USING: clutter.cally.ffi ;
IN: clutter.cally
-
! See http://factorcode.org/license.txt for BSD license.
USING: clutter.ffi ;
IN: clutter
-
! See http://factorcode.org/license.txt for BSD license.
USING: clutter.cogl.ffi ;
IN: clutter.cogl
-
FOREIGN-ATOMIC-TYPE: GL.enum GLenum
GIR: Cogl-1.0.gir
-
FOREIGN-RECORD-TYPE: cairo.Path cairo_path_t
GIR: Clutter-1.0.gir
-
>>
GIR: GtkClutter-1.0.gir
-
! See http://factorcode.org/license.txt for BSD license.
USING: clutter.gtk.ffi ;
IN: clutter.gtk
-
! See http://factorcode.org/license.txt for BSD license.
USING: clutter.json.ffi ;
IN: clutter.json
-
: include-file-name? ( name -- ? )
{
- [ path-components [ "." head? ] any? not ]
+ [ path-components [ "." head? ] any? not ]
[ link-info type>> +regular-file+ = ]
} 1&& ;
file name>> :> name
name file-html-name :> filename
i 2 + number>string :> istr
-
+
[XML <navPoint class="book" id=<-filename-> playOrder=<-istr->>
<navLabel><text><-name-></text></navLabel>
<content src=<-filename-> />
<-file-nav-points->
</navMap>
</ncx> XML> ;
-
+
:: code>opf ( dir name files -- xml )
"Generating OPF manifest" print flush
name ".ncx" append :> ncx-name
class all-slots [ assoc n (tuple-slot-quot) ] map :> quots
class <wrapper> :> \class
{ quots n ncleave \class boa } >quotation ;
-
+
: make-tuple ( x class assoc -- tuple )
1 nmake-tuple ; inline
: 3make-tuple ( x y z class assoc -- tuple )
3 nmake-tuple ; inline
-
: narray-quot ( length -- quot )
[
[ , [ f <array> ] % ]
- [
+ [
dup iota [
- 1 - , [ swap [ set-array-nth ] keep ] %
] with each
M: ##xor-vector vector-not-src
dup src1>> vreg>insn ##fill-vector? [ src2>> ] [ src1>> ] if ;
-M: ##and-vector rewrite
+M: ##and-vector rewrite
{
{ [ dup src1>> vreg>insn vector-not? ] [
{
slots length
default-params length
'[
- _ narray slot-assoc swap zip
+ _ narray slot-assoc swap zip
default-params swap assoc-union values _ firstn class boa
] ;
SYNTAX: SLOT-CONSTRUCTOR:
scan-new-word [ name>> "(" append create-reset ] keep
'[ scan-rest-input-effect in>> _ '[ _ _ slots>boa ] append! ] define-syntax ;
-
coroutine new
dup current-coro associate
[
- swapd , , \ with-variables ,
+ swapd , , \ with-variables ,
"Coroutine has terminated illegally." , \ throw ,
] [ ] make
[ >>resumecc ] [ >>originalcc ] bi ;
>json utf8 encode "application/json" <post-data> swap >>data ;
! documents
-: id> ( assoc -- id ) "_id" of ;
+: id> ( assoc -- id ) "_id" of ;
: >id ( assoc id -- assoc ) "_id" pick set-at ;
: rev> ( assoc -- rev ) "_rev" of ;
: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
couch get server>> next-uuid save-doc-as ;
: save-doc ( assoc -- )
- dup id> [ save-doc-as ] [ save-new-doc ] if* ;
+ dup id> [ save-doc-as ] [ save-new-doc ] if* ;
: load-doc ( id -- assoc )
id-url couch-get ;
! : construct-attachment ( content-type data -- assoc )
! H{ } clone "name" pick set-at "content-type" pick set-at ;
-!
+!
! : add-attachment ( assoc name attachment -- )
! pick attachments> [ H{ } clone ] unless*
-!
+!
! : attach ( assoc name content-type data -- )
! construct-attachment H{ } clone
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax sequences strings cpu.8080.emulator ;\r
-IN: cpu.8080\r
-\r
-\r
-ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator"\r
-"The cpu-8080 library provides an emulator for the Intel 8080 CPU"\r
-" instruction set. It is complete enough to emulate some 8080"\r
-" based arcade games." $nl \r
-"The emulated CPU can load 'ROM' files from disk using the "\r
-{ $link load-rom } " and " { $link load-rom* } " words. These expect "\r
-"the " { $link rom-root } " variable to be set to the path "\r
-"containing the ROM file's." ;\r
-\r
-ABOUT: { "cpu-8080" "cpu-8080" } \r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax sequences strings cpu.8080.emulator ;
+IN: cpu.8080
+
+
+ARTICLE: { "cpu-8080" "cpu-8080" } "Intel 8080 CPU Emulator"
+"The cpu-8080 library provides an emulator for the Intel 8080 CPU"
+" instruction set. It is complete enough to emulate some 8080"
+" based arcade games." $nl
+"The emulated CPU can load 'ROM' files from disk using the "
+{ $link load-rom } " and " { $link load-rom* } " words. These expect "
+"the " { $link rom-root } " variable to be set to the path "
+"containing the ROM file's." ;
+
+ABOUT: { "cpu-8080" "cpu-8080" }
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax sequences strings ;\r
-IN: cpu.8080.emulator\r
-\r
-HELP: load-rom \r
-{ $values { "filename" string } { "cpu" cpu } }\r
-{ $description \r
-"Read the ROM file into the cpu's memory starting at address 0000. " \r
-"The filename is relative to the path stored in the " { $link rom-root }\r
-" variable. An exception is thrown if this variable is not set."\r
-}\r
-{ $see-also load-rom* } ;\r
-\r
-HELP: load-rom*\r
-{ $values { "seq" sequence } { "cpu" cpu } }\r
-{ $description \r
-"Loads one or more ROM files into the cpu's memory. Each file is "\r
-"loaded at a particular starting address. 'seq' is a sequence of "\r
-"2 element arrays. The first element is the address and the second "\r
-"element is the file to load at that address." $nl\r
-"The filenames are relative to the path stored in the " { $link rom-root }\r
-" variable. An exception is thrown if this variable is not set."\r
-}\r
-{ $examples\r
- { $code "{ { 0x0000 \"invaders.rom\" } } <cpu> load-rom*" }\r
-}\r
-{ $see-also load-rom } ;\r
-\r
-HELP: rom-root\r
-{ $description \r
-"Holds the path where the ROM files are stored. Used for expanding "\r
-"the relative filenames passed to " { $link load-rom } " and "\r
-{ $link load-rom* } "."\r
-}\r
-{ $see-also load-rom load-rom* } ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax sequences strings ;
+IN: cpu.8080.emulator
+
+HELP: load-rom
+{ $values { "filename" string } { "cpu" cpu } }
+{ $description
+"Read the ROM file into the cpu's memory starting at address 0000. "
+"The filename is relative to the path stored in the " { $link rom-root }
+" variable. An exception is thrown if this variable is not set."
+}
+{ $see-also load-rom* } ;
+
+HELP: load-rom*
+{ $values { "seq" sequence } { "cpu" cpu } }
+{ $description
+"Loads one or more ROM files into the cpu's memory. Each file is "
+"loaded at a particular starting address. 'seq' is a sequence of "
+"2 element arrays. The first element is the address and the second "
+"element is the file to load at that address." $nl
+"The filenames are relative to the path stored in the " { $link rom-root }
+" variable. An exception is thrown if this variable is not set."
+}
+{ $examples
+ { $code "{ { 0x0000 \"invaders.rom\" } } <cpu> load-rom*" }
+}
+{ $see-also load-rom } ;
+
+HELP: rom-root
+{ $description
+"Holds the path where the ROM files are stored. Used for expanding "
+"the relative filenames passed to " { $link load-rom } " and "
+{ $link load-rom* } "."
+}
+{ $see-also load-rom load-rom* } ;
: pop-pc ( cpu -- pc )
#! Pop the value of the PC off the stack.
- [ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ;
+ [ sp>> ] [ read-word ] [ -2 swap decrement-sp ] tri ;
: push-sp ( value cpu -- )
[ 2 swap decrement-sp ] [ sp>> ] [ write-word ] tri ;
-USING: \r
- accessors\r
- combinators\r
- cpu.8080\r
- cpu.8080.emulator\r
- io\r
- io.files\r
- io.encodings.ascii\r
- kernel \r
- math\r
- math.bits\r
- sequences\r
- tools.time\r
-;\r
-IN: cpu.8080.test\r
-\r
-: step ( cpu -- )\r
- #! Run a single 8080 instruction\r
- [ read-instruction ] keep ! n cpu\r
- over get-cycles over inc-cycles\r
- [ swap instructions nth call( cpu -- ) ] keep\r
- [ pc>> 0xFFFF bitand ] keep \r
- [ pc<< ] keep \r
- process-interrupts ;\r
-\r
-: test-step ( cpu -- cpu )\r
- [ step ] keep dup cpu. ;\r
-\r
-: invaders ( -- seq )\r
- {\r
- { 0x0000 "invaders/invaders.h" }\r
- { 0x0800 "invaders/invaders.g" }\r
- { 0x1000 "invaders/invaders.f" }\r
- { 0x1800 "invaders/invaders.e" }\r
- } ;\r
-\r
-: test-cpu ( -- cpu )\r
- <cpu> invaders over load-rom* dup cpu. ;\r
-\r
-: test-n ( n -- )\r
- test-cpu swap [ test-step ] times drop ;\r
-\r
-: run-n ( cpu n -- cpu )\r
- [ dup step ] times ;\r
-\r
-: each-8bit ( n quot -- )\r
- [ 8 <bits> ] dip each ; inline\r
-\r
-: >ppm ( cpu filename -- cpu )\r
- #! Dump the current screen image to a ppm image file with the given name.\r
- ascii [\r
- "P3" print\r
- "256 224" print\r
- "1" print\r
- 224 [\r
- 32 [\r
- over 32 * over + 0x2400 + ! cpu h w addr\r
- [ pick ] dip swap ram>> nth [\r
- [\r
- " 0 0 0" write\r
- ] [\r
- " 1 1 1" write\r
- ] if\r
- ] each-8bit drop\r
- ] each drop nl\r
- ] each\r
- ] with-file-writer ;\r
-\r
-: time-test ( -- )\r
- test-cpu [ 1000000 run-n drop ] time ;\r
+USING:
+ accessors
+ combinators
+ cpu.8080
+ cpu.8080.emulator
+ io
+ io.files
+ io.encodings.ascii
+ kernel
+ math
+ math.bits
+ sequences
+ tools.time
+;
+IN: cpu.8080.test
+
+: step ( cpu -- )
+ #! Run a single 8080 instruction
+ [ read-instruction ] keep ! n cpu
+ over get-cycles over inc-cycles
+ [ swap instructions nth call( cpu -- ) ] keep
+ [ pc>> 0xFFFF bitand ] keep
+ [ pc<< ] keep
+ process-interrupts ;
+
+: test-step ( cpu -- cpu )
+ [ step ] keep dup cpu. ;
+
+: invaders ( -- seq )
+ {
+ { 0x0000 "invaders/invaders.h" }
+ { 0x0800 "invaders/invaders.g" }
+ { 0x1000 "invaders/invaders.f" }
+ { 0x1800 "invaders/invaders.e" }
+ } ;
+
+: test-cpu ( -- cpu )
+ <cpu> invaders over load-rom* dup cpu. ;
+
+: test-n ( n -- )
+ test-cpu swap [ test-step ] times drop ;
+
+: run-n ( cpu n -- cpu )
+ [ dup step ] times ;
+
+: each-8bit ( n quot -- )
+ [ 8 <bits> ] dip each ; inline
+
+: >ppm ( cpu filename -- cpu )
+ #! Dump the current screen image to a ppm image file with the given name.
+ ascii [
+ "P3" print
+ "256 224" print
+ "1" print
+ 224 [
+ 32 [
+ over 32 * over + 0x2400 + ! cpu h w addr
+ [ pick ] dip swap ram>> nth [
+ [
+ " 0 0 0" write
+ ] [
+ " 1 1 1" write
+ ] if
+ ] each-8bit drop
+ ] each drop nl
+ ] each
+ ] with-file-writer ;
+
+: time-test ( -- )
+ test-cpu [ 1000000 run-n drop ] time ;
a1 xtime :> a2
a2 xtime :> a4
a4 xtime :> a8
- a8 a1 bitxor :> a9
+ a8 a1 bitxor :> a9
a9 a2 bitxor :> ab
a9 a4 bitxor :> ad
a8 a4 a2 bitxor bitxor :> ae
TUPLE: aes-state nrounds key state ;
-: <aes> ( nrounds key state -- aes-state ) \ aes-state boa ;
+: <aes> ( nrounds key state -- aes-state ) \ aes-state boa ;
#! grabs the 4n...4(n+1) words of the key
: (key-at-nth-round) ( nth aes -- seq )
HOOK: (expand-key) aes-strategy ( K Nr -- sched )
HOOK: (first-round) aes-strategy ( aes -- aes' )
HOOK: (counter) aes-strategy ( nrounds -- seq )
-HOOK: (round) aes-strategy ( state -- )
+HOOK: (round) aes-strategy ( state -- )
HOOK: (add-key) aes-strategy ( aes -- aes' )
-HOOK: (final-round) aes-strategy ( aes -- aes' )
+HOOK: (final-round) aes-strategy ( aes -- aes' )
SINGLETON: aes-decrypt
SINGLETON: aes-encrypt
: (aes-crypt-block-inner) ( nrounds key block -- crypted-block )
<aes> (aes-crypt) state>> ;
-
+
: (aes-crypt-block) ( key block -- output-block )
[ (aes-expand-key) ] dip bytes>words (aes-crypt-block-inner) ;
: 4th-from-end ( seq -- el )
[ length 4 - ] keep nth ;
-
{ 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group
[ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat
11 final nth 2 to64 3append ;
-
+
: parse-shadow-password ( string -- magic salt password )
"$" split harvest first3 [ "$" dup surround ] 2dip ;
-
+
: authenticate-password ( shadow password -- ? )
'[ parse-shadow-password drop _ passwd-md5 ] keep = ;
: rsa-primes ( numbits -- p q )
2/ 2 swap unique-primes first2 ;
-: modulus-phi ( numbits -- n phi )
+: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
dup rsa-primes [ * ] 2keep
[ 1 - ] bi@ *
[ etag-vector ] 2keep [
[ etag-pair ] [ ctag-path ] bi [ suffix ] dip
] dip set-at ;
-
+
: etag-hash ( seq -- hash )
H{ } clone swap [ swap [ etag-add ] keep ] each ;
] each ;
: etags-write ( alist path -- )
- [ etag-strings ] dip ascii set-file-lines ;
+ [ etag-strings ] dip ascii set-file-lines ;
: etags ( path -- )
[ (ctags) sort-values etag-hash >alist ] dip etags-write ;
: with-cuda-context ( device flags quot -- )
[ set-up-cuda-context create-context ] dip (with-cuda-context) ; inline
-
: init-cuda ( -- )
0 cuInit cuda-error ; inline
-
FUNCTION: CUresult cuDeviceTotalMem ( uint* bytes, CUdevice dev ) ;
FUNCTION: CUresult cuDeviceGetProperties ( CUdevprop* prop, CUdevice dev ) ;
FUNCTION: CUresult cuDeviceGetAttribute ( int* pi, CUdevice_attribute attrib, CUdevice dev ) ;
-
+
FUNCTION: CUresult cuCtxCreate ( CUcontext* pctx, uint flags, CUdevice dev ) ;
FUNCTION: CUresult cuCtxDestroy ( CUcontext ctx ) ;
FUNCTION: CUresult cuCtxAttach ( CUcontext* pctx, uint flags ) ;
FUNCTION: CUresult cuModuleGetFunction ( CUfunction* hfunc, CUmodule hmod, c-string name ) ;
FUNCTION: CUresult cuModuleGetGlobal ( CUdeviceptr* dptr, uint* bytes, CUmodule hmod, char* name ) ;
FUNCTION: CUresult cuModuleGetTexRef ( CUtexref* pTexRef, CUmodule hmod, char* name ) ;
-
+
FUNCTION: CUresult cuMemGetInfo ( uint* free, uint* total ) ;
FUNCTION: CUresult cuMemAlloc ( CUdeviceptr* dptr, uint bytesize ) ;
-FUNCTION: CUresult cuMemAllocPitch ( CUdeviceptr* dptr,
+FUNCTION: CUresult cuMemAllocPitch ( CUdeviceptr* dptr,
uint* pPitch,
- uint WidthInBytes,
- uint Height,
+ uint WidthInBytes,
+ uint Height,
uint ElementSizeBytes
) ;
FUNCTION: CUresult cuMemFree ( CUdeviceptr dptr ) ;
FUNCTION: CUresult cuMemFreeHost ( void* p ) ;
FUNCTION: CUresult cuMemHostAlloc ( void** pp, size_t bytesize, uint Flags ) ;
-
+
FUNCTION: CUresult cuMemHostGetDevicePointer ( CUdeviceptr* pdptr, void* p, uint Flags ) ;
FUNCTION: CUresult cuMemHostGetFlags ( uint* pFlags, void* p ) ;
FUNCTION: CUresult cuMemcpy3D ( CUDA_MEMCPY3D* pCopy ) ;
-FUNCTION: CUresult cuMemcpyHtoDAsync ( CUdeviceptr dstDevice,
+FUNCTION: CUresult cuMemcpyHtoDAsync ( CUdeviceptr dstDevice,
void* srcHost, uint ByteCount, CUstream hStream ) ;
-FUNCTION: CUresult cuMemcpyDtoHAsync ( void* dstHost,
+FUNCTION: CUresult cuMemcpyDtoHAsync ( void* dstHost,
CUdeviceptr srcDevice, uint ByteCount, CUstream hStream ) ;
FUNCTION: CUresult cuMemcpyDtoDAsync ( CUdeviceptr dstDevice,
CUdeviceptr srcDevice, uint ByteCount, CUstream hStream ) ;
-FUNCTION: CUresult cuMemcpyHtoAAsync ( CUarray dstArray, uint dstIndex,
+FUNCTION: CUresult cuMemcpyHtoAAsync ( CUarray dstArray, uint dstIndex,
void* pSrc, uint ByteCount, CUstream hStream ) ;
-FUNCTION: CUresult cuMemcpyAtoHAsync ( void* dstHost, CUarray srcArray, uint srcIndex,
+FUNCTION: CUresult cuMemcpyAtoHAsync ( void* dstHost, CUarray srcArray, uint srcIndex,
uint ByteCount, CUstream hStream ) ;
FUNCTION: CUresult cuMemcpy2DAsync ( CUDA_MEMCPY2D* pCopy, CUstream hStream ) ;
FUNCTION: CUresult cuTexRefCreate ( CUtexref* pTexRef ) ;
FUNCTION: CUresult cuTexRefDestroy ( CUtexref hTexRef ) ;
-
+
FUNCTION: CUresult cuTexRefSetArray ( CUtexref hTexRef, CUarray hArray, uint Flags ) ;
FUNCTION: CUresult cuTexRefSetAddress ( uint* ByteOffset, CUtexref hTexRef, CUdeviceptr dptr, uint bytes ) ;
FUNCTION: CUresult cuTexRefSetAddress2D ( CUtexref hTexRef, CUDA_ARRAY_DESCRIPTOR* desc, CUdeviceptr dptr, uint Pitch ) ;
FUNCTION: CUresult cuGraphicsUnregisterResource ( CUgraphicsResource resource ) ;
FUNCTION: CUresult cuGraphicsSubResourceGetMappedArray ( CUarray* pArray, CUgraphicsResource resource, uint arrayIndex, uint mipLevel ) ;
FUNCTION: CUresult cuGraphicsResourceGetMappedPointer ( CUdeviceptr* pDevPtr, uint* pSize, CUgraphicsResource resource ) ;
-FUNCTION: CUresult cuGraphicsResourceSetMapFlags ( CUgraphicsResource resource, uint flags ) ;
+FUNCTION: CUresult cuGraphicsResourceSetMapFlags ( CUgraphicsResource resource, uint flags ) ;
FUNCTION: CUresult cuGraphicsMapResources ( uint count, CUgraphicsResource* resources, CUstream hStream ) ;
FUNCTION: CUresult cuGraphicsUnmapResources ( uint count, CUgraphicsResource* resources, CUstream hStream ) ;
FUNCTION: CUresult cuGLCtxCreate ( CUcontext* pCtx, uint Flags, CUdevice device ) ;
FUNCTION: CUresult cuGraphicsGLRegisterBuffer ( CUgraphicsResource* pCudaResource, GLuint buffer, uint Flags ) ;
FUNCTION: CUresult cuGraphicsGLRegisterImage ( CUgraphicsResource* pCudaResource, GLuint image, GLenum target, uint Flags ) ;
-
'[ _ _ cuGLCtxCreate cuda-error ] with-out-parameters ; inline
: with-gl-cuda-context ( device flags quot -- )
- [ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline
+ [ set-up-cuda-context create-gl-cuda-context ] dip (with-cuda-context) ; inline
: gl-buffer>resource ( gl-buffer flags -- resource )
enum>number
: cuda-global* ( module-name symbol-name -- device-ptr size )
[ { CUdeviceptr { c:uint initial: 0 } } ] 2dip
- [ cached-module ] dip
+ [ cached-module ] dip
'[ _ _ cuModuleGetGlobal cuda-error ] with-out-parameters ; inline
: cuda-global ( module-name symbol-name -- device-ptr )
: add-cuda-library ( name abi path -- )
normalize-path <cuda-library>
dup name>> cuda-libraries get-global set-at ;
-
{ initializer maybe{ string } } ;
TUPLE: ptx-negation
- { var string } ;
+ { var string } ;
TUPLE: ptx-vector
elements ;
: write-ptx-element ( elt -- )
dup ptx-element-label [ write ":" write ] when*
- "\t" write dup (write-ptx-element)
+ "\t" write dup (write-ptx-element)
ptx-semicolon? [ ";" print ] [ nl ] if ;
: write-ptx ( ptx -- )
{ z double }
{ w double } ;
-char2 lookup-c-type
+char2 lookup-c-type
2 >>align
2 >>align-first
drop
-char4 lookup-c-type
+char4 lookup-c-type
4 >>align
4 >>align-first
drop
-uchar2 lookup-c-type
+uchar2 lookup-c-type
2 >>align
2 >>align-first
drop
-uchar4 lookup-c-type
+uchar4 lookup-c-type
4 >>align
4 >>align-first
drop
-short2 lookup-c-type
+short2 lookup-c-type
4 >>align
4 >>align-first
drop
-short4 lookup-c-type
+short4 lookup-c-type
8 >>align
8 >>align-first
drop
-ushort2 lookup-c-type
+ushort2 lookup-c-type
4 >>align
4 >>align-first
drop
-ushort4 lookup-c-type
+ushort4 lookup-c-type
8 >>align
8 >>align-first
drop
-int2 lookup-c-type
+int2 lookup-c-type
8 >>align
8 >>align-first
drop
-int4 lookup-c-type
+int4 lookup-c-type
16 >>align
16 >>align-first
drop
-uint2 lookup-c-type
+uint2 lookup-c-type
8 >>align
8 >>align-first
drop
-uint4 lookup-c-type
+uint4 lookup-c-type
16 >>align
16 >>align-first
drop
-long2 lookup-c-type
+long2 lookup-c-type
long heap-size 2 * >>align
long heap-size 2 * >>align-first
drop
-long4 lookup-c-type
+long4 lookup-c-type
16 >>align
16 >>align-first
drop
-ulong2 lookup-c-type
+ulong2 lookup-c-type
long heap-size 2 * >>align
long heap-size 2 * >>align-first
drop
-ulong4 lookup-c-type
+ulong4 lookup-c-type
16 >>align
16 >>align-first
drop
-longlong2 lookup-c-type
+longlong2 lookup-c-type
16 >>align
16 >>align-first
drop
-longlong4 lookup-c-type
+longlong4 lookup-c-type
16 >>align
16 >>align-first
drop
-ulonglong2 lookup-c-type
+ulonglong2 lookup-c-type
16 >>align
16 >>align-first
drop
-ulonglong4 lookup-c-type
+ulonglong4 lookup-c-type
16 >>align
16 >>align-first
drop
-float2 lookup-c-type
+float2 lookup-c-type
8 >>align
8 >>align-first
drop
-float4 lookup-c-type
+float4 lookup-c-type
16 >>align
16 >>align-first
drop
-double2 lookup-c-type
+double2 lookup-c-type
16 >>align
16 >>align-first
drop
-double4 lookup-c-type
+double4 lookup-c-type
16 >>align
16 >>align-first
drop
[ 2in- ] dip -map-as ; inline
: 2map ( ... a b quot: ( ... x y -- ... z ) -- ... c )
- pick 2map-as ; inline
+ pick 2map-as ; inline
!
! generalized zips
MACRO: -nwith- ( n -- )
[ -with- ] n*quot ;
-
"." split1
[ [ CHAR: 0 = ] trim-head [ "0" ] when-empty ]
[ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi*
- [ append string>number ] [ nip length neg ] 2bi <decimal> ;
+ [ append string>number ] [ nip length neg ] 2bi <decimal> ;
: parse-decimal ( -- decimal ) scan-token string>decimal ;
: scale-mantissas ( D1 D2 -- m1 m2 exp )
[ [ mantissa>> ] bi@ ]
- [
+ [
[ exponent>> ] bi@
[
- dup 0 <
D2 >decimal< :> ( m2 e2 )
m1 a 10^ *
m2 /i
-
+
e1
e2 a + - <decimal> ;
-USING: help.syntax help.markup words ;\r
-IN: descriptive\r
-\r
-HELP: DESCRIPTIVE:\r
-{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }\r
-{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;\r
-\r
-HELP: DESCRIPTIVE::\r
-{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }\r
-{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;\r
-\r
-HELP: descriptive-error\r
-{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;\r
-\r
-HELP: make-descriptive\r
-{ $values { "word" word } }\r
-{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;\r
-\r
-ARTICLE: "descriptive" "Descriptive errors"\r
-"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:"\r
-{ $subsections descriptive-error }\r
-"The wrapper contains the word itself, the input parameters, as well as the original error."\r
-$nl\r
-"To annotate an existing word with descriptive error checking:"\r
-{ $subsections make-descriptive }\r
-"To define words which throw descriptive errors, use the following words:"\r
-{ $subsections\r
- POSTPONE: DESCRIPTIVE:\r
- POSTPONE: DESCRIPTIVE::\r
-} ;\r
-\r
-ABOUT: "descriptive"\r
+USING: help.syntax help.markup words ;
+IN: descriptive
+
+HELP: DESCRIPTIVE:
+{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }
+{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
+
+HELP: DESCRIPTIVE::
+{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }
+{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
+
+HELP: descriptive-error
+{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
+
+HELP: make-descriptive
+{ $values { "word" word } }
+{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;
+
+ARTICLE: "descriptive" "Descriptive errors"
+"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:"
+{ $subsections descriptive-error }
+"The wrapper contains the word itself, the input parameters, as well as the original error."
+$nl
+"To annotate an existing word with descriptive error checking:"
+{ $subsections make-descriptive }
+"To define words which throw descriptive errors, use the following words:"
+{ $subsections
+ POSTPONE: DESCRIPTIVE:
+ POSTPONE: DESCRIPTIVE::
+} ;
+
+ABOUT: "descriptive"
-USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see\r
-math.ratios ;\r
-IN: descriptive.tests\r
-\r
-DESCRIPTIVE: divide ( num denom -- fraction ) / ;\r
-\r
-[ 3 ] [ 9 3 divide ] unit-test\r
-\r
-[\r
- T{ descriptive-error f\r
- { { "num" 3 } { "denom" 0 } }\r
- T{ division-by-zero f 3 }\r
- divide\r
- }\r
-] [\r
- [ 3 0 divide ] [ ] recover\r
-] unit-test\r
-\r
-[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ]\r
-[ \ divide [ see ] with-string-writer ] unit-test\r
-\r
-DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\r
-\r
-[ 3 ] [ 9 3 divide* ] unit-test\r
-\r
-[\r
- T{ descriptive-error f\r
- { { "num" 3 } { "denom" 0 } }\r
- T{ division-by-zero f 3 }\r
- divide*\r
- }\r
-] [ [ 3 0 divide* ] [ ] recover ] unit-test\r
-\r
-[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test\r
+USING: descriptive kernel math tools.test continuations prettyprint io.streams.string see
+math.ratios ;
+IN: descriptive.tests
+
+DESCRIPTIVE: divide ( num denom -- fraction ) / ;
+
+[ 3 ] [ 9 3 divide ] unit-test
+
+[
+ T{ descriptive-error f
+ { { "num" 3 } { "denom" 0 } }
+ T{ division-by-zero f 3 }
+ divide
+ }
+] [
+ [ 3 0 divide ] [ ] recover
+] unit-test
+
+[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ]
+[ \ divide [ see ] with-string-writer ] unit-test
+
+DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;
+
+[ 3 ] [ 9 3 divide* ] unit-test
+
+[
+ T{ descriptive-error f
+ { { "num" 3 } { "denom" 0 } }
+ T{ division-by-zero f 3 }
+ divide*
+ }
+] [ [ 3 0 divide* ] [ ] recover ] unit-test
+
+[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test
: trim-ipv6-arpa ( string -- string' )
dotted> ipv6-arpa-suffix ?tail drop ;
-
+
: arpa>ipv4 ( string -- ip ) trim-ipv4-arpa reverse-ipv4 ;
: arpa>ipv6 ( string -- ip )
[ os>> >name ] bi append ;
M: MX rdata>byte-array
- drop
+ drop
[ preference>> 2 >be ]
[ exchange>> >name ] bi append ;
: message>mxs ( message -- assoc )
answer-section>> [ rdata>> [ preference>> ] [ exchange>> ] bi 2array ] map ;
-: messages>names ( messages -- names )
+: messages>names ( messages -- names )
[ message>names ] map concat ;
: forward-confirmed-reverse-dns-ipv4? ( ipv4-string -- ? )
dns-A-query message>a-names [ <ipv4> ] map
] if ;
*)
-
+
HOOK: initial-dns-servers os ( -- sequence )
{
: with-dns-servers ( servers quot -- )
[ dns-servers ] dip with-variable ; inline
-
+
dns-servers [ initial-dns-servers >vector ] initialize
USING: dns system windows.iphlpapi ;
IN: dns.windows
-M: windows initial-dns-servers dns-server-ips ;
\ No newline at end of file
+M: windows initial-dns-servers dns-server-ips ;
CONSTANT: DW_TAG_SUN_f90_interface 0x420c
CONSTANT: DW_TAG_SUN_fortran_vax_structure 0x420d
CONSTANT: DW_TAG_SUN_hi 0x42ff
-
+
CONSTANT: DW_TAG_hi_user 0xffff
CONSTANT: DW_children_no 0
CONSTANT: DW_AT_GNU_vector 0x2107
CONSTANT: DW_AT_GNU_template_name 0x2108
-CONSTANT: DW_AT_ALTIUM_loclist 0x2300
+CONSTANT: DW_AT_ALTIUM_loclist 0x2300
CONSTANT: DW_AT_SUN_template 0x2201
CONSTANT: DW_AT_VMS_rtnbeg_pd_address 0x2201
CONSTANT: DW_AT_upc_threads_scaled 0x3210
CONSTANT: DW_AT_PGI_lbase 0x3a00
-CONSTANT: DW_AT_PGI_soffset 0x3a01
-CONSTANT: DW_AT_PGI_lstride 0x3a02
+CONSTANT: DW_AT_PGI_soffset 0x3a01
+CONSTANT: DW_AT_PGI_lstride 0x3a02
CONSTANT: DW_AT_APPLE_closure 0x3fe4
CONSTANT: DW_AT_APPLE_major_runtime_vers 0x3fe5
CONSTANT: DW_LANG_lo_user 0x8000
CONSTANT: DW_LANG_Mips_Assembler 0x8001
CONSTANT: DW_LANG_Upc 0x8765
-CONSTANT: DW_LANG_ALTIUM_Assembler 0x9101
+CONSTANT: DW_LANG_ALTIUM_Assembler 0x9101
CONSTANT: DW_LANG_SUN_Assembler 0x9001
CONSTANT: DW_LANG_hi_user 0xffff
CONSTANT: DW_CC_nocall 0x03
CONSTANT: DW_CC_lo_user 0x40
-CONSTANT: DW_CC_ALTIUM_interrupt 0x65
-CONSTANT: DW_CC_ALTIUM_near_system_stack 0x66
-CONSTANT: DW_CC_ALTIUM_near_user_stack 0x67
-CONSTANT: DW_CC_ALTIUM_huge_user_stack 0x68
+CONSTANT: DW_CC_ALTIUM_interrupt 0x65
+CONSTANT: DW_CC_ALTIUM_near_system_stack 0x66
+CONSTANT: DW_CC_ALTIUM_near_user_stack 0x67
+CONSTANT: DW_CC_ALTIUM_huge_user_stack 0x68
CONSTANT: DW_CC_hi_user 0xff
CONSTANT: DW_INL_not_inlined 0x00
CONSTANT: DW_LNE_end_sequence 0x01
CONSTANT: DW_LNE_set_address 0x02
CONSTANT: DW_LNE_define_file 0x03
-CONSTANT: DW_LNE_set_discriminator 0x04
+CONSTANT: DW_LNE_set_discriminator 0x04
CONSTANT: DW_LNE_HP_negate_is_UV_update 0x11
CONSTANT: DW_LNE_HP_push_context 0x12
CONSTANT: DW_EH_PE_aligned 0x50
CONSTANT: DW_EH_PE_omit 0xff
-CONSTANT: DW_FRAME_CFA_COL 0
+CONSTANT: DW_FRAME_CFA_COL 0
CONSTANT: DW_FRAME_REG1 1
CONSTANT: DW_FRAME_REG2 2
:: get-public-key ( -- bin/f )
ec-key-handle :> KEY
- KEY EC_KEY_get0_public_key dup
+ KEY EC_KEY_get0_public_key dup
[| PUB |
KEY EC_KEY_get0_group :> GROUP
GROUP EC_GROUP_get_degree bits>bytes 1 + :> LEN
: echod-main ( -- ) 1234 echod drop ;
MAIN: echod-main
-
] find nip ;
TYPED:: elf-segment-data ( elf: Elf32/64_Ehdr header: Elf32/64_Phdr -- uchar-array/f )
- header p_offset>> elf >c-ptr <displaced-alien>
+ header p_offset>> elf >c-ptr <displaced-alien>
header p_filesz>> uchar <c-direct-array> ;
TYPED:: elf-section-data ( elf: Elf32/64_Ehdr header: Elf32/64_Shdr -- uchar-array/f )
} case "%-16s " printf
]
[ name>> "%s\n" printf ] tri ;
-
+
: elf-nm ( path -- )
[
sections dup ".symtab" find-section
M: env clear-assoc
drop os-envs keys [ unset-os-env ] each ;
-
-USING: accessors euler.b-rep euler.modeling euler.operators\r
-euler.b-rep.examples kernel locals math.vectors.simd.cords\r
-namespaces sequences tools.test ;\r
-IN: euler.b-rep.tests\r
-\r
-[ double-4{ 0.0 0.0 -1.0 0.0 } ]\r
-[ valid-cube-b-rep edges>> first face-normal ] unit-test\r
-\r
-[ double-4{ 0.0 0.0 -1.0 0.0 } -1.0 ]\r
-[ valid-cube-b-rep edges>> first face-plane ] unit-test\r
-\r
-[ t ] [ 0 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test\r
-[ t ] [ 5 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test\r
-[ f ] [ 6 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test\r
-\r
-:: mock-face ( p0 p1 p2 -- edge )\r
- b-edge new vertex new p0 >>position >>vertex :> e0\r
- b-edge new vertex new p1 >>position >>vertex :> e1\r
- b-edge new vertex new p2 >>position >>vertex :> e2\r
-\r
- e1 e0 next-edge<<\r
- e2 e1 next-edge<<\r
- e0 e2 next-edge<<\r
- \r
- e0 ;\r
-\r
-[\r
- double-4{\r
- 0x1.279a74590331dp-1\r
- 0x1.279a74590331dp-1\r
- 0x1.279a74590331dp-1\r
- 0.0\r
- }\r
- -0x1.bb67ae8584cabp1\r
-] [\r
- double-4{ 1 0 5 0 }\r
- double-4{ 0 1 5 0 }\r
- double-4{ 0 0 6 0 } mock-face face-plane\r
-] unit-test\r
-\r
-V{ t } clone sharpness-stack [\r
- [ t ] [ get-sharpness ] unit-test\r
- [ V{ f } ] [ f set-sharpness sharpness-stack get ] unit-test\r
- [ V{ f t } t ] [ t push-sharpness sharpness-stack get get-sharpness ] unit-test\r
- [ t V{ f } f ] [ pop-sharpness sharpness-stack get get-sharpness ] unit-test\r
-] with-variable\r
-\r
-[ t ] [ valid-cube-b-rep [ edges>> first ] keep is-valid-edge? ] unit-test\r
-[ f ] [ b-edge new valid-cube-b-rep is-valid-edge? ] unit-test\r
-\r
-[ t ] [\r
- valid-cube-b-rep edges>>\r
- [ [ 0 swap nth ] [ 1 swap nth ] bi connecting-edge ]\r
- [ 0 swap nth ] bi eq?\r
-] unit-test\r
-\r
-[ t ] [\r
- valid-cube-b-rep edges>>\r
- [ [ 1 swap nth ] [ 0 swap nth ] bi connecting-edge ]\r
- [ 6 swap nth ] bi eq?\r
-] unit-test\r
-\r
-[ t ] [\r
- valid-cube-b-rep edges>>\r
- [ [ 0 swap nth ] [ 3 swap nth ] bi connecting-edge ]\r
- [ 21 swap nth ] bi eq?\r
-] unit-test\r
-\r
-[ f ] [\r
- valid-cube-b-rep edges>>\r
- [ 0 swap nth ] [ 2 swap nth ] bi connecting-edge\r
-] unit-test\r
-\r
-[ double-4{ 0 0 -1 0 } ] [\r
- [\r
- { double-4{ 0 0 0 0 } double-4{ 0 1 0 0 } double-4{ 0 2 0 0 } double-4{ 1 1 0 0 } }\r
- smooth-smooth polygon>double-face face-normal\r
- ] make-b-rep drop\r
-] unit-test\r
+USING: accessors euler.b-rep euler.modeling euler.operators
+euler.b-rep.examples kernel locals math.vectors.simd.cords
+namespaces sequences tools.test ;
+IN: euler.b-rep.tests
+
+[ double-4{ 0.0 0.0 -1.0 0.0 } ]
+[ valid-cube-b-rep edges>> first face-normal ] unit-test
+
+[ double-4{ 0.0 0.0 -1.0 0.0 } -1.0 ]
+[ valid-cube-b-rep edges>> first face-plane ] unit-test
+
+[ t ] [ 0 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
+[ t ] [ 5 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
+[ f ] [ 6 multi-ringed-face-cube-b-rep faces>> nth base-face? ] unit-test
+
+:: mock-face ( p0 p1 p2 -- edge )
+ b-edge new vertex new p0 >>position >>vertex :> e0
+ b-edge new vertex new p1 >>position >>vertex :> e1
+ b-edge new vertex new p2 >>position >>vertex :> e2
+
+ e1 e0 next-edge<<
+ e2 e1 next-edge<<
+ e0 e2 next-edge<<
+
+ e0 ;
+
+[
+ double-4{
+ 0x1.279a74590331dp-1
+ 0x1.279a74590331dp-1
+ 0x1.279a74590331dp-1
+ 0.0
+ }
+ -0x1.bb67ae8584cabp1
+] [
+ double-4{ 1 0 5 0 }
+ double-4{ 0 1 5 0 }
+ double-4{ 0 0 6 0 } mock-face face-plane
+] unit-test
+
+V{ t } clone sharpness-stack [
+ [ t ] [ get-sharpness ] unit-test
+ [ V{ f } ] [ f set-sharpness sharpness-stack get ] unit-test
+ [ V{ f t } t ] [ t push-sharpness sharpness-stack get get-sharpness ] unit-test
+ [ t V{ f } f ] [ pop-sharpness sharpness-stack get get-sharpness ] unit-test
+] with-variable
+
+[ t ] [ valid-cube-b-rep [ edges>> first ] keep is-valid-edge? ] unit-test
+[ f ] [ b-edge new valid-cube-b-rep is-valid-edge? ] unit-test
+
+[ t ] [
+ valid-cube-b-rep edges>>
+ [ [ 0 swap nth ] [ 1 swap nth ] bi connecting-edge ]
+ [ 0 swap nth ] bi eq?
+] unit-test
+
+[ t ] [
+ valid-cube-b-rep edges>>
+ [ [ 1 swap nth ] [ 0 swap nth ] bi connecting-edge ]
+ [ 6 swap nth ] bi eq?
+] unit-test
+
+[ t ] [
+ valid-cube-b-rep edges>>
+ [ [ 0 swap nth ] [ 3 swap nth ] bi connecting-edge ]
+ [ 21 swap nth ] bi eq?
+] unit-test
+
+[ f ] [
+ valid-cube-b-rep edges>>
+ [ 0 swap nth ] [ 2 swap nth ] bi connecting-edge
+] unit-test
+
+[ double-4{ 0 0 -1 0 } ] [
+ [
+ { double-4{ 0 0 0 0 } double-4{ 0 1 0 0 } double-4{ 0 2 0 0 } double-4{ 1 1 0 0 } }
+ smooth-smooth polygon>double-face face-normal
+ ] make-b-rep drop
+] unit-test
tri ;
: connect-opposite-edges ( b-rep -- )
- edges>>
+ edges>>
[ [ [ next-edge>> vertex>> ] [ vertex>> 2array ] [ ] tri ] H{ } map>assoc ]
[ swap '[ [ vertex>> ] [ next-edge>> vertex>> 2array _ at ] [ opposite-edge<< ] tri ] each ] bi ;
V{ } clone :> edges
faces-vertices [ vertices reconstruct-face edges push-all ] { } map-as :> faces
- b-rep new
+ b-rep new
faces >>faces
edges >>edges
vertices >>vertices
[ opposite-n edge-pts set-nth-unsafe ] bi
] when
] each-index
-
+
edge-pts ; inline
:: vertex-points ( vertices edge-indices face-indices edge-pts face-points -- vertex-pts )
] map ; inline
TYPED:: subdivide ( brep: b-rep -- brep': b-rep )
- brep vertices>> :> vertices
+ brep vertices>> :> vertices
brep edges>> :> edges
brep faces>> :> faces
face new
dup >>base-face :> fac
-
+
b-edge new
fac >>face
point-a >>vertex :> edg-a
point-d [ edg-d or ] change-edge drop
] each-vertex-edge
] each
-
+
b-rep new
sub-faces { } like >>faces
sub-edges { } like >>edges
-USING: accessors kernel tools.test euler.b-rep euler.operators\r
-euler.modeling game.models.half-edge ;\r
-IN: euler.modeling.tests\r
-\r
-! polygon>double-face\r
-[ ] [\r
- [\r
- { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } { -1 1 0 } }\r
- smooth-smooth polygon>double-face\r
- [ face-sides 4 assert= ]\r
- [ opposite-edge>> face-sides 4 assert= ]\r
- [ face-normal { 0.0 0.0 1.0 } assert= ]\r
- tri\r
- ] make-b-rep check-b-rep\r
-] unit-test\r
-\r
-! extrude-simple\r
-[ ] [\r
- [\r
- { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } }\r
- smooth-smooth polygon>double-face\r
- 1 f extrude-simple\r
- [ face-sides 3 assert= ]\r
- [ opposite-edge>> face-sides 4 assert= ]\r
- bi\r
- ] make-b-rep check-b-rep\r
-] unit-test\r
-\r
-! project-pt-line\r
-[ { 0 1 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 1 0 } project-pt-line ] unit-test\r
-[ { 0 1 0 } ] [ { 0 0 0 } { 1 1 0 } { 0 1 0 } project-pt-line ] unit-test\r
-[ { 0 1 0 } ] [ { 0 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test\r
-[ { -1 1 0 } ] [ { -1 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test\r
-[ { 1/2 1/2 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 0 0 } project-pt-line ] unit-test\r
-\r
-! project-pt-plane\r
-[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -1 project-pt-plane ] unit-test\r
-[ { 0 0 -1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } 1 project-pt-plane ] unit-test\r
-[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -3 project-pt-plane ] unit-test\r
-[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 -1 } 3 project-pt-plane ] unit-test\r
-[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 1 1 } -1 project-pt-plane ] unit-test\r
-\r
-[ { 0 2/3 1/3 } ] [ { 0 0 0 } { 0 2 1 } { 0 1 1 } -1 project-pt-plane ] unit-test\r
-\r
-[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test\r
-[ { 0 1 1 } ] [ { 0 0 0 } { 0 1/2 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test\r
+USING: accessors kernel tools.test euler.b-rep euler.operators
+euler.modeling game.models.half-edge ;
+IN: euler.modeling.tests
+
+! polygon>double-face
+[ ] [
+ [
+ { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } { -1 1 0 } }
+ smooth-smooth polygon>double-face
+ [ face-sides 4 assert= ]
+ [ opposite-edge>> face-sides 4 assert= ]
+ [ face-normal { 0.0 0.0 1.0 } assert= ]
+ tri
+ ] make-b-rep check-b-rep
+] unit-test
+
+! extrude-simple
+[ ] [
+ [
+ { { -1 -1 0 } { 1 -1 0 } { 1 1 0 } }
+ smooth-smooth polygon>double-face
+ 1 f extrude-simple
+ [ face-sides 3 assert= ]
+ [ opposite-edge>> face-sides 4 assert= ]
+ bi
+ ] make-b-rep check-b-rep
+] unit-test
+
+! project-pt-line
+[ { 0 1 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 1 0 } project-pt-line ] unit-test
+[ { 0 1 0 } ] [ { 0 0 0 } { 1 1 0 } { 0 1 0 } project-pt-line ] unit-test
+[ { 0 1 0 } ] [ { 0 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test
+[ { -1 1 0 } ] [ { -1 0 0 } { 2 1 0 } { 1 1 0 } project-pt-line ] unit-test
+[ { 1/2 1/2 0 } ] [ { 0 0 0 } { 0 1 0 } { 1 0 0 } project-pt-line ] unit-test
+
+! project-pt-plane
+[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -1 project-pt-plane ] unit-test
+[ { 0 0 -1 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } 1 project-pt-plane ] unit-test
+[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 1 } -3 project-pt-plane ] unit-test
+[ { 0 0 3 } ] [ { 0 0 0 } { 0 0 1 } { 0 0 -1 } 3 project-pt-plane ] unit-test
+[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1 } { 0 1 1 } -1 project-pt-plane ] unit-test
+
+[ { 0 2/3 1/3 } ] [ { 0 0 0 } { 0 2 1 } { 0 1 1 } -1 project-pt-plane ] unit-test
+
+[ { 0 0 1 } ] [ { 0 0 0 } { 0 0 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test
+[ { 0 1 1 } ] [ { 0 0 0 } { 0 1/2 1/2 } { 0 0 1 } -1 project-pt-plane ] unit-test
-! Copyright (C) 2010 Slava Pestov.\r
-USING: accessors combinators fry kernel locals math.vectors\r
-namespaces sets sequences game.models.half-edge euler.b-rep\r
-euler.operators math ;\r
-IN: euler.modeling\r
-\r
-: (polygon>double-face) ( polygon -- edge )\r
- [ first2 make-vefs ] keep\r
- [ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi\r
- make-ef face-ccw ;\r
-\r
-SYMBOLS: smooth-smooth\r
-sharp-smooth\r
-smooth-sharp\r
-sharp-sharp\r
-smooth-like-vertex\r
-sharp-like-vertex\r
-smooth-continue\r
-sharp-continue ;\r
-\r
-: polygon>double-face ( polygon mode -- edge )\r
- ! This only handles the simple case with no repeating vertices\r
- drop\r
- dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless\r
- (polygon>double-face) ;\r
-\r
-:: extrude-simple ( edge dist sharp? -- edge )\r
- edge face-normal dist v*n :> vec\r
- edge vertex-pos vec v+ :> pos\r
- edge pos make-ev-one :> e0!\r
- e0 opposite-edge>> :> e-end\r
- edge face-ccw :> edge!\r
-\r
- [ edge e-end eq? not ] [\r
- edge vertex-pos vec v+ :> pos\r
- edge pos make-ev-one :> e1\r
- e0 e1 make-ef drop\r
- e1 e0!\r
- edge face-ccw edge!\r
- ] do while\r
- \r
- e-end face-ccw :> e-end\r
- e0 e-end make-ef drop\r
-\r
- e-end ;\r
-\r
-: check-bridge-rings ( e1 e2 -- )\r
- {\r
- [ [ face>> assert-no-rings ] bi@ ]\r
- [ [ face>> assert-base-face ] bi@ ]\r
- [ assert-different-faces ]\r
- [ [ face-sides ] bi@ assert= ]\r
- } 2cleave ;\r
-\r
-:: bridge-rings-simple ( e1 e2 sharp? -- edge )\r
- e1 e2 check-bridge-rings\r
- e1 e2 kill-f-make-rh\r
- e1 e2 make-e-kill-r face-cw :> ea!\r
- e2 face-ccw :> eb!\r
- [ ea e1 eq? not ] [\r
- ea eb make-ef opposite-edge>> face-cw ea!\r
- eb face-ccw eb!\r
- ] while\r
- eb ;\r
-\r
-:: project-pt-line ( p p0 p1 -- q )\r
- p1 p0 v- :> vt\r
- p p0 v- vt v* sum\r
- vt norm-sq /\r
- vt n*v p0 v+ ; inline\r
-\r
-:: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q )\r
- plane-d neg plane-n line-p0 v. -\r
- line-vt plane-n v. /\r
- line-vt n*v line-p0 v+ ; inline\r
-\r
-: project-poly-plane ( poly vdir plane-n plane-d -- qoly )\r
- '[ _ _ _ project-pt-plane ] map ; inline\r
+! Copyright (C) 2010 Slava Pestov.
+USING: accessors combinators fry kernel locals math.vectors
+namespaces sets sequences game.models.half-edge euler.b-rep
+euler.operators math ;
+IN: euler.modeling
+
+: (polygon>double-face) ( polygon -- edge )
+ [ first2 make-vefs ] keep
+ [ drop opposite-edge>> ] [ 2 tail-slice [ make-ev-one ] each ] 2bi
+ make-ef face-ccw ;
+
+SYMBOLS: smooth-smooth
+sharp-smooth
+smooth-sharp
+sharp-sharp
+smooth-like-vertex
+sharp-like-vertex
+smooth-continue
+sharp-continue ;
+
+: polygon>double-face ( polygon mode -- edge )
+ ! This only handles the simple case with no repeating vertices
+ drop
+ dup all-unique? [ "polygon>double-face doesn't support repeating vertices yet" throw ] unless
+ (polygon>double-face) ;
+
+:: extrude-simple ( edge dist sharp? -- edge )
+ edge face-normal dist v*n :> vec
+ edge vertex-pos vec v+ :> pos
+ edge pos make-ev-one :> e0!
+ e0 opposite-edge>> :> e-end
+ edge face-ccw :> edge!
+
+ [ edge e-end eq? not ] [
+ edge vertex-pos vec v+ :> pos
+ edge pos make-ev-one :> e1
+ e0 e1 make-ef drop
+ e1 e0!
+ edge face-ccw edge!
+ ] do while
+
+ e-end face-ccw :> e-end
+ e0 e-end make-ef drop
+
+ e-end ;
+
+: check-bridge-rings ( e1 e2 -- )
+ {
+ [ [ face>> assert-no-rings ] bi@ ]
+ [ [ face>> assert-base-face ] bi@ ]
+ [ assert-different-faces ]
+ [ [ face-sides ] bi@ assert= ]
+ } 2cleave ;
+
+:: bridge-rings-simple ( e1 e2 sharp? -- edge )
+ e1 e2 check-bridge-rings
+ e1 e2 kill-f-make-rh
+ e1 e2 make-e-kill-r face-cw :> ea!
+ e2 face-ccw :> eb!
+ [ ea e1 eq? not ] [
+ ea eb make-ef opposite-edge>> face-cw ea!
+ eb face-ccw eb!
+ ] while
+ eb ;
+
+:: project-pt-line ( p p0 p1 -- q )
+ p1 p0 v- :> vt
+ p p0 v- vt v* sum
+ vt norm-sq /
+ vt n*v p0 v+ ; inline
+
+:: project-pt-plane ( line-p0 line-vt plane-n plane-d -- q )
+ plane-d neg plane-n line-p0 v. -
+ line-vt plane-n v. /
+ line-vt n*v line-p0 v+ ; inline
+
+: project-poly-plane ( poly vdir plane-n plane-d -- qoly )
+ '[ _ _ _ project-pt-plane ] map ; inline
e1 [ f2 >>face drop ] each-face-edge
f1 b-rep delete-face
- e1 e2 incident? [
+ e1 e2 incident? [
e2 next-edge>> e2p next-edge<<
] [
t
] [ 2drop f ] if
] loop ;
-
+
: delete-if-exists ( file -- )
dup exists? [ delete-file ] [ drop ] if ;
[ . ] debug-print ;
: fcgi-handler ( -- )
- make-new-request parse-packets
+ make-new-request parse-packets
prepare-request
- "/path" main-responder get call-responder*
+ "/path" main-responder get call-responder*
[ content-type>> "\n\n" append ] [ body>> ] bi append write-response ;
: <fastcgi-server> ( addr -- server )
[ fcgi-handler ] >>handler ;
: test-output ( -- str )
- "<pre>"
+ "<pre>"
request tget header>> [ "%s => %s\n" sprintf ] { }
assoc>map concat append
"</pre>" append ;
[
[ (literal) ] { } make [ write ] each
] with-string-writer ;
-
: flip-text ( str -- str' )
[ ch>flip ] map reverse ;
-
-
particle_t-array{
S{ particle_t f float-array{ 0.5 0.6 } float-array{ 0 0.1 } 1.0 }
S{ particle_t f float-array{ 0.5 0.6 } float-array{ 0.1 0 } 3.0 }
-
+
S{ particle_t f float-array{ 0.5 0.5 } float-array{ 0.1 0.1 } 2.0 }
S{ particle_t f float-array{ 0.5 0.6 } float-array{ -0.1 0 } 1.0 }
S{ particle_t f float-array{ 0.6 0.5 } float-array{ 0 -0.1 } 3.0 }
world particles>> [
[ p>> [ first , ] [ second , ] bi ] each
] curry float-array{ } make :> verts
-
- [
+
+ [
verts world texture>> 30.0 world dim>> { 4 4 } v/
blended-point-sprite-batch &dispose
blend-state new set-gpu-state
: with-forestdb-path ( path quot -- )
[ absolute-path fdb-open-default-config ] dip with-forestdb-handles-commit-wal ; inline
! [ absolute-path fdb-open-default-config ] dip with-forestdb-handle-commit-normal ; inline
-*/
\ No newline at end of file
+*/
! : path>next-vnode-version-name ( path -- path' )
! [ file-name ]
-
: set-kv-range ( a b -- )
make-kv-range [ fdb-set-kv ] assoc-each ;
-
FUNCTION: void FT_Done_FreeType ( void* library ) ;
FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ;
-
print-banner integer? [ 9000 ] unless* <tty-server> start-server drop ;
: fuel-start-remote-listener* ( -- ) f fuel-start-remote-listener ;
-
: get-style ( hwnd n -- style )
GetWindowLongPtr [ win32-error=0/f ] keep ;
-
+
: set-style ( hwnd n style -- )
SetWindowLongPtr win32-error=0/f ;
:: enable-fullscreen ( triple hwnd -- rect )
hwnd hwnd>RECT :> rect
-
+
desktop-monitor-info
triple GetDesktopWindow find-devmode
hwnd set-fullscreen-styles
debug-text-fragment-shader debug-text-vertex-format ;
CONSTANT: debug-text-font
- T{ font
+ T{ font
{ name "monospace" }
{ size 16 }
{ bold? f }
{ italic? f }
{ foreground COLOR: white }
{ background COLOR: black } }
-
-CONSTANT: debug-text-texture-parameters
+
+CONSTANT: debug-text-texture-parameters
T{ texture-parameters
{ wrap repeat-texcoord }
{ min-filter filter-linear }
{ min-mipmap-filter f } }
-
-: text>image ( string color -- image )
+
+: text>image ( string color -- image )
debug-text-font clone swap >>foreground swap string>image drop ;
:: image>texture ( image -- texture )
: debug-text-vertex-array ( image pt dim -- vertex-array )
screen-quad stream-upload draw-usage vertex-buffer byte-array>buffer &dispose
debug-text-program <program-instance> <vertex-array> &dispose ;
-
+
: debug-text-index-buffer ( -- index-buffer )
uint-array{ 0 1 2 2 3 0 } stream-upload draw-usage index-buffer
byte-array>buffer &dispose 0 <buffer-ptr> 6 uint-indexes <index-elements> ;
{ { -1 1 -1 } { 1 1 -1 } }
{ { 1 -1 -1 } { 1 -1 1 } }
{ { 1 -1 -1 } { 1 1 -1 } } }
-
+
CONSTANT: cylinder-vertices
$[ 12 iota [ 2pi 12 / * [ cos ] [ drop 0.0 ] [ sin ] tri 3array ] map ]
-
+
:: scale-cylinder-vertices ( radius half-height verts -- bot-verts top-verts )
verts
[ [ radius v*n { 0 half-height 0 } v- ] map ]
[ 1 <column> normalize over v+ COLOR: green debug-line ]
[ 2 <column> normalize over v+ COLOR: blue debug-line ]
2tri ; inline
-
+
:: debug-box ( pt half-widths color -- )
box-vertices [
first2 [ half-widths v* pt v+ ] bi@ color debug-line
TYPED: draw-debug-points ( points: float-array mvp-matrix -- )
[ points-mode -rot draw-debug-primitives ] with-destructors ; inline
-
+
TYPED: draw-text ( string color: rgba pt dim -- )
[
[ debug-text-uniform-variables ] 2dip
:: draw-debug-tests ( world -- )
world [ wasd-p-matrix ] [ wasd-mv-matrix ] bi m. :> mvp-matrix
{ 0 0 0 } clear-screen
-
+
[
{ 0 0 0 } { 1 0 0 } COLOR: red debug-line
{ 0 0 0 } { 0 1 0 } COLOR: green debug-line
{ key-print-screen { { 155 0 } { 10 10 } } }
{ key-scroll-lock { { 165 0 } { 10 10 } } }
{ key-pause { { 175 0 } { 10 10 } } }
-
+
{ key-insert { { 155 15 } { 10 10 } } }
{ key-home { { 165 15 } { 10 10 } } }
{ key-page-up { { 175 15 } { 10 10 } } }
TUPLE: key-caps-gadget < gadget keys timer ;
: make-key-gadget ( scancode dim array -- )
- [
- swap [
+ [
+ swap [
" " [ drop ] <border-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute( -- value ) ] bi*
: add-keys-gadgets ( gadget -- gadget )
key-locations 256 f <array>
[ [ make-key-gadget ] curry assoc-each ]
- [ [ [ add-gadget ] when* ] each ]
+ [ [ [ add-gadget ] when* ] each ]
[ >>keys ] tri ;
: <key-caps-gadget> ( -- gadget )
M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
: update-key-caps-state ( gadget -- )
- read-keyboard keys>> over keys>>
- [ [ selected?<< ] [ drop ] if* ] 2each
+ read-keyboard keys>> over keys>>
+ [ [ selected?<< ] [ drop ] if* ] 2each
relayout-1 ;
M: key-caps-gadget graft*
]
[ drop ensure-benchmark-data ]
2bi push ;
-
: each-face-edge ( ... edge quot: ( ... edge -- ... ) -- ... )
[ next-edge>> ] edge-loop ; inline
-!
+!
: vertex-edges ( edge -- edges )
[ ] [ each-vertex-edge ] (collect) ;
: face-sides ( edge -- count )
[ each-face-edge ] (count) ;
-
IN: game.models
TUPLE: model attribute-buffer index-buffer vertex-format material ;
-
[ line>obj ] each-stream-line push-current-model
models get
] with-variables ;
-
[ [ iseq>> new-resizable ] keep iseq<< ]
[ [ rassoc>> clone nip ] keep rassoc<< ]
2tri ;
-
: with-gdbm-writer ( name quot -- )
writer swap with-gdbm-role ; inline
-
[ ]
[ ]
} spread country boa
- ] input<sequence
+ ] input<sequence
] map ;
MEMO: load-regions ( -- seq )
[ ]
[ [ blank? ] trim ]
} spread region boa
- ] input<sequence
+ ] input<sequence
] map ;
MEMO: load-cities ( -- seq )
[ ]
[ string>number ]
} spread city boa
- ] input<sequence
+ ] input<sequence
] map ;
MEMO: load-version ( -- seq )
[ ]
[ string>number ]
} spread version boa
- ] input<sequence
+ ] input<sequence
] map ;
-! Copyright (C) 2010 Slava Pestov.\r
-USING: kernel sequences euler.modeling gml.runtime ;\r
-IN: gml.modeling\r
-\r
-GML: poly2doubleface ( poly mode -- edge )\r
- {\r
- smooth-smooth\r
- sharp-smooth\r
- smooth-sharp\r
- sharp-sharp\r
- smooth-like-vertex\r
- sharp-like-vertex\r
- smooth-continue\r
- sharp-continue\r
- } nth polygon>double-face ;\r
-\r
-GML: extrude-simple ( edge dist sharp -- edge ) extrude-simple ;\r
-\r
-GML: bridgerings-simple ( e1 e2 sharp -- edge ) bridge-rings-simple ;\r
-\r
-GML: project_ptline ( p p0 p1 -- q ) project-pt-line ;\r
-\r
-GML: project_ptplane ( p dir n d -- q ) project-pt-plane ;\r
-\r
-GML: project_polyplane ( [p] dir n d -- [q] ) project-poly-plane ;\r
+! Copyright (C) 2010 Slava Pestov.
+USING: kernel sequences euler.modeling gml.runtime ;
+IN: gml.modeling
+
+GML: poly2doubleface ( poly mode -- edge )
+ {
+ smooth-smooth
+ sharp-smooth
+ smooth-sharp
+ sharp-sharp
+ smooth-like-vertex
+ sharp-like-vertex
+ smooth-continue
+ sharp-continue
+ } nth polygon>double-face ;
+
+GML: extrude-simple ( edge dist sharp -- edge ) extrude-simple ;
+
+GML: bridgerings-simple ( e1 e2 sharp -- edge ) bridge-rings-simple ;
+
+GML: project_ptline ( p p0 p1 -- q ) project-pt-line ;
+
+GML: project_ptplane ( p dir n d -- q ) project-pt-plane ;
+
+GML: project_polyplane ( [p] dir n d -- [q] ) project-poly-plane ;
Program = Tokens Spaces !(.) => [[ parse-proc ]]
;EBNF
-
scan-gml-name :> ( word name )
word [ parse-definition ] parse-locals-definition :> ( word def effect )
word name effect def define-gml-primitive
- ] ;
+ ] ;
: <gml> ( -- gml )
gml new
-! Copyright (C) 2010 Slava Pestov.\r
-USING: arrays accessors euler.b-rep fry gml gml.runtime gml.viewer\r
-gml.printer io.directories io.encodings.utf8 io.files\r
-io.pathnames io.streams.string kernel locals models namespaces\r
-sequences ui ui.gadgets ui.gadgets.buttons ui.gadgets.editors\r
-ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels\r
-ui.gadgets.packs ui.gadgets.scrollers ui.gadgets.worlds\r
-ui.gadgets.tables ui.gadgets.labeled unicode.case ;\r
-FROM: gml => gml ;\r
-IN: gml.ui\r
-\r
-SINGLETON: stack-entry-renderer\r
-\r
-M: stack-entry-renderer row-columns\r
- drop [ write-gml ] with-string-writer 1array ;\r
-\r
-M: stack-entry-renderer row-value\r
- drop ;\r
-\r
-: <stack-table> ( model -- table )\r
- stack-entry-renderer <table>\r
- 10 >>min-rows\r
- 10 >>max-rows\r
- 40 >>min-cols\r
- 40 >>max-cols ;\r
-\r
-: <stack-display> ( model -- gadget )\r
- <stack-table> <scroller> "Operand stack" <labeled-gadget> ;\r
-\r
-TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;\r
-\r
-: update-models ( gml-editor -- )\r
- [ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]\r
- [ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]\r
- bi ;\r
-\r
-: with-gml-editor ( gml-editor quot -- )\r
- '[\r
- [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]\r
- [ update-models ]\r
- bi\r
- ] with-scope ; inline\r
-\r
-: find-gml-editor ( gadget -- gml-editor )\r
- [ gml-editor? ] find-parent ;\r
-\r
-: load-input ( file gml-editor -- )\r
- [ utf8 file-contents ] dip editor>> set-editor-string ;\r
-\r
-: update-viewer ( gml-editor -- )\r
- dup [ editor>> editor-string run-gml-string ] with-gml-editor ;\r
-\r
-: new-viewer ( gml-editor -- )\r
- [ update-viewer ]\r
- [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]\r
- bi ;\r
-\r
-: reset-viewer ( gml-editor -- )\r
- [\r
- b-rep get clear-b-rep\r
- gml get operand-stack>> delete-all\r
- ] with-gml-editor ;\r
-\r
-: <new-button> ( -- button )\r
- "New viewer" [ find-gml-editor new-viewer ] <border-button> ;\r
-\r
-: <update-button> ( -- button )\r
- "Update viewer" [ find-gml-editor update-viewer ] <border-button> ;\r
-\r
-: <reset-button> ( -- button )\r
- "Reset viewer" [ find-gml-editor reset-viewer ] <border-button> ;\r
-\r
-: <control-buttons> ( -- gadget )\r
- <shelf> { 5 5 } >>gap\r
- <new-button> add-gadget\r
- <update-button> add-gadget\r
- <reset-button> add-gadget ;\r
-\r
-CONSTANT: example-dir "vocab:gml/examples/"\r
-\r
-: gml-files ( -- seq )\r
- example-dir directory-files\r
- [ file-extension >lower "gml" = ] filter ;\r
-\r
-: <example-button> ( file -- button )\r
- dup '[ example-dir _ append-path swap find-gml-editor load-input ]\r
- <border-button> ;\r
-\r
-: <example-buttons> ( -- gadget )\r
- gml-files\r
- <pile> { 5 5 } >>gap \r
- "Examples:" <label> add-gadget\r
- [ <example-button> add-gadget ] reduce ;\r
-\r
-: <editor-panel> ( editor -- gadget )\r
- 30 >>min-rows\r
- 30 >>max-rows\r
- 40 >>min-cols\r
- 40 >>max-cols\r
- <scroller> "Editor" <labeled-gadget> ;\r
-\r
-: <gml-editor> ( -- gadget )\r
- 2 3 gml-editor new-frame\r
- <gml> >>gml\r
- <b-rep> >>b-rep\r
- dup b-rep>> <model> >>b-rep-model\r
- dup gml>> operand-stack>> <model> >>stack-model\r
- { 20 20 } >>gap\r
- { 0 0 } >>filled-cell\r
- <source-editor> >>editor\r
- dup editor>> <editor-panel> { 0 0 } grid-add\r
- dup stack-model>> <stack-display> { 0 1 } grid-add\r
- <control-buttons> { 0 2 } grid-add\r
- <example-buttons> { 1 0 } grid-add ;\r
-\r
-M: gml-editor focusable-child* editor>> ;\r
-\r
-: gml-editor-window ( -- )\r
- <gml-editor> "Generative Modeling Language" open-window ;\r
-\r
-MAIN: gml-editor-window\r
+! Copyright (C) 2010 Slava Pestov.
+USING: arrays accessors euler.b-rep fry gml gml.runtime gml.viewer
+gml.printer io.directories io.encodings.utf8 io.files
+io.pathnames io.streams.string kernel locals models namespaces
+sequences ui ui.gadgets ui.gadgets.buttons ui.gadgets.editors
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels
+ui.gadgets.packs ui.gadgets.scrollers ui.gadgets.worlds
+ui.gadgets.tables ui.gadgets.labeled unicode.case ;
+FROM: gml => gml ;
+IN: gml.ui
+
+SINGLETON: stack-entry-renderer
+
+M: stack-entry-renderer row-columns
+ drop [ write-gml ] with-string-writer 1array ;
+
+M: stack-entry-renderer row-value
+ drop ;
+
+: <stack-table> ( model -- table )
+ stack-entry-renderer <table>
+ 10 >>min-rows
+ 10 >>max-rows
+ 40 >>min-cols
+ 40 >>max-cols ;
+
+: <stack-display> ( model -- gadget )
+ <stack-table> <scroller> "Operand stack" <labeled-gadget> ;
+
+TUPLE: gml-editor < frame editor gml stack-model b-rep b-rep-model ;
+
+: update-models ( gml-editor -- )
+ [ [ b-rep>> dup finish-b-rep ] [ b-rep-model>> ] bi set-model ]
+ [ [ gml>> operand-stack>> ] [ stack-model>> ] bi set-model ]
+ bi ;
+
+: with-gml-editor ( gml-editor quot -- )
+ '[
+ [ [ gml>> gml set ] [ b-rep>> b-rep set ] bi @ ]
+ [ update-models ]
+ bi
+ ] with-scope ; inline
+
+: find-gml-editor ( gadget -- gml-editor )
+ [ gml-editor? ] find-parent ;
+
+: load-input ( file gml-editor -- )
+ [ utf8 file-contents ] dip editor>> set-editor-string ;
+
+: update-viewer ( gml-editor -- )
+ dup [ editor>> editor-string run-gml-string ] with-gml-editor ;
+
+: new-viewer ( gml-editor -- )
+ [ update-viewer ]
+ [ [ b-rep-model>> ] [ stack-model>> ] bi gml-viewer ]
+ bi ;
+
+: reset-viewer ( gml-editor -- )
+ [
+ b-rep get clear-b-rep
+ gml get operand-stack>> delete-all
+ ] with-gml-editor ;
+
+: <new-button> ( -- button )
+ "New viewer" [ find-gml-editor new-viewer ] <border-button> ;
+
+: <update-button> ( -- button )
+ "Update viewer" [ find-gml-editor update-viewer ] <border-button> ;
+
+: <reset-button> ( -- button )
+ "Reset viewer" [ find-gml-editor reset-viewer ] <border-button> ;
+
+: <control-buttons> ( -- gadget )
+ <shelf> { 5 5 } >>gap
+ <new-button> add-gadget
+ <update-button> add-gadget
+ <reset-button> add-gadget ;
+
+CONSTANT: example-dir "vocab:gml/examples/"
+
+: gml-files ( -- seq )
+ example-dir directory-files
+ [ file-extension >lower "gml" = ] filter ;
+
+: <example-button> ( file -- button )
+ dup '[ example-dir _ append-path swap find-gml-editor load-input ]
+ <border-button> ;
+
+: <example-buttons> ( -- gadget )
+ gml-files
+ <pile> { 5 5 } >>gap
+ "Examples:" <label> add-gadget
+ [ <example-button> add-gadget ] reduce ;
+
+: <editor-panel> ( editor -- gadget )
+ 30 >>min-rows
+ 30 >>max-rows
+ 40 >>min-cols
+ 40 >>max-cols
+ <scroller> "Editor" <labeled-gadget> ;
+
+: <gml-editor> ( -- gadget )
+ 2 3 gml-editor new-frame
+ <gml> >>gml
+ <b-rep> >>b-rep
+ dup b-rep>> <model> >>b-rep-model
+ dup gml>> operand-stack>> <model> >>stack-model
+ { 20 20 } >>gap
+ { 0 0 } >>filled-cell
+ <source-editor> >>editor
+ dup editor>> <editor-panel> { 0 0 } grid-add
+ dup stack-model>> <stack-display> { 0 1 } grid-add
+ <control-buttons> { 0 2 } grid-add
+ <example-buttons> { 1 0 } grid-add ;
+
+M: gml-editor focusable-child* editor>> ;
+
+: gml-editor-window ( -- )
+ <gml-editor> "Generative Modeling Language" open-window ;
+
+MAIN: gml-editor-window
-USING: gml.viewer math.vectors.simd.cords tools.test ;\r
-IN: gml.viewer.tests\r
-\r
-[ {\r
- double-4{ 0 0 0 0 }\r
- double-4{ 1 1 1 1 }\r
-} ] [ { double-4{ 0 0 0 0 } { double-4{ 1 1 1 1 } 2 } 3 } selected-vectors ] unit-test\r
+USING: gml.viewer math.vectors.simd.cords tools.test ;
+IN: gml.viewer.tests
+
+[ {
+ double-4{ 0 0 0 0 }
+ double-4{ 1 1 1 1 }
+} ] [ { double-4{ 0 0 0 0 } { double-4{ 1 1 1 1 } 2 } 3 } selected-vectors ] unit-test
-USING: accessors alien.c-types alien.data alien.data.map arrays\r
-assocs byte-arrays colors combinators combinators.short-circuit\r
-destructors euler.b-rep euler.b-rep.triangulation fry game.input\r
-game.loop game.models.half-edge game.worlds gml.printer gpu\r
-gpu.buffers gpu.framebuffers gpu.render gpu.shaders gpu.state\r
-gpu.util.wasd growable images kernel literals locals math\r
-math.order math.ranges math.vectors math.vectors.conversion\r
-math.vectors.simd math.vectors.simd.cords method-chains models\r
-namespaces sequences sets specialized-vectors typed ui\r
-ui.gadgets ui.gadgets.worlds ui.gestures ui.pixel-formats\r
-vectors ;\r
-FROM: math.matrices => m.v ;\r
-FROM: models => change-model ;\r
-SPECIALIZED-VECTORS: ushort float-4 ;\r
-IN: gml.viewer\r
-\r
-CONSTANT: neutral-edge-color float-4{ 1 1 1 1 }\r
-CONSTANT: neutral-face-color float-4{ 1 1 1 1 }\r
-CONSTANT: selected-face-color float-4{ 1 0.9 0.8 1 }\r
-\r
-: double-4>float-4 ( in: double-4 -- out: float-4 )\r
- [ head>> ] [ tail>> ] bi double-2 float-4 vconvert ; inline\r
-: rgba>float-4 ( in: rgba -- out: float-4 )\r
- >rgba-components float-4-boa ; inline\r
-\r
-: face-color ( edge -- color )\r
- face-normal float-4{ 0 1 0.1 0 } v. 0.3 * 0.4 + dup dup 1.0 float-4-boa ; inline\r
-\r
-TUPLE: b-rep-vertices\r
- { array byte-array read-only }\r
- { face-vertex-count integer read-only }\r
- { edge-vertex-count integer read-only }\r
- { point-vertex-count integer read-only } ;\r
-\r
-:: <b-rep-vertices> ( face-array face-count\r
- edge-array edge-count\r
- point-array point-count -- vxs )\r
- face-array edge-array point-array 3append\r
- face-count edge-count point-count \ b-rep-vertices boa ; inline\r
-\r
-: face-selected? ( face selected -- ? )\r
- [ f ] 2dip [ edge>> ] dip '[ _ in? or ] each-face-edge ;\r
-\r
-:: b-rep-face-vertices ( b-rep selected -- vertices count indices )\r
- float-4-vector{ } clone :> vertices\r
- ushort-vector{ } clone :> indices\r
-\r
- 0 b-rep faces>> [| count face |\r
- face selected face-selected? :> selected?\r
- face dup base-face>> eq? [\r
- face edge>> face-color\r
- selected? selected-face-color neutral-face-color ? v* :> color\r
- face triangulate-face seq>> :> triangles\r
- triangles members :> tri-vertices\r
- tri-vertices >index-hash :> vx-indices\r
-\r
- tri-vertices [\r
- position>> double-4>float-4 vertices push\r
- color vertices push\r
- ] each\r
- triangles [ vx-indices at count + indices push ] each\r
-\r
- count tri-vertices length +\r
- ] [ count ] if\r
- ] each :> total\r
- vertices float-4 >c-array underlying>>\r
- total\r
- indices ushort-array{ } like ;\r
-\r
-: b-rep-edge-vertices ( b-rep -- vertices count )\r
- vertices>> [\r
- [\r
- position>> [ double-4>float-4 ] keep\r
- [ drop neutral-edge-color ]\r
- [ vertex-color rgba>float-4 ] 2bi\r
- ] data-map( object -- float-4[4] )\r
- ] [ length 2 * ] bi ; inline\r
-\r
-GENERIC: selected-vectors ( object -- vectors )\r
-M: object selected-vectors drop { } ;\r
-M: double-4 selected-vectors 1array ;\r
-M: sequence selected-vectors [ selected-vectors ] map concat ;\r
-\r
-: selected-vertices ( selected -- vertices count )\r
- selected-vectors [\r
- [ [ double-4>float-4 ] [ vertex-color rgba>float-4 ] bi ]\r
- data-map( object -- float-4[2] )\r
- ] [ length ] bi ; inline\r
-\r
-: edge-vertex-index ( e vertex-indices selected -- n selected? )\r
- [ dup vertex>> ] [ at 2 * ] [ swapd in? [ [ 1 + ] when ] keep ] tri* ;\r
-\r
-:: b-rep-edge-index-array ( b-rep selected offset -- edge-indices )\r
- b-rep vertices>> >index-hash :> vertex-indices\r
- b-rep edges>> length <ushort-vector> :> edge-indices\r
-\r
- b-rep edges>> [| e |\r
- e opposite-edge>> :> o\r
- e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )\r
- o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )\r
-\r
- from to < [ from edge-indices push to edge-indices push ] when\r
- ] each\r
-\r
- edge-indices ushort-array{ } like ;\r
-\r
-:: make-b-rep-vertices ( b-rep selected -- vertices face-indices edge-indices point-indices )\r
- b-rep selected b-rep-face-vertices :> ( face-vertices face-count face-indices )\r
- b-rep b-rep-edge-vertices :> ( edge-vertices edge-count )\r
- selected selected-vertices :> ( sel-vertices sel-count )\r
- face-vertices face-count edge-vertices edge-count sel-vertices sel-count\r
- <b-rep-vertices> :> vertices\r
-\r
- vertices array>>\r
-\r
- face-indices\r
-\r
- b-rep selected vertices face-vertex-count>> b-rep-edge-index-array\r
- vertices\r
-\r
- [ face-vertex-count>> ]\r
- [ edge-vertex-count>> + dup ]\r
- [ point-vertex-count>> + ] tri\r
- [a,b) ushort >c-array ;\r
-\r
-VERTEX-FORMAT: wire-vertex-format\r
- { "vertex" float-components 3 f }\r
- { f float-components 1 f }\r
- { "color" float-components 4 f } ;\r
-\r
-GLSL-SHADER-FILE: gml-viewer-vertex-shader vertex-shader "viewer.v.glsl"\r
-GLSL-SHADER-FILE: gml-viewer-fragment-shader fragment-shader "viewer.f.glsl"\r
-GLSL-PROGRAM: gml-viewer-program\r
- gml-viewer-vertex-shader gml-viewer-fragment-shader\r
- wire-vertex-format ;\r
-\r
-TUPLE: gml-viewer-world < wasd-world\r
- { b-rep b-rep }\r
- selected\r
- program\r
- vertex-array\r
- face-indices edge-indices point-indices\r
- view-faces? view-edges?\r
- drag? ;\r
-\r
-TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )\r
- dup control-value >>b-rep\r
- dup vertex-array>> [ vertex-array-buffer dispose ] when*\r
- dup [ b-rep>> ] [ selected>> value>> ] bi make-b-rep-vertices {\r
- [\r
- static-upload draw-usage vertex-buffer byte-array>buffer\r
- over program>> <vertex-array> >>vertex-array\r
- ]\r
- [ >>face-indices ]\r
- [ >>edge-indices ]\r
- [ >>point-indices ]\r
- } spread\r
- drop ;\r
-\r
-: viewable? ( gml-viewer-world -- ? )\r
- { [ b-rep>> ] [ program>> ] } 1&& ;\r
-\r
-M: gml-viewer-world model-changed\r
- nip\r
- [ control-value ]\r
- [ b-rep<< ]\r
- [ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;\r
-\r
-: init-viewer-model ( gml-viewer-world -- )\r
- [ dup model>> add-connection ]\r
- [ dup selected>> add-connection ] bi ;\r
-\r
-: reset-view ( gml-viewer-world -- )\r
- { 0.0 0.0 5.0 } 0.0 0.0 set-wasd-view drop ;\r
-\r
-M: gml-viewer-world begin-game-world\r
- init-gpu\r
- t >>view-faces?\r
- t >>view-edges?\r
- T{ point-state { size 5.0 } } set-gpu-state\r
- dup reset-view\r
- gml-viewer-program <program-instance> >>program\r
- dup init-viewer-model\r
- refresh-b-rep-view ;\r
-\r
-M: gml-viewer-world end-game-world\r
- [ dup selected>> remove-connection ]\r
- [ dup model>> remove-connection ] bi ;\r
-\r
-M: gml-viewer-world draw-world*\r
- system-framebuffer {\r
- { default-attachment { 0.0 0.0 0.0 1.0 } }\r
- { depth-attachment 1.0 }\r
- } clear-framebuffer\r
-\r
- [\r
- dup view-faces?>> [\r
- T{ depth-state { comparison cmp-less } } set-gpu-state\r
- {\r
- { "primitive-mode" [ drop triangles-mode ] }\r
- { "indexes" [ face-indices>> ] }\r
- { "uniforms" [ <mvp-uniforms> ] }\r
- { "vertex-array" [ vertex-array>> ] }\r
- } <render-set> render\r
- T{ depth-state { comparison f } } set-gpu-state\r
- ] [ drop ] if\r
- ] [\r
- dup view-edges?>> [\r
- {\r
- { "primitive-mode" [ drop lines-mode ] }\r
- { "indexes" [ edge-indices>> ] }\r
- { "uniforms" [ <mvp-uniforms> ] }\r
- { "vertex-array" [ vertex-array>> ] }\r
- } <render-set> render\r
- ] [ drop ] if\r
- ] [\r
- {\r
- { "primitive-mode" [ drop points-mode ] }\r
- { "indexes" [ point-indices>> ] }\r
- { "uniforms" [ <mvp-uniforms> ] }\r
- { "vertex-array" [ vertex-array>> ] }\r
- } <render-set> render\r
- ] tri ;\r
-\r
-TYPED: rotate-view-mode ( world: gml-viewer-world -- )\r
- dup view-edges?>> [\r
- dup view-faces?>>\r
- [ f >>view-faces? ]\r
- [ f >>view-edges? t >>view-faces? ] if\r
- ] [ t >>view-edges? ] if drop ;\r
-\r
-CONSTANT: edge-hitbox-radius 0.05\r
-\r
-:: line-nearest-t ( p0 u q0 v -- tp tq )\r
- p0 q0 v- :> w0\r
-\r
- u u v. :> a\r
- u v v. :> b\r
- v v v. :> c\r
- u w0 v. :> d\r
- v w0 v. :> e\r
-\r
- a c * b b * - :> denom\r
-\r
- b e * c d * - denom /f\r
- a e * b d * - denom /f ;\r
-\r
-:: intersects-edge-node? ( source direction edge -- ? )\r
- edge vertex>> position>> double-4>float-4 :> edge-source\r
- edge opposite-edge>> vertex>> position>> double-4>float-4 edge-source v- :> edge-direction\r
-\r
- source direction edge-source edge-direction line-nearest-t :> ( ray-t edge-t )\r
-\r
- ray-t 0.0 >= edge-t 0.0 0.5 between? and [\r
- source direction ray-t v*n v+\r
- edge-source edge-direction edge-t v*n v+ v- norm\r
- edge-hitbox-radius <\r
- ] [ f ] if ;\r
-\r
-: intersecting-edge-node ( source direction b-rep -- edge/f )\r
- edges>> [ intersects-edge-node? ] 2with find nip ;\r
-\r
-: select-edge ( world -- )\r
- [ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]\r
- [ b-rep>> intersecting-edge-node ]\r
- [ '[ _ [ selected>> push-model ] [ refresh-b-rep-view ] bi ] when* ] tri ;\r
-\r
-gml-viewer-world H{\r
- { T{ button-up f f 1 } [ dup drag?>> [ drop ] [ select-edge ] if ] }\r
- { T{ drag f 1 } [ t >>drag? drop ] }\r
- { T{ key-down f f "RET" } [ reset-view ] }\r
- { T{ key-down f f "TAB" } [ rotate-view-mode ] }\r
-} set-gestures\r
-\r
-AFTER: gml-viewer-world tick-game-world\r
- dup drag?>> [\r
- read-mouse buttons>>\r
- ! FIXME: GTK Mouse buttons are an integer\r
- ! MacOSX mouse buttons are an array of bools\r
- dup integer? [ 0 bit? ] [ first ] if >>drag?\r
- ] when drop ;\r
-\r
-M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;\r
-\r
-: wrap-in-model ( object -- model )\r
- dup model? [ <model> ] unless ;\r
-: wrap-in-growable-model ( object -- model )\r
- dup model? [\r
- dup growable? [ >vector ] unless\r
- <model>\r
- ] unless ;\r
-\r
-: gml-viewer ( b-rep selection -- )\r
- [ wrap-in-model ] [ wrap-in-growable-model ] bi*\r
- '[\r
- f T{ game-attributes\r
- { world-class gml-viewer-world }\r
- { title "GML wireframe viewer" }\r
- { pixel-format-attributes {\r
- windowed\r
- double-buffered\r
- T{ depth-bits f 16 }\r
- } }\r
- { grab-input? f }\r
- { use-game-input? t }\r
- { use-audio-engine? f }\r
- { pref-dim { 1024 768 } }\r
- { tick-interval-nanos $[ 30 fps ] }\r
- } open-window*\r
- _ >>model\r
- _ >>selected\r
- drop\r
- ] with-ui ;\r
+USING: accessors alien.c-types alien.data alien.data.map arrays
+assocs byte-arrays colors combinators combinators.short-circuit
+destructors euler.b-rep euler.b-rep.triangulation fry game.input
+game.loop game.models.half-edge game.worlds gml.printer gpu
+gpu.buffers gpu.framebuffers gpu.render gpu.shaders gpu.state
+gpu.util.wasd growable images kernel literals locals math
+math.order math.ranges math.vectors math.vectors.conversion
+math.vectors.simd math.vectors.simd.cords method-chains models
+namespaces sequences sets specialized-vectors typed ui
+ui.gadgets ui.gadgets.worlds ui.gestures ui.pixel-formats
+vectors ;
+FROM: math.matrices => m.v ;
+FROM: models => change-model ;
+SPECIALIZED-VECTORS: ushort float-4 ;
+IN: gml.viewer
+
+CONSTANT: neutral-edge-color float-4{ 1 1 1 1 }
+CONSTANT: neutral-face-color float-4{ 1 1 1 1 }
+CONSTANT: selected-face-color float-4{ 1 0.9 0.8 1 }
+
+: double-4>float-4 ( in: double-4 -- out: float-4 )
+ [ head>> ] [ tail>> ] bi double-2 float-4 vconvert ; inline
+: rgba>float-4 ( in: rgba -- out: float-4 )
+ >rgba-components float-4-boa ; inline
+
+: face-color ( edge -- color )
+ face-normal float-4{ 0 1 0.1 0 } v. 0.3 * 0.4 + dup dup 1.0 float-4-boa ; inline
+
+TUPLE: b-rep-vertices
+ { array byte-array read-only }
+ { face-vertex-count integer read-only }
+ { edge-vertex-count integer read-only }
+ { point-vertex-count integer read-only } ;
+
+:: <b-rep-vertices> ( face-array face-count
+ edge-array edge-count
+ point-array point-count -- vxs )
+ face-array edge-array point-array 3append
+ face-count edge-count point-count \ b-rep-vertices boa ; inline
+
+: face-selected? ( face selected -- ? )
+ [ f ] 2dip [ edge>> ] dip '[ _ in? or ] each-face-edge ;
+
+:: b-rep-face-vertices ( b-rep selected -- vertices count indices )
+ float-4-vector{ } clone :> vertices
+ ushort-vector{ } clone :> indices
+
+ 0 b-rep faces>> [| count face |
+ face selected face-selected? :> selected?
+ face dup base-face>> eq? [
+ face edge>> face-color
+ selected? selected-face-color neutral-face-color ? v* :> color
+ face triangulate-face seq>> :> triangles
+ triangles members :> tri-vertices
+ tri-vertices >index-hash :> vx-indices
+
+ tri-vertices [
+ position>> double-4>float-4 vertices push
+ color vertices push
+ ] each
+ triangles [ vx-indices at count + indices push ] each
+
+ count tri-vertices length +
+ ] [ count ] if
+ ] each :> total
+ vertices float-4 >c-array underlying>>
+ total
+ indices ushort-array{ } like ;
+
+: b-rep-edge-vertices ( b-rep -- vertices count )
+ vertices>> [
+ [
+ position>> [ double-4>float-4 ] keep
+ [ drop neutral-edge-color ]
+ [ vertex-color rgba>float-4 ] 2bi
+ ] data-map( object -- float-4[4] )
+ ] [ length 2 * ] bi ; inline
+
+GENERIC: selected-vectors ( object -- vectors )
+M: object selected-vectors drop { } ;
+M: double-4 selected-vectors 1array ;
+M: sequence selected-vectors [ selected-vectors ] map concat ;
+
+: selected-vertices ( selected -- vertices count )
+ selected-vectors [
+ [ [ double-4>float-4 ] [ vertex-color rgba>float-4 ] bi ]
+ data-map( object -- float-4[2] )
+ ] [ length ] bi ; inline
+
+: edge-vertex-index ( e vertex-indices selected -- n selected? )
+ [ dup vertex>> ] [ at 2 * ] [ swapd in? [ [ 1 + ] when ] keep ] tri* ;
+
+:: b-rep-edge-index-array ( b-rep selected offset -- edge-indices )
+ b-rep vertices>> >index-hash :> vertex-indices
+ b-rep edges>> length <ushort-vector> :> edge-indices
+
+ b-rep edges>> [| e |
+ e opposite-edge>> :> o
+ e vertex-indices selected edge-vertex-index [ offset + ] dip :> ( from e-selected? )
+ o vertex-indices selected edge-vertex-index [ offset + ] dip :> ( to o-selected? )
+
+ from to < [ from edge-indices push to edge-indices push ] when
+ ] each
+
+ edge-indices ushort-array{ } like ;
+
+:: make-b-rep-vertices ( b-rep selected -- vertices face-indices edge-indices point-indices )
+ b-rep selected b-rep-face-vertices :> ( face-vertices face-count face-indices )
+ b-rep b-rep-edge-vertices :> ( edge-vertices edge-count )
+ selected selected-vertices :> ( sel-vertices sel-count )
+ face-vertices face-count edge-vertices edge-count sel-vertices sel-count
+ <b-rep-vertices> :> vertices
+
+ vertices array>>
+
+ face-indices
+
+ b-rep selected vertices face-vertex-count>> b-rep-edge-index-array
+ vertices
+
+ [ face-vertex-count>> ]
+ [ edge-vertex-count>> + dup ]
+ [ point-vertex-count>> + ] tri
+ [a,b) ushort >c-array ;
+
+VERTEX-FORMAT: wire-vertex-format
+ { "vertex" float-components 3 f }
+ { f float-components 1 f }
+ { "color" float-components 4 f } ;
+
+GLSL-SHADER-FILE: gml-viewer-vertex-shader vertex-shader "viewer.v.glsl"
+GLSL-SHADER-FILE: gml-viewer-fragment-shader fragment-shader "viewer.f.glsl"
+GLSL-PROGRAM: gml-viewer-program
+ gml-viewer-vertex-shader gml-viewer-fragment-shader
+ wire-vertex-format ;
+
+TUPLE: gml-viewer-world < wasd-world
+ { b-rep b-rep }
+ selected
+ program
+ vertex-array
+ face-indices edge-indices point-indices
+ view-faces? view-edges?
+ drag? ;
+
+TYPED: refresh-b-rep-view ( world: gml-viewer-world -- )
+ dup control-value >>b-rep
+ dup vertex-array>> [ vertex-array-buffer dispose ] when*
+ dup [ b-rep>> ] [ selected>> value>> ] bi make-b-rep-vertices {
+ [
+ static-upload draw-usage vertex-buffer byte-array>buffer
+ over program>> <vertex-array> >>vertex-array
+ ]
+ [ >>face-indices ]
+ [ >>edge-indices ]
+ [ >>point-indices ]
+ } spread
+ drop ;
+
+: viewable? ( gml-viewer-world -- ? )
+ { [ b-rep>> ] [ program>> ] } 1&& ;
+
+M: gml-viewer-world model-changed
+ nip
+ [ control-value ]
+ [ b-rep<< ]
+ [ dup viewable? [ refresh-b-rep-view ] [ drop ] if ] tri ;
+
+: init-viewer-model ( gml-viewer-world -- )
+ [ dup model>> add-connection ]
+ [ dup selected>> add-connection ] bi ;
+
+: reset-view ( gml-viewer-world -- )
+ { 0.0 0.0 5.0 } 0.0 0.0 set-wasd-view drop ;
+
+M: gml-viewer-world begin-game-world
+ init-gpu
+ t >>view-faces?
+ t >>view-edges?
+ T{ point-state { size 5.0 } } set-gpu-state
+ dup reset-view
+ gml-viewer-program <program-instance> >>program
+ dup init-viewer-model
+ refresh-b-rep-view ;
+
+M: gml-viewer-world end-game-world
+ [ dup selected>> remove-connection ]
+ [ dup model>> remove-connection ] bi ;
+
+M: gml-viewer-world draw-world*
+ system-framebuffer {
+ { default-attachment { 0.0 0.0 0.0 1.0 } }
+ { depth-attachment 1.0 }
+ } clear-framebuffer
+
+ [
+ dup view-faces?>> [
+ T{ depth-state { comparison cmp-less } } set-gpu-state
+ {
+ { "primitive-mode" [ drop triangles-mode ] }
+ { "indexes" [ face-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ T{ depth-state { comparison f } } set-gpu-state
+ ] [ drop ] if
+ ] [
+ dup view-edges?>> [
+ {
+ { "primitive-mode" [ drop lines-mode ] }
+ { "indexes" [ edge-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ ] [ drop ] if
+ ] [
+ {
+ { "primitive-mode" [ drop points-mode ] }
+ { "indexes" [ point-indices>> ] }
+ { "uniforms" [ <mvp-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render
+ ] tri ;
+
+TYPED: rotate-view-mode ( world: gml-viewer-world -- )
+ dup view-edges?>> [
+ dup view-faces?>>
+ [ f >>view-faces? ]
+ [ f >>view-edges? t >>view-faces? ] if
+ ] [ t >>view-edges? ] if drop ;
+
+CONSTANT: edge-hitbox-radius 0.05
+
+:: line-nearest-t ( p0 u q0 v -- tp tq )
+ p0 q0 v- :> w0
+
+ u u v. :> a
+ u v v. :> b
+ v v v. :> c
+ u w0 v. :> d
+ v w0 v. :> e
+
+ a c * b b * - :> denom
+
+ b e * c d * - denom /f
+ a e * b d * - denom /f ;
+
+:: intersects-edge-node? ( source direction edge -- ? )
+ edge vertex>> position>> double-4>float-4 :> edge-source
+ edge opposite-edge>> vertex>> position>> double-4>float-4 edge-source v- :> edge-direction
+
+ source direction edge-source edge-direction line-nearest-t :> ( ray-t edge-t )
+
+ ray-t 0.0 >= edge-t 0.0 0.5 between? and [
+ source direction ray-t v*n v+
+ edge-source edge-direction edge-t v*n v+ v- norm
+ edge-hitbox-radius <
+ ] [ f ] if ;
+
+: intersecting-edge-node ( source direction b-rep -- edge/f )
+ edges>> [ intersects-edge-node? ] 2with find nip ;
+
+: select-edge ( world -- )
+ [ [ location>> ] [ hand-loc get wasd-pixel-ray ] bi ]
+ [ b-rep>> intersecting-edge-node ]
+ [ '[ _ [ selected>> push-model ] [ refresh-b-rep-view ] bi ] when* ] tri ;
+
+gml-viewer-world H{
+ { T{ button-up f f 1 } [ dup drag?>> [ drop ] [ select-edge ] if ] }
+ { T{ drag f 1 } [ t >>drag? drop ] }
+ { T{ key-down f f "RET" } [ reset-view ] }
+ { T{ key-down f f "TAB" } [ rotate-view-mode ] }
+} set-gestures
+
+AFTER: gml-viewer-world tick-game-world
+ dup drag?>> [
+ read-mouse buttons>>
+ ! FIXME: GTK Mouse buttons are an integer
+ ! MacOSX mouse buttons are an array of bools
+ dup integer? [ 0 bit? ] [ first ] if >>drag?
+ ] when drop ;
+
+M: gml-viewer-world wasd-mouse-scale drag?>> -1/600. 0.0 ? ;
+
+: wrap-in-model ( object -- model )
+ dup model? [ <model> ] unless ;
+: wrap-in-growable-model ( object -- model )
+ dup model? [
+ dup growable? [ >vector ] unless
+ <model>
+ ] unless ;
+
+: gml-viewer ( b-rep selection -- )
+ [ wrap-in-model ] [ wrap-in-growable-model ] bi*
+ '[
+ f T{ game-attributes
+ { world-class gml-viewer-world }
+ { title "GML wireframe viewer" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits f 16 }
+ } }
+ { grab-input? f }
+ { use-game-input? t }
+ { use-audio-engine? f }
+ { pref-dim { 1024 768 } }
+ { tick-interval-nanos $[ 30 fps ] }
+ } open-window*
+ _ >>model
+ _ >>selected
+ drop
+ ] with-ui ;
pixel-unpack-buffer pixel-pack-buffer
transform-feedback-buffer ;
-TUPLE: buffer < gpu-object
+TUPLE: buffer < gpu-object
{ upload-pattern buffer-upload-pattern }
{ usage-pattern buffer-usage-pattern }
{ kind buffer-kind } ;
M: buffer dispose
[ [ delete-gl-buffer ] when* f ] change-handle drop ;
-TUPLE: buffer-ptr
+TUPLE: buffer-ptr
{ buffer buffer read-only }
{ offset integer read-only } ;
C: <buffer-ptr> buffer-ptr
pick buffer-ptr?
[ with-buffer-ptr ]
[ [ gl-target 0 glBindBuffer ] dip call ] if ; inline
-
{ "color-texture" texture-uniform f }
{ "normal-texture" texture-uniform f }
{ "depth-texture" texture-uniform f }
- { "line-color" vec4-uniform f } ;
+ { "line-color" vec4-uniform f } ;
UNIFORM-TUPLE: loading-uniforms
{ "texcoord-scale" vec2-uniform f }
M: bunny-world begin-game-world
init-gpu
-
+
{ -0.2 0.13 0.1 } 1.1 0.2 set-wasd-view
<bunny-state> >>bunny
: draw-bunny ( world -- )
T{ depth-state { comparison cmp-less } } set-gpu-state
-
+
[
sobel>> framebuffer>> {
{ T{ color-attachment f 0 } { 0.15 0.15 0.15 1.0 } }
UNIFORM-TUPLE: raytrace-uniforms
{ "mv-inv-matrix" mat4-uniform f }
{ "fov" vec2-uniform f }
-
+
{ "spheres" sphere-uniforms 4 }
{ "floor-height" float-uniform f }
"vocab:gpu/demos/raytrace/green-ball.aiff" read-audio t <static-audio-clip>
audio-engine spheres fourth
"vocab:gpu/demos/raytrace/yellow-ball.aiff" read-audio t <static-audio-clip>
-
+
4array play-clips ;
M: raytrace-world begin-game-world
init-gpu
{ -2.0 6.25 10.0 } 0.19 0.55 set-wasd-view
- initial-spheres [ clone ] map >>spheres
+ initial-spheres [ clone ] map >>spheres
raytrace-program <program-instance> <window-vertex-array> >>vertex-array
set-up-audio ;
gl_FragColor = col;
}
;
-
+
UNIFORM-TUPLE: blur-uniforms
{ "texture" texture-uniform f }
{ "horizontal" bool-uniform f }
{ "blurSize" float-uniform f } ;
GLSL-PROGRAM: blur-program window-vertex-shader blur-fragment-shader window-vertex-format ;
-
+
:: (blur) ( texture horizontal? framebuffer dim -- )
{ 0 0 } dim <rect> <viewport-state> set-gpu-state
texture horizontal? 1.0 dim horizontal? [ first ] [ second ] if / blur-uniforms boa framebuffer {
{ "indexes" [ 2drop T{ index-range f 0 4 } ] }
{ "framebuffer" [ nip ] }
} 2<render-set> render ;
-
+
:: blur ( texture horizontal? -- texture )
texture 0 texture-dim :> dim
dim RGB float-components <2d-render-texture> :> ( target-framebuffer target-texture )
texture horizontal? target-framebuffer dim (blur)
target-framebuffer dispose
target-texture ;
-
+
: horizontal-blur ( texture -- texture ) t blur ; inline
-
+
: vertical-blur ( texture -- texture ) f blur ; inline
: discompose ( quot1 quot2 -- compose )
gpu-data-ptr -- )
GL_READ_FRAMEBUFFER framebuffer-rect framebuffer>> framebuffer-handle glBindFramebuffer
framebuffer-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glReadBuffer
- framebuffer-rect rect>> [ loc>> first2 ] [ dim>> first2 ] bi
+ framebuffer-rect rect>> [ loc>> first2 ] [ dim>> first2 ] bi
framebuffer-rect framebuffer-rect-image-type image-data-format
gpu-data-ptr pixel-pack-buffer [ glReadPixels ] with-gpu-data-ptr ;
-
+
: read-framebuffer ( framebuffer-rect -- byte-array )
dup framebuffer-rect-size <byte-array> [ read-framebuffer-to ] keep ; inline
framebuffer-rect-image-type
[ >>component-order ] [ >>component-type ] bi*
]
- [ read-framebuffer >>bitmap ]
+ [ read-framebuffer >>bitmap ]
} cleave ;
TYPED:: copy-framebuffer ( to-fb-rect: framebuffer-rect
to-fb-rect attachment>> [ GL_COLOR_BUFFER_BIT ] [ 0 ] if
depth? [ GL_DEPTH_BUFFER_BIT ] [ 0 ] if bitor
stencil? [ GL_STENCIL_BUFFER_BIT ] [ 0 ] if bitor :> mask
-
+
from-fb-rect rect>> rect-extent [ first2 ] bi@
to-fb-rect rect>> rect-extent [ first2 ] bi@
mask filter gl-mag-filter glBlitFramebuffer ;
-
{ uint-indexes [ GL_UNSIGNED_INT ] }
} case ; inline
-: gl-primitive-mode ( primitive-mode -- gl-primitive-mode )
+: gl-primitive-mode ( primitive-mode -- gl-primitive-mode )
{
{ points-mode [ GL_POINTS ] }
{ lines-mode [ GL_LINES ] }
[ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] [ ] tri*
glDrawArraysInstanced ;
-M: multi-index-range render-vertex-indexes
+M: multi-index-range render-vertex-indexes
[ gl-primitive-mode ] [ [ starts>> ] [ counts>> dup length ] bi ] bi*
glMultiDrawArrays ;
GENERIC: bind-uniform-vec4 ( index sequence -- )
M: object >uniform-bool-array [ >c-bool ] int-array{ } map-as ; inline
-M: binary-data >uniform-bool-array ; inline
+M: binary-data >uniform-bool-array ; inline
M: object >uniform-int-array c:int >c-array ; inline
-M: binary-data >uniform-int-array ; inline
+M: binary-data >uniform-int-array ; inline
M: object >uniform-uint-array c:uint >c-array ; inline
-M: binary-data >uniform-uint-array ; inline
+M: binary-data >uniform-uint-array ; inline
M: object >uniform-float-array c:float >c-array ; inline
-M: binary-data >uniform-float-array ; inline
+M: binary-data >uniform-float-array ; inline
M: object >uniform-bvec-array '[ _ head-slice [ >c-bool ] int-array{ } map-as ] map concat ; inline
M: binary-data >uniform-bvec-array drop ; inline
[ rows head-slice c:float >c-array ] { } map-as concat ; inline
M: binary-data >uniform-matrix 2drop ; inline
-M: object >uniform-matrix-array
+M: object >uniform-matrix-array
'[ _ _ >uniform-matrix ] map concat ; inline
M: binary-data >uniform-matrix-array 2drop ; inline
SYNTAX: UNIFORM-TUPLE:
parse-uniform-tuple-definition define-uniform-tuple ;
-<PRIVATE
+<PRIVATE
: bind-unnamed-output-attachments ( framebuffer attachments -- )
[ gl-attachment ] with map
{ primitive-mode primitive-mode 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 }
+ { indexes vertex-indexes initial: T{ index-range } read-only }
{ instances maybe{ integer } initial: f read-only }
{ framebuffer maybe{ any-framebuffer } initial: system-framebuffer read-only }
{ output-attachments sequence initial: { default-attachment } read-only }
bind-uniforms
]
[
- framebuffer>>
+ framebuffer>>
[ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ]
[ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if*
]
[ transform-feedback-output>> [ glEndTransformFeedback ] when ]
[ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ]
} cleave ; inline
-
[ handle>> ] dip glGetFragDataLocation ;
: vertex-format-attributes ( vertex-format -- attributes )
- "vertex-format-attributes" word-prop ; inline
+ "vertex-format-attributes" word-prop ; inline
<PRIVATE
{ uint-integer-components [ GL_UNSIGNED_INT ] }
} case ;
-: vertex-type-size ( component-type -- size )
+: vertex-type-size ( component-type -- size )
{
{ ubyte-components [ 1 ] }
{ ushort-components [ 2 ] }
:: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
{
- [ vertex-attribute name>> name = ]
+ [ vertex-attribute name>> name = ]
[ size 1 = ]
[ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
{ attributes-cleave 2cleave } >quotation :> with-block
- { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
+ { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
:: [link-feedback-format] ( vertex-attributes -- quot )
vertex-attributes [ name>> not ] any?
[ f 0 int <ref> 0 int <ref> ] dip <byte-array>
[ glGetTransformFeedbackVarying ] 3keep
ascii alien>string
- vertex-attribute assert-feedback-attribute
+ vertex-attribute assert-feedback-attribute
} >quotation ;
:: [verify-feedback-format] ( vertex-attributes -- quot )
: link-vertex-formats ( program-handle formats -- )
[ vertex-format-attributes [ name>> ] map sift ] map concat
- swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
+ swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
GENERIC: link-geometry-shader-parameter ( program-handle parameter -- )
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> ]
scan-word execute( -- kind )
scan-object in-word's-path
0
- over ascii file-contents
+ over ascii file-contents
] dip
shader boa
over reset-generic
{ antialias? boolean initial: f read-only } ;
C: <triangle-state> triangle-state
-VARIANT: point-sprite-origin
+VARIANT: point-sprite-origin
origin-upper-left origin-lower-left ;
TUPLE: point-state
<PRIVATE
: gl-triangle-face ( triangle-face -- face )
- {
+ {
{ face-ccw [ GL_CCW ] }
{ face-cw [ GL_CW ] }
} case ;
: gl-triangle-face> ( triangle-face -- face )
- {
+ {
{ $ GL_CCW [ face-ccw ] }
{ $ GL_CW [ face-cw ] }
} case ;
: gl-comparison ( comparison -- comparison )
{
- { cmp-never [ GL_NEVER ] }
+ { cmp-never [ GL_NEVER ] }
{ cmp-always [ GL_ALWAYS ] }
{ cmp-less [ GL_LESS ] }
{ cmp-less-equal [ GL_LEQUAL ] }
: gl-comparison> ( comparison -- comparison )
{
- { $ GL_NEVER [ cmp-never ] }
+ { $ GL_NEVER [ cmp-never ] }
{ $ GL_ALWAYS [ cmp-always ] }
{ $ GL_LESS [ cmp-less ] }
{ $ GL_LEQUAL [ cmp-less-equal ] }
<blend-state> ;
TYPED: get-mask-state ( -- mask-state: mask-state )
- GL_COLOR_WRITEMASK 4 get-gl-bools
+ GL_COLOR_WRITEMASK 4 get-gl-bools
GL_DEPTH_WRITEMASK get-gl-bool
GL_STENCIL_WRITEMASK get-gl-int
GL_STENCIL_BACK_WRITEMASK get-gl-int
TYPED: get-point-state ( -- point-state: point-state )
GL_VERTEX_PROGRAM_POINT_SIZE gl-enabled?
[ f ] [ GL_POINT_SIZE get-gl-float ] if
- GL_POINT_SPRITE_COORD_ORIGIN get-gl-int gl-point-sprite-origin>
+ GL_POINT_SPRITE_COORD_ORIGIN get-gl-int gl-point-sprite-origin>
GL_POINT_FADE_THRESHOLD_SIZE get-gl-float
<point-state> ;
M:: texture-2d-data-target texture-dim ( tdt level -- dim )
tdt bind-tdt :> texture
- tdt texture-data-gl-target level
+ tdt texture-data-gl-target level
[ GL_TEXTURE_WIDTH get-texture-int ] [ GL_TEXTURE_HEIGHT get-texture-int ] 2bi
2array ; inline
texture-1d-array <texture> ; inline
: <texture-2d-array> ( component-order component-type parameters -- texture )
texture-2d-array <texture> ; inline
-
{ 0.0 0.0 0.0 1.0 }
} }
}
-
+
GLSL-SHADER: window-vertex-shader vertex-shader
attribute vec2 vertex;
varying vec2 texcoord;
}
: <window-vertex-buffer> ( -- buffer )
- window-vertexes
+ window-vertexes
static-upload draw-usage vertex-buffer
byte-array>buffer ; inline
{ "indexes" [ 2drop length 2 / 0 swap <index-range> ] }
{ "framebuffer" [ drop nip ] }
} 3<render-set> render ;
-
+
:: blended-point-sprite-batch ( verts texture point-size dim -- texture )
dim RGB float-components <2d-render-texture> :> ( target-framebuffer target-texture )
verts target-framebuffer texture point-size dim (blended-point-sprite-batch)
near-plane far-plane frustum-matrix4 ;
:: wasd-pixel-ray ( world loc -- direction )
- loc world dim>> [ /f 0.5 - 2.0 * ] 2map
+ loc world dim>> [ /f 0.5 - 2.0 * ] 2map
world wasd-fov-vector v*
first2 neg -1.0 0.0 4array
world wasd-mv-inv-matrix swap m.v ;
:: wasd-keyboard-input ( world -- )
read-keyboard keys>> :> keys
- key-w keys nth [ world walk-forward ] when
- key-s keys nth [ world walk-backward ] when
- key-a keys nth [ world walk-leftward ] when
- key-d keys nth [ world walk-rightward ] when
- key-space keys nth [ world walk-upward ] when
- key-c keys nth [ world walk-downward ] when
+ key-w keys nth [ world walk-forward ] when
+ key-s keys nth [ world walk-backward ] when
+ key-a keys nth [ world walk-leftward ] when
+ key-d keys nth [ world walk-rightward ] when
+ key-space keys nth [ world walk-upward ] when
+ key-c keys nth [ world walk-downward ] when
key-escape keys nth [ world close-window ] when ;
: wasd-mouse-input ( world -- )
M: wasd-world resize-world
[ <viewport-state> set-gpu-state* ]
[ dup generate-p-matrix >>p-matrix drop ] bi ;
-
M: grid-mesh dispose
[ [ delete-gl-buffer ] when* f ] change-buffer
drop ;
-
! See http://factorcode.org/license.txt for BSD license.
USING: gstreamer.base.ffi ;
IN: gstreamer.base
-
>>
GIR: GstBase-0.10.gir
-
! See http://factorcode.org/license.txt for BSD license.
USING: gstreamer.controller.ffi ;
IN: gstreamer.controller
-
>>
GIR: GstController-0.10.gir
-
PRIVATE>
GIR: Gst-0.10.gir
-
! See http://factorcode.org/license.txt for BSD license.
USING: gstreamer.ffi ;
IN: gstreamer
-
>>
GIR: GstNet-0.10.gir
-
! See http://factorcode.org/license.txt for BSD license.
USING: gstreamer.net.ffi ;
IN: gstreamer.net
-
: on-button-clicked ( button label-user-data -- )
nip "Hello! :)" utf8 string>alien gtk_label_set_text ;
-
-:: hello-world-win ( -- window )
+
+:: hello-world-win ( -- window )
GTK_WINDOW_TOPLEVEL gtk_window_new :> window
window
gtk_fixed_new :> frame
window frame gtk_container_add
-
+
"Say 'Hello!'" utf8 string>alien gtk_button_new_with_label :> button
button 140 30 gtk_widget_set_size_request
frame button 80 60 gtk_fixed_put
button "clicked" utf8 string>alien
[ on-button-clicked ] GtkButton:clicked label
g_signal_connect drop
-
+
window ;
:: hello-world-main ( -- )
g_signal_connect drop
window gtk_widget_show_all
-
+
gtk_main ;
MAIN: hello-world-main
-
0.0 0.0 1.0 glColor3f
1 -1 glVertex2i
glEnd
-
+
gl-drawable gdk_gl_drawable_is_double_buffered 1 =
[ gl-drawable gdk_gl_drawable_swap_buffers ]
[ glFlush ] if
gl-drawable gdk_gl_drawable_gl_end
] when ;
-
-:: opengl-win ( -- window )
+
+:: opengl-win ( -- window )
GTK_WINDOW_TOPLEVEL gtk_window_new :> window
window
[ GTK_WIN_POS_CENTER gtk_window_set_position ] tri
GDK_GL_MODE_RGBA gdk_gl_config_new_by_mode :> gl-config
-
+
window gl-config f t GDK_GL_RGBA_TYPE
gtk_widget_set_gl_capability drop
f f 0 g_signal_connect_data drop
window gtk_widget_show_all
-
+
gtk_main ;
MAIN: opengl-main
-
] [ 2drop ] recover ;
MAIN: hamurabi
-
! Hashcash implementation
! Reference materials listed below:
-!
+!
! http://hashcash.org
! http://en.wikipedia.org/wiki/Hashcash
! http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash
-!
+!
! And the reference implementation (in python):
! http://www.gnosis.cx/download/gnosis/util/hashcash.py
! Return a string with today's date in the form YYMMDD
: get-date ( -- str )
- now [ year>> 100 mod pad-00 ]
- [ month>> pad-00 ]
+ now [ year>> 100 mod pad-00 ]
+ [ month>> pad-00 ]
[ day>> pad-00 ] tri 3append ;
! Random salt is formed by ascii characters
get-date >>date
8 salt >>salt ;
-M: hashcash string>>
+M: hashcash string>>
tuple-slots [ present ] map ":" join ;
<PRIVATE
: valid-guess? ( checksum tuple -- ? )
bits>> head all-char-zero? ;
-: (mint) ( tuple counter -- tuple )
- 2dup set-suffix checksummed-bits pick
+: (mint) ( tuple counter -- tuple )
+ 2dup set-suffix checksummed-bits pick
valid-guess? [ drop ] [ 1 + (mint) ] if ;
PRIVATE>
: check-stamp ( stamp -- ? )
dup ":" split [ sha1-checksum get-bits ] dip
second string>number head all-char-zero? ;
-
CONSTANT: genres
{
- "Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk"
- "Grunge" "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies" "Other"
- "Pop" "R&B" "Rap" "Reggae" "Rock" "Techno" "Industrial"
- "Alternative" "Ska" "Death Metal" "Pranks" "Soundtrack"
- "Euro-Techno" "Ambient" "Trip-Hop" "Vocal" "Jazz+Funk"
- "Fusion" "Trance" "Classical" "Instrumental" "Acid" "House"
- "Game" "Sound Clip" "Gospel" "Noise" "AlternRock" "Bass"
- "Soul" "Punk" "Space" "Meditative" "Instrumental Pop"
- "Instrumental Rock" "Ethnic" "Gothic" "Darkwave"
- "Techno-Industrial" "Electronic" "Pop-Folk" "Eurodance"
- "Dream" "Southern Rock" "Comedy" "Cult" "Gangsta" "Top 40"
- "Christian Rap" "Pop/Funk" "Jungle" "Native American"
- "Cabaret" "New Wave" "Psychedelic" "Rave" "Showtunes"
- "Trailer" "Lo-Fi" "Tribal" "Acid Punk" "Acid Jazz" "Polka"
- "Retro" "Musical" "Rock & Roll" "Hard Rock" "Folk"
- "Folk-Rock" "National Folk" "Swing" "Fast Fusion" "Bebop"
- "Latin" "Revival" "Celtic" "Bluegrass" "Avantgarde"
- "Gothic Rock" "Progressive Rock" "Psychedelic Rock"
- "Symphonic Rock" "Slow Rock" "Big Band" "Chorus"
- "Easy Listening" "Acoustic" "Humour" "Speech" "Chanson"
- "Opera" "Chamber Music" "Sonata" "Symphony" "Booty Bass"
- "Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
- "Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
- "Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
+ "Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk"
+ "Grunge" "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies" "Other"
+ "Pop" "R&B" "Rap" "Reggae" "Rock" "Techno" "Industrial"
+ "Alternative" "Ska" "Death Metal" "Pranks" "Soundtrack"
+ "Euro-Techno" "Ambient" "Trip-Hop" "Vocal" "Jazz+Funk"
+ "Fusion" "Trance" "Classical" "Instrumental" "Acid" "House"
+ "Game" "Sound Clip" "Gospel" "Noise" "AlternRock" "Bass"
+ "Soul" "Punk" "Space" "Meditative" "Instrumental Pop"
+ "Instrumental Rock" "Ethnic" "Gothic" "Darkwave"
+ "Techno-Industrial" "Electronic" "Pop-Folk" "Eurodance"
+ "Dream" "Southern Rock" "Comedy" "Cult" "Gangsta" "Top 40"
+ "Christian Rap" "Pop/Funk" "Jungle" "Native American"
+ "Cabaret" "New Wave" "Psychedelic" "Rave" "Showtunes"
+ "Trailer" "Lo-Fi" "Tribal" "Acid Punk" "Acid Jazz" "Polka"
+ "Retro" "Musical" "Rock & Roll" "Hard Rock" "Folk"
+ "Folk-Rock" "National Folk" "Swing" "Fast Fusion" "Bebop"
+ "Latin" "Revival" "Celtic" "Bluegrass" "Avantgarde"
+ "Gothic Rock" "Progressive Rock" "Psychedelic Rock"
+ "Symphonic Rock" "Slow Rock" "Big Band" "Chorus"
+ "Easy Listening" "Acoustic" "Humour" "Speech" "Chanson"
+ "Opera" "Chamber Music" "Sonata" "Symphony" "Booty Bass"
+ "Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
+ "Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
+ "Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
"Euro-House" "Dance Hall" "Goa" "Drum & Bass" "Club-House"
"Hardcore" "Terror" "Indie" "BritPop" "Negerpunk"
"Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
: read-frames ( seq -- assoc )
[ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ;
-
+
: read-v2-header ( seq -- header )
[ <header> ] dip
{
10 cut-slice
[ read-v2-header >>header ]
[ read-frames frames>assoc merge-frames ] bi* ;
-
+
: extract-v1-tags ( id3 seq -- id3 )
{
[ 30 head-slice decode-text filter-text-data >>title ]
image-placement image>> :> image
image-placement loc>> first2 :> ( x y )
image dim>> first2 :> ( w h )
-
+
x aw /f :> left-u
y ah /f :> top-v
x w + aw /f :> right-u
: read-comment-extension ( -- comment-extension )
\ comment-extension new
read-sub-blocks >>comment-data ;
-
+
: read-application-extension ( -- read-application-extension )
\ application-extension new
1 read le> >>block-size
M: image pprint*
<image-section> add-section ;
-
[ GL_TEXTURE_2D ] dip glBindTexture ;
: bind-2d-texture ( single-texture -- )
texture>> (bind-2d-texture) ;
-: (update-texture) ( image single-texture -- )
+: (update-texture) ( image single-texture -- )
bind-2d-texture tex-sub-image ;
! works only for single-texture
: update-texture ( image-gadget -- )
] if-empty ; inline
: grid-dim ( grid -- dim )
[ [ dim>> first ] grid-width ] [ flip [ dim>> second ] grid-width ] bi 2array ;
-M: multi-texture texture-size
+M: multi-texture texture-size
grid>> grid-dim ;
: same-size? ( image-gadget -- ? )
[ texture>> texture-size ] [ image>> dim>> ] bi = ;
(texture-format)
] [ f ] if*
] [ f ] if* ;
-: same-internal-format? ( image-gadget -- ? )
+: same-internal-format? ( image-gadget -- ? )
[ texture-format ] [ image>> image-format 2drop ] bi = ;
! TODO: also keep multitextures if possible ?
M: pathname set-image string>> load-image >>image ;
M: model set-image [ value>> >>image drop ] [ >>model ] 2bi ;
: new-image-gadget ( class -- gadget ) new ;
-: new-image-gadget* ( object class -- gadget )
+: new-image-gadget* ( object class -- gadget )
new-image-gadget swap set-image ;
: <image-gadget> ( object -- gadget )
\ image-gadget new-image-gadget* ;
: ini>string ( assoc -- str )
[ write-ini ] with-string-writer ;
-
-! (c)2010 Joe Groff bsd license\r
-USING: byte-arrays byte-arrays.hex io.encodings.8-bit.koi8-r\r
-io.encodings.8-bit.latin1 io.encodings.binary\r
-io.encodings.detect io.encodings.utf16 io.encodings.utf32\r
-io.encodings.utf8 namespaces tools.test ;\r
-IN: io.encodings.detect.tests\r
-\r
-! UTF encodings with BOMs\r
-[ utf16be ] [ HEX{ FEFF 0031 0032 0033 } detect-byte-array ] unit-test\r
-[ utf16le ] [ HEX{ FFFE 3100 3200 3300 } detect-byte-array ] unit-test\r
-[ utf32be ] [ HEX{ 0000FEFF 00000031 00000032 00000033 } detect-byte-array ] unit-test\r
-[ utf32le ] [ HEX{ FFFE0000 31000000 32000000 33000000 } detect-byte-array ] unit-test\r
-[ utf8 ] [ HEX{ EF BB BF 31 32 33 } detect-byte-array ] unit-test\r
-\r
-! XML prolog\r
-[ utf8 ]\r
-[ """<?xml version="1.0"?>""" >byte-array detect-byte-array ]\r
-unit-test\r
-\r
-[ utf8 ]\r
-[ """<?xml version="1.0" encoding="UTF-8"?>""" >byte-array detect-byte-array ]\r
-unit-test\r
-\r
-[ latin1 ]\r
-[ """<?xml version='1.0' encoding='ISO-8859-1'?>""" >byte-array detect-byte-array ]\r
-unit-test\r
-\r
-[ latin1 ]\r
-[ """<?xml version='1.0' encoding="ISO-8859-1" """ >byte-array detect-byte-array ]\r
-unit-test\r
-\r
-! Default to utf8 if decoding succeeds and there are no nulls\r
-[ utf8 ] [ HEX{ } detect-byte-array ] unit-test\r
-[ utf8 ] [ HEX{ 31 32 33 } detect-byte-array ] unit-test\r
-[ utf8 ] [ HEX{ 31 32 C2 A0 33 } detect-byte-array ] unit-test\r
-[ latin1 ] [ HEX{ 31 32 A0 33 } detect-byte-array ] unit-test\r
-[ koi8-r ] [\r
- koi8-r default-8bit-encoding [\r
- HEX{ 31 32 A0 33 } detect-byte-array\r
- ] with-variable\r
-] unit-test\r
-\r
-[ binary ] [ HEX{ 31 32 33 C2 A0 00 } detect-byte-array ] unit-test\r
-[ binary ] [ HEX{ 31 32 33 C2 A0 00 30 } detect-byte-array ] unit-test\r
-\r
+! (c)2010 Joe Groff bsd license
+USING: byte-arrays byte-arrays.hex io.encodings.8-bit.koi8-r
+io.encodings.8-bit.latin1 io.encodings.binary
+io.encodings.detect io.encodings.utf16 io.encodings.utf32
+io.encodings.utf8 namespaces tools.test ;
+IN: io.encodings.detect.tests
+
+! UTF encodings with BOMs
+[ utf16be ] [ HEX{ FEFF 0031 0032 0033 } detect-byte-array ] unit-test
+[ utf16le ] [ HEX{ FFFE 3100 3200 3300 } detect-byte-array ] unit-test
+[ utf32be ] [ HEX{ 0000FEFF 00000031 00000032 00000033 } detect-byte-array ] unit-test
+[ utf32le ] [ HEX{ FFFE0000 31000000 32000000 33000000 } detect-byte-array ] unit-test
+[ utf8 ] [ HEX{ EF BB BF 31 32 33 } detect-byte-array ] unit-test
+
+! XML prolog
+[ utf8 ]
+[ """<?xml version="1.0"?>""" >byte-array detect-byte-array ]
+unit-test
+
+[ utf8 ]
+[ """<?xml version="1.0" encoding="UTF-8"?>""" >byte-array detect-byte-array ]
+unit-test
+
+[ latin1 ]
+[ """<?xml version='1.0' encoding='ISO-8859-1'?>""" >byte-array detect-byte-array ]
+unit-test
+
+[ latin1 ]
+[ """<?xml version='1.0' encoding="ISO-8859-1" """ >byte-array detect-byte-array ]
+unit-test
+
+! Default to utf8 if decoding succeeds and there are no nulls
+[ utf8 ] [ HEX{ } detect-byte-array ] unit-test
+[ utf8 ] [ HEX{ 31 32 33 } detect-byte-array ] unit-test
+[ utf8 ] [ HEX{ 31 32 C2 A0 33 } detect-byte-array ] unit-test
+[ latin1 ] [ HEX{ 31 32 A0 33 } detect-byte-array ] unit-test
+[ koi8-r ] [
+ koi8-r default-8bit-encoding [
+ HEX{ 31 32 A0 33 } detect-byte-array
+ ] with-variable
+] unit-test
+
+[ binary ] [ HEX{ 31 32 33 C2 A0 00 } detect-byte-array ] unit-test
+[ binary ] [ HEX{ 31 32 33 C2 A0 00 30 } detect-byte-array ] unit-test
+
-! (c)2010 Joe Groff bsd license\r
-USING: accessors byte-arrays byte-arrays.hex combinators\r
-continuations fry io io.encodings io.encodings.8-bit.latin1\r
-io.encodings.ascii io.encodings.binary io.encodings.iana\r
-io.encodings.string io.encodings.utf16 io.encodings.utf32\r
-io.encodings.utf8 io.files io.streams.string kernel literals\r
-math namespaces sequences strings ;\r
-IN: io.encodings.detect\r
-\r
-SYMBOL: default-8bit-encoding\r
-default-8bit-encoding [ latin1 ] initialize\r
-\r
-<PRIVATE\r
-\r
-: prolog-tag ( bytes -- string )\r
- CHAR: > over index [ 1 + head-slice ] when* >string ;\r
-\r
-: prolog-encoding ( string -- iana-encoding )\r
- '[\r
- _ "encoding=" over start\r
- 10 + swap [ [ 1 - ] dip nth ] [ index-from ] [ swapd subseq ] 2tri\r
- ] [ drop "UTF-8" ] recover ;\r
-\r
-: detect-xml-prolog ( bytes -- encoding )\r
- prolog-tag prolog-encoding name>encoding [ ascii ] unless* ;\r
-\r
-: valid-utf8? ( bytes -- ? )\r
- utf8 decode 1 head-slice* replacement-char swap member? not ;\r
-\r
-PRIVATE>\r
-\r
-: detect-byte-array ( bytes -- encoding )\r
- {\r
- { [ dup HEX{ 0000FEFF } head? ] [ drop utf32be ] }\r
- { [ dup HEX{ FFFE0000 } head? ] [ drop utf32le ] }\r
- { [ dup HEX{ FEFF } head? ] [ drop utf16be ] }\r
- { [ dup HEX{ FFFE } head? ] [ drop utf16le ] }\r
- { [ dup HEX{ EF BB BF } head? ] [ drop utf8 ] }\r
- { [ dup $[ "<?xml" >byte-array ] head? ] [ detect-xml-prolog ] }\r
- { [ 0 over member? ] [ drop binary ] }\r
- { [ dup empty? ] [ drop utf8 ] }\r
- { [ dup valid-utf8? ] [ drop utf8 ] }\r
- [ drop default-8bit-encoding get ]\r
- } cond ;\r
-\r
-: detect-stream ( stream -- sample encoding )\r
- 256 swap stream-read dup detect-byte-array ;\r
-\r
-: detect-file ( file -- encoding )\r
- binary [ input-stream get detect-stream nip ] with-file-reader ;\r
+! (c)2010 Joe Groff bsd license
+USING: accessors byte-arrays byte-arrays.hex combinators
+continuations fry io io.encodings io.encodings.8-bit.latin1
+io.encodings.ascii io.encodings.binary io.encodings.iana
+io.encodings.string io.encodings.utf16 io.encodings.utf32
+io.encodings.utf8 io.files io.streams.string kernel literals
+math namespaces sequences strings ;
+IN: io.encodings.detect
+
+SYMBOL: default-8bit-encoding
+default-8bit-encoding [ latin1 ] initialize
+
+<PRIVATE
+
+: prolog-tag ( bytes -- string )
+ CHAR: > over index [ 1 + head-slice ] when* >string ;
+
+: prolog-encoding ( string -- iana-encoding )
+ '[
+ _ "encoding=" over start
+ 10 + swap [ [ 1 - ] dip nth ] [ index-from ] [ swapd subseq ] 2tri
+ ] [ drop "UTF-8" ] recover ;
+
+: detect-xml-prolog ( bytes -- encoding )
+ prolog-tag prolog-encoding name>encoding [ ascii ] unless* ;
+
+: valid-utf8? ( bytes -- ? )
+ utf8 decode 1 head-slice* replacement-char swap member? not ;
+
+PRIVATE>
+
+: detect-byte-array ( bytes -- encoding )
+ {
+ { [ dup HEX{ 0000FEFF } head? ] [ drop utf32be ] }
+ { [ dup HEX{ FFFE0000 } head? ] [ drop utf32le ] }
+ { [ dup HEX{ FEFF } head? ] [ drop utf16be ] }
+ { [ dup HEX{ FFFE } head? ] [ drop utf16le ] }
+ { [ dup HEX{ EF BB BF } head? ] [ drop utf8 ] }
+ { [ dup $[ "<?xml" >byte-array ] head? ] [ detect-xml-prolog ] }
+ { [ 0 over member? ] [ drop binary ] }
+ { [ dup empty? ] [ drop utf8 ] }
+ { [ dup valid-utf8? ] [ drop utf8 ] }
+ [ drop default-8bit-encoding get ]
+ } cond ;
+
+: detect-stream ( stream -- sample encoding )
+ 256 swap stream-read dup detect-byte-array ;
+
+: detect-file ( file -- encoding )
+ binary [ input-stream get detect-stream nip ] with-file-reader ;
! Directory inheritance
SYMBOLS: +file-inherit+ +directory-inherit+ +limit-inherit+ only-inherit+ ;
-
-
TYPEDEF: char[37] uuid_string_t
FUNCTION: int mbr_uuid_to_string ( uuid_t uu, char* string ) ;
-
M: macosx send-to-trash ( path -- )
<fs-ref> f kFSFileOperationDefaultOptions
FSMoveObjectToTrashSync check-err ;
-
-
{ [ os macosx? ] [ "io.files.trash.macosx" ] }
{ [ os unix? ] [ "io.files.trash.unix" ] }
} cond require
-
now "%Y-%m-%dT%H:%M:%S" strftime write nl
] with-file-writer
] bi move-file ;
-
-
SHFileOperationW [ throw ] unless-zero
] with-destructors ;
-
-
-
{ 3500000 0o0010016 }
{ 4000000 0o0010017 }
} ?at [ invalid-baud ] unless ;
-
summary system vocabs ;
IN: io.serial
-TUPLE: serial-port < disposable stream path baud
+TUPLE: serial-port < disposable stream path baud
termios iflag oflag cflag lflag ;
ERROR: invalid-baud baud ;
: jamshred-roll ( jamshred n -- )
[ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
-
+
: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
: mouse-scroll-y ( jamshred y -- )
hand-loc get [
over last-hand-loc>> [
v- (handle-mouse-motion)
- ] [ 2drop ] if*
+ ] [ 2drop ] if*
] 2keep >>last-hand-loc drop ;
: handle-mouse-scroll ( jamshred-gadget -- )
: play-in-tunnel ( player segments -- )
>>tunnel to-tunnel-start ;
-
+
: update-time ( player -- seconds-passed )
nano-count swap [ last-move>> - 1,000,000,000 / ] [ last-move<< ] 2bi ;
[ + 0 max-speed clamp ] change-speed drop ;
: multiply-player-speed ( n player -- )
- [ * 0 max-speed clamp ] change-speed drop ;
+ [ * 0 max-speed clamp ] change-speed drop ;
: distance-to-move ( seconds-passed player -- distance )
speed>> * ;
: bounce-off-wall ( oint segment -- )
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
-
" a2 = area(s2)"
"a = φ(a1,a2)"
}
-
+
}
}
{ $slide "Factor compiler overview"
-CALLBACK: void udev_set_log_fn_callback (
- udev* udev
- int priority,
- c-string file,
- int line,
- c-string fn,
+CALLBACK: void udev_set_log_fn_callback (
+ udev* udev
+ int priority,
+ c-string file,
+ int line,
+ c-string fn,
c-string format ) ;
! va_list args ) ;
FUNCTION: void udev_set_log_fn (
- udev* udev,
+ udev* udev,
udev_set_log_fn_callback log_fn ) ;
FUNCTION: void udev_set_log_priority (
- udev* udev,
+ udev* udev,
int priority ) ;
FUNCTION: void udev_set_userdata (
- udev* udev,
+ udev* udev,
void* userdata ) ;
FUNCTION: udev_list_entry* udev_list_entry_get_by_name (
- udev_list_entry* list_entry,
+ udev_list_entry* list_entry,
c-string name ) ;
FUNCTION: udev_device* udev_device_new_from_syspath (
- udev* udev,
+ udev* udev,
c-string syspath ) ;
FUNCTION: udev_device* udev_device_new_from_devnum (
- udev* udev,
- char type,
+ udev* udev,
+ char type,
dev_t devnum ) ;
FUNCTION: udev_device* udev_device_new_from_subsystem_sysname (
- udev* udev,
- c-string subsystem,
+ udev* udev,
+ c-string subsystem,
c-string sysname ) ;
FUNCTION: udev_device* udev_device_get_parent_with_subsystem_devtype (
- udev_device* udev_device,
- c-string subsystem,
+ udev_device* udev_device,
+ c-string subsystem,
c-string devtype ) ;
FUNCTION: c-string udev_device_get_property_value (
- udev_device* udev_device,
+ udev_device* udev_device,
c-string key ) ;
FUNCTION: c-string udev_device_get_sysattr_value (
- udev_device* udev_device,
+ udev_device* udev_device,
c-string sysattr ) ;
FUNCTION: udev_monitor* udev_monitor_new_from_netlink (
- udev* udev,
+ udev* udev,
c-string name ) ;
FUNCTION: udev_monitor* udev_monitor_new_from_socket (
- udev* udev,
+ udev* udev,
c-string socket_path ) ;
FUNCTION: int udev_monitor_set_receive_buffer_size (
- udev_monitor* udev_monitor,
+ udev_monitor* udev_monitor,
int size ) ;
FUNCTION: int udev_monitor_filter_add_match_subsystem_devtype (
- udev_monitor* udev_monitor,
- c-string subsystem,
+ udev_monitor* udev_monitor,
+ c-string subsystem,
c-string devtype ) ;
FUNCTION: int udev_enumerate_add_match_subsystem (
- udev_enumerate* udev_enumerate,
+ udev_enumerate* udev_enumerate,
c-string subsystem ) ;
FUNCTION: int udev_enumerate_add_nomatch_subsystem (
- udev_enumerate* udev_enumerate,
+ udev_enumerate* udev_enumerate,
c-string subsystem ) ;
FUNCTION: int udev_enumerate_add_match_sysattr (
- udev_enumerate* udev_enumerate,
- c-string sysattr,
+ udev_enumerate* udev_enumerate,
+ c-string sysattr,
c-string value ) ;
FUNCTION: int udev_enumerate_add_nomatch_sysattr (
- udev_enumerate* udev_enumerate,
- c-string sysattr,
+ udev_enumerate* udev_enumerate,
+ c-string sysattr,
c-string value ) ;
FUNCTION: int udev_enumerate_add_match_property (
- udev_enumerate* udev_enumerate,
- c-string property,
+ udev_enumerate* udev_enumerate,
+ c-string property,
c-string value ) ;
FUNCTION: int udev_enumerate_add_match_sysname (
- udev_enumerate* udev_enumerate,
+ udev_enumerate* udev_enumerate,
c-string sysname ) ;
FUNCTION: int udev_enumerate_add_syspath (
- udev_enumerate* udev_enumerate,
+ udev_enumerate* udev_enumerate,
c-string syspath ) ;
FUNCTION: int udev_queue_get_seqnum_is_finished (
- udev_queue* udev_queue,
+ udev_queue* udev_queue,
ulonglong seqnum ) ;
FUNCTION: int udev_queue_get_seqnum_sequence_is_finished (
- udev_queue* udev_queue,
- ulonglong start,
+ udev_queue* udev_queue,
+ ulonglong start,
ulonglong end ) ;
FUNCTION: udev_list_entry* udev_queue_get_failed_list_entry (
udev_queue* udev_queue ) ;
-
-
-
buffer >>buffer
user_data >>user_data
callback >>callback
-
+
buffer [
libusb_control_setup memory>struct wLength>> LIBUSB_CONTROL_SETUP_SIZE +
] [ 0 ] if* >>length drop ; inline
[ num_iso_packets>> ] bi
libusb_iso_packet_descriptor <c-direct-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 ]
+ [ iso_packet_desc>> >c-ptr ]
[ num_iso_packets>> ] bi
libusb_iso_packet_descriptor <c-direct-array> 0
[ length>> + ] reduce
[ f ]
[
0 transfer
- [ iso_packet_desc>> >c-ptr ]
+ [ iso_packet_desc>> >c-ptr ]
[ num_iso_packets>> ] bi
libusb_iso_packet_descriptor <c-direct-array> nth
length>> packet *
FUNCTION: int LLVMParseBitcode
( LLVMMemoryBufferRef MemBuf, LLVMModuleRef* OutModule, c-string* OutMessage ) ;
-
+
FUNCTION: int LLVMGetBitcodeModuleProvider
( LLVMMemoryBufferRef MemBuf, LLVMModuleProviderRef* OutMP, c-string* OutMessage ) ;
ref types get push
ref quot call( LLVMTypeRef -- type )
types get pop drop
- ] if* ;
+ ] if* ;
GENERIC: (>tref)* ( type -- LLVMTypeRef )
M: enclosing (>tref) [ (>tref)* ] push-type ;
;EBNF
-SYNTAX: TYPE: ";" parse-multiline-string parse-type suffix! ;
+SYNTAX: TYPE: ";" parse-multiline-string parse-type suffix! ;
-USING: kernel io io.files io.pathnames io.monitors io.encodings.utf8 ;\r
-IN: log-viewer\r
-\r
-: read-lines ( stream -- )\r
- dup stream-readln dup\r
- [ print read-lines ] [ 2drop flush ] if ;\r
-\r
-: tail-file-loop ( stream monitor -- )\r
- dup next-change drop over read-lines tail-file-loop ;\r
-\r
-: tail-file ( file -- )\r
- dup utf8 <file-reader> dup read-lines\r
- swap parent-directory f <monitor>\r
- tail-file-loop ;\r
+USING: kernel io io.files io.pathnames io.monitors io.encodings.utf8 ;
+IN: log-viewer
+
+: read-lines ( stream -- )
+ dup stream-readln dup
+ [ print read-lines ] [ 2drop flush ] if ;
+
+: tail-file-loop ( stream monitor -- )
+ dup next-change drop over read-lines tail-file-loop ;
+
+: tail-file ( file -- )
+ dup utf8 <file-reader> dup read-lines
+ swap parent-directory f <monitor>
+ tail-file-loop ;
: luaL_getn ( L i -- int ) lua_objlen ; inline
: luaL_setn ( L i j -- ) 3drop ; inline
-
+
: LUA_ERRFILE ( -- x ) LUA_ERRERR 1 + ;
STRUCT: luaL_Reg
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.syntax help.markup cpu.8080.emulator ;\r
-IN: lunar-rescue \r
-\r
-HELP: run-lunar \r
-{ $description \r
-"Run the Lunar Rescue emulator in a new window." $nl\r
-{ $link rom-root } " must be set to the directory containing the "\r
-"location of the Lunar Rescue ROM files. See " \r
-{ $link { "lunar-rescue" "lunar-rescue" } } " for details."\r
-} ;\r
-\r
-ARTICLE: { "lunar-rescue" "lunar-rescue" } "Lunar Rescue Emulator"\r
-"Provides an emulation of the original 8080 Arcade Game 'Lunar Rescue'." $nl\r
-"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/lrescue" } "." $nl\r
-"To play the game you need the ROM files for the arcade game. They should "\r
-"be placed in a directory called " { $snippet "lrescue" } " in the location specified by "\r
-"the variable " { $link rom-root } ". The specific files needed are:"\r
-{ $list\r
- "lrescue/lrescue.1"\r
- "lrescue/lrescue.2"\r
- "lrescue/lrescue.3"\r
- "lrescue/lrescue.4"\r
- "lrescue/lrescue.5"\r
- "lrescue/lrescue.6"\r
-}\r
-"These are the same ROM files as used by MAME. To run the game use the " \r
-{ $link run-lunar } " word." $nl\r
-"Keys:" \r
-{ $table\r
- { "Backspace" "Insert Coin" }\r
- { "1" "1 Player" }\r
- { "2" "2 Player" }\r
- { "Left" "Move Left" }\r
- { "Right" "Move Right" }\r
- { "Up" "Fire or apply thrusters" }\r
-}\r
-"If you save the Factor image while a game is running, when you restart "\r
-"the image the game continues where it left off." ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup cpu.8080.emulator ;
+IN: lunar-rescue
+
+HELP: run-lunar
+{ $description
+"Run the Lunar Rescue emulator in a new window." $nl
+{ $link rom-root } " must be set to the directory containing the "
+"location of the Lunar Rescue ROM files. See "
+{ $link { "lunar-rescue" "lunar-rescue" } } " for details."
+} ;
+
+ARTICLE: { "lunar-rescue" "lunar-rescue" } "Lunar Rescue Emulator"
+"Provides an emulation of the original 8080 Arcade Game 'Lunar Rescue'." $nl
+"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/lrescue" } "." $nl
+"To play the game you need the ROM files for the arcade game. They should "
+"be placed in a directory called " { $snippet "lrescue" } " in the location specified by "
+"the variable " { $link rom-root } ". The specific files needed are:"
+{ $list
+ "lrescue/lrescue.1"
+ "lrescue/lrescue.2"
+ "lrescue/lrescue.3"
+ "lrescue/lrescue.4"
+ "lrescue/lrescue.5"
+ "lrescue/lrescue.6"
+}
+"These are the same ROM files as used by MAME. To run the game use the "
+{ $link run-lunar } " word." $nl
+"Keys:"
+{ $table
+ { "Backspace" "Insert Coin" }
+ { "1" "1 Player" }
+ { "2" "2 Player" }
+ { "Left" "Move Left" }
+ { "Right" "Move Right" }
+ { "Up" "Fire or apply thrusters" }
+}
+"If you save the Factor image while a game is running, when you restart "
+"the image the game continues where it left off." ;
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-! Lunar Rescue: http://www.mameworld.net/maws/romset/lrescue\r
-!\r
-USING: kernel space-invaders ui ;\r
-IN: lunar-rescue\r
-\r
-TUPLE: lunar-rescue < space-invaders ;\r
-\r
-: <lunar-rescue> ( -- cpu )\r
- lunar-rescue new cpu-init ;\r
-\r
-CONSTANT: rom-info {\r
- { 0x0000 "lrescue/lrescue.1" }\r
- { 0x0800 "lrescue/lrescue.2" }\r
- { 0x1000 "lrescue/lrescue.3" }\r
- { 0x1800 "lrescue/lrescue.4" }\r
- { 0x4000 "lrescue/lrescue.5" }\r
- { 0x4800 "lrescue/lrescue.6" }\r
-}\r
-\r
-: run-lunar ( -- )\r
- [\r
- "Lunar Rescue" <lunar-rescue> rom-info run-rom\r
- ] with-ui ;\r
-\r
-MAIN: run-lunar\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Lunar Rescue: http://www.mameworld.net/maws/romset/lrescue
+!
+USING: kernel space-invaders ui ;
+IN: lunar-rescue
+
+TUPLE: lunar-rescue < space-invaders ;
+
+: <lunar-rescue> ( -- cpu )
+ lunar-rescue new cpu-init ;
+
+CONSTANT: rom-info {
+ { 0x0000 "lrescue/lrescue.1" }
+ { 0x0800 "lrescue/lrescue.2" }
+ { 0x1000 "lrescue/lrescue.3" }
+ { 0x1800 "lrescue/lrescue.4" }
+ { 0x4000 "lrescue/lrescue.5" }
+ { 0x4800 "lrescue/lrescue.6" }
+}
+
+: run-lunar ( -- )
+ [
+ "Lunar Rescue" <lunar-rescue> rom-info run-rom
+ ] with-ui ;
+
+MAIN: run-lunar
GENERIC: fit-y ( y transformer -- )
GENERIC: transform-y ( y transformer -- y' )
GENERIC: inverse-transform-y ( y transformer -- y' )
-
{ initprot vm_prot_t }
{ nsects uint }
{ flags uint } ;
-
+
CONSTANT: SG_HIGHVM 0x1
CONSTANT: SG_FVMLIB 0x2
CONSTANT: SG_NORELOC 0x4
[ nlist_64 <c-direct-array> ]
[ nlist <c-direct-array> ] if ]
[ stroff>> swap >c-ptr <displaced-alien> ] 2tri ;
-
+
: symbol-name ( symbol string-table -- name )
[ n_strx>> ] dip <displaced-alien> ascii alien>string ;
: center-rotation ( transform center -- transform )
[ [ x>> ] [ y>> ] [ ] tri ] dip [ vneg a.v ] [ v+ ] bi <affine-transform> ;
-
+
: flatten-transform ( transform -- array )
[ x>> ] [ y>> ] [ origin>> ] tri 3append ;
[ pi 2 * * sqrt ]
[ [ e / ] keep ^ ]
[ 12 * recip 1 + ] tri * * ;
-
: approximate ( x epsilon -- y )
[ check-float ] bi@ [ - ] [ + ] 2bi simplest ;
-
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ;
SUBROUTINE: DROTM
( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ;
-
+
! LEVEL 2 BLAS (MATRIX-VECTOR)
SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
! XXX should do a dense clone
M: blas-matrix-base clone
- [
+ [
[ {
[ underlying>> ]
[ ld>> ]
[ 1.0 ] 2dip n*V(*)Vconj ; inline
: n*M.M ( alpha A B -- alpha*A.B )
- 2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
+ 2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
[ 1.0 ] dip n*M.M+n*M! ;
: M. ( A B -- A.B )
copy-data copy-length copy-inc )
v [ length>> ] [ data-and-inc ] bi
v length>> element-size * <byte-array>
- 1
+ 1
over v length>> 1 ;
: (prepare-swap)
: min-by ( obj1 obj2 quot: ( obj -- n ) -- obj1/obj2 )
[ bi@ dupd min = ] curry most ; inline
-
-
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.derivatives.syntax
+USING: kernel math math.functions math.derivatives.syntax
math.order math.parser summary accessors make combinators ;
IN: math.derivatives
ERROR: undefined-derivative point word ;
M: undefined-derivative summary
- [ dup "Derivative of " % word>> name>> %
+ [ dup "Derivative of " % word>> name>> %
" is undefined at " % point>> # "." % ]
"" make ;
DERIVATIVE: / [ nip / ] [ sq / neg * ]
! Conditional checks if the epsilon-part of the exponent is
! 0 to avoid getting float answers for integer powers.
-DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ]
+DERIVATIVE: ^ [ [ 1 - ^ ] keep * * ]
[ [ dup zero? ] 2dip [ 3drop 0 ] [ [ ^ ] keep log * * ] if ]
-DERIVATIVE: abs
- [ 0 <=>
- {
- { +lt+ [ neg ] }
- { +eq+ [ 0 \ abs undefined-derivative ] }
- { +gt+ [ ] }
+DERIVATIVE: abs
+ [ 0 <=>
+ {
+ { +lt+ [ neg ] }
+ { +eq+ [ 0 \ abs undefined-derivative ] }
+ { +gt+ [ ] }
} case
]
! Copyright (C) 2009 Jason W. Merrill.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel parser words effects accessors sequences
+USING: kernel parser words effects accessors sequences
math.ranges ;
-
+
IN: math.derivatives.syntax
-SYNTAX: DERIVATIVE: scan-object dup stack-effect in>> length [1,b]
- [ drop scan-object ] map
- "derivative" set-word-prop ;
\ No newline at end of file
+SYNTAX: DERIVATIVE: scan-object dup stack-effect in>> length [1,b]
+ [ drop scan-object ] map
+ "derivative" set-word-prop ;
tri
'[ [ @ _ @ ] sum-outputs ] ;
-: set-dual-help ( word dword -- )
+: set-dual-help ( word dword -- )
[ swap
- [ stack-effect [ in>> ] [ out>> ] bi append
+ [ stack-effect [ in>> ] [ out>> ] bi append
[ dual ] { } map>assoc { $values } prepend
]
- [ [ { $description } % "Version of " ,
- { $link } swap suffix ,
- " extended to work on dual numbers." , ]
+ [ [ { $description } % "Version of " ,
+ { $link } swap suffix ,
+ " extended to work on dual numbers." , ]
{ } make
]
bi* 2array
[ (double-mantissa-bits) 52 2^ / ]
[ (double-exponent-bits) ] tri
[ 1 ] [ [ 1 + ] dip ] if-zero 1023 - 2 swap ^ * * ;
-
: map-columns ( ... a quot: ( ... col -- ... newcol ) -- ... c )
'[ columns _ 4 napply ] make-matrix4 ; inline
-
+
PRIVATE>
TYPED: m4+ ( a: matrix4 b: matrix4 -- c: matrix4 ) [ v+ ] 2map-columns ;
b3 first a1 n*v :> c3a
b4 first a1 n*v :> c4a
- b1 second a2 n*v c1a v+ :> c1b
+ b1 second a2 n*v c1a v+ :> c1b
b2 second a2 n*v c2a v+ :> c2b
b3 second a2 n*v c3a v+ :> c3b
b4 second a2 n*v c4a v+ :> c4b
- b1 third a3 n*v c1b v+ :> c1c
+ b1 third a3 n*v c1b v+ :> c1c
b2 third a3 n*v c2b v+ :> c2c
b3 third a3 n*v c3b v+ :> c3c
b4 third a3 n*v c4b v+ :> c4c
TYPED:: m4.v ( m: matrix4 v: float-4 -- v': float-4 )
m columns :> ( m1 m2 m3 m4 )
-
+
v first m1 n*v
v second m2 n*v v+
v third m3 n*v v+
TYPED: translation-matrix4 ( offset: float-4 -- matrix: matrix4 )
[
linear>homogeneous
- [
+ [
float-4{ 1.0 0.0 0.0 0.0 }
float-4{ 0.0 1.0 0.0 0.0 }
float-4{ 0.0 0.0 1.0 0.0 }
triangle-a triangle-b v- :> triangle-hi
diagonal triangle-hi triangle-lo (rotation-matrix4) ;
-
+
TYPED:: frustum-matrix4 ( xy: float-4 near: float far: float -- matrix: matrix4 )
[
near near near far + 2 near far * * float-4-boa ! num
float-4{ t t f f } xy near far - float-4-with v? ! denom
v/ :> fov
-
+
float-4{ 0.0 -1.0 0.0 0.0 } :> negone
fov vmerge-diagonal
{ 1 4 } { 1 } surround ;
: integrate-simpson ( from to quot -- x )
- [ setup-simpson-range dup ] dip
+ [ setup-simpson-range dup ] dip
map dup generate-simpson-weights
v. swap [ third ] keep first - 6 / * ; inline
: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
: midpoint ( point point -- point ) v+ 2 v/n ;
-: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
\ No newline at end of file
+: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
:: hermite-polynomial ( p0 m0 p1 m1 -- poly )
p0
- m0
+ m0
-3 p0 * -2 m0 * + 3 p1 * + m1 neg +
2 p0 * m0 + -2 p1 * + m1 +
4array ;
] each-index
] each-index
acc ;
-
+
:: <cubic-hermite-curve> ( p0 m0 p1 m1 -- polynomials )
p0 length iota [
{
0 0 1 test3
0 0 -1 test3
test4 ;
-
-
[ 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
:: <spline-gadget> ( polynomials dim steps -- gadget )
spline-gadget new
dim >>spline-dim
- polynomials >>polynomials
+ polynomials >>polynomials
steps >>steps ;
: spline. ( curve dim steps -- )
- <spline-gadget> gadget. ;
+ <spline-gadget> gadget. ;
: rev-haar ( seq -- seq' )
dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ;
-
: h+ ( a b -- c )
2dup [ (homogeneous-w) ] bi@ over =
- [ [ [ (homogeneous-xyz) ] bi@ v+ ] dip suffix ] [
+ [ [ [ (homogeneous-xyz) ] bi@ v+ ] dip suffix ] [
drop
[ [ (homogeneous-xyz) ] [ (homogeneous-w) ] bi* v*n ]
[ [ (homogeneous-w) ] [ (homogeneous-xyz) ] bi* n*v v+ ]
[ [ (homogeneous-w) ] [ (homogeneous-w) ] bi* * suffix ] 2tri
] if ;
-: n*h ( n h -- nh )
+: n*h ( n h -- nh )
[ (homogeneous-xyz) n*v ] [ (homogeneous-w) suffix ] bi ;
: h*n ( h n -- nh )
: h>v ( h -- v )
[ (homogeneous-xyz) ] [ (homogeneous-w) ] bi v/n ;
-
[ swap 2array ] produce 2nip ;
: m/quit ( -- ) QUIT <request> submit drop ;
-
-
: pile-align ( pile align -- pile )
[ align ] curry change-offset ;
-
SYNTAX: POOL:
scan-word scan-word '[ _ swap <pool> ] [ swap set-class-pool ] bi ;
-
"OpenGL 2.1 shaders, OpenAL 3D audio..."
}
{ $slide "Live coding demo"
-
+
}
{ $slide "C library interface"
"Efficient"
"Function pointers, callbacks"
}
{ $slide "Live coding demo"
-
+
}
{ $slide "Deployment"
{ "Let's play " { $vocab-link "tetris" } }
] 3map ;
: clear-screen ( -- )
- 0 0 0 0 glClearColor
+ 0 0 0 0 glClearColor
1 glClearDepth
0xffffffff glClearStencil
flags{ GL_COLOR_BUFFER_BIT
GL_DEPTH_BUFFER_BIT
GL_STENCIL_BUFFER_BIT } glClear ;
-
+
: draw-model ( world -- )
clear-screen
face-ccw cull-back <triangle-cull-state> set-gpu-state
[ condition>> call( -- ? ) ]
[ thread>> self = not ] bi or
[ [ value>> ] dip set-model f ]
- [ 2drop t ] if 100 milliseconds sleep
+ [ 2drop t ] if 100 milliseconds sleep
] 2curry "models.conditional" spawn-server
] keep thread<< ;
: <conditional> ( condition -- model )
f conditional new-model swap >>condition ;
-M: conditional model-activated [ model>> ] keep model-changed ;
\ No newline at end of file
+M: conditional model-activated [ model>> ] keep model-changed ;
-USING: help.syntax help.markup kernel math classes classes.tuple\r
-calendar models ;\r
-IN: models.history\r
-\r
-HELP: history\r
-{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;\r
-\r
-HELP: <history>\r
-{ $values { "value" object } { "history" "a new " { $link history } } }\r
-{ $description "Creates a new history model with an initial value." } ;\r
-\r
-{ <history> add-history go-back go-forward } related-words\r
-\r
-HELP: go-back\r
-{ $values { "history" history } }\r
-{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
-\r
-HELP: go-forward\r
-{ $values { "history" history } }\r
-{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
-\r
-HELP: add-history\r
-{ $values { "history" history } }\r
-{ $description "Adds the current value to the history." } ;\r
-\r
-ARTICLE: "models-history" "History models"\r
-"History models record previous values."\r
-{ $subsections\r
- history\r
- <history>\r
-}\r
-"Recording history:"\r
-{ $subsections add-history }\r
-"Navigating the history:"\r
-{ $subsections\r
- go-back\r
- go-forward\r
-} ;\r
-\r
-ABOUT: "models-history"\r
+USING: help.syntax help.markup kernel math classes classes.tuple
+calendar models ;
+IN: models.history
+
+HELP: history
+{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;
+
+HELP: <history>
+{ $values { "value" object } { "history" "a new " { $link history } } }
+{ $description "Creates a new history model with an initial value." } ;
+
+{ <history> add-history go-back go-forward } related-words
+
+HELP: go-back
+{ $values { "history" history } }
+{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
+
+HELP: go-forward
+{ $values { "history" history } }
+{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
+
+HELP: add-history
+{ $values { "history" history } }
+{ $description "Adds the current value to the history." } ;
+
+ARTICLE: "models-history" "History models"
+"History models record previous values."
+{ $subsections
+ history
+ <history>
+}
+"Recording history:"
+{ $subsections add-history }
+"Navigating the history:"
+{ $subsections
+ go-back
+ go-forward
+} ;
+
+ABOUT: "models-history"
-USING: arrays generic kernel math models namespaces sequences assocs\r
-tools.test models.history accessors ;\r
-IN: models.history.tests\r
-\r
-f <history> "history" set\r
-\r
-"history" get add-history\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get add-history\r
-3 "history" get set-model\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get add-history\r
-4 "history" get set-model\r
-\r
-[ f ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get go-back\r
-\r
-[ 3 ] [ "history" get value>> ] unit-test\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ f ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get go-forward\r
-\r
-[ 4 ] [ "history" get value>> ] unit-test\r
-\r
-[ f ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
+USING: arrays generic kernel math models namespaces sequences assocs
+tools.test models.history accessors ;
+IN: models.history.tests
+
+f <history> "history" set
+
+"history" get add-history
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get add-history
+3 "history" get set-model
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get add-history
+4 "history" get set-model
+
+[ f ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get go-back
+
+[ 3 ] [ "history" get value>> ] unit-test
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ f ] [ "history" get forward>> empty? ] unit-test
+
+"history" get go-forward
+
+[ 4 ] [ "history" get value>> ] unit-test
+
+[ f ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel locals models sequences ;\r
-IN: models.history\r
-\r
-TUPLE: history < model back forward ;\r
-\r
-: reset-history ( history -- history )\r
- V{ } clone >>back\r
- V{ } clone >>forward ; inline\r
-\r
-: <history> ( value -- history )\r
- history new-model\r
- reset-history ;\r
-\r
-: (add-history) ( history to -- )\r
- swap value>> [ swap push ] [ drop ] if* ;\r
-\r
-:: go-back/forward ( history to from -- )\r
- from empty? [\r
- history to (add-history)\r
- from pop history set-model\r
- ] unless ;\r
-\r
-: go-back ( history -- )\r
- dup [ forward>> ] [ back>> ] bi go-back/forward ;\r
-\r
-: go-forward ( history -- )\r
- dup [ back>> ] [ forward>> ] bi go-back/forward ;\r
-\r
-: add-history ( history -- )\r
- dup forward>> delete-all\r
- dup back>> (add-history) ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals models sequences ;
+IN: models.history
+
+TUPLE: history < model back forward ;
+
+: reset-history ( history -- history )
+ V{ } clone >>back
+ V{ } clone >>forward ; inline
+
+: <history> ( value -- history )
+ history new-model
+ reset-history ;
+
+: (add-history) ( history to -- )
+ swap value>> [ swap push ] [ drop ] if* ;
+
+:: go-back/forward ( history to from -- )
+ from empty? [
+ history to (add-history)
+ from pop history set-model
+ ] unless ;
+
+: go-back ( history -- )
+ dup [ forward>> ] [ back>> ] bi go-back/forward ;
+
+: go-forward ( history -- )
+ dup [ back>> ] [ forward>> ] bi go-back/forward ;
+
+: add-history ( history -- )
+ dup forward>> delete-all
+ dup back>> (add-history) ;
: <result> ( -- ) result new result set ; inline
-CONSTANT: CHECK-KEY f
+CONSTANT: CHECK-KEY f
CONSTANT: DOC-SMALL H{ }
CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
{ "total_word_count" 6743 }
- { "access_time" f }
+ { "access_time" f }
{ "meta_tags" H{ { "description" "i am a long description string" }
{ "author" "Holly Man" }
{ "dynamically_created_meta_tag" "who know\n what" } } }
{ "page_structure" H{ { "counted_tags" 3450 }
{ "no_of_js_attached" 10 }
{ "no_of_images" 6 } } }
- { "harvested_words" { "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ { "harvested_words" { "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo"
- "10gen" "web" "open" "source" "application" "paas"
- "platform-as-a-service" "technology" "helps"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
"developers" "focus" "building" "mongodb" "mongo" } } }
: set-doc ( name -- )
: small-doc-prepare ( -- quot: ( i -- doc ) )
small-doc drop
- '[ "x" DOC-SMALL clone [ set-at ] keep ] ;
+ '[ "x" DOC-SMALL clone [ set-at ] keep ] ;
: medium-doc-prepare ( -- quot: ( i -- doc ) )
medium-doc drop
- '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ;
+ '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ;
: large-doc-prepare ( -- quot: ( i -- doc ) )
large-doc drop
- [ "x" DOC-LARGE clone [ set-at ] keep
+ [ "x" DOC-LARGE clone [ set-at ] keep
[ now "access-time" ] dip
[ set-at ] keep ] ;
: (insert) ( quot: ( i -- doc ) collection -- )
[ trial-size ] 2dip
'[ _ call( i -- doc ) [ _ ] dip
- result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ;
+ result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ;
: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq )
[ [ * ] keep 1 range boa ] dip
- '[ _ call( i -- doc ) ] map ;
+ '[ _ call( i -- doc ) ] map ;
: (insert-batch) ( quot: ( i -- doc ) collection -- )
[ trial-size batch-size [ / ] keep ] 2dip
'[ _ _ (prepare-batch) [ _ ] dip
result get lasterror>> [ save ] [ save-unsafe ] if
- ] each-integer ;
+ ] each-integer ;
: bchar ( boolean -- char )
- [ "t" ] [ "f" ] if ; inline
+ [ "t" ] [ "f" ] if ; inline
: collection-name ( -- collection )
collection "benchmark" get*
result get doc>>
result get index>> bchar
"%s-%s-%s" sprintf
- [ [ result get ] dip >>collection drop ] keep ;
-
+ [ [ result get ] dip >>collection drop ] keep ;
+
: prepare-collection ( -- collection )
collection-name
[ "_x_idx" drop-index ] keep
[ drop-collection ] keep
- [ create-collection ] keep ;
+ [ create-collection ] keep ;
: prepare-index ( collection -- )
- "_x_idx" [ "x" asc ] key-spec <index-spec> t >>unique? ensure-index ;
+ "_x_idx" [ "x" asc ] key-spec <index-spec> t >>unique? ensure-index ;
: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
prepare-collection
[ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
- '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ;
+ '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ;
: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
[ 0 ] dip call( i -- doc ) assoc>bv
- '[ trial-size [ _ binary [ H{ } stream>assoc drop ] with-byte-reader ] times ] ;
+ '[ trial-size [ _ binary [ H{ } stream>assoc drop ] with-byte-reader ] times ] ;
: check-for-key ( assoc key -- )
- CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
+ CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
: (check-find-result) ( result -- )
"x" check-for-key ; inline
trial-size ] dip
1000000000 / [ /i ] [ result get batch>> [ [ batch-size /i ] dip ] when /i ] 2bi
"%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s %10s ops/s"
- sprintf print flush ;
+ sprintf print flush ;
: print-separator ( -- )
"---------------------------------------------------------------------------------" print flush ; inline
print-separator-bold ;
: with-result ( options quot -- )
- '[ <result> _ call( options -- time ) print-result ] with-scope ;
+ '[ <result> _ call( options -- time ) print-result ] with-scope ;
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _
'[ [ [ _ execute( -- quot ) ] dip
[ execute( -- ) ] each _ execute( quot -- quot ) gc
benchmark ] with-result ] each
- print-separator ] ;
+ print-separator ] ;
: run-serialization-bench ( doc-word-seq feat-seq -- )
"Serialization Tests" print
print-separator-bold
- \ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
+ \ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
: run-deserialization-bench ( doc-word-seq feat-seq -- )
"Deserialization Tests" print
print-separator-bold
- \ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
+ \ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
: run-insert-bench ( doc-word-seq feat-seq -- )
"Insert Tests" print
- print-separator-bold
- \ insert [bench-quot] '[ _ call( doc-word -- ) ] each ;
+ print-separator-bold
+ \ insert [bench-quot] '[ _ call( doc-word -- ) ] each ;
: run-find-one-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-One" print
print-separator-bold
- \ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ;
+ \ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ;
: run-find-all-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-All" print
print-separator-bold
- \ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ;
+ \ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ;
: run-find-range-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-Range" print
print-separator-bold
- \ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ;
+ \ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ;
: run-benchmarks ( -- )
] with-db ;
MAIN: run-benchmarks
-
<PRIVATE
-TUPLE: mongodb-cmd
+TUPLE: mongodb-cmd
{ name string }
{ const? boolean }
{ admin? boolean }
PRIVATE>
-CONSTANT: buildinfo-cmd
+CONSTANT: buildinfo-cmd
T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } }
CONSTANT: list-databases-cmd
T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } }
! Options: -1 gets the current profile level; 0-2 set the profile level
-CONSTANT: profile-cmd
+CONSTANT: profile-cmd
T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } }
CONSTANT: server-status-cmd
T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } }
: make-cmd ( cmd-stub -- cmd-assoc )
- dup const?>> [ ] [
+ dup const?>> [ ] [
clone [ clone <linked-assoc> ] change-assoc
] if ; inline
CONSTRUCTOR: <mdb-connection> mdb-connection ( instance -- mdb-connection ) ;
: check-ok ( result -- errmsg ? )
- [ [ "errmsg" ] dip at ]
- [ [ "ok" ] dip at ] bi ; inline
+ [ [ "errmsg" ] dip at ]
+ [ [ "ok" ] dip at ] bi ; inline
: <mdb-db> ( name nodes -- mdb-db )
mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
: with-connection ( connection quot -- * )
[ mdb-connection ] dip with-variable ; inline
-
+
: mdb-instance ( -- mdb )
mdb-connection get instance>> ; inline
[ "nonce" of ] [ f ] if* ;
: auth? ( mdb -- ? )
- [ username>> ] [ pwd-digest>> ] bi and ;
+ [ username>> ] [ pwd-digest>> ] bi and ;
: calculate-key-digest ( nonce -- digest )
mdb-instance
mdb-instance username>> "user" set-cmd-opt
get-nonce [ "nonce" set-cmd-opt ] [ ] bi
calculate-key-digest "key" set-cmd-opt ; inline
-
+
: perform-authentication ( -- )
authenticate-cmd make-cmd
build-auth-cmd send-cmd
[ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
: get-ismaster ( -- result )
- "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
+ "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
: split-host-str ( hoststr -- host port )
":" split [ first ] [ second string>number ] bi ; inline
[ drop f ] if* :> node2
node1 [ acc push ] when*
node2 [ acc push ] when*
- mdb acc nodelist>table >>nodes drop
+ mdb acc nodelist>table >>nodes drop
] with-destructors ;
ERROR: mongod-connection-error address message ;
-
+
: mdb-open ( mdb -- mdb-connection )
clone [ verify-nodes ] [ <mdb-connection> ] [ ] tri
master-node [
msg>> text ;
: >pwd-digest ( user password -- digest )
- "mongo" swap 3array ":" join md5-checksum ;
+ "mongo" swap 3array ":" join md5-checksum ;
<PRIVATE
GENERIC: update-query ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- )
-M: mdb-query-msg update-query
+M: mdb-query-msg update-query
swap [ start#>> ] [ returned#>> ] bi + >>skip# drop ;
M: mdb-getmore-msg update-query
- query>> update-query ;
-
+ query>> update-query ;
+
: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
over cursor>> 0 >
[ [ update-query ]
DEFER: send-query
-GENERIC: verify-query-result ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-result-msg mdb-query-msg/mdb-getmore-msg )
+GENERIC: verify-query-result ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-result-msg mdb-query-msg/mdb-getmore-msg )
M: mdb-query-msg verify-query-result ;
M: mdb-getmore-msg verify-query-result
over flags>> ResultFlag_CursorNotFound =
[ nip query>> [ send-query-plain ] keep ] when ;
-
+
: send-query ( mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f seq )
[ send-query-plain ] keep
- verify-query-result
+ verify-query-result
[ collection>> >>collection drop ]
- [ return#>> >>requested# ]
+ [ return#>> >>requested# ]
[ make-cursor ] 2tri
swap objects>> ;
PRIVATE>
SYNTAX: r/
- \ / [ >mdbregexp ] parse-literal ;
+ \ / [ >mdbregexp ] parse-literal ;
: with-db ( mdb quot -- )
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
} cleave send-cmd check-ok
[ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ]
[ throw ] if ;
-
+
: load-collection-list ( -- collection-list )
namespaces-collection
H{ } clone <mdb-query-msg> send-query-plain objects>> ;
: get-more ( mdb-cursor -- mdb-cursor seq )
[ [ query>> dup [ collection>> ] [ return#>> ] bi ]
- [ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
+ [ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
[ f f ] if* ;
PRIVATE>
GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
-M: mdb-query-msg hint
+M: mdb-query-msg hint
>>hint ;
GENERIC: find ( selector -- mdb-cursor/f seq )
: count ( mdb-query-msg -- result )
[ count-cmd make-cmd ] dip
[ collection>> "count" set-cmd-opt ]
- [ query>> "query" set-cmd-opt ] bi send-cmd
+ [ query>> "query" set-cmd-opt ] bi send-cmd
[ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
: lasterror ( -- error )
: drop-collection ( name -- )
[ drop-cmd make-cmd ] dip
"drop" set-cmd-opt send-cmd drop ;
-
-
"mongodb.connection" require
"mongodb.driver" require
"mongodb.tuple" require
-
IN: mongodb.msg
-CONSTANT: OP_Reply 1
-CONSTANT: OP_Message 1000
-CONSTANT: OP_Update 2001
-CONSTANT: OP_Insert 2002
-CONSTANT: OP_Query 2004
-CONSTANT: OP_GetMore 2005
-CONSTANT: OP_Delete 2006
+CONSTANT: OP_Reply 1
+CONSTANT: OP_Message 1000
+CONSTANT: OP_Update 2001
+CONSTANT: OP_Insert 2002
+CONSTANT: OP_Query 2004
+CONSTANT: OP_GetMore 2005
+CONSTANT: OP_Delete 2006
CONSTANT: OP_KillCursors 2007
CONSTANT: ResultFlag_CursorNotFound 1 ! /* returned, with zero results, when getMore is called but the cursor id is not valid at the server. */
CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */
CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
-
+
TUPLE: mdb-msg
- { opcode integer }
+ { opcode integer }
{ req-id integer initial: 0 }
{ resp-id integer initial: 0 }
- { length integer initial: 0 }
+ { length integer initial: 0 }
{ flags integer initial: 0 } ;
TUPLE: mdb-query-msg < mdb-msg
CONSTRUCTOR: <mdb-update-msg> mdb-update-msg ( collection selector object -- mdb-update-msg )
OP_Update >>opcode ; inline
-
-CONSTRUCTOR: <mdb-reply-msg> mdb-reply-msg ( -- mdb-reply-msg ) ; inline
+CONSTRUCTOR: <mdb-reply-msg> mdb-reply-msg ( -- mdb-reply-msg ) ; inline
CONSTANT: MSG-HEADER-SIZE 16
-SYMBOL: msg-bytes-read
+SYMBOL: msg-bytes-read
: bytes-read> ( -- integer )
msg-bytes-read get ; inline
read-longlong >>cursor
read-int32 >>start#
read-int32 [ >>returned# ] keep
- [ H{ } clone stream>assoc ] collector [ times ] dip >>objects ;
+ [ H{ } clone stream>assoc ] collector [ times ] dip >>objects ;
: (read-message) ( message opcode -- message )
- OP_Reply =
+ OP_Reply =
[ reply-read-message ]
[ "unknown message type" throw ] if ; inline
] (write-message) ; inline
: write-insert-message ( message -- )
- [
+ [
[ flags>> write-int32 ]
[ collection>> write-cstring ]
[ objects>> [ assoc>stream ] each ] tri
: write-update-message ( message -- )
[
- {
+ {
[ flags>> write-int32 ]
[ collection>> write-cstring ]
[ update-flags>> write-int32 ]
PRIVATE>
: write-message ( message -- )
- {
+ {
{ [ dup mdb-query-msg? ] [ write-query-message ] }
{ [ dup mdb-insert-msg? ] [ write-insert-message ] }
{ [ dup mdb-update-msg? ] [ write-update-message ] }
over class-of id-slot writer-word execute( object value -- ) ;
-
+
TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
GENERIC: tuple-collection ( object -- mdb-collection )
<PRIVATE
-: (mdb-collection) ( class -- mdb-collection )
+: (mdb-collection) ( class -- mdb-collection )
dup MDB_COLLECTION word-prop
[ nip ]
[ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
'[ split-optl swap _ set-at ] each ; inline
: index-list>map ( seq -- map )
- [ H{ } clone ] dip over
+ [ H{ } clone ] dip over
'[ dup name>> _ set-at ] each ; inline
: user-defined-key ( map -- key value ? )
M: tuple-class tuple-collection ( tuple -- mdb-collection )
(mdb-collection) ;
-
+
M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
class-of (mdb-collection) ;
-
+
M: mdb-persistent mdb-slot-map ( tuple -- string )
class-of (mdb-slot-map) ;
: slot-option? ( tuple slot option -- ? )
[ swap mdb-slot-map at ] dip
'[ _ swap member-eq? ] [ f ] if* ;
-
+
PRIVATE>
GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
-M: string <mdb-tuple-collection>
- collection-map [ ] [ key? ] 2bi
- [ at ] [ [ mdb-tuple-collection new dup ] 2dip
+M: string <mdb-tuple-collection>
+ collection-map [ ] [ key? ] 2bi
+ [ at ] [ [ mdb-tuple-collection new dup ] 2dip
[ [ >>name ] keep ] dip set-at ] if ; inline
M: mdb-tuple-collection <mdb-tuple-collection> ;
M: mdb-collection <mdb-tuple-collection>
[ first ] keep second lookup-word ; inline
: tuple-instance ( tuple-info -- instance )
- mdbinfo>tuple-class new ; inline
+ mdbinfo>tuple-class new ; inline
: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
[ tuple-info tuple-instance dup
CONSTRUCTOR: <cond-value> cond-value ( value quot -- cond-value ) ;
: write-mdb-persistent ( value quot -- value' )
- over [ call( tuple -- assoc ) ] dip
+ over [ call( tuple -- assoc ) ] dip
[ [ tuple-collection name>> ] [ >toid ] bi ] keep
[ add-storable ] dip
[ tuple-collection name>> ] [ id>> ] bi <dbref> ;
'[ _ 2over write-field?
[ _ write-field swap _ set-at ]
[ 2drop ] if
- ] assoc-each ;
+ ] assoc-each ;
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
H{ } clone swap [ <mirror> ] keep pick ; inline
[ make-tuple ]
[ ] if ] [ drop ] recover
] [ ] if ; inline recursive
-
: tuple-info? ( assoc -- ? )
[ MDB_TUPLE_INFO ] dip key? ;
-
classes.tuple.parser compiler.units fry kernel sequences
hashtables
mongodb.driver
-mongodb.msg mongodb.tuple.collection
+mongodb.msg mongodb.tuple.collection
mongodb.tuple.persistent mongodb.tuple.state strings ;
FROM: mongodb.driver => update delete find count ;
FROM: mongodb.tuple.persistent => assoc>tuple ;
SYNTAX: MDBTUPLE:
parse-tuple-definition
mdb-check-slots
- define-tuple-class ;
+ define-tuple-class ;
: define-persistent ( class collection slot-options index -- )
- [ [ <mdb-tuple-collection> dupd link-collection ] when* ] 2dip
+ [ [ <mdb-tuple-collection> dupd link-collection ] when* ] 2dip
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] 2dip
- [ drop set-slot-map ]
+ [ drop set-slot-map ]
[ nip set-index-map ] 3bi ; inline
: ensure-table ( class -- )
] bi ;
: ensure-tables ( classes -- )
- [ ensure-table ] each ;
+ [ ensure-table ] each ;
: drop-table ( class -- )
tuple-collection
[ name>> drop-collection ] bi ;
: recreate-table ( class -- )
- [ drop-table ]
+ [ drop-table ]
[ ensure-table ] bi ;
DEFER: tuple>query
dup mdb-query-msg? [ tuple>query ] unless ;
PRIVATE>
-
+
: save-tuple-deep ( tuple -- )
- tuple>storable [ (save-tuples) ] assoc-each ;
-
+ tuple>storable [ (save-tuples) ] assoc-each ;
+
: update-tuple ( tuple -- )
[ tuple-collection name>> ]
[ ensure-oid id-selector ]
: morse>ch ( str -- ch )
morse-code-table value-at char-gap-char or ;
-
+
<PRIVATE
-
+
: word>morse ( str -- morse )
[ ch>morse ] { } map-as " " join ;
: sentence>morse ( str -- morse )
" " split [ word>morse ] map " / " join ;
-
+
: trim-blanks ( str -- newstr )
[ blank? ] trim ; inline
[ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
PRIVATE>
-
+
: >morse ( str -- newstr )
trim-blanks sentence>morse ;
-
+
: morse> ( morse -- plain )
replace-underscores morse>sentence ;
-SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> suffix! ;
-
+SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> suffix! ;
+
<PRIVATE
-
+
SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
: queue ( symbol -- )
: start-vm-in-os-thread ( args -- threadhandle )
vm prefix
- [ length ] [ native-string-encoding strings>alien ] bi
+ [ length ] [ native-string-encoding strings>alien ] bi
start_standalone_factor_in_new_thread ;
: start-tetris-in-os-thread ( -- )
-USING: arrays kernel math opengl opengl.gl opengl.glu\r
-opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats\r
-threads accessors calendar literals ;\r
-IN: nehe.5\r
-\r
-TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
-CONSTANT: width 256\r
-CONSTANT: height 256\r
-: redraw-interval ( -- dt ) 10 milliseconds ;\r
-\r
-: <nehe5-gadget> ( -- gadget )\r
- nehe5-gadget new\r
- 0.0 >>rtri\r
- 0.0 >>rquad ;\r
-\r
-M: nehe5-gadget draw-gadget* ( gadget -- )\r
- GL_PROJECTION glMatrixMode\r
- glLoadIdentity\r
- 45.0 width height / >float 0.1 100.0 gluPerspective\r
- GL_MODELVIEW glMatrixMode\r
- glLoadIdentity\r
- GL_SMOOTH glShadeModel\r
- 0.0 0.0 0.0 0.0 glClearColor\r
- 1.0 glClearDepth\r
- GL_DEPTH_TEST glEnable\r
- GL_LEQUAL glDepthFunc\r
- GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint\r
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear\r
- glLoadIdentity\r
- -1.5 0.0 -6.0 glTranslatef\r
- dup rtri>> 0.0 1.0 0.0 glRotatef\r
-\r
- GL_TRIANGLES [\r
- 1.0 0.0 0.0 glColor3f\r
- 0.0 1.0 0.0 glVertex3f\r
- 0.0 1.0 0.0 glColor3f\r
- -1.0 -1.0 1.0 glVertex3f\r
- 0.0 0.0 1.0 glColor3f\r
- 1.0 -1.0 1.0 glVertex3f\r
-\r
- 1.0 0.0 0.0 glColor3f\r
- 0.0 1.0 0.0 glVertex3f\r
- 0.0 0.0 1.0 glColor3f\r
- 1.0 -1.0 1.0 glVertex3f\r
- 0.0 1.0 0.0 glColor3f\r
- 1.0 -1.0 -1.0 glVertex3f\r
-\r
- 1.0 0.0 0.0 glColor3f\r
- 0.0 1.0 0.0 glVertex3f\r
- 0.0 1.0 0.0 glColor3f\r
- 1.0 -1.0 -1.0 glVertex3f\r
- 0.0 0.0 1.0 glColor3f\r
- -1.0 -1.0 -1.0 glVertex3f\r
-\r
- 1.0 0.0 0.0 glColor3f\r
- 0.0 1.0 0.0 glVertex3f\r
- 0.0 0.0 1.0 glColor3f\r
- -1.0 -1.0 -1.0 glVertex3f\r
- 0.0 1.0 0.0 glColor3f\r
- -1.0 -1.0 1.0 glVertex3f\r
- ] do-state\r
-\r
- glLoadIdentity\r
-\r
- 1.5 0.0 -7.0 glTranslatef\r
- dup rquad>> 1.0 0.0 0.0 glRotatef\r
- GL_QUADS [\r
- 0.0 1.0 0.0 glColor3f\r
- 1.0 1.0 -1.0 glVertex3f\r
- -1.0 1.0 -1.0 glVertex3f\r
- -1.0 1.0 1.0 glVertex3f\r
- 1.0 1.0 1.0 glVertex3f\r
-\r
- 1.0 0.5 0.0 glColor3f\r
- 1.0 -1.0 1.0 glVertex3f\r
- -1.0 -1.0 1.0 glVertex3f\r
- -1.0 -1.0 -1.0 glVertex3f\r
- 1.0 -1.0 -1.0 glVertex3f\r
-\r
- 1.0 0.0 0.0 glColor3f\r
- 1.0 1.0 1.0 glVertex3f\r
- -1.0 1.0 1.0 glVertex3f\r
- -1.0 -1.0 1.0 glVertex3f\r
- 1.0 -1.0 1.0 glVertex3f\r
-\r
- 1.0 1.0 0.0 glColor3f\r
- 1.0 -1.0 -1.0 glVertex3f\r
- -1.0 -1.0 -1.0 glVertex3f\r
- -1.0 1.0 -1.0 glVertex3f\r
- 1.0 1.0 -1.0 glVertex3f\r
-\r
- 0.0 0.0 1.0 glColor3f\r
- -1.0 1.0 1.0 glVertex3f\r
- -1.0 1.0 -1.0 glVertex3f\r
- -1.0 -1.0 -1.0 glVertex3f\r
- -1.0 -1.0 1.0 glVertex3f\r
-\r
- 1.0 0.0 1.0 glColor3f\r
- 1.0 1.0 -1.0 glVertex3f\r
- 1.0 1.0 1.0 glVertex3f\r
- 1.0 -1.0 1.0 glVertex3f\r
- 1.0 -1.0 -1.0 glVertex3f\r
- ] do-state\r
- [ 0.2 + ] change-rtri\r
- [ 0.15 - ] change-rquad drop ;\r
-\r
-: nehe5-update-thread ( gadget -- )\r
- dup quit?>> [\r
- drop\r
- ] [\r
- redraw-interval sleep\r
- dup relayout-1\r
- nehe5-update-thread\r
- ] if ;\r
-\r
-M: nehe5-gadget graft* ( gadget -- )\r
- f >>quit?\r
- [ nehe5-update-thread ] curry in-thread ;\r
-\r
-M: nehe5-gadget ungraft* ( gadget -- )\r
- t >>quit? drop ;\r
-\r
-MAIN-WINDOW: run5\r
- {\r
- { title "NeHe Tutorial 5" }\r
- { pref-dim { $ width $ height } }\r
- { pixel-format-attributes {\r
- windowed\r
- double-buffered\r
- T{ depth-bits { value 16 } }\r
- } }\r
- }\r
- <nehe5-gadget> >>gadgets ;\r
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ui.pixel-formats
+threads accessors calendar literals ;
+IN: nehe.5
+
+TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
+CONSTANT: width 256
+CONSTANT: height 256
+: redraw-interval ( -- dt ) 10 milliseconds ;
+
+: <nehe5-gadget> ( -- gadget )
+ nehe5-gadget new
+ 0.0 >>rtri
+ 0.0 >>rquad ;
+
+M: nehe5-gadget draw-gadget* ( gadget -- )
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ 45.0 width height / >float 0.1 100.0 gluPerspective
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ GL_SMOOTH glShadeModel
+ 0.0 0.0 0.0 0.0 glClearColor
+ 1.0 glClearDepth
+ GL_DEPTH_TEST glEnable
+ GL_LEQUAL glDepthFunc
+ GL_PERSPECTIVE_CORRECTION_HINT GL_NICEST glHint
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ glLoadIdentity
+ -1.5 0.0 -6.0 glTranslatef
+ dup rtri>> 0.0 1.0 0.0 glRotatef
+
+ GL_TRIANGLES [
+ 1.0 0.0 0.0 glColor3f
+ 0.0 1.0 0.0 glVertex3f
+ 0.0 1.0 0.0 glColor3f
+ -1.0 -1.0 1.0 glVertex3f
+ 0.0 0.0 1.0 glColor3f
+ 1.0 -1.0 1.0 glVertex3f
+
+ 1.0 0.0 0.0 glColor3f
+ 0.0 1.0 0.0 glVertex3f
+ 0.0 0.0 1.0 glColor3f
+ 1.0 -1.0 1.0 glVertex3f
+ 0.0 1.0 0.0 glColor3f
+ 1.0 -1.0 -1.0 glVertex3f
+
+ 1.0 0.0 0.0 glColor3f
+ 0.0 1.0 0.0 glVertex3f
+ 0.0 1.0 0.0 glColor3f
+ 1.0 -1.0 -1.0 glVertex3f
+ 0.0 0.0 1.0 glColor3f
+ -1.0 -1.0 -1.0 glVertex3f
+
+ 1.0 0.0 0.0 glColor3f
+ 0.0 1.0 0.0 glVertex3f
+ 0.0 0.0 1.0 glColor3f
+ -1.0 -1.0 -1.0 glVertex3f
+ 0.0 1.0 0.0 glColor3f
+ -1.0 -1.0 1.0 glVertex3f
+ ] do-state
+
+ glLoadIdentity
+
+ 1.5 0.0 -7.0 glTranslatef
+ dup rquad>> 1.0 0.0 0.0 glRotatef
+ GL_QUADS [
+ 0.0 1.0 0.0 glColor3f
+ 1.0 1.0 -1.0 glVertex3f
+ -1.0 1.0 -1.0 glVertex3f
+ -1.0 1.0 1.0 glVertex3f
+ 1.0 1.0 1.0 glVertex3f
+
+ 1.0 0.5 0.0 glColor3f
+ 1.0 -1.0 1.0 glVertex3f
+ -1.0 -1.0 1.0 glVertex3f
+ -1.0 -1.0 -1.0 glVertex3f
+ 1.0 -1.0 -1.0 glVertex3f
+
+ 1.0 0.0 0.0 glColor3f
+ 1.0 1.0 1.0 glVertex3f
+ -1.0 1.0 1.0 glVertex3f
+ -1.0 -1.0 1.0 glVertex3f
+ 1.0 -1.0 1.0 glVertex3f
+
+ 1.0 1.0 0.0 glColor3f
+ 1.0 -1.0 -1.0 glVertex3f
+ -1.0 -1.0 -1.0 glVertex3f
+ -1.0 1.0 -1.0 glVertex3f
+ 1.0 1.0 -1.0 glVertex3f
+
+ 0.0 0.0 1.0 glColor3f
+ -1.0 1.0 1.0 glVertex3f
+ -1.0 1.0 -1.0 glVertex3f
+ -1.0 -1.0 -1.0 glVertex3f
+ -1.0 -1.0 1.0 glVertex3f
+
+ 1.0 0.0 1.0 glColor3f
+ 1.0 1.0 -1.0 glVertex3f
+ 1.0 1.0 1.0 glVertex3f
+ 1.0 -1.0 1.0 glVertex3f
+ 1.0 -1.0 -1.0 glVertex3f
+ ] do-state
+ [ 0.2 + ] change-rtri
+ [ 0.15 - ] change-rquad drop ;
+
+: nehe5-update-thread ( gadget -- )
+ dup quit?>> [
+ drop
+ ] [
+ redraw-interval sleep
+ dup relayout-1
+ nehe5-update-thread
+ ] if ;
+
+M: nehe5-gadget graft* ( gadget -- )
+ f >>quit?
+ [ nehe5-update-thread ] curry in-thread ;
+
+M: nehe5-gadget ungraft* ( gadget -- )
+ t >>quit? drop ;
+
+MAIN-WINDOW: run5
+ {
+ { title "NeHe Tutorial 5" }
+ { pref-dim { $ width $ height } }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 16 } }
+ } }
+ }
+ <nehe5-gadget> >>gadgets ;
-! Copyright (C) 2009 blei, Doug Coleman.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel locals make math multiline sequences ;\r
-IN: nested-comments\r
-\r
-: (count-subsequences) ( count substring string n -- count' )\r
- [ 2dup ] dip start* [\r
- pick length +\r
- [ 1 + ] 3dip (count-subsequences)\r
- ] [\r
- 2drop\r
- ] if* ;\r
-\r
-: count-subsequences ( subseq seq -- n )\r
- [ 0 ] 2dip 0 (count-subsequences) ;\r
-\r
-: parse-nestable-comment ( parsed-vector left-to-parse -- parsed-vector )\r
- 1 - "*)" parse-multiline-string\r
- [ "(*" ] dip\r
- count-subsequences + dup 0 > [ parse-nestable-comment ] [ drop ] if ;\r
-\r
-SYNTAX: (* 1 parse-nestable-comment ;\r
+! Copyright (C) 2009 blei, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel locals make math multiline sequences ;
+IN: nested-comments
+
+: (count-subsequences) ( count substring string n -- count' )
+ [ 2dup ] dip start* [
+ pick length +
+ [ 1 + ] 3dip (count-subsequences)
+ ] [
+ 2drop
+ ] if* ;
+
+: count-subsequences ( subseq seq -- n )
+ [ 0 ] 2dip 0 (count-subsequences) ;
+
+: parse-nestable-comment ( parsed-vector left-to-parse -- parsed-vector )
+ 1 - "*)" parse-multiline-string
+ [ "(*" ] dip
+ count-subsequences + dup 0 > [ parse-nestable-comment ] [ drop ] if ;
+
+SYNTAX: (* 1 parse-nestable-comment ;
: float-map>byte-map ( floats: float-array scale: float bias: float -- bytes: byte-array )
'[
- [ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
+ [ _ 255.0 * v*n _ 255.0 * v+n float-4 int-4 vconvert ] 4 napply
[ int-4 short-8 vconvert ] 2bi@
short-8 uchar-16 vconvert
] data-map( float-4[4] -- uchar-16 ) ; inline
[ v* ]
[ v* ]
} cleave ; inline
-
+
:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
x table nth-unsafe y + :> a
x 1 + table nth-unsafe y + :> b
: perlin-noise-image ( table transform dim -- image )
[ perlin-noise-map-coords perlin-noise-map ] [ 5/7. 0.5 float-map>image ] bi ;
-
: local-ntp ( -- ntp )
"localhost" <ntp> ;
-
!
USING:
alien
- alien.c-types
+ alien.c-types
alien.libraries
- alien.syntax
+ alien.syntax
classes.struct
- combinators
- kernel
+ combinators
+ kernel
system
;
IN: ogg
{ body_storage long }
{ body_fill long }
{ body_returned long }
- { lacing_vals int* }
+ { lacing_vals int* }
{ granule_vals longlong* }
{ lacing_storage long }
{ lacing_fill long }
STRUCT: ogg-sync-state
{ data uchar* }
{ storage int }
- { fill int }
+ { fill int }
{ returned int }
{ unsynced int }
{ headerbytes int }
FUNCTION: long ogg_page_pageno ( ogg-page* og ) ;
FUNCTION: int ogg_page_packets ( ogg-page* og ) ;
FUNCTION: void ogg_packet_clear ( ogg-packet* op ) ;
-
!
USING:
alien
- alien.c-types
+ alien.c-types
alien.libraries
- alien.syntax
+ alien.syntax
classes.struct
- combinators
- kernel
+ combinators
+ kernel
ogg
system
;
CONSTANT: TH-EBADPACKET -24
CONSTANT: TH-DUPFRAME 1
-TYPEDEF: int th-colorspace
+TYPEDEF: int th-colorspace
CONSTANT: TH-CS-UNSPECIFIED 0
CONSTANT: TH-CS-ITU-REC-470M 1
CONSTANT: TH-CS-ITU-REC-470BG 2
!
USING:
alien
- alien.c-types
+ alien.c-types
alien.libraries
- alien.syntax
+ alien.syntax
classes.struct
- combinators
- kernel
+ combinators
+ kernel
ogg
system
;
{ [ os windows? ] [ "vorbis.dll" ] }
{ [ os macosx? ] [ "libvorbis.0.dylib" ] }
{ [ os unix? ] [ "libvorbis.so" ] }
-} cond cdecl add-library
+} cond cdecl add-library
"vorbis" deploy-library
>>
LIBRARY: vorbis
-STRUCT: vorbis-info
+STRUCT: vorbis-info
{ version int }
{ channels int }
{ rate long }
{ bitrate_nominal long }
{ bitrate_lower long }
{ bitrate_window long }
- { codec_setup void* }
+ { codec_setup void* }
;
STRUCT: vorbis-dsp-state
] [
alGetString throw
] if ;
-
: play-sine ( freq duration -- )
[ ALUT_WAVEFORM_SINE ] 2dip [ 0 ] dip play-waveform ;
-
+
: (play-file) ( source -- )
100 milliseconds sleep
dup source-playing? [ (play-file) ] [ drop ] if ;
: play-file ( filename -- )
init-openal
- create-buffer-from-file
+ create-buffer-from-file
1 gen-sources
first dup [ AL_BUFFER rot set-source-param ] dip
dup source-play
: play-wav ( filename -- )
init-openal
- create-buffer-from-wav
+ create-buffer-from-wav
1 gen-sources
first dup [ AL_BUFFER rot set-source-param ] dip
dup source-play
LIBRARY: openal
-TYPEDEF: char ALboolean
+TYPEDEF: char ALboolean
TYPEDEF: char ALchar
TYPEDEF: char ALbyte
TYPEDEF: uchar ALubyte
CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED 0xD006
FUNCTION: void alEnable ( ALenum capability ) ;
-FUNCTION: void alDisable ( ALenum capability ) ;
-FUNCTION: ALboolean alIsEnabled ( ALenum capability ) ;
+FUNCTION: void alDisable ( ALenum capability ) ;
+FUNCTION: ALboolean alIsEnabled ( ALenum capability ) ;
FUNCTION: ALchar* alGetString ( ALenum param ) ;
FUNCTION: void alGetBooleanv ( ALenum param, ALboolean* data ) ;
FUNCTION: void alGetIntegerv ( ALenum param, ALint* data ) ;
FUNCTION: ALenum alGetEnumValue ( ALchar* ename ) ;
FUNCTION: void alListenerf ( ALenum param, ALfloat value ) ;
FUNCTION: void alListener3f ( ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alListenerfv ( ALenum param, ALfloat* values ) ;
+FUNCTION: void alListenerfv ( ALenum param, ALfloat* values ) ;
FUNCTION: void alListeneri ( ALenum param, ALint value ) ;
FUNCTION: void alListener3i ( ALenum param, ALint value1, ALint value2, ALint value3 ) ;
FUNCTION: void alListeneriv ( ALenum param, ALint* values ) ;
FUNCTION: void alGetListeneri ( ALenum param, ALint* value ) ;
FUNCTION: void alGetListener3i ( ALenum param, ALint* value1, ALint* value2, ALint* value3 ) ;
FUNCTION: void alGetListeneriv ( ALenum param, ALint* values ) ;
-FUNCTION: void alGenSources ( ALsizei n, ALuint* sources ) ;
+FUNCTION: void alGenSources ( ALsizei n, ALuint* sources ) ;
FUNCTION: void alDeleteSources ( ALsizei n, ALuint* sources ) ;
-FUNCTION: ALboolean alIsSource ( ALuint sid ) ;
-FUNCTION: void alSourcef ( ALuint sid, ALenum param, ALfloat value ) ;
+FUNCTION: ALboolean alIsSource ( ALuint sid ) ;
+FUNCTION: void alSourcef ( ALuint sid, ALenum param, ALfloat value ) ;
FUNCTION: void alSource3f ( ALuint sid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alSourcei ( ALuint sid, ALenum param, ALint value ) ;
+FUNCTION: void alSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alSourcei ( ALuint sid, ALenum param, ALint value ) ;
FUNCTION: void alSource3i ( ALuint sid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
FUNCTION: void alSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
FUNCTION: void alGetSourcef ( ALuint sid, ALenum param, ALfloat* value ) ;
CONSTANT: CL_D3D9_RESOURCE_ALREADY_ACQUIRED_NV -1012
CONSTANT: CL_D3D9_RESOURCE_NOT_ACQUIRED_NV -1013
-TYPEDEF: void* cl_d3d9_device_source_nv
-TYPEDEF: void* cl_d3d9_device_set_nv
+TYPEDEF: void* cl_d3d9_device_source_nv
+TYPEDEF: void* cl_d3d9_device_set_nv
FUNCTION: cl_int clGetDeviceIDsFromD3D9NV ( cl_platform_id platform, cl_d3d9_device_source_nv d3d_device_source, void* d3d_object, cl_d3d9_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ;
FUNCTION: cl_mem clCreateFromD3D9VertexBufferNV ( cl_context context, cl_mem_flags flags, void* id3dvb9_resource, cl_int* errcode_ret ) ;
CONSTANT: CL_D3D10_RESOURCE_ALREADY_ACQUIRED_NV -1004
CONSTANT: CL_D3D10_RESOURCE_NOT_ACQUIRED_NV -1005
-TYPEDEF: void* cl_d3d10_device_source_nv
-TYPEDEF: void* cl_d3d10_device_set_nv
+TYPEDEF: void* cl_d3d10_device_source_nv
+TYPEDEF: void* cl_d3d10_device_set_nv
FUNCTION: cl_int clGetDeviceIDsFromD3D10NV ( cl_platform_id platform, cl_d3d10_device_source_nv d3d_device_source, void* d3d_object, cl_d3d10_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ;
FUNCTION: cl_mem clCreateFromD3D10BufferNV ( cl_context context, cl_mem_flags flags, void* id3d10buffer_resource, cl_int* errcode_ret ) ;
CONSTANT: CL_D3D11_RESOURCE_ALREADY_ACQUIRED_NV -1008
CONSTANT: CL_D3D11_RESOURCE_NOT_ACQUIRED_NV -1009
-TYPEDEF: void* cl_d3d11_device_source_nv
-TYPEDEF: void* cl_d3d11_device_set_nv
+TYPEDEF: void* cl_d3d11_device_source_nv
+TYPEDEF: void* cl_d3d11_device_set_nv
FUNCTION: cl_int clGetDeviceIDsFromD3D11NV ( cl_platform_id platform, cl_d3d11_device_source_nv d3d_device_source, void* d3d_object, cl_d3d11_device_set_nv d3d_device_set, cl_uint num_entries, cl_device_id* devices, cl_uint* num_devices ) ;
FUNCTION: cl_mem clCreateFromD3D11BufferNV ( cl_context context, cl_mem_flags flags, void* id3d11buffer_resource, cl_int* errcode_ret ) ;
: cl-not-null ( err -- )
dup f = [ cl-error ] [ drop ] if ; inline
-
+
: info-data-size ( handle name info-quot -- size_t )
[ 0 f 0 size_t <ref> ] dip [ call cl-success ] 2keep drop size_t deref ; inline
TUPLE: cl-device
id type vendor-id max-compute-units max-work-item-dimensions
- max-work-item-sizes max-work-group-size preferred-vector-width-char
- preferred-vector-width-short preferred-vector-width-int
- preferred-vector-width-long preferred-vector-width-float
- preferred-vector-width-double max-clock-frequency address-bits
+ max-work-item-sizes max-work-group-size preferred-vector-width-char
+ preferred-vector-width-short preferred-vector-width-int
+ preferred-vector-width-long preferred-vector-width-float
+ preferred-vector-width-double max-clock-frequency address-bits
max-mem-alloc-size image-support max-read-image-args max-write-image-args
- image2d-max-width image2d-max-height image3d-max-width image3d-max-height
+ image2d-max-width image2d-max-height image3d-max-width image3d-max-height
image3d-max-depth max-samplers max-parameter-size mem-base-addr-align
min-data-type-align-size single-fp-config global-mem-cache-type
- global-mem-cacheline-size global-mem-cache-size global-mem-size
- max-constant-buffer-size max-constant-args local-mem? local-mem-size
- error-correction-support profiling-timer-resolution endian-little
+ global-mem-cacheline-size global-mem-cache-size global-mem-size
+ max-constant-buffer-size max-constant-args local-mem? local-mem-size
+ error-correction-support profiling-timer-resolution endian-little
available compiler-available execute-kernels? execute-native-kernels?
out-of-order-exec-available? profiling-available?
name vendor driver-version profile version extensions ;
[ CL_PLATFORM_VERSION platform-info-string ]
[ CL_PLATFORM_NAME platform-info-string ]
[ CL_PLATFORM_VENDOR platform-info-string ]
- [ CL_PLATFORM_EXTENSIONS platform-info-string ]
+ [ CL_PLATFORM_EXTENSIONS platform-info-string ]
} cleave ;
: cl_device_fp_config>flags ( ulong -- sequence )
[ [ CL_TRUE ] [ CL_FALSE ] if ]
[ addressing-mode-constant ]
[ filter-mode-constant ]
- tri* 0 int <ref> [ clCreateSampler ] keep int deref cl-success
+ tri* 0 int <ref> [ clCreateSampler ] keep int deref cl-success
cl-sampler new-disposable swap >>handle ;
: cl-normalized-coords? ( sampler -- ? )
: cl-barrier ( -- )
(current-cl-queue) clEnqueueBarrier cl-success ; inline
-
+
: cl-flush ( -- )
(current-cl-queue) handle>> clFlush cl-success ; inline
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-world ] }
{ T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-world ] }
{ T{ key-down f f "-" } [ dup distance-step swap zoom-demo-world ] }
-
+
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] }
{ mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-world ] }
} set-gestures
-
>>
LIBRARY: glu
-
+
! These are defined as structs in glu.h, but we only ever use pointers to them
C-TYPE: GLUnurbs
C-TYPE: GLUquadric
: (PAIR-M:) ( -- )
scan-word scan-word 2dup <=> +gt+ eq? [
- ?swap scan-word parse-definition
+ ?swap scan-word parse-definition
] keep ?prefix-swap define-pair-method ;
SYNTAX: PAIR-M: (PAIR-M:) ;
IN: pair-rocket
SYNTAX: => dup pop scan-object 2array suffix! ;
-
'digit' <!+> [ 10 digits>integer ] <@ ;
: 'string' ( -- parser )
- [ CHAR: " = ] satisfy
+ [ CHAR: " = ] satisfy
[ CHAR: " = not ] satisfy <*> &>
[ CHAR: " = ] satisfy <& [ >string ] <@ ;
-
+
: 'bold' ( -- parser )
- "*" token
- [ CHAR: * = not ] satisfy <*> [ >string ] <@ &>
+ "*" token
+ [ CHAR: * = not ] satisfy <*> [ >string ] <@ &>
"*" token <& ;
: 'italic' ( -- parser )
- "_" token
- [ CHAR: _ = not ] satisfy <*> [ >string ] <@ &>
+ "_" token
+ [ CHAR: _ = not ] satisfy <*> [ >string ] <@ &>
"_" token <& ;
: comma-list ( element -- parser )
- "," token list-of ;
\ No newline at end of file
+ "," token list-of ;
] map <table> swap data>> push ;
M: pdf-writer dispose drop ;
-
: b ( -- ) "b" print ;
: c ( -- ) "300 400 400 400 400 300 c" print ; ! FIXME:
-
-
-
-
: visual-wrap ( line font line-width -- lines )
[ string>elements ] dip dup wrap [ concat ] map ;
-
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax strings ;\r
-IN: peg.javascript\r
-\r
-HELP: parse-javascript\r
-{ $values\r
- { "string" string }\r
- { "ast" "a JavaScript abstract syntax tree" }\r
-}\r
-{ $description\r
- "Parse the input string using the JavaScript parser. Throws an error if "\r
- "the string does not contain valid JavaScript. Returns the abstract syntax tree "\r
- "if successful." } ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax strings ;
+IN: peg.javascript
+
+HELP: parse-javascript
+{ $values
+ { "string" string }
+ { "ast" "a JavaScript abstract syntax tree" }
+}
+{ $description
+ "Parse the input string using the JavaScript parser. Throws an error if "
+ "the string does not contain valid JavaScript. Returns the abstract syntax tree "
+ "if successful." } ;
| Stmt
SrcElems = SrcElem* => [[ ast-begin boa ]]
TopLevel = SrcElems Spaces
-;EBNF
\ No newline at end of file
+;EBNF
Tok = Spaces (Name | Keyword | Number | Str | RegExp | Special )
Toks = Tok* Spaces
;EBNF
-
: store-tuple ( tuple -- ) [ insert-tuple ] w/db ;
: modify-tuple ( tuple -- ) [ update-tuple ] w/db ;
: remove-tuples ( tuple -- ) [ delete-tuples ] w/db ;
-
+
TUPLE: pattern value ; C: <pattern> pattern
SYNTAX: %" parse-string <pattern> suffix! ;
M: pattern where value>> over column-name>> 0% " LIKE " 0% bind# ;
:: log-gamma ( x -- value )
x 0 <= [ "Invalid input" throw ] when
x 12 < [ x gamma abs log ] [
- 1.0 x x * / :> z
+ 1.0 x x * / :> z
7 c nth 7 iota reverse [ [ z * ] [ c nth ] bi* + ] each x / :> series
x 0.5 - x log * x - halfLogTwoPi + series +
] if ;
: alive? ( host -- ? )
[ ping drop t ] [ 2drop f ] recover ;
-
IN: pong
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
+!
! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
!
! Which was based on this Nodebox version: http://billmill.org/pong.html
! by Bill Mill.
-!
+!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: clamp-to-interval ( x interval -- x )
: mouse-x ( -- x ) hand-loc get first ;
:: valid-paddle-interval ( PADDLE PLAY-FIELD -- interval )
-
+
PLAY-FIELD [ left ] [ right ] bi PADDLE width - [a,b] ;
:: align-paddle-with-mouse ( PADDLE PLAY-FIELD -- )
clamp-to-interval
PADDLE pos>> (x!) ;
-
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Protocol for drawing PONG objects
M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
-
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M:: <pong> draw-gadget* ( PONG -- )
! To: username@host.com
! Subject: First test with mock POP3 server
! Content-Type: text/plain; charset=UTF-8
-!
+!
! .
! DELE 1
! +OK Marked for deletion
{
[ dup "USER" head? ]
[
-
+
"+OK Password required\r\n"
write flush t
]
"+OK 2 1753\r\n"
write flush t
]
- }
+ }
{
[ dup "LIST" = ]
[
: circle ( center size -- ) dup 2array ellipse ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
[ update-file-progress drop ] compose
with-file-reader
] with-progress-bar ; inline
-
: make-progress-bar ( percent length -- string )
[ check-percent ] [ check-length ] bi*
CHAR: = CHAR: - (make-progress-bar) ;
-
! 56003, 56113, 56333, 56443, 56663, 56773, and 56993.
! Consequently 56003, being the first member of this family,
! is the smallest prime with this property.
-!
+!
! Find the smallest prime which, by replacing part of the number
! (not necessarily adjacent digits) with the same digit,
! is part of an eight prime value family.
<PRIVATE
SYMBOL: family-count
SYMBOL: large-families
-: reset-globals ( -- )
+: reset-globals ( -- )
H{ } clone family-count set
H{ } clone large-families set ;
-: digits-positions ( str -- positions )
+: digits-positions ( str -- positions )
H{ } clone [ '[ swap _ push-at ] each-index ] keep ;
: *-if-index ( char combination index -- char )
dup length [1,b] [ all-combinations ] with map concat ;
: families ( stra -- seq )
- dup digits-positions values
+ dup digits-positions values
[ all-positions-combinations [ replace-positions-with-* ] with map ] with map concat ;
: save-family ( family -- )
! Test all primes that have length n
: n-digits-primes ( n -- primes )
- [ 1 - 10^ ] [ 10^ ] bi primes-between ;
+ [ 1 - 10^ ] [ 10^ ] bi primes-between ;
: test-n-digits-primes ( n -- seq )
- reset-globals
- n-digits-primes
+ reset-globals
+ n-digits-primes
[ number>string families [ handle-family ] each ] each
large-families get ;
! recursively test all primes by length until we find an answer
: (euler051) ( i -- answer )
- dup test-n-digits-primes
- dup assoc-size 0 >
+ dup test-n-digits-primes
+ dup assoc-size 0 >
[ nip values [ fill-*-with-ones string>number ] [ min ] map-reduce ]
[ drop 1 + (euler051) ] if ;
PRIVATE>
2dup [ >key ] dip
[ dup 0 swap [ 1 + ] change-nth ] change-at
2dup [ >key ] dip at first 5 =
- [
+ [
[ >key ] dip at second
] [
[ 1 + ] dip (euler062)
! 25134 ms ave run time - 31.96 SD (10 trials)
SOLUTION: euler074
-
:: minimal-path-sum-to ( x y matrix -- n )
x y + zero? [ 0 ] [
x zero? [ 0 y 1 - matrix get-matrix
- ] [
+ ] [
y zero? [
x 1 - 0 matrix get-matrix
] [
! Copyright (c) 2009 Guillaume Nargeot.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays grouping io.encodings.ascii io.files kernel math
+USING: arrays grouping io.encodings.ascii io.files kernel math
math.parser sequences splitting project-euler.common ;
IN: project-euler.102
: each-quadrant ( node quot -- )
{
- [ [ ll>> ] [ call ] bi* ]
- [ [ lr>> ] [ call ] bi* ]
- [ [ ul>> ] [ call ] bi* ]
- [ [ ur>> ] [ call ] bi* ]
+ [ [ ll>> ] [ call ] bi* ]
+ [ [ lr>> ] [ call ] bi* ]
+ [ [ ul>> ] [ call ] bi* ]
+ [ [ ur>> ] [ call ] bi* ]
} 2cleave ; inline
: map-quadrant ( node quot: ( child-node -- x ) -- array )
each-quadrant 4array ; inline
: node-in-rect* ( values rect node -- values )
[ (node-in-rect*) ] with each-quadrant ;
-:: leaf-in-rect* ( values rect leaf -- values )
+:: leaf-in-rect* ( values rect leaf -- values )
{ [ leaf point>> ] [ leaf point>> rect contains-point? ] } 0&&
[ values leaf value>> suffix! ] [ values ] if ;
: leaf-size ( leaf -- count )
point>> [ 1 ] [ 0 ] if ;
: node-size ( node -- count )
- 0 swap [ quadtree-size + ] each-quadrant ;
-
+ 0 swap [ quadtree-size + ] each-quadrant ;
+
: quadtree-size ( tree -- count )
dup leaf?>> [ leaf-size ] [ node-size ] if ;
[ dup ] dip map
[ zip ] [ rect-containing <quadtree> ] bi
[ '[ first2 _ set-at ] each ] [ values ] bi ; inline
-
swap seed-random ; inline
GENERIC: random-float* ( tuple -- r )
-
+
: random-float ( -- n ) random-generator get random-float* ; inline
M:: lagged-fibonacci random-float* ( lagged-fibonacci -- x )
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs math kernel shuffle generalizations\r
-words quotations arrays combinators sequences math.vectors\r
-io.styles prettyprint vocabs sorting io generic\r
-math.statistics math.order locals.types\r
-locals.definitions ;\r
-IN: reports.noise\r
-\r
-: badness ( word -- n )\r
- H{\r
- { -nrot 5 }\r
- { -rot 3 }\r
- { bi@ 1 }\r
- { 2curry 1 }\r
- { 2drop 1 }\r
- { 2dup 1 }\r
- { 2keep 1 }\r
- { 2nip 2 }\r
- { 2over 4 }\r
- { 2swap 3 }\r
- { 3curry 2 }\r
- { 3drop 1 }\r
- { 3dup 2 }\r
- { 3keep 3 }\r
- { 4drop 2 }\r
- { 4dup 3 }\r
- { compose 1/2 }\r
- { curry 1/3 }\r
- { dip 1 }\r
- { 2dip 2 }\r
- { drop 1/3 }\r
- { dup 1/3 }\r
- { if 1/3 }\r
- { when 1/4 }\r
- { unless 1/4 }\r
- { when* 1/3 }\r
- { unless* 1/3 }\r
- { ?if 1/2 }\r
- { cond 1/2 }\r
- { case 1/2 }\r
- { keep 1 }\r
- { napply 2 }\r
- { ncurry 3 }\r
- { ndip 5 }\r
- { ndrop 2 }\r
- { ndup 3 }\r
- { nip 2 }\r
- { nkeep 5 }\r
- { npick 6 }\r
- { nrot 5 }\r
- { nwith 4 }\r
- { over 2 }\r
- { pick 4 }\r
- { rot 3 }\r
- { swap 1 }\r
- { swapd 3 }\r
- { with 1/2 }\r
-\r
- { bi 1/2 }\r
- { tri 1 }\r
- { bi* 1/2 }\r
- { tri* 1 }\r
-\r
- { cleave 2 }\r
- { spread 2 }\r
- } at 0 or ;\r
-\r
-: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;\r
-\r
-GENERIC: noise ( obj -- pair )\r
-\r
-M: word noise badness 1 2array ;\r
-\r
-M: wrapper noise wrapped>> noise ;\r
-\r
-M: let noise body>> noise ;\r
-\r
-M: lambda noise body>> noise ;\r
-\r
-M: object noise drop { 0 0 } ;\r
-\r
-M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;\r
-\r
-M: array noise [ noise ] map vsum ;\r
-\r
-: noise-factor ( x y -- z ) / 100 * >integer ;\r
-\r
-: quot-noise-factor ( quot -- n )\r
- #! For very short words, noise doesn't count so much\r
- #! (so dup foo swap bar isn't penalized as badly).\r
- noise first2 {\r
- { [ over 4 <= ] [ [ drop 0 ] dip ] }\r
- { [ over 15 >= ] [ [ 2 * ] dip ] }\r
- [ ]\r
- } cond\r
- {\r
- ! short words are easier to read\r
- { [ dup 10 <= ] [ [ 2 / ] dip ] }\r
- { [ dup 5 <= ] [ [ 3 / ] dip ] }\r
- ! long words are penalized even more\r
- { [ dup 25 >= ] [ [ 2 * ] dip 20 max ] }\r
- { [ dup 20 >= ] [ [ 5/3 * ] dip ] }\r
- { [ dup 15 >= ] [ [ 3/2 * ] dip ] }\r
- [ ]\r
- } cond noise-factor ;\r
-\r
-GENERIC: word-noise-factor ( word -- factor )\r
-\r
-M: word word-noise-factor\r
- def>> quot-noise-factor ;\r
-\r
-M: lambda-word word-noise-factor\r
- "lambda" word-prop quot-noise-factor ;\r
-\r
-: flatten-generics ( words -- words' )\r
- [\r
- dup generic? [ "methods" word-prop values ] [ 1array ] if\r
- ] map concat ;\r
-\r
-: noisy-words ( -- alist )\r
- all-words flatten-generics\r
- [ dup word-noise-factor ] { } map>assoc\r
- sort-values reverse ;\r
-\r
-: noise. ( alist -- )\r
- standard-table-style [\r
- [\r
- [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row\r
- ] assoc-each\r
- ] tabular-output ;\r
-\r
-: vocab-noise-factor ( vocab -- factor )\r
- vocab-words flatten-generics\r
- [ word-noise-factor dup 20 < [ drop 0 ] when ] map\r
- [ 0 ] [\r
- [ [ sum ] [ length 5 max ] bi /i ]\r
- [ supremum ]\r
- bi +\r
- ] if-empty ;\r
-\r
-: noisy-vocabs ( -- alist )\r
- loaded-vocab-names [ dup vocab-noise-factor ] { } map>assoc\r
- sort-values reverse ;\r
-\r
-: noise-report ( -- )\r
- "NOISY WORDS:" print\r
- noisy-words 80 head noise.\r
- nl\r
- "NOISY VOCABS:" print\r
- noisy-vocabs 80 head noise. ;\r
-\r
-MAIN: noise-report\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs math kernel shuffle generalizations
+words quotations arrays combinators sequences math.vectors
+io.styles prettyprint vocabs sorting io generic
+math.statistics math.order locals.types
+locals.definitions ;
+IN: reports.noise
+
+: badness ( word -- n )
+ H{
+ { -nrot 5 }
+ { -rot 3 }
+ { bi@ 1 }
+ { 2curry 1 }
+ { 2drop 1 }
+ { 2dup 1 }
+ { 2keep 1 }
+ { 2nip 2 }
+ { 2over 4 }
+ { 2swap 3 }
+ { 3curry 2 }
+ { 3drop 1 }
+ { 3dup 2 }
+ { 3keep 3 }
+ { 4drop 2 }
+ { 4dup 3 }
+ { compose 1/2 }
+ { curry 1/3 }
+ { dip 1 }
+ { 2dip 2 }
+ { drop 1/3 }
+ { dup 1/3 }
+ { if 1/3 }
+ { when 1/4 }
+ { unless 1/4 }
+ { when* 1/3 }
+ { unless* 1/3 }
+ { ?if 1/2 }
+ { cond 1/2 }
+ { case 1/2 }
+ { keep 1 }
+ { napply 2 }
+ { ncurry 3 }
+ { ndip 5 }
+ { ndrop 2 }
+ { ndup 3 }
+ { nip 2 }
+ { nkeep 5 }
+ { npick 6 }
+ { nrot 5 }
+ { nwith 4 }
+ { over 2 }
+ { pick 4 }
+ { rot 3 }
+ { swap 1 }
+ { swapd 3 }
+ { with 1/2 }
+
+ { bi 1/2 }
+ { tri 1 }
+ { bi* 1/2 }
+ { tri* 1 }
+
+ { cleave 2 }
+ { spread 2 }
+ } at 0 or ;
+
+: vsum ( pairs -- pair ) { 0 0 } [ v+ ] reduce ;
+
+GENERIC: noise ( obj -- pair )
+
+M: word noise badness 1 2array ;
+
+M: wrapper noise wrapped>> noise ;
+
+M: let noise body>> noise ;
+
+M: lambda noise body>> noise ;
+
+M: object noise drop { 0 0 } ;
+
+M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
+
+M: array noise [ noise ] map vsum ;
+
+: noise-factor ( x y -- z ) / 100 * >integer ;
+
+: quot-noise-factor ( quot -- n )
+ #! For very short words, noise doesn't count so much
+ #! (so dup foo swap bar isn't penalized as badly).
+ noise first2 {
+ { [ over 4 <= ] [ [ drop 0 ] dip ] }
+ { [ over 15 >= ] [ [ 2 * ] dip ] }
+ [ ]
+ } cond
+ {
+ ! short words are easier to read
+ { [ dup 10 <= ] [ [ 2 / ] dip ] }
+ { [ dup 5 <= ] [ [ 3 / ] dip ] }
+ ! long words are penalized even more
+ { [ dup 25 >= ] [ [ 2 * ] dip 20 max ] }
+ { [ dup 20 >= ] [ [ 5/3 * ] dip ] }
+ { [ dup 15 >= ] [ [ 3/2 * ] dip ] }
+ [ ]
+ } cond noise-factor ;
+
+GENERIC: word-noise-factor ( word -- factor )
+
+M: word word-noise-factor
+ def>> quot-noise-factor ;
+
+M: lambda-word word-noise-factor
+ "lambda" word-prop quot-noise-factor ;
+
+: flatten-generics ( words -- words' )
+ [
+ dup generic? [ "methods" word-prop values ] [ 1array ] if
+ ] map concat ;
+
+: noisy-words ( -- alist )
+ all-words flatten-generics
+ [ dup word-noise-factor ] { } map>assoc
+ sort-values reverse ;
+
+: noise. ( alist -- )
+ standard-table-style [
+ [
+ [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
+ ] assoc-each
+ ] tabular-output ;
+
+: vocab-noise-factor ( vocab -- factor )
+ vocab-words flatten-generics
+ [ word-noise-factor dup 20 < [ drop 0 ] when ] map
+ [ 0 ] [
+ [ [ sum ] [ length 5 max ] bi /i ]
+ [ supremum ]
+ bi +
+ ] if-empty ;
+
+: noisy-vocabs ( -- alist )
+ loaded-vocab-names [ dup vocab-noise-factor ] { } map>assoc
+ sort-values reverse ;
+
+: noise-report ( -- )
+ "NOISY WORDS:" print
+ noisy-words 80 head noise.
+ nl
+ "NOISY VOCABS:" print
+ noisy-vocabs 80 head noise. ;
+
+MAIN: noise-report
{
[ [ first "user-agent" = ] both? ]
[ nip first "user-agent" = not ]
- } 2||
+ } 2||
] monotonic-split ;
: <rules> ( -- rules )
SYNTAX: ROLE: parse-role-definition define-role ;
SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ;
-
-
: omega0 ( -- omega0 ) 2 pi * T0 / ;
: theta ( -- theta ) current-time omega0 * cos theta0 * ;
-: relative-xy ( theta l -- xy )
+: relative-xy ( theta l -- xy )
[ [ sin ] [ cos ] bi ]
[ [ * ] curry ] bi* bi@ 2array ;
: theta-to-xy ( origin theta l -- xy ) relative-xy v+ ;
: window-l ( gadget -- l ) rect-bounds [ drop ] [ second ] bi* ;
: gadget-xy ( gadget -- xy ) [ O ] [ drop theta ] [ window-l ] tri theta-to-xy ;
-M: pendulum-gadget draw-gadget*
+M: pendulum-gadget draw-gadget*
COLOR: black gl-color
[ O ] [ gadget-xy ] bi gl-line ;
M: pendulum-gadget ungraft*
[ alarm>> stop-timer ] [ call-next-method ] bi ;
-: <pendulum-gadget> ( -- gadget )
- pendulum-gadget new
+: <pendulum-gadget> ( -- gadget )
+ pendulum-gadget new
{ 500 500 } >>pref-dim ;
: pendulum-main ( -- )
TUPLE: animated-label < label-control reversed alarm ;
: <animated-label> ( model -- <animated-model> )
- sentence animated-label new-label swap >>model
+ sentence animated-label new-label swap >>model
monospace-font >>font ;
: update-string ( str reverse -- str )
: points-to-lines ( seq -- seq )
dup rest [ 2array ] 2map ;
-: draw-lines ( {R,G,B} points image -- )
+: draw-lines ( {R,G,B} points image -- )
[ [ first2 ] dip draw-line ] curry with each ;
:: bezier-lines ( {R,G,B} P0 P1 P2 P3 image -- )
y0 :> y!
y0 y1 < [ 1 ystep! ] [ -1 ystep! ] if
x0 x1 1 <range> [
- y steep [ swap ] when 2array
- current-error deltaerr + current-error!
+ y steep [ swap ] when 2array
+ current-error deltaerr + current-error!
current-error 0.5 >= [
ystep y + y!
current-error 1 - current-error!
! Various utilities
: meach ( matrix quot -- ) [ each ] curry each ; inline
-: meach-index ( matrix quot -- )
+: meach-index ( matrix quot -- )
[ swap 2array ] prepose
[ curry each-index ] curry each-index ; inline
: mmap ( matrix quot -- matrix' ) [ map ] curry map ; inline
: mmap! ( matrix quot -- matrix' ) [ map! ] curry map! ; inline
-: mmap-index ( matrix quot -- matrix' )
+: mmap-index ( matrix quot -- matrix' )
[ swap 2array ] prepose
[ curry map-index ] curry map-index ; inline
: Mi,j ( {i,j} matrix -- elt ) [ first2 swap ] dip nth nth ;
! The storage functions
-: <raster-image> ( width height -- image )
+: <raster-image> ( width height -- image )
zero-matrix [ drop { 0 0 0 } ] mmap ;
-: fill-image ( {R,G,B} image -- image )
+: fill-image ( {R,G,B} image -- image )
swap '[ drop _ ] mmap! ;
: set-pixel ( {R,G,B} {i,j} image -- ) set-Mi,j ; inline
: get-pixel ( {i,j} image -- pixel ) Mi,j ; inline
write flush drop validate-readln ]
when ;
-: win ( -- ) "\nYou've won! Good job. You're so smart." print flush ;
+: win ( -- ) "\nYou've won! Good job. You're so smart." print flush ;
: main-loop ( x -- )
"Enter a 4 digit number: " write flush validate-readln num>hash swap
] while
p ;
-: gray-code-main ( -- )
+: gray-code-main ( -- )
-1 32 [a,b] [
dup [ >bin ] [ gray-encode ] bi
[ >bin ] [ gray-decode ] bi 4array .
" has length " write pprint "." print ;
MAIN: hailstone-main
-
h 2 3 5 [ '[ _ * ] lazy-map ] tri-curry@ tri
sort-merge sort-merge
] lazy-cons h! h ;
-
TUPLE: bw-noise-gadget < image-control timers cnt old-cnt fps-model ;
: animate-image ( control -- )
- [ 1 + ] change-cnt
+ [ 1 + ] change-cnt
model>> <random-bw-image> swap set-model ;
: update-cnt ( gadget -- )
M: bw-noise-gadget ungraft* [ stop-animation ] [ call-next-method ] bi ;
: <bw-noise-gadget> ( -- gadget )
- <random-bw-image> <model> bw-noise-gadget new-image-gadget*
+ <random-bw-image> <model> bw-noise-gadget new-image-gadget*
0 >>cnt 0 >>old-cnt 0 <model> >>fps-model V{ } clone >>timers ;
: fps-gadget ( model -- gadget )
: best-bounty ( -- bounty )
find-max-amounts [ 1 + iota ] map <product-sequence>
[ <bounty> ] [ max ] map-reduce ;
-
T{ item f "socks" 4 50 }
T{ item f "book" 30 10 }
}
-
+
CONSTANT: limit 400
-
+
: make-table ( -- table )
items length 1 + [ limit 1 + 0 <array> ] replicate ;
-
+
:: iterate ( item-no table -- )
item-no table nth :> prev
item-no 1 + table nth :> curr
: luhn? ( n -- ? )
luhn-digit 0 = ;
-
: odd-word ( string -- )
[ read-odd-word ] with-string-reader ;
-
10 [ dup print-cellular step ] times print-cellular ;
MAIN: main-cellular
-
-30.0 30.0 -30.0 30.0 -30.0 30.0 glOrtho
GL_MODELVIEW glMatrixMode ;
-: paint ( -- )
+: paint ( -- )
0.3 0.3 0.3 0.0 glClearColor
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
GL_SMOOTH glShadeModel
GL_TRIANGLES glBegin
1.0 0.0 0.0 glColor3f 0.0 0.0 glVertex2f
0.0 1.0 0.0 glColor3f 30.0 0.0 glVertex2f
- 0.0 0.0 1.0 glColor3f 0.0 30.0 glVertex2f
+ 0.0 0.0 1.0 glColor3f 0.0 30.0 glVertex2f
glEnd
glFlush ;
[ triangle-gadget new "Triangle" open-window ] with-ui ;
MAIN: triangle-window
-
: add-triplets ( current-triples limit triplet -- stop )
sum 2dup > [
/i [ + ] curry change-total
- [ 1 + ] change-primitives drop t
+ [ 1 + ] change-primitives drop t
] [ 3drop f ] if ;
: all-triplets ( current-triples limit seed -- triplets )
- 3dup add-triplets [
+ 3dup add-triplets [
candidates-triplets [ all-triplets ] with swapd reduce
] [ 2drop ] if ;
<0-triplets-count> swap base all-triplets ;
: pprint-triplet-count ( limit count -- )
- [ total>> ] [ primitives>> ] bi
+ [ total>> ] [ primitives>> ] bi
"Up to %d: %d triples, %d primitives.\n" printf ;
: pyth ( -- )
8 [1,b] [ 10^ dup count-triplets pprint-triplet-count ] each ;
-
-
! Timothy Grove,E16398,29900,D190
TUPLE: employee name id salary department ;
-
+
CONSTANT: employees {
T{ employee f "Tyler Bennett" "E10297" 32000 "D101" }
T{ employee f "John Rappl" "E21437" 47000 "D050" }
[ [ data>> ] dip call drop ]
[ drop left>> [ swap push-back ] [ drop ] if* ]
[ drop right>> [ swap push-back ] [ drop ] if* ]
- [ nip (levelorder) ]
+ [ nip (levelorder) ]
} 3cleave
] if ; inline recursive
-! Copyright (C) 2009 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: assocs help.markup help.syntax kernel strings ;\r
-IN: s3\r
-\r
-HELP: buckets\r
-{ $values \r
- { "seq" "a sequence of " { $link bucket } " objects" } \r
-}\r
-{ $description \r
- "Returns a list of " { $link bucket } " objects containing data on the buckets available on S3."}\r
-{ $examples\r
- { $unchecked-example "USING: s3 ;" "buckets ." "{ }" }\r
-}\r
-;\r
-\r
-HELP: create-bucket\r
-{ $values \r
- { "bucket" string } \r
-}\r
-{ $description \r
- "Creates a bucket with the given name."\r
-} \r
-{ $examples\r
- { $unchecked-example "USING: s3 ;" "\"testbucket\" create-bucket" "" }\r
-}\r
-;\r
-\r
-HELP: delete-bucket\r
-{ $values \r
- { "bucket" string } \r
-}\r
-{ $description \r
- "Deletes the bucket with the given name."\r
-} \r
-{ $examples\r
- { $unchecked-example "USING: s3 ;" "\"testbucket\" delete-bucket" "" }\r
-}\r
-;\r
-\r
-HELP: keys\r
-{ $values \r
- { "bucket" string } \r
- { "seq" "a sequence of " { $link key } " objects"} \r
-}\r
-{ $description \r
- "Returns a sequence of " { $link key } " objects. Each object in the sequence has information about the keys contained within the bucket."\r
-} \r
-{ $examples\r
- { $unchecked-example "USING: s3 ;" "\"testbucket\" keys . " "{ }" }\r
-}\r
-;\r
-\r
-HELP: get-object\r
-{ $values \r
- { "bucket" string }\r
- { "key" string }\r
- { "response" "The HTTP response object"}\r
- { "data" "The data returned from the http request"}\r
-}\r
-{ $description \r
- "Does an HTTP request to retrieve the object in the bucket with the given key."\r
-} \r
-{ $examples\r
- { $unchecked-example "USING: s3 ;" "\"testbucket\" \"mykey\" http-get " "" }\r
-}\r
-;\r
-\r
-HELP: put-object\r
-{ $values\r
- { "data" object }\r
- { "mime-type" string }\r
- { "bucket" string }\r
- { "key" string }\r
- { "headers" assoc }\r
-}\r
-{ $description \r
- "Stores the object under the key in the given bucket. The object has "\r
-"the given mimetype. 'headers' should contain key/values for any headers to "\r
-"be associated with the object. 'data' is any Factor object that can be "\r
-"used as the 'data' slot in <post-data>. If it's a <pathname> it stores "\r
-"the contents of the file. If it's a stream, it's the contents of the "\r
-"stream, etc."\r
-} \r
-{ $examples\r
- { $unchecked-example "USING: s3 ;" "\"hello\" binary encode \"text/plain\" \"testbucket\" \"hello.txt\" H{ { \"x-amz-acl\" \"public-read\" } } put-object" "" }\r
- { $unchecked-example "USING: s3 ;" "\"hello.txt\" <pathname> \"text/plain\" \"testbucket\" \"hello.txt\" H{ { \"x-amz-acl\" \"public-read\" } } put-object" "" }\r
-}\r
-;\r
-\r
-HELP: delete-object\r
-{ $values \r
- { "bucket" string }\r
- { "key" string }\r
-}\r
-{ $description \r
- "Deletes the object in the bucket with the given key."\r
-} \r
-{ $examples\r
- { $unchecked-example "USING: s3 ;" "\"testbucket\" \"mykey\" delete-object" "" }\r
-}\r
-;\r
-\r
-ARTICLE: "s3" "Amazon S3"\r
-"The " { $vocab-link "s3" } " vocabulary provides a wrapper to the Amazon "\r
-"Simple Storage Service API."\r
-$nl\r
-"To use the api you must set the variables " { $link key-id } " and " \r
-{ $link secret-key } " to your Amazon S3 key and secret key respectively. Once "\r
-"this is done you can call any of the words below."\r
-{ $subsections buckets\r
- create-bucket\r
- delete-bucket\r
- keys\r
- get-object\r
- put-object\r
- delete-object\r
-}\r
-;\r
-\r
-ABOUT: "s3"\r
+! Copyright (C) 2009 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel strings ;
+IN: s3
+
+HELP: buckets
+{ $values
+ { "seq" "a sequence of " { $link bucket } " objects" }
+}
+{ $description
+ "Returns a list of " { $link bucket } " objects containing data on the buckets available on S3."}
+{ $examples
+ { $unchecked-example "USING: s3 ;" "buckets ." "{ }" }
+}
+;
+
+HELP: create-bucket
+{ $values
+ { "bucket" string }
+}
+{ $description
+ "Creates a bucket with the given name."
+}
+{ $examples
+ { $unchecked-example "USING: s3 ;" "\"testbucket\" create-bucket" "" }
+}
+;
+
+HELP: delete-bucket
+{ $values
+ { "bucket" string }
+}
+{ $description
+ "Deletes the bucket with the given name."
+}
+{ $examples
+ { $unchecked-example "USING: s3 ;" "\"testbucket\" delete-bucket" "" }
+}
+;
+
+HELP: keys
+{ $values
+ { "bucket" string }
+ { "seq" "a sequence of " { $link key } " objects"}
+}
+{ $description
+ "Returns a sequence of " { $link key } " objects. Each object in the sequence has information about the keys contained within the bucket."
+}
+{ $examples
+ { $unchecked-example "USING: s3 ;" "\"testbucket\" keys . " "{ }" }
+}
+;
+
+HELP: get-object
+{ $values
+ { "bucket" string }
+ { "key" string }
+ { "response" "The HTTP response object"}
+ { "data" "The data returned from the http request"}
+}
+{ $description
+ "Does an HTTP request to retrieve the object in the bucket with the given key."
+}
+{ $examples
+ { $unchecked-example "USING: s3 ;" "\"testbucket\" \"mykey\" http-get " "" }
+}
+;
+
+HELP: put-object
+{ $values
+ { "data" object }
+ { "mime-type" string }
+ { "bucket" string }
+ { "key" string }
+ { "headers" assoc }
+}
+{ $description
+ "Stores the object under the key in the given bucket. The object has "
+"the given mimetype. 'headers' should contain key/values for any headers to "
+"be associated with the object. 'data' is any Factor object that can be "
+"used as the 'data' slot in <post-data>. If it's a <pathname> it stores "
+"the contents of the file. If it's a stream, it's the contents of the "
+"stream, etc."
+}
+{ $examples
+ { $unchecked-example "USING: s3 ;" "\"hello\" binary encode \"text/plain\" \"testbucket\" \"hello.txt\" H{ { \"x-amz-acl\" \"public-read\" } } put-object" "" }
+ { $unchecked-example "USING: s3 ;" "\"hello.txt\" <pathname> \"text/plain\" \"testbucket\" \"hello.txt\" H{ { \"x-amz-acl\" \"public-read\" } } put-object" "" }
+}
+;
+
+HELP: delete-object
+{ $values
+ { "bucket" string }
+ { "key" string }
+}
+{ $description
+ "Deletes the object in the bucket with the given key."
+}
+{ $examples
+ { $unchecked-example "USING: s3 ;" "\"testbucket\" \"mykey\" delete-object" "" }
+}
+;
+
+ARTICLE: "s3" "Amazon S3"
+"The " { $vocab-link "s3" } " vocabulary provides a wrapper to the Amazon "
+"Simple Storage Service API."
+$nl
+"To use the api you must set the variables " { $link key-id } " and "
+{ $link secret-key } " to your Amazon S3 key and secret key respectively. Once "
+"this is done you can call any of the words below."
+{ $subsections buckets
+ create-bucket
+ delete-bucket
+ keys
+ get-object
+ put-object
+ delete-object
+}
+;
+
+ABOUT: "s3"
: signature ( s3-request -- string )
[
- {
+ {
[ method>> % "\n" % "\n" % ]
[ mime-type>> % "\n" % ]
[ date>> timestamp>rfc822 % "\n" % ]
: s3-url ( s3-request -- string )
[
- "http://" %
- dup bucket>> [ % "." % ] when*
+ "http://" %
+ dup bucket>> [ % "." % ] when*
"s3.amazonaws.com" %
path>> %
] "" make ;
swap sign "Authorization" set-header ;
: s3-get ( bucket path headers -- request data )
- "GET" <s3-request> dup s3-url <get-request>
+ "GET" <s3-request> dup s3-url <get-request>
sign-http-request http-request ;
: s3-put ( data bucket path headers -- request data )
- "PUT" <s3-request> dup s3-url swapd <put-request>
+ "PUT" <s3-request> dup s3-url swapd <put-request>
sign-http-request http-request ;
PRIVATE>
<PRIVATE
: (buckets) ( xml -- seq )
- "Buckets" tag-named
+ "Buckets" tag-named
"Bucket" tags-named [
- [ "Name" tag-named children>string ]
+ [ "Name" tag-named children>string ]
[ "CreationDate" tag-named children>string ] bi bucket boa
] map ;
PRIVATE>
-
+
: buckets ( -- seq )
f "/" H{ } clone s3-get nip >string string>xml (buckets) ;
"" swap "/" H{ } clone "PUT" <s3-request>
"application/octet-stream" >>mime-type
dup s3-url swapd <put-request>
- 0 "content-length" set-header
+ 0 "content-length" set-header
sign-http-request
http-request 2drop ;
dup s3-url <delete-request> sign-http-request http-request 2drop ;
: put-object ( data mime-type bucket key headers -- )
- [ "/" prepend ] dip "PUT" <s3-request>
+ [ "/" prepend ] dip "PUT" <s3-request>
over >>mime-type
[ <post-data> swap >>data ] dip
- dup s3-url swapd <put-request>
+ dup s3-url swapd <put-request>
dup header>> pick headers>> assoc-union >>header
- sign-http-request
+ sign-http-request
http-request 2drop ;
: delete-object ( bucket key -- )
M: replacer new-sequence
underlying>> [ set-length ] keep ; inline
-
PRIVATE>
-INSTANCE: n-based-assoc assoc
+INSTANCE: n-based-assoc assoc
M: n-based-assoc at* ( key assoc -- value ? )
n-based@ 2dup bounds-check?
[ nth-unsafe t ] [ 2drop f f ] if ;
update-tuple ;
: sites-to-report ( -- seq )
- "select users.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from users, site, watching_site where users.username = watching_site.account_name and site.site_id = watching_site.site_id and site.changed = '1'" sql-query
+ "select users.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from users, site, watching_site where users.username = watching_site.account_name and site.site_id = watching_site.site_id and site.changed = '1'" sql-query
[ [ reporting-site boa ] input<sequence ] map
"update site set changed = 0;" sql-command ;
[ account>> email>> ] 2dip
pick [
[ <email> site-watcher-from get >>from ] 3dip
- [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
+ [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
] [ 3drop ] if ;
SYMBOL: site-watcher-frequency
5 minutes site-watcher-frequency set-global
-
+
SYMBOL: running-site-watcher
[ f running-site-watcher set-global ] "site-watcher" add-startup-hook
find-sites check-sites sites-to-report send-reports ;
: run-site-watcher ( db -- )
- [ running-site-watcher get ] dip '[
+ [ running-site-watcher get ] dip '[
[ _ [ watch-sites ] with-db ] site-watcher-frequency get every
running-site-watcher set
] unless ;
send-site-email ;
: spider-sites ( -- )
- f spidering-sites [ spider-and-email ] parallel-each ;
\ No newline at end of file
+ f spidering-sites [ spider-and-email ] parallel-each ;
: set-slot* ( tuple value name -- tuple )
swapd '[ _ set-slot ] keep ; inline
-: change-slot* ( tuple name quot: ( ..a old -- ..b new ) -- ..b tuple )
+: change-slot* ( tuple name quot: ( ..a old -- ..b new ) -- ..b tuple )
'[ _ _ change-slot ] keep ; inline
! Multiple-slot accessors
: >>writer-word ( name -- word )
">>" prepend "accessors" lookup-word ;
-
+
: writer-word<< ( name -- word )
">>" prepend "accessors" lookup-word ;
[ writer-word<< 1quotation ] bi append
] map-tokens
'[ swap _ cleave ] append! ;
-
+
SYNTAX: get[ POSTPONE: slots[ ;
SYNTAX: get{ POSTPONE: slots{ ;
SYNTAX: set[ POSTPONE: set-slots[ ;
self suffix <ast-block> ast-method boa ;
TUPLE: symbol { name string } ;
-MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
+MEMO: intern ( name -- symbol ) symbol boa ;
M: array assigned-locals
[ assigned-locals ] map concat ;
-M: object assigned-locals drop f ;
\ No newline at end of file
+M: object assigned-locals drop f ;
nip
[
[ name>> ] [ superclass>> ] [ ivars>> ] tri
- define-class <class-lexenv>
+ define-class <class-lexenv>
]
[ methods>> ] bi
[ compile-method ] with each
[ local-writer ]
[ ivar-writer ]
[ drop bad-identifier ]
- } 2|| ;
\ No newline at end of file
+ } 2|| ;
block need-return-continuation? [
quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
n '[ _ _ ncurry callcc1 ]
- ] [ quot ] if rewrite-closures first ;
\ No newline at end of file
+ ] [ quot ] if rewrite-closures first ;
SELECTOR: time
-M: object selector-time '[ _ call( -- result ) ] time ;
\ No newline at end of file
+M: object selector-time '[ _ call( -- result ) ] time ;
"Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
[ eval-interactively smalltalk-listener ] when* ;
-MAIN: smalltalk-listener
\ No newline at end of file
+MAIN: smalltalk-listener
M: symbol smalltalk>string
name>> smalltalk>string "#" prepend ;
-M: object smalltalk>string unparse-short ;
\ No newline at end of file
+M: object smalltalk>string unparse-short ;
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.syntax help.markup cpu.8080.emulator ;\r
-IN: space-invaders \r
-\r
-HELP: run-invaders\r
-{ $description \r
-"Run the Space Invaders emulator in a new window." $nl\r
-{ $link rom-root } " must be set to the directory containing the "\r
-"location of the Space Invaders ROM files. See " \r
-{ $link { "space-invaders" "space-invaders" } } " for details."\r
-} ;\r
-\r
-ARTICLE: { "space-invaders" "space-invaders" } "Space Invaders Emulator"\r
-"Provides an emulation of the original 8080 Arcade Game 'Space Invaders'." $nl\r
-"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/invaders" } "." $nl\r
-"To play the game you need the ROM files for the arcade game. They should "\r
-"be placed in a directory called 'invaders' in the location specified by "\r
-"the variable " { $link rom-root } ". The specific files needed are:"\r
-{ $list\r
- "invaders/invaders.e"\r
- "invaders/invaders.f"\r
- "invaders/invaders.g"\r
- "invaders/invaders.h"\r
-}\r
-"These are the same ROM files as used by MAME. To run the game use the " \r
-{ $link run-invaders } " word." $nl\r
-"Keys:" \r
-{ $table\r
- { "Backspace" "Insert Coin" }\r
- { "1" "1 Player" }\r
- { "2" "2 Player" }\r
- { "Left" "Move Left" }\r
- { "Right" "Move Right" }\r
- { "Up" "Fire" }\r
-}\r
-"If you save the Factor image while a game is running, when you restart "\r
-"the image the game continues where it left off." ;\r
-\r
-ABOUT: { "space-invaders" "space-invaders" } \r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup cpu.8080.emulator ;
+IN: space-invaders
+
+HELP: run-invaders
+{ $description
+"Run the Space Invaders emulator in a new window." $nl
+{ $link rom-root } " must be set to the directory containing the "
+"location of the Space Invaders ROM files. See "
+{ $link { "space-invaders" "space-invaders" } } " for details."
+} ;
+
+ARTICLE: { "space-invaders" "space-invaders" } "Space Invaders Emulator"
+"Provides an emulation of the original 8080 Arcade Game 'Space Invaders'." $nl
+"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/invaders" } "." $nl
+"To play the game you need the ROM files for the arcade game. They should "
+"be placed in a directory called 'invaders' in the location specified by "
+"the variable " { $link rom-root } ". The specific files needed are:"
+{ $list
+ "invaders/invaders.e"
+ "invaders/invaders.f"
+ "invaders/invaders.g"
+ "invaders/invaders.h"
+}
+"These are the same ROM files as used by MAME. To run the game use the "
+{ $link run-invaders } " word." $nl
+"Keys:"
+{ $table
+ { "Backspace" "Insert Coin" }
+ { "1" "1 Player" }
+ { "2" "2 Player" }
+ { "Left" "Move Left" }
+ { "Right" "Move Right" }
+ { "Up" "Fire" }
+}
+"If you save the Factor image while a game is running, when you restart "
+"the image the game continues where it left off." ;
+
+ABOUT: { "space-invaders" "space-invaders" }
[ [ 1 + ] dip nth ]
[ [ 2 + ] dip nth ] 2tri 3array ;
-CONSTANT: SOUND-SHOT 0
-CONSTANT: SOUND-UFO 1
-CONSTANT: SOUND-BASE-HIT 2
-CONSTANT: SOUND-INVADER-HIT 3
-CONSTANT: SOUND-WALK1 4
+CONSTANT: SOUND-SHOT 0
+CONSTANT: SOUND-UFO 1
+CONSTANT: SOUND-BASE-HIT 2
+CONSTANT: SOUND-INVADER-HIT 3
+CONSTANT: SOUND-WALK1 4
CONSTANT: SOUND-WALK2 5
-CONSTANT: SOUND-WALK3 6
-CONSTANT: SOUND-WALK4 7
-CONSTANT: SOUND-UFO-HIT 8
+CONSTANT: SOUND-WALK3 6
+CONSTANT: SOUND-WALK4 7
+CONSTANT: SOUND-UFO-HIT 8
: init-sound ( index cpu filename -- )
absolute-path swapd [ sounds>> nth AL_BUFFER ] dip
: read-port3 ( cpu -- byte )
#! Used to compute a special formula
- [ port4hi>> 8 shift ] keep
- [ port4lo>> bitor ] keep
+ [ port4hi>> 8 shift ] keep
+ [ port4lo>> bitor ] keep
port2o>> shift -8 shift 0xFF bitand ;
M: space-invaders read-port
0 >>port3o
0 >>port4lo
0 >>port4hi
- 0 >>port5o
+ 0 >>port5o
drop ;
: gui-step ( cpu -- )
[ read-instruction ] keep ! n cpu
over get-cycles over inc-cycles
- [ swap instructions nth call( cpu -- ) ] keep
- [ pc>> 0xFFFF bitand ] keep
+ [ swap instructions nth call( cpu -- ) ] keep
+ [ pc>> 0xFFFF bitand ] keep
pc<< ;
: gui-frame/2 ( cpu -- )
{ T{ key-up f f "RIGHT" } [ cpu>> right-up ] }
} set-gestures
-: <invaders-gadget> ( cpu -- gadget )
+: <invaders-gadget> ( cpu -- gadget )
invaders-gadget new
swap >>cpu
f >>quit? ;
PREDICATE: specialized-word < word
"specialized-defs" word-prop >boolean ;
-
{
float distance_factor = (gl_FragCoord.z * 0.5 + 0.5);
distance_factor = pow(distance_factor, 500.0)*0.5;
-
+
gl_FragColor = checker_color(object_position)
? mix(checker_color_1, checker_color_2, distance_factor)
: mix(checker_color_2, checker_color_1, distance_factor);
{
world_position = gl_ModelViewMatrix * vec4(center, 1);
sphere_position = gl_Vertex.xyz;
-
+
gl_Position = gl_ProjectionMatrix * (world_position + vec4(sphere_position * radius, 0));
-
+
vcolor = surface_color;
vradius = radius;
}
vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz;
vec3 direction = normalize(transformed_light_position - point);
float d = max(0.0, dot(normal, direction));
-
+
return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a);
}
;
{ "GL_EXT_framebuffer_object" } require-gl-extensions
GL_DEPTH_TEST glEnable
GL_VERTEX_ARRAY glEnableClientState
- 0.15 0.15 1.0 1.0 glClearColor
+ 0.15 0.15 1.0 1.0 glClearColor
20.0 10.0 20.0 set-demo-orientation
(plane-program) >>plane-program
(solid-sphere-program) >>solid-sphere-program
program "center" glGetAttribLocation center first3 glVertexAttrib3f
program "radius" glGetAttribLocation radius glVertexAttrib1f
{ -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect ;
-
+
:: (draw-colored-sphere) ( program center radius surfacecolor -- )
program "surface_color" glGetAttribLocation surfacecolor first4 glVertexAttrib4f
program center radius (draw-sphere) ;
first4 swapd [ 2array ] 2dip 2array 2array
] if-empty
] bi*
- ]
+ ]
[ 2 tail "\n" join ] tri srt-chunk boa ;
: parse-srt-lines ( seq -- seq' )
: ?send-buffer ( buffer -- buffer )
dup id>> [ send-buffer ] unless ;
-
: >note ( harmonics note buffer -- buffer )
[ [ note-harmonic-data ] 2curry map <summed> ] [ data<< ] [ ] tri ;
-
: total-withholding ( salary w4 tax-table -- x )
dup entity>> dup federal = [
- withholding*
+ withholding*
] [
drop
[ drop <federal> federal withholding* ]
: allowance ( -- x ) 3500 ; inline
: calculate-w4-allowances ( w4 -- x ) allowances>> allowance * ;
-
{ $code "5 9 [ sq ] bi@" }
}
{ $slide "Sequence combinators"
-
+
{ $link each }
{ $code "{ 1 2 3 4 5 } [ sq . ] each" }
{ $link map }
{ $code "{ 1 2 3 4 5 } [ even? ] filter" }
}
{ $slide "Multiple sequence combinators"
-
+
{ $link 2each }
{ $code "{ 1 2 3 } { 10 20 30 } [ + . ] 2each" }
{ $link 2map }
TUPLE: terrain
{ big-noise-table byte-array }
{ small-noise-table byte-array }
- { tiny-noise-seed integer } ;
+ { tiny-noise-seed integer } ;
: <terrain> ( -- terrain )
<perlin-noise-table> <perlin-noise-table>
: big-noise-segment ( terrain at -- bytes )
[ big-noise-table>> terrain-big-noise-scale scale-matrix4 ] dip
- terrain-segment-size-vector v* translation-matrix4 m4.
+ terrain-segment-size-vector v* translation-matrix4 m4.
terrain-segment-size perlin-noise-image bitmap>> ; inline
: small-noise-segment ( terrain at -- bytes )
[ small-noise-table>> terrain-small-noise-scale scale-matrix4 ] dip
- terrain-segment-size-vector v* translation-matrix4 m4.
+ terrain-segment-size-vector v* translation-matrix4 m4.
terrain-segment-size perlin-noise-image bitmap>> ; inline
: tiny-noise-segment ( terrain at -- bytes )
[ tiny-noise-seed>> ] dip seed-at
vec4 p = gl_ProjectionMatrixInverse * v;
p.z = -abs(p.z);
-
+
float s = sin(sky_theta), c = cos(sky_theta);
direction = mat3(1, 0, 0, 0, c, s, 0, -s, c)
* (gl_ModelViewMatrixInverse * vec4(p.xyz, 0.0)).xyz;
[ second swap rows>> nth ] keep first swap ;
: set-block ( board block colour -- ) -rot board@block set-nth ;
-
+
: block ( board block -- colour ) board@block nth ;
: block-free? ( board block -- ? ) block not ;
#! remove full rows, then add blank ones at the top, returning the number
#! of rows removed (and added)
remove-full-rows dup height>> over rows>> length - swap top-up-rows ;
-
: <tetris> ( width height -- tetris )
dupd <board> swap <piece-llist>
tetris new swap >>pieces swap >>board ;
-
+
: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
: <new-tetris> ( old -- new )
[ next-piece draw-next-piece ]
[ current-piece draw-piece ]
} cleave
- ] do-matrix ;
\ No newline at end of file
+ ] do-matrix ;
M: tetris-gadget ungraft* ( gadget -- )
[ stop-timer f ] change-timer drop ;
-: tetris-window ( -- )
+: tetris-window ( -- )
[
<default-tetris> <tetris-gadget>
"Tetris" open-status-window
[
{ {
{ 0 0 } { 1 0 } { 2 0 } { 3 0 }
- }
+ }
{ { 0 0 }
{ 0 1 }
{ 0 2 }
}
} COLOR: orange
] [
- {
+ {
{ { 0 0 } { 1 0 } { 2 0 }
{ 2 1 }
} {
: blocks-height ( blocks -- height )
[ second ] blocks-max ;
-
: file-to-pdf ( path encoding -- )
[ file-contents text-to-pdf ]
[ [ ".pdf" append ] dip set-file-contents ] 2bi ;
-
] [
timeval>duration since-1970 now time-
] if ;
-
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar.windows system time windows.errors
+USING: calendar.windows system time windows.errors
windows.kernel32 kernel classes.struct calendar ;
IN: time.windows
: >tnetstring ( value -- string )
dump-tnetstring ;
-
command-line get [ cat-lines ] [ cat-files ] if-empty ;
MAIN: run-cat
-
CONSTANT: norton-dns-servers { "198.153.192.1" "198.153.194.1" }
: norton-host ( domain -- ) [ norton-dns-servers ] dip dns-host ;
-CONSTANT: verizon-dns-servers {
+CONSTANT: verizon-dns-servers {
"4.2.2.1"
"4.2.2.2"
"4.2.2.3"
! Add a valid point if the mouse is in the gadget
! Otherwise, add an "invisible" point
-
+
hand-gadget get GADGET =
[ mouse GADGET points>> circular-push ]
[ { -10 -10 } GADGET points>> circular-push ]
[ node+link ]
[ node-link ]
[ set-node+link ] tri
- [ set-node-link ] keep ;
+ [ set-node-link ] keep ;
: single-rotate ( node -- node )
0 >>balance
- 0 over node+link
+ 0 over node+link
balance<< rotate ;
: pick-balances ( a node -- balance balance )
: user-image ( user -- image/f )
profile-image-url>> load-http-image ;
-CONSTANT: tweet-table-style
- H{ { table-gap { 5 5 } } }
+CONSTANT: tweet-table-style
+ H{ { table-gap { 5 5 } } }
-CONSTANT: tweet-username-style
+CONSTANT: tweet-username-style
H{
{ font-style bold }
- }
+ }
-CONSTANT: tweet-text-style
+CONSTANT: tweet-text-style
H{
{ font-name "sans-serif" }
{ font-size 16 }
{ wrap-margin 500 }
- }
+ }
CONSTANT: tweet-metadata-style
H{
{ font-size 10 }
- }
+ }
: profile. ( user -- )
tweet-table-style [
dup source>> write
] with-style
] with-style
- ] with-nesting
+ ] with-nesting
] with-cell
] with-row
] tabular-output nl
screen-name
description
location
- profile-image-url
+ profile-image-url
url
protected?
followers-count ;
} twitter-user keys-boa ;
: <twitter-status> ( assoc -- tweet )
- clone "user" over [ <twitter-user> ] change-at
+ clone "user" over [ <twitter-user> ] change-at
{
"created_at"
"id"
: into-window ( world quot -- world )
[ dup ] dip with-gl-context ; inline
-
-
{ 5 5 } >>gap
COLOR: blue <grid-lines> >>boundary
add-gadget ;
-
+
: ui-render-test ( -- )
<ui-render-test> "Test" open-window ;
SYMBOLS: width height ;
: store-dim ( gadget -- ) dim>> [ first width set ] [ second height set ] bi ;
: with-dim ( gadget quot -- ) '[ _ store-dim @ ] with-scope ; inline
-: with-w/h ( gadget quot -- ) '[ origin get _ with-translation ] with-dim ; inline
\ No newline at end of file
+: with-w/h ( gadget quot -- ) '[ origin get _ with-translation ] with-dim ; inline
! : c 299792458 m/s ;
! : c0 299792458 m/s ; ! same as c
! : c-vacuum 299792458 m/s ; ! same as c
-!
+!
! ! more to come
-!
+!
! : avogadro
! 6.02214179e23 { } { mol } <dimensioned> ;
-
: imperial-gill ( n -- dimensioned ) 5 * imperial-fluid-ounces ;
-: dry-gallons ( n -- dimensioned ) 440488377086/100000000000 * L ;
+: dry-gallons ( n -- dimensioned ) 440488377086/100000000000 * L ;
: dry-quarts ( n -- dimensioned ) 1/4 * dry-gallons ;
: backup-boot-image ( -- )
my-boot-image-name
- { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string
+ { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string
move-file ;
: backup-image ( -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-MAIN: update-latest
\ No newline at end of file
+MAIN: update-latest
} 2cleave (define-variable) ;
SYNTAX: TYPED-VAR:
- scan-new-word scan-object define-typed-variable ;
+ scan-new-word scan-object define-typed-variable ;
M: typed-variable definer drop \ TYPED-VAR: f ;
M: typed-variable definition "variable-type" word-prop 1quotation ;
scan-new-word scan-object define-typed-global ;
M: typed-global-variable definer drop \ TYPED-GLOBAL: f ;
-
MACRO: match ( branches -- )
[ dup callable? [ first2 (match-branch) 2array ] unless ] map
[ \ dup \ ?class ] dip \ case [ ] 4sequence ;
-
ERROR: git-revision-not-found path ;
: use-vocab-rev ( vocab-name rev -- )
- [ create-vocab vocab-source-path dup ] dip git-object-id
+ [ create-vocab vocab-source-path dup ] dip git-object-id
[ [ input-stream get swap parse-stream call( -- ) ] with-git-object-stream ]
[ git-revision-not-found ] if* ;
! Copyright (C) 2008 Chris Double. All Rights Reserved.
-USING:
+USING:
accessors
fjsc
furnace
namespaces
peg
sequences
- urls
+ urls
validators
;
IN: webapps.fjsc
TUPLE: fjsc < dispatcher ;
: absolute-url ( url -- url )
- "http://" request get "host" header append
- over "/" head? [ "/" append ] unless
+ "http://" request get "host" header append
+ over "/" head? [ "/" append ] unless
swap append ;
: <javascript-content> ( body -- content )
<compile-action> "compile" add-responder
<compile-url-action> "compile-url" add-responder
<boilerplate>
- { fjsc "fjsc" } >>template
+ { fjsc "fjsc" } >>template
>>default ;
: activate-fjsc ( -- )
USING: accessors furnace.actions furnace.redirection
html.forms http http.server http.server.dispatchers
io.directories io.encodings.utf8 io.files io.pathnames
-kernel math.parser multiline namespaces sequences urls
+kernel math.parser multiline namespaces sequences urls
math ;
IN: webapps.imagebin
: next-image-path ( -- path )
imagebin get
- [ path>> ] [ [ 1 + ] change-n n>> number>string ] bi append-path ;
+ [ path>> ] [ [ 1 + ] change-n n>> number>string ] bi append-path ;
M: imagebin call-responder*
[ imagebin set ] [ call-next-method ] bi ;
TUPLE: irclog-app < dispatcher ;
-: irc-link ( channel -- string )
+: irc-link ( channel -- string )
gmt -7 hours convert-timezone >date<
[ unparse 2 tail ] 2dip
"http://bespin.org/~nef/logs/%s/%02s.%02d.%02d"
sprintf ;
-
+
: <display-irclog-action> ( -- action )
<action>
[ "concatenative" irc-link <redirect> ] >>display ;
site-list-url <redirect>
] >>submit
<protected>
- "spider sites" >>description ;
\ No newline at end of file
+ "spider sites" >>description ;
site-list-url <redirect>
] >>submit
<protected>
- "check watched sites" >>description ;
\ No newline at end of file
+ "check watched sites" >>description ;
validate-integer-id
"id" value <todo> select-tuple from-object
] >>init
-
+
{ todo-list "view-todo" } >>template ;
: validate-todo ( -- )
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math.ranges sequences random accessors
+USING: math.ranges sequences random accessors
kernel namespaces fry db.types db.tuples urls validators
html.components html.forms http http.server.dispatchers furnace
-furnace.actions furnace.boilerplate furnace.redirection
+furnace.actions furnace.boilerplate furnace.redirection
furnace.utilities continuations ;
IN: webapps.wee-url
] >>init
{ wiki "view" } >>template
-
+
<article-boilerplate> ;
: <random-article-action> ( -- action )
[ add-revision ]
[ title>> revisions-url <redirect> ] bi
] >>submit
-
+
<protected>
"rollback wiki articles" >>description ;
SYMBOL: *wordtimes*
SYMBOL: *calling*
-: reset-word-timer ( -- )
+: reset-word-timer ( -- )
H{ } clone *wordtimes* set-global
H{ } clone *calling* set-global ;
[ timed-call ] [ drop call ] if ; inline
: (add-timer) ( word quot -- quot' )
- [ swap time-unless-recursing ] 2curry ;
+ [ swap time-unless-recursing ] 2curry ;
: add-timer ( word -- )
dup '[ [ _ ] dip (add-timer) ] annotate ;
swap [ * - ] keep 2array ;
: (correct-for-timing-overhead) ( timingshash -- timingshash )
- time-dummy-word [ subtract-overhead ] curry assoc-map ;
+ time-dummy-word [ subtract-overhead ] curry assoc-map ;
: correct-for-timing-overhead ( -- )
*wordtimes* [ (correct-for-timing-overhead) ] change-global ;
*wordtimes* get-global [ swap suffix ] { } assoc>map natural-sort reverse pprint ;
: wordtimer-call ( quot -- )
- reset-word-timer
+ reset-word-timer
benchmark [
correct-for-timing-overhead
"total time:" write
! Set this value to keep libyaml's default
SYMBOL: +libyaml-default+
-{
+{
emitter-canonical
emitter-indent
emitter-width
: raw-zone-map ( -- assoc )
zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
-
+
GENERIC: zone-matches? ( string rule -- ? )
M: raw-rule zone-matches? name>> = ;
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-namespaces\r
-accessors\r
-assocs\r
-make\r
-math\r
-math.functions\r
-math.trig\r
-math.parser\r
-hashtables\r
-sequences\r
-combinators\r
-continuations\r
-colors\r
-colors.constants\r
-prettyprint\r
-vars\r
-quotations\r
-io\r
-io.directories\r
-io.pathnames\r
-help.markup\r
-io.files\r
-ui.gadgets.panes\r
- ui\r
- ui.gadgets\r
- ui.traverse\r
- ui.gadgets.borders\r
- ui.gadgets.frames\r
- ui.gadgets.tracks\r
- ui.gadgets.labels\r
- ui.gadgets.labeled \r
- ui.gadgets.lists\r
- ui.gadgets.buttons\r
- ui.gadgets.packs\r
- ui.gadgets.grids\r
- ui.gadgets.corners\r
- ui.gestures\r
- ui.gadgets.scrollers\r
-splitting\r
-vectors\r
-math.vectors\r
-values\r
-4DNav.turtle\r
-4DNav.window3D\r
-4DNav.deep\r
-4DNav.space-file-decoder\r
-models\r
-fry\r
-adsoda\r
-adsoda.tools\r
-;\r
-QUALIFIED-WITH: ui.pens.solid s\r
-QUALIFIED-WITH: ui.gadgets.wrappers w\r
-\r
-\r
-IN: 4DNav\r
-VALUE: selected-file\r
-VALUE: translation-step\r
-VALUE: rotation-step\r
-\r
-3 \ translation-step set-value\r
-5 \ rotation-step set-value\r
-\r
-VAR: selected-file-model\r
-VAR: observer3d \r
-VAR: view1 \r
-VAR: view2\r
-VAR: view3\r
-VAR: view4\r
-VAR: present-space\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-! namespace utilities\r
-\r
-: closed-quot ( quot -- quot )\r
- namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! waiting for deep-cleave-quots\r
-\r
-: 4D-Rxy ( angle -- Rx ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , dup cos , dup sin neg ,\r
- 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rxz ( angle -- Ry ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , dup cos , 0.0 , dup sin neg ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rxw ( angle -- Rz ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , dup cos , dup sin neg , 0.0 ,\r
- 0.0 , dup sin , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-: 4D-Ryz ( angle -- Rx ) deg>rad\r
-[ dup cos , 0.0 , 0.0 , dup sin neg ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Ryw ( angle -- Ry ) deg>rad\r
-[ dup cos , 0.0 , dup sin neg , 0.0 ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- dup sin , 0.0 , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rzw ( angle -- Rz ) deg>rad\r
-[ dup cos , dup sin neg , 0.0 , 0.0 ,\r
- dup sin , dup cos , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! UI\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: button* ( string quot -- button ) \r
- closed-quot <repeat-button> ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: model-projection-chooser ( -- gadget )\r
- observer3d> projection-mode>>\r
- { { 1 "perspective" } { 0 "orthogonal" } } \r
- <radio-buttons> ;\r
-\r
-: collision-detection-chooser ( -- gadget )\r
- observer3d> collision-mode>>\r
- { { t "on" } { f "off" } } <radio-buttons> ;\r
-\r
-: model-projection ( x -- space ) \r
- present-space> swap space-project ;\r
-\r
-: update-observer-projections ( -- )\r
- view1> relayout-1 \r
- view2> relayout-1 \r
- view3> relayout-1 \r
- view4> relayout-1 ;\r
-\r
-: update-model-projections ( -- )\r
- 0 model-projection <model> view1> model<<\r
- 1 model-projection <model> view2> model<<\r
- 2 model-projection <model> view3> model<<\r
- 3 model-projection <model> view4> model<< ;\r
-\r
-: camera-action ( quot -- quot ) \r
- '[ drop _ observer3d> \r
- with-self update-observer-projections ] \r
- closed-quot ;\r
-\r
-: win3D ( text gadget -- ) \r
- "navigateur 4D : " rot append open-window ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! 4D object manipulation\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: (mvt-4D) ( quot -- ) \r
- present-space> \r
- swap call space-ensure-solids \r
- >present-space \r
- update-model-projections \r
- update-observer-projections ; inline\r
-\r
-: rotation-4D ( m -- ) \r
- '[ _ [ [ middle-of-space dup vneg ] keep \r
- swap space-translate ] dip\r
- space-transform \r
- swap space-translate\r
- ] (mvt-4D) ;\r
-\r
-: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! menu\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: menu-rotations-4D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- <pile> 1 >>fill\r
- "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] \r
- button* add-gadget\r
- "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] \r
- button* add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] \r
- button* add-gadget\r
- "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] \r
- button* add-gadget \r
- @top grid-add \r
- <pile> 1 >>fill\r
- "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] \r
- button* add-gadget\r
- "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] \r
- button* add-gadget \r
- @center grid-add\r
- <pile> 1 >>fill\r
- "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] \r
- button* add-gadget\r
- "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] \r
- button* add-gadget \r
- @top-right grid-add \r
- <pile> 1 >>fill\r
- "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] \r
- button* add-gadget\r
- "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] \r
- button* add-gadget \r
- @right grid-add \r
- <pile> 1 >>fill\r
- "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] \r
- button* add-gadget\r
- "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] \r
- button* add-gadget \r
- @bottom-right grid-add \r
-;\r
-\r
-: menu-translations-4D ( -- gadget )\r
- 3 3 <frame> \r
- { 1 1 } >>filled-cell\r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill \r
- "X+" [ drop { 1 0 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "X-" [ drop { -1 0 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- "YZW" <label> add-gadget\r
- @bottom-right grid-add\r
- <pile> 1 >>fill\r
- "XZW" <label> add-gadget\r
- <shelf> 1 >>fill\r
- "Y+" [ drop { 0 1 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "Y-" [ drop { 0 -1 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- @top-right grid-add\r
- <pile> 1 >>fill\r
- "XYW" <label> add-gadget\r
- <shelf> 1 >>fill\r
- "Z+" [ drop { 0 0 1 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "Z-" [ drop { 0 0 -1 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill\r
- "W+" [ drop { 0 0 0 1 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "W-" [ drop { 0 0 0 -1 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- "XYZ" <label> add-gadget\r
- @bottom-left grid-add \r
- "X" <label> @center grid-add\r
-;\r
-\r
-: menu-4D ( -- gadget ) \r
- <shelf> \r
- "rotations" <label> add-gadget\r
- menu-rotations-4D add-gadget\r
- "translations" <label> add-gadget\r
- menu-translations-4D add-gadget\r
- 0.5 >>align\r
- { 0 10 } >>gap\r
-;\r
-\r
-\r
-! ------------------------------------------------------\r
-\r
-: redraw-model ( space -- )\r
- >present-space \r
- update-model-projections \r
- update-observer-projections ;\r
-\r
-: load-model-file ( -- )\r
- selected-file dup selected-file-model> set-model \r
- read-model-file \r
- redraw-model ;\r
-\r
-: mvt-3D-X ( turn pitch -- quot )\r
- '[ turtle-pos> norm neg reset-turtle \r
- _ turn-left \r
- _ pitch-up \r
- step-turtle ] ;\r
-\r
-: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline\r
-: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline\r
-: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline\r
-: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline\r
-\r
-: camera-button ( string quot -- button ) \r
- [ <label> ] dip camera-action <repeat-button> ;\r
-\r
-! ----------------------------------------------------------\r
-! file chooser\r
-! ----------------------------------------------------------\r
-: <run-file-button> ( file-name -- button )\r
- dup '[ drop _ \ selected-file set-value load-model-file \r
- ] \r
- closed-quot <roll-button> { 0 0 } >>align ;\r
-\r
-: <list-runner> ( -- gadget )\r
- "resource:extra/4DNav" \r
- <pile> 1 >>fill \r
- over dup directory-files \r
- [ ".xml" tail? ] filter \r
- [ append-path ] with map\r
- [ <run-file-button> add-gadget ] each\r
- swap <labeled-gadget> ;\r
-\r
-! -----------------------------------------------------\r
-\r
-: menu-rotations-3D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- "Turn\n left" [ rotation-step turn-left ] \r
- camera-button @left grid-add \r
- "Turn\n right" [ rotation-step turn-right ] \r
- camera-button @right grid-add \r
- "Pitch down" [ rotation-step pitch-down ] \r
- camera-button @bottom grid-add \r
- "Pitch up" [ rotation-step pitch-up ] \r
- camera-button @top grid-add \r
- <shelf> 1 >>fill\r
- "Roll left\n (ctl)" [ rotation-step roll-left ] \r
- camera-button add-gadget \r
- "Roll right\n(ctl)" [ rotation-step roll-right ] \r
- camera-button add-gadget \r
- @center grid-add \r
-;\r
-\r
-: menu-translations-3D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- "left\n(alt)" [ translation-step strafe-left ]\r
- camera-button @left grid-add \r
- "right\n(alt)" [ translation-step strafe-right ]\r
- camera-button @right grid-add \r
- "Strafe up \n (alt)" [ translation-step strafe-up ] \r
- camera-button @top grid-add\r
- "Strafe down\n (alt)" [ translation-step strafe-down ]\r
- camera-button @bottom grid-add \r
- <pile> 1 >>fill\r
- "Forward (ctl)" [ translation-step step-turtle ] \r
- camera-button add-gadget\r
- "Backward (ctl)" \r
- [ translation-step neg step-turtle ] \r
- camera-button add-gadget\r
- @center grid-add\r
-;\r
-\r
-: menu-quick-views ( -- gadget )\r
- <shelf>\r
- "View 1 (1)" mvt-3D-1 camera-button add-gadget\r
- "View 2 (2)" mvt-3D-2 camera-button add-gadget\r
- "View 3 (3)" mvt-3D-3 camera-button add-gadget \r
- "View 4 (4)" mvt-3D-4 camera-button add-gadget \r
-;\r
-\r
-: menu-3D ( -- gadget ) \r
- <pile>\r
- <shelf> \r
- menu-rotations-3D add-gadget\r
- menu-translations-3D add-gadget\r
- 0.5 >>align\r
- { 0 10 } >>gap\r
- add-gadget\r
- menu-quick-views add-gadget ; \r
-\r
-TUPLE: handler < w:wrapper table ;\r
-\r
-: <handler> ( child -- handler ) handler w:new-wrapper ;\r
-\r
-M: handler handle-gesture ( gesture gadget -- ? )\r
- tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;\r
-\r
-: add-keyboard-delegate ( obj -- obj )\r
- <handler>\r
-H{\r
- { T{ key-down f f "LEFT" } \r
- [ [ rotation-step turn-left ] camera-action ] }\r
- { T{ key-down f f "RIGHT" } \r
- [ [ rotation-step turn-right ] camera-action ] }\r
- { T{ key-down f f "UP" } \r
- [ [ rotation-step pitch-down ] camera-action ] }\r
- { T{ key-down f f "DOWN" } \r
- [ [ rotation-step pitch-up ] camera-action ] }\r
-\r
- { T{ key-down f { C+ } "UP" } \r
- [ [ translation-step step-turtle ] camera-action ] }\r
- { T{ key-down f { C+ } "DOWN" } \r
- [ [ translation-step neg step-turtle ] \r
- camera-action ] }\r
- { T{ key-down f { C+ } "LEFT" } \r
- [ [ rotation-step roll-left ] camera-action ] }\r
- { T{ key-down f { C+ } "RIGHT" } \r
- [ [ rotation-step roll-right ] camera-action ] }\r
-\r
- { T{ key-down f { A+ } "LEFT" } \r
- [ [ translation-step strafe-left ] camera-action ] }\r
- { T{ key-down f { A+ } "RIGHT" } \r
- [ [ translation-step strafe-right ] camera-action ] }\r
- { T{ key-down f { A+ } "UP" } \r
- [ [ translation-step strafe-up ] camera-action ] }\r
- { T{ key-down f { A+ } "DOWN" } \r
- [ [ translation-step strafe-down ] camera-action ] }\r
-\r
-\r
- { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }\r
- { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }\r
- { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
- { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
-\r
- } >>table\r
- ; \r
-\r
-! --------------------------------------------\r
-! print elements \r
-! --------------------------------------------\r
-! print-content\r
-\r
-GENERIC: adsoda-display-model ( x -- ) \r
-\r
-M: light adsoda-display-model \r
-"\n light : " .\r
- { \r
- [ direction>> "direction : " pprint . ] \r
- [ color>> "color : " pprint . ]\r
- } cleave\r
- ;\r
-\r
-M: face adsoda-display-model \r
- {\r
- [ halfspace>> "halfspace : " pprint . ] \r
- [ touching-corners>> "touching corners : " pprint . ]\r
- } cleave\r
- ;\r
-M: solid adsoda-display-model \r
- {\r
- [ name>> "solid called : " pprint . ] \r
- [ color>> "color : " pprint . ]\r
- [ dimension>> "dimension : " pprint . ]\r
- [ faces>> "composed of faces : " pprint \r
- [ adsoda-display-model ] each ]\r
- } cleave\r
- ;\r
-M: space adsoda-display-model \r
- {\r
- [ dimension>> "dimension : " pprint . ] \r
- [ ambient-color>> "ambient-color : " pprint . ]\r
- [ solids>> "composed of solids : " pprint \r
- [ adsoda-display-model ] each ]\r
- [ lights>> "composed of lights : " pprint \r
- [ adsoda-display-model ] each ] \r
- } cleave\r
- ;\r
-\r
-! ----------------------------------------------\r
-: menu-bar ( -- gadget )\r
- <shelf>\r
- "reinit" [ drop load-model-file ] button* add-gadget\r
- selected-file-model> <label-control> add-gadget\r
- ;\r
-\r
-\r
-: controller-window* ( -- gadget )\r
- { 0 1 } <track>\r
- menu-bar f track-add\r
- <list-runner> \r
- <scroller>\r
- f track-add\r
- <shelf>\r
- "Projection mode : " <label> add-gadget\r
- model-projection-chooser add-gadget\r
- f track-add\r
- <shelf>\r
- "Collision detection (slow and buggy ) : " \r
- <label> add-gadget\r
- collision-detection-chooser add-gadget\r
- f track-add\r
- <pile>\r
- 0.5 >>align \r
- menu-4D add-gadget \r
- COLOR: purple s:<solid> >>interior\r
- "4D movements" <labeled-gadget>\r
- f track-add\r
- <pile>\r
- 0.5 >>align\r
- { 2 2 } >>gap\r
- menu-3D add-gadget\r
- COLOR: purple s:<solid> >>interior\r
- "Camera 3D" <labeled-gadget>\r
- f track-add \r
- COLOR: gray s:<solid> >>interior\r
- ;\r
- \r
-: viewer-windows* ( -- )\r
- "YZW" view1> win3D \r
- "XZW" view2> win3D \r
- "XYW" view3> win3D \r
- "XYZ" view4> win3D \r
-;\r
-\r
-: navigator-window* ( -- )\r
- controller-window*\r
- viewer-windows* \r
- add-keyboard-delegate\r
- "navigateur 4D" open-window\r
-;\r
-\r
-: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;\r
-\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: init-variables ( -- )\r
- "choose a file" <model> >selected-file-model \r
- <observer> >observer3d\r
- [ observer3d> >self\r
- reset-turtle \r
- 45 turn-left \r
- 45 pitch-up \r
- -300 step-turtle \r
- ] with-scope\r
- \r
-;\r
-\r
-\r
-: init-models ( -- )\r
- 0 model-projection observer3d> <window3D> >view1\r
- 1 model-projection observer3d> <window3D> >view2\r
- 2 model-projection observer3d> <window3D> >view3\r
- 3 model-projection observer3d> <window3D> >view4\r
-;\r
-\r
-: 4DNav ( -- ) \r
- init-variables\r
- selected-file read-model-file >present-space\r
- init-models\r
- windows\r
-;\r
-\r
-MAIN: 4DNav\r
-\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel
+namespaces
+accessors
+assocs
+make
+math
+math.functions
+math.trig
+math.parser
+hashtables
+sequences
+combinators
+continuations
+colors
+colors.constants
+prettyprint
+vars
+quotations
+io
+io.directories
+io.pathnames
+help.markup
+io.files
+ui.gadgets.panes
+ ui
+ ui.gadgets
+ ui.traverse
+ ui.gadgets.borders
+ ui.gadgets.frames
+ ui.gadgets.tracks
+ ui.gadgets.labels
+ ui.gadgets.labeled
+ ui.gadgets.lists
+ ui.gadgets.buttons
+ ui.gadgets.packs
+ ui.gadgets.grids
+ ui.gadgets.corners
+ ui.gestures
+ ui.gadgets.scrollers
+splitting
+vectors
+math.vectors
+values
+4DNav.turtle
+4DNav.window3D
+4DNav.deep
+4DNav.space-file-decoder
+models
+fry
+adsoda
+adsoda.tools
+;
+QUALIFIED-WITH: ui.pens.solid s
+QUALIFIED-WITH: ui.gadgets.wrappers w
+
+
+IN: 4DNav
+VALUE: selected-file
+VALUE: translation-step
+VALUE: rotation-step
+
+3 \ translation-step set-value
+5 \ rotation-step set-value
+
+VAR: selected-file-model
+VAR: observer3d
+VAR: view1
+VAR: view2
+VAR: view3
+VAR: view4
+VAR: present-space
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! namespace utilities
+
+: closed-quot ( quot -- quot )
+ namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! waiting for deep-cleave-quots
+
+: 4D-Rxy ( angle -- Rx ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ 0.0 , 0.0 , dup cos , dup sin neg ,
+ 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Rxz ( angle -- Ry ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , dup cos , 0.0 , dup sin neg ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Rxw ( angle -- Rz ) deg>rad
+[ 1.0 , 0.0 , 0.0 , 0.0 ,
+ 0.0 , dup cos , dup sin neg , 0.0 ,
+ 0.0 , dup sin , dup cos , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+: 4D-Ryz ( angle -- Rx ) deg>rad
+[ dup cos , 0.0 , 0.0 , dup sin neg ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;
+
+: 4D-Ryw ( angle -- Ry ) deg>rad
+[ dup cos , 0.0 , dup sin neg , 0.0 ,
+ 0.0 , 1.0 , 0.0 , 0.0 ,
+ dup sin , 0.0 , dup cos , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+: 4D-Rzw ( angle -- Rz ) deg>rad
+[ dup cos , dup sin neg , 0.0 , 0.0 ,
+ dup sin , dup cos , 0.0 , 0.0 ,
+ 0.0 , 0.0 , 1.0 , 0.0 ,
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! UI
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: button* ( string quot -- button )
+ closed-quot <repeat-button> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: model-projection-chooser ( -- gadget )
+ observer3d> projection-mode>>
+ { { 1 "perspective" } { 0 "orthogonal" } }
+ <radio-buttons> ;
+
+: collision-detection-chooser ( -- gadget )
+ observer3d> collision-mode>>
+ { { t "on" } { f "off" } } <radio-buttons> ;
+
+: model-projection ( x -- space )
+ present-space> swap space-project ;
+
+: update-observer-projections ( -- )
+ view1> relayout-1
+ view2> relayout-1
+ view3> relayout-1
+ view4> relayout-1 ;
+
+: update-model-projections ( -- )
+ 0 model-projection <model> view1> model<<
+ 1 model-projection <model> view2> model<<
+ 2 model-projection <model> view3> model<<
+ 3 model-projection <model> view4> model<< ;
+
+: camera-action ( quot -- quot )
+ '[ drop _ observer3d>
+ with-self update-observer-projections ]
+ closed-quot ;
+
+: win3D ( text gadget -- )
+ "navigateur 4D : " rot append open-window ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 4D object manipulation
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (mvt-4D) ( quot -- )
+ present-space>
+ swap call space-ensure-solids
+ >present-space
+ update-model-projections
+ update-observer-projections ; inline
+
+: rotation-4D ( m -- )
+ '[ _ [ [ middle-of-space dup vneg ] keep
+ swap space-translate ] dip
+ space-transform
+ swap space-translate
+ ] (mvt-4D) ;
+
+: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! menu
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: menu-rotations-4D ( -- gadget )
+ 3 3 <frame>
+ { 1 1 } >>filled-cell
+ <pile> 1 >>fill
+ "XY +" [ drop rotation-step 4D-Rxy rotation-4D ]
+ button* add-gadget
+ "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ]
+ button* add-gadget
+ @top-left grid-add
+ <pile> 1 >>fill
+ "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ]
+ button* add-gadget
+ "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ]
+ button* add-gadget
+ @top grid-add
+ <pile> 1 >>fill
+ "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ]
+ button* add-gadget
+ "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ]
+ button* add-gadget
+ @center grid-add
+ <pile> 1 >>fill
+ "XW +" [ drop rotation-step 4D-Rxw rotation-4D ]
+ button* add-gadget
+ "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ]
+ button* add-gadget
+ @top-right grid-add
+ <pile> 1 >>fill
+ "YW +" [ drop rotation-step 4D-Ryw rotation-4D ]
+ button* add-gadget
+ "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ]
+ button* add-gadget
+ @right grid-add
+ <pile> 1 >>fill
+ "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ]
+ button* add-gadget
+ "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ]
+ button* add-gadget
+ @bottom-right grid-add
+;
+
+: menu-translations-4D ( -- gadget )
+ 3 3 <frame>
+ { 1 1 } >>filled-cell
+ <pile> 1 >>fill
+ <shelf> 1 >>fill
+ "X+" [ drop { 1 0 0 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ "X-" [ drop { -1 0 0 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ add-gadget
+ "YZW" <label> add-gadget
+ @bottom-right grid-add
+ <pile> 1 >>fill
+ "XZW" <label> add-gadget
+ <shelf> 1 >>fill
+ "Y+" [ drop { 0 1 0 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ "Y-" [ drop { 0 -1 0 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ add-gadget
+ @top-right grid-add
+ <pile> 1 >>fill
+ "XYW" <label> add-gadget
+ <shelf> 1 >>fill
+ "Z+" [ drop { 0 0 1 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ "Z-" [ drop { 0 0 -1 0 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ add-gadget
+ @top-left grid-add
+ <pile> 1 >>fill
+ <shelf> 1 >>fill
+ "W+" [ drop { 0 0 0 1 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ "W-" [ drop { 0 0 0 -1 } translation-step v*n
+ translation-4D ]
+ button* add-gadget
+ add-gadget
+ "XYZ" <label> add-gadget
+ @bottom-left grid-add
+ "X" <label> @center grid-add
+;
+
+: menu-4D ( -- gadget )
+ <shelf>
+ "rotations" <label> add-gadget
+ menu-rotations-4D add-gadget
+ "translations" <label> add-gadget
+ menu-translations-4D add-gadget
+ 0.5 >>align
+ { 0 10 } >>gap
+;
+
+
+! ------------------------------------------------------
+
+: redraw-model ( space -- )
+ >present-space
+ update-model-projections
+ update-observer-projections ;
+
+: load-model-file ( -- )
+ selected-file dup selected-file-model> set-model
+ read-model-file
+ redraw-model ;
+
+: mvt-3D-X ( turn pitch -- quot )
+ '[ turtle-pos> norm neg reset-turtle
+ _ turn-left
+ _ pitch-up
+ step-turtle ] ;
+
+: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline
+: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline
+: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline
+: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline
+
+: camera-button ( string quot -- button )
+ [ <label> ] dip camera-action <repeat-button> ;
+
+! ----------------------------------------------------------
+! file chooser
+! ----------------------------------------------------------
+: <run-file-button> ( file-name -- button )
+ dup '[ drop _ \ selected-file set-value load-model-file
+ ]
+ closed-quot <roll-button> { 0 0 } >>align ;
+
+: <list-runner> ( -- gadget )
+ "resource:extra/4DNav"
+ <pile> 1 >>fill
+ over dup directory-files
+ [ ".xml" tail? ] filter
+ [ append-path ] with map
+ [ <run-file-button> add-gadget ] each
+ swap <labeled-gadget> ;
+
+! -----------------------------------------------------
+
+: menu-rotations-3D ( -- gadget )
+ 3 3 <frame>
+ { 1 1 } >>filled-cell
+ "Turn\n left" [ rotation-step turn-left ]
+ camera-button @left grid-add
+ "Turn\n right" [ rotation-step turn-right ]
+ camera-button @right grid-add
+ "Pitch down" [ rotation-step pitch-down ]
+ camera-button @bottom grid-add
+ "Pitch up" [ rotation-step pitch-up ]
+ camera-button @top grid-add
+ <shelf> 1 >>fill
+ "Roll left\n (ctl)" [ rotation-step roll-left ]
+ camera-button add-gadget
+ "Roll right\n(ctl)" [ rotation-step roll-right ]
+ camera-button add-gadget
+ @center grid-add
+;
+
+: menu-translations-3D ( -- gadget )
+ 3 3 <frame>
+ { 1 1 } >>filled-cell
+ "left\n(alt)" [ translation-step strafe-left ]
+ camera-button @left grid-add
+ "right\n(alt)" [ translation-step strafe-right ]
+ camera-button @right grid-add
+ "Strafe up \n (alt)" [ translation-step strafe-up ]
+ camera-button @top grid-add
+ "Strafe down\n (alt)" [ translation-step strafe-down ]
+ camera-button @bottom grid-add
+ <pile> 1 >>fill
+ "Forward (ctl)" [ translation-step step-turtle ]
+ camera-button add-gadget
+ "Backward (ctl)"
+ [ translation-step neg step-turtle ]
+ camera-button add-gadget
+ @center grid-add
+;
+
+: menu-quick-views ( -- gadget )
+ <shelf>
+ "View 1 (1)" mvt-3D-1 camera-button add-gadget
+ "View 2 (2)" mvt-3D-2 camera-button add-gadget
+ "View 3 (3)" mvt-3D-3 camera-button add-gadget
+ "View 4 (4)" mvt-3D-4 camera-button add-gadget
+;
+
+: menu-3D ( -- gadget )
+ <pile>
+ <shelf>
+ menu-rotations-3D add-gadget
+ menu-translations-3D add-gadget
+ 0.5 >>align
+ { 0 10 } >>gap
+ add-gadget
+ menu-quick-views add-gadget ;
+
+TUPLE: handler < w:wrapper table ;
+
+: <handler> ( child -- handler ) handler w:new-wrapper ;
+
+M: handler handle-gesture ( gesture gadget -- ? )
+ tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;
+
+: add-keyboard-delegate ( obj -- obj )
+ <handler>
+H{
+ { T{ key-down f f "LEFT" }
+ [ [ rotation-step turn-left ] camera-action ] }
+ { T{ key-down f f "RIGHT" }
+ [ [ rotation-step turn-right ] camera-action ] }
+ { T{ key-down f f "UP" }
+ [ [ rotation-step pitch-down ] camera-action ] }
+ { T{ key-down f f "DOWN" }
+ [ [ rotation-step pitch-up ] camera-action ] }
+
+ { T{ key-down f { C+ } "UP" }
+ [ [ translation-step step-turtle ] camera-action ] }
+ { T{ key-down f { C+ } "DOWN" }
+ [ [ translation-step neg step-turtle ]
+ camera-action ] }
+ { T{ key-down f { C+ } "LEFT" }
+ [ [ rotation-step roll-left ] camera-action ] }
+ { T{ key-down f { C+ } "RIGHT" }
+ [ [ rotation-step roll-right ] camera-action ] }
+
+ { T{ key-down f { A+ } "LEFT" }
+ [ [ translation-step strafe-left ] camera-action ] }
+ { T{ key-down f { A+ } "RIGHT" }
+ [ [ translation-step strafe-right ] camera-action ] }
+ { T{ key-down f { A+ } "UP" }
+ [ [ translation-step strafe-up ] camera-action ] }
+ { T{ key-down f { A+ } "DOWN" }
+ [ [ translation-step strafe-down ] camera-action ] }
+
+
+ { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }
+ { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }
+ { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }
+ { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }
+
+ } >>table
+ ;
+
+! --------------------------------------------
+! print elements
+! --------------------------------------------
+! print-content
+
+GENERIC: adsoda-display-model ( x -- )
+
+M: light adsoda-display-model
+"\n light : " .
+ {
+ [ direction>> "direction : " pprint . ]
+ [ color>> "color : " pprint . ]
+ } cleave
+ ;
+
+M: face adsoda-display-model
+ {
+ [ halfspace>> "halfspace : " pprint . ]
+ [ touching-corners>> "touching corners : " pprint . ]
+ } cleave
+ ;
+M: solid adsoda-display-model
+ {
+ [ name>> "solid called : " pprint . ]
+ [ color>> "color : " pprint . ]
+ [ dimension>> "dimension : " pprint . ]
+ [ faces>> "composed of faces : " pprint
+ [ adsoda-display-model ] each ]
+ } cleave
+ ;
+M: space adsoda-display-model
+ {
+ [ dimension>> "dimension : " pprint . ]
+ [ ambient-color>> "ambient-color : " pprint . ]
+ [ solids>> "composed of solids : " pprint
+ [ adsoda-display-model ] each ]
+ [ lights>> "composed of lights : " pprint
+ [ adsoda-display-model ] each ]
+ } cleave
+ ;
+
+! ----------------------------------------------
+: menu-bar ( -- gadget )
+ <shelf>
+ "reinit" [ drop load-model-file ] button* add-gadget
+ selected-file-model> <label-control> add-gadget
+ ;
+
+
+: controller-window* ( -- gadget )
+ { 0 1 } <track>
+ menu-bar f track-add
+ <list-runner>
+ <scroller>
+ f track-add
+ <shelf>
+ "Projection mode : " <label> add-gadget
+ model-projection-chooser add-gadget
+ f track-add
+ <shelf>
+ "Collision detection (slow and buggy ) : "
+ <label> add-gadget
+ collision-detection-chooser add-gadget
+ f track-add
+ <pile>
+ 0.5 >>align
+ menu-4D add-gadget
+ COLOR: purple s:<solid> >>interior
+ "4D movements" <labeled-gadget>
+ f track-add
+ <pile>
+ 0.5 >>align
+ { 2 2 } >>gap
+ menu-3D add-gadget
+ COLOR: purple s:<solid> >>interior
+ "Camera 3D" <labeled-gadget>
+ f track-add
+ COLOR: gray s:<solid> >>interior
+ ;
+
+: viewer-windows* ( -- )
+ "YZW" view1> win3D
+ "XZW" view2> win3D
+ "XYW" view3> win3D
+ "XYZ" view4> win3D
+;
+
+: navigator-window* ( -- )
+ controller-window*
+ viewer-windows*
+ add-keyboard-delegate
+ "navigateur 4D" open-window
+;
+
+: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-variables ( -- )
+ "choose a file" <model> >selected-file-model
+ <observer> >observer3d
+ [ observer3d> >self
+ reset-turtle
+ 45 turn-left
+ 45 pitch-up
+ -300 step-turtle
+ ] with-scope
+
+;
+
+
+: init-models ( -- )
+ 0 model-projection observer3d> <window3D> >view1
+ 1 model-projection observer3d> <window3D> >view2
+ 2 model-projection observer3d> <window3D> >view3
+ 3 model-projection observer3d> <window3D> >view4
+;
+
+: 4DNav ( -- )
+ init-variables
+ selected-file read-model-file >present-space
+ init-models
+ windows
+;
+
+MAIN: 4DNav
+
+
-USING: macros quotations math math.functions math.trig \r
-sequences.deep kernel make fry combinators grouping ;\r
-IN: 4DNav.deep\r
-\r
-! USING: bake ;\r
-! MACRO: deep-cleave-quots ( seq -- quot )\r
-! [ [ quotation? ] deep-filter ]\r
-! [ [ dup quotation? [ drop , ] when ] deep-map ]\r
-! bi '[ _ cleave _ bake ] ;\r
-\r
-: make-matrix ( quot width -- matrix ) \r
- [ { } make ] dip group ; inline\r
-\r
+USING: macros quotations math math.functions math.trig
+sequences.deep kernel make fry combinators grouping ;
+IN: 4DNav.deep
+
+! USING: bake ;
+! MACRO: deep-cleave-quots ( seq -- quot )
+! [ [ quotation? ] deep-filter ]
+! [ [ dup quotation? [ drop , ] when ] deep-map ]
+! bi '[ _ cleave _ bake ] ;
+
+: make-matrix ( quot width -- matrix )
+ [ { } make ] dip group ; inline
+
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING:\r
-kernel\r
-io.files\r
-io.backend\r
-io.directories\r
-io.files.info\r
-io.pathnames\r
-sequences\r
-models\r
-strings\r
-ui\r
-ui.operations\r
-ui.commands\r
-ui.gestures\r
-ui.gadgets\r
-ui.gadgets.buttons\r
-ui.gadgets.lists\r
-ui.gadgets.labels\r
-ui.gadgets.tracks\r
-ui.gadgets.packs\r
-ui.gadgets.panes\r
-ui.gadgets.scrollers\r
-prettyprint\r
-combinators\r
-accessors\r
-values\r
-tools.walker\r
-fry\r
-;\r
-IN: 4DNav.file-chooser\r
-\r
-TUPLE: file-chooser < track \r
- path\r
- extension \r
- selected-file\r
- presenter\r
- hook \r
- list\r
- ;\r
-\r
-: find-file-list ( gadget -- list )\r
- [ file-chooser? ] find-parent list>> ;\r
-\r
-file-chooser H{\r
- { T{ key-down f f "UP" } \r
- [ find-file-list select-previous ] }\r
- { T{ key-down f f "DOWN" } \r
- [ find-file-list select-next ] }\r
- { T{ key-down f f "PAGE_UP" } \r
- [ find-file-list list-page-up ] }\r
- { T{ key-down f f "PAGE_DOWN" } \r
- [ find-file-list list-page-down ] }\r
- { T{ key-down f f "RET" } \r
- [ find-file-list invoke-value-action ] }\r
- { T{ button-down } \r
- request-focus }\r
- { T{ button-down f 1 } \r
- [ find-file-list invoke-value-action ] }\r
-} set-gestures\r
-\r
-: list-of-files ( file-chooser -- seq )\r
- [ path>> value>> directory-entries ] [ extension>> ] bi\r
- '[ [ name>> _ [ tail? ] with any? ] \r
- [ directory? ] bi or ] filter\r
-;\r
-\r
-: update-filelist-model ( file-chooser -- )\r
- [ list-of-files ] [ model>> ] bi set-model ;\r
-\r
-: init-filelist-model ( file-chooser -- file-chooser )\r
- dup list-of-files <model> >>model ; \r
-\r
-: (fc-go) ( file-chooser button quot -- )\r
- [ [ file-chooser? ] find-parent dup path>> ] dip\r
- call\r
- normalize-path swap set-model\r
- update-filelist-model\r
- drop ; inline\r
-\r
-: fc-go-parent ( file-chooser button -- )\r
- [ dup value>> parent-directory ] (fc-go) ;\r
-\r
-: fc-go-home ( file-chooser button -- )\r
- [ home ] (fc-go) ;\r
-\r
-: fc-change-directory ( file-chooser file -- )\r
- dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
- append-path over path>> set-model \r
- update-filelist-model\r
-;\r
-\r
-: fc-load-file ( file-chooser file -- )\r
- over [ name>> ] [ selected-file>> ] bi* set-model \r
- [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi\r
- call( path -- )\r
-; inline\r
-\r
-! : fc-ok-action ( file-chooser -- quot )\r
-! dup selected-file>> value>> "" =\r
-! [ drop [ drop ] ] [ \r
-! [ path>> value>> ] \r
-! [ selected-file>> value>> append ] \r
-! [ hook>> prefix ] tri\r
-! [ drop ] prepend\r
-! ] if ; \r
-\r
-: line-selected-action ( file-chooser -- )\r
- dup list>> list-value\r
- dup directory? \r
- [ fc-change-directory ] [ fc-load-file ] if ;\r
-\r
-: present-dir-element ( element -- string )\r
- [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;\r
-\r
-: <file-list> ( file-chooser -- list )\r
- dup [ nip line-selected-action ] curry \r
- [ present-dir-element ] rot model>> <list> ;\r
-\r
-: <file-chooser> ( hook path extension -- gadget )\r
- { 0 1 } file-chooser new-track\r
- swap >>extension\r
- swap <model> >>path\r
- "" <model> >>selected-file\r
- swap >>hook\r
- init-filelist-model\r
- dup <file-list> >>list\r
- "choose a file in directory " <label> f track-add\r
- dup path>> <label-control> f track-add\r
- dup extension>> ", " join "limited to : " prepend \r
- <label> f track-add\r
- <shelf> \r
- "selected file : " <label> add-gadget\r
- over selected-file>> <label-control> add-gadget\r
- f track-add\r
- <shelf> \r
- over [ swap fc-go-parent ] curry "go up" \r
- swap <border-button> add-gadget\r
- over [ swap fc-go-home ] curry "go home" \r
- swap <border-button> add-gadget\r
- ! over [ swap fc-ok-action ] curry "OK" \r
- ! swap <bevel-button> add-gadget\r
- ! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
- f track-add\r
- dup list>> <scroller> 1 track-add\r
-;\r
-\r
-M: file-chooser pref-dim* drop { 400 200 } ;\r
-\r
-: file-chooser-window ( -- )\r
- [ . ] home { "xml" "txt" } <file-chooser> \r
- "Choose a file" open-window ;\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING:
+kernel
+io.files
+io.backend
+io.directories
+io.files.info
+io.pathnames
+sequences
+models
+strings
+ui
+ui.operations
+ui.commands
+ui.gestures
+ui.gadgets
+ui.gadgets.buttons
+ui.gadgets.lists
+ui.gadgets.labels
+ui.gadgets.tracks
+ui.gadgets.packs
+ui.gadgets.panes
+ui.gadgets.scrollers
+prettyprint
+combinators
+accessors
+values
+tools.walker
+fry
+;
+IN: 4DNav.file-chooser
+
+TUPLE: file-chooser < track
+ path
+ extension
+ selected-file
+ presenter
+ hook
+ list
+ ;
+
+: find-file-list ( gadget -- list )
+ [ file-chooser? ] find-parent list>> ;
+
+file-chooser H{
+ { T{ key-down f f "UP" }
+ [ find-file-list select-previous ] }
+ { T{ key-down f f "DOWN" }
+ [ find-file-list select-next ] }
+ { T{ key-down f f "PAGE_UP" }
+ [ find-file-list list-page-up ] }
+ { T{ key-down f f "PAGE_DOWN" }
+ [ find-file-list list-page-down ] }
+ { T{ key-down f f "RET" }
+ [ find-file-list invoke-value-action ] }
+ { T{ button-down }
+ request-focus }
+ { T{ button-down f 1 }
+ [ find-file-list invoke-value-action ] }
+} set-gestures
+
+: list-of-files ( file-chooser -- seq )
+ [ path>> value>> directory-entries ] [ extension>> ] bi
+ '[ [ name>> _ [ tail? ] with any? ]
+ [ directory? ] bi or ] filter
+;
+
+: update-filelist-model ( file-chooser -- )
+ [ list-of-files ] [ model>> ] bi set-model ;
+
+: init-filelist-model ( file-chooser -- file-chooser )
+ dup list-of-files <model> >>model ;
+
+: (fc-go) ( file-chooser button quot -- )
+ [ [ file-chooser? ] find-parent dup path>> ] dip
+ call
+ normalize-path swap set-model
+ update-filelist-model
+ drop ; inline
+
+: fc-go-parent ( file-chooser button -- )
+ [ dup value>> parent-directory ] (fc-go) ;
+
+: fc-go-home ( file-chooser button -- )
+ [ home ] (fc-go) ;
+
+: fc-change-directory ( file-chooser file -- )
+ dupd [ path>> value>> normalize-path ] [ name>> ] bi*
+ append-path over path>> set-model
+ update-filelist-model
+;
+
+: fc-load-file ( file-chooser file -- )
+ over [ name>> ] [ selected-file>> ] bi* set-model
+ [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi
+ call( path -- )
+; inline
+
+! : fc-ok-action ( file-chooser -- quot )
+! dup selected-file>> value>> "" =
+! [ drop [ drop ] ] [
+! [ path>> value>> ]
+! [ selected-file>> value>> append ]
+! [ hook>> prefix ] tri
+! [ drop ] prepend
+! ] if ;
+
+: line-selected-action ( file-chooser -- )
+ dup list>> list-value
+ dup directory?
+ [ fc-change-directory ] [ fc-load-file ] if ;
+
+: present-dir-element ( element -- string )
+ [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;
+
+: <file-list> ( file-chooser -- list )
+ dup [ nip line-selected-action ] curry
+ [ present-dir-element ] rot model>> <list> ;
+
+: <file-chooser> ( hook path extension -- gadget )
+ { 0 1 } file-chooser new-track
+ swap >>extension
+ swap <model> >>path
+ "" <model> >>selected-file
+ swap >>hook
+ init-filelist-model
+ dup <file-list> >>list
+ "choose a file in directory " <label> f track-add
+ dup path>> <label-control> f track-add
+ dup extension>> ", " join "limited to : " prepend
+ <label> f track-add
+ <shelf>
+ "selected file : " <label> add-gadget
+ over selected-file>> <label-control> add-gadget
+ f track-add
+ <shelf>
+ over [ swap fc-go-parent ] curry "go up"
+ swap <border-button> add-gadget
+ over [ swap fc-go-home ] curry "go home"
+ swap <border-button> add-gadget
+ ! over [ swap fc-ok-action ] curry "OK"
+ ! swap <bevel-button> add-gadget
+ ! [ drop ] "Cancel" swap <bevel-button> add-gadget
+ f track-add
+ dup list>> <scroller> 1 track-add
+;
+
+M: file-chooser pref-dim* drop { 400 200 } ;
+
+: file-chooser-window ( -- )
+ [ . ] home { "xml" "txt" } <file-chooser>
+ "Choose a file" open-window ;
+
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: adsoda xml xml.traversal xml.syntax accessors \r
-combinators sequences math.parser kernel splitting values \r
-continuations ;\r
-IN: 4DNav.space-file-decoder\r
-\r
-: decode-number-array ( x -- y ) \r
- "," split [ string>number ] map ;\r
-\r
-TAGS: adsoda-read-model ( tag -- model )\r
-\r
-TAG: dimension adsoda-read-model \r
- children>> first string>number ;\r
-TAG: direction adsoda-read-model \r
- children>> first decode-number-array ;\r
-TAG: color adsoda-read-model \r
- children>> first decode-number-array ;\r
-TAG: name adsoda-read-model \r
- children>> first ;\r
-TAG: face adsoda-read-model \r
- children>> first decode-number-array ;\r
-\r
-TAG: solid adsoda-read-model \r
- <solid> swap \r
- { \r
- [ "dimension" tag-named adsoda-read-model >>dimension ]\r
- [ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named adsoda-read-model >>color ] \r
- [ "face" \r
- tags-named [ adsoda-read-model cut-solid ] each ] \r
- } cleave\r
- ensure-adjacencies\r
-;\r
-\r
-TAG: light adsoda-read-model \r
- <light> swap \r
- { \r
- [ "direction" tag-named adsoda-read-model >>direction ]\r
- [ "color" tag-named adsoda-read-model >>color ] \r
- } cleave\r
-;\r
-\r
-TAG: space adsoda-read-model \r
- <space> swap \r
- { \r
- [ "dimension" tag-named adsoda-read-model >>dimension ]\r
- [ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named \r
- adsoda-read-model >>ambient-color ] \r
- [ "solid" tags-named \r
- [ adsoda-read-model suffix-solids ] each ] \r
- [ "light" tags-named \r
- [ adsoda-read-model suffix-lights ] each ]\r
- } cleave\r
-;\r
-\r
-: read-model-file ( path -- x )\r
- [\r
- [ file>xml "space" tag-named adsoda-read-model ] \r
- [ 2drop <space> ] recover \r
- ] [ <space> ] if*\r
-;\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: adsoda xml xml.traversal xml.syntax accessors
+combinators sequences math.parser kernel splitting values
+continuations ;
+IN: 4DNav.space-file-decoder
+
+: decode-number-array ( x -- y )
+ "," split [ string>number ] map ;
+
+TAGS: adsoda-read-model ( tag -- model )
+
+TAG: dimension adsoda-read-model
+ children>> first string>number ;
+TAG: direction adsoda-read-model
+ children>> first decode-number-array ;
+TAG: color adsoda-read-model
+ children>> first decode-number-array ;
+TAG: name adsoda-read-model
+ children>> first ;
+TAG: face adsoda-read-model
+ children>> first decode-number-array ;
+
+TAG: solid adsoda-read-model
+ <solid> swap
+ {
+ [ "dimension" tag-named adsoda-read-model >>dimension ]
+ [ "name" tag-named adsoda-read-model >>name ]
+ [ "color" tag-named adsoda-read-model >>color ]
+ [ "face"
+ tags-named [ adsoda-read-model cut-solid ] each ]
+ } cleave
+ ensure-adjacencies
+;
+
+TAG: light adsoda-read-model
+ <light> swap
+ {
+ [ "direction" tag-named adsoda-read-model >>direction ]
+ [ "color" tag-named adsoda-read-model >>color ]
+ } cleave
+;
+
+TAG: space adsoda-read-model
+ <space> swap
+ {
+ [ "dimension" tag-named adsoda-read-model >>dimension ]
+ [ "name" tag-named adsoda-read-model >>name ]
+ [ "color" tag-named
+ adsoda-read-model >>ambient-color ]
+ [ "solid" tags-named
+ [ adsoda-read-model suffix-solids ] each ]
+ [ "light" tags-named
+ [ adsoda-read-model suffix-lights ] each ]
+ } cleave
+;
+
+: read-model-file ( path -- x )
+ [
+ [ file>xml "space" tag-named adsoda-read-model ]
+ [ 2drop <space> ] recover
+ ] [ <space> ] if*
+;
+
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-ui.gadgets\r
-ui.render\r
-opengl\r
-opengl.gl\r
-opengl.glu\r
-4DNav.camera\r
-4DNav.turtle\r
-math\r
-values\r
-alien.c-types\r
-accessors\r
-namespaces\r
-adsoda \r
-models\r
-prettyprint\r
-;\r
-\r
-IN: 4DNav.window3D\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! drawing functions \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-TUPLE: window3D < gadget observer ; \r
-\r
-: <window3D> ( model observer -- gadget )\r
- window3D new\r
- swap 2dup \r
- projection-mode>> add-connection\r
- 2dup \r
- collision-mode>> add-connection\r
- >>observer \r
- swap <model> >>model \r
- t >>root?\r
-;\r
-\r
-M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;\r
-\r
-M: window3D draw-gadget* ( gadget -- )\r
-\r
- GL_PROJECTION glMatrixMode\r
- glLoadIdentity\r
- 0.6 0.6 0.6 .9 glClearColor\r
- dup observer>> projection-mode>> value>> 1 = \r
- [ 60.0 1.0 0.1 3000.0 gluPerspective ]\r
- [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if\r
- dup observer>> collision-mode>> value>> \r
- \ remove-hidden-solids? \r
- set-value\r
- dup observer>> do-look-at\r
- GL_MODELVIEW glMatrixMode\r
- glLoadIdentity \r
- 0.9 0.9 0.9 1.0 glClearColor\r
- 1.0 glClearDepth\r
- GL_LINE_SMOOTH glEnable\r
- GL_BLEND glEnable\r
- GL_DEPTH_TEST glEnable \r
- GL_LEQUAL glDepthFunc\r
- GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc\r
- GL_LINE_SMOOTH_HINT GL_NICEST glHint\r
- 1.25 glLineWidth\r
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor \r
- glClear\r
- glLoadIdentity\r
- GL_LIGHTING glEnable\r
- GL_LIGHT0 glEnable\r
- GL_COLOR_MATERIAL glEnable\r
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial\r
- ! *************************\r
- \r
- control-value\r
- [ space->GL ] when*\r
-\r
- ! *************************\r
-;\r
-\r
-M: window3D graft* drop ;\r
-\r
-M: window3D model-changed nip relayout ; \r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel
+ui.gadgets
+ui.render
+opengl
+opengl.gl
+opengl.glu
+4DNav.camera
+4DNav.turtle
+math
+values
+alien.c-types
+accessors
+namespaces
+adsoda
+models
+prettyprint
+;
+
+IN: 4DNav.window3D
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! drawing functions
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: window3D < gadget observer ;
+
+: <window3D> ( model observer -- gadget )
+ window3D new
+ swap 2dup
+ projection-mode>> add-connection
+ 2dup
+ collision-mode>> add-connection
+ >>observer
+ swap <model> >>model
+ t >>root?
+;
+
+M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;
+
+M: window3D draw-gadget* ( gadget -- )
+
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ 0.6 0.6 0.6 .9 glClearColor
+ dup observer>> projection-mode>> value>> 1 =
+ [ 60.0 1.0 0.1 3000.0 gluPerspective ]
+ [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if
+ dup observer>> collision-mode>> value>>
+ \ remove-hidden-solids?
+ set-value
+ dup observer>> do-look-at
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ 0.9 0.9 0.9 1.0 glClearColor
+ 1.0 glClearDepth
+ GL_LINE_SMOOTH glEnable
+ GL_BLEND glEnable
+ GL_DEPTH_TEST glEnable
+ GL_LEQUAL glDepthFunc
+ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+ GL_LINE_SMOOTH_HINT GL_NICEST glHint
+ 1.25 glLineWidth
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor
+ glClear
+ glLoadIdentity
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_COLOR_MATERIAL glEnable
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ ! *************************
+
+ control-value
+ [ space->GL ] when*
+
+ ! *************************
+;
+
+M: window3D graft* drop ;
+
+M: window3D model-changed nip relayout ;
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax ;\r
-IN: adsoda\r
-\r
-! --------------------------------------------------------------\r
-! faces\r
-! --------------------------------------------------------------\r
-ARTICLE: "face-page" "Face in ADSODA"\r
-"explanation of faces"\r
-$nl\r
-"link to functions" $nl\r
-"what is an halfspace" $nl\r
-"halfspace touching-corners adjacent-faces" $nl\r
-"touching-corners list of pointers to the corners which touch this face" $nl\r
-"adjacent-faces list of pointers to the faces which touch this face"\r
-{ $subsections\r
- face\r
- <face>\r
-}\r
-"test relative position"\r
-{ $subsections\r
- point-inside-or-on-face?\r
- point-inside-face?\r
-}\r
-"handling face"\r
-{ $subsections\r
- flip-face\r
- face-translate\r
- face-transform\r
-}\r
-\r
-;\r
-\r
-HELP: face\r
-{ $class-description "a face is defined by"\r
-{ $list "halfspace equation" }\r
-{ $list "list of touching corners" }\r
-{ $list "list of adjacent faces" }\r
-$nl\r
-"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
-}\r
-\r
-\r
-;\r
-HELP: <face> \r
-{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
-HELP: flip-face \r
-{ $values { "face" "a face" } { "face" "flipped face" } }\r
-{ $description "change the orientation of a face" }\r
-;\r
-\r
-HELP: face-translate \r
-{ $values { "face" "a face" } { "v" "a vector" } }\r
-{ $description \r
-"translate a face following a vector"\r
-$nl\r
-"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
-\r
- \r
- ;\r
-HELP: face-transform \r
-{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
-{ $description "compute the transformation of a face using a transformation matrix" }\r
- \r
- ;\r
-! --------------------------------\r
-! solid\r
-! --------------------------------------------------------------\r
-ARTICLE: "solid-page" "Solid in ADSODA"\r
-"explanation of solids"\r
-$nl\r
-"link to functions"\r
-{ $subsections\r
- solid\r
- <solid>\r
-}\r
-"test relative position"\r
-{ $subsections\r
- point-inside-solid?\r
- point-inside-or-on-solid?\r
-}\r
-"playing with faces and solids"\r
-{ $subsections\r
- add-face\r
- cut-solid\r
- slice-solid\r
-}\r
-"solid handling"\r
-{ $subsections\r
- solid-project\r
- solid-translate\r
- solid-transform\r
- subtract\r
- get-silhouette \r
- solid=\r
-}\r
-;\r
-\r
-HELP: solid \r
-{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
-}\r
-;\r
-\r
-HELP: add-face \r
-{ $values { "solid" "a solid" } { "face" "a face" } }\r
-{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
-\r
-HELP: cut-solid\r
-{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
-{ $description "like add-face but just with halfspace equation" } ;\r
-\r
-HELP: slice-solid\r
-{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
-{ $description "cut a solid into two parts. The face acts like a knife"\r
-} ;\r
-\r
-\r
-HELP: solid-project\r
-{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
-{ $description "Project the solid using pv vector" \r
-$nl\r
-"TODO: explain how to use lights"\r
-} ;\r
-\r
-HELP: solid-translate \r
-{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
-{ $description "Translate a solid using a vector" \r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: solid-transform \r
-{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
-{ $description "Transform a solid using a matrix"\r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: subtract \r
-{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
-{ $description "Substract solid2 from solid1" } ;\r
-\r
-\r
-! --------------------------------------------------------------\r
-! space \r
-! --------------------------------------------------------------\r
-ARTICLE: "space-page" "Space in ADSODA"\r
-"A space is a collection of solids and lights."\r
-$nl\r
-"link to functions"\r
-$nl\r
-"Defining words"\r
-{ $subsections\r
- space\r
- <space>\r
- suffix-solids \r
- suffix-lights\r
- clear-space-solids \r
- describe-space\r
-}\r
-\r
-\r
-"Handling space"\r
-{ $subsections\r
- space-ensure-solids\r
- eliminate-empty-solids\r
- space-transform\r
- space-translate\r
- remove-hidden-solids\r
- space-project\r
-}\r
-\r
-\r
-;\r
-\r
-HELP: space \r
-{ $class-description \r
-"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
-}\r
-;\r
-\r
-HELP: suffix-solids \r
-"( space solid -- space )"\r
-{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
-{ $description "Add solid to space definition" } ;\r
-\r
-HELP: suffix-lights \r
-"( space light -- space ) "\r
-{ $values { "space" "a space" } { "light" "a light to add" } }\r
-{ $description "Add a light to space definition" } ;\r
-\r
-HELP: clear-space-solids \r
-"( space -- space )" \r
-{ $values { "space" "a space" } }\r
-{ $description "remove all solids in space" } ;\r
-\r
-HELP: space-ensure-solids \r
-{ $values { "space" "a space" } }\r
-{ $description "rebuild corners of all solids in space" } ;\r
-\r
-\r
-\r
-HELP: space-transform \r
-{ $values { "space" "a space" } { "m" "a matrix" } }\r
-{ $description "Transform a space using a matrix" } ;\r
-\r
-HELP: space-translate \r
-{ $values { "space" "a space" } { "v" "a vector" } }\r
-{ $description "Translate a space following a vector" } ;\r
-\r
-HELP: describe-space\r
-{ $values { "space" "a space" } }\r
-{ $description "return a description of space" } ;\r
-\r
-HELP: space-project \r
-{ $values { "space" "a space" } { "i" "an integer" } }\r
-{ $description "Project a space along ith coordinate" } ;\r
-\r
-! --------------------------------------------------------------\r
-! 3D rendering\r
-! --------------------------------------------------------------\r
-ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"\r
-"explanation of 3D rendering"\r
-$nl\r
-"link to functions"\r
-{ $subsections\r
- face->GL\r
- solid->GL\r
- space->GL\r
-}\r
-\r
-;\r
-\r
-HELP: face->GL \r
-{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
-{ $description "display a face" } ;\r
-\r
-HELP: solid->GL \r
-{ $values { "solid" "a solid" } }\r
-{ $description "display a solid" } ;\r
-\r
-HELP: space->GL \r
-{ $values { "space" "a space" } }\r
-{ $description "display a space" } ;\r
-\r
-! --------------------------------------------------------------\r
-! light\r
-! --------------------------------------------------------------\r
-\r
-ARTICLE: "light-page" "Light in ADSODA"\r
-"explanation of light"\r
-$nl\r
-"link to functions"\r
-;\r
-\r
-ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
-{ $code """\r
-! HELP: light position color\r
-! <light> ( -- tuple ) light new ;\r
-! light est un vecteur avec 3 variables pour les couleurs\n\r
- void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n\r
- { \n\r
- // Dot the light direction with the normalized normal of Face.\r
- register double intensity = -(normal * (*this));\r
- // Face is a backface, from light's perspective\r
- if (intensity < 0)\r
- return;\r
- \r
- // Add the intensity componentwise\r
- cRed += red * intensity;\r
- cGreen += green * intensity;\r
- cBlue += blue * intensity;\r
- // Clip to unit range\r
- if (cRed > 1.0) cRed = 1.0;\r
- if (cGreen > 1.0) cGreen = 1.0;\r
- if (cBlue > 1.0) cBlue = 1.0;\r
-""" }\r
-;\r
-\r
-\r
-\r
-ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
-" defined by the concatenation of the normal vector and a constant" \r
- ;\r
-\r
-\r
-\r
-ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
-"multidimensional handler :" \r
-$nl\r
-"design a solid using face delimitations. Only works on convex shapes"\r
-$nl\r
-{ $emphasis "written in C++ by Greg Ferrar" }\r
-$nl\r
-"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
-$nl\r
-"Useful words are describe on the following pages: "\r
-{ $subsections\r
- "face-page"\r
- "solid-page"\r
- "space-page"\r
- "light-page"\r
- "3D-rendering-page"\r
-} ;\r
-\r
-ABOUT: "adsoda-main-page"\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: adsoda
+
+! --------------------------------------------------------------
+! faces
+! --------------------------------------------------------------
+ARTICLE: "face-page" "Face in ADSODA"
+"explanation of faces"
+$nl
+"link to functions" $nl
+"what is an halfspace" $nl
+"halfspace touching-corners adjacent-faces" $nl
+"touching-corners list of pointers to the corners which touch this face" $nl
+"adjacent-faces list of pointers to the faces which touch this face"
+{ $subsections
+ face
+ <face>
+}
+"test relative position"
+{ $subsections
+ point-inside-or-on-face?
+ point-inside-face?
+}
+"handling face"
+{ $subsections
+ flip-face
+ face-translate
+ face-transform
+}
+
+;
+
+HELP: face
+{ $class-description "a face is defined by"
+{ $list "halfspace equation" }
+{ $list "list of touching corners" }
+{ $list "list of adjacent faces" }
+$nl
+"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"
+}
+
+
+;
+HELP: <face>
+{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;
+HELP: flip-face
+{ $values { "face" "a face" } { "face" "flipped face" } }
+{ $description "change the orientation of a face" }
+;
+
+HELP: face-translate
+{ $values { "face" "a face" } { "v" "a vector" } }
+{ $description
+"translate a face following a vector"
+$nl
+"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }
+
+
+ ;
+HELP: face-transform
+{ $values { "face" "a face" } { "m" "a transformation matrix" } }
+{ $description "compute the transformation of a face using a transformation matrix" }
+
+ ;
+! --------------------------------
+! solid
+! --------------------------------------------------------------
+ARTICLE: "solid-page" "Solid in ADSODA"
+"explanation of solids"
+$nl
+"link to functions"
+{ $subsections
+ solid
+ <solid>
+}
+"test relative position"
+{ $subsections
+ point-inside-solid?
+ point-inside-or-on-solid?
+}
+"playing with faces and solids"
+{ $subsections
+ add-face
+ cut-solid
+ slice-solid
+}
+"solid handling"
+{ $subsections
+ solid-project
+ solid-translate
+ solid-transform
+ subtract
+ get-silhouette
+ solid=
+}
+;
+
+HELP: solid
+{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name"
+}
+;
+
+HELP: add-face
+{ $values { "solid" "a solid" } { "face" "a face" } }
+{ $description "reshape a solid with a face. The face truncate the solid." } ;
+
+HELP: cut-solid
+{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }
+{ $description "like add-face but just with halfspace equation" } ;
+
+HELP: slice-solid
+{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }
+{ $description "cut a solid into two parts. The face acts like a knife"
+} ;
+
+
+HELP: solid-project
+{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }
+{ $description "Project the solid using pv vector"
+$nl
+"TODO: explain how to use lights"
+} ;
+
+HELP: solid-translate
+{ $values { "solid" "a solid" } { "v" "translating vector" } }
+{ $description "Translate a solid using a vector"
+$nl
+"v and solid must have the same dimension "
+} ;
+
+HELP: solid-transform
+{ $values { "solid" "a solid" } { "m" "transformation matrix" } }
+{ $description "Transform a solid using a matrix"
+$nl
+"v and solid must have the same dimension "
+} ;
+
+HELP: subtract
+{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }
+{ $description "Substract solid2 from solid1" } ;
+
+
+! --------------------------------------------------------------
+! space
+! --------------------------------------------------------------
+ARTICLE: "space-page" "Space in ADSODA"
+"A space is a collection of solids and lights."
+$nl
+"link to functions"
+$nl
+"Defining words"
+{ $subsections
+ space
+ <space>
+ suffix-solids
+ suffix-lights
+ clear-space-solids
+ describe-space
+}
+
+
+"Handling space"
+{ $subsections
+ space-ensure-solids
+ eliminate-empty-solids
+ space-transform
+ space-translate
+ remove-hidden-solids
+ space-project
+}
+
+
+;
+
+HELP: space
+{ $class-description
+"dimension" $nl " solids" $nl " ambient-color" $nl "lights"
+}
+;
+
+HELP: suffix-solids
+"( space solid -- space )"
+{ $values { "space" "a space" } { "solid" "a solid to add" } }
+{ $description "Add solid to space definition" } ;
+
+HELP: suffix-lights
+"( space light -- space ) "
+{ $values { "space" "a space" } { "light" "a light to add" } }
+{ $description "Add a light to space definition" } ;
+
+HELP: clear-space-solids
+"( space -- space )"
+{ $values { "space" "a space" } }
+{ $description "remove all solids in space" } ;
+
+HELP: space-ensure-solids
+{ $values { "space" "a space" } }
+{ $description "rebuild corners of all solids in space" } ;
+
+
+
+HELP: space-transform
+{ $values { "space" "a space" } { "m" "a matrix" } }
+{ $description "Transform a space using a matrix" } ;
+
+HELP: space-translate
+{ $values { "space" "a space" } { "v" "a vector" } }
+{ $description "Translate a space following a vector" } ;
+
+HELP: describe-space
+{ $values { "space" "a space" } }
+{ $description "return a description of space" } ;
+
+HELP: space-project
+{ $values { "space" "a space" } { "i" "an integer" } }
+{ $description "Project a space along ith coordinate" } ;
+
+! --------------------------------------------------------------
+! 3D rendering
+! --------------------------------------------------------------
+ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"
+"explanation of 3D rendering"
+$nl
+"link to functions"
+{ $subsections
+ face->GL
+ solid->GL
+ space->GL
+}
+
+;
+
+HELP: face->GL
+{ $values { "face" "a face" } { "color" "3 3 values array" } }
+{ $description "display a face" } ;
+
+HELP: solid->GL
+{ $values { "solid" "a solid" } }
+{ $description "display a solid" } ;
+
+HELP: space->GL
+{ $values { "space" "a space" } }
+{ $description "display a space" } ;
+
+! --------------------------------------------------------------
+! light
+! --------------------------------------------------------------
+
+ARTICLE: "light-page" "Light in ADSODA"
+"explanation of light"
+$nl
+"link to functions"
+;
+
+ARTICLE: { "adsoda" "light" } "ADSODA : lights"
+{ $code """
+! HELP: light position color
+! <light> ( -- tuple ) light new ;
+! light est un vecteur avec 3 variables pour les couleurs\n
+ void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n
+ { \n
+ // Dot the light direction with the normalized normal of Face.
+ register double intensity = -(normal * (*this));
+ // Face is a backface, from light's perspective
+ if (intensity < 0)
+ return;
+
+ // Add the intensity componentwise
+ cRed += red * intensity;
+ cGreen += green * intensity;
+ cBlue += blue * intensity;
+ // Clip to unit range
+ if (cRed > 1.0) cRed = 1.0;
+ if (cGreen > 1.0) cGreen = 1.0;
+ if (cBlue > 1.0) cBlue = 1.0;
+""" }
+;
+
+
+
+ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"
+" defined by the concatenation of the normal vector and a constant"
+ ;
+
+
+
+ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"
+"multidimensional handler :"
+$nl
+"design a solid using face delimitations. Only works on convex shapes"
+$nl
+{ $emphasis "written in C++ by Greg Ferrar" }
+$nl
+"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }
+$nl
+"Useful words are describe on the following pages: "
+{ $subsections
+ "face-page"
+ "solid-page"
+ "space-page"
+ "light-page"
+ "3D-rendering-page"
+} ;
+
+ABOUT: "adsoda-main-page"
-USING: adsoda\r
-kernel\r
-math\r
-accessors\r
-sequences\r
- adsoda.solution2\r
- fry\r
- tools.test \r
- arrays ;\r
-\r
-IN: adsoda.tests\r
-\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
-\r
-\r
-! {\r
-! { 1 0 0 0 }\r
-! { 0 1 0 0 }\r
-! { 0 0 0.984807753012208 -0.1736481776669303 }\r
-! { 0 0 0.1736481776669303 0.984807753012208 }\r
-! }\r
-\r
-! ------------------------------------------------------------\r
-! constant+\r
-[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! translate\r
-[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! transform\r
-[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 }\r
- } transform \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! compare-nleft-to-identity-matrix\r
-[ t ] [ \r
- { \r
- { 1 0 0 1232 } \r
- { 0 1 0 0 321 } \r
- { 0 0 1 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-! ------------------------------------------------------------\r
-[ t ] [ \r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 2 valid-solution? \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-[ 3 ] [ { 1 2 3 } last ] unit-test \r
-\r
-[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
-\r
-! ------------------------------------------------------------\r
-! position-point \r
-[ 0 ] [ \r
- { 1 -1 -5 } { 2 7 } position-point \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-\r
-! transform\r
-! TODO construire un exemple\r
-\r
-\r
-! ------------------------------------------------------------\r
-! slice-solid \r
-\r
-! ------------------------------------------------------------\r
-! solve-equation \r
-! deux cas de tests, avec solution et sans solution\r
-\r
-[ { 2 7 } ] \r
-[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-! ------------------------------------------------------------\r
-! point-inside-halfspace\r
-[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
-unit-test\r
-[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
-unit-test\r
-[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
-unit-test\r
-\r
-\r
-! ------------------------------\r
-! order solid\r
-\r
-[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
-[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
-\r
-\r
-! clip-solid\r
-[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
- [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-solid2 corners>> '[ _ ]\r
- [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-!\r
-[\r
- {\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
- }\r
-] [ 0 >pv solid2 solid3 2array \r
- solid1 (solids-silhouette-subtract) \r
- [ corners>> ] map\r
- ] unit-test\r
-\r
-\r
-[\r
-{\r
- { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
-}\r
-] [ \r
- 0 >pv <space> solid1 suffix-solids \r
- solid2 suffix-solids \r
- solid3 suffix-solids\r
- remove-hidden-solids\r
- solids>> [ corners>> ] map\r
-] unit-test\r
-\r
-! { }\r
-! { }\r
-! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
-! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
-! suffix \r
-! { 0.1 0.1 0.1 } suffix ! ambient color\r
-! { 0.23 0.32 0.17 } suffix ! solid color\r
-! solid3 faces>> first \r
-\r
-! enlight-projection\r
+USING: adsoda
+kernel
+math
+accessors
+sequences
+ adsoda.solution2
+ fry
+ tools.test
+ arrays ;
+
+IN: adsoda.tests
+
+
+
+: s1 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "s1" >>name
+ { 1 1 1 } >>color
+ { 1 -1 -5 } cut-solid
+ { -1 -1 -21 } cut-solid
+ { -1 0 -12 } cut-solid
+ { 1 2 16 } cut-solid
+;
+: solid1 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid1" >>name
+ { 1 -1 -5 } cut-solid
+ { -1 -1 -21 } cut-solid
+ { -1 0 -12 } cut-solid
+ { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+;
+: solid2 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid2" >>name
+ { -1 1 -10 } cut-solid
+ { -1 -1 -28 } cut-solid
+ { 1 0 13 } cut-solid
+ ! { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid3 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid3" >>name
+ { 1 1 1 } >>color
+ { 1 0 16 } cut-solid
+ { -1 0 -36 } cut-solid
+ { 0 1 1 } cut-solid
+ { 0 -1 -17 } cut-solid
+ ! { 1 2 16 } cut-solid
+ ensure-adjacencies
+
+
+;
+
+: solid4 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid4" >>name
+ { 1 1 1 } >>color
+ { 1 0 21 } cut-solid
+ { -1 0 -36 } cut-solid
+ { 0 1 1 } cut-solid
+ { 0 -1 -17 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid5 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid5" >>name
+ { 1 1 1 } >>color
+ { 1 0 6 } cut-solid
+ { -1 0 -17 } cut-solid
+ { 0 1 17 } cut-solid
+ { 0 -1 -19 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid7 ( -- solid )
+ <solid>
+ 2 >>dimension
+ "solid7" >>name
+ { 1 1 1 } >>color
+ { 1 0 38 } cut-solid
+ { 1 -5 -66 } cut-solid
+ { -2 1 -75 } cut-solid
+ ensure-adjacencies
+
+;
+
+: solid6s ( -- seq )
+ solid3 clone solid2 clone subtract
+;
+
+: space1 ( -- space )
+ <space>
+ 2 >>dimension
+ ! solid3 suffix-solids
+ solid1 suffix-solids
+ solid2 suffix-solids
+ ! solid6s [ suffix-solids ] each
+ solid4 suffix-solids
+ ! solid5 suffix-solids
+ solid7 suffix-solids
+ { 1 1 1 } >>ambient-color
+ <light>
+ { -100 -100 } >>position
+ { 0.2 0.7 0.1 } >>color
+ suffix-lights
+;
+
+: space2 ( -- space )
+ <space>
+ 4 >>dimension
+ ! 4cube suffix-solids
+ { 1 1 1 } >>ambient-color
+ <light>
+ { -100 -100 } >>position
+ { 0.2 0.7 0.1 } >>color
+ suffix-lights
+
+ ;
+
+
+
+! {
+! { 1 0 0 0 }
+! { 0 1 0 0 }
+! { 0 0 0.984807753012208 -0.1736481776669303 }
+! { 0 0 0.1736481776669303 0.984807753012208 }
+! }
+
+! ------------------------------------------------------------
+! constant+
+[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test
+
+! ------------------------------------------------------------
+! translate
+[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test
+
+! ------------------------------------------------------------
+! transform
+[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }
+ { { 1 0 0 }
+ { 0 1 0 }
+ { 0 0 1 }
+ } transform
+] unit-test
+
+! ------------------------------------------------------------
+! compare-nleft-to-identity-matrix
+[ t ] [
+ {
+ { 1 0 0 1232 }
+ { 0 1 0 0 321 }
+ { 0 0 1 0 } }
+ 3 compare-nleft-to-identity-matrix
+] unit-test
+
+[ f ] [
+ { { 1 0 0 } { 0 1 0 } { 0 0 0 } }
+ 3 compare-nleft-to-identity-matrix
+] unit-test
+
+[ f ] [
+ { { 2 0 0 } { 0 1 0 } { 0 0 1 } }
+ 3 compare-nleft-to-identity-matrix
+] unit-test
+! ------------------------------------------------------------
+[ t ] [
+ { { 1 0 0 }
+ { 0 1 0 }
+ { 0 0 1 } } 3 valid-solution?
+] unit-test
+
+[ f ] [
+ { { 1 0 0 1 }
+ { 0 0 0 1 }
+ { 0 0 1 0 } } 3 valid-solution?
+] unit-test
+
+[ f ] [
+ { { 1 0 0 1 }
+ { 0 0 0 1 } } 3 valid-solution?
+] unit-test
+
+[ f ] [
+ { { 1 0 0 1 }
+ { 0 0 0 1 }
+ { 0 0 1 0 } } 2 valid-solution?
+] unit-test
+
+! ------------------------------------------------------------
+[ 3 ] [ { 1 2 3 } last ] unit-test
+
+[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test
+
+! ------------------------------------------------------------
+! position-point
+[ 0 ] [
+ { 1 -1 -5 } { 2 7 } position-point
+] unit-test
+
+! ------------------------------------------------------------
+
+! transform
+! TODO construire un exemple
+
+
+! ------------------------------------------------------------
+! slice-solid
+
+! ------------------------------------------------------------
+! solve-equation
+! deux cas de tests, avec solution et sans solution
+
+[ { 2 7 } ]
+[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ]
+unit-test
+
+[ f ]
+[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]
+unit-test
+
+[ f ]
+[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]
+unit-test
+
+! ------------------------------------------------------------
+! point-inside-halfspace
+[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ]
+unit-test
+[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ]
+unit-test
+[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ]
+unit-test
+
+
+! ------------------------------
+! order solid
+
+[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test
+[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test
+[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test
+[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test
+
+
+! clip-solid
+[ { { 13 15 } { 15 13 } { 13 13 } } ]
+ [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test
+
+solid1 corners>> '[ _ ]
+ [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test
+
+solid1 corners>> '[ _ ]
+ [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test
+
+solid1 corners>> '[ _ ]
+ [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test
+solid2 corners>> '[ _ ]
+ [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test
+
+!
+[
+ {
+ { { 13 15 } { 15 13 } { 13 13 } }
+ { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }
+ }
+] [ 0 >pv solid2 solid3 2array
+ solid1 (solids-silhouette-subtract)
+ [ corners>> ] map
+ ] unit-test
+
+
+[
+{
+ { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }
+ { { 13 15 } { 15 13 } { 13 13 } }
+ { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }
+}
+] [
+ 0 >pv <space> solid1 suffix-solids
+ solid2 suffix-solids
+ solid3 suffix-solids
+ remove-hidden-solids
+ solids>> [ corners>> ] map
+] unit-test
+
+! { }
+! { }
+! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix
+! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix
+! suffix
+! { 0.1 0.1 0.1 } suffix ! ambient color
+! { 0.23 0.32 0.17 } suffix ! solid color
+! solid3 faces>> first
+
+! enlight-projection
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors\r
-arrays \r
-assocs\r
-combinators\r
-kernel \r
-fry\r
-math \r
-math.constants\r
-math.functions\r
-math.libm\r
-math.order\r
-math.vectors \r
-math.matrices \r
-math.parser\r
-namespaces\r
-prettyprint\r
-sequences\r
-sequences.deep\r
-sets\r
-slots\r
-sorting\r
-tools.time\r
-vars\r
-continuations\r
-words\r
-opengl\r
-opengl.gl\r
-colors\r
-adsoda.solution2\r
-adsoda.combinators\r
-opengl.demo-support\r
-values\r
-tools.walker\r
-;\r
-\r
-IN: adsoda\r
-\r
-DEFER: combinations\r
-VAR: pv\r
-\r
-\r
-! -------------------------------------------------------------\r
-! global values\r
-VALUE: remove-hidden-solids?\r
-VALUE: VERY-SMALL-NUM\r
-VALUE: ZERO-VALUE\r
-VALUE: MAX-FACE-PER-CORNER\r
-\r
-t \ remove-hidden-solids? set-value\r
-0.0000001 \ VERY-SMALL-NUM set-value\r
-0.0000001 \ ZERO-VALUE set-value\r
-4 \ MAX-FACE-PER-CORNER set-value\r
-! -------------------------------------------------------------\r
-! sequence complement\r
-\r
-: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
-\r
-: dimension ( array -- x ) length 1 - ; inline \r
-: change-last ( seq quot -- ) \r
- [ [ dimension ] keep ] dip change-nth ; inline\r
-\r
-! -------------------------------------------------------------\r
-! light\r
-! -------------------------------------------------------------\r
-\r
-TUPLE: light name { direction array } color ;\r
-: <light> ( -- tuple ) light new ;\r
-\r
-! -------------------------------------------------------------\r
-! halfspace manipulation\r
-! -------------------------------------------------------------\r
-\r
-: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
-: translate ( u v -- w ) dupd v* sum constant+ ; \r
-\r
-: transform ( u matrix -- w )\r
- [ swap m.v ] 2keep ! compute new normal vector \r
- [\r
- [ [ abs ZERO-VALUE > ] find ] keep \r
- ! find a point on the frontier\r
- ! be sure it's not null vector\r
- last ! get constant\r
- swap /f neg swap ! intercept value\r
- ] dip \r
- flip \r
- nth\r
- [ * ] with map ! apply intercep value\r
- over v*\r
- sum neg\r
- suffix ! add value as constant at the end of equation\r
-;\r
-\r
-: position-point ( halfspace v -- x ) \r
- -1 suffix v* sum ; inline\r
-: point-inside-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM > ; \r
-: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM neg > ;\r
-: project-vector ( seq -- seq ) \r
- pv> [ head ] [ 1 + tail ] 2bi append ; \r
-: get-intersection ( matrice -- seq ) \r
- [ 1 tail* ] map flip first ;\r
-\r
-: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
-\r
-: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
- [ [ head ] curry map ] keep identity-matrix m- \r
- flatten\r
- [ abs ZERO-VALUE < ] all?\r
-;\r
-\r
-: valid-solution? ( matrice n -- ? )\r
- islenght=?\r
- [ compare-nleft-to-identity-matrix ] \r
- [ 2drop f ] if ; inline\r
-\r
-: intersect-hyperplanes ( matrice -- seq )\r
- [ solution dup ] [ first dimension ] bi\r
- valid-solution? [ get-intersection ] [ drop f ] if ;\r
-\r
-! -------------------------------------------------------------\r
-! faces\r
-! -------------------------------------------------------------\r
-\r
-TUPLE: face { halfspace array } \r
- touching-corners adjacent-faces ;\r
-: <face> ( v -- tuple ) face new swap >>halfspace ;\r
-: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
-: erase-face-touching-corners ( face -- face ) \r
- f >>touching-corners ;\r
-: erase-face-adjacent-faces ( face -- face ) \r
- f >>adjacent-faces ;\r
-: faces-intersection ( faces -- v ) \r
- [ halfspace>> ] map intersect-hyperplanes ;\r
-: face-translate ( face v -- face ) \r
- [ translate ] curry change-halfspace ; inline\r
-: face-transform ( face m -- face )\r
- [ transform ] curry change-halfspace ; inline\r
-: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
-: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
-: pv-factor ( face -- f face ) \r
- halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
-: suffix-touching-corner ( face corner -- face ) \r
- [ suffix ] curry change-touching-corners ; inline\r
-: real-face? ( face -- ? )\r
- [ touching-corners>> length ] \r
- [ halfspace>> dimension ] bi >= ;\r
-\r
-: (add-to-adjacent-faces) ( face face -- face )\r
- over adjacent-faces>> 2dup member?\r
- [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
-\r
-: add-to-adjacent-faces ( face face -- face )\r
- 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
-\r
-: update-adjacent-faces ( faces corner -- )\r
- '[ [ _ suffix-touching-corner drop ] each ] keep \r
- 2 among [ \r
- [ first ] keep second \r
- [ add-to-adjacent-faces drop ] 2keep \r
- swap add-to-adjacent-faces drop \r
- ] each ; inline\r
-\r
-: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
-\r
-: apply-light ( color light normal -- u )\r
- over direction>> v. \r
- neg dup 0 > \r
- [ \r
- [ color>> swap ] dip \r
- [ * ] curry map v+ \r
- [ 1 min ] map \r
- ] \r
- [ 2drop ] \r
- if\r
-;\r
-\r
-: enlight-projection ( array face -- color )\r
- ! array = lights + ambient color\r
- [ [ third ] [ second ] [ first ] tri ]\r
- [ halfspace>> project-vector normalize ] bi*\r
- [ apply-light ] curry each\r
- v*\r
-;\r
-\r
-: (intersection-into-face) ( face-init face-adja quot -- face )\r
- [\r
- [ [ pv-factor ] bi@ \r
- roll \r
- [ map ] 2bi@\r
- v-\r
- ] 2keep\r
- [ touching-corners>> ] bi@\r
- [ swap [ = ] curry find nip f = ] curry find nip\r
- ] dip over\r
- [\r
- call\r
- dupd\r
- point-inside-halfspace? [ vneg ] unless \r
- <face> \r
- ] [ 3drop f ] if \r
- ; inline\r
-\r
-: intersection-into-face ( face-init face-adja -- face )\r
- [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
-\r
-: intersection-into-silhouette-face ( face-init face-adja -- face )\r
- [ ] (intersection-into-face) ;\r
-\r
-: intersections-into-faces ( face -- faces )\r
- clone dup \r
- adjacent-faces>> [ intersection-into-face ] with map \r
- sift ;\r
-\r
-: (face-silhouette) ( face -- faces )\r
- clone dup adjacent-faces>>\r
- [ backface?\r
- [ intersection-into-silhouette-face ] [ 2drop f ] if \r
- ] with map \r
- sift\r
-; inline\r
-\r
-: face-silhouette ( face -- faces ) \r
- backface? [ drop f ] [ (face-silhouette) ] if ;\r
-\r
-! --------------------------------\r
-! solid\r
-! -------------------------------------------------------------\r
-TUPLE: solid dimension silhouettes \r
- faces corners adjacencies-valid color name ;\r
-\r
-: <solid> ( -- tuple ) solid new ;\r
-\r
-: suffix-silhouettes ( solid silhouette -- solid ) \r
- [ suffix ] curry change-silhouettes ;\r
-\r
-: suffix-face ( solid face -- solid ) \r
- [ suffix ] curry change-faces ;\r
-: suffix-corner ( solid corner -- solid ) \r
- [ suffix ] curry change-corners ; \r
-: erase-solid-corners ( solid -- solid ) f >>corners ;\r
-\r
-: erase-silhouettes ( solid -- solid ) \r
- dup dimension>> f <array> >>silhouettes ;\r
-: filter-real-faces ( solid -- solid ) \r
- [ [ real-face? ] filter ] change-faces ;\r
-: initiate-solid-from-face ( face -- solid ) \r
- face-project-dim <solid> swap >>dimension ;\r
-\r
-: erase-old-adjacencies ( solid -- solid )\r
- erase-solid-corners\r
- [ dup [ erase-face-touching-corners \r
- erase-face-adjacent-faces drop ] each ]\r
- change-faces ;\r
-\r
-: point-inside-or-on-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
-\r
-: point-inside-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-halfspace? ;\r
-\r
-: point-inside-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
-\r
-: point-inside-or-on-solid? ( solid point -- ? )\r
- [ faces>> ] dip \r
- [ point-inside-or-on-face? ] curry all? ; inline\r
-\r
-: unvalid-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies f >>adjacencies-valid \r
- erase-silhouettes ;\r
-\r
-: add-face ( solid face -- solid ) \r
- suffix-face unvalid-adjacencies ; \r
-\r
-: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
-\r
-: slice-solid ( solid face -- solid1 solid2 )\r
- [ [ clone ] bi@ flip-face add-face \r
- [ "/outer/" append ] change-name ] 2keep\r
- add-face [ "/inner/" append ] change-name ;\r
-\r
-! -------------\r
-\r
-\r
-: add-silhouette ( solid -- solid )\r
- dup \r
- ! find-adjacencies \r
- faces>> { } \r
- [ face-silhouette append ] reduce\r
- sift\r
- <solid> \r
- swap >>faces\r
- over dimension>> >>dimension \r
- over name>> " silhouette " append \r
- pv> number>string append \r
- >>name\r
- ! ensure-adjacencies\r
- suffix-silhouettes ; inline\r
-\r
-: find-silhouettes ( solid -- solid )\r
- { } >>silhouettes \r
- dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
-\r
-: ensure-silhouettes ( solid -- solid )\r
- dup silhouettes>> [ f = ] all?\r
- [ find-silhouettes ] when ; \r
-\r
-! ------------\r
-\r
-: corner-added? ( solid corner -- ? ) \r
- ! add corner to solid if it is inside solid\r
- [ ] \r
- [ point-inside-or-on-solid? ] \r
- [ swap corners>> member? not ] \r
- 2tri and\r
- [ suffix-corner drop t ] [ 2drop f ] if ;\r
-\r
-: process-corner ( solid faces corner -- )\r
- swapd \r
- [ corner-added? ] keep swap ! test if corner is inside solid\r
- [ update-adjacent-faces ] \r
- [ 2drop ]\r
- if ;\r
-\r
-: compute-intersection ( solid faces -- )\r
- dup faces-intersection\r
- dup f = [ 3drop ] [ process-corner ] if ;\r
-\r
-: test-faces-combinaisons ( solid n -- )\r
- [ dup faces>> ] dip among \r
- [ compute-intersection ] with each ;\r
-\r
-: compute-adjacencies ( solid -- solid )\r
- dup dimension>> [ >= ] curry \r
- [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
-\r
-: find-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies \r
- compute-adjacencies\r
- filter-real-faces \r
- t >>adjacencies-valid ;\r
-\r
-: ensure-adjacencies ( solid -- solid ) \r
- dup adjacencies-valid>> \r
- [ find-adjacencies ] unless \r
- ensure-silhouettes\r
- ;\r
-\r
-: (non-empty-solid?) ( solid -- ? ) \r
- [ dimension>> ] [ corners>> length ] bi < ;\r
-: non-empty-solid? ( solid -- ? ) \r
- ensure-adjacencies (non-empty-solid?) ;\r
-\r
-: compare-corners-roughly ( corner corner -- ? )\r
- 2drop t ;\r
-! : remove-inner-faces ( -- ) ;\r
-: face-project ( array face -- seq )\r
- backface? \r
- [ 2drop f ]\r
- [ [ enlight-projection ] \r
- [ initiate-solid-from-face ]\r
- [ intersections-into-faces ] tri\r
- >>faces\r
- swap >>color \r
- ] if ;\r
-\r
-: solid-project ( lights ambient solid -- solids )\r
- ensure-adjacencies\r
- [ color>> ] [ faces>> ] bi [ 3array ] dip\r
- [ face-project ] with map \r
- sift\r
- [ ensure-adjacencies ] map\r
-;\r
-\r
-: (solid-move) ( solid v move -- solid ) \r
- curry [ map ] curry \r
- [ dup faces>> ] dip call drop \r
- unvalid-adjacencies ; inline\r
-\r
-: solid-translate ( solid v -- solid ) \r
- [ face-translate ] (solid-move) ; \r
-: solid-transform ( solid m -- solid ) \r
- [ face-transform ] (solid-move) ; \r
-\r
-: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
- pv> swap silhouettes>> nth \r
- swap corners>>\r
- [ point-inside-solid? ] with find swap ;\r
-\r
-: valid-face-for-order ( solid point -- face )\r
- [ point-inside-face? not ] \r
- [ drop face-orientation 0 = not ] 2bi and ;\r
-\r
-: check-orientation ( s1 s2 pt -- int )\r
- [ nip faces>> ] dip\r
- [ valid-face-for-order ] curry find swap\r
- [ face-orientation ] [ drop f ] if ;\r
-\r
-: (order-solid) ( s1 s2 -- int )\r
- 2dup find-corner-in-silhouette\r
- [ check-orientation ] [ 3drop f ] if ;\r
-\r
-: order-solid ( solid solid -- i ) \r
- 2dup (order-solid)\r
- [ 2nip ]\r
- [ swap (order-solid)\r
- [ neg ] [ f ] if*\r
- ] if* ;\r
-\r
-: subtract ( solid1 solid2 -- solids )\r
- faces>> swap clone ensure-adjacencies ensure-silhouettes \r
- [ swap slice-solid drop ] curry map\r
- [ non-empty-solid? ] filter\r
- [ ensure-adjacencies ] map\r
-; inline\r
-\r
-! -------------------------------------------------------------\r
-! space \r
-! -------------------------------------------------------------\r
-TUPLE: space name dimension solids ambient-color lights ;\r
-: <space> ( -- space ) space new ;\r
-: suffix-solids ( space solid -- space ) \r
- [ suffix ] curry change-solids ; inline\r
-: suffix-lights ( space light -- space ) \r
- [ suffix ] curry change-lights ; inline\r
-: clear-space-solids ( space -- space ) f >>solids ;\r
-\r
-: space-ensure-solids ( space -- space ) \r
- [ [ ensure-adjacencies ] map ] change-solids ;\r
-: eliminate-empty-solids ( space -- space ) \r
- [ [ non-empty-solid? ] filter ] change-solids ;\r
-\r
-: projected-space ( space solids -- space ) \r
- swap dimension>> 1 - <space> \r
- swap >>dimension swap >>solids ;\r
-\r
-: get-silhouette ( solid -- silhouette ) \r
- silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] same? ;\r
-\r
-: space-apply ( space m quot -- space ) \r
- curry [ map ] curry [ dup solids>> ] dip\r
- [ call ] [ 2drop ] recover drop ; inline\r
-: space-transform ( space m -- space ) \r
- [ solid-transform ] space-apply ;\r
-: space-translate ( space v -- space ) \r
- [ solid-translate ] space-apply ; \r
-\r
-: describe-space ( space -- ) \r
- solids>> \r
- [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
-\r
-: clip-solid ( solid solid -- solids )\r
- [ ]\r
- [ solid= not ]\r
- [ order-solid -1 = ] 2tri \r
- and\r
- [ get-silhouette subtract ] \r
- [ drop 1array ] \r
- if \r
- \r
- ;\r
-\r
-: (solids-silhouette-subtract) ( solids solid -- solids ) \r
- [ clip-solid append ] curry { } -rot each ; inline\r
-\r
-: solids-silhouette-subtract ( solids i solid -- solids )\r
-! solids is an array of 1 solid arrays\r
- [ (solids-silhouette-subtract) ] curry map-but \r
-; inline \r
-\r
-: remove-hidden-solids ( space -- space ) \r
-! We must include each solid in a sequence because \r
-! during substration \r
-! a solid can be divided in more than on solid\r
- [ \r
- [ [ 1array ] map ] \r
- [ length ] \r
- [ ] \r
- tri \r
- [ solids-silhouette-subtract ] 2each\r
- { } [ append ] reduce \r
- ] change-solids\r
- eliminate-empty-solids ! TODO include into change-solids\r
-;\r
-\r
-: space-project ( space i -- space )\r
- [\r
- [ clone \r
- remove-hidden-solids? [ remove-hidden-solids ] when\r
- dup \r
- [ solids>> ] \r
- [ lights>> ] \r
- [ ambient-color>> ] tri \r
- [ rot solid-project ] 2curry \r
- map \r
- [ append ] { } -rot each \r
- ! TODO project lights\r
- projected-space \r
- ! remove-inner-faces \r
- ! \r
- eliminate-empty-solids\r
- ] with-pv \r
- ] [ 3drop <space> ] recover\r
- ; inline\r
-\r
-: middle-of-space ( space -- point )\r
- solids>> [ corners>> ] map concat\r
- [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
-;\r
-\r
-! -------------------------------------------------------------\r
-! 3D rendering\r
-! -------------------------------------------------------------\r
-\r
-: face-reference ( face -- halfspace point vect )\r
- [ halfspace>> ] \r
- [ touching-corners>> first ] \r
- [ touching-corners>> second ] tri \r
- over v-\r
-;\r
-\r
-: theta ( v halfspace point vect -- v x )\r
- [ [ over ] dip v- ] dip \r
- [ cross dup norm >float ]\r
- [ v. >float ] \r
- 2bi \r
- fatan2\r
- -rot v. \r
- 0 < [ neg ] when\r
-;\r
-\r
-: ordered-face-points ( face -- corners ) \r
- [ touching-corners>> 1 head ] \r
- [ touching-corners>> 1 tail ] \r
- [ face-reference [ theta ] 3curry ] tri\r
- { } map>assoc sort-values keys \r
- append\r
- ; inline\r
-\r
-: point->GL ( point -- ) gl-vertex ;\r
-: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
-\r
-: face->GL ( face color -- )\r
- [ ordered-face-points ] dip\r
- [ first3 1.0 glColor4d GL_POLYGON \r
- [ [ point->GL ] each ] do-state ] curry\r
- [ 0 0 0 1 glColor4d GL_LINE_LOOP \r
- [ [ point->GL ] each ] do-state ]\r
- bi\r
- ; inline\r
-\r
-: solid->GL ( solid -- ) \r
- [ faces>> ] \r
- [ color>> ] bi\r
- [ face->GL ] curry each ; inline\r
-\r
-: space->GL ( space -- )\r
- solids>>\r
- [ solid->GL ] each ;\r
-\r
-\r
-\r
-\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors
+arrays
+assocs
+combinators
+kernel
+fry
+math
+math.constants
+math.functions
+math.libm
+math.order
+math.vectors
+math.matrices
+math.parser
+namespaces
+prettyprint
+sequences
+sequences.deep
+sets
+slots
+sorting
+tools.time
+vars
+continuations
+words
+opengl
+opengl.gl
+colors
+adsoda.solution2
+adsoda.combinators
+opengl.demo-support
+values
+tools.walker
+;
+
+IN: adsoda
+
+DEFER: combinations
+VAR: pv
+
+
+! -------------------------------------------------------------
+! global values
+VALUE: remove-hidden-solids?
+VALUE: VERY-SMALL-NUM
+VALUE: ZERO-VALUE
+VALUE: MAX-FACE-PER-CORNER
+
+t \ remove-hidden-solids? set-value
+0.0000001 \ VERY-SMALL-NUM set-value
+0.0000001 \ ZERO-VALUE set-value
+4 \ MAX-FACE-PER-CORNER set-value
+! -------------------------------------------------------------
+! sequence complement
+
+: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline
+
+: dimension ( array -- x ) length 1 - ; inline
+: change-last ( seq quot -- )
+ [ [ dimension ] keep ] dip change-nth ; inline
+
+! -------------------------------------------------------------
+! light
+! -------------------------------------------------------------
+
+TUPLE: light name { direction array } color ;
+: <light> ( -- tuple ) light new ;
+
+! -------------------------------------------------------------
+! halfspace manipulation
+! -------------------------------------------------------------
+
+: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;
+: translate ( u v -- w ) dupd v* sum constant+ ;
+
+: transform ( u matrix -- w )
+ [ swap m.v ] 2keep ! compute new normal vector
+ [
+ [ [ abs ZERO-VALUE > ] find ] keep
+ ! find a point on the frontier
+ ! be sure it's not null vector
+ last ! get constant
+ swap /f neg swap ! intercept value
+ ] dip
+ flip
+ nth
+ [ * ] with map ! apply intercep value
+ over v*
+ sum neg
+ suffix ! add value as constant at the end of equation
+;
+
+: position-point ( halfspace v -- x )
+ -1 suffix v* sum ; inline
+: point-inside-halfspace? ( halfspace v -- ? )
+ position-point VERY-SMALL-NUM > ;
+: point-inside-or-on-halfspace? ( halfspace v -- ? )
+ position-point VERY-SMALL-NUM neg > ;
+: project-vector ( seq -- seq )
+ pv> [ head ] [ 1 + tail ] 2bi append ;
+: get-intersection ( matrice -- seq )
+ [ 1 tail* ] map flip first ;
+
+: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;
+
+: compare-nleft-to-identity-matrix ( seq n -- ? )
+ [ [ head ] curry map ] keep identity-matrix m-
+ flatten
+ [ abs ZERO-VALUE < ] all?
+;
+
+: valid-solution? ( matrice n -- ? )
+ islenght=?
+ [ compare-nleft-to-identity-matrix ]
+ [ 2drop f ] if ; inline
+
+: intersect-hyperplanes ( matrice -- seq )
+ [ solution dup ] [ first dimension ] bi
+ valid-solution? [ get-intersection ] [ drop f ] if ;
+
+! -------------------------------------------------------------
+! faces
+! -------------------------------------------------------------
+
+TUPLE: face { halfspace array }
+ touching-corners adjacent-faces ;
+: <face> ( v -- tuple ) face new swap >>halfspace ;
+: flip-face ( face -- face ) [ vneg ] change-halfspace ;
+: erase-face-touching-corners ( face -- face )
+ f >>touching-corners ;
+: erase-face-adjacent-faces ( face -- face )
+ f >>adjacent-faces ;
+: faces-intersection ( faces -- v )
+ [ halfspace>> ] map intersect-hyperplanes ;
+: face-translate ( face v -- face )
+ [ translate ] curry change-halfspace ; inline
+: face-transform ( face m -- face )
+ [ transform ] curry change-halfspace ; inline
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;
+: backface? ( face -- face ? ) dup face-orientation 0 <= ;
+: pv-factor ( face -- f face )
+ halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline
+: suffix-touching-corner ( face corner -- face )
+ [ suffix ] curry change-touching-corners ; inline
+: real-face? ( face -- ? )
+ [ touching-corners>> length ]
+ [ halfspace>> dimension ] bi >= ;
+
+: (add-to-adjacent-faces) ( face face -- face )
+ over adjacent-faces>> 2dup member?
+ [ 2drop ] [ swap suffix >>adjacent-faces ] if ;
+
+: add-to-adjacent-faces ( face face -- face )
+ 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;
+
+: update-adjacent-faces ( faces corner -- )
+ '[ [ _ suffix-touching-corner drop ] each ] keep
+ 2 among [
+ [ first ] keep second
+ [ add-to-adjacent-faces drop ] 2keep
+ swap add-to-adjacent-faces drop
+ ] each ; inline
+
+: face-project-dim ( face -- x ) halfspace>> length 2 - ;
+
+: apply-light ( color light normal -- u )
+ over direction>> v.
+ neg dup 0 >
+ [
+ [ color>> swap ] dip
+ [ * ] curry map v+
+ [ 1 min ] map
+ ]
+ [ 2drop ]
+ if
+;
+
+: enlight-projection ( array face -- color )
+ ! array = lights + ambient color
+ [ [ third ] [ second ] [ first ] tri ]
+ [ halfspace>> project-vector normalize ] bi*
+ [ apply-light ] curry each
+ v*
+;
+
+: (intersection-into-face) ( face-init face-adja quot -- face )
+ [
+ [ [ pv-factor ] bi@
+ roll
+ [ map ] 2bi@
+ v-
+ ] 2keep
+ [ touching-corners>> ] bi@
+ [ swap [ = ] curry find nip f = ] curry find nip
+ ] dip over
+ [
+ call
+ dupd
+ point-inside-halfspace? [ vneg ] unless
+ <face>
+ ] [ 3drop f ] if
+ ; inline
+
+: intersection-into-face ( face-init face-adja -- face )
+ [ [ project-vector ] bi@ ] (intersection-into-face) ;
+
+: intersection-into-silhouette-face ( face-init face-adja -- face )
+ [ ] (intersection-into-face) ;
+
+: intersections-into-faces ( face -- faces )
+ clone dup
+ adjacent-faces>> [ intersection-into-face ] with map
+ sift ;
+
+: (face-silhouette) ( face -- faces )
+ clone dup adjacent-faces>>
+ [ backface?
+ [ intersection-into-silhouette-face ] [ 2drop f ] if
+ ] with map
+ sift
+; inline
+
+: face-silhouette ( face -- faces )
+ backface? [ drop f ] [ (face-silhouette) ] if ;
+
+! --------------------------------
+! solid
+! -------------------------------------------------------------
+TUPLE: solid dimension silhouettes
+ faces corners adjacencies-valid color name ;
+
+: <solid> ( -- tuple ) solid new ;
+
+: suffix-silhouettes ( solid silhouette -- solid )
+ [ suffix ] curry change-silhouettes ;
+
+: suffix-face ( solid face -- solid )
+ [ suffix ] curry change-faces ;
+: suffix-corner ( solid corner -- solid )
+ [ suffix ] curry change-corners ;
+: erase-solid-corners ( solid -- solid ) f >>corners ;
+
+: erase-silhouettes ( solid -- solid )
+ dup dimension>> f <array> >>silhouettes ;
+: filter-real-faces ( solid -- solid )
+ [ [ real-face? ] filter ] change-faces ;
+: initiate-solid-from-face ( face -- solid )
+ face-project-dim <solid> swap >>dimension ;
+
+: erase-old-adjacencies ( solid -- solid )
+ erase-solid-corners
+ [ dup [ erase-face-touching-corners
+ erase-face-adjacent-faces drop ] each ]
+ change-faces ;
+
+: point-inside-or-on-face? ( face v -- ? )
+ [ halfspace>> ] dip point-inside-or-on-halfspace? ;
+
+: point-inside-face? ( face v -- ? )
+ [ halfspace>> ] dip point-inside-halfspace? ;
+
+: point-inside-solid? ( solid point -- ? )
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline
+
+: point-inside-or-on-solid? ( solid point -- ? )
+ [ faces>> ] dip
+ [ point-inside-or-on-face? ] curry all? ; inline
+
+: unvalid-adjacencies ( solid -- solid )
+ erase-old-adjacencies f >>adjacencies-valid
+ erase-silhouettes ;
+
+: add-face ( solid face -- solid )
+ suffix-face unvalid-adjacencies ;
+
+: cut-solid ( solid halfspace -- solid ) <face> add-face ;
+
+: slice-solid ( solid face -- solid1 solid2 )
+ [ [ clone ] bi@ flip-face add-face
+ [ "/outer/" append ] change-name ] 2keep
+ add-face [ "/inner/" append ] change-name ;
+
+! -------------
+
+
+: add-silhouette ( solid -- solid )
+ dup
+ ! find-adjacencies
+ faces>> { }
+ [ face-silhouette append ] reduce
+ sift
+ <solid>
+ swap >>faces
+ over dimension>> >>dimension
+ over name>> " silhouette " append
+ pv> number>string append
+ >>name
+ ! ensure-adjacencies
+ suffix-silhouettes ; inline
+
+: find-silhouettes ( solid -- solid )
+ { } >>silhouettes
+ dup dimension>> [ [ add-silhouette ] with-pv ] each ;
+
+: ensure-silhouettes ( solid -- solid )
+ dup silhouettes>> [ f = ] all?
+ [ find-silhouettes ] when ;
+
+! ------------
+
+: corner-added? ( solid corner -- ? )
+ ! add corner to solid if it is inside solid
+ [ ]
+ [ point-inside-or-on-solid? ]
+ [ swap corners>> member? not ]
+ 2tri and
+ [ suffix-corner drop t ] [ 2drop f ] if ;
+
+: process-corner ( solid faces corner -- )
+ swapd
+ [ corner-added? ] keep swap ! test if corner is inside solid
+ [ update-adjacent-faces ]
+ [ 2drop ]
+ if ;
+
+: compute-intersection ( solid faces -- )
+ dup faces-intersection
+ dup f = [ 3drop ] [ process-corner ] if ;
+
+: test-faces-combinaisons ( solid n -- )
+ [ dup faces>> ] dip among
+ [ compute-intersection ] with each ;
+
+: compute-adjacencies ( solid -- solid )
+ dup dimension>> [ >= ] curry
+ [ keep swap ] curry MAX-FACE-PER-CORNER swap
+ [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;
+
+: find-adjacencies ( solid -- solid )
+ erase-old-adjacencies
+ compute-adjacencies
+ filter-real-faces
+ t >>adjacencies-valid ;
+
+: ensure-adjacencies ( solid -- solid )
+ dup adjacencies-valid>>
+ [ find-adjacencies ] unless
+ ensure-silhouettes
+ ;
+
+: (non-empty-solid?) ( solid -- ? )
+ [ dimension>> ] [ corners>> length ] bi < ;
+: non-empty-solid? ( solid -- ? )
+ ensure-adjacencies (non-empty-solid?) ;
+
+: compare-corners-roughly ( corner corner -- ? )
+ 2drop t ;
+! : remove-inner-faces ( -- ) ;
+: face-project ( array face -- seq )
+ backface?
+ [ 2drop f ]
+ [ [ enlight-projection ]
+ [ initiate-solid-from-face ]
+ [ intersections-into-faces ] tri
+ >>faces
+ swap >>color
+ ] if ;
+
+: solid-project ( lights ambient solid -- solids )
+ ensure-adjacencies
+ [ color>> ] [ faces>> ] bi [ 3array ] dip
+ [ face-project ] with map
+ sift
+ [ ensure-adjacencies ] map
+;
+
+: (solid-move) ( solid v move -- solid )
+ curry [ map ] curry
+ [ dup faces>> ] dip call drop
+ unvalid-adjacencies ; inline
+
+: solid-translate ( solid v -- solid )
+ [ face-translate ] (solid-move) ;
+: solid-transform ( solid m -- solid )
+ [ face-transform ] (solid-move) ;
+
+: find-corner-in-silhouette ( s1 s2 -- elt bool )
+ pv> swap silhouettes>> nth
+ swap corners>>
+ [ point-inside-solid? ] with find swap ;
+
+: valid-face-for-order ( solid point -- face )
+ [ point-inside-face? not ]
+ [ drop face-orientation 0 = not ] 2bi and ;
+
+: check-orientation ( s1 s2 pt -- int )
+ [ nip faces>> ] dip
+ [ valid-face-for-order ] curry find swap
+ [ face-orientation ] [ drop f ] if ;
+
+: (order-solid) ( s1 s2 -- int )
+ 2dup find-corner-in-silhouette
+ [ check-orientation ] [ 3drop f ] if ;
+
+: order-solid ( solid solid -- i )
+ 2dup (order-solid)
+ [ 2nip ]
+ [ swap (order-solid)
+ [ neg ] [ f ] if*
+ ] if* ;
+
+: subtract ( solid1 solid2 -- solids )
+ faces>> swap clone ensure-adjacencies ensure-silhouettes
+ [ swap slice-solid drop ] curry map
+ [ non-empty-solid? ] filter
+ [ ensure-adjacencies ] map
+; inline
+
+! -------------------------------------------------------------
+! space
+! -------------------------------------------------------------
+TUPLE: space name dimension solids ambient-color lights ;
+: <space> ( -- space ) space new ;
+: suffix-solids ( space solid -- space )
+ [ suffix ] curry change-solids ; inline
+: suffix-lights ( space light -- space )
+ [ suffix ] curry change-lights ; inline
+: clear-space-solids ( space -- space ) f >>solids ;
+
+: space-ensure-solids ( space -- space )
+ [ [ ensure-adjacencies ] map ] change-solids ;
+: eliminate-empty-solids ( space -- space )
+ [ [ non-empty-solid? ] filter ] change-solids ;
+
+: projected-space ( space solids -- space )
+ swap dimension>> 1 - <space>
+ swap >>dimension swap >>solids ;
+
+: get-silhouette ( solid -- silhouette )
+ silhouettes>> pv> swap nth ;
+: solid= ( solid solid -- ? ) [ corners>> ] same? ;
+
+: space-apply ( space m quot -- space )
+ curry [ map ] curry [ dup solids>> ] dip
+ [ call ] [ 2drop ] recover drop ; inline
+: space-transform ( space m -- space )
+ [ solid-transform ] space-apply ;
+: space-translate ( space v -- space )
+ [ solid-translate ] space-apply ;
+
+: describe-space ( space -- )
+ solids>>
+ [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;
+
+: clip-solid ( solid solid -- solids )
+ [ ]
+ [ solid= not ]
+ [ order-solid -1 = ] 2tri
+ and
+ [ get-silhouette subtract ]
+ [ drop 1array ]
+ if
+
+ ;
+
+: (solids-silhouette-subtract) ( solids solid -- solids )
+ [ clip-solid append ] curry { } -rot each ; inline
+
+: solids-silhouette-subtract ( solids i solid -- solids )
+! solids is an array of 1 solid arrays
+ [ (solids-silhouette-subtract) ] curry map-but
+; inline
+
+: remove-hidden-solids ( space -- space )
+! We must include each solid in a sequence because
+! during substration
+! a solid can be divided in more than on solid
+ [
+ [ [ 1array ] map ]
+ [ length ]
+ [ ]
+ tri
+ [ solids-silhouette-subtract ] 2each
+ { } [ append ] reduce
+ ] change-solids
+ eliminate-empty-solids ! TODO include into change-solids
+;
+
+: space-project ( space i -- space )
+ [
+ [ clone
+ remove-hidden-solids? [ remove-hidden-solids ] when
+ dup
+ [ solids>> ]
+ [ lights>> ]
+ [ ambient-color>> ] tri
+ [ rot solid-project ] 2curry
+ map
+ [ append ] { } -rot each
+ ! TODO project lights
+ projected-space
+ ! remove-inner-faces
+ !
+ eliminate-empty-solids
+ ] with-pv
+ ] [ 3drop <space> ] recover
+ ; inline
+
+: middle-of-space ( space -- point )
+ solids>> [ corners>> ] map concat
+ [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n
+;
+
+! -------------------------------------------------------------
+! 3D rendering
+! -------------------------------------------------------------
+
+: face-reference ( face -- halfspace point vect )
+ [ halfspace>> ]
+ [ touching-corners>> first ]
+ [ touching-corners>> second ] tri
+ over v-
+;
+
+: theta ( v halfspace point vect -- v x )
+ [ [ over ] dip v- ] dip
+ [ cross dup norm >float ]
+ [ v. >float ]
+ 2bi
+ fatan2
+ -rot v.
+ 0 < [ neg ] when
+;
+
+: ordered-face-points ( face -- corners )
+ [ touching-corners>> 1 head ]
+ [ touching-corners>> 1 tail ]
+ [ face-reference [ theta ] 3curry ] tri
+ { } map>assoc sort-values keys
+ append
+ ; inline
+
+: point->GL ( point -- ) gl-vertex ;
+: points->GL ( array -- ) do-cycle [ point->GL ] each ;
+
+: face->GL ( face color -- )
+ [ ordered-face-points ] dip
+ [ first3 1.0 glColor4d GL_POLYGON
+ [ [ point->GL ] each ] do-state ] curry
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP
+ [ [ point->GL ] each ] do-state ]
+ bi
+ ; inline
+
+: solid->GL ( solid -- )
+ [ faces>> ]
+ [ color>> ] bi
+ [ face->GL ] curry each ; inline
+
+: space->GL ( space -- )
+ solids>>
+ [ solid->GL ] each ;
+
+
+
+
+
-USING: adsoda.combinators\r
-sequences\r
- tools.test \r
- ;\r
-\r
-IN: adsoda.combinators.tests\r
-\r
-\r
-[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
- unit-test\r
-\r
+USING: adsoda.combinators
+sequences
+ tools.test
+ ;
+
+IN: adsoda.combinators.tests
+
+
+[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ]
+ unit-test
+
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel arrays sequences fry math combinators ;\r
-\r
-IN: adsoda.combinators\r
-\r
-! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;\r
-\r
-! : prefix-each [ prefix ] curry map ; inline\r
-\r
-! : combinations ( seq n -- seqs )\r
-! {\r
-! { [ dup 0 = ] [ 2drop { { } } ] }\r
-! { [ over empty? ] [ 2drop { } ] }\r
-! { [ t ] [ \r
-! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]\r
-! [ (combinations) ] 2bi append\r
-! ] }\r
-! } cond ;\r
-\r
-: columnize ( array -- array ) [ 1array ] map ; inline\r
-\r
-: among ( array n -- array )\r
- 2dup swap length \r
- {\r
- { [ over 1 = ] [ 3drop columnize ] }\r
- { [ over 0 = ] [ 4drop { } ] }\r
- { [ 2dup < ] [ 2drop [ 1 cut ] dip\r
- [ 1 - among [ append ] with map ]\r
- [ among append ] 2bi\r
- ] }\r
- { [ 2dup = ] [ 3drop 1array ] }\r
- { [ 2dup > ] [ 4drop { } ] }\r
- } cond\r
-;\r
-\r
-: concat-nth ( seq1 seq2 -- seq )\r
- [ nth append ] curry map-index ;\r
-\r
-: do-cycle ( array -- array ) dup first suffix ;\r
-\r
-: map-but ( seq i quot -- seq )\r
- ! quot : ( seq x -- seq )\r
- '[ _ = [ @ ] unless ] map-index ; inline\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays sequences fry math combinators ;
+
+IN: adsoda.combinators
+
+! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;
+
+! : prefix-each [ prefix ] curry map ; inline
+
+! : combinations ( seq n -- seqs )
+! {
+! { [ dup 0 = ] [ 2drop { { } } ] }
+! { [ over empty? ] [ 2drop { } ] }
+! { [ t ] [
+! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]
+! [ (combinations) ] 2bi append
+! ] }
+! } cond ;
+
+: columnize ( array -- array ) [ 1array ] map ; inline
+
+: among ( array n -- array )
+ 2dup swap length
+ {
+ { [ over 1 = ] [ 3drop columnize ] }
+ { [ over 0 = ] [ 4drop { } ] }
+ { [ 2dup < ] [ 2drop [ 1 cut ] dip
+ [ 1 - among [ append ] with map ]
+ [ among append ] 2bi
+ ] }
+ { [ 2dup = ] [ 3drop 1array ] }
+ { [ 2dup > ] [ 4drop { } ] }
+ } cond
+;
+
+: concat-nth ( seq1 seq2 -- seq )
+ [ nth append ] curry map-index ;
+
+: do-cycle ( array -- array ) dup first suffix ;
+
+: map-but ( seq i quot -- seq )
+ ! quot : ( seq x -- seq )
+ '[ _ = [ @ ] unless ] map-index ; inline
+
-USING: kernel\r
-sequences\r
-namespaces\r
-\r
-math\r
-math.vectors\r
-math.matrices\r
-;\r
-IN: adsoda.solution2\r
-\r
-! -------------------\r
-! correctif solution\r
-! ---------------\r
-SYMBOL: matrix\r
-: MIN-VAL-adsoda ( -- x ) 0.00000001\r
-! 0.000000000001 \r
-;\r
-\r
-: zero? ( x -- ? ) \r
- abs MIN-VAL-adsoda <\r
-;\r
-\r
-! [ number>string string>number ] map \r
-\r
-: with-matrix ( matrix quot -- )\r
- [ swap matrix set call matrix get ] with-scope ; inline\r
-\r
-: nth-row ( row# -- seq ) matrix get nth ;\r
-\r
-: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
- matrix get swap change-nth ; inline\r
-\r
-: exchange-rows ( row# row# -- ) matrix get exchange ;\r
-\r
-: rows ( -- n ) matrix get length ;\r
-\r
-: cols ( -- n ) 0 nth-row length ;\r
-\r
-: skip ( i seq quot -- n )\r
- over [ find-from drop ] dip length or ; inline\r
-\r
-: first-col ( row# -- n )\r
- #! First non-zero column\r
- 0 swap nth-row [ zero? not ] skip ;\r
-\r
-: clear-scale ( col# pivot-row i-row -- n )\r
- [ over ] dip nth dup zero? [\r
- 3drop 0\r
- ] [\r
- [ nth dup zero? ] dip swap [\r
- 2drop 0\r
- ] [\r
- swap / neg\r
- ] if\r
- ] if ;\r
-\r
-: (clear-col) ( col# pivot-row i -- )\r
- [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
-\r
-: rows-from ( row# -- slice )\r
- rows dup <slice> ;\r
-\r
-: clear-col ( col# row# rows -- )\r
- [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
-\r
-: do-row ( exchange-with row# -- )\r
- [ exchange-rows ] keep\r
- [ first-col ] keep\r
- dup 1 + rows-from clear-col ;\r
-\r
-: find-row ( row# quot -- i elt )\r
- [ rows-from ] dip find ; inline\r
-\r
-: pivot-row ( col# row# -- n )\r
- [ dupd nth-row nth zero? not ] find-row 2nip ;\r
-\r
-: (echelon) ( col# row# -- )\r
- over cols < over rows < and [\r
- 2dup pivot-row [ over do-row 1 + ] when*\r
- [ 1 + ] dip (echelon)\r
- ] [\r
- 2drop\r
- ] if ;\r
-\r
-: echelon ( matrix -- matrix' )\r
- [ 0 0 (echelon) ] with-matrix ;\r
-\r
-: nonzero-rows ( matrix -- matrix' )\r
- [ [ zero? ] all? ] reject ;\r
-\r
-: null/rank ( matrix -- null rank )\r
- echelon dup length swap nonzero-rows length [ - ] keep ;\r
-\r
-: leading ( seq -- n elt ) [ zero? not ] find ;\r
-\r
-: reduced ( matrix' -- matrix'' )\r
- [\r
- rows <reversed> [\r
- dup nth-row leading drop\r
- dup [ swap dup clear-col ] [ 2drop ] if\r
- ] each\r
- ] with-matrix ;\r
-\r
-: basis-vector ( row col# -- )\r
- [ clone ] dip\r
- [ swap nth neg recip ] 2keep\r
- [ 0 spin set-nth ] 2keep\r
- [ n*v ] dip\r
- matrix get set-nth ;\r
-\r
-: nullspace ( matrix -- seq )\r
- echelon reduced dup empty? [\r
- dup first length identity-matrix [\r
- [\r
- dup leading drop\r
- dup [ basis-vector ] [ 2drop ] if\r
- ] each\r
- ] with-matrix flip nonzero-rows\r
- ] unless ;\r
-\r
-: 1-pivots ( matrix -- matrix )\r
- [ dup leading nip [ recip v*n ] when* ] map ;\r
-\r
-: solution ( matrix -- matrix )\r
- echelon nonzero-rows reduced 1-pivots ;\r
-\r
+USING: kernel
+sequences
+namespaces
+
+math
+math.vectors
+math.matrices
+;
+IN: adsoda.solution2
+
+! -------------------
+! correctif solution
+! ---------------
+SYMBOL: matrix
+: MIN-VAL-adsoda ( -- x ) 0.00000001
+! 0.000000000001
+;
+
+: zero? ( x -- ? )
+ abs MIN-VAL-adsoda <
+;
+
+! [ number>string string>number ] map
+
+: with-matrix ( matrix quot -- )
+ [ swap matrix set call matrix get ] with-scope ; inline
+
+: nth-row ( row# -- seq ) matrix get nth ;
+
+: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )
+ matrix get swap change-nth ; inline
+
+: exchange-rows ( row# row# -- ) matrix get exchange ;
+
+: rows ( -- n ) matrix get length ;
+
+: cols ( -- n ) 0 nth-row length ;
+
+: skip ( i seq quot -- n )
+ over [ find-from drop ] dip length or ; inline
+
+: first-col ( row# -- n )
+ #! First non-zero column
+ 0 swap nth-row [ zero? not ] skip ;
+
+: clear-scale ( col# pivot-row i-row -- n )
+ [ over ] dip nth dup zero? [
+ 3drop 0
+ ] [
+ [ nth dup zero? ] dip swap [
+ 2drop 0
+ ] [
+ swap / neg
+ ] if
+ ] if ;
+
+: (clear-col) ( col# pivot-row i -- )
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
+
+: rows-from ( row# -- slice )
+ rows dup <slice> ;
+
+: clear-col ( col# row# rows -- )
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
+
+: do-row ( exchange-with row# -- )
+ [ exchange-rows ] keep
+ [ first-col ] keep
+ dup 1 + rows-from clear-col ;
+
+: find-row ( row# quot -- i elt )
+ [ rows-from ] dip find ; inline
+
+: pivot-row ( col# row# -- n )
+ [ dupd nth-row nth zero? not ] find-row 2nip ;
+
+: (echelon) ( col# row# -- )
+ over cols < over rows < and [
+ 2dup pivot-row [ over do-row 1 + ] when*
+ [ 1 + ] dip (echelon)
+ ] [
+ 2drop
+ ] if ;
+
+: echelon ( matrix -- matrix' )
+ [ 0 0 (echelon) ] with-matrix ;
+
+: nonzero-rows ( matrix -- matrix' )
+ [ [ zero? ] all? ] reject ;
+
+: null/rank ( matrix -- null rank )
+ echelon dup length swap nonzero-rows length [ - ] keep ;
+
+: leading ( seq -- n elt ) [ zero? not ] find ;
+
+: reduced ( matrix' -- matrix'' )
+ [
+ rows <reversed> [
+ dup nth-row leading drop
+ dup [ swap dup clear-col ] [ 2drop ] if
+ ] each
+ ] with-matrix ;
+
+: basis-vector ( row col# -- )
+ [ clone ] dip
+ [ swap nth neg recip ] 2keep
+ [ 0 spin set-nth ] 2keep
+ [ n*v ] dip
+ matrix get set-nth ;
+
+: nullspace ( matrix -- seq )
+ echelon reduced dup empty? [
+ dup first length identity-matrix [
+ [
+ dup leading drop
+ dup [ basis-vector ] [ 2drop ] if
+ ] each
+ ] with-matrix flip nonzero-rows
+ ] unless ;
+
+: 1-pivots ( matrix -- matrix )
+ [ dup leading nip [ recip v*n ] when* ] map ;
+
+: solution ( matrix -- matrix )
+ echelon nonzero-rows reduced 1-pivots ;
+
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-adsoda.tools\r
-tools.test\r
-;\r
-\r
-IN: adsoda.tools.tests\r
-\r
-\r
- [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
- [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
-\r
- [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING:
+adsoda.tools
+tools.test
+;
+
+IN: adsoda.tools.tests
+
+
+ [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test
+ [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test
+
+ [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-kernel\r
-sequences\r
-math\r
-accessors\r
-adsoda\r
-math.vectors \r
-math.matrices\r
-bunny.model\r
-io.encodings.ascii\r
-io.files\r
-sequences.deep\r
-combinators\r
-adsoda.combinators\r
-fry\r
-io.files.temp\r
-grouping\r
-;\r
-\r
-IN: adsoda.tools\r
-\r
-\r
-\r
-\r
-\r
-! ---------------------------------\r
-: coord-min ( x array -- array ) swap suffix ;\r
-: coord-max ( x array -- array ) swap neg suffix ;\r
-\r
-: 4cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 4 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
- [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
- [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
- [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-: 3cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 3 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
- [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
- [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-\r
-: equation-system-for-normal ( points -- matrix )\r
- unclip [ v- 0 suffix ] curry map\r
- dup first [ drop 1 ] map suffix\r
-;\r
-\r
-: normal-vector ( points -- v ) \r
- equation-system-for-normal\r
- intersect-hyperplanes ;\r
-\r
-: points-to-hyperplane ( points -- hyperplane )\r
- [ normal-vector 0 suffix ] [ first ] bi\r
- translate ;\r
-\r
-: refs-to-points ( points faces -- faces )\r
- [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] \r
- with map\r
-;\r
-! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
-! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
-\r
-: ply-model-path ( -- path )\r
-\r
-! "bun_zipper.ply" \r
-"screw2.ply"\r
-temp-file \r
-;\r
-\r
-: read-bunny-model ( -- v )\r
-ply-model-path ascii [ parse-model ] with-file-reader\r
-\r
-refs-to-points\r
-;\r
-\r
-: 3points-to-normal ( seq -- v )\r
- unclip [ v- ] curry map first2 cross normalize\r
-;\r
-: 2-faces-to-prism ( seq seq -- seq )\r
- 2dup\r
- [ do-cycle 2 clump ] bi@ concat-nth \r
- ! 3 faces rectangulaires\r
- swap prefix\r
- swap prefix\r
-; \r
-\r
-: Xpoints-to-prisme ( seq height -- cube )\r
- ! from 3 points gives a list of faces representing \r
- ! a cube of height "height"\r
- ! and of based on the three points\r
- ! a face is a group of 3 or mode points. \r
- [ dup dup 3points-to-normal ] dip \r
- v*n [ v+ ] curry map ! 2 eme face triangulaire \r
- 2-faces-to-prism \r
-\r
-! [ dup number? [ 1 + ] when ] deep-map\r
-! dup keep \r
-;\r
-\r
-\r
-: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
- ! from 3 points gives a list of faces representing \r
- ! a cube in 4th dim\r
- ! from x to y (height = y-x)\r
- ! and of based on the X points\r
- ! a face is a group of 3 or mode points. \r
- '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
- 2-faces-to-prism\r
-;\r
-\r
-: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
- [ 1 Xpoints-to-prisme [ 100 \r
- 110 Xpoints-to-plane4D ] map concat ] map \r
-\r
-;\r
-\r
-: test-figure ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-\r
+! Copyright (C) 2008 Jeff Bigot
+! See http://factorcode.org/license.txt for BSD license.
+USING:
+kernel
+sequences
+math
+accessors
+adsoda
+math.vectors
+math.matrices
+bunny.model
+io.encodings.ascii
+io.files
+sequences.deep
+combinators
+adsoda.combinators
+fry
+io.files.temp
+grouping
+;
+
+IN: adsoda.tools
+
+
+
+
+
+! ---------------------------------
+: coord-min ( x array -- array ) swap suffix ;
+: coord-max ( x array -- array ) swap neg suffix ;
+
+: 4cube ( array name -- solid )
+! array : xmin xmax ymin ymax zmin zmax wmin wmax
+ <solid>
+ 4 >>dimension
+ swap >>name
+ swap
+ {
+ [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ]
+ [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]
+ [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ]
+ [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]
+ }
+ [ curry call ] 2map
+ [ cut-solid ] each
+ ensure-adjacencies
+
+; inline
+
+: 3cube ( array name -- solid )
+! array : xmin xmax ymin ymax zmin zmax wmin wmax
+ <solid>
+ 3 >>dimension
+ swap >>name
+ swap
+ {
+ [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ]
+ [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]
+ [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ]
+ }
+ [ curry call ] 2map
+ [ cut-solid ] each
+ ensure-adjacencies
+
+; inline
+
+
+: equation-system-for-normal ( points -- matrix )
+ unclip [ v- 0 suffix ] curry map
+ dup first [ drop 1 ] map suffix
+;
+
+: normal-vector ( points -- v )
+ equation-system-for-normal
+ intersect-hyperplanes ;
+
+: points-to-hyperplane ( points -- hyperplane )
+ [ normal-vector 0 suffix ] [ first ] bi
+ translate ;
+
+: refs-to-points ( points faces -- faces )
+ [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ]
+ with map
+;
+! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }
+! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }
+
+: ply-model-path ( -- path )
+
+! "bun_zipper.ply"
+"screw2.ply"
+temp-file
+;
+
+: read-bunny-model ( -- v )
+ply-model-path ascii [ parse-model ] with-file-reader
+
+refs-to-points
+;
+
+: 3points-to-normal ( seq -- v )
+ unclip [ v- ] curry map first2 cross normalize
+;
+: 2-faces-to-prism ( seq seq -- seq )
+ 2dup
+ [ do-cycle 2 clump ] bi@ concat-nth
+ ! 3 faces rectangulaires
+ swap prefix
+ swap prefix
+;
+
+: Xpoints-to-prisme ( seq height -- cube )
+ ! from 3 points gives a list of faces representing
+ ! a cube of height "height"
+ ! and of based on the three points
+ ! a face is a group of 3 or mode points.
+ [ dup dup 3points-to-normal ] dip
+ v*n [ v+ ] curry map ! 2 eme face triangulaire
+ 2-faces-to-prism
+
+! [ dup number? [ 1 + ] when ] deep-map
+! dup keep
+;
+
+
+: Xpoints-to-plane4D ( seq x y -- 4Dplane )
+ ! from 3 points gives a list of faces representing
+ ! a cube in 4th dim
+ ! from x to y (height = y-x)
+ ! and of based on the X points
+ ! a face is a group of 3 or mode points.
+ '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call
+ 2-faces-to-prism
+;
+
+: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )
+ [ 1 Xpoints-to-prisme [ 100
+ 110 Xpoints-to-plane4D ] map concat ] map
+
+;
+
+: test-figure ( -- solid )
+ <solid>
+ 2 >>dimension
+ { 1 -1 -5 } cut-solid
+ { -1 -1 -21 } cut-solid
+ { -1 0 -12 } cut-solid
+ { 1 2 16 } cut-solid
+;
+
-USING: furnace furnace.actions furnace.callbacks accessors\r
-http http.server http.server.responses tools.test\r
-namespaces io fry sequences\r
-splitting kernel hashtables continuations ;\r
-IN: furnace.callbacks.tests\r
-\r
-[ 123 ] [\r
- [\r
- <request> "GET" >>method init-request\r
- [\r
- exit-continuation set\r
- { }\r
- <action> [ [ "hello" print 123 ] show-final ] >>display\r
- <callback-responder>\r
- call-responder\r
- ] callcc1\r
- ] with-scope\r
-] unit-test\r
-\r
-[\r
- <action> [\r
- [\r
- "hello" print\r
- <html-content>\r
- ] show-page\r
- "byebye" print\r
- [ 123 ] show-final\r
- ] >>display\r
- <callback-responder> "r" set\r
-\r
- [ 123 ] [\r
- <request> init-request\r
-\r
- [\r
- exit-continuation set\r
- <request> "GET" >>method init-request\r
- { } "r" get call-responder\r
- ] callcc1\r
-\r
- body>> first\r
-\r
- <request>\r
- "GET" >>method\r
- dup url>> rot cont-id associate >>query drop\r
- dup url>> "/" >>path drop\r
- init-request\r
-\r
- [\r
- exit-continuation set\r
- { }\r
- "r" get call-responder\r
- ] callcc1\r
-\r
- ! get-post-get\r
- <request>\r
- "GET" >>method\r
- dup url>> rot "location" header query>> >>query drop\r
- dup url>> "/" >>path drop\r
- init-request\r
-\r
- [\r
- exit-continuation set\r
- { }\r
- "r" get call-responder\r
- ] callcc1\r
- ] unit-test\r
-] with-scope\r
+USING: furnace furnace.actions furnace.callbacks accessors
+http http.server http.server.responses tools.test
+namespaces io fry sequences
+splitting kernel hashtables continuations ;
+IN: furnace.callbacks.tests
+
+[ 123 ] [
+ [
+ <request> "GET" >>method init-request
+ [
+ exit-continuation set
+ { }
+ <action> [ [ "hello" print 123 ] show-final ] >>display
+ <callback-responder>
+ call-responder
+ ] callcc1
+ ] with-scope
+] unit-test
+
+[
+ <action> [
+ [
+ "hello" print
+ <html-content>
+ ] show-page
+ "byebye" print
+ [ 123 ] show-final
+ ] >>display
+ <callback-responder> "r" set
+
+ [ 123 ] [
+ <request> init-request
+
+ [
+ exit-continuation set
+ <request> "GET" >>method init-request
+ { } "r" get call-responder
+ ] callcc1
+
+ body>> first
+
+ <request>
+ "GET" >>method
+ dup url>> rot cont-id associate >>query drop
+ dup url>> "/" >>path drop
+ init-request
+
+ [
+ exit-continuation set
+ { }
+ "r" get call-responder
+ ] callcc1
+
+ ! get-post-get
+ <request>
+ "GET" >>method
+ dup url>> rot "location" header query>> >>query drop
+ dup url>> "/" >>path drop
+ init-request
+
+ [
+ exit-continuation set
+ { }
+ "r" get call-responder
+ ] callcc1
+ ] unit-test
+] with-scope
-! Copyright (C) 2004 Chris Double.\r
-! Copyright (C) 2006, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: http http.server io kernel math namespaces\r
-continuations calendar sequences assocs hashtables\r
-accessors arrays alarms quotations combinators fry\r
-http.server.redirection furnace assocs.lib urls ;\r
-IN: furnace.callbacks\r
-\r
-SYMBOL: responder\r
-\r
-TUPLE: callback-responder responder callbacks ;\r
-\r
-: <callback-responder> ( responder -- responder' )\r
- H{ } clone callback-responder boa ;\r
-\r
-TUPLE: callback cont quot expires alarm responder ;\r
-\r
-: timeout 20 minutes ;\r
-\r
-: timeout-callback ( callback -- )\r
- [ alarm>> cancel-alarm ]\r
- [ dup responder>> callbacks>> delete-at ]\r
- bi ;\r
-\r
-: touch-callback ( callback -- )\r
- dup expires>> [\r
- dup alarm>> [ cancel-alarm ] when*\r
- dup '[ , timeout-callback ] timeout later >>alarm\r
- ] when drop ;\r
-\r
-: <callback> ( cont quot expires? -- callback )\r
- f callback-responder get callback boa\r
- dup touch-callback ;\r
-\r
-: invoke-callback ( callback -- response )\r
- [ touch-callback ]\r
- [ quot>> request get exit-continuation get 3array ]\r
- [ cont>> continue-with ]\r
- tri ;\r
-\r
-: register-callback ( cont quot expires? -- id )\r
- <callback> callback-responder get callbacks>> set-at-unique ;\r
-\r
-: forward-to-url ( url -- * )\r
- #! When executed inside a 'show' call, this will force a\r
- #! HTTP 302 to occur to instruct the browser to forward to\r
- #! the request URL.\r
- <temporary-redirect> exit-with ;\r
-\r
-: cont-id "factorcontid" ;\r
-\r
-: forward-to-id ( id -- * )\r
- #! When executed inside a 'show' call, this will force a\r
- #! HTTP 302 to occur to instruct the browser to forward to\r
- #! the request URL.\r
- <url>\r
- swap cont-id set-query-param forward-to-url ;\r
-\r
-: restore-request ( pair -- )\r
- first3 exit-continuation set request set call ;\r
-\r
-SYMBOL: post-refresh-get?\r
-\r
-: redirect-to-here ( -- )\r
- #! Force a redirect to the client browser so that the browser\r
- #! goes to the current point in the code. This forces an URL\r
- #! change on the browser so that refreshing that URL will\r
- #! immediately run from this code point. This prevents the\r
- #! "this request will issue a POST" warning from the browser\r
- #! and prevents re-running the previous POST logic. This is\r
- #! known as the 'post-refresh-get' pattern.\r
- post-refresh-get? get [\r
- [\r
- [ ] t register-callback forward-to-id\r
- ] callcc1 restore-request\r
- ] [\r
- post-refresh-get? on\r
- ] if ;\r
-\r
-SYMBOL: current-show\r
-\r
-: store-current-show ( -- )\r
- #! Store the current continuation in the variable 'current-show'\r
- #! so it can be returned to later by 'quot-id'. Note that it\r
- #! recalls itself when the continuation is called to ensure that\r
- #! it resets its value back to the most recent show call.\r
- [ current-show set f ] callcc1\r
- [ restore-request store-current-show ] when* ;\r
-\r
-: show-final ( quot -- * )\r
- [ redirect-to-here store-current-show ] dip\r
- call exit-with ; inline\r
-\r
-: resuming-callback ( responder request -- id )\r
- url>> cont-id query-param swap callbacks>> at ;\r
-\r
-M: callback-responder call-responder* ( path responder -- response )\r
- '[\r
- , ,\r
-\r
- [ callback-responder set ]\r
- [ request get resuming-callback ] bi\r
-\r
- [\r
- invoke-callback\r
- ] [\r
- callback-responder get responder>> call-responder\r
- ] ?if\r
- ] with-exit-continuation ;\r
-\r
-: show-page ( quot -- )\r
- [ redirect-to-here store-current-show ] dip\r
- [\r
- [ ] t register-callback swap call exit-with\r
- ] callcc1 restore-request ; inline\r
-\r
-: quot-id ( quot -- id )\r
- current-show get swap t register-callback ;\r
-\r
-: quot-url ( quot -- url )\r
- quot-id f swap cont-id associate derive-url ;\r
+! Copyright (C) 2004 Chris Double.
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http http.server io kernel math namespaces
+continuations calendar sequences assocs hashtables
+accessors arrays alarms quotations combinators fry
+http.server.redirection furnace assocs.lib urls ;
+IN: furnace.callbacks
+
+SYMBOL: responder
+
+TUPLE: callback-responder responder callbacks ;
+
+: <callback-responder> ( responder -- responder' )
+ H{ } clone callback-responder boa ;
+
+TUPLE: callback cont quot expires alarm responder ;
+
+: timeout 20 minutes ;
+
+: timeout-callback ( callback -- )
+ [ alarm>> cancel-alarm ]
+ [ dup responder>> callbacks>> delete-at ]
+ bi ;
+
+: touch-callback ( callback -- )
+ dup expires>> [
+ dup alarm>> [ cancel-alarm ] when*
+ dup '[ , timeout-callback ] timeout later >>alarm
+ ] when drop ;
+
+: <callback> ( cont quot expires? -- callback )
+ f callback-responder get callback boa
+ dup touch-callback ;
+
+: invoke-callback ( callback -- response )
+ [ touch-callback ]
+ [ quot>> request get exit-continuation get 3array ]
+ [ cont>> continue-with ]
+ tri ;
+
+: register-callback ( cont quot expires? -- id )
+ <callback> callback-responder get callbacks>> set-at-unique ;
+
+: forward-to-url ( url -- * )
+ #! When executed inside a 'show' call, this will force a
+ #! HTTP 302 to occur to instruct the browser to forward to
+ #! the request URL.
+ <temporary-redirect> exit-with ;
+
+: cont-id "factorcontid" ;
+
+: forward-to-id ( id -- * )
+ #! When executed inside a 'show' call, this will force a
+ #! HTTP 302 to occur to instruct the browser to forward to
+ #! the request URL.
+ <url>
+ swap cont-id set-query-param forward-to-url ;
+
+: restore-request ( pair -- )
+ first3 exit-continuation set request set call ;
+
+SYMBOL: post-refresh-get?
+
+: redirect-to-here ( -- )
+ #! Force a redirect to the client browser so that the browser
+ #! goes to the current point in the code. This forces an URL
+ #! change on the browser so that refreshing that URL will
+ #! immediately run from this code point. This prevents the
+ #! "this request will issue a POST" warning from the browser
+ #! and prevents re-running the previous POST logic. This is
+ #! known as the 'post-refresh-get' pattern.
+ post-refresh-get? get [
+ [
+ [ ] t register-callback forward-to-id
+ ] callcc1 restore-request
+ ] [
+ post-refresh-get? on
+ ] if ;
+
+SYMBOL: current-show
+
+: store-current-show ( -- )
+ #! Store the current continuation in the variable 'current-show'
+ #! so it can be returned to later by 'quot-id'. Note that it
+ #! recalls itself when the continuation is called to ensure that
+ #! it resets its value back to the most recent show call.
+ [ current-show set f ] callcc1
+ [ restore-request store-current-show ] when* ;
+
+: show-final ( quot -- * )
+ [ redirect-to-here store-current-show ] dip
+ call exit-with ; inline
+
+: resuming-callback ( responder request -- id )
+ url>> cont-id query-param swap callbacks>> at ;
+
+M: callback-responder call-responder* ( path responder -- response )
+ '[
+ , ,
+
+ [ callback-responder set ]
+ [ request get resuming-callback ] bi
+
+ [
+ invoke-callback
+ ] [
+ callback-responder get responder>> call-responder
+ ] ?if
+ ] with-exit-continuation ;
+
+: show-page ( quot -- )
+ [ redirect-to-here store-current-show ] dip
+ [
+ [ ] t register-callback swap call exit-with
+ ] callcc1 restore-request ; inline
+
+: quot-id ( quot -- id )
+ current-show get swap t register-callback ;
+
+: quot-url ( quot -- url )
+ quot-id f swap cont-id associate derive-url ;
-USING: alien.strings io.encodings.utf16n windows.com\r
-windows.com.wrapper combinators windows.kernel32 windows.ole32\r
-windows.shell32 kernel accessors windows.types\r
-prettyprint namespaces ui.tools.listener ui.tools.workspace\r
-alien.data alien sequences math classes.struct ;\r
-SPECIALIZED-ARRAY: WCHAR\r
-IN: windows.dragdrop-listener\r
-\r
-: filenames-from-hdrop ( hdrop -- filenames )\r
- dup 0xFFFFFFFF f 0 DragQueryFile ! get count of files\r
- [\r
- 2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
- dup WCHAR <c-array>\r
- [ swap DragQueryFile drop ] keep\r
- utf16n alien>string\r
- ] with map ;\r
-\r
-: filenames-from-data-object ( data-object -- filenames )\r
- FORMATETC <struct>\r
- CF_HDROP >>cfFormat\r
- f >>ptd\r
- DVASPECT_CONTENT >>dwAspect\r
- -1 >>lindex\r
- TYMED_HGLOBAL >>tymed\r
- STGMEDIUM <struct>\r
- [ IDataObject::GetData ] keep swap succeeded? [\r
- dup data>>\r
- [ filenames-from-hdrop ] with-global-lock\r
- swap ReleaseStgMedium\r
- ] [ drop f ] if ;\r
-\r
-TUPLE: listener-dragdrop hWnd last-drop-effect ;\r
-\r
-: <listener-dragdrop> ( hWnd -- object )\r
- DROPEFFECT_NONE listener-dragdrop construct-boa ;\r
-\r
-SYMBOL: +listener-dragdrop-wrapper+\r
-{\r
- { "IDropTarget" {\r
- [ ! DragEnter\r
- [\r
- 2drop\r
- filenames-from-data-object\r
- length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if\r
- dup 0\r
- ] dip set-ulong-nth\r
- >>last-drop-effect drop\r
- S_OK\r
- ] [ ! DragOver\r
- [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth\r
- S_OK\r
- ] [ ! DragLeave\r
- drop S_OK\r
- ] [ ! Drop\r
- [\r
- 2drop nip\r
- filenames-from-data-object\r
- dup length 1 = [\r
- first unparse [ "USE: parser " % % " run-file" % ] "" make\r
- eval-listener\r
- DROPEFFECT_COPY\r
- ] [ 2drop DROPEFFECT_NONE ] if\r
- 0\r
- ] dip set-ulong-nth\r
- S_OK\r
- ]\r
- } }\r
-} <com-wrapper> +listener-dragdrop-wrapper+ set-global\r
-\r
-: dragdrop-listener-window ( -- )\r
- get-workspace parent>> handle>> hWnd>>\r
- dup <listener-dragdrop>\r
- +listener-dragdrop-wrapper+ get-global com-wrap\r
- [ RegisterDragDrop ole32-error ] with-com-interface ;\r
+USING: alien.strings io.encodings.utf16n windows.com
+windows.com.wrapper combinators windows.kernel32 windows.ole32
+windows.shell32 kernel accessors windows.types
+prettyprint namespaces ui.tools.listener ui.tools.workspace
+alien.data alien sequences math classes.struct ;
+SPECIALIZED-ARRAY: WCHAR
+IN: windows.dragdrop-listener
+
+: filenames-from-hdrop ( hdrop -- filenames )
+ dup 0xFFFFFFFF f 0 DragQueryFile ! get count of files
+ [
+ 2dup f 0 DragQueryFile 1 + ! get size of filename buffer
+ dup WCHAR <c-array>
+ [ swap DragQueryFile drop ] keep
+ utf16n alien>string
+ ] with map ;
+
+: filenames-from-data-object ( data-object -- filenames )
+ FORMATETC <struct>
+ CF_HDROP >>cfFormat
+ f >>ptd
+ DVASPECT_CONTENT >>dwAspect
+ -1 >>lindex
+ TYMED_HGLOBAL >>tymed
+ STGMEDIUM <struct>
+ [ IDataObject::GetData ] keep swap succeeded? [
+ dup data>>
+ [ filenames-from-hdrop ] with-global-lock
+ swap ReleaseStgMedium
+ ] [ drop f ] if ;
+
+TUPLE: listener-dragdrop hWnd last-drop-effect ;
+
+: <listener-dragdrop> ( hWnd -- object )
+ DROPEFFECT_NONE listener-dragdrop construct-boa ;
+
+SYMBOL: +listener-dragdrop-wrapper+
+{
+ { "IDropTarget" {
+ [ ! DragEnter
+ [
+ 2drop
+ filenames-from-data-object
+ length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if
+ dup 0
+ ] dip set-ulong-nth
+ >>last-drop-effect drop
+ S_OK
+ ] [ ! DragOver
+ [ 2drop last-drop-effect>> 0 ] dip set-ulong-nth
+ S_OK
+ ] [ ! DragLeave
+ drop S_OK
+ ] [ ! Drop
+ [
+ 2drop nip
+ filenames-from-data-object
+ dup length 1 = [
+ first unparse [ "USE: parser " % % " run-file" % ] "" make
+ eval-listener
+ DROPEFFECT_COPY
+ ] [ 2drop DROPEFFECT_NONE ] if
+ 0
+ ] dip set-ulong-nth
+ S_OK
+ ]
+ } }
+} <com-wrapper> +listener-dragdrop-wrapper+ set-global
+
+: dragdrop-listener-window ( -- )
+ get-workspace parent>> handle>> hWnd>>
+ dup <listener-dragdrop>
+ +listener-dragdrop-wrapper+ get-global com-wrap
+ [ RegisterDragDrop ole32-error ] with-com-interface ;
-! Copyright (C) 2009 Kobi Lurie, Doug Coleman.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors fry images.loader\r
-images.processing.rotation kernel literals math sequences\r
-tools.test images.processing.rotation.private ;\r
-IN: images.processing.rotation.tests\r
-\r
-: first-row ( seq^2 -- seq ) first ;\r
-: first-col ( seq^2 -- item ) harvest [ first ] map ;\r
-: last-row ( seq^2 -- item ) last ;\r
-: last-col ( seq^2 -- item ) harvest [ last ] map ;\r
-: end-of-first-row ( seq^2 -- item ) first-row last ;\r
-: first-of-first-row ( seq^2 -- item ) first-row first ;\r
-: end-of-last-row ( seq^2 -- item ) last-row last ;\r
-: first-of-last-row ( seq^2 -- item ) last-row first ;\r
-\r
-<<\r
-\r
-: clone-image ( image -- new-image )\r
- clone [ clone ] change-bitmap ;\r
-\r
->>\r
-\r
-: pasted-image ( -- image )\r
- "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"\r
- load-image clone-image ;\r
-\r
-: pasted-image90 ( -- image )\r
- "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"\r
- load-image clone-image ;\r
-\r
-: lake-image ( -- image )\r
- "vocab:images/processing/rotation/test-bitmaps/lake.bmp"\r
- load-image clone-image image>pixel-rows ;\r
-\r
-[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test\r
-[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test\r
-[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test\r
-[ t ] [\r
- pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each =\r
-] unit-test\r
-\r
-[ t ] [\r
- pasted-image 90 rotate\r
- pasted-image90 = \r
-] unit-test\r
-\r
-[ t ] [\r
- "vocab:images/processing/rotation/test-bitmaps/small.bmp"\r
- load-image 90 rotate \r
- "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"\r
- load-image =\r
-] unit-test\r
- \r
-[ t ] [\r
- lake-image\r
- [ first-of-first-row ]\r
- [ 90 (rotate) end-of-first-row ] bi =\r
-] unit-test\r
-\r
-[ t ]\r
-[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test\r
-\r
-[ t ]\r
-[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test\r
-\r
-[ t ]\r
-[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test\r
-\r
-[ t ]\r
-[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test\r
+! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry images.loader
+images.processing.rotation kernel literals math sequences
+tools.test images.processing.rotation.private ;
+IN: images.processing.rotation.tests
+
+: first-row ( seq^2 -- seq ) first ;
+: first-col ( seq^2 -- item ) harvest [ first ] map ;
+: last-row ( seq^2 -- item ) last ;
+: last-col ( seq^2 -- item ) harvest [ last ] map ;
+: end-of-first-row ( seq^2 -- item ) first-row last ;
+: first-of-first-row ( seq^2 -- item ) first-row first ;
+: end-of-last-row ( seq^2 -- item ) last-row last ;
+: first-of-last-row ( seq^2 -- item ) last-row first ;
+
+<<
+
+: clone-image ( image -- new-image )
+ clone [ clone ] change-bitmap ;
+
+>>
+
+: pasted-image ( -- image )
+ "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
+ load-image clone-image ;
+
+: pasted-image90 ( -- image )
+ "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
+ load-image clone-image ;
+
+: lake-image ( -- image )
+ "vocab:images/processing/rotation/test-bitmaps/lake.bmp"
+ load-image clone-image image>pixel-rows ;
+
+[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test
+[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test
+[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test
+[ t ] [
+ pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each =
+] unit-test
+
+[ t ] [
+ pasted-image 90 rotate
+ pasted-image90 =
+] unit-test
+
+[ t ] [
+ "vocab:images/processing/rotation/test-bitmaps/small.bmp"
+ load-image 90 rotate
+ "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
+ load-image =
+] unit-test
+
+[ t ] [
+ lake-image
+ [ first-of-first-row ]
+ [ 90 (rotate) end-of-first-row ] bi =
+] unit-test
+
+[ t ]
+[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test
+
+[ t ]
+[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test
+
+[ t ]
+[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test
+
+[ t ]
+[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: kernel vocabs.loader sequences strings splitting words irc.messages ;\r
-\r
-IN: irc.ui.commandparser\r
-\r
-: command ( string string -- string command )\r
- [ "say" ] when-empty\r
- dup "irc.ui.commands" lookup\r
- [ nip ]\r
- [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;\r
-\r
-: parse-message ( string -- )\r
- "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;\r
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel vocabs.loader sequences strings splitting words irc.messages ;
+
+IN: irc.ui.commandparser
+
+: command ( string string -- string command )
+ [ "say" ] when-empty
+ dup "irc.ui.commands" lookup
+ [ nip ]
+ [ " " append prepend "quote" "irc.ui.commands" lookup ] if* ;
+
+: parse-message ( string -- )
+ "/" ?head [ " " split1 swap command ] [ "say" command ] if execute ;
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel sequences arrays irc.client\r
- irc.messages irc.ui namespaces ;\r
-\r
-IN: irc.ui.commands\r
-\r
-: say ( string -- )\r
- irc-tab get\r
- [ window>> client>> profile>> nickname>> <own-message> print-irc ]\r
- [ chat>> speak ] 2bi ;\r
-\r
-: me ( string -- ) ! Placeholder until I make /me look different\r
- "ACTION " 1 prefix prepend 1 suffix say ;\r
-\r
-: join ( string -- )\r
- irc-tab get window>> join-channel ;\r
-\r
-: query ( string -- )\r
- irc-tab get window>> query-nick ;\r
-\r
-: whois ( string -- )\r
- "WHOIS" swap { } clone swap <irc-client-message>\r
- irc-tab get listener>> speak ;\r
-\r
-: quote ( string -- )\r
- drop ; ! THIS WILL CHANGE\r
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel sequences arrays irc.client
+ irc.messages irc.ui namespaces ;
+
+IN: irc.ui.commands
+
+: say ( string -- )
+ irc-tab get
+ [ window>> client>> profile>> nickname>> <own-message> print-irc ]
+ [ chat>> speak ] 2bi ;
+
+: me ( string -- ) ! Placeholder until I make /me look different
+ "ACTION " 1 prefix prepend 1 suffix say ;
+
+: join ( string -- )
+ irc-tab get window>> join-channel ;
+
+: query ( string -- )
+ irc-tab get window>> query-nick ;
+
+: whois ( string -- )
+ "WHOIS" swap { } clone swap <irc-client-message>
+ irc-tab get listener>> speak ;
+
+: quote ( string -- )
+ drop ; ! THIS WILL CHANGE
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: kernel io.files io.pathnames parser editors sequences ;\r
-\r
-IN: irc.ui.load\r
-\r
-: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;\r
-\r
-: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;\r
-\r
-: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;\r
-\r
-: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;\r
-\r
-: run-ircui ( -- ) ircui-rc run-file ;\r
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel io.files io.pathnames parser editors sequences ;
+
+IN: irc.ui.load
+
+: file-or ( path path -- path ) [ [ exists? ] keep ] dip ? ;
+
+: personal-ui-rc ( -- path ) home ".ircui-rc" append-path ;
+
+: system-ui-rc ( -- path ) "extra/irc/ui/ircui-rc" resource-path ;
+
+: ircui-rc ( -- path ) personal-ui-rc system-ui-rc file-or ;
+
+: run-ircui ( -- ) ircui-rc run-file ;
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel threads combinators concurrency.mailboxes\r
- sequences strings hashtables splitting fry assocs hashtables colors\r
- sorting unicode.collation math.order\r
- ui ui.gadgets ui.gadgets.panes ui.gadgets.editors\r
- ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures\r
- ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels\r
- io io.styles namespaces calendar calendar.format models continuations\r
- irc.client irc.client.private irc.messages\r
- irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;\r
-\r
-RENAME: join sequences => sjoin\r
-\r
-IN: irc.ui\r
-\r
-SYMBOL: chat\r
-\r
-SYMBOL: client\r
-\r
-TUPLE: ui-window < tabbed client ;\r
-\r
-M: ui-window ungraft*\r
- client>> terminate-irc ;\r
-\r
-TUPLE: irc-tab < frame chat client window ;\r
-\r
-: write-color ( str color -- )\r
- foreground associate format ;\r
-CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }\r
-CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }\r
-CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }\r
-\r
-: dot-or-parens ( string -- string )\r
- [ "." ]\r
- [ "(" prepend ")" append ] if-empty ;\r
-\r
-GENERIC: write-irc ( irc-message -- )\r
-\r
-M: ping write-irc\r
- drop "* Ping" blue write-color ;\r
-\r
-M: privmsg write-irc\r
- "<" dark-blue write-color\r
- [ irc-message-sender write ] keep\r
- "> " dark-blue write-color\r
- trailing>> write ;\r
-\r
-M: notice write-irc\r
- [ type>> dark-blue write-color ] keep\r
- ": " dark-blue write-color\r
- trailing>> write ;\r
-\r
-TUPLE: own-message message nick timestamp ;\r
-\r
-: <own-message> ( message nick -- own-message )\r
- now own-message boa ;\r
-\r
-M: own-message write-irc\r
- "<" dark-blue write-color\r
- [ nick>> bold font-style associate format ] keep\r
- "> " dark-blue write-color\r
- message>> write ;\r
-\r
-M: join write-irc\r
- "* " dark-green write-color\r
- irc-message-sender write\r
- " has entered the channel." dark-green write-color ;\r
-\r
-M: part write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has left the channel" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: quit write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has left IRC" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: kick write-irc\r
- "* " dark-red write-color\r
- [ irc-message-sender write ] keep\r
- " has kicked " dark-red write-color\r
- [ who>> write ] keep\r
- " from the channel" dark-red write-color\r
- trailing>> dot-or-parens dark-red write-color ;\r
-\r
-M: mode write-irc\r
- "* " dark-blue write-color\r
- [ name>> write ] keep\r
- " has applied mode " dark-blue write-color\r
- [ mode>> write ] keep\r
- " to " dark-blue write-color\r
- parameter>> write ;\r
-\r
-M: nick write-irc\r
- "* " dark-blue write-color\r
- [ irc-message-sender write ] keep\r
- " is now known as " blue write-color\r
- trailing>> write ;\r
-\r
-M: unhandled write-irc\r
- "UNHANDLED: " write\r
- line>> dark-blue write-color ;\r
-\r
-M: irc-end write-irc\r
- drop "* You have left IRC" dark-red write-color ;\r
-\r
-M: irc-disconnected write-irc\r
- drop "* Disconnected" dark-red write-color ;\r
-\r
-M: irc-connected write-irc\r
- drop "* Connected" dark-green write-color ;\r
-\r
-M: irc-chat-end write-irc\r
- drop ;\r
-\r
-M: irc-message write-irc\r
- "UNIMPLEMENTED" write\r
- [ class pprint ] keep\r
- ": " write\r
- line>> dark-blue write-color ;\r
-\r
-GENERIC: time-happened ( message -- timestamp )\r
-\r
-M: irc-message time-happened timestamp>> ;\r
-\r
-M: object time-happened drop now ;\r
-\r
-: print-irc ( irc-message -- )\r
- [ time-happened timestamp>hms write " " write ]\r
- [ write-irc nl ] bi ;\r
-\r
-: send-message ( message -- )\r
- [ print-irc ]\r
- [ chat get speak ] bi ;\r
-\r
-GENERIC: handle-inbox ( tab message -- )\r
-\r
-: value-labels ( assoc val -- seq )\r
- '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;\r
-\r
-: add-gadget-color ( pack seq color -- pack )\r
- '[ _ >>color add-gadget ] each ;\r
-\r
-M: object handle-inbox\r
- nip print-irc ;\r
-\r
-: display ( stream tab -- )\r
- '[ _ [ [ t ]\r
- [ _ dup chat>> hear handle-inbox ]\r
- while ] with-output-stream ] "ircv" spawn drop ;\r
-\r
-: <irc-pane> ( tab -- tab pane )\r
- <scrolling-pane>\r
- [ <pane-stream> swap display ] 2keep ;\r
-\r
-TUPLE: irc-editor < editor outstream tab ;\r
-\r
-: <irc-editor> ( tab pane -- tab editor )\r
- irc-editor new-editor\r
- swap <pane-stream> >>outstream ;\r
-\r
-: editor-send ( irc-editor -- )\r
- { [ outstream>> ]\r
- [ [ irc-tab? ] find-parent ]\r
- [ editor-string ]\r
- [ "" swap set-editor-string ] } cleave\r
- '[ _ irc-tab set _ parse-message ] with-output-stream ;\r
-\r
-irc-editor "general" f {\r
- { T{ key-down f f "RET" } editor-send }\r
- { T{ key-down f f "ENTER" } editor-send }\r
-} define-command-map\r
-\r
-: new-irc-tab ( chat ui-window class -- irc-tab )\r
- new-frame\r
- swap >>window\r
- swap >>chat\r
- <irc-pane> [ <scroller> @center grid-add ] keep\r
- <irc-editor> <scroller> @bottom grid-add ;\r
-\r
-M: irc-tab graft*\r
- [ chat>> ] [ window>> client>> ] bi attach-chat ;\r
-\r
-M: irc-tab ungraft*\r
- chat>> detach-chat ;\r
-\r
-TUPLE: irc-channel-tab < irc-tab userlist ;\r
-\r
-: <irc-channel-tab> ( chat ui-window -- irc-tab )\r
- irc-channel-tab new-irc-tab\r
- <pile> [ <scroller> @right grid-add ] keep >>userlist ;\r
-\r
-: update-participants ( tab -- )\r
- [ userlist>> [ clear-gadget ] keep ]\r
- [ chat>> participants>> ] bi\r
- [ +operator+ value-labels dark-green add-gadget-color ]\r
- [ +voice+ value-labels blue add-gadget-color ]\r
- [ +normal+ value-labels black add-gadget-color ] tri drop ;\r
-\r
-M: participant-changed handle-inbox\r
- drop update-participants ;\r
-\r
-TUPLE: irc-server-tab < irc-tab ;\r
-\r
-: <irc-server-tab> ( chat -- irc-tab )\r
- f irc-server-tab new-irc-tab ;\r
-\r
-: <irc-nick-tab> ( chat ui-window -- irc-tab )\r
- irc-tab new-irc-tab ;\r
-\r
-M: irc-tab pref-dim*\r
- drop { 480 480 } ;\r
-\r
-: join-channel ( name ui-window -- )\r
- [ dup <irc-channel-chat> ] dip\r
- [ <irc-channel-tab> swap ] keep\r
- add-page ;\r
-\r
-: query-nick ( nick ui-window -- )\r
- [ dup <irc-nick-chat> ] dip\r
- [ <irc-nick-tab> swap ] keep\r
- add-page ;\r
-\r
-: irc-window ( ui-window -- )\r
- [ ]\r
- [ client>> profile>> server>> ] bi\r
- open-window ;\r
-\r
-: ui-connect ( profile -- ui-window )\r
- <irc-client>\r
- { [ [ <irc-server-chat> ] dip attach-chat ]\r
- [ chats>> +server-chat+ swap at <irc-server-tab> dup\r
- "Server" associate ui-window new-tabbed [ swap window<< ] keep ]\r
- [ >>client ]\r
- [ connect-irc ] } cleave ;\r
-\r
-: server-open ( server port nick password channels -- )\r
- [ <irc-profile> ui-connect [ irc-window ] keep ] dip\r
- [ over join-channel ] each drop ;\r
-\r
-: main-run ( -- ) run-ircui ;\r
-\r
-MAIN: main-run\r
-\r
-"irc.ui.commands" require\r
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel threads combinators concurrency.mailboxes
+ sequences strings hashtables splitting fry assocs hashtables colors
+ sorting unicode.collation math.order
+ ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
+ ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
+ ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
+ io io.styles namespaces calendar calendar.format models continuations
+ irc.client irc.client.private irc.messages
+ irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;
+
+RENAME: join sequences => sjoin
+
+IN: irc.ui
+
+SYMBOL: chat
+
+SYMBOL: client
+
+TUPLE: ui-window < tabbed client ;
+
+M: ui-window ungraft*
+ client>> terminate-irc ;
+
+TUPLE: irc-tab < frame chat client window ;
+
+: write-color ( str color -- )
+ foreground associate format ;
+CONSTANT: dark-red T{ rgba f 0.5 0.0 0.0 1 }
+CONSTANT: dark-green T{ rgba f 0.0 0.5 0.0 1 }
+CONSTANT: dark-blue T{ rgba f 0.0 0.0 0.5 1 }
+
+: dot-or-parens ( string -- string )
+ [ "." ]
+ [ "(" prepend ")" append ] if-empty ;
+
+GENERIC: write-irc ( irc-message -- )
+
+M: ping write-irc
+ drop "* Ping" blue write-color ;
+
+M: privmsg write-irc
+ "<" dark-blue write-color
+ [ irc-message-sender write ] keep
+ "> " dark-blue write-color
+ trailing>> write ;
+
+M: notice write-irc
+ [ type>> dark-blue write-color ] keep
+ ": " dark-blue write-color
+ trailing>> write ;
+
+TUPLE: own-message message nick timestamp ;
+
+: <own-message> ( message nick -- own-message )
+ now own-message boa ;
+
+M: own-message write-irc
+ "<" dark-blue write-color
+ [ nick>> bold font-style associate format ] keep
+ "> " dark-blue write-color
+ message>> write ;
+
+M: join write-irc
+ "* " dark-green write-color
+ irc-message-sender write
+ " has entered the channel." dark-green write-color ;
+
+M: part write-irc
+ "* " dark-red write-color
+ [ irc-message-sender write ] keep
+ " has left the channel" dark-red write-color
+ trailing>> dot-or-parens dark-red write-color ;
+
+M: quit write-irc
+ "* " dark-red write-color
+ [ irc-message-sender write ] keep
+ " has left IRC" dark-red write-color
+ trailing>> dot-or-parens dark-red write-color ;
+
+M: kick write-irc
+ "* " dark-red write-color
+ [ irc-message-sender write ] keep
+ " has kicked " dark-red write-color
+ [ who>> write ] keep
+ " from the channel" dark-red write-color
+ trailing>> dot-or-parens dark-red write-color ;
+
+M: mode write-irc
+ "* " dark-blue write-color
+ [ name>> write ] keep
+ " has applied mode " dark-blue write-color
+ [ mode>> write ] keep
+ " to " dark-blue write-color
+ parameter>> write ;
+
+M: nick write-irc
+ "* " dark-blue write-color
+ [ irc-message-sender write ] keep
+ " is now known as " blue write-color
+ trailing>> write ;
+
+M: unhandled write-irc
+ "UNHANDLED: " write
+ line>> dark-blue write-color ;
+
+M: irc-end write-irc
+ drop "* You have left IRC" dark-red write-color ;
+
+M: irc-disconnected write-irc
+ drop "* Disconnected" dark-red write-color ;
+
+M: irc-connected write-irc
+ drop "* Connected" dark-green write-color ;
+
+M: irc-chat-end write-irc
+ drop ;
+
+M: irc-message write-irc
+ "UNIMPLEMENTED" write
+ [ class pprint ] keep
+ ": " write
+ line>> dark-blue write-color ;
+
+GENERIC: time-happened ( message -- timestamp )
+
+M: irc-message time-happened timestamp>> ;
+
+M: object time-happened drop now ;
+
+: print-irc ( irc-message -- )
+ [ time-happened timestamp>hms write " " write ]
+ [ write-irc nl ] bi ;
+
+: send-message ( message -- )
+ [ print-irc ]
+ [ chat get speak ] bi ;
+
+GENERIC: handle-inbox ( tab message -- )
+
+: value-labels ( assoc val -- seq )
+ '[ nip _ = ] assoc-filter keys sort-strings [ <label> ] map ;
+
+: add-gadget-color ( pack seq color -- pack )
+ '[ _ >>color add-gadget ] each ;
+
+M: object handle-inbox
+ nip print-irc ;
+
+: display ( stream tab -- )
+ '[ _ [ [ t ]
+ [ _ dup chat>> hear handle-inbox ]
+ while ] with-output-stream ] "ircv" spawn drop ;
+
+: <irc-pane> ( tab -- tab pane )
+ <scrolling-pane>
+ [ <pane-stream> swap display ] 2keep ;
+
+TUPLE: irc-editor < editor outstream tab ;
+
+: <irc-editor> ( tab pane -- tab editor )
+ irc-editor new-editor
+ swap <pane-stream> >>outstream ;
+
+: editor-send ( irc-editor -- )
+ { [ outstream>> ]
+ [ [ irc-tab? ] find-parent ]
+ [ editor-string ]
+ [ "" swap set-editor-string ] } cleave
+ '[ _ irc-tab set _ parse-message ] with-output-stream ;
+
+irc-editor "general" f {
+ { T{ key-down f f "RET" } editor-send }
+ { T{ key-down f f "ENTER" } editor-send }
+} define-command-map
+
+: new-irc-tab ( chat ui-window class -- irc-tab )
+ new-frame
+ swap >>window
+ swap >>chat
+ <irc-pane> [ <scroller> @center grid-add ] keep
+ <irc-editor> <scroller> @bottom grid-add ;
+
+M: irc-tab graft*
+ [ chat>> ] [ window>> client>> ] bi attach-chat ;
+
+M: irc-tab ungraft*
+ chat>> detach-chat ;
+
+TUPLE: irc-channel-tab < irc-tab userlist ;
+
+: <irc-channel-tab> ( chat ui-window -- irc-tab )
+ irc-channel-tab new-irc-tab
+ <pile> [ <scroller> @right grid-add ] keep >>userlist ;
+
+: update-participants ( tab -- )
+ [ userlist>> [ clear-gadget ] keep ]
+ [ chat>> participants>> ] bi
+ [ +operator+ value-labels dark-green add-gadget-color ]
+ [ +voice+ value-labels blue add-gadget-color ]
+ [ +normal+ value-labels black add-gadget-color ] tri drop ;
+
+M: participant-changed handle-inbox
+ drop update-participants ;
+
+TUPLE: irc-server-tab < irc-tab ;
+
+: <irc-server-tab> ( chat -- irc-tab )
+ f irc-server-tab new-irc-tab ;
+
+: <irc-nick-tab> ( chat ui-window -- irc-tab )
+ irc-tab new-irc-tab ;
+
+M: irc-tab pref-dim*
+ drop { 480 480 } ;
+
+: join-channel ( name ui-window -- )
+ [ dup <irc-channel-chat> ] dip
+ [ <irc-channel-tab> swap ] keep
+ add-page ;
+
+: query-nick ( nick ui-window -- )
+ [ dup <irc-nick-chat> ] dip
+ [ <irc-nick-tab> swap ] keep
+ add-page ;
+
+: irc-window ( ui-window -- )
+ [ ]
+ [ client>> profile>> server>> ] bi
+ open-window ;
+
+: ui-connect ( profile -- ui-window )
+ <irc-client>
+ { [ [ <irc-server-chat> ] dip attach-chat ]
+ [ chats>> +server-chat+ swap at <irc-server-tab> dup
+ "Server" associate ui-window new-tabbed [ swap window<< ] keep ]
+ [ >>client ]
+ [ connect-irc ] } cleave ;
+
+: server-open ( server port nick password channels -- )
+ [ <irc-profile> ui-connect [ irc-window ] keep ] dip
+ [ over join-channel ] each drop ;
+
+: main-run ( -- ) run-ircui ;
+
+MAIN: main-run
+
+"irc.ui.commands" require
projects / factor.git / commitdiff