definitions system layouts vectors math.partial-dispatch
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
-sorting.private combinators.short-circuit
+sorting.private combinators.short-circuit grouping prettyprint
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
[ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
[ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
] unit-test
+
+[ ] [
+ [ { null } declare [ 1 ] [ 2 ] if ]
+ build-tree normalize propagate cleanup check-nodes
+] unit-test
+
+[ t ] [
+ [ { array } declare 2 <groups> [ . . ] assoc-each ]
+ \ nth-unsafe inlined?
+] unit-test
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
dup live-children sift dup length {
- { 0 [ 2drop f ] }
+ { 0 [ drop in-d>> #drop ] }
{ 1 [ first swap in-d>> #drop prefix ] }
[ 2drop ]
} case ;
quotations.private prettyprint classes.tuple.private classes
classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
+compiler.tree.checker
kernel.private ;
\ escape-analysis must-infer
propagate
cleanup
escape-analysis
+ dup check-nodes
0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
-[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
+[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 0 ] [
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
SYMBOL: infer-children-data
: copy-value-info ( -- )
- value-infos [ clone ] change
- constraints [ clone ] change ;
+ value-infos [ H{ } clone suffix ] change
+ constraints [ H{ } clone suffix ] change ;
: no-value-info ( -- )
value-infos off
M: true-constraint assume*
[ \ f class-not <class-info> swap value>> refine-value-info ]
- [ constraints get at [ assume ] when* ]
+ [ constraints get assoc-stack [ assume ] when* ]
bi ;
M: true-constraint satisfied?
M: false-constraint assume*
[ \ f <class-info> swap value>> refine-value-info ]
- [ constraints get at [ assume ] when* ]
+ [ constraints get assoc-stack [ assume ] when* ]
bi ;
M: false-constraint satisfied?
C: --> implication
: assume-implication ( p q -- )
- [ constraints get [ swap suffix ] change-at ]
+ [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication assume*
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
object-info value-info-intersect =
] unit-test
+
+[ t ] [
+ null-info 3 <literal-info> value-info<=
+] unit-test
: null-info T{ value-info f null empty-interval } ; inline
-: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
+: object-info T{ value-info f object full-interval } ; inline
: class-interval ( class -- interval )
dup real class<=
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
- dup empty-interval eq? [
+ dup special-interval? [
2drop f f
] [
dup from>> first {
: literals<= ( info1 info2 -- ? )
{
{ [ dup literal?>> not ] [ 2drop t ] }
- { [ over literal?>> not ] [ 2drop f ] }
+ { [ over literal?>> not ] [ drop class>> null-class? ] }
[ [ literal>> ] bi@ eql? ]
} cond ;
]
} cond ;
-! Current value --> info mapping
+! Assoc stack of current value --> info mapping
SYMBOL: value-infos
: value-info ( value -- info )
- resolve-copy value-infos get at null-info or ;
+ resolve-copy value-infos get assoc-stack null-info or ;
: set-value-info ( info value -- )
- resolve-copy value-infos get set-at ;
+ resolve-copy value-infos get peek set-at ;
: refine-value-info ( info value -- )
- resolve-copy value-infos get [ value-info-intersect ] change-at ;
+ resolve-copy value-infos get
+ [ assoc-stack value-info-intersect ] 2keep
+ peek set-at ;
: value-literal ( value -- obj ? )
value-info >literal< ;
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
-float-arrays system ;
+float-arrays system sorting ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
+[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences namespaces hashtables
+USING: accessors kernel sequences namespaces hashtables arrays
compiler.tree
compiler.tree.propagation.copy
compiler.tree.propagation.info
: propagate ( node -- node )
H{ } clone copies set
- H{ } clone constraints set
- H{ } clone value-infos set
+ H{ } clone 1array value-infos set
+ H{ } clone 1array constraints set
dup count-nodes
dup (propagate) ;
[ value-info<= ] 2all?
[ drop ] [ label>> f >>fixed-point drop ] if ;
+: latest-input-infos ( node -- infos )
+ in-d>> [ value-info ] map ;
+
: recursive-stacks ( #enter-recursive -- stacks initial )
[ label>> calls>> [ node-input-infos ] map flip ]
- [ in-d>> [ value-info ] map ] bi ;
+ [ latest-input-infos ] bi ;
: generalize-counter-interval ( interval initial-interval -- interval' )
{
] if ;
: propagate-recursive-phi ( #enter-recursive -- )
- [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
- [ node-output-infos check-fixed-point ]
- [ out-d>> set-value-infos drop ]
- 3bi ;
+ [ recursive-stacks unify-recursive-stacks ] keep
+ out-d>> set-value-infos ;
M: #recursive propagate-around ( #recursive -- )
+ constraints [ H{ } clone suffix ] change
[
- constraints [ clone ] change
+ constraints [ but-last H{ } clone suffix ] change
child>>
[ first compute-copy-equiv ]
tri
] until-fixed-point ;
+: recursive-phi-infos ( node -- infos )
+ label>> enter-recursive>> node-output-infos ;
+
: generalize-return-interval ( info -- info' )
dup [ literal?>> ] [ class>> null-class? ] bi or
[ clone [-inf,inf] >>interval ] unless ;
[ generalize-return-interval ] map ;
: return-infos ( node -- infos )
- label>> [ return>> node-input-infos ] [ loop?>> ] bi
- [ generalize-return ] unless ;
+ label>> return>> node-input-infos generalize-return ;
+
+: save-return-infos ( node infos -- )
+ swap out-d>> set-value-infos ;
+
+: unless-loop ( node quot -- )
+ [ dup label>> loop?>> [ drop ] ] dip if ; inline
M: #call-recursive propagate-before ( #call-recursive -- )
- [ ] [ return-infos ] [ node-output-infos ] tri
- [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
+ [
+ [ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
+ check-fixed-point
+ ]
+ [
+ [
+ [ ] [ return-infos ] [ node-output-infos ] tri
+ [ check-fixed-point ] [ drop save-return-infos ] 3bi
+ ] unless-loop
+ ] bi ;
M: #call-recursive annotate-node
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
M: #enter-recursive annotate-node
dup out-d>> (annotate-node) ;
+M: #return-recursive propagate-before ( #return-recursive -- )
+ [
+ [ ] [ latest-input-infos ] [ node-input-infos ] tri
+ check-fixed-point
+ ] unless-loop ;
+
M: #return-recursive annotate-node
dup in-d>> (annotate-node) ;
[ f ] [ <dlist> 3 over push-front 4 over push-back -1 swap deque-member? ] unit-test
[ f ] [ <dlist> 0 swap deque-member? ] unit-test
+
+! Make sure clone does the right thing
+[ V{ 2 1 } V{ 2 1 3 } ] [
+ <dlist> 1 over push-front 2 over push-front
+ dup clone 3 over push-back
+ [ dlist>seq ] bi@
+] unit-test
: dlist-each ( dlist quot -- )
[ obj>> ] prepose dlist-each-node ; inline
+: dlist>seq ( dlist -- seq )
+ [ ] pusher [ dlist-each ] dip ;
+
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
+M: dlist clone
+ <dlist> [
+ [ push-back ] curry dlist-each
+ ] keep ;
+
INSTANCE: dlist deque
USING: help.markup help.syntax ui.commands ui.operations
ui.tools.search ui.tools.workspace editors vocabs.loader
kernel sequences prettyprint tools.test tools.vocabs strings
-unicode.categories unicode.case ;
+unicode.categories unicode.case ui.tools.browser ;
IN: help.tutorial
ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
"Factor source code is organized into " { $link "vocabularies" } ". Before we can write our first program, we must create a vocabulary for it."
$nl
-"Start by asking Factor for the path to your ``work'' directory, where you will place your own code:"
+"Start by loading the scaffold tool:"
+{ $code "USE: tools.scaffold" }
+"Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":"
+{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
+"If you look at the output, you will see that a few files were created in your ``work'' directory. The following phrase will print the full path of your work directory:"
{ $code "\"work\" resource-path ." }
-"Open the work directory in your file manager, and create a subdirectory named " { $snippet "palindrome" } ". Inside this directory, create a file named " { $snippet "palindrome.factor" } " using your favorite text editor. Leave the file empty for now."
+"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file."
$nl
-"Inside the Factor listener, type"
-{ $code "USE: palindrome" }
-"The source file should now load. Since it is empty, it does nothing. If you get an error message, make sure you created the directory and the file in the right place and gave them the right names."
-$nl
-"Now, we will start filling out this source file. Go back to your editor, and type:"
-{ $code
- "! Copyright (C) 2008 <your name here>"
- "! See http://factorcode.org/license.txt for BSD license."
-}
-"This is the standard header for Factor source files; it consists of two " { $link "syntax-comments" } "."
-$nl
-"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
+"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
{ $code "IN: palindrome" }
+"We will add new definitions after the " { $link POSTPONE: IN: } " form."
+$nl
"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
ARTICLE: "first-program-logic" "Writing some logic in your first program"
$nl
"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
$nl
-"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary by entering the following in the listener:"
-{ $code "\\ dup see" }
-"This shows the definition of " { $link dup } ", along with an " { $link POSTPONE: IN: } " form."
+"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-follow } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
$nl
-"Now, add the following at the start of the source file:"
+"So now, add the following at the start of the source file:"
{ $code "USING: kernel ;" }
-"Next, find out what vocabulary " { $link reverse } " lives in:"
-{ $code "\\ reverse see" }
+"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the workspace listener's input area, and press " { $operation com-follow } "."
+$nl
"It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
{ $code "USING: kernel sequences ;" }
-"Finally, check what vocabulary " { $link = } " lives in:"
-{ $code "\\ = see" }
-"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
-
+"Finally, check what vocabulary " { $link = } " lives in, and confirm that it's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
+$nl
"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
ARTICLE: "first-program-test" "Testing your first program"
{ $code "." }
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
$nl
-"Create a file named " { $snippet "palindrome-tests.factor" } " in the same directory as " { $snippet "palindrome.factor" } ". Now, we can run unit tests from the listener:"
-{ $code "\"palindrome\" test" }
-"We will add some unit tests corresponding to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
+"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
+$nl
+"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
ARTICLE: "first-program" "Your first program"
"In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
$nl
-"In this tutorial, you will learn about basic Factor development tools, as well as application deployment."
+"In this tutorial, you will learn about basic Factor development tools. You may want to open a second workspace window by pressing " { $command workspace "workflow" workspace-window } "; this will allow you to read this tutorial and browse other documentation at the same time."
{ $subsection "first-program-start" }
{ $subsection "first-program-logic" }
{ $subsection "first-program-test" }
IN: io.encodings.string
ARTICLE: "io.encodings.string" "Encoding and decoding strings"
-"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:"
+"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
+{ $link "encodings-descriptors" } " to the following words:"
{ $subsection encode }
{ $subsection decode } ;
$nl
"The two methods are equivalent, representing a functional versus an object-oriented approach to the problem." ;
+ARTICLE: "server-examples" "Threaded server examples"
+"The " { $vocab-link "time-server" } " vocabulary implements a simple threaded server which sends the current time to the client. The " { $vocab-link "concurrency.distributed" } ", " { $vocab-link "ftp.server" } ", and " { $vocab-link "http.server" } " vocabularies demonstrate more complex usage of the threaded server library." ;
+
ARTICLE: "io.servers.connection" "Threaded servers"
"The " { $vocab-link "io.servers.connection" } " vocabulary implements a generic server abstraction for " { $link "network-connection" } ". A set of threads listen for connections, and additional threads are spawned for each client connection. In addition to this basic functionality, it provides some advanced features such as logging, connection limits and secure socket support."
-{ $subsection threaded-server }
-{ $subsection "server-config" }
+{ $subsection "server-examples" }
"Creating threaded servers with client handler quotations:"
{ $subsection <threaded-server> }
"Client handlers can also be implemented by subclassing a threaded server; see " { $link "server-config-handler" } " for details:"
+{ $subsection threaded-server }
{ $subsection new-threaded-server }
{ $subsection handle-client* }
+"The server must be configured before it can be started."
+{ $subsection "server-config" }
"Starting the server:"
{ $subsection start-server }
{ $subsection start-server* }
USING: help.syntax help.markup kernel macros prettyprint
-memoize ;
+memoize combinators arrays ;
IN: locals
HELP: [|
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
+ARTICLE: "locals-literals" "Locals in array and hashtable literals"
+"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
+$nl
+"The data types which receive this special handling are the following:"
+{ $list
+ { $link "arrays" }
+ { $link "hashtables" }
+ { $link "vectors" }
+ { $link "tuples" }
+}
+"This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
+{ $example
+ "IN: scratchpad"
+ "TUPLE: person first-name last-name ;"
+ ": ordinary-word-test ( -- tuple )"
+ " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
+ "ordinary-word-test ordinary-word-test eq? ."
+ "t"
+}
+"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
+{ $example
+ "IN: scratchpad"
+ "TUPLE: person first-name last-name ;"
+ ":: ordinary-word-test ( -- tuple )"
+ " T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
+ "ordinary-word-test ordinary-word-test eq? ."
+ "f"
+}
+"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
+$nl
+"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
+{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
+
ARTICLE: "locals-mutable" "Mutable locals"
"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
$nl
"Lambda abstractions:"
{ $subsection POSTPONE: [| }
"Additional topics:"
+{ $subsection "locals-literals" }
{ $subsection "locals-mutable" }
{ $subsection "locals-limitations" }
"Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ;
-USING: help.markup help.syntax math ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax math sequences ;
IN: math.bitwise
-ARTICLE: "math-bitfields" "Constructing bit fields"
-"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
-{ $subsection bitfield } ;
-
-ABOUT: "math-bitfields"
-
HELP: bitfield
{ $values { "values..." "a series of objects" } { "bitspec" "an array" } { "n" integer } }
{ $description "Constructs an integer from a series of values on the stack together with a bit field specifier, which is an array whose elements have one of the following shapes:"
{ $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
HELP: bitroll
-{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
+{ $values { "x" integer } { "s" "a shift integer" } { "w" "a wrap integer" } { "y" integer }
+}
{ $description "Roll n by s bits to the left, wrapping around after w bits." }
{ $examples
{ $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
} ;
+
+HELP: bit-clear?
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Returns " { $link t } " if the nth bit is set to zero." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: ff 8 bit-clear? ."
+ "t"
+ }
+ { $example "" "USING: math.bitwise prettyprint ;"
+ "HEX: ff 7 bit-clear? ."
+ "f"
+ }
+} ;
+
+{ bit? bit-clear? set-bit clear-bit } related-words
+
+HELP: bit-count
+{ $values
+ { "x" integer }
+ { "n" integer }
+}
+{ $description "Returns the number of set bits as an integer." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: f0 bit-count ."
+ "4"
+ }
+ { $example "USING: math.bitwise prettyprint ;"
+ "-7 bit-count ."
+ "2"
+ }
+} ;
+
+HELP: bitroll-32
+{ $values
+ { "n" integer } { "s" integer }
+ { "n'" integer }
+}
+{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: 1 10 bitroll-32 .h"
+ "400"
+ }
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: 1 -10 bitroll-32 .h"
+ "400000"
+ }
+} ;
+
+HELP: bitroll-64
+{ $values
+ { "n" integer } { "s" "a shift integer" }
+ { "n'" integer }
+}
+{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
+{ $examples
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: 1 10 bitroll-64 .h"
+ "400"
+ }
+ { $example "USING: math.bitwise prettyprint ;"
+ "HEX: 1 -10 bitroll-64 .h"
+ "40000000000000"
+ }
+} ;
+
+{ bitroll bitroll-32 bitroll-64 } related-words
+
+HELP: clear-bit
+{ $values
+ { "x" integer } { "n" integer }
+ { "y" integer }
+}
+{ $description "Sets the nth bit of " { $snippet "x" } " to zero." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff 7 clear-bit .h"
+ "7f"
+ }
+} ;
+
+HELP: flags
+{ $values
+ { "values" sequence }
+}
+{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "IN: scratchpad"
+ ": MY-CONSTANT HEX: 1 ; inline"
+ "{ HEX: 20 MY-CONSTANT BIN: 100 } flags .h"
+ "25"
+ }
+} ;
+
+HELP: mask
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "After the operation, only the bits that were set in both the mask and the original number are set." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "BIN: 11111111 BIN: 101 mask .b"
+ "101"
+ }
+} ;
+
+HELP: mask-bit
+{ $values
+ { "m" integer } { "n" integer }
+ { "m'" integer }
+}
+{ $description "Turns off all bits besides the nth bit." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff 2 mask-bit .b"
+ "100"
+ }
+} ;
+
+HELP: mask?
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Returns true if all of the bits in the mask " { $snippet "n" } " are set in the integer input " { $snippet "x" } "." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff HEX: f mask? ."
+ "t"
+ }
+
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: f0 HEX: 1 mask? ."
+ "f"
+ }
+} ;
+
+HELP: on-bits
+{ $values
+ { "n" integer }
+ { "m" integer }
+}
+{ $description "Returns an integer with " { $snippet "n" } " bits set." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "6 on-bits .h"
+ "3f"
+ }
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "64 on-bits .h"
+ "ffffffffffffffff"
+ }
+}
+;
+
+HELP: set-bit
+{ $values
+ { "x" integer } { "n" integer }
+ { "y" integer }
+}
+{ $description "Sets the nth bit of " { $snippet "x" } "." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "0 5 set-bit .h"
+ "20"
+ }
+} ;
+
+HELP: shift-mod
+{ $values
+ { "n" integer } { "s" integer } { "w" integer }
+ { "n" integer }
+}
+{ $description "" } ;
+
+HELP: unmask
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Clears the bits in " { $snippet "x" } " if they are set in the mask " { $snippet "n" } "." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff HEX: 0f unmask .h"
+ "f0"
+ }
+} ;
+
+HELP: unmask?
+{ $values
+ { "x" integer } { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Tests whether unmasking the bits in " { $snippet "x" } " would return an integer greater than zero." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ff HEX: 0f unmask? ."
+ "t"
+ }
+} ;
+
+HELP: w*
+{ $values
+ { "int" integer } { "int" integer }
+ { "int" integer }
+}
+{ $description "Multiplies two integers and wraps the result to 32 bits." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ffffffff HEX: 2 w* ."
+ "4294967294"
+ }
+} ;
+
+HELP: w+
+{ $values
+ { "int" integer } { "int" integer }
+ { "int" integer }
+}
+{ $description "Adds two integers and wraps the result to 32 bits." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: ffffffff HEX: 2 w+ ."
+ "1"
+ }
+} ;
+
+HELP: w-
+{ $values
+ { "int" integer } { "int" integer }
+ { "int" integer }
+}
+{ $description "Subtracts two integers and wraps the result to 32 bits." }
+{ $examples
+ { $example "USING: math.bitwise kernel prettyprint ;"
+ "HEX: 0 HEX: ff w- ."
+ "4294967041"
+ }
+} ;
+
+HELP: wrap
+{ $values
+ { "m" integer } { "n" integer }
+ { "m'" integer }
+}
+{ $description "Wraps an integer " { $snippet "m" } " by modding it by " { $snippet "n" } ". This word is uses bitwise arithmetic and does not actually call the modulus word, and as such can only mod by powers of two." }
+{ $examples "Equivalent to modding by 8:"
+ { $example
+ "USING: math.bitwise prettyprint ;"
+ "HEX: ffff 8 wrap .h"
+ "7"
+ }
+} ;
+
+ARTICLE: "math-bitfields" "Constructing bit fields"
+"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
+{ $subsection bitfield } ;
+
+ARTICLE: "math.bitwise" "Bitwise arithmetic"
+"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
+"Setting and clearing bits:"
+{ $subsection set-bit }
+{ $subsection clear-bit }
+"Testing if bits are set or clear:"
+{ $subsection bit? }
+{ $subsection bit-clear? }
+"Operations with bitmasks:"
+{ $subsection mask }
+{ $subsection unmask }
+{ $subsection mask? }
+{ $subsection unmask? }
+"Generating an integer with n set bits:"
+{ $subsection on-bits }
+"Counting the number of set bits:"
+{ $subsection bit-count }
+"More efficient modding by powers of two:"
+{ $subsection wrap }
+"Bit-rolling:"
+{ $subsection bitroll }
+{ $subsection bitroll-32 }
+{ $subsection bitroll-64 }
+"32-bit arithmetic:"
+{ $subsection w+ }
+{ $subsection w- }
+{ $subsection w* }
+"Bitfields:"
+{ $subsection flags }
+{ $subsection "math-bitfields" } ;
+
+ABOUT: "math.bitwise"
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
+
+[ 1 ] [ { 1 } flags ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints
! utilities
: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
: set-bit ( x n -- y ) 2^ bitor ; inline
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
+: bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
: unmask ( x n -- ? ) bitnot bitand ; inline
: unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline
: wrap ( m n -- m' ) 1- bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
-: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
+: mask-bit ( m n -- m' ) 2^ mask ; inline
+: on-bits ( n -- m ) 2^ 1- ; inline
: shift-mod ( n s w -- n )
- >r shift r> 2^ wrap ; inline
+ [ shift ] dip 2^ wrap ; inline
: bitroll ( x s w -- y )
- [ wrap ] keep
- [ shift-mod ]
- [ [ - ] keep shift-mod ] 3bi bitor ; inline
+ [ wrap ] keep
+ [ shift-mod ]
+ [ [ - ] keep shift-mod ] 3bi bitor ; inline
-: bitroll-32 ( n s -- n' ) 32 bitroll ;
+: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
HINTS: bitroll-32 bignum fixnum ;
-: bitroll-64 ( n s -- n' ) 64 bitroll ;
+: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
HINTS: bitroll-64 bignum fixnum ;
! flags
MACRO: flags ( values -- )
- [ 0 ] [ [ execute bitor ] curry compose ] reduce ;
+ [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
! bitfield
<PRIVATE
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
- first2 over word? [ >r swapd execute r> ] [ ] ?
+ first2 over word? [ [ swapd execute ] dip ] [ ] ?
[ shift bitor ] append 2curry ;
PRIVATE>
PRIVATE>
: bit-count ( x -- n )
- dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline
+ dup 0 < [ bitnot ] when (bit-count) ; inline
[ -4.0 ] [ -4.4 round ] unit-test
[ 5.0 ] [ 4.5 round ] unit-test
[ 4.0 ] [ 4.4 round ] unit-test
+
+[ 6 59967 ] [ 3837888 factor-2s ] unit-test
+[ 6 -59967 ] [ -3837888 factor-2s ] unit-test
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel math.constants math.private
-math.libm combinators math.order ;
+math.libm combinators math.order sequences ;
IN: math.functions
+: >fraction ( a/b -- a b )
+ [ numerator ] [ denominator ] bi ; inline
+
<PRIVATE
: (rect>) ( x y -- z )
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline recursive
-: ^n ( z w -- z^w )
- 1 swap [
- [ dupd * ] when >r sq r>
- ] each-bit nip ; inline
+: map-bits ( n quot: ( ? -- obj ) -- seq )
+ accumulator [ each-bit ] dip ; inline
+
+: factor-2s ( n -- r s )
+ #! factor an integer into 2^r * s
+ dup 0 = [ 1 ] [
+ 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while
+ ] if ; inline
+
+<PRIVATE
+
+GENERIC# ^n 1 ( z w -- z^w )
+
+: (^n) 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
+
+M: integer ^n
+ [ factor-2s ] dip [ (^n) ] keep rot * shift ;
+
+M: ratio ^n
+ [ >fraction ] dip tuck [ ^n ] 2bi@ / ;
+
+M: float ^n
+ (^n) ;
: integer^ ( x y -- z )
dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
+PRIVATE>
+
: >rect ( z -- x y )
[ real-part ] [ imaginary-part ] bi ; inline
: polar> ( abs arg -- z ) cis * ; inline
+<PRIVATE
+
: ^mag ( w abs arg -- magnitude )
>r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
inline
: 0^ ( x -- z )
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
+PRIVATE>
+
: ^ ( x y -- z )
{
{ [ over zero? ] [ nip 0^ ] }
[ empty-interval ] [ 0 5 (a,b] empty-interval interval-intersect ] unit-test
+[ t ] [
+ 0 1 (a,b) full-interval interval-intersect 0 1 (a,b) =
+] unit-test
+
[ t ] [
empty-interval empty-interval interval-subset?
] unit-test
! Interval random tester
: random-element ( interval -- n )
- dup to>> first over from>> first tuck - random +
- 2dup swap interval-contains? [
- nip
+ dup full-interval eq? [
+ drop 32 random-bits 31 2^ -
] [
- drop random-element
+ dup to>> first over from>> first tuck - random +
+ 2dup swap interval-contains? [
+ nip
+ ] [
+ drop random-element
+ ] if
] if ;
: random-interval ( -- interval )
- 2000 random 1000 - dup 2 1000 random + +
- 1 random zero? [ [ neg ] bi@ swap ] when
- 4 random {
- { 0 [ [a,b] ] }
- { 1 [ [a,b) ] }
- { 2 [ (a,b) ] }
- { 3 [ (a,b] ] }
- } case ;
+ 10 random 0 = [ full-interval ] [
+ 2000 random 1000 - dup 2 1000 random + +
+ 1 random zero? [ [ neg ] bi@ swap ] when
+ 4 random {
+ { 0 [ [a,b] ] }
+ { 1 [ [a,b) ] }
+ { 2 [ (a,b) ] }
+ { 3 [ (a,b] ] }
+ } case
+ ] if ;
: random-unary-op ( -- pair )
{
{ bitand interval-bitand }
{ bitor interval-bitor }
{ bitxor interval-bitxor }
- { shift interval-shift }
+ ! { shift interval-shift }
{ min interval-min }
{ max interval-max }
}
SYMBOL: empty-interval
+SYMBOL: full-interval
+
TUPLE: interval { from read-only } { to read-only } ;
: <interval> ( from to -- int )
: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
-: [-inf,inf] ( -- interval )
- T{ interval f { -1./0. t } { 1./0. t } } ; inline
+: [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? )
>r over first over first r> call [
: do-empty-interval ( i1 i2 quot -- i3 )
{
- { [ pick empty-interval eq? ] [ drop drop ] }
+ { [ pick empty-interval eq? ] [ 2drop ] }
{ [ over empty-interval eq? ] [ drop nip ] }
+ { [ pick full-interval eq? ] [ 2drop ] }
+ { [ over full-interval eq? ] [ drop nip ] }
[ call ]
} cond ; inline
: interval-intersect ( i1 i2 -- i3 )
{
- { [ dup empty-interval eq? ] [ nip ] }
{ [ over empty-interval eq? ] [ drop ] }
+ { [ dup empty-interval eq? ] [ nip ] }
+ { [ over full-interval eq? ] [ nip ] }
+ { [ dup full-interval eq? ] [ drop ] }
[
[ interval>points ] bi@ swapd
[ [ swap endpoint< ] most ]
: interval-union ( i1 i2 -- i3 )
{
- { [ dup empty-interval eq? ] [ drop ] }
{ [ over empty-interval eq? ] [ nip ] }
+ { [ dup empty-interval eq? ] [ drop ] }
+ { [ over full-interval eq? ] [ drop ] }
+ { [ dup full-interval eq? ] [ nip ] }
[ [ interval>points 2array ] bi@ append points>interval ]
} cond ;
: interval-contains? ( x int -- ? )
dup empty-interval eq? [ 2drop f ] [
- [ from>> first2 [ >= ] [ > ] if ]
- [ to>> first2 [ <= ] [ < ] if ]
- 2bi and
+ dup full-interval eq? [ 2drop t ] [
+ [ from>> first2 [ >= ] [ > ] if ]
+ [ to>> first2 [ <= ] [ < ] if ]
+ 2bi and
+ ] if
] if ;
: interval-zero? ( int -- ? )
: interval-sq ( i1 -- i2 ) dup interval* ;
+: special-interval? ( interval -- ? )
+ { empty-interval full-interval } memq? ;
+
: interval-singleton? ( int -- ? )
- dup empty-interval eq? [
+ dup special-interval? [
drop f
] [
interval>points
: interval-length ( int -- n )
{
{ [ dup empty-interval eq? ] [ drop 0 ] }
+ { [ dup full-interval eq? ] [ drop 1/0. ] }
[ interval>points [ first ] bi@ swap - ]
} cond ;
[ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
: interval-interior ( i1 -- i2 )
- dup empty-interval eq? [
+ dup special-interval? [
interval>points [ first ] bi@ (a,b)
] unless ;
: interval-abs ( i1 -- i2 )
{
{ [ dup empty-interval eq? ] [ ] }
+ { [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
[ (interval-abs) points>interval ]
} cond ;
: interval< ( i1 i2 -- ? )
{
- { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+ { [ 2dup [ special-interval? ] either? ] [ incomparable ] }
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
{ [ 2dup left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] }
: interval<= ( i1 i2 -- ? )
{
- { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+ { [ 2dup [ special-interval? ] either? ] [ incomparable ] }
{ [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
{ [ 2dup right-endpoint-<= ] [ t ] }
[ incomparable ]
interval-bitor ;
: assume< ( i1 i2 -- i3 )
- dup empty-interval eq? [ drop ] [
+ dup special-interval? [ drop ] [
to>> first [-inf,a) interval-intersect
] if ;
: assume<= ( i1 i2 -- i3 )
- dup empty-interval eq? [ drop ] [
+ dup special-interval? [ drop ] [
to>> first [-inf,a] interval-intersect
] if ;
: assume> ( i1 i2 -- i3 )
- dup empty-interval eq? [ drop ] [
+ dup special-interval? [ drop ] [
from>> first (a,inf] interval-intersect
] if ;
: assume>= ( i1 i2 -- i3 )
- dup empty-interval eq? [ drop ] [
+ dup special-interval? [ drop ] [
from>> first [a,inf] interval-intersect
] if ;
: integral-closure ( i1 -- i2 )
- dup empty-interval eq? [
+ dup special-interval? [
[ from>> first2 [ 1+ ] unless ]
[ to>> first2 [ 1- ] unless ]
bi [a,b]
USING: help.markup help.syntax math math.private
-math.ratios.private ;
+math.ratios.private math.functions ;
IN: math.ratios
ARTICLE: "rationals" "Rational numbers"
USING: accessors kernel kernel.private math math.functions math.private ;
IN: math.ratios
-: >fraction ( a/b -- a b )
- dup numerator swap denominator ; inline
-
: 2>fraction ( a/b c/d -- a c b d )
[ >fraction ] bi@ swapd ; inline
HELP: gl-error
{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
-HELP: do-state
- {
- $values
- { "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
- { "quot" quotation }
- }
-{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
-
HELP: do-enabled
{ $values { "what" integer } { "quot" quotation } }
{ $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } }
{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ;
-HELP: gl-vertex
-{ $values { "point" "a pair of integers" } }
-{ $description "Wrapper for " { $link glVertex2d } " taking a point object." } ;
-
HELP: gl-line
{ $values { "a" "a pair of integers" } { "b" "a pair of integers" } }
{ $description "Draws a line between two points." } ;
HELP: gl-fill-rect
-{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
-{ $description "Draws a filled rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
+{ $values { "dim" "a pair of integers" } }
+{ $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
HELP: gl-rect
-{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
-{ $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
-
-HELP: rect-vertices
-{ $values { "lower-left" "A pair of numbers indicating the lower-left coordinates of the rectangle." } { "upper-right" "The upper-right coordinates of the rectangle." } }
-{ $description "Emits" { $link glVertex2d } " calls outlining the axis-aligned rectangle from " { $snippet "lower-left" } " to " { $snippet "upper-right" } " on the z=0 plane in counterclockwise order." } ;
-
-HELP: gl-fill-poly
-{ $values { "points" "a sequence of pairs of integers" } }
-{ $description "Draws a filled polygon." } ;
-
-HELP: gl-poly
-{ $values { "points" "a sequence of pairs of integers" } }
-{ $description "Draws the outline of a polygon." } ;
-
-HELP: gl-gradient
-{ $values { "direction" "an orientation specifier" } { "colors" "a sequence of color specifiers" } { "dim" "a pair of integers" } }
-{ $description "Draws a rectangle with top-left corner " { $snippet "{ 0 0 }" } " and dimensions " { $snippet "dim" } ", filled with a smoothly shaded transition between the colors in " { $snippet "colors" } "." } ;
+{ $values { "dim" "a pair of integers" } }
+{ $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
HELP: gen-texture
{ $values { "id" integer } }
{ $subsection "opengl-low-level" }
"Wrappers:"
{ $subsection gl-color }
-{ $subsection gl-vertex }
{ $subsection gl-translate }
{ $subsection gen-texture }
{ $subsection bind-texture-unit }
"Combinators:"
-{ $subsection do-state }
{ $subsection do-enabled }
{ $subsection do-attribs }
{ $subsection do-matrix }
{ $subsection gl-line }
{ $subsection gl-fill-rect }
{ $subsection gl-rect }
-{ $subsection gl-fill-poly }
-{ $subsection gl-poly }
-{ $subsection gl-gradient }
;
ABOUT: "gl-utilities"
! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-
USING: alien alien.c-types continuations kernel libc math macros
- namespaces math.vectors math.constants math.functions
- math.parser opengl.gl opengl.glu combinators arrays sequences
- splitting words byte-arrays assocs colors accessors ;
-
+namespaces math.vectors math.constants math.functions
+math.parser opengl.gl opengl.glu combinators arrays sequences
+splitting words byte-arrays assocs colors accessors
+generalizations locals memoize ;
IN: opengl
-: coordinates ( point1 point2 -- x1 y2 x2 y2 )
- [ first2 ] bi@ ;
-
-: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
- [ first2 [ >fixnum ] bi@ ] bi@ ;
+: color>raw ( object -- r g b a )
+ >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
-: gl-color ( color -- ) first4 glColor4d ; inline
+: gl-color ( color -- ) color>raw glColor4d ; inline
-: gl-clear-color ( color -- )
- first4 glClearColor ;
+: gl-clear-color ( color -- ) color>raw glClearColor ;
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
-: color>raw ( object -- r g b a )
- >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
-
-: set-color ( object -- ) color>raw glColor4d ;
-: set-clear-color ( object -- ) color>raw glClearColor ;
-
: gl-error ( -- )
glGetError dup zero? [
"GL error: " over gluErrorString append throw
] unless drop ;
-: do-state ( mode quot -- )
- swap glBegin call glEnd ; inline
-
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
+
: do-enabled-client-state ( what quot -- )
over glEnableClientState dip glDisableClientState ; inline
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
+
: (all-enabled-client-state) ( seq quot -- )
[ dup [ glEnableClientState ] each ] dip
dip
MACRO: all-enabled ( seq quot -- )
>r words>values r> [ (all-enabled) ] 2curry ;
+
MACRO: all-enabled-client-state ( seq quot -- )
>r words>values r> [ (all-enabled-client-state) ] 2curry ;
swap [ glMatrixMode glPushMatrix call ] keep
glMatrixMode glPopMatrix ; inline
-: gl-vertex ( point -- )
- dup length {
- { 2 [ first2 glVertex2d ] }
- { 3 [ first3 glVertex3d ] }
- { 4 [ first4 glVertex4d ] }
- } case ;
-
-: gl-normal ( normal -- ) first3 glNormal3d ;
-
: gl-material ( face pname params -- )
>c-float-array glMaterialfv ;
+: gl-vertex-pointer ( seq -- )
+ [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
+
+: gl-color-pointer ( seq -- )
+ [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
+
+: gl-texture-coord-pointer ( seq -- )
+ [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
+
+: line-vertices ( a b -- )
+ append >c-float-array gl-vertex-pointer ;
+
: gl-line ( a b -- )
- GL_LINES [ gl-vertex gl-vertex ] do-state ;
+ line-vertices GL_LINES 0 2 glDrawArrays ;
-: gl-fill-rect ( loc ext -- )
- coordinates glRectd ;
+: (rect-vertices) ( dim -- vertices )
+ {
+ [ drop 0 1 ]
+ [ first 1- 1 ]
+ [ [ first 1- ] [ second ] bi ]
+ [ second 0 swap ]
+ } cleave 8 narray >c-float-array ;
-: gl-rect ( loc ext -- )
- GL_FRONT_AND_BACK GL_LINE glPolygonMode
- >r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
- GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
+: rect-vertices ( dim -- )
+ (rect-vertices) gl-vertex-pointer ;
-: (gl-poly) ( points state -- )
- [ [ gl-vertex ] each ] do-state ;
+: (gl-rect) ( -- )
+ GL_LINE_LOOP 0 4 glDrawArrays ;
-: gl-fill-poly ( points -- )
- dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
+: gl-rect ( dim -- )
+ rect-vertices (gl-rect) ;
-: gl-poly ( points -- )
- GL_LINE_LOOP (gl-poly) ;
+: (fill-rect-vertices) ( dim -- vertices )
+ {
+ [ drop 0 0 ]
+ [ first 0 ]
+ [ first2 ]
+ [ second 0 swap ]
+ } cleave 8 narray >c-float-array ;
+
+: fill-rect-vertices ( dim -- )
+ (fill-rect-vertices) gl-vertex-pointer ;
+
+: (gl-fill-rect) ( -- )
+ GL_QUADS 0 4 glDrawArrays ;
+
+: gl-fill-rect ( dim -- )
+ fill-rect-vertices (gl-fill-rect) ;
: circle-steps ( steps -- angles )
dup length v/n 2 pi * v*n ;
: circle-points ( loc dim steps -- points )
circle-steps unit-circle adjust-points scale-points ;
-: gl-circle ( loc dim steps -- )
- circle-points gl-poly ;
-
-: gl-fill-circle ( loc dim steps -- )
- circle-points gl-fill-poly ;
-
-: prepare-gradient ( direction dim -- v1 v2 )
- tuck v* [ v- ] keep ;
-
-: gl-gradient ( direction colors dim -- )
- GL_QUAD_STRIP [
- swap >r prepare-gradient r>
- [ length dup 1- v/n ] keep [
- >r >r 2dup r> r> set-color v*n
- dup gl-vertex v+ gl-vertex
- ] 2each 2drop
- ] do-state ;
+: circle-vertices ( loc dim steps -- vertices )
+ circle-points concat >c-float-array ;
: (gen-gl-object) ( quot -- id )
>r 1 0 <uint> r> keep *uint ; inline
+
: gen-texture ( -- id )
[ glGenTextures ] (gen-gl-object) ;
+
: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;
: (delete-gl-object) ( id quot -- )
>r 1 swap <uint> r> call ; inline
+
: delete-texture ( id -- )
[ glDeleteTextures ] (delete-gl-object) ;
+
: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
: gl-translate ( point -- ) first2 0.0 glTranslated ;
-<PRIVATE
-
-: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
-
-: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
-
-: bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
-
-: bottom-right 1 1 glTexCoord2i gl-vertex ; inline
+MEMO: (rect-texture-coords) ( -- seq )
+ { 0 0 1 0 1 1 0 1 } >c-float-array ;
-PRIVATE>
-
-: four-sides ( dim -- )
- dup top-left dup top-right dup bottom-right bottom-left ;
+: rect-texture-coords ( -- )
+ (rect-texture-coords) gl-texture-coord-pointer ;
: draw-sprite ( sprite -- )
- dup loc>> gl-translate
- GL_TEXTURE_2D over texture>> glBindTexture
- init-texture
- GL_QUADS [ dim2>> four-sides ] do-state
- GL_TEXTURE_2D 0 glBindTexture ;
-
-: rect-vertices ( lower-left upper-right -- )
- GL_QUADS [
- over first2 glVertex2d
- dup first pick second glVertex2d
- dup first2 glVertex2d
- swap first swap second glVertex2d
- ] do-state ;
+ GL_TEXTURE_COORD_ARRAY [
+ dup loc>> gl-translate
+ GL_TEXTURE_2D over texture>> glBindTexture
+ init-texture rect-texture-coords
+ dim2>> fill-rect-vertices
+ (gl-fill-rect)
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-enabled-client-state ;
: make-sprite-dlist ( sprite -- id )
GL_MODELVIEW [
: with-translation ( loc quot -- )
GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline
+: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
+ [ first2 [ >fixnum ] bi@ ] bi@ ;
+
: gl-set-clip ( loc dim -- )
fix-coordinates glScissor ;
USING: prettyprint.backend prettyprint.config
prettyprint.sections prettyprint.private help.markup help.syntax
-io kernel words definitions quotations strings ;
+io kernel words definitions quotations strings generic classes ;
IN: prettyprint
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
{ $subsection pprint-cell }
"Printing a definition (see " { $link "definitions" } "):"
{ $subsection see }
+"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
+{ $subsection see-methods }
"More prettyprinter usage:"
{ $subsection "prettyprint-numbers" }
{ $subsection "prettyprint-stacks" }
HELP: pprint
{ $values { "obj" object } }
-{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+ "Unparsing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link pprint-short } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
{ pprint pprint* with-pprint } related-words
HELP: .
{ $values { "obj" object } }
-{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+ "Printing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link short. } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
HELP: unparse
{ $values { "obj" object } { "str" "Factor source string" } }
-{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+ "Unparsing a large object can take a long time and consume a lot of memory. If you need to unparse large objects, use " { $link unparse-short } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
HELP: pprint-short
{ $values { "obj" object } }
{ $values { "defspec" "a definition specifier" } }
{ $contract "Prettyprints a definition." } ;
+HELP: see-methods
+{ $values { "word" "a " { $link generic } " or a " { $link class } } }
+{ $contract "Prettyprints the methods defined on a generic word or class." } ;
+
HELP: definer
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
{ $contract "Outputs the parsing words which delimit the definition." }
: mt-a HEX: 9908b0df ; inline
: calculate-y ( n seq -- y )
- [ nth 32 mask-bit ]
+ [ nth 31 mask-bit ]
[ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
: (mt-generate) ( n seq -- next-mt )
-USING: help.markup help.syntax words definitions ;
+USING: help.markup help.syntax words definitions prettyprint ;
IN: tools.crossref
ARTICLE: "tools.crossref" "Cross-referencing tools"
{ $subsection usage. }
{ $subsection apropos }
-{ $see-also "definitions" "words" } ;
+{ $see-also "definitions" "words" see see-methods } ;
ABOUT: "tools.crossref"
"{ $values" print
[ " " write ($values.) ]
[ [ nl " " write ($values.) ] unless-empty ] bi*
- " }" write nl
+ nl "}" print
] if
] when* ;
:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [
loc [
+ -0.5 0.5 0.0 glTranslated
string open-font string char-widths scan-sums [
[ open-font sprites ] 2dip draw-char
] 2each
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences
- strings quotations assocs combinators classes colors
- classes.tuple opengl math.vectors
- ui.commands ui.gadgets ui.gadgets.borders
- ui.gadgets.labels ui.gadgets.theme
- ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
- ui.render math.geometry.rect ;
+strings quotations assocs combinators classes colors
+classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
+ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
+ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ui.render math.geometry.rect locals alien.c-types ;
IN: ui.gadgets.buttons
} cond ;
M: button-paint draw-interior
- button-paint draw-interior ;
+ button-paint dup [ draw-interior ] [ 2drop ] if ;
M: button-paint draw-boundary
- button-paint draw-boundary ;
+ button-paint dup [ draw-boundary ] [ 2drop ] if ;
: align-left ( button -- button )
{ 0 1/2 } >>align ; inline
#! the mouse is held down.
repeat-button new-button bevel-button-theme ;
-TUPLE: checkmark-paint color ;
+TUPLE: checkmark-paint < caching-pen color last-vertices ;
-C: <checkmark-paint> checkmark-paint
+: <checkmark-paint> ( color -- paint )
+ checkmark-paint new swap >>color ;
+
+<PRIVATE
+
+: checkmark-points ( dim -- points )
+ {
+ [ { 0 0 } v* { 0 1 } v+ ]
+ [ { 1 1 } v* { 0 1 } v+ ]
+ [ { 0 1 } v* ]
+ [ { 1 0 } v* ]
+ } cleave 4array ;
+
+: checkmark-vertices ( dim -- vertices )
+ checkmark-points concat >c-float-array ;
+
+PRIVATE>
+
+M: checkmark-paint recompute-pen
+ swap dim>> checkmark-vertices >>last-vertices drop ;
M: checkmark-paint draw-interior
- color>> set-color
- origin get [
- rect-dim
- { 0 0 } over gl-line
- dup { 0 1 } v* swap { 1 0 } v* gl-line
- ] with-translation ;
+ [ compute-pen ]
+ [ color>> gl-color ]
+ [ last-vertices>> gl-vertex-pointer ] tri
+ GL_LINES 0 4 glDrawArrays ;
: checkmark-theme ( gadget -- gadget )
f
M: checkbox model-changed
swap value>> >>selected? relayout-1 ;
-TUPLE: radio-paint color ;
+TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
+
+: <radio-paint> ( color -- paint ) radio-paint new swap >>color ;
+
+<PRIVATE
+
+: circle-steps 8 ;
-C: <radio-paint> radio-paint
+PRIVATE>
+
+M: radio-paint recompute-pen
+ swap dim>>
+ [ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
+ [ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
+ drop ;
+
+<PRIVATE
+
+: (radio-paint) ( gadget paint -- )
+ [ compute-pen ] [ color>> gl-color ] bi ;
+
+PRIVATE>
M: radio-paint draw-interior
- color>> set-color
- origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
+ [ (radio-paint) ] [ interior-vertices>> gl-vertex-pointer ] bi
+ GL_POLYGON 0 circle-steps glDrawArrays ;
M: radio-paint draw-boundary
- color>> set-color
- origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
+ [ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
+ GL_LINE_LOOP 0 circle-steps glDrawArrays ;
-: radio-knob-theme ( gadget -- gadget )
- f
- f
- black <radio-paint>
- black <radio-paint>
- <button-paint> >>interior
- black <radio-paint> >>boundary ;
+:: radio-knob-theme ( gadget -- gadget )
+ [let | radio-paint [ black <radio-paint> ] |
+ gadget
+ f f radio-paint radio-paint <button-paint> >>interior
+ radio-paint >>boundary
+ { 16 16 } >>dim
+ ] ;
: <radio-knob> ( -- gadget )
- <gadget>
- radio-knob-theme
- { 16 16 } >>dim ;
+ <gadget> radio-knob-theme ;
TUPLE: radio-control < button value ;
: draw-caret ( -- )
editor get focused?>> [
editor get
- dup caret-color>> set-color
- dup caret-loc origin get v+
- swap caret-dim over v+
- [ { 0.5 -0.5 } v+ ] bi@ gl-line
+ [ caret-color>> gl-color ]
+ [
+ dup caret-loc origin get v+
+ swap caret-dim over v+
+ gl-line
+ ] bi
] when ;
: line-translation ( n -- loc )
: draw-lines ( -- )
\ first-visible-line get [
- editor get dup color>> set-color
+ editor get dup color>> gl-color
dup visible-lines
[ draw-line 1 translate-lines ] with each
] with-editor-translation ;
dup editor-mark* swap editor-caret* sort-pair ;
: (draw-selection) ( x1 x2 -- )
- 2dup = [ 2 + ] when
- 0.0 swap editor get line-height glRectd ;
+ over -
+ dup 0 = [ 2 + ] when
+ [ 0.0 2array ] [ editor get line-height 2array ] bi*
+ swap [ gl-fill-rect ] with-translation ;
: draw-selected-line ( start end n -- )
[ start/end-on-line ] keep tuck
- >r >r editor get offset>x r> r>
+ [ editor get offset>x ] 2dip
editor get offset>x
(draw-selection) ;
: draw-selection ( -- )
- editor get selection-color>> set-color
+ editor get selection-color>> gl-color
editor get selection-start/end
over first [
2dup [
] with each ;
M: grid-lines draw-boundary
- origin get [
- -0.5 -0.5 0.0 glTranslated
- color>> set-color [
- dup grid set
- dup rect-dim half-gap v- grid-dim set
- compute-grid
- { 0 1 } draw-grid-lines
- { 1 0 } draw-grid-lines
- ] with-scope
- ] with-translation ;
+ color>> gl-color [
+ dup grid set
+ dup rect-dim half-gap v- grid-dim set
+ compute-grid
+ { 0 1 } draw-grid-lines
+ { 1 0 } draw-grid-lines
+ ] with-scope ;
: title-theme ( gadget -- gadget )
{ 1 0 } >>orientation
- T{ gradient f {
+ {
T{ rgba f 0.65 0.65 1.0 1.0 }
T{ rgba f 0.65 0.45 1.0 1.0 }
- } } >>interior ;
+ } <gradient> >>interior ;
: <title-label> ( text -- label ) <label> title-theme ;
[ font>> open-font ] [ text>> ] bi text-dim ;
M: label draw-gadget*
- [ color>> set-color ]
+ [ color>> gl-color ]
[ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
M: label gadget-text* label-string % ;
M: list draw-gadget*
origin get [
- dup color>> set-color
- selected-rect [ rect-extent gl-fill-rect ] when*
+ dup color>> gl-color
+ selected-rect [
+ dup loc>> [
+ dim>> gl-fill-rect
+ ] with-translation
+ ] when*
] with-translation ;
M: list focusable-child* drop t ;
>r clip get over intersects? r> [ drop ] if ; inline
M: gadget draw-selection ( loc gadget -- )
- swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
+ swap offset-rect [
+ dup loc>> [
+ dim>> gl-fill-rect
+ ] with-translation
+ ] if-fits ;
M: node draw-selection ( loc node -- )
2dup value>> swap offset-rect [
M: pane draw-gadget*
dup gadget-selection? [
- dup selection-color>> set-color
+ dup selection-color>> gl-color
origin get over rect-loc v- swap selected-children
[ draw-selection ] with each
] [
: selection-color ( -- color ) light-purple ;
-: plain-gradient
- T{ gradient f {
+: plain-gradient ( -- gradient )
+ {
T{ gray f 0.94 1.0 }
T{ gray f 0.83 1.0 }
T{ gray f 0.83 1.0 }
T{ gray f 0.62 1.0 }
- } } ;
+ } <gradient> ;
-: rollover-gradient
- T{ gradient f {
+: rollover-gradient ( -- gradient )
+ {
T{ gray f 1.0 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.75 1.0 }
- } } ;
+ } <gradient> ;
-: pressed-gradient
- T{ gradient f {
+: pressed-gradient ( -- gradient )
+ {
T{ gray f 0.75 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 0.9 1.0 }
T{ gray f 1.0 1.0 }
- } } ;
+ } <gradient> ;
-: selected-gradient
- T{ gradient f {
+: selected-gradient ( -- gradient )
+ {
T{ gray f 0.65 1.0 }
T{ gray f 0.8 1.0 }
T{ gray f 0.8 1.0 }
T{ gray f 1.0 1.0 }
- } } ;
+ } <gradient> ;
-: lowered-gradient
- T{ gradient f {
+: lowered-gradient ( -- gradient )
+ {
T{ gray f 0.37 1.0 }
T{ gray f 0.43 1.0 }
T{ gray f 0.5 1.0 }
- } } ;
+ } <gradient> ;
: sans-serif-font { "sans-serif" plain 12 } ;
} ;
HELP: <polygon>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } }
+{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "polygon" polygon } }
{ $description "Creates a new instance of " { $link polygon } "." } ;
HELP: <polygon-gadget>
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays hashtables io kernel math namespaces opengl
-opengl.gl opengl.glu sequences strings io.styles vectors
-combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect ;
+USING: accessors alien alien.c-types arrays hashtables io kernel
+math namespaces opengl opengl.gl opengl.glu sequences strings
+io.styles vectors combinators math.vectors ui.gadgets colors
+math.order math.geometry.rect locals ;
IN: ui.render
SYMBOL: clip
: init-clip ( clip-rect rect -- )
GL_SCISSOR_TEST glEnable
[ rect-intersect ] keep
- rect-dim dup { 0 1 } v* viewport-translation set
+ dim>> dup { 0 1 } v* viewport-translation set
{ 0 0 } over gl-viewport
- 0 swap first2 0 gluOrtho2D
+ -0.5 swap first2 [ 0.5 - ] [ 0.5 + ] bi* 0.5 gluOrtho2D
clip set
do-clip ;
GL_SMOOTH glShadeModel
GL_BLEND glEnable
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+ GL_VERTEX_ARRAY glEnableClientState
init-matrices
init-clip
! white gl-clear is broken w.r.t window resizing
! Linux/PPC Radeon 9200
- white set-color
- clip get rect-extent gl-fill-rect ;
+ white gl-color
+ clip get dim>> gl-fill-rect ;
GENERIC: draw-gadget* ( gadget -- )
: (draw-gadget) ( gadget -- )
[
dup translate
- dup dup interior>> draw-interior
+ dup interior>> [
+ origin get [ dupd draw-interior ] with-translation
+ ] when*
dup draw-gadget*
dup visible-children [ draw-gadget ] each
- dup boundary>> draw-boundary
+ dup boundary>> [
+ origin get [ dupd draw-boundary ] with-translation
+ ] when*
+ drop
] with-scope ;
: >absolute ( rect -- rect )
[ [ (draw-gadget) ] with-clipping ]
} cond ;
-! Pen paint properties
-M: f draw-interior 2drop ;
-M: f draw-boundary 2drop ;
+! A pen that caches vertex arrays, etc
+TUPLE: caching-pen last-dim ;
+
+GENERIC: recompute-pen ( gadget pen -- )
+
+: compute-pen ( gadget pen -- )
+ 2dup [ dim>> ] [ last-dim>> ] bi* = [
+ 2drop
+ ] [
+ [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
+ ] if ;
! Solid fill/border
-TUPLE: solid color ;
+TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
-C: <solid> solid
+: <solid> ( color -- solid ) solid new swap >>color ;
+
+M: solid recompute-pen
+ swap dim>>
+ [ (fill-rect-vertices) >>interior-vertices ]
+ [ (rect-vertices) >>boundary-vertices ]
+ bi drop ;
+
+<PRIVATE
! Solid pen
-: (solid) ( gadget paint -- loc dim )
- color>> set-color rect-dim >r origin get dup r> v+ ;
+: (solid) ( gadget pen -- )
+ [ compute-pen ] [ color>> gl-color ] bi ;
+
+PRIVATE>
-M: solid draw-interior (solid) gl-fill-rect ;
+M: solid draw-interior
+ [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
+ (gl-fill-rect) ;
-M: solid draw-boundary (solid) gl-rect ;
+M: solid draw-boundary
+ [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
+ (gl-rect) ;
! Gradient pen
-TUPLE: gradient colors ;
+TUPLE: gradient < caching-pen colors last-vertices last-colors ;
-C: <gradient> gradient
+: <gradient> ( colors -- gradient ) gradient new swap >>colors ;
+
+<PRIVATE
+
+:: gradient-vertices ( direction dim colors -- seq )
+ direction dim v* dim over v- swap
+ colors length dup 1- v/n [ v*n ] with map
+ [ dup rot v+ 2array ] with map
+ concat concat >c-float-array ;
+
+: gradient-colors ( colors -- seq )
+ [ color>raw 4array dup 2array ] map concat concat >c-float-array ;
+
+M: gradient recompute-pen ( gadget gradient -- )
+ tuck
+ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
+ [ gradient-vertices >>last-vertices ]
+ [ gradient-colors >>last-colors ] bi
+ drop ;
+
+: draw-gradient ( colors -- )
+ GL_COLOR_ARRAY [
+ [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
+ ] do-enabled-client-state ;
+
+PRIVATE>
M: gradient draw-interior
- origin get [
- over orientation>>
- swap colors>>
- rot rect-dim
- gl-gradient
- ] with-translation ;
+ {
+ [ compute-pen ]
+ [ last-vertices>> gl-vertex-pointer ]
+ [ last-colors>> gl-color-pointer ]
+ [ colors>> draw-gradient ]
+ } cleave ;
! Polygon pen
-TUPLE: polygon color points ;
+TUPLE: polygon color vertex-array count ;
-C: <polygon> polygon
+: <polygon> ( color points -- polygon )
+ [ concat >c-float-array ] [ length ] bi polygon boa ;
-: draw-polygon ( polygon quot -- )
- origin get [
- >r dup color>> set-color points>> r> call
- ] with-translation ; inline
+: draw-polygon ( polygon mode -- )
+ swap
+ [ color>> gl-color ]
+ [ vertex-array>> gl-vertex-pointer ]
+ [ 0 swap count>> glDrawArrays ]
+ tri ;
M: polygon draw-boundary
- [ gl-poly ] draw-polygon drop ;
+ GL_LINE_LOOP draw-polygon drop ;
M: polygon draw-interior
- [ gl-fill-poly ] draw-polygon drop ;
+ dup count>> 2 > GL_POLYGON GL_LINES ?
+ draw-polygon drop ;
: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
listener>> input>> interactor-busy? ;
: listener-input ( string -- )
- get-workspace listener>> input>> set-editor-string ;
+ get-workspace listener>> input>>
+ [ set-editor-string ] [ request-focus ] bi ;
: (call-listener) ( quot listener -- )
input>> interactor-call ;
[ ] [ effective-group-name [ ] with-effective-group ] unit-test
[ ] [ effective-group-id [ ] with-effective-group ] unit-test
+
+[ ] [ [ ] with-group-cache ] unit-test
HELP: passwd
{ $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
-HELP: passwd-cache
-{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ;
+HELP: user-cache
+{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-user-cache } "." } ;
HELP: passwd>new-passwd
{ $values
{ "string/id" "a string or a uid" } { "quot" quotation } }
{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
-HELP: with-passwd-cache
+HELP: with-user-cache
{ $values
{ "quot" quotation } }
-{ $description "Iterates over the password file using library calls and creates a cache in the " { $link passwd-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
+{ $description "Iterates over the password file using library calls and creates a cache in the " { $link user-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
HELP: with-real-user
{ $values
[ ] [ effective-username [ ] with-effective-user ] unit-test
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
+
+[ ] [ [ ] with-user-cache ] unit-test
[ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
] with-pwent ;
-SYMBOL: passwd-cache
+SYMBOL: user-cache
-: with-passwd-cache ( quot -- )
+: with-user-cache ( quot -- )
all-users [ [ uid>> ] keep ] H{ } map>assoc
- passwd-cache swap with-variable ; inline
+ user-cache rot with-variable ; inline
GENERIC: user-passwd ( obj -- passwd )
M: integer user-passwd ( id -- passwd/f )
- passwd-cache get
+ user-cache get
[ at ] [ getpwuid passwd>new-passwd ] if* ;
M: string user-passwd ( string -- passwd/f )
*FreeBSD*) OS=freebsd;;
*OpenBSD*) OS=openbsd;;
*DragonFly*) OS=dragonflybsd;;
- SunOS) OS=solaris;;
+ SunOS) OS=solaris;;
esac
}
$ECHO "WORD: $WORD"
$ECHO "OS, ARCH, or WORD is empty. Please report this."
- echo $MAKE_TARGET
+ echo $MAKE_TARGET
exit 5
fi
}
check_ret cd
}
+check_makefile_exists() {
+ if [[ ! -e "Makefile" ]] ; then
+ echo ""
+ echo "***Makefile not found***"
+ echo "You are likely in the wrong directory."
+ echo "Run this script from your factor directory:"
+ echo " ./build-support/factor.sh"
+ exit 6
+ fi
+}
+
invoke_make() {
- $MAKE $MAKE_OPTS $*
- check_ret $MAKE
+ check_makefile_exists
+ $MAKE $MAKE_OPTS $*
+ check_ret $MAKE
}
make_clean() {
USING: help.markup help.syntax words classes classes.algebra
definitions kernel alien sequences math quotations
-generic.standard generic.math combinators ;
+generic.standard generic.math combinators prettyprint ;
IN: generic
ARTICLE: "method-order" "Method precedence"
"Low-level method constructor:"
{ $subsection <method> }
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
-{ $subsection method-spec } ;
+{ $subsection method-spec }
+{ $see-also see see-methods } ;
ARTICLE: "method-combination" "Custom method combination"
"Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:"
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
-accessors ;
+sequences.private accessors ;
IN: grouping
-TUPLE: abstract-groups { seq read-only } { n read-only } ;
+<PRIVATE
+
+TUPLE: chunking-seq { seq read-only } { n read-only } ;
: check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
GENERIC: group@ ( n groups -- from to seq )
-M: abstract-groups nth group@ subseq ;
+M: chunking-seq set-nth group@ <slice> 0 swap copy ;
-M: abstract-groups set-nth group@ <slice> 0 swap copy ;
+M: chunking-seq like drop { } like ;
-M: abstract-groups like drop { } like ;
+INSTANCE: chunking-seq sequence
-INSTANCE: abstract-groups sequence
+MIXIN: subseq-chunking
-TUPLE: groups < abstract-groups ;
+M: subseq-chunking nth group@ subseq ;
-: <groups> ( seq n -- groups )
- groups new-groups ; inline
+MIXIN: slice-chunking
+
+M: slice-chunking nth group@ <slice> ;
+
+M: slice-chunking nth-unsafe group@ slice boa ;
+
+TUPLE: abstract-groups < chunking-seq ;
-M: groups length
+M: abstract-groups length
[ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
-M: groups set-length
+M: abstract-groups set-length
[ n>> * ] [ seq>> ] bi set-length ;
-M: groups group@
+M: abstract-groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
-TUPLE: sliced-groups < groups ;
+TUPLE: abstract-clumps < chunking-seq ;
+
+M: abstract-clumps length
+ [ seq>> length ] [ n>> ] bi - 1+ ;
+
+M: abstract-clumps set-length
+ [ n>> + 1- ] [ seq>> ] bi set-length ;
+
+M: abstract-clumps group@
+ [ n>> over + ] [ seq>> ] bi ;
+
+PRIVATE>
+
+TUPLE: groups < abstract-groups ;
+
+: <groups> ( seq n -- groups )
+ groups new-groups ; inline
+
+INSTANCE: groups subseq-chunking
+
+TUPLE: sliced-groups < abstract-groups ;
: <sliced-groups> ( seq n -- groups )
sliced-groups new-groups ; inline
-M: sliced-groups nth group@ <slice> ;
+INSTANCE: sliced-groups slice-chunking
-TUPLE: clumps < abstract-groups ;
+TUPLE: clumps < abstract-clumps ;
: <clumps> ( seq n -- clumps )
clumps new-groups ; inline
-M: clumps length
- [ seq>> length ] [ n>> ] bi - 1+ ;
-
-M: clumps set-length
- [ n>> + 1- ] [ seq>> ] bi set-length ;
-
-M: clumps group@
- [ n>> over + ] [ seq>> ] bi ;
+INSTANCE: clumps subseq-chunking
-TUPLE: sliced-clumps < clumps ;
+TUPLE: sliced-clumps < abstract-clumps ;
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline
-M: sliced-clumps nth group@ <slice> ;
+INSTANCE: sliced-clumps slice-chunking
: group ( seq n -- array ) <groups> { } like ;
ARTICLE: "io.encodings" "I/O encodings"
"Bytes can't be understood in isolation as text. They must be interpreted under a certain encoding. Factor provides utilities for dealing with encoded text by declaring that a stream has a particular encoding, and utilities to encode and decode strings."
-{ $subsection "encodings-constructors" }
{ $subsection "encodings-descriptors" }
+{ $subsection "encodings-constructors" }
+{ $subsection "io.encodings.string" }
+"New types of encodings can be defined:"
{ $subsection "encodings-protocol" } ;
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
HELP: loop
{ $values
{ "pred" quotation } }
-{ $description "Calls the quotation repeatedly until the output is true." }
+ { $description "Calls the quotation repeatedly until it outputs " { $link f } "." }
{ $examples "Loop until we hit a zero:"
{ $unchecked-example "USING: kernel random math io ; "
" [ \"hi\" write bl 10 random zero? not ] loop"
HELP: with-scope
{ $values { "quot" quotation } }
-{ $description "Calls the quotation in a new namespace. Any variables set by the quotation are discarded when it returns." } ;
+{ $description "Calls the quotation in a new namespace. Any variables set by the quotation are discarded when it returns." }
+{ $examples
+ { $example "USING: math namespaces prettyprint ;" "IN: scratchpad" "SYMBOL: x" "0 x set" "[ x [ 5 + ] change x get . ] with-scope x get ." "5\n0" }
+} ;
HELP: with-variable
{ $values { "value" object } { "key" "a variable, by convention a symbol" } { "quot" quotation } }
HELP: unclip-slice
{ $values { "seq" sequence } { "rest-slice" slice } { "first" object } }
-{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
+{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." }
+{ $examples { $example "USING: math.order prettyprint sequences ;" "{ 3 -1 -10 5 7 } unclip-slice [ min ] reduce ." "-10" } } ;
HELP: unclip-last
{ $values { "seq" sequence } { "butlast" sequence } { "last" object } }
: draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
-: display ( -- ) black set-color bitmap> draw-bitmap ;
+: display ( -- ) black gl-color bitmap> draw-bitmap ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-USING: accessors alien.c-types arrays combinators destructors http.client
-io io.encodings.ascii io.files kernel math math.matrices math.parser
-math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib
-splitting vectors words ;
+USING: accessors alien.c-types arrays combinators destructors
+http.client io io.encodings.ascii io.files kernel math
+math.matrices math.parser math.vectors opengl
+opengl.capabilities opengl.gl opengl.demo-support sequences
+sequences.lib splitting vectors words ;
IN: bunny.model
: numbers ( str -- seq )
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
-opengl.framebuffers opengl.gl opengl.capabilities sequences
-ui.gadgets combinators accessors ;
+opengl.framebuffers opengl.gl opengl.demo-support
+opengl.capabilities sequences ui.gadgets combinators accessors ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
--- /dev/null
+Sampo Vuori
--- /dev/null
+! Cairo "Hello World" demo
+! Copyright (c) 2007 Sampo Vuori
+! License: http://factorcode.org/license.txt
+!
+! This example is an adaptation of the following cairo sample code:
+! http://cairographics.org/samples/text/
+
+
+USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
+ ui.gadgets opengl.gl accessors ;
+
+IN: cairo-demo
+
+
+: make-image-array ( -- array )
+ 384 256 4 * * <byte-array> ;
+
+: convert-array-to-surface ( array -- cairo_surface_t )
+ CAIRO_FORMAT_ARGB32 384 256 over 4 *
+ cairo_image_surface_create_for_data ;
+
+
+TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
+
+M: cairo-demo-gadget draw-gadget* ( gadget -- )
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+ image-array>> glDrawPixels ;
+
+: create-surface ( gadget -- cairo_surface_t )
+ make-image-array [ swap (>>image-array) ] keep
+ convert-array-to-surface ;
+
+: init-cairo ( gadget -- cairo_t )
+ create-surface cairo_create ;
+
+M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ;
+
+: draw-hello-world ( gadget -- )
+ cairo-t>>
+ dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
+ dup 90.0 cairo_set_font_size
+ dup 10.0 135.0 cairo_move_to
+ dup "Hello" cairo_show_text
+ dup 70.0 165.0 cairo_move_to
+ dup "World" cairo_text_path
+ dup 0.5 0.5 1 cairo_set_source_rgb
+ dup cairo_fill_preserve
+ dup 0 0 0 cairo_set_source_rgb
+ dup 2.56 cairo_set_line_width
+ dup cairo_stroke
+ dup 1 0.2 0.2 0.6 cairo_set_source_rgba
+ dup 10.0 135.0 5.12 0 pi 2 * cairo_arc
+ dup cairo_close_path
+ dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
+ cairo_fill ;
+
+M: cairo-demo-gadget graft* ( gadget -- )
+ dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
+
+M: cairo-demo-gadget ungraft* ( gadget -- )
+ cairo-t>> cairo_destroy ;
+
+: <cairo-demo-gadget> ( -- gadget )
+ cairo-demo-gadget new-gadget ;
+
+: run ( -- )
+ [
+ <cairo-demo-gadget> "Hello World from Factor!" open-window
+ ] with-ui ;
+
+MAIN: run
--- /dev/null
+Sampo Vuori
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cairo.ffi kernel accessors sequences
+namespaces fry continuations destructors ;
+IN: cairo
+
+TUPLE: cairo-t alien ;
+C: <cairo-t> cairo-t
+M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
+
+TUPLE: cairo-surface-t alien ;
+C: <cairo-surface-t> cairo-surface-t
+M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+
+: check-cairo ( cairo_status_t -- )
+ dup CAIRO_STATUS_SUCCESS = [ drop ]
+ [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
+
+SYMBOL: cairo
+: cr ( -- cairo ) cairo get ;
+
+: (with-cairo) ( cairo-t quot -- )
+ >r alien>> cairo r> [ cr cairo_status check-cairo ]
+ compose with-variable ; inline
+
+: with-cairo ( cairo quot -- )
+ >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
+
+: (with-surface) ( cairo-surface-t quot -- )
+ >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
+
+: with-surface ( cairo_surface quot -- )
+ >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
+
+: with-cairo-from-surface ( cairo_surface quot -- )
+ '[ cairo_create _ with-cairo ] with-surface ; inline
--- /dev/null
+! Copyright (c) 2007 Sampo Vuori
+! Copyright (c) 2008 Matthew Willis
+!
+! Adapted from cairo.h, version 1.5.14
+! License: http://factorcode.org/license.txt
+
+USING: system combinators alien alien.syntax kernel
+alien.c-types accessors sequences arrays ui.gadgets ;
+
+IN: cairo.ffi
+<< "cairo" {
+ { [ os winnt? ] [ "libcairo-2.dll" ] }
+ { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+ { [ os unix? ] [ "libcairo.so.2" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: cairo
+
+FUNCTION: int cairo_version ( ) ;
+FUNCTION: char* cairo_version_string ( ) ;
+
+TYPEDEF: int cairo_bool_t
+
+! I am leaving these and other void* types as opaque structures
+TYPEDEF: void* cairo_t
+TYPEDEF: void* cairo_surface_t
+
+C-STRUCT: cairo_matrix_t
+ { "double" "xx" }
+ { "double" "yx" }
+ { "double" "xy" }
+ { "double" "yy" }
+ { "double" "x0" }
+ { "double" "y0" } ;
+
+TYPEDEF: void* cairo_pattern_t
+
+TYPEDEF: void* cairo_destroy_func_t
+: cairo-destroy-func ( quot -- callback )
+ >r "void" { "void*" } "cdecl" r> alien-callback ; inline
+
+! See cairo.h for details
+C-STRUCT: cairo_user_data_key_t
+ { "int" "unused" } ;
+
+TYPEDEF: int cairo_status_t
+C-ENUM:
+ CAIRO_STATUS_SUCCESS
+ CAIRO_STATUS_NO_MEMORY
+ CAIRO_STATUS_INVALID_RESTORE
+ CAIRO_STATUS_INVALID_POP_GROUP
+ CAIRO_STATUS_NO_CURRENT_POINT
+ CAIRO_STATUS_INVALID_MATRIX
+ CAIRO_STATUS_INVALID_STATUS
+ CAIRO_STATUS_NULL_POINTER
+ CAIRO_STATUS_INVALID_STRING
+ CAIRO_STATUS_INVALID_PATH_DATA
+ CAIRO_STATUS_READ_ERROR
+ CAIRO_STATUS_WRITE_ERROR
+ CAIRO_STATUS_SURFACE_FINISHED
+ CAIRO_STATUS_SURFACE_TYPE_MISMATCH
+ CAIRO_STATUS_PATTERN_TYPE_MISMATCH
+ CAIRO_STATUS_INVALID_CONTENT
+ CAIRO_STATUS_INVALID_FORMAT
+ CAIRO_STATUS_INVALID_VISUAL
+ CAIRO_STATUS_FILE_NOT_FOUND
+ CAIRO_STATUS_INVALID_DASH
+ CAIRO_STATUS_INVALID_DSC_COMMENT
+ CAIRO_STATUS_INVALID_INDEX
+ CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
+ CAIRO_STATUS_TEMP_FILE_ERROR
+ CAIRO_STATUS_INVALID_STRIDE ;
+
+TYPEDEF: int cairo_content_t
+: CAIRO_CONTENT_COLOR HEX: 1000 ;
+: CAIRO_CONTENT_ALPHA HEX: 2000 ;
+: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
+
+TYPEDEF: void* cairo_write_func_t
+: cairo-write-func ( quot -- callback )
+ >r "cairo_status_t" { "void*" "uchar*" "int" }
+ "cdecl" r> alien-callback ; inline
+
+TYPEDEF: void* cairo_read_func_t
+: cairo-read-func ( quot -- callback )
+ >r "cairo_status_t" { "void*" "uchar*" "int" }
+ "cdecl" r> alien-callback ; inline
+
+! Functions for manipulating state objects
+FUNCTION: cairo_t*
+cairo_create ( cairo_surface_t* target ) ;
+
+FUNCTION: cairo_t*
+cairo_reference ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_destroy ( cairo_t* cr ) ;
+
+FUNCTION: uint
+cairo_get_reference_count ( cairo_t* cr ) ;
+
+FUNCTION: void*
+cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_save ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_restore ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pop_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_pop_group_to_source ( cairo_t* cr ) ;
+
+! Modify state
+TYPEDEF: int cairo_operator_t
+C-ENUM:
+ CAIRO_OPERATOR_CLEAR
+
+ CAIRO_OPERATOR_SOURCE
+ CAIRO_OPERATOR_OVER
+ CAIRO_OPERATOR_IN
+ CAIRO_OPERATOR_OUT
+ CAIRO_OPERATOR_ATOP
+
+ CAIRO_OPERATOR_DEST
+ CAIRO_OPERATOR_DEST_OVER
+ CAIRO_OPERATOR_DEST_IN
+ CAIRO_OPERATOR_DEST_OUT
+ CAIRO_OPERATOR_DEST_ATOP
+
+ CAIRO_OPERATOR_XOR
+ CAIRO_OPERATOR_ADD
+ CAIRO_OPERATOR_SATURATE ;
+
+FUNCTION: void
+cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
+
+FUNCTION: void
+cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
+
+FUNCTION: void
+cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
+
+FUNCTION: void
+cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
+
+TYPEDEF: int cairo_antialias_t
+C-ENUM:
+ CAIRO_ANTIALIAS_DEFAULT
+ CAIRO_ANTIALIAS_NONE
+ CAIRO_ANTIALIAS_GRAY
+ CAIRO_ANTIALIAS_SUBPIXEL ;
+
+FUNCTION: void
+cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
+
+TYPEDEF: int cairo_fill_rule_t
+C-ENUM:
+ CAIRO_FILL_RULE_WINDING
+ CAIRO_FILL_RULE_EVEN_ODD ;
+
+FUNCTION: void
+cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
+
+FUNCTION: void
+cairo_set_line_width ( cairo_t* cr, double width ) ;
+
+TYPEDEF: int cairo_line_cap_t
+C-ENUM:
+ CAIRO_LINE_CAP_BUTT
+ CAIRO_LINE_CAP_ROUND
+ CAIRO_LINE_CAP_SQUARE ;
+
+FUNCTION: void
+cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
+
+TYPEDEF: int cairo_line_join_t
+C-ENUM:
+ CAIRO_LINE_JOIN_MITER
+ CAIRO_LINE_JOIN_ROUND
+ CAIRO_LINE_JOIN_BEVEL ;
+
+FUNCTION: void
+cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
+
+FUNCTION: void
+cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
+
+FUNCTION: void
+cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
+
+FUNCTION: void
+cairo_translate ( cairo_t* cr, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_scale ( cairo_t* cr, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_rotate ( cairo_t* cr, double angle ) ;
+
+FUNCTION: void
+cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_identity_matrix ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+! Path creation functions
+FUNCTION: void
+cairo_new_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_move_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_new_sub_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_line_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
+
+FUNCTION: void
+cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
+
+FUNCTION: void
+cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+FUNCTION: void
+cairo_close_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Painting functions
+FUNCTION: void
+cairo_paint ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
+
+FUNCTION: void
+cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
+
+FUNCTION: void
+cairo_stroke ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_stroke_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_copy_page ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_page ( cairo_t* cr ) ;
+
+! Insideness testing
+FUNCTION: cairo_bool_t
+cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: cairo_bool_t
+cairo_in_fill ( cairo_t* cr, double x, double y ) ;
+
+! Rectangular extents
+FUNCTION: void
+cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+FUNCTION: void
+cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Clipping
+FUNCTION: void
+cairo_reset_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+C-STRUCT: cairo_rectangle_t
+ { "double" "x" }
+ { "double" "y" }
+ { "double" "width" }
+ { "double" "height" } ;
+
+C-STRUCT: cairo_rectangle_list_t
+ { "cairo_status_t" "status" }
+ { "cairo_rectangle_t*" "rectangles" }
+ { "int" "num_rectangles" } ;
+
+FUNCTION: cairo_rectangle_list_t*
+cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
+
+! Font/Text functions
+
+TYPEDEF: void* cairo_scaled_font_t
+
+TYPEDEF: void* cairo_font_face_t
+
+C-STRUCT: cairo_glyph_t
+ { "ulong" "index" }
+ { "double" "x" }
+ { "double" "y" } ;
+
+C-STRUCT: cairo_text_extents_t
+ { "double" "x_bearing" }
+ { "double" "y_bearing" }
+ { "double" "width" }
+ { "double" "height" }
+ { "double" "x_advance" }
+ { "double" "y_advance" } ;
+
+C-STRUCT: cairo_font_extents_t
+ { "double" "ascent" }
+ { "double" "descent" }
+ { "double" "height" }
+ { "double" "max_x_advance" }
+ { "double" "max_y_advance" } ;
+
+TYPEDEF: int cairo_font_slant_t
+C-ENUM:
+ CAIRO_FONT_SLANT_NORMAL
+ CAIRO_FONT_SLANT_ITALIC
+ CAIRO_FONT_SLANT_OBLIQUE ;
+
+TYPEDEF: int cairo_font_weight_t
+C-ENUM:
+ CAIRO_FONT_WEIGHT_NORMAL
+ CAIRO_FONT_WEIGHT_BOLD ;
+
+TYPEDEF: int cairo_subpixel_order_t
+C-ENUM:
+ CAIRO_SUBPIXEL_ORDER_DEFAULT
+ CAIRO_SUBPIXEL_ORDER_RGB
+ CAIRO_SUBPIXEL_ORDER_BGR
+ CAIRO_SUBPIXEL_ORDER_VRGB
+ CAIRO_SUBPIXEL_ORDER_VBGR ;
+
+TYPEDEF: int cairo_hint_style_t
+C-ENUM:
+ CAIRO_HINT_STYLE_DEFAULT
+ CAIRO_HINT_STYLE_NONE
+ CAIRO_HINT_STYLE_SLIGHT
+ CAIRO_HINT_STYLE_MEDIUM
+ CAIRO_HINT_STYLE_FULL ;
+
+TYPEDEF: int cairo_hint_metrics_t
+C-ENUM:
+ CAIRO_HINT_METRICS_DEFAULT
+ CAIRO_HINT_METRICS_OFF
+ CAIRO_HINT_METRICS_ON ;
+
+TYPEDEF: void* cairo_font_options_t
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_create ( ) ;
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_copy ( cairo_font_options_t* original ) ;
+
+FUNCTION: void
+cairo_font_options_destroy ( cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_options_status ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: cairo_bool_t
+cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: ulong
+cairo_font_options_hash ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
+
+FUNCTION: cairo_subpixel_order_t
+cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
+
+FUNCTION: cairo_hint_style_t
+cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
+
+FUNCTION: cairo_hint_metrics_t
+cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
+
+! This interface is for dealing with text as text, not caring about the
+! font object inside the the cairo_t.
+
+FUNCTION: void
+cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
+
+FUNCTION: void
+cairo_set_font_size ( cairo_t* cr, double size ) ;
+
+FUNCTION: void
+cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_get_font_face ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_get_scaled_font ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_text ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_path ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
+
+! Generic identifier for a font style
+
+FUNCTION: cairo_font_face_t*
+cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void
+cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: uint
+cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_status ( cairo_font_face_t* font_face ) ;
+
+TYPEDEF: int cairo_font_type_t
+C-ENUM:
+ CAIRO_FONT_TYPE_TOY
+ CAIRO_FONT_TYPE_FT
+ CAIRO_FONT_TYPE_WIN32
+ CAIRO_FONT_TYPE_QUARTZ ;
+
+FUNCTION: cairo_font_type_t
+cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void*
+cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+! Portable interface to general font features.
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: uint
+cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_font_type_t
+cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void*
+cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
+
+! Query functions
+
+FUNCTION: cairo_operator_t
+cairo_get_operator ( cairo_t* cr ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_get_source ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_tolerance ( cairo_t* cr ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_get_antialias ( cairo_t* cr ) ;
+
+FUNCTION: cairo_bool_t
+cairo_has_current_point ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: cairo_fill_rule_t
+cairo_get_fill_rule ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_line_width ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_cap_t
+cairo_get_line_cap ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_join_t
+cairo_get_line_join ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_miter_limit ( cairo_t* cr ) ;
+
+FUNCTION: int
+cairo_get_dash_count ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
+
+FUNCTION: void
+cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_target ( cairo_t* cr ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_group_target ( cairo_t* cr ) ;
+
+TYPEDEF: int cairo_path_data_type_t
+C-ENUM:
+ CAIRO_PATH_MOVE_TO
+ CAIRO_PATH_LINE_TO
+ CAIRO_PATH_CURVE_TO
+ CAIRO_PATH_CLOSE_PATH ;
+
+! NEED TO DO UNION HERE
+C-STRUCT: cairo_path_data_t-point
+ { "double" "x" }
+ { "double" "y" } ;
+
+C-STRUCT: cairo_path_data_t-header
+ { "cairo_path_data_type_t" "type" }
+ { "int" "length" } ;
+
+C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
+
+C-STRUCT: cairo_path_t
+ { "cairo_status_t" "status" }
+ { "cairo_path_data_t*" "data" }
+ { "int" "num_data" } ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path ( cairo_t* cr ) ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path_flat ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
+
+FUNCTION: void
+cairo_path_destroy ( cairo_path_t* path ) ;
+
+! Error status queries
+
+FUNCTION: cairo_status_t
+cairo_status ( cairo_t* cr ) ;
+
+FUNCTION: char*
+cairo_status_to_string ( cairo_status_t status ) ;
+
+! Surface manipulation
+
+FUNCTION: cairo_surface_t*
+cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_surface_reference ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_finish ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_destroy ( cairo_surface_t* surface ) ;
+
+FUNCTION: uint
+cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_status ( cairo_surface_t* surface ) ;
+
+TYPEDEF: int cairo_surface_type_t
+C-ENUM:
+ CAIRO_SURFACE_TYPE_IMAGE
+ CAIRO_SURFACE_TYPE_PDF
+ CAIRO_SURFACE_TYPE_PS
+ CAIRO_SURFACE_TYPE_XLIB
+ CAIRO_SURFACE_TYPE_XCB
+ CAIRO_SURFACE_TYPE_GLITZ
+ CAIRO_SURFACE_TYPE_QUARTZ
+ CAIRO_SURFACE_TYPE_WIN32
+ CAIRO_SURFACE_TYPE_BEOS
+ CAIRO_SURFACE_TYPE_DIRECTFB
+ CAIRO_SURFACE_TYPE_SVG
+ CAIRO_SURFACE_TYPE_OS2
+ CAIRO_SURFACE_TYPE_WIN32_PRINTING
+ CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
+
+FUNCTION: cairo_surface_type_t
+cairo_surface_get_type ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_content_t
+cairo_surface_get_content ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
+
+FUNCTION: void*
+cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_surface_flush ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
+
+FUNCTION: void
+cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
+
+FUNCTION: void
+cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
+
+FUNCTION: void
+cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
+
+FUNCTION: void
+cairo_surface_copy_page ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_show_page ( cairo_surface_t* surface ) ;
+
+! Image-surface functions
+
+TYPEDEF: int cairo_format_t
+C-ENUM:
+ CAIRO_FORMAT_ARGB32
+ CAIRO_FORMAT_RGB24
+ CAIRO_FORMAT_A8
+ CAIRO_FORMAT_A1
+ CAIRO_FORMAT_RGB16_565 ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
+
+FUNCTION: int
+cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
+
+FUNCTION: uchar*
+cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_format_t
+cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png ( char* filename ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
+
+! Pattern creation functions
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgb ( double red, double green, double blue ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: uint
+cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_status ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void*
+cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+TYPEDEF: int cairo_pattern_type_t
+C-ENUM:
+ CAIRO_PATTERN_TYPE_SOLID
+ CAIRO_PATTERN_TYPE_SURFACE
+ CAIRO_PATTERN_TYPE_LINEAR
+ CAIRO_PATTERN_TYPE_RADIA ;
+
+FUNCTION: cairo_pattern_type_t
+cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+TYPEDEF: int cairo_extend_t
+C-ENUM:
+ CAIRO_EXTEND_NONE
+ CAIRO_EXTEND_REPEAT
+ CAIRO_EXTEND_REFLECT
+ CAIRO_EXTEND_PAD ;
+
+FUNCTION: void
+cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
+
+FUNCTION: cairo_extend_t
+cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
+
+TYPEDEF: int cairo_filter_t
+C-ENUM:
+ CAIRO_FILTER_FAST
+ CAIRO_FILTER_GOOD
+ CAIRO_FILTER_BEST
+ CAIRO_FILTER_NEAREST
+ CAIRO_FILTER_BILINEAR
+ CAIRO_FILTER_GAUSSIAN ;
+
+FUNCTION: void
+cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
+
+FUNCTION: cairo_filter_t
+cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
+
+! Matrix functions
+
+FUNCTION: void
+cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
+
+FUNCTION: void
+cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: void
+cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: cairo_status_t
+cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
+
+FUNCTION: void
+cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
+
+! Functions to be used while debugging (not intended for use in production code)
+FUNCTION: void
+cairo_debug_reset_static_data ( ) ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math opengl.gadgets kernel
+byte-arrays cairo.ffi cairo io.backend
+ui.gadgets accessors opengl.gl
+arrays fry classes ;
+
+IN: cairo.gadgets
+
+: width>stride ( width -- stride ) 4 * ;
+
+: copy-cairo ( dim quot -- byte-array )
+ >r first2 over width>stride
+ [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_create_for_data ] 3bi
+ r> with-cairo-from-surface ; inline
+
+TUPLE: cairo-gadget < texture-gadget ;
+
+: <cairo-gadget> ( dim -- gadget )
+ cairo-gadget new-gadget
+ swap >>dim ;
+
+M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ;
+
+: render-cairo ( dim quot -- bytes format )
+ >r 2^-bounds r> copy-cairo GL_BGRA ; inline
+
+GENERIC: render-cairo* ( gadget -- )
+
+M: cairo-gadget render*
+ [ dim>> dup ] [ '[ _ render-cairo* ] ] bi
+ render-cairo render-bytes* ;
+
+! maybe also texture>png
+! : cairo>png ( gadget path -- )
+! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
+! [ height>> ] tri over width>stride
+! cairo_image_surface_create_for_data
+! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
+
+: copy-surface ( surface -- )
+ cr swap 0 0 cairo_set_source_surface
+ cr cairo_paint ;
+
+TUPLE: png-gadget < texture-gadget path ;
+: <png> ( path -- gadget )
+ png-gadget new-gadget
+ swap >>path ;
+
+M: png-gadget render*
+ path>> normalize-path cairo_image_surface_create_from_png
+ [ cairo_image_surface_get_width ]
+ [ cairo_image_surface_get_height 2array dup 2^-bounds ]
+ [ [ copy-surface ] curry copy-cairo ] tri
+ GL_BGRA render-bytes* ;
+
+M: png-gadget cache-key* path>> ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis
+! See http://factorcode.org/license.txt for BSD license.
+!
+! these samples are a subset of the samples on
+! http://cairographics.org/samples/
+USING: cairo cairo.ffi locals math.constants math
+io.backend kernel alien.c-types libc namespaces
+cairo.gadgets ui.gadgets accessors ;
+
+IN: cairo.samples
+
+TUPLE: arc-gadget < cairo-gadget ;
+M:: arc-gadget render-cairo* ( gadget -- )
+ [let | xc [ 128.0 ]
+ yc [ 128.0 ]
+ radius [ 100.0 ]
+ angle1 [ pi 1/4 * ]
+ angle2 [ pi ] |
+ cr 10.0 cairo_set_line_width
+ cr xc yc radius angle1 angle2 cairo_arc
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6.0 cairo_set_line_width
+
+ cr xc yc 10.0 0 2 pi * cairo_arc
+ cr cairo_fill
+
+ cr xc yc radius angle1 angle1 cairo_arc
+ cr xc yc cairo_line_to
+ cr xc yc radius angle2 angle2 cairo_arc
+ cr xc yc cairo_line_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: clip-gadget < cairo-gadget ;
+M: clip-gadget render-cairo* ( gadget -- )
+ drop
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 0 0 256 256 cairo_rectangle
+ cr cairo_fill
+ cr 0 1 0 cairo_set_source_rgb
+ cr 0 0 cairo_move_to
+ cr 256 256 cairo_line_to
+ cr 256 0 cairo_move_to
+ cr 0 256 cairo_line_to
+ cr 10 cairo_set_line_width
+ cr cairo_stroke ;
+
+TUPLE: clip-image-gadget < cairo-gadget ;
+M:: clip-image-gadget render-cairo* ( gadget -- )
+ [let* | png [ "resource:misc/icons/Factor_128x128.png"
+ normalize-path cairo_image_surface_create_from_png ]
+ w [ png cairo_image_surface_get_width ]
+ h [ png cairo_image_surface_get_height ] |
+ cr 128 128 76.8 0 2 pi * cairo_arc
+ cr cairo_clip
+ cr cairo_new_path
+
+ cr 192.0 w / 192.0 h / cairo_scale
+ cr png 32 32 cairo_set_source_surface
+ cr cairo_paint
+ png cairo_surface_destroy
+ ] ;
+
+TUPLE: dash-gadget < cairo-gadget ;
+M:: dash-gadget render-cairo* ( gadget -- )
+ [let | dashes [ { 50 10 10 10 } >c-double-array ]
+ ndash [ 4 ] |
+ cr dashes ndash -50 cairo_set_dash
+ cr 10 cairo_set_line_width
+ cr 128.0 25.6 cairo_move_to
+ cr 230.4 230.4 cairo_line_to
+ cr -102.4 0 cairo_rel_line_to
+ cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
+ cr cairo_stroke
+ ] ;
+
+TUPLE: gradient-gadget < cairo-gadget ;
+M:: gradient-gadget render-cairo* ( gadget -- )
+ [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
+ radial [ 115.2 102.4 25.6 102.4 102.4 128.0
+ cairo_pattern_create_radial ] |
+ pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ cr 0 0 256 256 cairo_rectangle
+ cr pat cairo_set_source
+ cr cairo_fill
+ pat cairo_pattern_destroy
+
+ radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
+ radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
+ cr radial cairo_set_source
+ cr 128.0 128.0 76.8 0 2 pi * cairo_arc
+ cr cairo_fill
+ radial cairo_pattern_destroy
+ ] ;
+
+TUPLE: text-gadget < cairo-gadget ;
+M: text-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ cr 10 135 cairo_move_to
+ cr "Hello" cairo_show_text
+
+ cr 70 165 cairo_move_to
+ cr "factor" cairo_text_path
+ cr 0.5 0.5 1 cairo_set_source_rgb
+ cr cairo_fill_preserve
+ cr 0 0 0 cairo_set_source_rgb
+ cr 2.56 cairo_set_line_width
+ cr cairo_stroke
+
+ ! draw helping lines
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 10 135 5.12 0 2 pi * cairo_arc
+ cr cairo_close_path
+ cr 70 165 5.12 0 2 pi * cairo_arc
+ cr cairo_fill ;
+
+TUPLE: utf8-gadget < cairo-gadget ;
+M: utf8-gadget render-cairo* ( gadget -- )
+ drop
+ cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ cairo_select_font_face
+ cr 50 cairo_set_font_size
+ "cairo_text_extents_t" malloc-object
+ cr "日本語" pick cairo_text_extents
+ cr over
+ [ cairo_text_extents_t-width 2 / ]
+ [ cairo_text_extents_t-x_bearing ] bi +
+ 128 swap - pick
+ [ cairo_text_extents_t-height 2 / ]
+ [ cairo_text_extents_t-y_bearing ] bi +
+ 128 swap - cairo_move_to
+ free
+ cr "日本語" cairo_show_text
+
+ cr 1 0.2 0.2 0.6 cairo_set_source_rgba
+ cr 6 cairo_set_line_width
+ cr 128 0 cairo_move_to
+ cr 0 256 cairo_rel_line_to
+ cr 0 128 cairo_move_to
+ cr 256 0 cairo_rel_line_to
+ cr cairo_stroke ;
+
+ USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
+ : samples ( -- )
+ {
+ arc-gadget clip-gadget clip-image-gadget dash-gadget
+ gradient-gadget text-gadget utf8-gadget
+ }
+ [ new-gadget { 256 256 } >>dim gadget. ] each ;
+
+ MAIN: samples
--- /dev/null
+Cairo graphics library binding
SELF-SLOTS: hsva
-: clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ;
+: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: push-color ( -- ) self> color-stack> push self> clone >self ;
-: pop-color ( -- ) color-stack> pop dup >self set-color ;
+: pop-color ( -- ) color-stack> pop dup >self gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: circle ( -- )
- self> set-color
+ self> gl-color
gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
: triangle ( -- )
- self> set-color
+ self> gl-color
GL_POLYGON glBegin
0 0.577 glVertex2d
0.5 -0.289 glVertex2d
glEnd ;
: square ( -- )
- self> set-color
+ self> gl-color
GL_POLYGON glBegin
-0.5 0.5 glVertex2d
0.5 0.5 glVertex2d
set-initial-color
- self> set-color
+ self> gl-color
start-shape> call
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
- 2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
+ 2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
: ftp-login ( ftp-client -- )
read-response 220 ftp-assert
dupd '[
_ [ ftp-login ] [ @ ] bi
ftp-quit drop
- ] >r ftp-connect r> with-stream ; inline
+ ] [ ftp-connect ] dip with-stream ; inline
M: ftp-client ftp-download ( path ftp-client -- )
[
[ drop parent-directory ftp-cwd drop ]
- [ >r file-name r> ftp-get drop ] 2bi
+ [ [ file-name ] dip ftp-get drop ] 2bi
] with-ftp-client ;
M: string ftp-download ( path string -- )
: ftp-ipv4 1 ; inline
: ftp-ipv6 2 ; inline
-
: ch>type ( ch -- type )
{
{ CHAR: d [ +directory+ ] }
} case ;
: file-info>string ( file-info name -- string )
- >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
- [ size>> number>string 15 CHAR: \s pad-left ] bi r>
- 3array " " join ;
+ [
+ [
+ [ type>> type>ch 1string ]
+ [ drop "rwx------" append ] bi
+ ]
+ [ size>> number>string 15 CHAR: \s pad-left ] bi
+ ] dip 3array " " join ;
: directory-list ( -- seq )
"" directory-files
namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays ;
+continuations math concurrency.promises byte-arrays sequences.lib
+hexdump ;
IN: ftp.server
SYMBOL: client
TUPLE: ftp-get path ;
: <ftp-get> ( path -- obj )
- ftp-get new swap >>path ;
+ ftp-get new
+ swap >>path ;
TUPLE: ftp-put path ;
: <ftp-put> ( path -- obj )
- ftp-put new swap >>path ;
+ ftp-put new
+ swap >>path ;
TUPLE: ftp-list ;
: handle-USER ( ftp-command -- )
[
- tokenized>> second client get swap >>user drop
+ tokenized>> second client get (>>user)
331 "Please specify the password." server-response
] [
2drop "bad USER" ftp-error
: handle-PASS ( ftp-command -- )
[
- tokenized>> second client get swap >>password drop
+ tokenized>> second client get (>>password)
230 "Login successful" server-response
] [
2drop "PASS error" ftp-error
: handle-PWD ( obj -- )
drop
- 257 current-directory get "\"" swap "\"" 3append server-response ;
+ 257 current-directory get "\"" "\"" surround server-response ;
: handle-SYST ( obj -- )
drop
215 "UNIX Type: L8" server-response ;
: if-command-promise ( quot -- )
- >r client get command-promise>> r>
+ [ client get command-promise>> ] dip
[ "Establish an active or passive connection first" ftp-error ] if* ;
: handle-STOR ( obj -- )
[
tokenized>> second
- [ >r <ftp-put> r> fulfill ] if-command-promise
+ [ [ <ftp-put> ] dip fulfill ] if-command-promise
] [
2drop
] recover ;
rot
[ file-name ] [
" " swap file-info size>> number>string
- "(" " bytes)." swapd 3append append
+ "(" " bytes)." surround append
] bi 3append server-response ;
: transfer-incoming-file ( path -- )
: handle-LIST ( obj -- )
drop
- [ >r <ftp-list> r> fulfill ] if-command-promise ;
+ [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
: handle-SIZE ( obj -- )
[
expect-connection
[
"Entering Passive Mode (127,0,0,1," %
- port>bytes [ number>string ] bi@ "," swap 3append %
+ port>bytes [ number>string ] bi@ "," splice %
")" %
] "" make 227 swap server-response ;
set-current-directory
250 "Directory successully changed." server-response
] [
- not-a-directory throw
+ not-a-directory
] if
] [
2drop
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences float-arrays ;
+USING: accessors alien.c-types jamshred.game jamshred.oint
+jamshred.player jamshred.tunnel kernel math math.constants
+math.functions math.vectors opengl opengl.gl opengl.glu
+opengl.demo-support sequences float-arrays ;
IN: jamshred.gl
: min-vertices 6 ; inline
dup [ / pi 2 * * ] curry map ;
: draw-segment-vertex ( segment theta -- )
- over color>> set-color segment-vertex-and-normal
+ over color>> gl-color segment-vertex-and-normal
gl-normal gl-vertex ;
: draw-vertex-pair ( theta next-segment segment -- )
-! Copyright (c) 2007 Samuel Tardieu
+! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions sequences fry ;
IN: math.algebra
: chinese-remainder ( aseq nseq -- x )
- dup product
- [
+ dup product [
'[ _ over / [ swap gcd drop ] keep * * ] 2map sum
] keep rem ; foldable
--- /dev/null
+USING: help.markup help.syntax math ;
+IN: math.analysis
+
+HELP: gamma
+{ $values { "x" number } { "y" number } }
+{ $description "Gamma function; an extension of factorial to real and complex numbers." } ;
+
+HELP: gammaln
+{ $values { "x" number } { "gamma[x]" number } }
+{ $description "An alternative to " { $link gamma } " when gamma(x)'s range varies too widely." } ;
+
+HELP: nth-root
+{ $values { "n" integer } { "x" number } { "y" number } }
+{ $description "Calculates the nth root of a number, such that " { $snippet "y^n=x" } "." } ;
+
+HELP: exp-int
+{ $values { "x" number } { "y" number } }
+{ $description "Exponential integral function." }
+{ $notes "Works only for real values of " { $snippet "x" } " and is accurate to 7 decimal places." } ;
+
+HELP: stirling-fact
+{ $values { "n" integer } { "fact" integer } }
+{ $description "James Stirling's factorial approximation." } ;
+
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
- [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
+ [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: help.markup help.syntax ;
-
+USING: help.markup help.syntax math ;
IN: math.compare
HELP: absmin
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the smaller absolute number with the original sign."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the smaller absolute number with the original sign." } ;
HELP: absmax
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the larger absolute number with the original sign."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the larger absolute number with the original sign." } ;
HELP: posmax
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the most-positive value, or zero if both are negative."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the most-positive value, or zero if both are negative." } ;
HELP: negmin
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the most-negative value, or zero if both are positive."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the most-negative value, or zero if both are positive." } ;
HELP: clamp
-{ $values { "a" "a number" } { "value" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description
- "Returns the value when between 'a' and 'b', 'a' if <= 'a', or 'b' if >= 'b'."
-} ;
+{ $values { "a" number } { "value" number } { "b" number } { "x" number } }
+{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ;
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: kernel math math.functions math.compare tools.test ;
-
+USING: kernel math math.compare math.functions tools.test ;
IN: math.compare.tests
[ -1 ] [ -1 5 absmin ] unit-test
[ 1 ] [ 0 1 2 clamp ] unit-test
[ 2 ] [ 0 3 2 clamp ] unit-test
-
-
-
-! Copyright (C) 2008 John Benediktsson
+! Copyright (C) 2008 John Benediktsson.
! See http://factorcode.org/license.txt for BSD license
-
USING: math math.order kernel ;
+IN: math.compare
-IN: math.compare
-
-: absmin ( a b -- x )
- [ [ abs ] bi@ < ] 2keep ? ;
+: absmin ( a b -- x )
+ [ [ abs ] bi@ < ] 2keep ? ;
-: absmax ( a b -- x )
- [ [ abs ] bi@ > ] 2keep ? ;
+: absmax ( a b -- x )
+ [ [ abs ] bi@ > ] 2keep ? ;
-: posmax ( a b -- x )
- 0 max max ;
+: posmax ( a b -- x )
+ 0 max max ;
-: negmin ( a b -- x )
- 0 min min ;
+: negmin ( a b -- x )
+ 0 min min ;
: clamp ( a value b -- x )
- min max ;
+ min max ;
--- /dev/null
+USING: math math.derivatives tools.test ;
+IN: math.derivatives.test
+
+[ 8 ] [ 4 [ sq ] derivative >integer ] unit-test
+
-USING: kernel continuations combinators sequences math
- math.order math.ranges accessors float-arrays ;
-
+! Copyright (c) 2008 Reginald Keith Ford II, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations combinators sequences math math.order math.ranges
+ accessors float-arrays ;
IN: math.derivatives
TUPLE: state x func h err i j errt fac hh ans a done ;
: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
: check-h ( state -- state )
- dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+ dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+
: init-a ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
: init-hh ( state -- state ) dup h>> >>hh ;
: init-err ( state -- state ) big >>err ;
! If error is decreased, save the improved answer
: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
+
: save-improved-answer ( state -- state )
- dup err>> >>errt
- dup a[j][i] >>ans ;
+ dup err>> >>errt
+ dup a[j][i] >>ans ;
! If higher order is worse by a significant factor SAFE, then quit early.
: check-safe ( state -- state )
- dup
- [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
- [ t >>done ]
- when ;
+ dup [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ]
+ [ err>> safe * ] bi >= [ t >>done ] when ;
+
: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
+
: limit-approx ( state -- val )
- [
- [ [ x+hh ] [ func>> ] bi call ]
- [ [ x-hh ] [ func>> ] bi call ]
- bi -
- ]
- [ hh>> 2.0 * ]
- bi / ;
+ [
+ [ [ x+hh ] [ func>> ] bi call ]
+ [ [ x-hh ] [ func>> ] bi call ] bi -
+ ] [ hh>> 2.0 * ] bi / ;
+
: a[0][0]! ( state -- state )
- { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+
: a[0][i]! ( state -- state )
- { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+
: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
+
: new-a[j][i] ( state -- val )
- [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
- [ fac>> 1.0 - ]
- bi / ;
+ [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
+ [ fac>> 1.0 - ] bi / ;
+
: a[j][i]! ( state -- state )
- { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
+ { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
: update-errt ( state -- state )
- dup
- [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
- [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
- bi max
- >>errt ;
+ dup [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
+ [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] bi max >>errt ;
: not-done? ( state -- state ? ) dup done>> not ;
: derive ( state -- state )
- init-a
- check-h
- init-hh
- a[0][0]!
- init-err
- 1 ntab [a,b)
- [
- >>i
- not-done?
- [
- update-hh
- a[0][i]!
- reset-fac
- 1 over i>> [a,b]
- [
- >>j
- a[j][i]!
- update-fac
- update-errt
- error-decreased? [ save-improved-answer ] when
- ]
- each
- check-safe
- ]
- when
- ]
- each ;
+ init-a
+ check-h
+ init-hh
+ a[0][0]!
+ init-err
+ 1 ntab [a,b) [
+ >>i not-done? [
+ update-hh
+ a[0][i]!
+ reset-fac
+ 1 over i>> [a,b] [
+ >>j
+ a[j][i]!
+ update-fac
+ update-errt
+ error-decreased? [ save-improved-answer ] when
+ ] each check-safe
+ ] when
+ ] each ;
: derivative-state ( x func h err -- state )
state new
! h should be small enough to give the correct sgn(f'(x))
! err is the max tolerance of gain in error for a single iteration-
: (derivative) ( x func h err -- ans error )
- derivative-state
- derive
- [ ans>> ]
- [ errt>> ]
- bi ;
+ derivative-state derive [ ans>> ] [ errt>> ] bi ;
-: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
+: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
: derivative-func ( func -- der ) [ derivative ] curry ;
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
- math.ranges sequences accessors ;
+USING: accessors bit-arrays fry kernel lists.lazy math math.functions
+ math.primes.list math.ranges sequences ;
IN: math.erato
<PRIVATE
TUPLE: erato limit bits latest ;
: ind ( n -- i )
- 2/ 1- ; inline
+ 2/ 1- ; inline
: is-prime ( n limit -- bool )
- [ ind ] [ bits>> ] bi* nth ; inline
+ [ ind ] [ bits>> ] bi* nth ; inline
: indices ( n erato -- range )
- limit>> ind over 3 * ind swap rot <range> ;
+ limit>> ind over 3 * ind spin <range> ;
: mark-multiples ( n erato -- )
- over sq over limit>> <=
- [ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ;
+ 2dup [ sq ] [ limit>> ] bi* <= [
+ [ indices ] keep bits>> '[ _ f -rot set-nth ] each
+ ] [ 2drop ] if ;
: <erato> ( n -- erato )
- dup ind 1+ <bit-array> 1 over set-bits erato boa ;
+ dup ind 1+ <bit-array> dup set-bits 1 erato boa ;
: next-prime ( erato -- prime/f )
- [ 2 + ] change-latest [ latest>> ] keep
- 2dup limit>> <=
- [
- 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
- ] [
- 2drop f
- ] if ;
+ [ 2 + ] change-latest [ latest>> ] keep
+ 2dup limit>> <= [
+ 2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
+ ] [
+ 2drop f
+ ] if ;
PRIVATE>
: lerato ( n -- lazy-list )
- dup 1000003 < [
- 0 primes-under-million seq>list swap [ <= ] curry lwhile
- ] [
- <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
- ] if ;
+ dup 1000003 < [
+ 0 primes-under-million seq>list swap '[ _ <= ] lwhile
+ ] [
+ <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
+ ] if ;
-Sieve of Eratosthene
+Sieve of Eratosthenes
+++ /dev/null
-Hans Schmid
+++ /dev/null
-! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
-! http://dressguardmeister.blogspot.com/2007/01/fft.html
-USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting grouping columns ;
-IN: math.fft
-
-: n^v ( n v -- w ) [ ^ ] with map ;
-: even ( seq -- seq ) 2 group 0 <column> ;
-: odd ( seq -- seq ) 2 group 1 <column> ;
-DEFER: fft
-: two ( seq -- seq ) fft 2 v/n dup append ;
-: omega ( n -- n' ) recip -2 pi i* * * exp ;
-: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ;
-: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ;
-: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ;
+++ /dev/null
-Fast fourier transform
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
+! Copyright (C) 2008 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel grouping sequences shuffle
math math.functions math.statistics math.vectors ;
-
IN: math.finance
<PRIVATE
-: weighted ( x y a -- z )
- tuck [ * ] [ 1 swap - * ] 2bi* + ;
+: weighted ( x y a -- z )
+ tuck [ * ] [ 1- neg * ] 2bi* + ;
-: a ( n -- a )
- 1 + 2 swap / ;
+: a ( n -- a )
+ 1+ 2 swap / ;
PRIVATE>
: ema ( seq n -- newseq )
- a swap unclip [ [ dup ] 2dip swap rot weighted ] accumulate 2nip ;
+ a swap unclip [ [ dup ] 2dip spin weighted ] accumulate 2nip ;
: sma ( seq n -- newseq )
clump [ mean ] map ;
rot dup ema [ swap ema ] dip v- ;
: momentum ( seq n -- newseq )
- 2dup tail-slice -rot swap [ length ] keep
- [ - neg ] dip swap head-slice v- ;
+ [ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel math sequences prettyprint math.parser io
+math.functions ;
IN: math.floating-point
-: float-sign ( float -- ? )
- float>bits -31 shift { 1 -1 } nth ;
+: (double-sign) ( bits -- n ) -63 shift ; inline
+: double-sign ( double -- n ) double>bits (double-sign) ;
-: double-sign ( float -- ? )
- double>bits -63 shift { 1 -1 } nth ;
-
-: float-exponent-bits ( float -- n )
- float>bits -23 shift 8 2^ 1- bitand ;
+: (double-exponent-bits) ( bits -- n )
+ -52 shift 11 2^ 1- bitand ; inline
: double-exponent-bits ( double -- n )
- double>bits -52 shift 11 2^ 1- bitand ;
+ double>bits (double-exponent-bits) ;
-: float-mantissa-bits ( float -- n )
- float>bits 23 2^ 1- bitand ;
+: (double-mantissa-bits) ( double -- n )
+ 52 2^ 1- bitand ;
: double-mantissa-bits ( double -- n )
- double>bits 52 2^ 1- bitand ;
-
-: float-e ( -- float ) 127 ; inline
-: double-e ( -- float ) 1023 ; inline
-
-! : calculate-float ( S M E -- float )
- ! float-e - 2^ * * ; ! bits>float ;
-
-! : calculate-double ( S M E -- frac )
- ! double-e - 2^ swap 52 2^ /f 1+ * * ;
+ double>bits (double-mantissa-bits) ;
+
+: >double ( S E M -- frac )
+ [ 52 shift ] dip
+ [ 63 shift ] 2dip bitor bitor bits>double ;
+
+: >double< ( double -- S E M )
+ double>bits
+ [ (double-sign) ]
+ [ (double-exponent-bits) ]
+ [ (double-mantissa-bits) ] tri ;
+
+: double. ( double -- )
+ double>bits
+ [ (double-sign) .b ]
+ [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ]
+ [
+ (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
+ 11 [ bl ] times print
+ ] tri ;
-! Copyright © 2008 Reginald Keith Ford II
-! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
-
+! Copyright (c) 2008 Reginald Keith Ford II.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel math arrays sequences sequences.lib ;
-IN: math.function-tools
-: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
-: eval ( x func -- pt ) dupd call 2array ; inline
-: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
-: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline
+IN: math.function-tools
+
+! Tools for quickly comparing, transforming, and evaluating mathematical functions
+
+: difference-func ( func func -- func )
+ [ bi - ] 2curry ; inline
+
+: eval ( x func -- pt )
+ dupd call 2array ; inline
+
+: eval-inverse ( y func -- pt )
+ dupd call swap 2array ; inline
+
+: eval3d ( x y func -- pt )
+ [ 2dup ] dip call 3array ; inline
+++ /dev/null
-! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting grouping columns ;
-IN: math.haar
-
-: averages ( seq -- seq )
- [ first2 + 2 / ] map ;
-
-: differences ( seq averages -- differences )
- >r 0 <column> r> [ - ] 2map ;
-
-: haar-step ( seq -- differences averages )
- 2 group dup averages [ differences ] keep ;
-
-: haar ( seq -- seq )
- dup length 1 <= [ haar-step haar prepend ] unless ;
+++ /dev/null
-Haar wavelet transform
: cols ( -- n ) 0 nth-row length ;
: skip ( i seq quot -- n )
- over >r find-from drop r> length or ; inline
+ 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 )
- >r over r> nth dup zero? [
+ [ over ] dip nth dup zero? [
3drop 0
] [
- >r nth dup zero? r> swap [
+ [ nth dup zero? ] dip swap [
2drop 0
] [
swap / neg
] if ;
: (clear-col) ( col# pivot-row i -- )
- [ [ clear-scale ] 2keep >r n*v r> v+ ] change-row ;
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
: rows-from ( row# -- slice )
rows dup <slice> ;
: clear-col ( col# row# rows -- )
- >r nth-row r> [ >r 2dup r> (clear-col) ] each 2drop ;
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
: do-row ( exchange-with row# -- )
[ exchange-rows ] keep
dup 1+ rows-from clear-col ;
: find-row ( row# quot -- i elt )
- >r rows-from r> find ; inline
+ [ 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*
- >r 1+ r> (echelon)
+ [ 1+ ] dip (echelon)
] [
2drop
] if ;
] with-matrix ;
: basis-vector ( row col# -- )
- >r clone r>
+ [ clone ] dip
[ swap nth neg recip ] 2keep
[ 0 spin set-nth ] 2keep
- >r n*v r>
+ [ n*v ] dip
matrix get set-nth ;
: nullspace ( matrix -- seq )
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math math.functions
-math.vectors math.order ;
+USING: arrays kernel math math.order math.vectors sequences ;
IN: math.matrices
! Matrices
: m.v ( m v -- v ) [ v. ] curry map ;
: m. ( m m -- m ) flip [ swap m.v ] curry map ;
-: mmin ( m -- n ) >r 1/0. r> [ [ min ] each ] each ;
-: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
+: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
+: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
<PRIVATE
TUPLE: positive-even-expected n ;
-: (factor-2s) ( r s -- r s )
- dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
-
-: factor-2s ( n -- r s )
- #! factor an integer into s * 2^r
- 0 swap (factor-2s) ;
-
:: (miller-rabin) ( n trials -- ? )
[let | r [ n 1- factor-2s drop ]
s [ n 1- factor-2s nip ]
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright (c) 2008 Reginald Keith Ford II.
! See http://factorcode.org/license.txt for BSD license.
-! Newton's Method of approximating roots
USING: kernel math math.derivatives ;
IN: math.newtons-method
+! Newton's method of approximating roots
+
<PRIVATE
: newton-step ( x function -- x2 )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences vectors math math.vectors
-namespaces make shuffle splitting sequences.lib math.order ;
+USING: arrays kernel make math math.order math.vectors sequences shuffle
+ splitting vectors ;
IN: math.polynomials
! Polynomials are vectors with the highest powers on the right:
<array> 1 [ * ] accumulate nip ;
<PRIVATE
-: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ;
-: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ;
+
+: 2pad-left ( p p n -- p p ) [ 0 pad-left ] curry bi@ ;
+: 2pad-right ( p p n -- p p ) [ 0 pad-right ] curry bi@ ;
: pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
: unempty ( seq -- seq ) [ { 0 } ] when-empty ;
: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE>
+
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
! convolution
: pextend-conv ( p p -- p p )
- #! extend to: p_m + p_n - 1
+ #! extend to: p_m + p_n - 1
2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
: p* ( p p -- p )
#! Multiply two polynomials.
2unempty pextend-conv <reversed> dup length
[ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
-
+
: p-sq ( p -- p-sq )
dup p* ;
dup V{ 0 } clone p= [
drop nip
] [
- tuck p/mod >r pick p* swap >r swapd p- r> r> (pgcd)
+ tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ;
: pgcd ( p p -- p q )
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lists math math.primes namespaces make
-sequences ;
+USING: arrays kernel lists make math math.primes sequences ;
IN: math.primes.factors
<PRIVATE
: (count) ( n d -- n' )
[ (factor) ] { } make
- [ [ first ] keep length 2array , ] unless-empty ;
+ [ [ first ] [ length ] bi 2array , ] unless-empty ;
: (unique) ( n d -- n' )
[ (factor) ] { } make
[ first , ] unless-empty ;
: (factors) ( quot list n -- )
- dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
+ dup 1 > [
+ swap uncons swap [ pick call ] dip swap (factors)
+ ] [ 3drop ] if ;
: (decompose) ( n quot -- seq )
[ lprimes rot (factors) ] { } make ;
dup 2 < [
drop 0
] [
- dup unique-factors dup 1 [ 1- * ] reduce swap product / *
+ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / *
] if ; foldable
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel lists.lazy math math.functions math.miller-rabin
- math.order math.primes.list math.ranges sequences sorting
- binary-search ;
+USING: binary-search combinators kernel lists.lazy math math.functions
+ math.miller-rabin math.primes.list sequences ;
IN: math.primes
<PRIVATE
} cond ; foldable
: primes-between ( low high -- seq )
- primes-upto
- [ 1- next-prime ] dip
- [ natural-search drop ] keep [ length ] keep <slice> ; foldable
+ primes-upto [ 1- next-prime ] dip
+ [ natural-search drop ] [ length ] [ ] tri <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
-: q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline
+: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
-: q*b ( u v -- b ) 2q >r ** swap r> * + ; inline
+: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
PRIVATE>
: v>q ( v -- q )
#! Turn a 3-vector into a quaternion with real part 0.
- first3 rect> >r 0 swap rect> r> 2array ;
+ first3 rect> [ 0 swap rect> ] dip 2array ;
: q>v ( q -- v )
#! Get the vector part of a quaternion, discarding the real
#! part.
- first2 >r imaginary-part r> >rect 3array ;
+ first2 [ imaginary-part ] dip >rect 3array ;
! Zero
: q0 { 0 0 } ;
! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html
: (euler) ( theta unit -- q )
- >r -0.5 * dup cos c>q swap sin r> n*v v- ;
+ [ -0.5 * dup cos c>q swap sin ] dip n*v v- ;
: euler ( phi theta psi -- q )
[ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright (c) 2008 Reginald Keith Ford II.
! See http://factorcode.org/license.txt for BSD license.
-! Secant Method of approximating roots
USING: kernel math math.function-tools math.points math.vectors ;
IN: math.secant-method
+! Secant method of approximating roots
+
<PRIVATE
: secant-solution ( x1 x2 function -- solution )
! Copyright (C) 2008 Doug Coleman, Michael Judge.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.analysis math.functions math.vectors sequences
-sequences.lib sorting ;
+USING: arrays kernel math math.analysis math.functions sequences sequences.lib
+ sorting ;
IN: math.statistics
: mean ( seq -- n )
: median ( seq -- n )
#! middle number if odd, avg of two middle numbers if even
- natural-sort dup length dup even? [
- 1- 2 / swap [ nth ] [ [ 1+ ] dip nth ] 2bi + 2 /
+ natural-sort dup length even? [
+ [ midpoint@ dup 1- 2array ] keep nths mean
] [
- 2 / swap nth
+ [ midpoint@ ] keep nth
] if ;
: range ( seq -- n )
: ste ( seq -- x )
#! standard error, standard deviation / sqrt ( length of sequence )
- dup std swap length sqrt / ;
+ [ std ] [ length ] bi sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
- 0 [ [ >r pick r> swap - ] bi@ * + ] 2reduce 2nip ;
+ 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
- * recip >r [ ((r)) ] keep length 1- / r> * ;
+ * recip [ [ ((r)) ] keep length 1- / ] dip * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
SYMBOL: and-needed?
: set-conjunction ( seq -- )
- first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ;
+ first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
: negative-text ( n -- str )
0 < "Negative " "" ? ;
--- /dev/null
+Hans Schmid
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.fft
+
+HELP: fft
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Fast Fourier transform function." } ;
+
--- /dev/null
+! Copyright (c) 2007 Hans Schmid.
+! See http://factorcode.org/license.txt for BSD license.
+USING: columns grouping kernel math math.constants math.functions math.vectors
+ sequences ;
+IN: math.transforms.fft
+
+! Fast Fourier Transform
+
+<PRIVATE
+
+: n^v ( n v -- w ) [ ^ ] with map ;
+
+: omega ( n -- n' )
+ recip -2 pi i* * * exp ;
+
+: twiddle ( seq -- seq )
+ dup length [ omega ] [ n^v ] bi v* ;
+
+PRIVATE>
+
+DEFER: fft
+
+: two ( seq -- seq )
+ fft 2 v/n dup append ;
+
+<PRIVATE
+
+: even ( seq -- seq ) 2 group 0 <column> ;
+: odd ( seq -- seq ) 2 group 1 <column> ;
+
+: (fft) ( seq -- seq )
+ [ odd two twiddle ] [ even two ] bi v+ ;
+
+PRIVATE>
+
+: fft ( seq -- seq )
+ dup length 1 = [ (fft) ] unless ;
+
--- /dev/null
+Fast fourier transform
--- /dev/null
+Slava Pestov
+Aaron Schaefer
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.haar
+
+HELP: haar
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Haar wavelet transform function." }
+{ $notes "The sequence length should be a power of two." }
+{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 7 1 6 6 3 -5 4 2 } haar ." "{ 3 2 -1 -2 3 0 4 1 }" } } ;
+
+HELP: rev-haar
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Reverse Haar wavelet transform function." }
+{ $notes "The sequence length should be a power of two." }
+{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 3 2 -1 -2 3 0 4 1 } rev-haar ." "{ 7 1 6 6 3 -5 4 2 }" } } ;
+
--- /dev/null
+USING: math.transforms.haar tools.test ;
+IN: math.transforms.haar.tests
+
+[ { 3 2 -1 -2 3 0 4 1 } ] [ { 7 1 6 6 3 -5 4 2 } haar ] unit-test
+[ { 7 1 6 6 3 -5 4 2 } ] [ { 3 2 -1 -2 3 0 4 1 } rev-haar ] unit-test
+
--- /dev/null
+! Copyright (c) 2008 Slava Pestov, Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs columns grouping kernel math math.statistics math.vectors
+ sequences ;
+IN: math.transforms.haar
+
+! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/
+
+<PRIVATE
+
+: averages ( seq -- seq )
+ [ mean ] map ;
+
+: differences ( seq averages -- differences )
+ [ 0 <column> ] dip v- ;
+
+: haar-step ( seq -- differences averages )
+ 2 group dup averages [ differences ] keep ;
+
+: rev-haar-step ( seq -- seq )
+ halves [ v+ ] [ v- ] 2bi zip concat ;
+
+PRIVATE>
+
+: haar ( seq -- seq )
+ dup length 1 <= [ haar-step haar prepend ] unless ;
+
+: rev-haar ( seq -- seq )
+ dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ;
+
--- /dev/null
+Haar wavelet transform
--- /dev/null
+Collection of mathematical transforms
! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl
-arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
-math.order math.geometry.rect ;
+opengl.demo-support arrays kernel random ui ui.gadgets
+ui.gadgets.canvas ui.render math.order math.geometry.rect ;
IN: maze
: line-width 8 ;
] if ;
: draw-maze ( n -- )
+ -0.5 0.5 0 glTranslated
line-width 2 - glLineWidth
line-width 2 - glPointSize
1.0 1.0 1.0 1.0 glColor4d
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ;
IN: nehe.2
TUPLE: nehe2-gadget < gadget ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ;
IN: nehe.3
TUPLE: nehe3-gadget < gadget ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render threads accessors ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render threads accessors ;
IN: nehe.4
TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
-USING: arrays kernel math opengl opengl.gl opengl.glu ui\r
-ui.gadgets ui.render threads accessors ;\r
+USING: arrays kernel math opengl opengl.gl opengl.glu\r
+opengl.demo-support ui ui.gadgets ui.render threads accessors ;\r
IN: nehe.5\r
\r
TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
-USING: arrays kernel math math.functions
-math.order math.vectors namespaces opengl opengl.gl sequences ui
-ui.gadgets ui.gestures ui.render accessors ;
+USING: arrays kernel math math.functions math.order math.vectors
+namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
+ui.render accessors combinators ;
IN: opengl.demo-support
: FOV 2.0 sqrt 1+ ; inline
: drag-yaw-pitch ( -- yaw pitch )
last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
+: gl-vertex ( point -- )
+ dup length {
+ { 2 [ first2 glVertex2d ] }
+ { 3 [ first3 glVertex3d ] }
+ { 4 [ first4 glVertex4d ] }
+ } case ;
+
+: gl-normal ( normal -- ) first3 glNormal3d ;
+
+: do-state ( mode quot -- )
+ swap glBegin call glEnd ; inline
+
+: rect-vertices ( lower-left upper-right -- )
+ GL_QUADS [
+ over first2 glVertex2d
+ dup first pick second glVertex2d
+ dup first2 glVertex2d
+ swap first swap second glVertex2d
+ ] do-state ;
+
demo-gadget H{
{ T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: locals math.functions math namespaces
-opengl.gl accessors kernel opengl ui.gadgets
+opengl.gl opengl.demo-support accessors kernel opengl ui.gadgets
fry assocs
destructors sequences ui.render colors ;
IN: opengl.gadgets
-TUPLE: texture-gadget ;
+TUPLE: texture-gadget < gadget ;
GENERIC: render* ( gadget -- texture dims )
GENERIC: cache-key* ( gadget -- key )
: (read-128-ber) ( n -- n )
read1
- [ >r 7 shift r> 7 clear-bit bitor ] keep
+ [ [ 7 shift ] [ 7 clear-bit ] bi* bitor ] keep
7 bit? [ (read-128-ber) ] when ;
: read-128-ber ( -- n )
USING: kernel namespaces arrays sequences grouping
alien.c-types
math math.vectors math.geometry.rect
- opengl.gl opengl.glu opengl generalizations vars
+ opengl.gl opengl.glu opengl.demo-support opengl generalizations vars
combinators.cleave colors ;
IN: processing.shapes
: fill-mode ( -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode
- fill-color> set-color ;
+ fill-color> gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: stroke-mode ( -- )
GL_FRONT_AND_BACK GL_LINE glPolygonMode
- stroke-color> set-color ;
+ stroke-color> gl-color ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ellipse ( center dim -- )
GL_FRONT_AND_BACK GL_FILL glPolygonMode
- [ stroke-color> set-color gl-ellipse ]
- [ fill-color> set-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
+ [ stroke-color> gl-color gl-ellipse ]
+ [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: euler001b ( -- answer )
- 1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ;
+ 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
<PRIVATE
: source-004 ( -- seq )
- 100 999 [a,b] [ 10 mod zero? not ] filter ;
+ 100 999 [a,b] [ 10 mod 0 = not ] filter ;
: max-palindrome ( seq -- palindrome )
natural-sort [ palindrome? ] find-last nip ;
<PRIVATE
: worth-calculating? ( n -- ? )
- 1- 3 { [ mod zero? ] [ / even? ] } 2&& ;
+ 1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
PRIVATE>
: euler019 ( -- answer )
1901 2000 [a,b] [
12 [1,b] [ 1 zeller-congruence ] with map
- ] map concat [ zero? ] count ;
+ ] map concat [ 0 = ] count ;
! [ euler019 ] 100 ave-time
! 1 ms ave run time - 0.51 SD (100 trials)
PRIVATE>
: euler019a ( -- answer )
- end-date start-date first-days [ zero? ] count ;
+ end-date start-date first-days [ 0 = ] count ;
! [ euler019a ] 100 ave-time
! 17 ms ave run time - 2.13 SD (100 trials)
] reduce-permutations ;
! [ euler043 ] time
-! 104526 ms run / 42735 ms GC time
+! 60280 ms run / 59 ms GC time
! ALTERNATE SOLUTIONS
0 <repetition> >array sieve set ;
: is-prime? ( index -- ? )
- sieve get nth zero? ;
+ sieve get nth 0 = ;
: multiples ( n -- seq )
sieve get length 1- over <range> ;
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
- { [ odd? ] [ 3 mod zero? ] } 1&& ;
+ { [ odd? ] [ 3 mod 0 = ] } 1&& ;
: next-all-same ( x n -- n )
dup candidate? [
--- /dev/null
+USING: project-euler.071 tools.test ;
+IN: project-euler.071.tests
+
+[ 428570 ] [ euler071 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math project-euler.common sequences ;
+IN: project-euler.071
+
+! http://projecteuler.net/index.php?section=problems&id=71
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers. If n<d and
+! HCF(n,d) = 1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d <= 8 in ascending order of
+! size, we get:
+
+! 1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8,
+! 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that 2/5 is the fraction immediately to the left of 3/7.
+
+! By listing the set of reduced proper fractions for d <= 1,000,000 in
+! ascending order of size, find the numerator of the fraction immediately to the
+! left of 3/7.
+
+
+! SOLUTION
+! --------
+
+! Use the properties of a Farey sequence by setting an upper bound of 3/7 and
+! then taking the mediant of that fraction and the one to its immediate left
+! repeatedly until the denominator is as close to 1000000 as possible without
+! going over.
+
+<PRIVATE
+
+: penultimate ( seq -- elt )
+ dup length 2 - swap nth ;
+
+PRIVATE>
+
+: euler071 ( -- answer )
+ 2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] [ ] produce
+ nip penultimate numerator ;
+
+! [ euler071 ] 100 ave-time
+! 155 ms ave run time - 6.95 SD (100 trials)
+
+MAIN: euler071
--- /dev/null
+USING: project-euler.073 tools.test ;
+IN: project-euler.073.tests
+
+[ 5066251 ] [ euler073 ] unit-test
--- /dev/null
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel locals make math project-euler.common sequences ;
+IN: project-euler.073
+
+! http://projecteuler.net/index.php?section=problems&id=73
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers. If n<d and
+! HCF(n,d) = 1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d <= 8 in ascending order of
+! size, we get:
+
+! 1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8,
+! 2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that there are 3 fractions between 1/3 and 1/2.
+
+! How many fractions lie between 1/3 and 1/2 in the sorted set of reduced
+! proper fractions for d <= 10,000?
+
+
+! SOLUTION
+! --------
+
+! Use the properties of a Farey sequence and mediants to recursively generate
+! the next fraction until the denominator is as close to 1000000 as possible
+! without going over.
+
+<PRIVATE
+
+:: (euler073) ( limit lo hi -- )
+ [let | m [ lo hi mediant ] |
+ m denominator limit <= [
+ m ,
+ limit lo m (euler073)
+ limit m hi (euler073)
+ ] when
+ ] ;
+
+PRIVATE>
+
+: euler073 ( -- answer )
+ [ 10000 1/3 1/2 (euler073) ] { } make length ;
+
+! [ euler073 ] 10 ave-time
+! 20506 ms ave run time - 937.07 SD (10 trials)
+
+MAIN: euler073
--- /dev/null
+USING: project-euler.203 tools.test ;
+IN: project-euler.203.tests
+
+[ 105 ] [ 8 solve ] unit-test
+[ 34029210557338 ] [ 51 solve ] unit-test
--- /dev/null
+USING: fry kernel math math.primes.factors sequences sets ;
+IN: project-euler.203
+
+: iterate ( n initial quot -- results ) swapd '[ @ dup ] replicate nip ; inline
+: (generate) ( seq -- seq ) [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
+: generate ( n -- seq ) 1- { 1 } [ (generate) ] iterate concat prune ;
+: squarefree ( n -- ? ) factors duplicates empty? ;
+: solve ( n -- n ) generate [ squarefree ] filter sum ;
+: euler203 ( -- n ) 51 solve ;
-USING: project-euler.215 tools.test ;
+USING: project-euler.215 project-euler.215.private tools.test ;
IN: project-euler.215.tests
[ 8 ] [ 9 3 solve ] unit-test
+! Copyright (c) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel locals math ;
IN: project-euler.215
+! http://projecteuler.net/index.php?section=problems&id=215
+
+! DESCRIPTION
+! -----------
+
+! Consider the problem of building a wall out of 2x1 and 3x1 bricks
+! (horizontalvertical dimensions) such that, for extra strength, the gaps
+! between horizontally-adjacent bricks never line up in consecutive layers,
+! i.e. never form a "running crack".
+
+! For example, the following 93 wall is not acceptable due to the running crack
+! shown in red:
+
+! See problem site for image...
+
+! There are eight ways of forming a crack-free 9x3 wall, written W(9,3) = 8.
+
+! Calculate W(32,10).
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
TUPLE: block two three ;
TUPLE: end { ways integer } ;
: failure? ( t -- ? ) ways>> 0 = ; inline
-: choice ( t p q -- t t ) [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline
+: choice ( t p q -- t t )
+ [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline
GENERIC: merge ( t t -- t )
GENERIC# block-merge 1 ( t t -- t )
: next-row ( t -- t ) [ h-1 ] [ h1 ] choice swap <block> ;
: first-row ( n -- t )
- [ <failure> <success> <failure> ] dip
- 1- [| a b c | b c <block> a b ] times 2drop ;
+ [ <failure> <success> <failure> ] dip
+ 1- [| a b c | b c <block> a b ] times 2drop ;
GENERIC: total ( t -- n )
M: block total [ total ] dup choice + ;
M: end total ways>> ;
: solve ( width height -- ways )
- [ first-row ] dip 1- [ next-row ] times total ;
+ [ first-row ] dip 1- [ next-row ] times total ;
+
+PRIVATE>
+
+: euler215 ( -- answer )
+ 32 10 solve ;
+
+! [ euler215 ] 100 ave-time
+! 208 ms ave run time - 9.06 SD (100 trials)
-: euler215 ( -- ways ) 32 10 solve ;
+MAIN: euler215
! Copyright (c) 2007-2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel make math math.functions math.matrices math.miller-rabin
- math.order math.parser math.primes.factors math.ranges sequences
- sequences.lib sorting strings unicode.case ;
+ math.order math.parser math.primes.factors math.ranges math.ratios
+ sequences sequences.lib sorting strings unicode.case ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
! log10 - #25, #134
! max-path - #18, #67
+! mediant - #71, #73
! nth-triangle - #12, #42
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
! palindrome? - #4, #36, #55
: (sum-divisors) ( n -- sum )
dup sqrt >fixnum [1,b] [
- [ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each
+ [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ;
: log10 ( m -- n )
log 10 log / ;
+: mediant ( a/c b/d -- (a+b)/(c+d) )
+ 2>fraction [ + ] 2bi@ / ;
+
: max-path ( triangle -- n )
dup length 1 > [
2 cut* first2 max-children [ + ] 2map suffix max-path
] if ;
: number>digits ( n -- seq )
- [ dup zero? not ] [ 10 /mod ] [ ] produce reverse nip ;
+ [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ;
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
factor-2s dup [ 1+ ]
[ perfect-square? -1 0 ? ]
[ dup sqrt >fixnum [1,b] ] tri* [
- dupd mod zero? [ [ 2 + ] dip ] when
+ dupd mod 0 = [ [ 2 + ] dip ] when
] each drop * ;
! These transforms are for generating primitive Pythagorean triples
! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: definitions io io.files kernel math math.parser project-euler.ave-time
- sequences vocabs vocabs.loader prettyprint
+USING: definitions io io.files kernel math math.parser
+ prettyprint project-euler.ave-time sequences vocabs vocabs.loader
project-euler.001 project-euler.002 project-euler.003 project-euler.004
project-euler.005 project-euler.006 project-euler.007 project-euler.008
project-euler.009 project-euler.010 project-euler.011 project-euler.012
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.052 project-euler.053 project-euler.055 project-euler.056
- project-euler.059 project-euler.067 project-euler.075 project-euler.076
- project-euler.079 project-euler.092 project-euler.097 project-euler.100
- project-euler.116 project-euler.117 project-euler.134 project-euler.148
- project-euler.150 project-euler.151 project-euler.164 project-euler.169
- project-euler.173 project-euler.175 project-euler.186 project-euler.190 ;
+ project-euler.059 project-euler.067 project-euler.071 project-euler.073
+ project-euler.075 project-euler.076 project-euler.079 project-euler.092
+ project-euler.097 project-euler.100 project-euler.116 project-euler.117
+ project-euler.134 project-euler.148 project-euler.150 project-euler.151
+ project-euler.164 project-euler.169 project-euler.173 project-euler.175
+ project-euler.186 project-euler.190 project-euler.215 ;
IN: project-euler
<PRIVATE
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel math ;
IN: roman
{ $values { "n" "an integer" } { "str" "a string" } }
{ $description "Converts a number to its lower-case Roman Numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >ROMAN roman> } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "56 >roman print"
+ "lvi"
+ }
+} ;
HELP: >ROMAN
{ $values { "n" "an integer" } { "str" "a string" } }
{ $description "Converts a number to its upper-case Roman numeral equivalent." }
{ $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >roman roman> } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "56 >ROMAN print"
+ "LVI"
+ }
+} ;
HELP: roman>
{ $values { "str" "a string" } { "n" "an integer" } }
{ $description "Converts a Roman numeral to an integer." }
{ $notes "The range for this word is i-mmmcmxcix, inclusive." }
-{ $see-also >roman } ;
+{ $examples
+ { $example "USING: prettyprint roman ;"
+ "\"lvi\" roman> ."
+ "56"
+ }
+} ;
+
+{ >roman >ROMAN roman> } related-words
HELP: roman+
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Adds two Roman numerals." }
-{ $see-also roman- } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"v\" \"v\" roman+ print"
+ "x"
+ }
+} ;
HELP: roman-
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Subtracts two Roman numerals." }
-{ $see-also roman+ } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"x\" \"v\" roman- print"
+ "v"
+ }
+} ;
+
+{ roman+ roman- } related-words
HELP: roman*
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Multiplies two Roman numerals." }
-{ $see-also roman/i roman/mod } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"ii\" \"iii\" roman* print"
+ "vi"
+ }
+} ;
HELP: roman/i
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
{ $description "Computes the integer division of two Roman numerals." }
-{ $see-also roman* roman/mod /i } ;
+{ $examples
+ { $example "USING: io roman ;"
+ "\"v\" \"iv\" roman/i print"
+ "i"
+ }
+} ;
HELP: roman/mod
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
-{ $see-also roman* roman/i /mod } ;
+{ $examples
+ { $example "USING: kernel io roman ;"
+ "\"v\" \"iv\" roman/mod [ print ] bi@"
+ "i\ni"
+ }
+} ;
+
+{ roman* roman/i roman/mod } related-words
HELP: ROMAN:
-{ $description "A parsing word that reads the next token and converts it to an integer." } ;
+{ $description "A parsing word that reads the next token and converts it to an integer." }
+{ $examples
+ { $example "USING: prettyprint roman ;"
+ "ROMAN: v ."
+ "5"
+ }
+} ;
+
+ARTICLE: "roman" "Roman numerals"
+"The " { $vocab-link "roman" } " vocabulary can convert numbers to and from the Roman numeral system and can perform arithmetic given Roman numerals as input." $nl
+"A parsing word for literal Roman numerals:"
+{ $subsection POSTPONE: ROMAN: }
+"Converting to Roman numerals:"
+{ $subsection >roman }
+{ $subsection >ROMAN }
+"Converting Roman numerals to integers:"
+{ $subsection roman> }
+"Roman numeral arithmetic:"
+{ $subsection roman+ }
+{ $subsection roman- }
+{ $subsection roman* }
+{ $subsection roman/i }
+{ $subsection roman/mod } ;
+
+ABOUT: "roman"
: enumerate ( seq -- seq' ) <enum> >alist ;
+: splice ( left-seq right-seq seq -- newseq ) swap 3append ;
+
+: surround ( seq left-seq right-seq -- newseq ) swapd 3append ;
-USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
-opengl multiline ui.gadgets accessors sequences ui.render ui math locals
-arrays generalizations combinators opengl.capabilities ui.gadgets.worlds ;
+USING: kernel opengl opengl.demo-support opengl.gl
+opengl.shaders opengl.framebuffers opengl.capabilities multiline
+ui.gadgets accessors sequences ui.render ui math locals arrays
+generalizations combinators ui.gadgets.worlds ;
IN: spheres
STRING: plane-vertex-shader
! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
-: display ( -- ) set-projection black set-color draw-nodes draw-springs ;
+: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
#! OpenGL rendering for tetris
: draw-block ( block -- )
- dup { 1 1 } v+ gl-fill-rect ;
+ [ { 1 1 } gl-fill-rect ] with-translation ;
: draw-piece-blocks ( piece -- )
piece-blocks [ draw-block ] each ;
: draw-piece ( piece -- )
- dup tetromino>> colour>> set-color draw-piece-blocks ;
+ dup tetromino>> colour>> gl-color draw-piece-blocks ;
: draw-next-piece ( piece -- )
dup tetromino>> colour>>
- clone 0.2 >>alpha set-color draw-piece-blocks ;
+ clone 0.2 >>alpha gl-color draw-piece-blocks ;
! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )
>r over r> nth dup
- [ set-color 2array draw-block ] [ 3drop ] if ;
+ [ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row ( y row -- )
dup length -rot [ (draw-row) ] 2curry each ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test time-server ;
+IN: time-server.tests
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.servers.connection accessors threads
+calendar calendar.format ;
+IN: time-server
+
+: handle-time-client ( -- )
+ now timestamp>rfc822 print ;
+
+: <time-server> ( -- threaded-server )
+ <threaded-server>
+ "time-server" >>name
+ 1234 >>insecure
+ [ handle-time-client ] >>handler ;
+
+: start-time-server ( -- threaded-server )
+ <time-server> [ start-server ] in-thread ;
+
+MAIN: start-time-server
+++ /dev/null
-Sampo Vuori
+++ /dev/null
-! Cairo "Hello World" demo
-! Copyright (c) 2007 Sampo Vuori
-! License: http://factorcode.org/license.txt
-!
-! This example is an adaptation of the following cairo sample code:
-! http://cairographics.org/samples/text/
-
-
-USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
- ui.gadgets opengl.gl ;
-
-IN: cairo-demo
-
-
-: make-image-array ( -- array )
- 384 256 4 * * <byte-array> ;
-
-: convert-array-to-surface ( array -- cairo_surface_t )
- CAIRO_FORMAT_ARGB32 384 256 over 4 *
- cairo_image_surface_create_for_data ;
-
-
-TUPLE: cairo-gadget image-array cairo-t ;
-
-M: cairo-gadget draw-gadget* ( gadget -- )
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
- cairo-gadget-image-array glDrawPixels ;
-
-: create-surface ( gadget -- cairo_surface_t )
- make-image-array
- [ swap set-cairo-gadget-image-array ] keep
- convert-array-to-surface ;
-
-: init-cairo ( gadget -- cairo_t )
- create-surface cairo_create ;
-
-M: cairo-gadget pref-dim* drop { 384 256 0 } ;
-
-: draw-hello-world ( gadget -- )
- cairo-gadget-cairo-t
- dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
- dup 90.0 cairo_set_font_size
- dup 10.0 135.0 cairo_move_to
- dup "Hello" cairo_show_text
- dup 70.0 165.0 cairo_move_to
- dup "World" cairo_text_path
- dup 0.5 0.5 1 cairo_set_source_rgb
- dup cairo_fill_preserve
- dup 0 0 0 cairo_set_source_rgb
- dup 2.56 cairo_set_line_width
- dup cairo_stroke
- dup 1 0.2 0.2 0.6 cairo_set_source_rgba
- dup 10.0 135.0 5.12 0 pi 2 * cairo_arc
- dup cairo_close_path
- dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
- cairo_fill ;
-
-M: cairo-gadget graft* ( gadget -- )
- dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
-
-M: cairo-gadget ungraft* ( gadget -- )
- cairo-gadget-cairo-t cairo_destroy ;
-
-: <cairo-gadget> ( -- gadget )
- cairo-gadget construct-gadget ;
-
-: run ( -- )
- [
- <cairo-gadget> "Hello World from Factor!" open-window
- ] with-ui ;
-
-MAIN: run
+++ /dev/null
-Sampo Vuori
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: cairo.ffi kernel accessors sequences
-namespaces fry continuations destructors ;
-IN: cairo
-
-TUPLE: cairo-t alien ;
-C: <cairo-t> cairo-t
-M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
-
-TUPLE: cairo-surface-t alien ;
-C: <cairo-surface-t> cairo-surface-t
-M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
-
-: check-cairo ( cairo_status_t -- )
- dup CAIRO_STATUS_SUCCESS = [ drop ]
- [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
-
-SYMBOL: cairo
-: cr ( -- cairo ) cairo get ;
-
-: (with-cairo) ( cairo-t quot -- )
- >r alien>> cairo r> [ cr cairo_status check-cairo ]
- compose with-variable ; inline
-
-: with-cairo ( cairo quot -- )
- >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
-
-: (with-surface) ( cairo-surface-t quot -- )
- >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
-
-: with-surface ( cairo_surface quot -- )
- >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
-
-: with-cairo-from-surface ( cairo_surface quot -- )
- '[ cairo_create , with-cairo ] with-surface ; inline
+++ /dev/null
-! Copyright (c) 2007 Sampo Vuori
-! Copyright (c) 2008 Matthew Willis
-!
-! Adapted from cairo.h, version 1.5.14
-! License: http://factorcode.org/license.txt
-
-USING: system combinators alien alien.syntax kernel
-alien.c-types accessors sequences arrays ui.gadgets ;
-
-IN: cairo.ffi
-<< "cairo" {
- { [ os winnt? ] [ "libcairo-2.dll" ] }
- { [ os macosx? ] [ "libcairo.dylib" ] }
- { [ os unix? ] [ "libcairo.so.2" ] }
-} cond "cdecl" add-library >>
-
-LIBRARY: cairo
-
-FUNCTION: int cairo_version ( ) ;
-FUNCTION: char* cairo_version_string ( ) ;
-
-TYPEDEF: int cairo_bool_t
-
-! I am leaving these and other void* types as opaque structures
-TYPEDEF: void* cairo_t
-TYPEDEF: void* cairo_surface_t
-
-C-STRUCT: cairo_matrix_t
- { "double" "xx" }
- { "double" "yx" }
- { "double" "xy" }
- { "double" "yy" }
- { "double" "x0" }
- { "double" "y0" } ;
-
-TYPEDEF: void* cairo_pattern_t
-
-TYPEDEF: void* cairo_destroy_func_t
-: cairo-destroy-func ( quot -- callback )
- >r "void" { "void*" } "cdecl" r> alien-callback ; inline
-
-! See cairo.h for details
-C-STRUCT: cairo_user_data_key_t
- { "int" "unused" } ;
-
-TYPEDEF: int cairo_status_t
-C-ENUM:
- CAIRO_STATUS_SUCCESS
- CAIRO_STATUS_NO_MEMORY
- CAIRO_STATUS_INVALID_RESTORE
- CAIRO_STATUS_INVALID_POP_GROUP
- CAIRO_STATUS_NO_CURRENT_POINT
- CAIRO_STATUS_INVALID_MATRIX
- CAIRO_STATUS_INVALID_STATUS
- CAIRO_STATUS_NULL_POINTER
- CAIRO_STATUS_INVALID_STRING
- CAIRO_STATUS_INVALID_PATH_DATA
- CAIRO_STATUS_READ_ERROR
- CAIRO_STATUS_WRITE_ERROR
- CAIRO_STATUS_SURFACE_FINISHED
- CAIRO_STATUS_SURFACE_TYPE_MISMATCH
- CAIRO_STATUS_PATTERN_TYPE_MISMATCH
- CAIRO_STATUS_INVALID_CONTENT
- CAIRO_STATUS_INVALID_FORMAT
- CAIRO_STATUS_INVALID_VISUAL
- CAIRO_STATUS_FILE_NOT_FOUND
- CAIRO_STATUS_INVALID_DASH
- CAIRO_STATUS_INVALID_DSC_COMMENT
- CAIRO_STATUS_INVALID_INDEX
- CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
- CAIRO_STATUS_TEMP_FILE_ERROR
- CAIRO_STATUS_INVALID_STRIDE ;
-
-TYPEDEF: int cairo_content_t
-: CAIRO_CONTENT_COLOR HEX: 1000 ;
-: CAIRO_CONTENT_ALPHA HEX: 2000 ;
-: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
-
-TYPEDEF: void* cairo_write_func_t
-: cairo-write-func ( quot -- callback )
- >r "cairo_status_t" { "void*" "uchar*" "int" }
- "cdecl" r> alien-callback ; inline
-
-TYPEDEF: void* cairo_read_func_t
-: cairo-read-func ( quot -- callback )
- >r "cairo_status_t" { "void*" "uchar*" "int" }
- "cdecl" r> alien-callback ; inline
-
-! Functions for manipulating state objects
-FUNCTION: cairo_t*
-cairo_create ( cairo_surface_t* target ) ;
-
-FUNCTION: cairo_t*
-cairo_reference ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_destroy ( cairo_t* cr ) ;
-
-FUNCTION: uint
-cairo_get_reference_count ( cairo_t* cr ) ;
-
-FUNCTION: void*
-cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_save ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_restore ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_push_group ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pop_group ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_pop_group_to_source ( cairo_t* cr ) ;
-
-! Modify state
-TYPEDEF: int cairo_operator_t
-C-ENUM:
- CAIRO_OPERATOR_CLEAR
-
- CAIRO_OPERATOR_SOURCE
- CAIRO_OPERATOR_OVER
- CAIRO_OPERATOR_IN
- CAIRO_OPERATOR_OUT
- CAIRO_OPERATOR_ATOP
-
- CAIRO_OPERATOR_DEST
- CAIRO_OPERATOR_DEST_OVER
- CAIRO_OPERATOR_DEST_IN
- CAIRO_OPERATOR_DEST_OUT
- CAIRO_OPERATOR_DEST_ATOP
-
- CAIRO_OPERATOR_XOR
- CAIRO_OPERATOR_ADD
- CAIRO_OPERATOR_SATURATE ;
-
-FUNCTION: void
-cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
-
-FUNCTION: void
-cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
-
-FUNCTION: void
-cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
-
-FUNCTION: void
-cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
-
-FUNCTION: void
-cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
-
-FUNCTION: void
-cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
-
-TYPEDEF: int cairo_antialias_t
-C-ENUM:
- CAIRO_ANTIALIAS_DEFAULT
- CAIRO_ANTIALIAS_NONE
- CAIRO_ANTIALIAS_GRAY
- CAIRO_ANTIALIAS_SUBPIXEL ;
-
-FUNCTION: void
-cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
-
-TYPEDEF: int cairo_fill_rule_t
-C-ENUM:
- CAIRO_FILL_RULE_WINDING
- CAIRO_FILL_RULE_EVEN_ODD ;
-
-FUNCTION: void
-cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
-
-FUNCTION: void
-cairo_set_line_width ( cairo_t* cr, double width ) ;
-
-TYPEDEF: int cairo_line_cap_t
-C-ENUM:
- CAIRO_LINE_CAP_BUTT
- CAIRO_LINE_CAP_ROUND
- CAIRO_LINE_CAP_SQUARE ;
-
-FUNCTION: void
-cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
-
-TYPEDEF: int cairo_line_join_t
-C-ENUM:
- CAIRO_LINE_JOIN_MITER
- CAIRO_LINE_JOIN_ROUND
- CAIRO_LINE_JOIN_BEVEL ;
-
-FUNCTION: void
-cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
-
-FUNCTION: void
-cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
-
-FUNCTION: void
-cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
-
-FUNCTION: void
-cairo_translate ( cairo_t* cr, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_scale ( cairo_t* cr, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_rotate ( cairo_t* cr, double angle ) ;
-
-FUNCTION: void
-cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_identity_matrix ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: void
-cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
-
-FUNCTION: void
-cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: void
-cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
-
-! Path creation functions
-FUNCTION: void
-cairo_new_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_move_to ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: void
-cairo_new_sub_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_line_to ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: void
-cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
-
-FUNCTION: void
-cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
-
-FUNCTION: void
-cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
-
-FUNCTION: void
-cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
-
-FUNCTION: void
-cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
-
-FUNCTION: void
-cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
-
-FUNCTION: void
-cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
-
-FUNCTION: void
-cairo_close_path ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-! Painting functions
-FUNCTION: void
-cairo_paint ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
-
-FUNCTION: void
-cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
-
-FUNCTION: void
-cairo_stroke ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_stroke_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_fill ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_fill_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_copy_page ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_show_page ( cairo_t* cr ) ;
-
-! Insideness testing
-FUNCTION: cairo_bool_t
-cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
-
-FUNCTION: cairo_bool_t
-cairo_in_fill ( cairo_t* cr, double x, double y ) ;
-
-! Rectangular extents
-FUNCTION: void
-cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-FUNCTION: void
-cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-! Clipping
-FUNCTION: void
-cairo_reset_clip ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip_preserve ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
-
-C-STRUCT: cairo_rectangle_t
- { "double" "x" }
- { "double" "y" }
- { "double" "width" }
- { "double" "height" } ;
-
-C-STRUCT: cairo_rectangle_list_t
- { "cairo_status_t" "status" }
- { "cairo_rectangle_t*" "rectangles" }
- { "int" "num_rectangles" } ;
-
-FUNCTION: cairo_rectangle_list_t*
-cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
-
-! Font/Text functions
-
-TYPEDEF: void* cairo_scaled_font_t
-
-TYPEDEF: void* cairo_font_face_t
-
-C-STRUCT: cairo_glyph_t
- { "ulong" "index" }
- { "double" "x" }
- { "double" "y" } ;
-
-C-STRUCT: cairo_text_extents_t
- { "double" "x_bearing" }
- { "double" "y_bearing" }
- { "double" "width" }
- { "double" "height" }
- { "double" "x_advance" }
- { "double" "y_advance" } ;
-
-C-STRUCT: cairo_font_extents_t
- { "double" "ascent" }
- { "double" "descent" }
- { "double" "height" }
- { "double" "max_x_advance" }
- { "double" "max_y_advance" } ;
-
-TYPEDEF: int cairo_font_slant_t
-C-ENUM:
- CAIRO_FONT_SLANT_NORMAL
- CAIRO_FONT_SLANT_ITALIC
- CAIRO_FONT_SLANT_OBLIQUE ;
-
-TYPEDEF: int cairo_font_weight_t
-C-ENUM:
- CAIRO_FONT_WEIGHT_NORMAL
- CAIRO_FONT_WEIGHT_BOLD ;
-
-TYPEDEF: int cairo_subpixel_order_t
-C-ENUM:
- CAIRO_SUBPIXEL_ORDER_DEFAULT
- CAIRO_SUBPIXEL_ORDER_RGB
- CAIRO_SUBPIXEL_ORDER_BGR
- CAIRO_SUBPIXEL_ORDER_VRGB
- CAIRO_SUBPIXEL_ORDER_VBGR ;
-
-TYPEDEF: int cairo_hint_style_t
-C-ENUM:
- CAIRO_HINT_STYLE_DEFAULT
- CAIRO_HINT_STYLE_NONE
- CAIRO_HINT_STYLE_SLIGHT
- CAIRO_HINT_STYLE_MEDIUM
- CAIRO_HINT_STYLE_FULL ;
-
-TYPEDEF: int cairo_hint_metrics_t
-C-ENUM:
- CAIRO_HINT_METRICS_DEFAULT
- CAIRO_HINT_METRICS_OFF
- CAIRO_HINT_METRICS_ON ;
-
-TYPEDEF: void* cairo_font_options_t
-
-FUNCTION: cairo_font_options_t*
-cairo_font_options_create ( ) ;
-
-FUNCTION: cairo_font_options_t*
-cairo_font_options_copy ( cairo_font_options_t* original ) ;
-
-FUNCTION: void
-cairo_font_options_destroy ( cairo_font_options_t* options ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_options_status ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
-
-FUNCTION: cairo_bool_t
-cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
-
-FUNCTION: ulong
-cairo_font_options_hash ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
-
-FUNCTION: cairo_antialias_t
-cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
-
-FUNCTION: cairo_subpixel_order_t
-cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
-
-FUNCTION: cairo_hint_style_t
-cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
-
-FUNCTION: cairo_hint_metrics_t
-cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
-
-! This interface is for dealing with text as text, not caring about the
-! font object inside the the cairo_t.
-
-FUNCTION: void
-cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
-
-FUNCTION: void
-cairo_set_font_size ( cairo_t* cr, double size ) ;
-
-FUNCTION: void
-cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
-
-FUNCTION: cairo_font_face_t*
-cairo_get_font_face ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_scaled_font_t*
-cairo_get_scaled_font ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_show_text ( cairo_t* cr, char* utf8 ) ;
-
-FUNCTION: void
-cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
-
-FUNCTION: void
-cairo_text_path ( cairo_t* cr, char* utf8 ) ;
-
-FUNCTION: void
-cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
-
-FUNCTION: void
-cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
-
-! Generic identifier for a font style
-
-FUNCTION: cairo_font_face_t*
-cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: void
-cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: uint
-cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_face_status ( cairo_font_face_t* font_face ) ;
-
-TYPEDEF: int cairo_font_type_t
-C-ENUM:
- CAIRO_FONT_TYPE_TOY
- CAIRO_FONT_TYPE_FT
- CAIRO_FONT_TYPE_WIN32
- CAIRO_FONT_TYPE_QUARTZ ;
-
-FUNCTION: cairo_font_type_t
-cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
-
-FUNCTION: void*
-cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-! Portable interface to general font features.
-
-FUNCTION: cairo_scaled_font_t*
-cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
-
-FUNCTION: cairo_scaled_font_t*
-cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void
-cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: uint
-cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_status_t
-cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: cairo_font_type_t
-cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void*
-cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
-
-FUNCTION: void
-cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
-
-FUNCTION: cairo_font_face_t*
-cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
-
-FUNCTION: void
-cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
-
-! Query functions
-
-FUNCTION: cairo_operator_t
-cairo_get_operator ( cairo_t* cr ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_get_source ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_tolerance ( cairo_t* cr ) ;
-
-FUNCTION: cairo_antialias_t
-cairo_get_antialias ( cairo_t* cr ) ;
-
-FUNCTION: cairo_bool_t
-cairo_has_current_point ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
-
-FUNCTION: cairo_fill_rule_t
-cairo_get_fill_rule ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_line_width ( cairo_t* cr ) ;
-
-FUNCTION: cairo_line_cap_t
-cairo_get_line_cap ( cairo_t* cr ) ;
-
-FUNCTION: cairo_line_join_t
-cairo_get_line_join ( cairo_t* cr ) ;
-
-FUNCTION: double
-cairo_get_miter_limit ( cairo_t* cr ) ;
-
-FUNCTION: int
-cairo_get_dash_count ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
-
-FUNCTION: void
-cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_get_target ( cairo_t* cr ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_get_group_target ( cairo_t* cr ) ;
-
-TYPEDEF: int cairo_path_data_type_t
-C-ENUM:
- CAIRO_PATH_MOVE_TO
- CAIRO_PATH_LINE_TO
- CAIRO_PATH_CURVE_TO
- CAIRO_PATH_CLOSE_PATH ;
-
-! NEED TO DO UNION HERE
-C-STRUCT: cairo_path_data_t-point
- { "double" "x" }
- { "double" "y" } ;
-
-C-STRUCT: cairo_path_data_t-header
- { "cairo_path_data_type_t" "type" }
- { "int" "length" } ;
-
-C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
-
-C-STRUCT: cairo_path_t
- { "cairo_status_t" "status" }
- { "cairo_path_data_t*" "data" }
- { "int" "num_data" } ;
-
-FUNCTION: cairo_path_t*
-cairo_copy_path ( cairo_t* cr ) ;
-
-FUNCTION: cairo_path_t*
-cairo_copy_path_flat ( cairo_t* cr ) ;
-
-FUNCTION: void
-cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
-
-FUNCTION: void
-cairo_path_destroy ( cairo_path_t* path ) ;
-
-! Error status queries
-
-FUNCTION: cairo_status_t
-cairo_status ( cairo_t* cr ) ;
-
-FUNCTION: char*
-cairo_status_to_string ( cairo_status_t status ) ;
-
-! Surface manipulation
-
-FUNCTION: cairo_surface_t*
-cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_surface_reference ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_finish ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_destroy ( cairo_surface_t* surface ) ;
-
-FUNCTION: uint
-cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_status ( cairo_surface_t* surface ) ;
-
-TYPEDEF: int cairo_surface_type_t
-C-ENUM:
- CAIRO_SURFACE_TYPE_IMAGE
- CAIRO_SURFACE_TYPE_PDF
- CAIRO_SURFACE_TYPE_PS
- CAIRO_SURFACE_TYPE_XLIB
- CAIRO_SURFACE_TYPE_XCB
- CAIRO_SURFACE_TYPE_GLITZ
- CAIRO_SURFACE_TYPE_QUARTZ
- CAIRO_SURFACE_TYPE_WIN32
- CAIRO_SURFACE_TYPE_BEOS
- CAIRO_SURFACE_TYPE_DIRECTFB
- CAIRO_SURFACE_TYPE_SVG
- CAIRO_SURFACE_TYPE_OS2
- CAIRO_SURFACE_TYPE_WIN32_PRINTING
- CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
-
-FUNCTION: cairo_surface_type_t
-cairo_surface_get_type ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_content_t
-cairo_surface_get_content ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
-
-FUNCTION: void*
-cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-FUNCTION: void
-cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
-
-FUNCTION: void
-cairo_surface_flush ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
-
-FUNCTION: void
-cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
-
-FUNCTION: void
-cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
-
-FUNCTION: void
-cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
-
-FUNCTION: void
-cairo_surface_copy_page ( cairo_surface_t* surface ) ;
-
-FUNCTION: void
-cairo_surface_show_page ( cairo_surface_t* surface ) ;
-
-! Image-surface functions
-
-TYPEDEF: int cairo_format_t
-C-ENUM:
- CAIRO_FORMAT_ARGB32
- CAIRO_FORMAT_RGB24
- CAIRO_FORMAT_A8
- CAIRO_FORMAT_A1
- CAIRO_FORMAT_RGB16_565 ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
-
-FUNCTION: int
-cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
-
-FUNCTION: uchar*
-cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_format_t
-cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
-
-FUNCTION: int
-cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_from_png ( char* filename ) ;
-
-FUNCTION: cairo_surface_t*
-cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
-
-! Pattern creation functions
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_rgb ( double red, double green, double blue ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
-
-FUNCTION: cairo_pattern_t*
-cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: uint
-cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_status ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void*
-cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
-
-TYPEDEF: int cairo_pattern_type_t
-C-ENUM:
- CAIRO_PATTERN_TYPE_SOLID
- CAIRO_PATTERN_TYPE_SURFACE
- CAIRO_PATTERN_TYPE_LINEAR
- CAIRO_PATTERN_TYPE_RADIA ;
-
-FUNCTION: cairo_pattern_type_t
-cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: void
-cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
-
-FUNCTION: void
-cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
-
-FUNCTION: void
-cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
-
-TYPEDEF: int cairo_extend_t
-C-ENUM:
- CAIRO_EXTEND_NONE
- CAIRO_EXTEND_REPEAT
- CAIRO_EXTEND_REFLECT
- CAIRO_EXTEND_PAD ;
-
-FUNCTION: void
-cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
-
-FUNCTION: cairo_extend_t
-cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
-
-TYPEDEF: int cairo_filter_t
-C-ENUM:
- CAIRO_FILTER_FAST
- CAIRO_FILTER_GOOD
- CAIRO_FILTER_BEST
- CAIRO_FILTER_NEAREST
- CAIRO_FILTER_BILINEAR
- CAIRO_FILTER_GAUSSIAN ;
-
-FUNCTION: void
-cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
-
-FUNCTION: cairo_filter_t
-cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
-
-FUNCTION: cairo_status_t
-cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
-
-! Matrix functions
-
-FUNCTION: void
-cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
-
-FUNCTION: void
-cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
-
-FUNCTION: void
-cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
-
-FUNCTION: void
-cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
-
-FUNCTION: void
-cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
-
-FUNCTION: cairo_status_t
-cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
-
-FUNCTION: void
-cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
-
-FUNCTION: void
-cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
-
-FUNCTION: void
-cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
-
-! Functions to be used while debugging (not intended for use in production code)
-FUNCTION: void
-cairo_debug_reset_static_data ( ) ;
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math opengl.gadgets kernel
-byte-arrays cairo.ffi cairo io.backend
-ui.gadgets accessors opengl.gl
-arrays ;
-
-IN: cairo.gadgets
-
-: width>stride ( width -- stride ) 4 * ;
-
-: copy-cairo ( dim quot -- byte-array )
- >r first2 over width>stride
- [ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
- [ cairo_image_surface_create_for_data ] 3bi
- r> with-cairo-from-surface ; inline
-
-TUPLE: cairo-gadget < texture-gadget dim quot ;
-
-: <cairo-gadget> ( dim quot -- gadget )
- cairo-gadget construct-gadget
- swap >>quot
- swap >>dim ;
-
-M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
-
-: render-cairo ( dim quot -- bytes format )
- >r 2^-bounds r> copy-cairo GL_BGRA ; inline
-
-! M: cairo-gadget render*
-! [ dim>> dup ] [ quot>> ] bi
-! render-cairo render-bytes* ;
-
-! maybe also texture>png
-! : cairo>png ( gadget path -- )
-! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
-! [ height>> ] tri over width>stride
-! cairo_image_surface_create_for_data
-! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
-
-: copy-surface ( surface -- )
- cr swap 0 0 cairo_set_source_surface
- cr cairo_paint ;
-
-TUPLE: png-gadget < texture-gadget path ;
-: <png> ( path -- gadget )
- png-gadget construct-gadget
- swap >>path ;
-
-M: png-gadget render*
- path>> normalize-path cairo_image_surface_create_from_png
- [ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height 2array dup 2^-bounds ]
- [ [ copy-surface ] curry copy-cairo ] tri
- GL_BGRA render-bytes* ;
-
-M: png-gadget cache-key* path>> ;
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis
-! See http://factorcode.org/license.txt for BSD license.
-!
-! these samples are a subset of the samples on
-! http://cairographics.org/samples/
-USING: cairo cairo.ffi locals math.constants math
-io.backend kernel alien.c-types libc namespaces ;
-
-IN: cairo.samples
-
-:: arc ( -- )
- [let | xc [ 128.0 ]
- yc [ 128.0 ]
- radius [ 100.0 ]
- angle1 [ pi 1/4 * ]
- angle2 [ pi ] |
- cr 10.0 cairo_set_line_width
- cr xc yc radius angle1 angle2 cairo_arc
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6.0 cairo_set_line_width
-
- cr xc yc 10.0 0 2 pi * cairo_arc
- cr cairo_fill
-
- cr xc yc radius angle1 angle1 cairo_arc
- cr xc yc cairo_line_to
- cr xc yc radius angle2 angle2 cairo_arc
- cr xc yc cairo_line_to
- cr cairo_stroke
- ] ;
-
-: clip ( -- )
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 0 0 256 256 cairo_rectangle
- cr cairo_fill
- cr 0 1 0 cairo_set_source_rgb
- cr 0 0 cairo_move_to
- cr 256 256 cairo_line_to
- cr 256 0 cairo_move_to
- cr 0 256 cairo_line_to
- cr 10 cairo_set_line_width
- cr cairo_stroke ;
-
-:: clip-image ( -- )
- [let* | png [ "resource:misc/icons/Factor_128x128.png"
- normalize-path cairo_image_surface_create_from_png ]
- w [ png cairo_image_surface_get_width ]
- h [ png cairo_image_surface_get_height ] |
- cr 128 128 76.8 0 2 pi * cairo_arc
- cr cairo_clip
- cr cairo_new_path
-
- cr 192.0 w / 192.0 h / cairo_scale
- cr png 32 32 cairo_set_source_surface
- cr cairo_paint
- png cairo_surface_destroy
- ] ;
-
-:: dash ( -- )
- [let | dashes [ { 50 10 10 10 } >c-double-array ]
- ndash [ 4 ] |
- cr dashes ndash -50 cairo_set_dash
- cr 10 cairo_set_line_width
- cr 128.0 25.6 cairo_move_to
- cr 230.4 230.4 cairo_line_to
- cr -102.4 0 cairo_rel_line_to
- cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
- cr cairo_stroke
- ] ;
-
-:: gradient ( -- )
- [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
- radial [ 115.2 102.4 25.6 102.4 102.4 128.0
- cairo_pattern_create_radial ] |
- pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- cr 0 0 256 256 cairo_rectangle
- cr pat cairo_set_source
- cr cairo_fill
- pat cairo_pattern_destroy
-
- radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
- radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
- cr radial cairo_set_source
- cr 128.0 128.0 76.8 0 2 pi * cairo_arc
- cr cairo_fill
- radial cairo_pattern_destroy
- ] ;
-
-: text ( -- )
- cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
- cairo_select_font_face
- cr 50 cairo_set_font_size
- cr 10 135 cairo_move_to
- cr "Hello" cairo_show_text
-
- cr 70 165 cairo_move_to
- cr "factor" cairo_text_path
- cr 0.5 0.5 1 cairo_set_source_rgb
- cr cairo_fill_preserve
- cr 0 0 0 cairo_set_source_rgb
- cr 2.56 cairo_set_line_width
- cr cairo_stroke
-
- ! draw helping lines
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 10 135 5.12 0 2 pi * cairo_arc
- cr cairo_close_path
- cr 70 165 5.12 0 2 pi * cairo_arc
- cr cairo_fill ;
-
-: utf8 ( -- )
- cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
- cairo_select_font_face
- cr 50 cairo_set_font_size
- "cairo_text_extents_t" malloc-object
- cr "日本語" pick cairo_text_extents
- cr over
- [ cairo_text_extents_t-width 2 / ]
- [ cairo_text_extents_t-x_bearing ] bi +
- 128 swap - pick
- [ cairo_text_extents_t-height 2 / ]
- [ cairo_text_extents_t-y_bearing ] bi +
- 128 swap - cairo_move_to
- free
- cr "日本語" cairo_show_text
-
- cr 1 0.2 0.2 0.6 cairo_set_source_rgba
- cr 6 cairo_set_line_width
- cr 128 0 cairo_move_to
- cr 0 256 cairo_rel_line_to
- cr 0 128 cairo_move_to
- cr 256 0 cairo_rel_line_to
- cr cairo_stroke ;
-
- USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
- : samples ( -- )
- { arc clip clip-image dash gradient text utf8 }
- [ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
-
- MAIN: samples
+++ /dev/null
-Cairo graphics library binding
projects / factor.git / commitdiff